cgen/sem-frags.scm

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