diff options
author | Andy Wingo <wingo@pobox.com> | 2013-11-15 11:17:18 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2013-11-15 11:17:18 +0100 |
commit | 987c1f5ff333dfa57e1e08b472d79f194e40ad0b (patch) | |
tree | 93c518711d7e544bb1545b38818a5a710e6ec307 /module | |
parent | 13085a828f6d31c6aaf1e0c403dbe4d1b9dd1449 (diff) | |
download | guile-987c1f5ff333dfa57e1e08b472d79f194e40ad0b.tar.gz |
Rewrite slot allocation pass
* module/language/cps/slot-allocation.scm ($allocation): Refactor
internal format of allocations. Instead of an allocation being a hash
table of small $allocation objects, it is an $allocation object that
contains packed vectors.
(find-first-trailing-zero): Rework to not need a maximum.
(lookup-maybe-slot): New interface.
(lookup-slot): Raise an error if a var has no slot.
(lookup-call-allocation): New helper.
(lookup-constant-value, lookup-maybe-constant-value):
(lookup-call-proc-slot, lookup-parallel-moves): Adapt to $allocation
change
(allocate-slots): Rewrite so that instead of being recursive, it
traverses the blocks in CFA order. Also, procedure call frames are
now allocated with respect to the live set after using arguments (and
killing any dead-after-use vars); this should make call frames more
compact but it does necessitate a parallel move solution. Therefore
parallel moves are recorded for all calls, for arguments; also if the
continuation is a $ktrunc, the continuation gets parallel moves for
the results.
This rewrite is in preparation to allocating call args directly in the
appropriate slots, where possible.
* module/language/cps/compile-rtl.scm (compile-fun): Adapt to slot
allocation changes, using lookup-maybe-slot where appropriate,
performing parallel moves when calling functions, and expecting return
moves to be associated with $ktrunc continuations.
Diffstat (limited to 'module')
-rw-r--r-- | module/language/cps/compile-rtl.scm | 84 | ||||
-rw-r--r-- | module/language/cps/slot-allocation.scm | 712 |
2 files changed, 421 insertions, 375 deletions
diff --git a/module/language/cps/compile-rtl.scm b/module/language/cps/compile-rtl.scm index e23441493..6ad5d8b5c 100644 --- a/module/language/cps/compile-rtl.scm +++ b/module/language/cps/compile-rtl.scm @@ -98,6 +98,9 @@ (define (lookup-cont k) (vector-ref contv (cfa-k-idx cfa k))) + (define (maybe-slot sym) + (lookup-maybe-slot sym allocation)) + (define (slot sym) (lookup-slot sym allocation)) @@ -182,7 +185,7 @@ (($ $ktail) (compile-tail label exp)) (($ $kargs (name) (sym)) - (let ((dst (slot sym))) + (let ((dst (maybe-slot sym))) (when dst (compile-value label exp dst nlocals))) (maybe-emit-jump)) @@ -197,12 +200,12 @@ (and (= k-idx (1+ n)) (< (+ n 2) (cfa-k-count cfa)) (cfa-k-sym cfa (+ n 2))))) - (($ $ktrunc ($ $arity req () rest () #f) k) - (compile-trunc label exp (length req) (and rest #t) nlocals) + (($ $ktrunc ($ $arity req () rest () #f) kargs) + (compile-trunc label k exp (length req) (and rest #t) nlocals) (unless (and (= k-idx (1+ n)) (< (+ n 2) (cfa-k-count cfa)) - (eq? (cfa-k-sym cfa (+ n 2)) k)) - (emit-br asm k)))))) + (eq? (cfa-k-sym cfa (+ n 2)) kargs)) + (emit-br asm kargs)))))) (define (compile-tail label exp) ;; There are only three kinds of expressions in tail position: @@ -215,8 +218,11 @@ (let ((tail-slots (cdr (iota (1+ (length args)))))) (for-each maybe-load-constant tail-slots args)) (emit-tail-call asm (1+ (length args)))) + (($ $values ()) + (emit-reset-frame asm 1) + (emit-return-values asm)) (($ $values (arg)) - (if (slot arg) + (if (maybe-slot arg) (emit-return asm (slot arg)) (begin (emit-load-constant asm 1 (constant arg)) @@ -246,19 +252,15 @@ (($ $fun src meta free ($ $cont k)) (emit-make-closure asm dst k (length free))) (($ $call proc args) - (let ((proc-slot (lookup-call-proc-slot label allocation)) - (nargs (length args))) - (or (maybe-load-constant proc-slot proc) - (maybe-mov proc-slot (slot proc))) - (let lp ((n (1+ proc-slot)) (args args)) - (match args - (() - (emit-call asm proc-slot (+ nargs 1)) - (emit-receive asm dst proc-slot nlocals)) - ((arg . args) - (or (maybe-load-constant n arg) - (maybe-mov n (slot arg))) - (lp (1+ n) args)))))) + (let* ((proc-slot (lookup-call-proc-slot label allocation)) + (nargs (1+ (length args))) + (arg-slots (map (lambda (x) (+ x proc-slot)) (iota nargs)))) + (for-each (match-lambda + ((src . dst) (emit-mov asm dst src))) + (lookup-parallel-moves label allocation)) + (for-each maybe-load-constant arg-slots (cons proc args)) + (emit-call asm proc-slot nargs) + (emit-receive asm dst proc-slot nlocals))) (($ $primcall 'current-module) (emit-current-module asm dst)) (($ $primcall 'cached-toplevel-box (scope name bound?)) @@ -314,7 +316,7 @@ (($ $ktrunc ($ $arity req () rest () #f) khandler-body) (let ((receive-args (gensym "handler")) (nreq (length req)) - (proc-slot (lookup-call-proc-slot label allocation))) + (proc-slot (lookup-call-proc-slot handler allocation))) (emit-prompt asm (slot tag) escape? proc-slot receive-args) (emit-br asm k) (emit-label asm receive-args) @@ -423,31 +425,27 @@ (($ $primcall '>= (a b)) (binary emit-br-if-<= b a)) (($ $primcall '> (a b)) (binary emit-br-if-< b a)))) - (define (compile-trunc label exp nreq rest? nlocals) + (define (compile-trunc label k exp nreq rest? nlocals) (match exp (($ $call proc args) - (let ((proc-slot (lookup-call-proc-slot label allocation)) - (nargs (length args))) - (or (maybe-load-constant proc-slot proc) - (maybe-mov proc-slot (slot proc))) - (let lp ((n (1+ proc-slot)) (args args)) - (match args - (() - (emit-call asm proc-slot (+ nargs 1)) - ;; FIXME: Only allow more values if there is a rest arg. - ;; Express values truncation by the presence of an - ;; unused rest arg instead of implicitly. - (emit-receive-values asm proc-slot #t nreq) - (when rest? - (emit-bind-rest asm (+ proc-slot 1 nreq))) - (for-each (match-lambda - ((src . dst) (emit-mov asm dst src))) - (lookup-parallel-moves label allocation)) - (emit-reset-frame asm nlocals)) - ((arg . args) - (or (maybe-load-constant n arg) - (maybe-mov n (slot arg))) - (lp (1+ n) args)))))))) + (let* ((proc-slot (lookup-call-proc-slot label allocation)) + (nargs (1+ (length args))) + (arg-slots (map (lambda (x) (+ x proc-slot)) (iota nargs)))) + (for-each (match-lambda + ((src . dst) (emit-mov asm dst src))) + (lookup-parallel-moves label allocation)) + (for-each maybe-load-constant arg-slots (cons proc args)) + (emit-call asm proc-slot nargs) + ;; FIXME: Only allow more values if there is a rest arg. + ;; Express values truncation by the presence of an + ;; unused rest arg instead of implicitly. + (emit-receive-values asm proc-slot #t nreq) + (when rest? + (emit-bind-rest asm (+ proc-slot 1 nreq))) + (for-each (match-lambda + ((src . dst) (emit-mov asm dst src))) + (lookup-parallel-moves k allocation)) + (emit-reset-frame asm nlocals))))) (match f (($ $fun src meta free ($ $cont k ($ $kentry self tail clauses))) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index f3c3f1c78..7a1dc570b 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -31,57 +31,81 @@ #:use-module (language cps dfg) #:export (allocate-slots lookup-slot + lookup-maybe-slot lookup-constant-value lookup-maybe-constant-value lookup-nlocals lookup-call-proc-slot lookup-parallel-moves)) -;; Continuations can bind variables. The $allocation structure -;; represents the slot in which a variable is stored. -;; -;; Not all variables have slots allocated. Variables that are constant -;; and that are only used by primcalls that can accept constants -;; directly are not allocated to slots, and their SLOT value is false. -;; Likewise constants that are only used by calls are not allocated into -;; slots, to avoid needless copying. If a variable is constant, its -;; constant value is set to the CONST slot and HAS-CONST? is set to a -;; true value. -;; (define-record-type $allocation - (make-allocation slot has-const? const) + (make-allocation dfa slots + has-constv constant-values + call-allocations + nlocals) allocation? - (slot allocation-slot) - (has-const? allocation-has-const?) - (const allocation-const)) - -;; Continuations can also have associated allocation data. For example, -;; when a call happens in a labelled continuation, we need to know what -;; slot the procedure goes in. Likewise before branching to the target -;; continuation, we might need to shuffle values into the right place: a -;; parallel move. $cont-allocation stores allocation data keyed on the -;; continuation label. -(define-record-type $cont-allocation - (make-cont-allocation call-proc-slot parallel-moves) - cont-allocation? - - ;; Currently calls are allocated in the caller frame, above all locals - ;; that are live at the time of the call. Therefore there is no - ;; parallel move problem. We could be more clever here. + + ;; A DFA records all variables bound in a function, and assigns them + ;; indices. The slot in which a variable is stored at runtime can be + ;; had by indexing into the SLOTS vector with the variable's index. + ;; + (dfa allocation-dfa) + (slots allocation-slots) + + ;; Not all variables have slots allocated. Variables that are + ;; constant and that are only used by primcalls that can accept + ;; constants directly are not allocated to slots, and their SLOT value + ;; is false. Likewise constants that are only used by calls are not + ;; allocated into slots, to avoid needless copying. If a variable is + ;; constant, its constant value is set in the CONSTANT-VALUES vector + ;; and the corresponding bit in the HAS-CONSTV bitvector is set. + ;; + (has-constv allocation-has-constv) + (constant-values allocation-constant-values) + + ;; Some continuations have additional associated information. This + ;; addition information is a /call allocation/. Call allocations + ;; record the way that functions are passed values, and how their + ;; return values are rebound to local variables. + ;; + ;; A call allocation contains two pieces of information: the call's + ;; /proc slot/, and a set of /parallel moves/. The proc slot + ;; indicates the slot of a procedure in a procedure call, or where the + ;; procedure would be in a multiple-value return. The parallel moves + ;; shuffle locals into position for a call, or shuffle returned values + ;; back into place. Though they use the same slot, moves for a call + ;; are called "call moves", and moves to handle a return are "return + ;; moves". + ;; + ;; $ktrunc continuations record a proc slot and a set of return moves + ;; to adapt multiple values from the stack to local variables. + ;; + ;; Tail calls record arg moves, but no proc slot. + ;; + ;; Non-tail calls record arg moves and a call slot. Multiple-valued + ;; returns will have an associated $ktrunc continuation, which records + ;; the same proc slot, but has return moves. + ;; + ;; $prompt handlers are $ktrunc continuations like any other. + ;; + ;; $values expressions with more than 1 value record moves but have no + ;; proc slot. ;; - ;; $prompt expressions also use this call slot to indicate where the - ;; handler's arguments are expected, but without reserving space for a - ;; frame or for the procedure slot. - (call-proc-slot cont-call-proc-slot) - - ;; Tail calls, multiple-value returns, and jumps to continuations with - ;; multiple arguments are forms of parallel assignment. A - ;; $parallel-move represents a specific solution to the parallel - ;; assignment problem, with an ordered list of (SRC . DST) moves. This - ;; may involve a temporary variable. + ;; A set of moves is expressed as an ordered list of (SRC . DST) + ;; moves, where SRC and DST are slots. This may involve a temporary + ;; variable. ;; - ;; ((src . dst) ...) - (parallel-moves cont-parallel-moves)) + (call-allocations allocation-call-allocations) + + ;; The number of locals for a $kclause. + ;; + (nlocals allocation-nlocals)) + +(define-record-type $call-allocation + (make-call-allocation proc-slot moves) + call-allocation? + (proc-slot call-allocation-proc-slot) + (moves call-allocation-moves)) (define (find-first-zero n) ;; Naive implementation. @@ -90,56 +114,57 @@ (lp (1+ slot)) slot))) -(define (find-first-trailing-zero n count) - (let lp ((slot count)) +(define (find-first-trailing-zero n) + (let lp ((slot (let lp ((count 2)) + (if (< n (ash 1 (1- count))) + count + ;; Grow upper bound slower than factor 2 to avoid + ;; needless bignum allocation on 32-bit systems + ;; when there are more than 16 locals. + (lp (+ count (ash count -1))))))) (if (or (zero? slot) (logbit? (1- slot) n)) slot (lp (1- slot))))) -(define (lookup-allocation sym allocation) - (let ((res (hashq-ref allocation sym))) - (unless res - (error "Variable or continuation not defined" sym)) - res)) +(define (lookup-maybe-slot sym allocation) + (match allocation + (($ $allocation dfa slots) + (vector-ref slots (dfa-var-idx dfa sym))))) (define (lookup-slot sym allocation) - (match (lookup-allocation sym allocation) - (($ $allocation slot has-const? const) slot))) + (or (lookup-maybe-slot sym allocation) + (error "Variable not allocated to a slot" sym))) (define (lookup-constant-value sym allocation) - (match (lookup-allocation sym allocation) - (($ $allocation slot #t const) const) - (_ - (error "Variable does not have constant value" sym)))) + (match allocation + (($ $allocation dfa slots has-constv constant-values) + (let ((idx (dfa-var-idx dfa sym))) + (if (bitvector-ref has-constv idx) + (vector-ref constant-values idx) + (error "Variable does not have constant value" sym)))))) (define (lookup-maybe-constant-value sym allocation) - (match (lookup-allocation sym allocation) - (($ $allocation slot has-const? const) - (values has-const? const)))) + (match allocation + (($ $allocation dfa slots has-constv constant-values) + (let ((idx (dfa-var-idx dfa sym))) + (values (bitvector-ref has-constv idx) + (vector-ref constant-values idx)))))) -(define (lookup-call-proc-slot k allocation) - (match (lookup-allocation k allocation) - (($ $cont-allocation proc-slot parallel-moves) - (unless proc-slot - (error "Continuation not a call" k)) - proc-slot) - (_ - (error "Continuation not a call" k)))) +(define (lookup-call-allocation k allocation) + (or (hashq-ref (allocation-call-allocations allocation) k) + (error "Continuation not a call" k))) -(define (lookup-nlocals k allocation) - (match (lookup-allocation k allocation) - ((? number? nlocals) nlocals) - (_ - (error "Not a clause continuation" k)))) +(define (lookup-call-proc-slot k allocation) + (or (call-allocation-proc-slot (lookup-call-allocation k allocation)) + (error "Call has no proc slot" k))) (define (lookup-parallel-moves k allocation) - (match (lookup-allocation k allocation) - (($ $cont-allocation proc-slot parallel-moves) - (unless parallel-moves - (error "Continuation does not have parallel moves" k)) - parallel-moves) - (_ - (error "Continuation not a call" k)))) + (or (call-allocation-moves (lookup-call-allocation k allocation)) + (error "Call has no use parallel moves slot" k))) + +(define (lookup-nlocals k allocation) + (or (hashq-ref (allocation-nlocals allocation) k) + (error "Not a clause continuation" k))) (define (solve-parallel-move src dst tmp) "Solve the parallel move problem between src and dst slot lists, which @@ -199,259 +224,282 @@ are comparable with eqv?. A tmp slot may be used." (not (bitvector-ref (dfa-k-out dfa l) v-idx)))) (define (allocate-slots fun dfg) - (define (empty-live-slots) - #b0) - - (define (add-live-slot slot live-slots) - (logior live-slots (ash 1 slot))) - - (define (kill-dead-slot slot live-slots) - (logand live-slots (lognot (ash 1 slot)))) - - (define (compute-slot live-slots hint) - (if (and hint (not (logbit? hint live-slots))) - hint - (find-first-zero live-slots))) - - (define (compute-call-proc-slot live-slots nlocals) - (+ 3 (find-first-trailing-zero live-slots nlocals))) - - (define (compute-prompt-handler-proc-slot live-slots nlocals) - (1- (find-first-trailing-zero live-slots nlocals))) - - (define (recompute-live-slots k slots nargs dfa) - (let ((in (dfa-k-in dfa (dfa-k-idx dfa k)))) - (let lp ((v 0) (live-slots (1- (ash 1 (1+ nargs))))) - (let ((v (bit-position #t in v))) - (if v - (let ((slot (vector-ref slots v))) - (lp (1+ v) - (if slot - (add-live-slot slot live-slots) - live-slots))) - live-slots))))) - - (define (visit-clause clause dfa allocation slots live-slots) - (define nlocals (compute-slot live-slots #f)) - (define nargs - (match clause - (($ $cont _ ($ $kclause _ ($ $cont _ ($ $kargs names syms)))) - (length syms)))) - - (define (allocate! sym k hint live-slots) - (match (hashq-ref allocation sym) - (($ $allocation slot) - ;; Parallel move already allocated this one. - (if slot - (add-live-slot slot live-slots) - live-slots)) + (let* ((dfa (compute-live-variables fun dfg)) + (cfa (analyze-control-flow fun dfg)) + (usev (make-vector (cfa-k-count cfa) '())) + (defv (make-vector (cfa-k-count cfa) '())) + (cont-table (dfg-cont-table dfg)) + (slots (make-vector (dfa-var-count dfa) #f)) + (constant-values (make-vector (dfa-var-count dfa) #f)) + (has-constv (make-bitvector (dfa-var-count dfa) #f)) + (has-slotv (make-bitvector (dfa-var-count dfa) #t)) + (needs-slotv (make-bitvector (dfa-var-count dfa) #t)) + (call-allocations (make-hash-table)) + (nlocals 0) ; Mutable. It pains me. + (nlocals-table (make-hash-table))) + + (define (bump-nlocals! nlocals*) + (when (< nlocals nlocals*) + (set! nlocals nlocals*))) + + (define (empty-live-slots) + #b0) + + (define (add-live-slot slot live-slots) + (logior live-slots (ash 1 slot))) + + (define (kill-dead-slot slot live-slots) + (logand live-slots (lognot (ash 1 slot)))) + + (define (compute-slot live-slots hint) + (if (and hint (not (logbit? hint live-slots))) + hint + (find-first-zero live-slots))) + + (define (compute-call-proc-slot live-slots) + (+ 3 (find-first-trailing-zero live-slots))) + + (define (compute-prompt-handler-proc-slot live-slots) + (1- (find-first-trailing-zero live-slots))) + + (define (recompute-live-slots k nargs) + (let ((in (dfa-k-in dfa (dfa-k-idx dfa k)))) + (let lp ((v 0) (live-slots (1- (ash 1 (1+ nargs))))) + (let ((v (bit-position #t in v))) + (if v + (let ((slot (vector-ref slots v))) + (lp (1+ v) + (if slot + (add-live-slot slot live-slots) + live-slots))) + live-slots))))) + + (define* (allocate! var-idx hint live) + (cond + ((not (bitvector-ref needs-slotv var-idx)) live) + ((vector-ref slots var-idx) => (cut add-live-slot <> live)) + (else + (let ((slot (compute-slot live hint))) + (bump-nlocals! (1+ slot)) + (vector-set! slots var-idx slot) + (add-live-slot slot live))))) + + ;; Although some parallel moves may proceed without a temporary + ;; slot, in general one is needed. That temporary slot must not be + ;; part of the source or destination sets, and that slot should not + ;; correspond to a live variable. Usually the source and + ;; destination sets are a subset of the union of the live sets + ;; before and after the move. However for stack slots that don't + ;; have names -- those slots that correspond to function arguments + ;; or to function return values -- it could be that they are out of + ;; the computed live set. In that case they need to be adjoined to + ;; the live set, used when choosing a temporary slot. + (define (compute-tmp-slot live stack-slots) + (find-first-zero (fold add-live-slot live stack-slots))) + + (define (parallel-move src-slots dst-slots tmp-slot) + (let ((moves (solve-parallel-move src-slots dst-slots tmp-slot))) + (when (assv tmp-slot moves) + (bump-nlocals! (1+ tmp-slot))) + moves)) + + ;; Find variables that are actually constant, and determine which + ;; of those can avoid slot allocation. + (define (compute-constants!) + (let lp ((n 0)) + (when (< n (vector-length constant-values)) + (let ((sym (dfa-var-sym dfa n))) + (call-with-values (lambda () (find-constant-value sym dfg)) + (lambda (has-const? const) + (when has-const? + (bitvector-set! has-constv n has-const?) + (vector-set! constant-values n const) + (when (not (constant-needs-allocation? sym const dfg)) + (bitvector-set! needs-slotv n #f))) + (lp (1+ n)))))))) + + ;; Record uses and defs, as lists of variable indexes, indexed by + ;; CFA continuation index. + (define (compute-uses-and-defs!) + (let lp ((n 0)) + (when (< n (vector-length usev)) + (match (lookup-cont (cfa-k-sym cfa n) cont-table) + (($ $kentry self) + (vector-set! defv n (list (dfa-var-idx dfa self)))) + (($ $kargs names syms body) + (vector-set! defv n (map (cut dfa-var-idx dfa <>) syms)) + (vector-set! usev n + (map (cut dfa-var-idx dfa <>) + (match (find-expression body) + (($ $call proc args) + (cons proc args)) + (($ $primcall name args) + args) + (($ $values args) + args) + (($ $prompt escape? tag handler pop) + (list tag)) + (_ '()))))) + (_ #f)) + (lp (1+ n))))) + + (define (allocate-call label k uses pre-live post-live) + (match (lookup-cont k cont-table) + (($ $ktail) + (let* ((tail-nlocals (length uses)) + (tail-slots (iota tail-nlocals)) + (moves (parallel-move (map (cut vector-ref slots <>) uses) + tail-slots + (compute-tmp-slot pre-live tail-slots)))) + (bump-nlocals! tail-nlocals) + (hashq-set! call-allocations label + (make-call-allocation #f moves)))) + (($ $ktrunc arity kargs) + (let* ((proc-slot (compute-call-proc-slot post-live)) + (call-slots (map (cut + proc-slot <>) (iota (length uses)))) + (arg-moves (parallel-move (map (cut vector-ref slots <>) uses) + call-slots + (compute-tmp-slot pre-live + call-slots))) + (result-vars (vector-ref defv (cfa-k-idx cfa kargs))) + (value-slots (map (cut + proc-slot 1 <>) + (iota (length result-vars)))) + (result-live (fold allocate! + post-live result-vars value-slots)) + (result-slots (map (cut vector-ref slots <>) result-vars)) + (result-moves (parallel-move value-slots + result-slots + (compute-tmp-slot result-live + value-slots)))) + (bump-nlocals! (+ proc-slot (length uses))) + (hashq-set! call-allocations label + (make-call-allocation proc-slot arg-moves)) + (hashq-set! call-allocations k + (make-call-allocation proc-slot result-moves)))) + (_ - (call-with-values (lambda () (find-constant-value sym dfg)) - (lambda (has-const? const) - (cond - ((and has-const? (not (constant-needs-allocation? sym const dfg))) - (hashq-set! allocation sym - (make-allocation #f has-const? const)) - live-slots) - (else - (let ((slot (compute-slot live-slots hint))) - (when (>= slot nlocals) - (set! nlocals (+ slot 1))) - (vector-set! slots (dfa-var-idx dfa sym) slot) - (hashq-set! allocation sym - (make-allocation slot has-const? const)) - (add-live-slot slot live-slots))))))))) - - (define (allocate-prompt-handler! k live-slots) - (let ((proc-slot (compute-prompt-handler-proc-slot live-slots nlocals))) - (hashq-set! allocation k - (make-cont-allocation - proc-slot - (match (hashq-ref allocation k) - (($ $cont-allocation #f moves) moves) - (#f #f)))) - live-slots)) - - (define (allocate-frame! k nargs live-slots) - (let ((proc-slot (compute-call-proc-slot live-slots nlocals))) - (set! nlocals (max nlocals (+ proc-slot 1 nargs))) - (hashq-set! allocation k - (make-cont-allocation - proc-slot - (match (hashq-ref allocation k) - (($ $cont-allocation #f moves) moves) - (#f #f)))) - live-slots)) - - (define (parallel-move! src-k src-slots pre-live-slots post-live-slots dst-slots) - (let* ((tmp-slot (find-first-zero (logior pre-live-slots post-live-slots))) - (moves (solve-parallel-move src-slots dst-slots tmp-slot))) - (when (and (>= tmp-slot nlocals) (assv tmp-slot moves)) - (set! nlocals (+ tmp-slot 1))) - (hashq-set! allocation src-k - (make-cont-allocation - (match (hashq-ref allocation src-k) - (($ $cont-allocation proc-slot #f) proc-slot) - (#f #f)) - moves)) - post-live-slots)) - - (define (visit-cont cont label live-slots) - (define (maybe-kill-definition sym live-slots) - (let* ((v (dfa-var-idx dfa sym)) - (slot (vector-ref slots v))) - (if (and slot (> slot nargs) (dead-after-def? label v dfa)) - (kill-dead-slot slot live-slots) - live-slots))) - - (define (maybe-recompute-live-slots live-slots) - (if (control-point? label dfg) - (recompute-live-slots label slots nargs dfa) - live-slots)) - - (match cont - (($ $kclause arity ($ $cont k body)) - (visit-cont body k live-slots)) - - (($ $kargs names syms body) - (visit-term body label - (maybe-recompute-live-slots - (fold maybe-kill-definition - (fold (cut allocate! <> label #f <>) live-slots syms) - syms)))) - - (($ $ktrunc) live-slots) - (($ $kif) live-slots))) - - (define (visit-term term label live-slots) - (match term - (($ $letk conts body) - (let ((live-slots (visit-term body label live-slots))) - (for-each (match-lambda - (($ $cont k cont) - (visit-cont cont k live-slots))) - conts)) - live-slots) - - (($ $continue k src exp) - (visit-exp exp label k live-slots)))) - - (define (visit-exp exp label k live-slots) - (define (use sym live-slots) - (let* ((v (dfa-var-idx dfa sym)) - (l (dfa-k-idx dfa label)) - (slot (vector-ref slots v))) - (if (and slot (> slot nargs) (dead-after-use? label v dfa)) - (kill-dead-slot slot live-slots) - live-slots))) - - (match exp - (($ $call proc args) - (match (lookup-cont k (dfg-cont-table dfg)) - (($ $ktail) - (let ((tail-nlocals (1+ (length args)))) - (set! nlocals (max nlocals tail-nlocals)) - (parallel-move! label - (map (cut lookup-slot <> allocation) - (cons proc args)) - live-slots (fold use live-slots (cons proc args)) - (iota tail-nlocals)))) - (($ $ktrunc arity kargs) - (let* ((live-slots - (fold use - (use proc - (allocate-frame! label (length args) live-slots)) - args)) - (proc-slot (lookup-call-proc-slot label allocation)) - (dst-syms (lookup-bound-syms kargs dfg)) - (nvals (length dst-syms)) - (src-slots (map (cut + proc-slot 1 <>) (iota nvals))) - (live-slots* (fold (cut allocate! <> kargs <> <>) - live-slots dst-syms src-slots)) - (dst-slots (map (cut lookup-slot <> allocation) - dst-syms))) - (parallel-move! label src-slots live-slots live-slots* dst-slots))) - (else - (fold use - (use proc (allocate-frame! label (length args) live-slots)) - args)))) - - (($ $primcall name args) - (fold use live-slots args)) - - (($ $values (arg)) - (use arg live-slots)) - - (($ $values args) - (let ((live-slots* (fold use live-slots args))) - (define (compute-dst-slots) - (match (lookup-cont k (dfg-cont-table dfg)) - (($ $ktail) - (let ((tail-nlocals (1+ (length args)))) - (set! nlocals (max nlocals tail-nlocals)) - (cdr (iota tail-nlocals)))) - (_ - (let* ((src-slots (map (cut lookup-slot <> allocation) args)) - (dst-syms (lookup-bound-syms k dfg)) - (dst-live-slots (fold (cut allocate! <> k <> <>) - live-slots* dst-syms src-slots))) - (map (cut lookup-slot <> allocation) dst-syms))))) - - (parallel-move! label - (map (cut lookup-slot <> allocation) args) - live-slots live-slots* - (compute-dst-slots)))) - - (($ $values args) - (let ((live-slots* (fold use live-slots args))) - (define (compute-dst-slots) - (match (lookup-cont k (dfg-cont-table dfg)) - (($ $ktail) - (let ((tail-nlocals (1+ (length args)))) - (set! nlocals (max nlocals tail-nlocals)) - (cdr (iota tail-nlocals)))) - (_ - (let* ((src-slots (map (cut lookup-slot <> allocation) args)) - (dst-syms (lookup-bound-syms k dfg)) - (dst-live-slots (fold (cut allocate! <> k <> <>) - live-slots* dst-syms src-slots))) - (map (cut lookup-slot <> allocation) dst-syms))))) - - (parallel-move! label - (map (cut lookup-slot <> allocation) args) - live-slots live-slots* - (compute-dst-slots)))) - - (($ $prompt escape? tag handler pop) - (match (lookup-cont handler (dfg-cont-table dfg)) - (($ $ktrunc arity kargs) - (let* ((live-slots (allocate-prompt-handler! label live-slots)) - (proc-slot (lookup-call-proc-slot label allocation)) - (dst-syms (lookup-bound-syms kargs dfg)) - (nvals (length dst-syms)) - (src-slots (map (cut + proc-slot 1 <>) (iota nvals))) - (live-slots* (fold (cut allocate! <> kargs <> <>) - live-slots dst-syms src-slots)) - (dst-slots (map (cut lookup-slot <> allocation) - dst-syms))) - (parallel-move! handler src-slots live-slots live-slots* dst-slots)))) - (use tag live-slots)) - - (_ live-slots))) - - (match clause - (($ $cont k body) - (visit-cont body k live-slots) - (hashq-set! allocation k nlocals)))) - - (match fun - (($ $fun src meta free ($ $cont k ($ $kentry self tail clauses))) - (let* ((dfa (compute-live-variables fun dfg)) - (allocation (make-hash-table)) - (slots (make-vector (dfa-var-count dfa) #f)) - (live-slots (add-live-slot 0 (empty-live-slots)))) - (vector-set! slots (dfa-var-idx dfa self) 0) - (hashq-set! allocation self (make-allocation 0 #f #f)) - (for-each (cut visit-clause <> dfa allocation slots live-slots) - clauses) - allocation)))) + (let* ((proc-slot (compute-call-proc-slot post-live)) + (call-slots (map (cut + proc-slot <>) (iota (length uses)))) + (arg-moves (parallel-move (map (cut vector-ref slots <>) uses) + call-slots + (compute-tmp-slot pre-live + call-slots)))) + (bump-nlocals! (+ proc-slot (length uses))) + (hashq-set! call-allocations label + (make-call-allocation proc-slot arg-moves)))))) + + (define (allocate-values label k uses pre-live post-live) + (let* ((src-slots (map (cut vector-ref slots <>) uses)) + (dst-slots (match (lookup-cont k cont-table) + (($ $ktail) + (let ((tail-nlocals (1+ (length uses)))) + (bump-nlocals! tail-nlocals) + (cdr (iota tail-nlocals)))) + (_ + (let ((dst-vars (vector-ref defv (cfa-k-idx cfa k)))) + (fold allocate! post-live dst-vars src-slots) + (map (cut vector-ref slots <>) dst-vars))))) + (moves (parallel-move src-slots + dst-slots + (compute-tmp-slot pre-live dst-slots)))) + (hashq-set! call-allocations label + (make-call-allocation #f moves)))) + + (define (allocate-prompt label k handler nargs) + (match (lookup-cont handler cont-table) + (($ $ktrunc arity kargs) + (let* ((handler-live (recompute-live-slots handler nargs)) + (proc-slot (compute-prompt-handler-proc-slot handler-live)) + (result-vars (vector-ref defv (cfa-k-idx cfa kargs))) + (value-slots (map (cut + proc-slot 1 <>) + (iota (length result-vars)))) + (result-live (fold allocate! + handler-live result-vars value-slots)) + (result-slots (map (cut vector-ref slots <>) result-vars)) + (moves (parallel-move value-slots + result-slots + (compute-tmp-slot result-live + value-slots)))) + (bump-nlocals! (+ proc-slot 1 (length result-vars))) + (hashq-set! call-allocations handler + (make-call-allocation proc-slot moves)))))) + + (define (allocate-defs! n live) + (fold (cut allocate! <> #f <>) live (vector-ref defv n))) + + ;; This traversal will visit definitions before uses, as + ;; definitions dominate uses and a block's dominator will appear + ;; before it, in reverse post-order. + (define (visit-clause n nargs live) + (let lp ((n n) (live live)) + (define (kill-dead live vars-by-cfa-idx pred) + (fold (lambda (v live) + (let ((slot (vector-ref slots v))) + (if (and slot + (> slot nargs) + (pred (cfa-k-sym cfa n) v dfa)) + (kill-dead-slot slot live) + live))) + live + (vector-ref vars-by-cfa-idx n))) + (define (kill-dead-defs live) + (kill-dead live defv dead-after-def?)) + (define (kill-dead-uses live) + (kill-dead live usev dead-after-use?)) + (if (= n (cfa-k-count cfa)) + n + (let* ((label (cfa-k-sym cfa n)) + (live (if (control-point? label dfg) + (recompute-live-slots label nargs) + live)) + (live (kill-dead-defs (allocate-defs! n live))) + (post-live (kill-dead-uses live))) + ;; LIVE are the live slots coming into the term. + ;; POST-LIVE is the subset that is still live after the + ;; term uses its inputs. + (match (lookup-cont label cont-table) + (($ $kclause) n) + (($ $kargs names syms body) + (let ((uses (vector-ref usev n))) + (match (find-call body) + (($ $continue k src ($ $call)) + (allocate-call label k uses live post-live)) + (($ $continue k src ($ $primcall)) #t) + ;; We only need to make a call allocation if there + ;; are two or more values. + (($ $continue k src ($ $values (_ _ . _))) + (allocate-values label k uses live post-live)) + (($ $continue k src ($ $values)) #t) + (($ $continue k src ($ $prompt escape? tag handler pop)) + (allocate-prompt label k handler nargs)) + (_ #f))) + (lp (1+ n) post-live)) + ((or ($ $ktrunc) ($ $kif) ($ $ktail)) + (lp (1+ n) post-live))))))) + + (define (visit-entry) + (define (visit-clauses n live) + (unless (eqv? live (add-live-slot 0 (empty-live-slots))) + (error "Unexpected clause live set")) + (set! nlocals 1) + (let ((k (cfa-k-sym cfa n))) + (match (lookup-cont k cont-table) + (($ $kclause arity ($ $cont kbody ($ $kargs names))) + (unless (eq? (cfa-k-sym cfa (1+ n)) kbody) + (error "Unexpected CFA order")) + (let ((next (visit-clause (1+ n) (length names) live))) + (hashq-set! nlocals-table k nlocals) + (when (< next (cfa-k-count cfa)) + (visit-clauses next live))))))) + (match (lookup-cont (cfa-k-sym cfa 0) cont-table) + (($ $kentry self) + (visit-clauses 1 (allocate-defs! 0 (empty-live-slots)))))) + + (compute-constants!) + (compute-uses-and-defs!) + (visit-entry) + + (make-allocation dfa slots + has-constv constant-values + call-allocations + nlocals-table))) |