2 ; Copyright (C) 2000, 2009 Red Hat, Inc.
3 ; This file is part of CGEN.
4 ; See file COPYING.CGEN for details.
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
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
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
42 ; - insns can also be split on timing-sensitive boundaries (pipeline, memory,
43 ; whatever) though that is not implemented yet. This may involve rtl
47 ; - call sim-sfrag-init! first, to initialize
48 ; - call sim-sfrag-analyze-insns! to create the semantic fragments
50 ; - sim-sfrag-insn-list
51 ; - sim-sfrag-frag-table
52 ; - sim-sfrag-usage-table
53 ; - sim-sfrag-locals-list
55 ; Statement computation.
57 ; Set to #t to collect various statistics.
59 (define /stmt-stats? #f)
61 ; Collection of computed stats. Only set if /stmt-stats? = #t.
63 (define /stmt-stats #f)
65 ; Collection of computed statement data. Only set if /stmt-stats? = #t.
67 (define /stmt-stats-data #f)
69 ; Create a structure recording data of all statements.
70 ; A pair of (next-ordinal . table).
72 (define (/stmt-data-make hash-size)
73 (cons 0 (make-vector hash-size nil))
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)))
84 ; INSN semantics either consist of a single statement or a sequence of them.
87 (class-make '<statement> nil
92 ; Local variables of the sequence `expr' is in.
93 ; This is recorded in the same form as the sequence,
97 ; Ordinal of the statement.
101 ; SPEED-COST is the cost of executing fragment, relative to a
103 ; SIZE-COST is the size of the fragment, relative to a simple
105 ; ??? The cost numbers are somewhat arbitrary and subject to
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.
120 (define-getters <statement> -stmt (expr locals num speed-cost size-cost users))
122 (define-setters <statement> -stmt (users))
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.
131 ; The user list is set to nil.
133 (define (/stmt-make expr locals num speed-cost size-cost)
134 (make <statement> expr locals num speed-cost size-cost nil)
137 ; Add a user of STMT.
139 (define (/stmt-add-user! stmt user-num user-obj)
140 (-stmt-set-users! stmt (cons (cons user-num user-obj) (-stmt-users stmt)))
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.
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)))
153 ; ??? equal? should be appropriate rtx-equal?, blah blah blah.
154 ((equal? (-stmt-expr (car stmts)) stmt)
157 (loop (cdr stmts))))))
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).
166 (define /frag-hash-value-tmp 0)
168 (define (/frag-hash-string str)
169 (let loop ((chars (map char->integer (string->list str))) (result 0))
172 (loop (cdr chars) (modulo (+ (* result 7) (car chars)) #xfffffff))))
175 ;; MODE is the name of the mode.
177 (define (/frag-hash-compute! rtx-obj expr parent-expr op-pos tstate appstuff)
179 (case (rtx-name expr)
181 (set! h (/frag-hash-string (symbol->string (rtx-operand-name expr)))))
183 (set! h (/frag-hash-string (symbol->string (rtx-local-name expr)))))
185 (set! h (rtx-const-value expr)))
187 (set! h (rtx-num rtx-obj))))
188 (set! /frag-hash-value-tmp
190 (modulo (+ (* /frag-hash-value-tmp 3) h op-pos)
193 ; #f -> "continue with normal traversing"
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)
203 ; Compute the speed/size costs of a statement.
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).
209 (define /frag-speed-cost-tmp 0)
210 (define /frag-size-cost-tmp 0)
212 ;; MODE is the name of the mode.
214 (define (/frag-cost-compute! rtx-obj expr parent-expr op-pos tstate appstuff)
218 (case (rtx-class rtx-obj)
220 #f) ; these don't contribute to costs (at least for now)
222 ; FIXME: speed/size = 0?
225 ((UNARY BINARY TRINARY COMPARE)
234 (set! /frag-speed-cost-tmp (+ /frag-speed-cost-tmp speed))
235 (set! /frag-size-cost-tmp (+ /frag-size-cost-tmp size)))
237 ; #f -> "continue with normal traversing"
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)
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.
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)))
261 ; Return the locals in EXPR.
262 ; If a sequence, return locals.
263 ; Otherwise, return nil.
264 ; The result is in assq'able form.
266 (define (/frag-expr-locals expr)
267 (if (rtx-kind? 'sequence expr)
268 (rtx-sequence-locals expr)
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.
277 (define (/frag-expr-assq-locals expr)
278 (if (rtx-kind? 'sequence expr)
279 (rtx-sequence-assq-locals expr)
283 ; Return the statements in EXPR.
284 ; If a sequence, return the sequence's expressions.
285 ; Otherwise, return (list expr).
287 (define (/frag-expr-stmts expr)
288 (if (rtx-kind? 'sequence expr)
289 (rtx-sequence-exprs expr)
293 ; Analyze statement STMT.
294 ; If STMT is already in STMT-DATA increment its frequency count.
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.
301 (define (/frag-analyze-expr-stmt! locals stmt stmt-data usage-table expr-num owner)
302 (logit 3 "Analyzing statement: " (rtx-strdump stmt) "\n")
304 (/frag-hash-stmt stmt locals (/stmt-data-hash-size stmt-data)))
305 (stmt-obj (/frag-lookup-stmt stmt-data chain-num stmt)))
307 (logit 3 " chain #" chain-num "\n")
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"))
318 (/stmt-add-user! stmt-obj expr-num owner)
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)))))
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.
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))
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.
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
358 (define (/frag-compute-statements exprs owners)
359 (logit 2 "Computing statement table ...\n")
360 (let* ((num-exprs (length exprs))
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)
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)))
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)))))
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)))
389 (vector-set! stmt-table (-stmt-num stmt) stmt))
390 (vector-ref stmt-hash-table i))
393 ; All done. Compute stats if asked to.
396 ; See how well the hashing worked.
397 (set! /stmt-stats-data stmt-data)
399 (make-vector (vector-length stmt-hash-table) #f))
403 (vector-set! /stmt-stats i
404 (length (vector-ref stmt-hash-table i)))
408 (cons usage-table stmt-table))))
411 ; Semantic fragment selection.
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.
418 (class-make '<sfrag> '(<ident>)
420 ; List of insn's using this frag.
423 ; Ordinal's of each element of `users'.
426 ; Semantic format of insns using this fragment.
429 ; List of statement numbers that make up `semantics'.
430 ; Each element is an index into the stmt-table arg of
432 ; This is #f if the sfrag wasn't derived from some set of
436 ; rtl source of fragment.
439 ; Boolean indicating if this frag is for parallel exec support.
442 ; Boolean indicating if this is a header frag.
443 ; This includes all frags that begin a sequence.
446 ; Boolean indicating if this is a trailer frag.
447 ; This includes all frags that end a sequence.
453 (define-getters <sfrag> sfrag
454 (users user-nums sfmt stmt-numbers semantics
455 parallel? header? trailer?)
458 (define-setters <sfrag> sfrag
462 ; Sorter to merge common fragments together.
463 ; A and B are lists of statement numbers.
465 (define (/frag-sort a b)
475 (/frag-sort (cdr a) (cdr b))))
478 ; Return a boolean indicating if L1,L2 match in the first LEN elements.
479 ; Each element is an integer.
481 (define (/frag-list-match? l1 l2 len)
484 ((or (null? l1) (null? l2))
486 ((= (car l1) (car l2))
487 (/frag-list-match? (cdr l1) (cdr l2) (- len 1)))
492 ; Return the number of expressions that match in the first LEN statements.
494 (define (/frag-find-matching expr-table indices stmt-list len)
495 (let loop ((num-exprs 0) (indices indices))
496 (cond ((null? indices)
498 ((/frag-list-match? stmt-list
499 (vector-ref expr-table (car indices)) len)
500 (loop (+ num-exprs 1) (cdr indices)))
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.
510 (define (/frag-merge-profitable? stmt-table stmt-list num-exprs)
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)))
518 ; Return the cost of executing STMT-LIST.
519 ; STMT-LIST is a list of statment numbers, indices into STMT-TABLE.
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.
524 (define (/frag-list-speed-cost stmt-table stmt-list)
526 (apply + (map (lambda (stmt-num)
527 (-stmt-speed-cost (vector-ref stmt-table stmt-num)))
531 (define (/frag-list-size-cost stmt-table stmt-list)
533 (apply + (map (lambda (stmt-num)
534 (-stmt-size-cost (vector-ref stmt-table stmt-num)))
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).
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
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.
553 ; FIXME: Choosing a statement list should depend on whether there are existing
554 ; chosen statement lists only slightly shorter.
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))))
560 (let loop ((len 1) (prev-num-exprs 0))
562 ; See how many subsequent expressions match at length LEN.
563 (let ((num-exprs (/frag-find-matching stmt-usage-table (cdr indices)
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.
570 (let ((matching-stmt-list (list-take (- len 1) stmt-list)))
571 (if (/frag-merge-profitable? stmt-table matching-stmt-list
573 (cons prev-num-exprs matching-stmt-list)
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)))))
581 ; Return list of lists of objects for each unique <sformat-argbuf> in
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.
589 (define (/frag-split-by-sbuf user-list)
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"))
597 ; Find INSN in SFMT-LIST. The result is the list INSN belongs in
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)
605 (obj:name (sfmt-sbuf (insn-sfmt (cdaar sbuf-list)))))
606 (eq? (insn-cti? insn)
607 (insn-cti? (cdaar sbuf-list))))
610 (loop (cdr sbuf-list))))))))
612 (let loop ((users user-list))
613 (if (not (null? users))
614 (let ((try (find-obj result (cdar users))))
616 (append! try (list (car users)))
617 (set! result (cons (list (car users)) result)))
618 (loop (cdr users)))))
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.
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.
634 ; This works for trailing fragments too as we do the computation based on the
635 ; reversed statement lists.
637 (define (/frag-compute-desired-frags stmt-table stmt-usage-table owner-table kind)
638 (logit 2 "Computing desired " kind " frags ...\n")
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
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.
653 ; Update STMT-USAGE-TABLE in case we reversed the contents.
654 (set! stmt-usage-table (list->vector stmt-usage-list))
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)))
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)
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)
675 (vector-ref owner-table
679 (logit 3 "Creating frag of length " (length stmt-list) ", " num-exprs " users\n")
680 (logit 3 "Indices: " picked-indices "\n")
682 ; Create an sfrag for each sbuf.
685 (let* ((first-owner (cdar users))
686 (context (make-obj-context first-owner "While building sfrags"))
692 (map (lambda (stmt-num)
694 (vector-ref stmt-table
699 (symbol-append (obj:name first-owner)
700 (if (eq? kind 'header)
707 (insn-sfmt first-owner)
714 (set! desired-frags (cons sfrag desired-frags))))
717 ; Continue, dropping statements we've put into the frag.
718 (loop (list-drop num-exprs indices) (+ iteration 1)))
720 ; Couldn't find an acceptable statement list.
721 ; Try again with next one.
723 (logit 3 "No acceptable frag found.\n")
724 (loop (cdr indices) (+ iteration 1)))))))
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.
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.
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
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.
752 (define (/frag-pick-best stmt-table stmt-usage-table owner-table)
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)
762 ; Also allocate space for expression sfrag usage table.
763 ; We compute it as we go to save scanning the header and trailer
765 ; copy-tree is needed to avoid shared storage.
766 (expr-sfrags (copy-tree (make-vector (vector-length stmt-usage-table)
770 ; Compute desired headers.
771 (set! desired-header-frags
772 (/frag-compute-desired-frags stmt-table stmt-usage-table owner-table
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
784 (vector-set! expr-hdrs-v expr-num hdr))
785 (sfrag-user-nums hdr))
786 (loop (cdr hdrs) (+ hdrnum 1)))))
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)))
792 (set! desired-trailer-frags
793 (/frag-compute-desired-frags
795 ; FIXME: Shouldn't have to use list->vector.
796 ; [still pass a vector, but use vector-map here instead of map]
798 (map (lambda (expr hdr)
800 (list-drop (length (sfrag-stmt-numbers hdr)) expr)
802 stmt-usage-list expr-hdrs))
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
815 (vector-set! expr-trlrs-v expr-num trlr))
816 (sfrag-user-nums trlr))
817 (loop (cdr trlrs) (+ trlrnum 1)))))
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))
826 (map (lambda (expr hdr trlr)
828 (if trlr (length (sfrag-stmt-numbers trlr)) 0)
830 (if hdr (length (sfrag-stmt-numbers hdr)) 0)
832 stmt-usage-list expr-hdrs expr-trlrs)))
834 ; Finally, record the middle sfrags used by each expression.
835 (let loop ((tmp-middle-frags nil)
836 (next-middle-frag-num 0)
838 (expr-middle-stmts expr-middle-stmts))
840 (if (null? expr-middle-stmts)
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))
849 ; Does this expr have a middle sfrag?
850 (if (null? (car expr-middle-stmts))
852 (loop tmp-middle-frags
855 (cdr expr-middle-stmts))
857 (let* ((owner (vector-ref owner-table expr-num))
858 (context (make-obj-context owner "While building sfrags"))
864 (map (lambda (stmt-num)
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)
878 (car expr-middle-stmts)
885 (+ next-middle-frag-num 1)
887 (cdr expr-middle-stmts))))))))))
892 desired-trailer-frags
896 ; Given a list of expressions, return list of locals in top level sequences.
897 ; ??? Collisions will be handled by rewriting rtl (renaming locals).
899 ; This has to be done now as the cse pass must (currently) take into account
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).
904 (define (/frag-compute-locals! expr-list)
905 (logit 2 "Computing common locals ...\n")
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)))))
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)))
918 (local-equal? local entry))
920 (set! result (cons local result)))))
927 ; Common subexpression computation.
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
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.
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
946 ; - ??? Need to handle collisions among incompatible types.
951 (define (/sem-find-common-frags-1 exprs owners)
953 (if (not (elm-bound? (car owners) 'sfmt))
954 (error "sformats not computed"))
956 ; A simple procedure that calls, in order:
957 ; /frag-compute-locals!
958 ; /frag-compute-statements
960 ; The rest is shuffling of results.
962 ; Internally it's easier if OWNERS is a vector.
963 (let ((owners (list->vector owners))
964 (locals (/frag-compute-locals! exprs)))
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)))
971 ; Compute the frags we want to create.
972 ; These are in general sequences of statements.
974 (/frag-pick-best stmt-table stmt-usage-table owners)))
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))
982 (vector expr-sfrags stmt-table locals
983 headers trailers middles))))))
986 ; Cover proc of /sem-find-common-frags-1.
987 ; See its documentation.
989 (define (sem-find-common-frags insn-list)
990 (/sem-find-common-frags-1
992 (logit 2 "Simplifying rtl ...\n")
994 (rtx-simplify-insn #f insn))
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.
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.
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)
1024 (x-header-num x-header-relnum)
1025 (x-trailer-num (+ x-trailer-relnum num-headers))
1028 ; cse'd header created?
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.
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))))
1041 ; middle fragment present?
1043 (append! result (list middle)))
1045 ; cse'd trailer created?
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.
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))))
1062 ; Subroutine of /sfrag-create-cse-mapping to find the fragment number of the
1063 ; x-header/x-trailer virtual frags.
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)))
1071 (loop (+ i 1) (cdr frag-list)))))
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)
1080 (define (/sfrag-create-cse-mapping insn-list)
1081 (logit 1 "Creating semantic fragments for pbb engine ...\n")
1083 (let ((cse-data (sem-find-common-frags insn-list)))
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)))
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.
1098 (append header-list1
1102 "header fragment for insns without one"
1103 (atlist-parse (make-prefix-context "semantic frag computation")
1107 (insn-sfmt (current-insn-lookup 'x-before #f))
1115 (append trailer-list1
1119 "trailer fragment for insns without one"
1120 (atlist-parse (make-prefix-context "semantic frag computation")
1124 (insn-sfmt (current-insn-lookup 'x-before #f))
1132 (let ((num-headers (length header-list))
1133 (num-trailers (length trailer-list))
1134 (num-middles (length middle-list)))
1136 ; Combine the three sfrag tables (headers, trailers, middles) into
1138 (let ((frag-table (list->vector (append header-list
1141 (x-header-relnum (/frag-lookup-virtual header-list 'x-header))
1142 (x-trailer-relnum (/frag-lookup-virtual trailer-list 'x-trailer))
1144 ; Convert sfrag-usage-table to one that refers to the one big
1146 (logit 2 "Computing insn frag usage ...\n")
1148 (map (lambda (insn frag-usage)
1149 (/sfrag-compute-frag-list! insn frag-usage
1151 num-headers num-trailers
1155 ; FIXME: vector->list
1156 (vector->list sfrag-usage-table)))
1158 (logit 1 "Done fragment creation.\n")
1159 (vector frag-table insn-frags locals-list)))))))
1162 ; Data analysis interface.
1164 (define /sim-sfrag-init? #f)
1165 (define (sim-sfrag-init?) /sim-sfrag-init?)
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)
1174 (define (sim-sfrag-insn-list)
1175 (assert /sim-sfrag-init?)
1176 /sim-sfrag-insn-list
1178 (define (sim-sfrag-frag-table)
1179 (assert /sim-sfrag-init?)
1180 /sim-sfrag-frag-table
1182 (define (sim-sfrag-usage-table)
1183 (assert /sim-sfrag-init?)
1184 /sim-sfrag-usage-table
1186 (define (sim-sfrag-locals-list)
1187 (assert /sim-sfrag-init?)
1188 /sim-sfrag-locals-list
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)
1199 (define (sim-sfrag-analyze-insns!)
1200 (if (not /sim-sfrag-init?)
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)))
1214 (define (/frag-small-test-data)
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))
1222 (define (/frag-test-data)
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))))
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)
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))