cgen/sem-frags.scm

   1 ; Semantic fragments.
   2 ; Copyright (C) 2000 Red Hat, Inc.
   3 ; This file is part of CGEN.
   4 ; See file COPYING.CGEN for details.
   5
   6 ; Background info:
   7 ; Some improvement in pbb simulator efficiency is obtained in cases like
   8 ; the ARM where for example operand2 computation is expensive in terms of
   9 ; cpu cost, code size, and subroutine call overhead if the code is put in
  10 ; a subroutine.  It could be inlined, but there are numerous occurences
  11 ; resulting in poor icache usage.
  12 ; If the computation is put in its own fragment then code size is reduced
  13 ; [improving icache usage] and subroutine call overhead is removed in a
  14 ; computed-goto simulator [arguments are passed in machine generated local
  15 ; variables].
  16 ;
  17 ; The basic procedure here is to:
  18 ; - break all insns up into a set of statements
  19 ;   This is either one statement in the case of insns that don't begin with a
  20 ;   sequence, or a list of statements, one for each element in the sequence.
  21 ; - find a profitable set of common leading statements (called the "header")
  22 ;   and a profitable set of common trailing statements (called the "trailer")
  23 ;   What is "profitable" depends on
  24 ;   - how expensive the statement is
  25 ;   - how long the statement is
  26 ;   - the number of insns using the statement
  27 ;   - what fraction of the total insn the statement is
  28 ; - rewrite insn semantics in terms of the new header and trailer fragments
  29 ;   plus a "middle" part that is whatever is left over
  30 ;   - there is always a header, the middle and trailer parts are optional
  31 ;   - cti insns require a header and trailer, though they can be the same
  32 ;     fragment
  33 ;
  34 ; TODO:
  35 ; - check ARM orr insns which come out as header, tiny middle, trailer
  36 ;   - the tiny middle seems like a waste (combine with trailer?)
  37 ; - there are 8 trailers consisting of just `nop' for ARM
  38 ; - rearranging statements to increase number and length of common sets
  39 ; - combine common middle fragments
  40 ; - parallel's not handled yet (only have to handle parallel's at the
  41 ;   top level)
  42 ; - insns can also be split on timing-sensitive boundaries (pipeline, memory,
  43 ;   whatever) though that is not implemented yet.  This may involve rtl
  44 ;   additions.
  45 ;
  46 ; Usage:
  47 ; - call sim-sfrag-init! first, to initialize
  48 ; - call sim-sfrag-analyze-insns! to create the semantic fragments
  49 ; - afterwards, call
  50 ;   - sim-sfrag-insn-list
  51 ;   - sim-sfrag-frag-table
  52 ;   - sim-sfrag-usage-table
  53 ;   - sim-sfrag-locals-list
  54 \f
  55 ; Statement computation.
  56
  57 ; Set to #t to collect various statistics.
  58
  59 (define -stmt-stats? #f)
  60
  61 ; Collection of computed stats.  Only set if -stmt-stats? = #t.
  62
  63 (define -stmt-stats #f)
  64
  65 ; Collection of computed statement data.  Only set if -stmt-stats? = #t.
  66
  67 (define -stmt-stats-data #f)
  68
  69 ; Create a structure recording data of all statements.
  70 ; A pair of (next-ordinal . table).
  71
  72 (define (-stmt-data-make hash-size)
  73   (cons 0 (make-vector hash-size nil))
  74 )
  75
  76 ; Accessors.
  77
  78 (define (-stmt-data-table data) (cdr data))
  79 (define (-stmt-data-next-num data) (car data))
  80 (define (-stmt-data-set-next-num! data newval) (set-car! data newval))
  81 (define (-stmt-data-hash-size data) (vector-length (cdr data)))
  82
  83 ; A single statement.
  84 ; INSN semantics either consist of a single statement or a sequence of them.
  85
  86 (define <statement>
  87   (class-make '<statement> nil
  88               '(
  89                 ; RTL code
  90                 expr
  91
  92                 ; Local variables of the sequence `expr' is in.
  93                 locals
  94
  95                 ; Ordinal of the statement.
  96                 num
  97
  98                 ; Costs.
  99                 ; SPEED-COST is the cost of executing fragment, relative to a
 100                 ; simple add.
 101                 ; SIZE-COST is the size of the fragment, relative to a simple
 102                 ; add.
 103                 ; ??? The cost numbers are somewhat arbitrary and subject to
 104                 ; review.
 105                 speed-cost
 106                 size-cost
 107
 108                 ; Users of this statement.
 109                 ; Each element is (owner-number . owner-object),
 110                 ; where owner-number is an index into the initial insn table
 111                 ; (e.g. insn-list arg of sfrag-create-cse-mapping), and
 112                 ; owner-object is the corresponding object.
 113                 users
 114                 )
 115               nil)
 116 )
 117
 118 (define-getters <statement> -stmt (expr locals num speed-cost size-cost users))
 119
 120 (define-setters <statement> -stmt (users))
 121
 122 ; Make a <statement> object of EXPR.
 123 ; LOCALS is a list of local variables of the sequence EXPR is in.
 124 ; NUM is the ordinal of EXPR.
 125 ; SPEED-COST is the cost of executing the statement, relative to a simple add.
 126 ; SIZE-COST is the size of the fragment, relative to a simple add.
 127 ; ??? The cost numbers are somewhat arbitrary and subject to review.
 128 ;
 129 ; The user list is set to nil.
 130
 131 (define (-stmt-make expr locals num speed-cost size-cost)
 132   (make <statement> expr locals num speed-cost size-cost nil)
 133 )
 134
 135 ; Add a user of STMT.
 136
 137 (define (-stmt-add-user! stmt user-num user-obj)
 138   (-stmt-set-users! stmt (cons (cons user-num user-obj) (-stmt-users stmt)))
 139   *UNSPECIFIED*
 140 )
 141
 142 ; Lookup STMT in DATA.
 143 ; CHAIN-NUM is an argument so it need only be computed once.
 144 ; The result is the found <statement> object or #f.
 145
 146 (define (-frag-lookup-stmt data chain-num stmt)
 147   (let ((table (-stmt-data-table data)))
 148     (let loop ((stmts (vector-ref table chain-num)))
 149       (cond ((null? stmts)
 150              #f)
 151             ; ??? equal? should be appropriate rtx-equal?, blah blah blah.
 152             ((equal? (-stmt-expr (car stmts)) stmt)
 153              (car stmts))
 154             (else
 155              (loop (cdr stmts))))))
 156 )
 157
 158 ; Hash a statement.
 159
 160 ; Computed hash value.
 161 ; Global 'cus -frag-hash-compute! is defined globally so we can use
 162 ; /fastcall (FIXME: Need /fastcall to work on non-global procs).
 163
 164 (define -frag-hash-value-tmp 0)
 165
 166 (define (-frag-hash-string str)
 167   (let loop ((chars (map char->integer (string->list str))) (result 0))
 168     (if (null? chars)
 169         result
 170         (loop (cdr chars) (modulo (+ (* result 7) (car chars)) #xfffffff))))
 171 )
 172
 173 (define (-frag-hash-compute! rtx-obj expr mode parent-expr op-pos tstate appstuff)
 174   (let ((h 0))
 175     (case (rtx-name expr)
 176       ((operand)
 177        (set! h (-frag-hash-string (symbol->string (rtx-operand-name expr)))))
 178       ((local)
 179        (set! h (-frag-hash-string (symbol->string (rtx-local-name expr)))))
 180       ((const)
 181        (set! h (rtx-const-value expr)))
 182       (else
 183        (set! h (rtx-num rtx-obj))))
 184     (set! -frag-hash-value-tmp
 185           ; Keep number small.
 186           (modulo (+ (* -frag-hash-value-tmp 3) h op-pos)
 187                   #xfffffff)))
 188
 189   ; #f -> "continue with normal traversing"
 190   #f
 191 )
 192
 193 (define (-frag-hash-stmt stmt locals size)
 194   (set! -frag-hash-value-tmp 0)
 195   (rtx-traverse-with-locals #f #f stmt -frag-hash-compute! locals #f) ; FIXME: (/fastcall-make -frag-hash-compute!))
 196   (modulo -frag-hash-value-tmp size)
 197 )
 198
 199 ; Compute the speed/size costs of a statement.
 200
 201 ; Compute speed/size costs.
 202 ; Global 'cus -frag-cost-compute! is defined globally so we can use
 203 ; /fastcall (FIXME: Need /fastcall to work on non-global procs).
 204
 205 (define -frag-speed-cost-tmp 0)
 206 (define -frag-size-cost-tmp 0)
 207
 208 (define (-frag-cost-compute! rtx-obj expr mode parent-expr op-pos tstate appstuff)
 209   ; FIXME: wip
 210   (let ((speed 0)
 211         (size 0))
 212     (case (rtx-class rtx-obj)
 213       ((ARG)
 214        #f) ; these don't contribute to costs (at least for now)
 215       ((SET)
 216        ; FIXME: speed/size = 0?
 217        (set! speed 1)
 218        (set! size 1))
 219       ((UNARY BINARY TRINARY)
 220        (set! speed 1)
 221        (set! size 1))
 222       ((IF)
 223        (set! speed 2)
 224        (set! size 2))
 225       (else
 226        (set! speed 4)
 227        (set! size 4)))
 228     (set! -frag-speed-cost-tmp (+ -frag-speed-cost-tmp speed))
 229     (set! -frag-size-cost-tmp (+ -frag-size-cost-tmp size)))
 230
 231   ; #f -> "continue with normal traversing"
 232   #f
 233 )
 234
 235 (define (-frag-stmt-cost stmt locals)
 236   (set! -frag-speed-cost-tmp 0)
 237   (set! -frag-size-cost-tmp 0)
 238   (rtx-traverse-with-locals #f #f stmt -frag-cost-compute! locals #f) ; FIXME: (/fastcall-make -frag-cost-compute!))
 239   (cons -frag-speed-cost-tmp -frag-size-cost-tmp)
 240 )
 241
 242 ; Add STMT to statement table DATA.
 243 ; CHAIN-NUM is the chain in the hash table to add STMT to.
 244 ; {SPEED,SIZE}-COST are passed through to -stmt-make.
 245 ; The result is the newly created <statement> object.
 246
 247 (define (-frag-add-stmt! data chain-num stmt locals speed-cost size-cost)
 248   (let ((stmt (-stmt-make stmt locals (-stmt-data-next-num data) speed-cost size-cost))
 249         (table (-stmt-data-table data)))
 250     (vector-set! table chain-num (cons stmt (vector-ref table chain-num)))
 251     (-stmt-data-set-next-num! data (+ 1 (-stmt-data-next-num data)))
 252     stmt)
 253 )
 254
 255 ; Return the locals in EXPR.
 256 ; If a sequence, return locals.
 257 ; Otherwise, return nil.
 258 ; The result is in assq'able form.
 259
 260 (define (-frag-expr-locals expr)
 261   (if (rtx-kind? 'sequence expr)
 262       (rtx-sequence-assq-locals expr)
 263       nil)
 264 )
 265
 266 ; Return the statements in EXPR.
 267 ; If a sequence, return the sequence's expressions.
 268 ; Otherwise, return (list expr).
 269
 270 (define (-frag-expr-stmts expr)
 271   (if (rtx-kind? 'sequence expr)
 272       (rtx-sequence-exprs expr)
 273       (list expr))
 274 )
 275
 276 ; Analyze statement STMT.
 277 ; If STMT is already in STMT-DATA increment its frequency count.
 278 ; Otherwise add it.
 279 ; LOCALS are locals of the sequence STMT is in.
 280 ; USAGE-TABLE is a vector of statement index lists for each expression.
 281 ; USAGE-INDEX is the index of USAGE-TABLE to use.
 282 ; OWNER is the object of the owner of the statement.
 283
 284 (define (-frag-analyze-expr-stmt! locals stmt stmt-data usage-table expr-num owner)
 285   (logit 3 "Analyzing statement: " (rtx-strdump stmt) "\n")
 286   (let* ((chain-num
 287           (-frag-hash-stmt stmt locals (-stmt-data-hash-size stmt-data)))
 288          (stmt-obj (-frag-lookup-stmt stmt-data chain-num stmt)))
 289
 290     (logit 3 "  chain #" chain-num  "\n")
 291
 292     (if (not stmt-obj)
 293         (let* ((costs (-frag-stmt-cost stmt locals))
 294                (speed-cost (car costs))
 295                (size-cost (cdr costs)))
 296           (set! stmt-obj (-frag-add-stmt! stmt-data chain-num stmt locals
 297                                           speed-cost size-cost))
 298           (logit 3 "  new statement, #" (-stmt-num stmt-obj) "\n"))
 299         (logit 3   "  existing statement, #" (-stmt-num stmt-obj) "\n"))
 300
 301     (-stmt-add-user! stmt-obj expr-num owner)
 302
 303     ; If first entry, initialize list, otherwise append to existing list.
 304     (if (null? (vector-ref usage-table expr-num))
 305         (vector-set! usage-table expr-num (list (-stmt-num stmt-obj)))
 306         (append! (vector-ref usage-table expr-num)
 307                  (list (-stmt-num stmt-obj)))))
 308
 309   *UNSPECIFIED*
 310 )
 311
 312 ; Analyze each statement in EXPR and add it to STMT-DATA.
 313 ; OWNER is the object of the owner of the expression.
 314 ; USAGE-TABLE is a vector of statement index lists for each expression.
 315 ; USAGE-INDEX is the index of the USAGE-TABLE entry to use.
 316 ; As each statement's ordinal is computed it is added to the usage list.
 317
 318 (define (-frag-analyze-expr! expr owner stmt-data usage-table usage-index)
 319   (logit 3 "Analyzing " (obj:name owner) ": " (rtx-strdump expr) "\n")
 320   (let ((locals (-frag-expr-locals expr))
 321         (stmt-list (-frag-expr-stmts expr)))
 322     (for-each (lambda (stmt)
 323                 (-frag-analyze-expr-stmt! locals stmt stmt-data
 324                                           usage-table usage-index owner))
 325               stmt-list))
 326   *UNSPECIFIED*
 327 )
 328
 329 ; Compute statement data from EXPRS, a list of expressions.
 330 ; OWNERS is a vector of objects that "own" each corresponding element in EXPRS.
 331 ; The owner is usually an <insn> object.  Actually it'll probably always be
 332 ; an <insn> object but for now I want the disassociation.
 333 ;
 334 ; The result contains:
 335 ; - vector of statement lists of each expression
 336 ;   - each element is (stmt1-index stmt2-index ...) where each stmtN-index is
 337 ;     an index into the statement table
 338 ; - vector of statements (the statement table of the previous item)
 339 ;   - each element is a <statement> object
 340
 341 (define (-frag-compute-statements exprs owners)
 342   (logit 2 "Computing statement table ...\n")
 343   (let* ((num-exprs (length exprs))
 344          (hash-size
 345           ; FIXME: This is just a quick hack to put something down on paper.
 346           ; blah blah blah.  Revisit as necessary.
 347           (cond ((> num-exprs 300) 1019)
 348                 ((> num-exprs 100) 511)
 349                 (else 127))))
 350
 351     (let (; Hash table of expressions.
 352           (stmt-data (-stmt-data-make hash-size))
 353           ; Statement index lists for each expression.
 354           (usage-table (make-vector num-exprs nil)))
 355
 356       ; Scan each expr, filling in stmt-data and usage-table.
 357       (let loop ((exprs exprs) (exprnum 0))
 358         (if (not (null? exprs))
 359             (let ((expr (car exprs))
 360                   (owner (vector-ref owners exprnum)))
 361               (-frag-analyze-expr! expr owner stmt-data usage-table exprnum)
 362               (loop (cdr exprs) (+ exprnum 1)))))
 363
 364       ; Convert statement hash table to vector.
 365       (let ((stmt-hash-table (-stmt-data-table stmt-data))
 366             (end (vector-length (-stmt-data-table stmt-data)))
 367             (stmt-table (make-vector (-stmt-data-next-num stmt-data) #f)))
 368         (let loop ((i 0))
 369           (if (< i end)
 370               (begin
 371                 (map (lambda (stmt)
 372                        (vector-set! stmt-table (-stmt-num stmt) stmt))
 373                      (vector-ref stmt-hash-table i))
 374                 (loop (+ i 1)))))
 375
 376         ; All done.  Compute stats if asked to.
 377         (if -stmt-stats?
 378             (begin
 379               ; See how well the hashing worked.
 380               (set! -stmt-stats-data stmt-data)
 381               (set! -stmt-stats
 382                     (make-vector (vector-length stmt-hash-table) #f))
 383               (let loop ((i 0))
 384                 (if (< i end)
 385                     (begin
 386                       (vector-set! -stmt-stats i
 387                                    (length (vector-ref stmt-hash-table i)))
 388                       (loop (+ i 1)))))))
 389
 390         ; Result.
 391         (cons usage-table stmt-table))))
 392 )
 393 \f
 394 ; Semantic fragment selection.
 395 ;
 396 ; "semantic fragment" is the name assigned to each header/middle/trailer
 397 ; "fragment" as each may consist of more than one statement, though not
 398 ; necessarily all statements of the original sequence.
 399
 400 (define <sfrag>
 401   (class-make '<sfrag> '(<ident>)
 402               '(
 403                 ; List of insn's using this frag.
 404                 users
 405
 406                 ; Ordinal's of each element of `users'.
 407                 user-nums
 408
 409                 ; Semantic format of insns using this fragment.
 410                 sfmt
 411
 412                 ; List of statement numbers that make up `semantics'.
 413                 ; Each element is an index into the stmt-table arg of
 414                 ; -frag-pick-best.
 415                 ; This is #f if the sfrag wasn't derived from some set of
 416                 ; statements.
 417                 stmt-numbers
 418
 419                 ; Raw rtl source of fragment.
 420                 semantics
 421
 422                 ; Compiled source.
 423                 compiled-semantics
 424
 425                 ; Boolean indicating if this frag is for parallel exec support.
 426                 parallel?
 427
 428                 ; Boolean indicating if this is a header frag.
 429                 ; This includes all frags that begin a sequence.
 430                 header?
 431
 432                 ; Boolean indicating if this is a trailer frag.
 433                 ; This includes all frags that end a sequence.
 434                 trailer?
 435                 )
 436               nil)
 437 )
 438
 439 (define-getters <sfrag> sfrag
 440   (users user-nums sfmt stmt-numbers semantics compiled-semantics
 441          parallel? header? trailer?)
 442 )
 443
 444 (define-setters <sfrag> sfrag
 445   (header? trailer?)
 446 )
 447
 448 ; Sorter to merge common fragments together.
 449 ; A and B are lists of statement numbers.
 450
 451 (define (-frag-sort a b)
 452   (cond ((null? a)
 453          (not (null? b)))
 454         ((null? b)
 455          #f)
 456         ((< (car a) (car b))
 457          #t)
 458         ((> (car a) (car b))
 459          #f)
 460         (else ; =
 461          (-frag-sort (cdr a) (cdr b))))
 462 )
 463
 464 ; Return a boolean indicating if L1,L2 match in the first LEN elements.
 465 ; Each element is an integer.
 466
 467 (define (-frag-list-match? l1 l2 len)
 468   (cond ((= len 0)
 469          #t)
 470         ((or (null? l1) (null? l2))
 471          #f)
 472         ((= (car l1) (car l2))
 473          (-frag-list-match? (cdr l1) (cdr l2) (- len 1)))
 474         (else
 475          #f))
 476 )
 477
 478 ; Return the number of expressions that match in the first LEN statements.
 479
 480 (define (-frag-find-matching expr-table indices stmt-list len)
 481   (let loop ((num-exprs 0) (indices indices))
 482     (cond ((null? indices)
 483            num-exprs)
 484           ((-frag-list-match? stmt-list
 485                               (vector-ref expr-table (car indices)) len)
 486            (loop (+ num-exprs 1) (cdr indices)))
 487           (else
 488            num-exprs)))
 489 )
 490
 491 ; Return a boolean indicating if making STMT-LIST a common fragment
 492 ; among several owners is profitable.
 493 ; STMT-LIST is a list of statement numbers, indices into STMT-TABLE.
 494 ; NUM-EXPRS is the number of expressions with STMT-LIST in common.
 495
 496 (define (-frag-merge-profitable? stmt-table stmt-list num-exprs)
 497   ; FIXME: wip
 498   (and (>= num-exprs 2)
 499        (or ; No need to include speed costs yet.
 500            ;(>= (-frag-list-speed-cost stmt-table stmt-list) 10)
 501            (>= (-frag-list-size-cost stmt-table stmt-list) 4)))
 502 )
 503
 504 ; Return the cost of executing STMT-LIST.
 505 ; STMT-LIST is a list of statment numbers, indices into STMT-TABLE.
 506 ;
 507 ; FIXME: The yardstick to use is wip.  Currently we measure things relative
 508 ; to a simple add insn which is given the value 1.
 509
 510 (define (-frag-list-speed-cost stmt-table stmt-list)
 511   ; FIXME: wip
 512   (apply + (map (lambda (stmt-num)
 513                   (-stmt-speed-cost (vector-ref stmt-table stmt-num)))
 514                 stmt-list))
 515 )
 516
 517 (define (-frag-list-size-cost stmt-table stmt-list)
 518   ; FIXME: wip
 519   (apply + (map (lambda (stmt-num)
 520                   (-stmt-size-cost (vector-ref stmt-table stmt-num)))
 521                 stmt-list))
 522 )
 523
 524 ; Compute the longest set of fragments it is desirable/profitable to create.
 525 ; The result is (number-of-matching-exprs . stmt-number-list)
 526 ; or #f if there isn't one (the longest set is the empty set).
 527 ;
 528 ; What is desirable depends on a few things:
 529 ; - how often is it used?
 530 ; - how expensive is it (size-wise and speed-wise)
 531 ; - relationship to other frags
 532 ;
 533 ; STMT-TABLE is a vector of all statements.
 534 ; STMT-USAGE-TABLE is a vector of all expressions.  Each element is a list of
 535 ; statement numbers (indices into STMT-TABLE).
 536 ; INDICES is a sorted list of indices into STMT-USAGE-TABLE.
 537 ; STMT-USAGE-TABLE is processed in the order specified by INDICES.
 538 ;
 539 ; FIXME: Choosing a statement list should depend on whether there are existing
 540 ; chosen statement lists only slightly shorter.
 541
 542 (define (-frag-longest-desired stmt-table stmt-usage-table indices)
 543   ; STMT-LIST is the list of statements in the first expression.
 544   (let ((stmt-list (vector-ref stmt-usage-table (car indices))))
 545
 546     (let loop ((len 1) (prev-num-exprs 0))
 547
 548       ; See how many subsequent expressions match at length LEN.
 549       (let ((num-exprs (-frag-find-matching stmt-usage-table (cdr indices)
 550                                             stmt-list len)))
 551         ; If there aren't any, we're done.
 552         ; If LEN-1 is usable, return that.
 553         ; Otherwise there is no profitable list of fragments.
 554         (if (= num-exprs 0)
 555
 556             (let ((matching-stmt-list (list-take (- len 1) stmt-list)))
 557               (if (-frag-merge-profitable? stmt-table matching-stmt-list
 558                                            prev-num-exprs)
 559                   (cons prev-num-exprs matching-stmt-list)
 560                   #f))
 561
 562             ; Found at least 1 subsequent matching expression.
 563             ; Extend LEN and see if we still find matching expressions.
 564             (loop (+ len 1) num-exprs)))))
 565 )
 566
 567 ; Return list of lists of objects for each unique <sformat-argbuf> in
 568 ; USER-LIST.
 569 ; Each element of USER-LIST is (insn-num . <insn> object).
 570 ; The result is a list of lists.  Each element in the top level list is
 571 ; a list of elements of USER-LIST that have the same <sformat-argbuf>.
 572 ; Insns are also distinguished by being a CTI insn vs a non-CTI insn.
 573 ; CTI insns require special handling in the semantics.
 574
 575 (define (-frag-split-by-sbuf user-list)
 576   ; Sanity check.
 577   (if (not (elm-bound? (cdar user-list) 'sfmt))
 578       (error "sformats not computed"))
 579   (if (not (elm-bound? (insn-sfmt (cdar user-list)) 'sbuf))
 580       (error "sformat argbufs not computed"))
 581
 582   (let ((result nil)
 583         ; Find INSN in SFMT-LIST.  The result is the list INSN belongs in
 584         ; or #f.
 585         (find-obj (lambda (sbuf-list insn)
 586                     (let ((name (obj:name (sfmt-sbuf (insn-sfmt insn)))))
 587                       (let loop ((sbuf-list sbuf-list))
 588                         (cond ((null? sbuf-list)
 589                                #f)
 590                               ((and (eq? name
 591                                          (obj:name (sfmt-sbuf (insn-sfmt (cdaar sbuf-list)))))
 592                                     (eq? (insn-cti? insn)
 593                                          (insn-cti? (cdaar sbuf-list))))
 594                                (car sbuf-list))
 595                               (else
 596                                (loop (cdr sbuf-list))))))))
 597         )
 598     (let loop ((users user-list))
 599       (if (not (null? users))
 600           (let ((try (find-obj result (cdar users))))
 601             (if try
 602                 (append! try (list (car users)))
 603                 (set! result (cons (list (car users)) result)))
 604             (loop (cdr users)))))
 605
 606     ; Done
 607     result)
 608 )
 609
 610 ; Return a list of desired fragments to create.
 611 ; These consist of the longest set of profitable leading statements in EXPRS.
 612 ; Each element of the result is an <sfrag> object.
 613 ;
 614 ; STMT-TABLE is a vector of all statements.
 615 ; STMT-USAGE-TABLE is a vector of statement number lists of each expression.
 616 ; OWNER-TABLE is a vector of owner objects of each corresponding expression
 617 ; in STMT-USAGE-TABLE.
 618 ; KIND is one of 'header or 'trailer.
 619 ;
 620 ; This works for trailing fragments too as we do the computation based on the
 621 ; reversed statement lists.
 622
 623 (define (-frag-compute-desired-frags stmt-table stmt-usage-table owner-table kind)
 624   (logit 2 "Computing desired " kind " frags ...\n")
 625
 626   (let* (
 627          (stmt-usage-list
 628           (if (eq? kind 'header)
 629               (vector->list stmt-usage-table)
 630               (map reverse (vector->list stmt-usage-table))))
 631          ; Sort STMT-USAGE-TABLE.  That will bring exprs with common fragments
 632          ; together.
 633          (sorted-indices (sort-grade stmt-usage-list -frag-sort))
 634          ; List of statement lists that together yield the fragment to create,
 635          ; plus associated users.
 636          (desired-frags nil)
 637          )
 638
 639     ; Update STMT-USAGE-TABLE in case we reversed the contents.
 640     (set! stmt-usage-table (list->vector stmt-usage-list))
 641
 642     (let loop ((indices sorted-indices) (iteration 1))
 643       (logit 3 "Iteration " iteration "\n")
 644       (if (not (null? indices))
 645           (let ((longest (-frag-longest-desired stmt-table stmt-usage-table indices)))
 646
 647             (if longest
 648
 649                 ; Found an acceptable frag to create.
 650                 (let* ((num-exprs (car longest))
 651                        ; Reverse statement numbers back if trailer.
 652                        (stmt-list (if (eq? kind 'header)
 653                                       (cdr longest)
 654                                       (reverse (cdr longest))))
 655                        (picked-indices (list-take num-exprs indices))
 656                        ; Need one copy of the frag for each sbuf, as structure
 657                        ; offsets will be different in generated C/C++ code.
 658                        (sfmt-users (-frag-split-by-sbuf
 659                                     (map (lambda (expr-num)
 660                                            (cons expr-num
 661                                                  (vector-ref owner-table
 662                                                              expr-num)))
 663                                          picked-indices))))
 664
 665                   (logit 3 "Creating frag of length " (length stmt-list) ", " num-exprs " users\n")
 666                   (logit 3 "Indices: " picked-indices "\n")
 667
 668                   ; Create an sfrag for each sbuf.
 669                   (for-each
 670                    (lambda (users)
 671                      (let* ((first-owner (cdar users))
 672                             (sfrag
 673                              (make <sfrag>
 674                                (symbol-append (obj:name first-owner)
 675                                               (if (eq? kind 'header)
 676                                                   '-hdr
 677                                                   '-trlr))
 678                                ""
 679                                atlist-empty
 680                                (map cdr users)
 681                                (map car users)
 682                                (insn-sfmt first-owner)
 683                                stmt-list
 684                                (apply
 685                                 rtx-make
 686                                 (cons 'sequence
 687                                       (cons 'VOID
 688                                             (cons nil
 689                                                   (map (lambda (stmt-num)
 690                                                          (-stmt-expr
 691                                                           (vector-ref stmt-table
 692                                                                       stmt-num)))
 693                                                        stmt-list)))))
 694                                #f ; compiled-semantics
 695                                #f ; parallel?
 696                                (eq? kind 'header)
 697                                (eq? kind 'trailer)
 698                                )))
 699                        (set! desired-frags (cons sfrag desired-frags))))
 700                    sfmt-users)
 701
 702                   ; Continue, dropping statements we've put into the frag.
 703                   (loop (list-drop num-exprs indices) (+ iteration 1)))
 704
 705                 ; Couldn't find an acceptable statement list.
 706                 ; Try again with next one.
 707                 (begin
 708                   (logit 3 "No acceptable frag found.\n")
 709                   (loop (cdr indices) (+ iteration 1)))))))
 710
 711     ; Done.
 712     desired-frags)
 713 )
 714
 715 ; Return the set of desired fragments to create.
 716 ; STMT-TABLE is a vector of each statement.
 717 ; STMT-USAGE-TABLE is a vector of (stmt1-index stmt2-index ...) elements for
 718 ; each expression, where each stmtN-index is an index into STMT-TABLE.
 719 ; OWNER-TABLE is a vector of owner objects of each corresponding expression
 720 ; in STMT-USAGE-TABLE.
 721 ;
 722 ; Each expression is split in up to three pieces: header, middle, trailer.
 723 ; This computes pseudo-optimal headers and trailers (if they exist).
 724 ; The "middle" part is whatever is leftover.
 725 ;
 726 ; The result is a vector of 4 elements:
 727 ; - vector of (header middle trailer) semantic fragments for each expression
 728 ;   - each element is an index into the respective table or #f if not present
 729 ; - list of header fragments, each element is an <sfrag> object
 730 ; - same but for trailer fragments
 731 ; - same but for middle fragments
 732 ;
 733 ; ??? While this is a big function, each piece is simple and straightforward.
 734 ; It's kept as one big function so we can compute each expression's sfrag list
 735 ; as we go.  Though it's not much extra expense to not do this.
 736
 737 (define (-frag-pick-best stmt-table stmt-usage-table owner-table)
 738   (let (
 739         (num-stmts (vector-length stmt-table))
 740         (num-exprs (vector-length stmt-usage-table))
 741         ; FIXME: Shouldn't have to do vector->list.
 742         (stmt-usage-list (vector->list stmt-usage-table))
 743         ; Specify result holders here, simplifies code.
 744         (desired-header-frags #f)
 745         (desired-trailer-frags #f)
 746         (middle-frags #f)
 747         ; Also allocate space for expression sfrag usage table.
 748         ; We compute it as we go to save scanning the header and trailer
 749         ; lists twice.
 750         ; copy-tree is needed to avoid shared storage.
 751         (expr-sfrags (copy-tree (make-vector (vector-length stmt-usage-table)
 752                                              #(#f #f #f))))
 753         )
 754
 755     ; Compute desired headers.
 756     (set! desired-header-frags
 757           (-frag-compute-desired-frags stmt-table stmt-usage-table owner-table
 758                                        'header))
 759
 760     ; Compute the header used by each expression.
 761     (let ((expr-hdrs-v (make-vector num-exprs #f))
 762           (num-hdrs (length desired-header-frags)))
 763       (let loop ((hdrs desired-header-frags) (hdrnum 0))
 764         (if (< hdrnum num-hdrs)
 765             (let ((hdr (car hdrs)))
 766               (for-each (lambda (expr-num)
 767                           (vector-set! (vector-ref expr-sfrags expr-num) 0
 768                                        hdrnum)
 769                           (vector-set! expr-hdrs-v expr-num hdr))
 770                         (sfrag-user-nums hdr))
 771               (loop (cdr hdrs) (+ hdrnum 1)))))
 772
 773       ; Truncate each expression by the header it will use and then find
 774       ; the set of desired trailers.
 775       (let ((expr-hdrs (vector->list expr-hdrs-v)))
 776
 777         (set! desired-trailer-frags
 778               (-frag-compute-desired-frags
 779                stmt-table
 780                ; FIXME: Shouldn't have to use list->vector.
 781                ; [still pass a vector, but use vector-map here instead of map]
 782                (list->vector
 783                 (map (lambda (expr hdr)
 784                        (if hdr
 785                            (list-drop (length (sfrag-stmt-numbers hdr)) expr)
 786                            expr))
 787                      stmt-usage-list expr-hdrs))
 788                owner-table
 789                'trailer))
 790
 791         ; Record the trailer used by each expression.
 792         (let ((expr-trlrs-v (make-vector num-exprs #f))
 793               (num-trlrs (length desired-trailer-frags)))
 794           (let loop ((trlrs desired-trailer-frags) (trlrnum 0))
 795             (if (< trlrnum num-trlrs)
 796                 (let ((trlr (car trlrs)))
 797                   (for-each (lambda (expr-num)
 798                               (vector-set! (vector-ref expr-sfrags expr-num) 2
 799                                            trlrnum)
 800                               (vector-set! expr-trlrs-v expr-num trlr))
 801                             (sfrag-user-nums trlr))
 802                   (loop (cdr trlrs) (+ trlrnum 1)))))
 803
 804           ; We have the desired headers and trailers, now compute the middle
 805           ; part for each expression.  This is just what's left over.
 806           ; ??? We don't try to cse the middle part.  Though we can in the
 807           ; future should it prove useful enough.
 808           (logit 2 "Computing middle frags ...\n")
 809           (let* ((expr-trlrs (vector->list expr-trlrs-v))
 810                  (expr-middle-stmts
 811                   (map (lambda (expr hdr trlr)
 812                          (list-tail-drop
 813                           (if trlr (length (sfrag-stmt-numbers trlr)) 0)
 814                           (list-drop
 815                            (if hdr (length (sfrag-stmt-numbers hdr)) 0)
 816                            expr)))
 817                        stmt-usage-list expr-hdrs expr-trlrs)))
 818
 819             ; Finally, record the middle sfrags used by each expression.
 820             (let loop ((tmp-middle-frags nil)
 821                        (next-middle-frag-num 0)
 822                        (expr-num 0)
 823                        (expr-middle-stmts expr-middle-stmts))
 824
 825               (if (null? expr-middle-stmts)
 826
 827                   ; Done!
 828                   ; [The next statement executed after this is the one at the
 829                   ; end that builds the result.  Maybe it should be built here
 830                   ; and this should be the last statement, but I'm trying this
 831                   ; style out for awhile.]
 832                   (set! middle-frags (reverse! tmp-middle-frags))
 833
 834                   ; Does this expr have a middle sfrag?
 835                   (if (null? (car expr-middle-stmts))
 836                       ; Nope.
 837                       (loop tmp-middle-frags
 838                             next-middle-frag-num
 839                             (+ expr-num 1)
 840                             (cdr expr-middle-stmts))
 841                       ; Yep.
 842                       (let ((owner (vector-ref owner-table expr-num)))
 843                         (vector-set! (vector-ref expr-sfrags expr-num)
 844                                      1 next-middle-frag-num)
 845                         (loop (cons (make <sfrag>
 846                                       (symbol-append (obj:name owner) '-mid)
 847                                       (string-append (obj:comment owner)
 848                                                      ", middle part")
 849                                       (obj-atlist owner)
 850                                       (list owner)
 851                                       (list expr-num)
 852                                       (insn-sfmt owner)
 853                                       (car expr-middle-stmts)
 854                                       (apply
 855                                        rtx-make
 856                                        (cons 'sequence
 857                                              (cons 'VOID
 858                                                    (cons nil
 859                                                          (map (lambda (stmt-num)
 860                                                                 (-stmt-expr
 861                                                                  (vector-ref stmt-table stmt-num)))
 862                                                               (car expr-middle-stmts))))))
 863                                       #f ; compiled-semantics
 864                                       #f ; parallel?
 865                                       #f ; header?
 866                                       #f ; trailer?
 867                                       )
 868                                     tmp-middle-frags)
 869                               (+ next-middle-frag-num 1)
 870                               (+ expr-num 1)
 871                               (cdr expr-middle-stmts))))))))))
 872
 873     ; Result.
 874     (vector expr-sfrags
 875             desired-header-frags
 876             desired-trailer-frags
 877             middle-frags))
 878 )
 879 \f
 880 ; Given a list of expressions, return list of locals in top level sequences.
 881 ; ??? Collisions will be handled by rewriting rtl (renaming locals).
 882 ;
 883 ; This has to be done now as the cse pass must (currently) take into account
 884 ; the rewritten rtl.
 885 ; ??? This can be done later, with an appropriate enhancement to rtx-equal?
 886 ; ??? cse can be improved by ignoring local variable name (of course).
 887
 888 (define (-frag-compute-locals! expr-list)
 889   (logit 2 "Computing common locals ...\n")
 890   (let ((result nil)
 891         (lookup-local (lambda (local local-list)
 892                         (assq (car local) local-list)))
 893         (local-equal? (lambda (l1 l2)
 894                         (and (eq? (car l1) (car l2))
 895                              (mode:eq? (cadr l1) (cadr l2)))))
 896         )
 897     (for-each (lambda (expr)
 898                 (let ((locals (-frag-expr-locals expr)))
 899                   (for-each (lambda (local)
 900                               (let ((entry (lookup-local local result)))
 901                                 (if (and entry
 902                                          (local-equal? local entry))
 903                                     #f ; already present
 904                                     (set! result (cons local result)))))
 905                             locals)))
 906               expr-list)
 907     ; Done.
 908     result)
 909 )
 910 \f
 911 ; Common subexpression computation.
 912
 913 ; Given a list of rtl expressions and their owners, return a pseudo-optimal
 914 ; set of fragments and a usage list for each owner.
 915 ; Common fragments are combined and the original expressions become a sequence
 916 ; of these fragments.  The result is "pseudo-optimal" in the sense that the
 917 ; desired result is somewhat optimal, though no attempt is made at precise
 918 ; optimality.
 919 ;
 920 ; OWNERS is a list of objects that "own" each corresponding element in EXPRS.
 921 ; The owner is usually an <insn> object.  Actually it'll probably always be
 922 ; an <insn> object but for now I want the disassociation.
 923 ;
 924 ; The result is a vector of six elements:
 925 ; - sfrag usage table for each owner #(header middle trailer)
 926 ; - statement table (vector of all statements, made with -stmt-make)
 927 ; - list of sequence locals used by header sfrags
 928 ;   - these locals are defined at the top level so that all fragments have
 929 ;     access to them
 930 ;   - ??? Need to handle collisions among incompatible types.
 931 ; - header sfrags
 932 ; - trailer sfrags
 933 ; - middle sfrags
 934
 935 (define (-sem-find-common-frags-1 exprs owners)
 936   ; Sanity check.
 937   (if (not (elm-bound? (car owners) 'sfmt))
 938       (error "sformats not computed"))
 939
 940   ; A simple procedure that calls, in order:
 941   ; -frag-compute-locals!
 942   ; -frag-compute-statements
 943   ; -frag-pick-best
 944   ; The rest is shuffling of results.
 945
 946   ; Internally it's easier if OWNERS is a vector.
 947   (let ((owners (list->vector owners))
 948         (locals (-frag-compute-locals! exprs)))
 949
 950     ; Collect statement usage data.
 951     (let ((stmt-usage (-frag-compute-statements exprs owners)))
 952       (let ((stmt-usage-table (car stmt-usage))
 953             (stmt-table (cdr stmt-usage)))
 954
 955         ; Compute the frags we want to create.
 956         ; These are in general sequences of statements.
 957         (let ((desired-frags
 958                (-frag-pick-best stmt-table stmt-usage-table owners)))
 959           (let (
 960                 (expr-sfrags (vector-ref desired-frags 0))
 961                 (headers (vector-ref desired-frags 1))
 962                 (trailers (vector-ref desired-frags 2))
 963                 (middles (vector-ref desired-frags 3))
 964                 )
 965             ; Result.
 966             (vector expr-sfrags stmt-table locals
 967                     headers trailers middles))))))
 968 )
 969
 970 ; Cover proc of -sem-find-common-frags-1.
 971 ; See its documentation.
 972
 973 (define (sem-find-common-frags insn-list)
 974   (-sem-find-common-frags-1
 975    (begin
 976      (logit 2 "Simplifying/canonicalizing rtl ...\n")
 977      (map (lambda (insn)
 978             ; Must pass canonicalized and macro-expanded rtl.
 979             (rtx-simplify #f insn (insn-semantics insn)
 980                           (-build-known-values insn)))
 981           insn-list))
 982    insn-list)
 983 )
 984
 985 ; Subroutine of sfrag-create-cse-mapping to compute INSN's fragment list.
 986 ; FRAG-USAGE is a vector of 3 elements: #(header middle trailer).
 987 ; Each element is a fragment number or #f if not present.
 988 ; Numbers in FRAG-USAGE are indices relative to their respective subtables
 989 ; of FRAG-TABLE (which is a vector of all 3 tables concatenated together).
 990 ; NUM-HEADERS,NUM-TRAILERS are used to compute absolute indices.
 991 ;
 992 ; No header may have been created.  This happens when
 993 ; it's not profitable (or possible) to merge this insn's
 994 ; leading statements with other insns.  Ditto for
 995 ; trailer.  However, each cti insn must have a header
 996 ; and a trailer (for pc handling setup and change).
 997 ; Try to use the middle fragment if present.  Otherwise,
 998 ; use the x-header,x-trailer virtual insns.
 999
1000 (define (-sfrag-compute-frag-list! insn frag-usage frag-table num-headers num-trailers x-header-relnum x-trailer-relnum)
1001   ; `(list #f)' is so append! works.  The #f is deleted before returning.
1002   (let ((result (list #f))
1003         (header (vector-ref frag-usage 0))
1004         (middle (and (vector-ref frag-usage 1)
1005                      (+ (vector-ref frag-usage 1)
1006                         num-headers num-trailers)))
1007         (trailer (and (vector-ref frag-usage 2)
1008                       (+ (vector-ref frag-usage 2)
1009                          num-headers)))
1010         (x-header-num x-header-relnum)
1011         (x-trailer-num (+ x-trailer-relnum num-headers))
1012         )
1013
1014     ; cse'd header created?
1015     (if header
1016         ; Yep.
1017         (append! result (list header))
1018         ; Nope.  Use the middle frag if present, otherwise use x-header.
1019         ; Can't use the trailer fragment because by definition it is shared
1020         ; among several insns.
1021         (if middle
1022             ; Mark the middle frag as the header frag.
1023             (sfrag-set-header?! (vector-ref frag-table middle) #t)
1024             ; No middle, use x-header.
1025             (append! result (list x-header-num))))
1026
1027     ; middle fragment present?
1028     (if middle
1029         (append! result (list middle)))
1030
1031     ; cse'd trailer created?
1032     (if trailer
1033         ; Yep.
1034         (append! result (list trailer))
1035         ; Nope.  Use the middle frag if present, otherwise use x-trailer.
1036         ; Can't use the header fragment because by definition it is shared
1037         ; among several insns.
1038         (if middle
1039             ; Mark the middle frag as the trailer frag.
1040             (sfrag-set-trailer?! (vector-ref frag-table middle) #t)
1041             ; No middle, use x-trailer.
1042             (append! result (list x-trailer-num))))
1043
1044     ; Done.
1045     (cdr result))
1046 )
1047
1048 ; Subroutine of sfrag-create-cse-mapping to find the fragment number of the
1049 ; x-header/x-trailer virtual frags.
1050
1051 (define (-frag-lookup-virtual frag-list name)
1052   (let loop ((i 0) (frag-list frag-list))
1053     (if (null? frag-list)
1054         (assert (not "expected virtual insn not present"))
1055         (if (eq? name (obj:name (car frag-list)))
1056             i
1057             (loop (+ i 1) (cdr frag-list)))))
1058 )
1059
1060 ; Handle complex case, find set of common header and trailer fragments.
1061 ; The result is a vector of:
1062 ; - fragment table (a vector)
1063 ; - table mapping used fragments for each insn (a list)
1064 ; - locals list
1065
1066 (define (sfrag-create-cse-mapping insn-list)
1067   (logit 1 "Creating semantic fragments for pbb engine ...\n")
1068
1069   (let ((cse-data (sem-find-common-frags insn-list)))
1070
1071     ; Extract the results of sem-find-common-frags.
1072     (let ((sfrag-usage-table (vector-ref cse-data 0))
1073           (stmt-table (vector-ref cse-data 1))
1074           (locals-list (vector-ref cse-data 2))
1075           (header-list1 (vector-ref cse-data 3))
1076           (trailer-list1 (vector-ref cse-data 4))
1077           (middle-list (vector-ref cse-data 5)))
1078
1079       ; Create two special frags: x-header, x-trailer.
1080       ; These are used by insns that don't have one or the other.
1081       ; Header/trailer table indices are already computed for each insn
1082       ; so append x-header/x-trailer to the end.
1083       (let ((header-list
1084              (append header-list1
1085                      (list
1086                       (make <sfrag>
1087                         'x-header
1088                         "header fragment for insns without one"
1089                         (atlist-parse '(VIRTUAL) "" "semantic frag computation")
1090                         nil ; users
1091                         nil ; user ordinals
1092                         (insn-sfmt (current-insn-lookup 'x-before))
1093                         #f ; stmt-numbers
1094                         (rtx-make 'nop)
1095                         #f ; compiled-semantics
1096                         #f ; parallel?
1097                         #t ; header?
1098                         #f ; trailer?
1099                         ))))
1100             (trailer-list
1101              (append trailer-list1
1102                      (list
1103                       (make <sfrag>
1104                         'x-trailer
1105                         "trailer fragment for insns without one"
1106                         (atlist-parse '(VIRTUAL) "" "semantic frag computation")
1107                         nil ; users
1108                         nil ; user ordinals
1109                         (insn-sfmt (current-insn-lookup 'x-before))
1110                         #f ; stmt-numbers
1111                         (rtx-make 'nop)
1112                         #f ; compiled-semantics
1113                         #f ; parallel?
1114                         #f ; header?
1115                         #t ; trailer?
1116                         )))))
1117
1118         (let ((num-headers (length header-list))
1119               (num-trailers (length trailer-list))
1120               (num-middles (length middle-list)))
1121
1122           ; Combine the three sfrag tables (headers, trailers, middles) into
1123           ; one big one.
1124           (let ((frag-table (list->vector (append header-list
1125                                                   trailer-list
1126                                                   middle-list)))
1127                 (x-header-relnum (-frag-lookup-virtual header-list 'x-header))
1128                 (x-trailer-relnum (-frag-lookup-virtual trailer-list 'x-trailer))
1129                 )
1130             ; Convert sfrag-usage-table to one that refers to the one big
1131             ; sfrag table.
1132             (logit 2 "Computing insn frag usage ...\n")
1133             (let ((insn-frags
1134                    (map (lambda (insn frag-usage)
1135                           (-sfrag-compute-frag-list! insn frag-usage
1136                                                      frag-table
1137                                                      num-headers num-trailers
1138                                                      x-header-relnum
1139                                                      x-trailer-relnum))
1140                         insn-list
1141                         ; FIXME: vector->list
1142                         (vector->list sfrag-usage-table)))
1143                   )
1144               (logit 1 "Done fragment creation.\n")
1145               (vector frag-table insn-frags locals-list)))))))
1146 )
1147 \f
1148 ; Data analysis interface.
1149
1150 (define -sim-sfrag-init? #f)
1151 (define (sim-sfrag-init?) -sim-sfrag-init?)
1152
1153 ; Keep in globals for now, simplifies debugging.
1154 ; evil globals, blah blah blah.
1155 (define -sim-sfrag-insn-list #f)
1156 (define -sim-sfrag-frag-table #f)
1157 (define -sim-sfrag-usage-table #f)
1158 (define -sim-sfrag-locals-list #f)
1159
1160 (define (sim-sfrag-insn-list)
1161   (assert -sim-sfrag-init?)
1162   -sim-sfrag-insn-list
1163 )
1164 (define (sim-sfrag-frag-table)
1165   (assert -sim-sfrag-init?)
1166   -sim-sfrag-frag-table
1167 )
1168 (define (sim-sfrag-usage-table)
1169   (assert -sim-sfrag-init?)
1170   -sim-sfrag-usage-table
1171 )
1172 (define (sim-sfrag-locals-list)
1173   (assert -sim-sfrag-init?)
1174   -sim-sfrag-locals-list
1175 )
1176
1177 (define (sim-sfrag-init!)
1178   (set! -sim-sfrag-init? #f)
1179   (set! -sim-sfrag-insn-list #f)
1180   (set! -sim-sfrag-frag-table #f)
1181   (set! -sim-sfrag-usage-table #f)
1182   (set! -sim-sfrag-locals-list #f)
1183 )
1184
1185 (define (sim-sfrag-analyze-insns!)
1186   (if (not -sim-sfrag-init?)
1187       (begin
1188         (set! -sim-sfrag-insn-list (non-multi-insns (non-alias-insns (current-insn-list))))
1189         (let ((frag-data (sfrag-create-cse-mapping -sim-sfrag-insn-list)))
1190           (set! -sim-sfrag-frag-table (vector-ref frag-data 0))
1191           (set! -sim-sfrag-usage-table (vector-ref frag-data 1))
1192           (set! -sim-sfrag-locals-list (vector-ref frag-data 2)))
1193         (set! -sim-sfrag-init? #t)))
1194
1195   *UNSPECIFIED*
1196 )
1197 \f
1198 ; Testing support.
1199
1200 (define (-frag-small-test-data)
1201   '(
1202     (a . (sequence VOID ((SI tmp)) (set DFLT tmp rm) (set DFLT rd rm)))
1203     (b . (sequence VOID ((SI tmp)) (set DFLT tmp rm) (set DFLT rd rm)))
1204     (c . (set DFLT rd rm))
1205     )
1206 )
1207
1208 (define (-frag-test-data)
1209   (cons
1210    (map (lambda (insn)
1211           ; Must pass canonicalized and macro-expanded rtl.
1212           (rtx-simplify #f insn (insn-semantics insn)
1213                         (-build-known-values insn)))
1214         (non-multi-insns (non-alias-insns (current-insn-list))))
1215    (non-multi-insns (non-alias-insns (current-insn-list))))
1216 )
1217
1218 (define test-sfrag-table #f)
1219 (define test-stmt-table #f)
1220 (define test-locals-list #f)
1221 (define test-header-list #f)
1222 (define test-trailer-list #f)
1223 (define test-middle-list #f)
1224
1225 (define (frag-test-run)
1226   (let* ((test-data (-frag-test-data))
1227          (frag-data (sem-find-common-frags (car test-data) (cdr test-data))))
1228     (set! test-sfrag-table (vector-ref frag-data 0))
1229     (set! test-stmt-table (vector-ref frag-data 1))
1230     (set! test-locals-list (vector-ref frag-data 2))
1231     (set! test-header-list (vector-ref frag-data 3))
1232     (set! test-trailer-list (vector-ref frag-data 4))
1233     (set! test-middle-list (vector-ref frag-data 5))
1234     )
1235   *UNSPECIFIED*
1236 )