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 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)
 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 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 COMPARE)
 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)
 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                 ; rtl source of fragment.
 437                 semantics
 438
 439                 ; Boolean indicating if this frag is for parallel exec support.
 440                 parallel?
 441
 442                 ; Boolean indicating if this is a header frag.
 443                 ; This includes all frags that begin a sequence.
 444                 header?
 445
 446                 ; Boolean indicating if this is a trailer frag.
 447                 ; This includes all frags that end a sequence.
 448                 trailer?
 449                 )
 450               nil)
 451 )
 452
 453 (define-getters <sfrag> sfrag
 454   (users user-nums sfmt stmt-numbers semantics
 455          parallel? header? trailer?)
 456 )
 457
 458 (define-setters <sfrag> sfrag
 459   (header? trailer?)
 460 )
 461
 462 ; Sorter to merge common fragments together.
 463 ; A and B are lists of statement numbers.
 464
 465 (define (/frag-sort a b)
 466   (cond ((null? a)
 467          (not (null? b)))
 468         ((null? b)
 469          #f)
 470         ((< (car a) (car b))
 471          #t)
 472         ((> (car a) (car b))
 473          #f)
 474         (else ; =
 475          (/frag-sort (cdr a) (cdr b))))
 476 )
 477
 478 ; Return a boolean indicating if L1,L2 match in the first LEN elements.
 479 ; Each element is an integer.
 480
 481 (define (/frag-list-match? l1 l2 len)
 482   (cond ((= len 0)
 483          #t)
 484         ((or (null? l1) (null? l2))
 485          #f)
 486         ((= (car l1) (car l2))
 487          (/frag-list-match? (cdr l1) (cdr l2) (- len 1)))
 488         (else
 489          #f))
 490 )
 491
 492 ; Return the number of expressions that match in the first LEN statements.
 493
 494 (define (/frag-find-matching expr-table indices stmt-list len)
 495   (let loop ((num-exprs 0) (indices indices))
 496     (cond ((null? indices)
 497            num-exprs)
 498           ((/frag-list-match? stmt-list
 499                               (vector-ref expr-table (car indices)) len)
 500            (loop (+ num-exprs 1) (cdr indices)))
 501           (else
 502            num-exprs)))
 503 )
 504
 505 ; Return a boolean indicating if making STMT-LIST a common fragment
 506 ; among several owners is profitable.
 507 ; STMT-LIST is a list of statement numbers, indices into STMT-TABLE.
 508 ; NUM-EXPRS is the number of expressions with STMT-LIST in common.
 509
 510 (define (/frag-merge-profitable? stmt-table stmt-list num-exprs)
 511   ; FIXME: wip
 512   (and (>= num-exprs 2)
 513        (or ; No need to include speed costs yet.
 514            ;(>= (/frag-list-speed-cost stmt-table stmt-list) 10)
 515            (>= (/frag-list-size-cost stmt-table stmt-list) 4)))
 516 )
 517
 518 ; Return the cost of executing STMT-LIST.
 519 ; STMT-LIST is a list of statment numbers, indices into STMT-TABLE.
 520 ;
 521 ; FIXME: The yardstick to use is wip.  Currently we measure things relative
 522 ; to a simple add insn which is given the value 1.
 523
 524 (define (/frag-list-speed-cost stmt-table stmt-list)
 525   ; FIXME: wip
 526   (apply + (map (lambda (stmt-num)
 527                   (-stmt-speed-cost (vector-ref stmt-table stmt-num)))
 528                 stmt-list))
 529 )
 530
 531 (define (/frag-list-size-cost stmt-table stmt-list)
 532   ; FIXME: wip
 533   (apply + (map (lambda (stmt-num)
 534                   (-stmt-size-cost (vector-ref stmt-table stmt-num)))
 535                 stmt-list))
 536 )
 537
 538 ; Compute the longest set of fragments it is desirable/profitable to create.
 539 ; The result is (number-of-matching-exprs . stmt-number-list)
 540 ; or #f if there isn't one (the longest set is the empty set).
 541 ;
 542 ; What is desirable depends on a few things:
 543 ; - how often is it used?
 544 ; - how expensive is it (size-wise and speed-wise)
 545 ; - relationship to other frags
 546 ;
 547 ; STMT-TABLE is a vector of all statements.
 548 ; STMT-USAGE-TABLE is a vector of all expressions.  Each element is a list of
 549 ; statement numbers (indices into STMT-TABLE).
 550 ; INDICES is a sorted list of indices into STMT-USAGE-TABLE.
 551 ; STMT-USAGE-TABLE is processed in the order specified by INDICES.
 552 ;
 553 ; FIXME: Choosing a statement list should depend on whether there are existing
 554 ; chosen statement lists only slightly shorter.
 555
 556 (define (/frag-longest-desired stmt-table stmt-usage-table indices)
 557   ; STMT-LIST is the list of statements in the first expression.
 558   (let ((stmt-list (vector-ref stmt-usage-table (car indices))))
 559
 560     (let loop ((len 1) (prev-num-exprs 0))
 561
 562       ; See how many subsequent expressions match at length LEN.
 563       (let ((num-exprs (/frag-find-matching stmt-usage-table (cdr indices)
 564                                             stmt-list len)))
 565         ; If there aren't any, we're done.
 566         ; If LEN-1 is usable, return that.
 567         ; Otherwise there is no profitable list of fragments.
 568         (if (= num-exprs 0)
 569
 570             (let ((matching-stmt-list (list-take (- len 1) stmt-list)))
 571               (if (/frag-merge-profitable? stmt-table matching-stmt-list
 572                                            prev-num-exprs)
 573                   (cons prev-num-exprs matching-stmt-list)
 574                   #f))
 575
 576             ; Found at least 1 subsequent matching expression.
 577             ; Extend LEN and see if we still find matching expressions.
 578             (loop (+ len 1) num-exprs)))))
 579 )
 580
 581 ; Return list of lists of objects for each unique <sformat-argbuf> in
 582 ; USER-LIST.
 583 ; Each element of USER-LIST is (insn-num . <insn> object).
 584 ; The result is a list of lists.  Each element in the top level list is
 585 ; a list of elements of USER-LIST that have the same <sformat-argbuf>.
 586 ; Insns are also distinguished by being a CTI insn vs a non-CTI insn.
 587 ; CTI insns require special handling in the semantics.
 588
 589 (define (/frag-split-by-sbuf user-list)
 590   ; Sanity check.
 591   (if (not (elm-bound? (cdar user-list) 'sfmt))
 592       (error "sformats not computed"))
 593   (if (not (elm-bound? (insn-sfmt (cdar user-list)) 'sbuf))
 594       (error "sformat argbufs not computed"))
 595
 596   (let ((result nil)
 597         ; Find INSN in SFMT-LIST.  The result is the list INSN belongs in
 598         ; or #f.
 599         (find-obj (lambda (sbuf-list insn)
 600                     (let ((name (obj:name (sfmt-sbuf (insn-sfmt insn)))))
 601                       (let loop ((sbuf-list sbuf-list))
 602                         (cond ((null? sbuf-list)
 603                                #f)
 604                               ((and (eq? name
 605                                          (obj:name (sfmt-sbuf (insn-sfmt (cdaar sbuf-list)))))
 606                                     (eq? (insn-cti? insn)
 607                                          (insn-cti? (cdaar sbuf-list))))
 608                                (car sbuf-list))
 609                               (else
 610                                (loop (cdr sbuf-list))))))))
 611         )
 612     (let loop ((users user-list))
 613       (if (not (null? users))
 614           (let ((try (find-obj result (cdar users))))
 615             (if try
 616                 (append! try (list (car users)))
 617                 (set! result (cons (list (car users)) result)))
 618             (loop (cdr users)))))
 619
 620     ; Done
 621     result)
 622 )
 623
 624 ; Return a list of desired fragments to create.
 625 ; These consist of the longest set of profitable leading statements in EXPRS.
 626 ; Each element of the result is an <sfrag> object.
 627 ;
 628 ; STMT-TABLE is a vector of all statements.
 629 ; STMT-USAGE-TABLE is a vector of statement number lists of each expression.
 630 ; OWNER-TABLE is a vector of owner objects of each corresponding expression
 631 ; in STMT-USAGE-TABLE.
 632 ; KIND is one of 'header or 'trailer.
 633 ;
 634 ; This works for trailing fragments too as we do the computation based on the
 635 ; reversed statement lists.
 636
 637 (define (/frag-compute-desired-frags stmt-table stmt-usage-table owner-table kind)
 638   (logit 2 "Computing desired " kind " frags ...\n")
 639
 640   (let* (
 641          (stmt-usage-list
 642           (if (eq? kind 'header)
 643               (vector->list stmt-usage-table)
 644               (map reverse (vector->list stmt-usage-table))))
 645          ; Sort STMT-USAGE-TABLE.  That will bring exprs with common fragments
 646          ; together.
 647          (sorted-indices (sort-grade stmt-usage-list /frag-sort))
 648          ; List of statement lists that together yield the fragment to create,
 649          ; plus associated users.
 650          (desired-frags nil)
 651          )
 652
 653     ; Update STMT-USAGE-TABLE in case we reversed the contents.
 654     (set! stmt-usage-table (list->vector stmt-usage-list))
 655
 656     (let loop ((indices sorted-indices) (iteration 1))
 657       (logit 3 "Iteration " iteration "\n")
 658       (if (not (null? indices))
 659           (let ((longest (/frag-longest-desired stmt-table stmt-usage-table indices)))
 660
 661             (if longest
 662
 663                 ; Found an acceptable frag to create.
 664                 (let* ((num-exprs (car longest))
 665                        ; Reverse statement numbers back if trailer.
 666                        (stmt-list (if (eq? kind 'header)
 667                                       (cdr longest)
 668                                       (reverse (cdr longest))))
 669                        (picked-indices (list-take num-exprs indices))
 670                        ; Need one copy of the frag for each sbuf, as structure
 671                        ; offsets will be different in generated C/C++ code.
 672                        (sfmt-users (/frag-split-by-sbuf
 673                                     (map (lambda (expr-num)
 674                                            (cons expr-num
 675                                                  (vector-ref owner-table
 676                                                              expr-num)))
 677                                          picked-indices))))
 678
 679                   (logit 3 "Creating frag of length " (length stmt-list) ", " num-exprs " users\n")
 680                   (logit 3 "Indices: " picked-indices "\n")
 681
 682                   ; Create an sfrag for each sbuf.
 683                   (for-each
 684                    (lambda (users)
 685                      (let* ((first-owner (cdar users))
 686                             (context (make-obj-context first-owner "While building sfrags"))
 687                             (rtl (apply
 688                                   rtx-make
 689                                   (cons 'sequence
 690                                         (cons 'VOID
 691                                               (cons nil
 692                                                     (map (lambda (stmt-num)
 693                                                            (-stmt-expr
 694                                                             (vector-ref stmt-table
 695                                                                         stmt-num)))
 696                                                          stmt-list))))))
 697                             (sfrag
 698                              (make <sfrag>
 699                                (symbol-append (obj:name first-owner)
 700                                               (if (eq? kind 'header)
 701                                                   '-hdr
 702                                                   '-trlr))
 703                                ""
 704                                atlist-empty
 705                                (map cdr users)
 706                                (map car users)
 707                                (insn-sfmt first-owner)
 708                                stmt-list
 709                                rtl
 710                                #f ; parallel?
 711                                (eq? kind 'header)
 712                                (eq? kind 'trailer)
 713                                )))
 714                        (set! desired-frags (cons sfrag desired-frags))))
 715                    sfmt-users)
 716
 717                   ; Continue, dropping statements we've put into the frag.
 718                   (loop (list-drop num-exprs indices) (+ iteration 1)))
 719
 720                 ; Couldn't find an acceptable statement list.
 721                 ; Try again with next one.
 722                 (begin
 723                   (logit 3 "No acceptable frag found.\n")
 724                   (loop (cdr indices) (+ iteration 1)))))))
 725
 726     ; Done.
 727     desired-frags)
 728 )
 729
 730 ; Return the set of desired fragments to create.
 731 ; STMT-TABLE is a vector of each statement.
 732 ; STMT-USAGE-TABLE is a vector of (stmt1-index stmt2-index ...) elements for
 733 ; each expression, where each stmtN-index is an index into STMT-TABLE.
 734 ; OWNER-TABLE is a vector of owner objects of each corresponding expression
 735 ; in STMT-USAGE-TABLE.
 736 ;
 737 ; Each expression is split in up to three pieces: header, middle, trailer.
 738 ; This computes pseudo-optimal headers and trailers (if they exist).
 739 ; The "middle" part is whatever is leftover.
 740 ;
 741 ; The result is a vector of 4 elements:
 742 ; - vector of (header middle trailer) semantic fragments for each expression
 743 ;   - each element is an index into the respective table or #f if not present
 744 ; - list of header fragments, each element is an <sfrag> object
 745 ; - same but for trailer fragments
 746 ; - same but for middle fragments
 747 ;
 748 ; ??? While this is a big function, each piece is simple and straightforward.
 749 ; It's kept as one big function so we can compute each expression's sfrag list
 750 ; as we go.  Though it's not much extra expense to not do this.
 751
 752 (define (/frag-pick-best stmt-table stmt-usage-table owner-table)
 753   (let (
 754         (num-stmts (vector-length stmt-table))
 755         (num-exprs (vector-length stmt-usage-table))
 756         ; FIXME: Shouldn't have to do vector->list.
 757         (stmt-usage-list (vector->list stmt-usage-table))
 758         ; Specify result holders here, simplifies code.
 759         (desired-header-frags #f)
 760         (desired-trailer-frags #f)
 761         (middle-frags #f)
 762         ; Also allocate space for expression sfrag usage table.
 763         ; We compute it as we go to save scanning the header and trailer
 764         ; lists twice.
 765         ; copy-tree is needed to avoid shared storage.
 766         (expr-sfrags (copy-tree (make-vector (vector-length stmt-usage-table)
 767                                              #(#f #f #f))))
 768         )
 769
 770     ; Compute desired headers.
 771     (set! desired-header-frags
 772           (/frag-compute-desired-frags stmt-table stmt-usage-table owner-table
 773                                        'header))
 774
 775     ; Compute the header used by each expression.
 776     (let ((expr-hdrs-v (make-vector num-exprs #f))
 777           (num-hdrs (length desired-header-frags)))
 778       (let loop ((hdrs desired-header-frags) (hdrnum 0))
 779         (if (< hdrnum num-hdrs)
 780             (let ((hdr (car hdrs)))
 781               (for-each (lambda (expr-num)
 782                           (vector-set! (vector-ref expr-sfrags expr-num) 0
 783                                        hdrnum)
 784                           (vector-set! expr-hdrs-v expr-num hdr))
 785                         (sfrag-user-nums hdr))
 786               (loop (cdr hdrs) (+ hdrnum 1)))))
 787
 788       ; Truncate each expression by the header it will use and then find
 789       ; the set of desired trailers.
 790       (let ((expr-hdrs (vector->list expr-hdrs-v)))
 791
 792         (set! desired-trailer-frags
 793               (/frag-compute-desired-frags
 794                stmt-table
 795                ; FIXME: Shouldn't have to use list->vector.
 796                ; [still pass a vector, but use vector-map here instead of map]
 797                (list->vector
 798                 (map (lambda (expr hdr)
 799                        (if hdr
 800                            (list-drop (length (sfrag-stmt-numbers hdr)) expr)
 801                            expr))
 802                      stmt-usage-list expr-hdrs))
 803                owner-table
 804                'trailer))
 805
 806         ; Record the trailer used by each expression.
 807         (let ((expr-trlrs-v (make-vector num-exprs #f))
 808               (num-trlrs (length desired-trailer-frags)))
 809           (let loop ((trlrs desired-trailer-frags) (trlrnum 0))
 810             (if (< trlrnum num-trlrs)
 811                 (let ((trlr (car trlrs)))
 812                   (for-each (lambda (expr-num)
 813                               (vector-set! (vector-ref expr-sfrags expr-num) 2
 814                                            trlrnum)
 815                               (vector-set! expr-trlrs-v expr-num trlr))
 816                             (sfrag-user-nums trlr))
 817                   (loop (cdr trlrs) (+ trlrnum 1)))))
 818
 819           ; We have the desired headers and trailers, now compute the middle
 820           ; part for each expression.  This is just what's left over.
 821           ; ??? We don't try to cse the middle part.  Though we can in the
 822           ; future should it prove useful enough.
 823           (logit 2 "Computing middle frags ...\n")
 824           (let* ((expr-trlrs (vector->list expr-trlrs-v))
 825                  (expr-middle-stmts
 826                   (map (lambda (expr hdr trlr)
 827                          (list-tail-drop
 828                           (if trlr (length (sfrag-stmt-numbers trlr)) 0)
 829                           (list-drop
 830                            (if hdr (length (sfrag-stmt-numbers hdr)) 0)
 831                            expr)))
 832                        stmt-usage-list expr-hdrs expr-trlrs)))
 833
 834             ; Finally, record the middle sfrags used by each expression.
 835             (let loop ((tmp-middle-frags nil)
 836                        (next-middle-frag-num 0)
 837                        (expr-num 0)
 838                        (expr-middle-stmts expr-middle-stmts))
 839
 840               (if (null? expr-middle-stmts)
 841
 842                   ; Done!
 843                   ; [The next statement executed after this is the one at the
 844                   ; end that builds the result.  Maybe it should be built here
 845                   ; and this should be the last statement, but I'm trying this
 846                   ; style out for awhile.]
 847                   (set! middle-frags (reverse! tmp-middle-frags))
 848
 849                   ; Does this expr have a middle sfrag?
 850                   (if (null? (car expr-middle-stmts))
 851                       ; Nope.
 852                       (loop tmp-middle-frags
 853                             next-middle-frag-num
 854                             (+ expr-num 1)
 855                             (cdr expr-middle-stmts))
 856                       ; Yep.
 857                       (let* ((owner (vector-ref owner-table expr-num))
 858                              (context (make-obj-context owner "While building sfrags"))
 859                              (rtl (apply
 860                                    rtx-make
 861                                    (cons 'sequence
 862                                          (cons 'VOID
 863                                                (cons nil
 864                                                      (map (lambda (stmt-num)
 865                                                             (-stmt-expr
 866                                                              (vector-ref stmt-table stmt-num)))
 867                                                           (car expr-middle-stmts))))))))
 868                         (vector-set! (vector-ref expr-sfrags expr-num)
 869                                      1 next-middle-frag-num)
 870                         (loop (cons (make <sfrag>
 871                                       (symbol-append (obj:name owner) '-mid)
 872                                       (string-append (obj:comment owner)
 873                                                      ", middle part")
 874                                       (obj-atlist owner)
 875                                       (list owner)
 876                                       (list expr-num)
 877                                       (insn-sfmt owner)
 878                                       (car expr-middle-stmts)
 879                                       rtl
 880                                       #f ; parallel?
 881                                       #f ; header?
 882                                       #f ; trailer?
 883                                       )
 884                                     tmp-middle-frags)
 885                               (+ next-middle-frag-num 1)
 886                               (+ expr-num 1)
 887                               (cdr expr-middle-stmts))))))))))
 888
 889     ; Result.
 890     (vector expr-sfrags
 891             desired-header-frags
 892             desired-trailer-frags
 893             middle-frags))
 894 )
 895 \f
 896 ; Given a list of expressions, return list of locals in top level sequences.
 897 ; ??? Collisions will be handled by rewriting rtl (renaming locals).
 898 ;
 899 ; This has to be done now as the cse pass must (currently) take into account
 900 ; the rewritten rtl.
 901 ; ??? This can be done later, with an appropriate enhancement to rtx-equal?
 902 ; ??? cse can be improved by ignoring local variable name (of course).
 903
 904 (define (/frag-compute-locals! expr-list)
 905   (logit 2 "Computing common locals ...\n")
 906   (let ((result nil)
 907         (lookup-local (lambda (local local-list)
 908                         (assq (car local) local-list)))
 909         (local-equal? (lambda (l1 l2)
 910                         (and (eq? (car l1) (car l2))
 911                              (mode:eq? (cadr l1) (cadr l2)))))
 912         )
 913     (for-each (lambda (expr)
 914                 (let ((locals (/frag-expr-assq-locals expr)))
 915                   (for-each (lambda (local)
 916                               (let ((entry (lookup-local local result)))
 917                                 (if (and entry
 918                                          (local-equal? local entry))
 919                                     #f ; already present
 920                                     (set! result (cons local result)))))
 921                             locals)))
 922               expr-list)
 923     ; Done.
 924     result)
 925 )
 926 \f
 927 ; Common subexpression computation.
 928
 929 ; Given a list of rtl expressions and their owners, return a pseudo-optimal
 930 ; set of fragments and a usage list for each owner.
 931 ; Common fragments are combined and the original expressions become a sequence
 932 ; of these fragments.  The result is "pseudo-optimal" in the sense that the
 933 ; desired result is somewhat optimal, though no attempt is made at precise
 934 ; optimality.
 935 ;
 936 ; OWNERS is a list of objects that "own" each corresponding element in EXPRS.
 937 ; The owner is usually an <insn> object.  Actually it'll probably always be
 938 ; an <insn> object but for now I want the disassociation.
 939 ;
 940 ; The result is a vector of six elements:
 941 ; - sfrag usage table for each owner #(header middle trailer)
 942 ; - statement table (vector of all statements, made with /stmt-make)
 943 ; - list of sequence locals used by header sfrags
 944 ;   - these locals are defined at the top level so that all fragments have
 945 ;     access to them
 946 ;   - ??? Need to handle collisions among incompatible types.
 947 ; - header sfrags
 948 ; - trailer sfrags
 949 ; - middle sfrags
 950
 951 (define (/sem-find-common-frags-1 exprs owners)
 952   ; Sanity check.
 953   (if (not (elm-bound? (car owners) 'sfmt))
 954       (error "sformats not computed"))
 955
 956   ; A simple procedure that calls, in order:
 957   ; /frag-compute-locals!
 958   ; /frag-compute-statements
 959   ; /frag-pick-best
 960   ; The rest is shuffling of results.
 961
 962   ; Internally it's easier if OWNERS is a vector.
 963   (let ((owners (list->vector owners))
 964         (locals (/frag-compute-locals! exprs)))
 965
 966     ; Collect statement usage data.
 967     (let ((stmt-usage (/frag-compute-statements exprs owners)))
 968       (let ((stmt-usage-table (car stmt-usage))
 969             (stmt-table (cdr stmt-usage)))
 970
 971         ; Compute the frags we want to create.
 972         ; These are in general sequences of statements.
 973         (let ((desired-frags
 974                (/frag-pick-best stmt-table stmt-usage-table owners)))
 975           (let (
 976                 (expr-sfrags (vector-ref desired-frags 0))
 977                 (headers (vector-ref desired-frags 1))
 978                 (trailers (vector-ref desired-frags 2))
 979                 (middles (vector-ref desired-frags 3))
 980                 )
 981             ; Result.
 982             (vector expr-sfrags stmt-table locals
 983                     headers trailers middles))))))
 984 )
 985
 986 ; Cover proc of /sem-find-common-frags-1.
 987 ; See its documentation.
 988
 989 (define (sem-find-common-frags insn-list)
 990   (/sem-find-common-frags-1
 991    (begin
 992      (logit 2 "Simplifying rtl ...\n")
 993      (map (lambda (insn)
 994             (rtx-simplify-insn #f insn))
 995           insn-list))
 996    insn-list)
 997 )
 998
 999 ; Subroutine of /sfrag-create-cse-mapping to compute INSN's fragment list.
1000 ; FRAG-USAGE is a vector of 3 elements: #(header middle trailer).
1001 ; Each element is a fragment number or #f if not present.
1002 ; Numbers in FRAG-USAGE are indices relative to their respective subtables
1003 ; of FRAG-TABLE (which is a vector of all 3 tables concatenated together).
1004 ; NUM-HEADERS,NUM-TRAILERS are used to compute absolute indices.
1005 ;
1006 ; No header may have been created.  This happens when
1007 ; it's not profitable (or possible) to merge this insn's
1008 ; leading statements with other insns.  Ditto for
1009 ; trailer.  However, each cti insn must have a header
1010 ; and a trailer (for pc handling setup and change).
1011 ; Try to use the middle fragment if present.  Otherwise,
1012 ; use the x-header,x-trailer virtual insns.
1013
1014 (define (/sfrag-compute-frag-list! insn frag-usage frag-table num-headers num-trailers x-header-relnum x-trailer-relnum)
1015   ; `(list #f)' is so append! works.  The #f is deleted before returning.
1016   (let ((result (list #f))
1017         (header (vector-ref frag-usage 0))
1018         (middle (and (vector-ref frag-usage 1)
1019                      (+ (vector-ref frag-usage 1)
1020                         num-headers num-trailers)))
1021         (trailer (and (vector-ref frag-usage 2)
1022                       (+ (vector-ref frag-usage 2)
1023                          num-headers)))
1024         (x-header-num x-header-relnum)
1025         (x-trailer-num (+ x-trailer-relnum num-headers))
1026         )
1027
1028     ; cse'd header created?
1029     (if header
1030         ; Yep.
1031         (append! result (list header))
1032         ; Nope.  Use the middle frag if present, otherwise use x-header.
1033         ; Can't use the trailer fragment because by definition it is shared
1034         ; among several insns.
1035         (if middle
1036             ; Mark the middle frag as the header frag.
1037             (sfrag-set-header?! (vector-ref frag-table middle) #t)
1038             ; No middle, use x-header.
1039             (append! result (list x-header-num))))
1040
1041     ; middle fragment present?
1042     (if middle
1043         (append! result (list middle)))
1044
1045     ; cse'd trailer created?
1046     (if trailer
1047         ; Yep.
1048         (append! result (list trailer))
1049         ; Nope.  Use the middle frag if present, otherwise use x-trailer.
1050         ; Can't use the header fragment because by definition it is shared
1051         ; among several insns.
1052         (if middle
1053             ; Mark the middle frag as the trailer frag.
1054             (sfrag-set-trailer?! (vector-ref frag-table middle) #t)
1055             ; No middle, use x-trailer.
1056             (append! result (list x-trailer-num))))
1057
1058     ; Done.
1059     (cdr result))
1060 )
1061
1062 ; Subroutine of /sfrag-create-cse-mapping to find the fragment number of the
1063 ; x-header/x-trailer virtual frags.
1064
1065 (define (/frag-lookup-virtual frag-list name)
1066   (let loop ((i 0) (frag-list frag-list))
1067     (if (null? frag-list)
1068         (assert (not "expected virtual insn not present"))
1069         (if (eq? name (obj:name (car frag-list)))
1070             i
1071             (loop (+ i 1) (cdr frag-list)))))
1072 )
1073
1074 ; Handle complex case, find set of common header and trailer fragments.
1075 ; The result is a vector of:
1076 ; - fragment table (a vector)
1077 ; - table mapping used fragments for each insn (a list)
1078 ; - locals list
1079
1080 (define (/sfrag-create-cse-mapping insn-list)
1081   (logit 1 "Creating semantic fragments for pbb engine ...\n")
1082
1083   (let ((cse-data (sem-find-common-frags insn-list)))
1084
1085     ; Extract the results of sem-find-common-frags.
1086     (let ((sfrag-usage-table (vector-ref cse-data 0))
1087           (stmt-table (vector-ref cse-data 1))
1088           (locals-list (vector-ref cse-data 2))
1089           (header-list1 (vector-ref cse-data 3))
1090           (trailer-list1 (vector-ref cse-data 4))
1091           (middle-list (vector-ref cse-data 5)))
1092
1093       ; Create two special frags: x-header, x-trailer.
1094       ; These are used by insns that don't have one or the other.
1095       ; Header/trailer table indices are already computed for each insn
1096       ; so append x-header/x-trailer to the end.
1097       (let ((header-list
1098              (append header-list1
1099                      (list
1100                       (make <sfrag>
1101                         'x-header
1102                         "header fragment for insns without one"
1103                         (atlist-parse (make-prefix-context "semantic frag computation")
1104                                       '(VIRTUAL) "")
1105                         nil ; users
1106                         nil ; user ordinals
1107                         (insn-sfmt (current-insn-lookup 'x-before #f))
1108                         #f ; stmt-numbers
1109                         (rtx-make 'nop)
1110                         #f ; parallel?
1111                         #t ; header?
1112                         #f ; trailer?
1113                         ))))
1114             (trailer-list
1115              (append trailer-list1
1116                      (list
1117                       (make <sfrag>
1118                         'x-trailer
1119                         "trailer fragment for insns without one"
1120                         (atlist-parse (make-prefix-context "semantic frag computation")
1121                                       '(VIRTUAL) "")
1122                         nil ; users
1123                         nil ; user ordinals
1124                         (insn-sfmt (current-insn-lookup 'x-before #f))
1125                         #f ; stmt-numbers
1126                         (rtx-make 'nop)
1127                         #f ; parallel?
1128                         #f ; header?
1129                         #t ; trailer?
1130                         )))))
1131
1132         (let ((num-headers (length header-list))
1133               (num-trailers (length trailer-list))
1134               (num-middles (length middle-list)))
1135
1136           ; Combine the three sfrag tables (headers, trailers, middles) into
1137           ; one big one.
1138           (let ((frag-table (list->vector (append header-list
1139                                                   trailer-list
1140                                                   middle-list)))
1141                 (x-header-relnum (/frag-lookup-virtual header-list 'x-header))
1142                 (x-trailer-relnum (/frag-lookup-virtual trailer-list 'x-trailer))
1143                 )
1144             ; Convert sfrag-usage-table to one that refers to the one big
1145             ; sfrag table.
1146             (logit 2 "Computing insn frag usage ...\n")
1147             (let ((insn-frags
1148                    (map (lambda (insn frag-usage)
1149                           (/sfrag-compute-frag-list! insn frag-usage
1150                                                      frag-table
1151                                                      num-headers num-trailers
1152                                                      x-header-relnum
1153                                                      x-trailer-relnum))
1154                         insn-list
1155                         ; FIXME: vector->list
1156                         (vector->list sfrag-usage-table)))
1157                   )
1158               (logit 1 "Done fragment creation.\n")
1159               (vector frag-table insn-frags locals-list)))))))
1160 )
1161 \f
1162 ; Data analysis interface.
1163
1164 (define /sim-sfrag-init? #f)
1165 (define (sim-sfrag-init?) /sim-sfrag-init?)
1166
1167 ; Keep in globals for now, simplifies debugging.
1168 ; evil globals, blah blah blah.
1169 (define /sim-sfrag-insn-list #f)
1170 (define /sim-sfrag-frag-table #f)
1171 (define /sim-sfrag-usage-table #f)
1172 (define /sim-sfrag-locals-list #f)
1173
1174 (define (sim-sfrag-insn-list)
1175   (assert /sim-sfrag-init?)
1176   /sim-sfrag-insn-list
1177 )
1178 (define (sim-sfrag-frag-table)
1179   (assert /sim-sfrag-init?)
1180   /sim-sfrag-frag-table
1181 )
1182 (define (sim-sfrag-usage-table)
1183   (assert /sim-sfrag-init?)
1184   /sim-sfrag-usage-table
1185 )
1186 (define (sim-sfrag-locals-list)
1187   (assert /sim-sfrag-init?)
1188   /sim-sfrag-locals-list
1189 )
1190
1191 (define (sim-sfrag-init!)
1192   (set! /sim-sfrag-init? #f)
1193   (set! /sim-sfrag-insn-list #f)
1194   (set! /sim-sfrag-frag-table #f)
1195   (set! /sim-sfrag-usage-table #f)
1196   (set! /sim-sfrag-locals-list #f)
1197 )
1198
1199 (define (sim-sfrag-analyze-insns!)
1200   (if (not /sim-sfrag-init?)
1201       (begin
1202         (set! /sim-sfrag-insn-list (non-multi-insns (non-alias-insns (current-insn-list))))
1203         (let ((frag-data (/sfrag-create-cse-mapping /sim-sfrag-insn-list)))
1204           (set! /sim-sfrag-frag-table (vector-ref frag-data 0))
1205           (set! /sim-sfrag-usage-table (vector-ref frag-data 1))
1206           (set! /sim-sfrag-locals-list (vector-ref frag-data 2)))
1207         (set! /sim-sfrag-init? #t)))
1208
1209   *UNSPECIFIED*
1210 )
1211 \f
1212 ; Testing support.
1213
1214 (define (/frag-small-test-data)
1215   '(
1216     (a . (sequence VOID ((SI tmp)) (set DFLT tmp rm) (set DFLT rd rm)))
1217     (b . (sequence VOID ((SI tmp)) (set DFLT tmp rm) (set DFLT rd rm)))
1218     (c . (set DFLT rd rm))
1219     )
1220 )
1221
1222 (define (/frag-test-data)
1223   (cons
1224    (map (lambda (insn)
1225           (rtx-simplify-insn #f insn))
1226         (non-multi-insns (non-alias-insns (current-insn-list))))
1227    (non-multi-insns (non-alias-insns (current-insn-list))))
1228 )
1229
1230 (define test-sfrag-table #f)
1231 (define test-stmt-table #f)
1232 (define test-locals-list #f)
1233 (define test-header-list #f)
1234 (define test-trailer-list #f)
1235 (define test-middle-list #f)
1236
1237 (define (frag-test-run)
1238   (let* ((test-data (/frag-test-data))
1239          (frag-data (sem-find-common-frags (car test-data) (cdr test-data))))
1240     (set! test-sfrag-table (vector-ref frag-data 0))
1241     (set! test-stmt-table (vector-ref frag-data 1))
1242     (set! test-locals-list (vector-ref frag-data 2))
1243     (set! test-header-list (vector-ref frag-data 3))
1244     (set! test-trailer-list (vector-ref frag-data 4))
1245     (set! test-middle-list (vector-ref frag-data 5))
1246     )
1247   *UNSPECIFIED*
1248 )