mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-17 22:42:25 +02:00
Code Activity

Rewrite slot allocation pass

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2013-11-15 11:17:18 +01:00
parent 13085a828f
commit 987c1f5ff3
2 changed files with 405 additions and 359 deletions
Download patch file Download diff file Expand all files Collapse all files

68
module/language/cps/compile-rtl.scm
View file

@ -98,6 +98,9 @@
(define (lookup-cont k) (define (lookup-cont k)
(vector-ref contv (cfa-k-idx cfa k))) (vector-ref contv (cfa-k-idx cfa k)))
(define (maybe-slot sym)
(lookup-maybe-slot sym allocation))
(define (slot sym) (define (slot sym)
(lookup-slot sym allocation)) (lookup-slot sym allocation))
@ -182,7 +185,7 @@
(($ $ktail) (($ $ktail)
(compile-tail label exp)) (compile-tail label exp))
(($ $kargs (name) (sym)) (($ $kargs (name) (sym))
(let ((dst (slot sym))) (let ((dst (maybe-slot sym)))
(when dst (when dst
(compile-value label exp dst nlocals))) (compile-value label exp dst nlocals)))
(maybe-emit-jump)) (maybe-emit-jump))
@ -197,12 +200,12 @@
(and (= k-idx (1+ n)) (and (= k-idx (1+ n))
(< (+ n 2) (cfa-k-count cfa)) (< (+ n 2) (cfa-k-count cfa))
(cfa-k-sym cfa (+ n 2))))) (cfa-k-sym cfa (+ n 2)))))
(($ $ktrunc ($ $arity req () rest () #f) k) (($ $ktrunc ($ $arity req () rest () #f) kargs)
(compile-trunc label exp (length req) (and rest #t) nlocals) (compile-trunc label k exp (length req) (and rest #t) nlocals)
(unless (and (= k-idx (1+ n)) (unless (and (= k-idx (1+ n))
(< (+ n 2) (cfa-k-count cfa)) (< (+ n 2) (cfa-k-count cfa))
(eq? (cfa-k-sym cfa (+ n 2)) k)) (eq? (cfa-k-sym cfa (+ n 2)) kargs))
(emit-br asm k)))))) (emit-br asm kargs))))))
(define (compile-tail label exp) (define (compile-tail label exp)
;; There are only three kinds of expressions in tail position: ;; There are only three kinds of expressions in tail position:
@ -215,8 +218,11 @@
(let ((tail-slots (cdr (iota (1+ (length args)))))) (let ((tail-slots (cdr (iota (1+ (length args))))))
(for-each maybe-load-constant tail-slots args)) (for-each maybe-load-constant tail-slots args))
(emit-tail-call asm (1+ (length args)))) (emit-tail-call asm (1+ (length args))))
(($ $values ())
(emit-reset-frame asm 1)
(emit-return-values asm))
(($ $values (arg)) (($ $values (arg))
(if (slot arg) (if (maybe-slot arg)
(emit-return asm (slot arg)) (emit-return asm (slot arg))
(begin (begin
(emit-load-constant asm 1 (constant arg)) (emit-load-constant asm 1 (constant arg))
@ -246,19 +252,15 @@
(($ $fun src meta free ($ $cont k)) (($ $fun src meta free ($ $cont k))
(emit-make-closure asm dst k (length free))) (emit-make-closure asm dst k (length free)))
(($ $call proc args) (($ $call proc args)
(let ((proc-slot (lookup-call-proc-slot label allocation)) (let* ((proc-slot (lookup-call-proc-slot label allocation))
(nargs (length args))) (nargs (1+ (length args)))
(or (maybe-load-constant proc-slot proc) (arg-slots (map (lambda (x) (+ x proc-slot)) (iota nargs))))
(maybe-mov proc-slot (slot proc))) (for-each (match-lambda
(let lp ((n (1+ proc-slot)) (args args)) ((src . dst) (emit-mov asm dst src)))
(match args (lookup-parallel-moves label allocation))
(() (for-each maybe-load-constant arg-slots (cons proc args))
(emit-call asm proc-slot (+ nargs 1)) (emit-call asm proc-slot nargs)
(emit-receive asm dst proc-slot nlocals)) (emit-receive asm dst proc-slot nlocals)))
((arg . args)
(or (maybe-load-constant n arg)
(maybe-mov n (slot arg)))
(lp (1+ n) args))))))
(($ $primcall 'current-module) (($ $primcall 'current-module)
(emit-current-module asm dst)) (emit-current-module asm dst))
(($ $primcall 'cached-toplevel-box (scope name bound?)) (($ $primcall 'cached-toplevel-box (scope name bound?))
@ -314,7 +316,7 @@
(($ $ktrunc ($ $arity req () rest () #f) khandler-body) (($ $ktrunc ($ $arity req () rest () #f) khandler-body)
(let ((receive-args (gensym "handler")) (let ((receive-args (gensym "handler"))
(nreq (length req)) (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-prompt asm (slot tag) escape? proc-slot receive-args)
(emit-br asm k) (emit-br asm k)
(emit-label asm receive-args) (emit-label asm receive-args)
@ -423,17 +425,17 @@
(($ $primcall '>= (a b)) (binary emit-br-if-<= b a)) (($ $primcall '>= (a b)) (binary emit-br-if-<= b a))
(($ $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 (match exp
(($ $call proc args) (($ $call proc args)
(let ((proc-slot (lookup-call-proc-slot label allocation)) (let* ((proc-slot (lookup-call-proc-slot label allocation))
(nargs (length args))) (nargs (1+ (length args)))
(or (maybe-load-constant proc-slot proc) (arg-slots (map (lambda (x) (+ x proc-slot)) (iota nargs))))
(maybe-mov proc-slot (slot proc))) (for-each (match-lambda
(let lp ((n (1+ proc-slot)) (args args)) ((src . dst) (emit-mov asm dst src)))
(match args (lookup-parallel-moves label allocation))
(() (for-each maybe-load-constant arg-slots (cons proc args))
(emit-call asm proc-slot (+ nargs 1)) (emit-call asm proc-slot nargs)
;; FIXME: Only allow more values if there is a rest arg. ;; FIXME: Only allow more values if there is a rest arg.
;; Express values truncation by the presence of an ;; Express values truncation by the presence of an
;; unused rest arg instead of implicitly. ;; unused rest arg instead of implicitly.
@ -442,12 +444,8 @@
(emit-bind-rest asm (+ proc-slot 1 nreq))) (emit-bind-rest asm (+ proc-slot 1 nreq)))
(for-each (match-lambda (for-each (match-lambda
((src . dst) (emit-mov asm dst src))) ((src . dst) (emit-mov asm dst src)))
(lookup-parallel-moves label allocation)) (lookup-parallel-moves k allocation))
(emit-reset-frame asm nlocals)) (emit-reset-frame asm nlocals)))))
((arg . args)
(or (maybe-load-constant n arg)
(maybe-mov n (slot arg)))
(lp (1+ n) args))))))))
(match f (match f
(($ $fun src meta free ($ $cont k ($ $kentry self tail clauses))) (($ $fun src meta free ($ $cont k ($ $kentry self tail clauses)))

628
module/language/cps/slot-allocation.scm
View file

@ -31,57 +31,81 @@
#:use-module (language cps dfg) #:use-module (language cps dfg)
#:export (allocate-slots #:export (allocate-slots
lookup-slot lookup-slot
lookup-maybe-slot
lookup-constant-value lookup-constant-value
lookup-maybe-constant-value lookup-maybe-constant-value
lookup-nlocals lookup-nlocals
lookup-call-proc-slot lookup-call-proc-slot
lookup-parallel-moves)) 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 (define-record-type $allocation
(make-allocation slot has-const? const) (make-allocation dfa slots
has-constv constant-values
call-allocations
nlocals)
allocation? allocation?
(slot allocation-slot)
(has-const? allocation-has-const?)
(const allocation-const))
;; Continuations can also have associated allocation data. For example, ;; A DFA records all variables bound in a function, and assigns them
;; when a call happens in a labelled continuation, we need to know what ;; indices. The slot in which a variable is stored at runtime can be
;; slot the procedure goes in. Likewise before branching to the target ;; had by indexing into the SLOTS vector with the variable's index.
;; 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.
;; ;;
;; $prompt expressions also use this call slot to indicate where the (dfa allocation-dfa)
;; handler's arguments are expected, but without reserving space for a (slots allocation-slots)
;; frame or for the procedure slot.
(call-proc-slot cont-call-proc-slot)
;; Tail calls, multiple-value returns, and jumps to continuations with ;; Not all variables have slots allocated. Variables that are
;; multiple arguments are forms of parallel assignment. A ;; constant and that are only used by primcalls that can accept
;; $parallel-move represents a specific solution to the parallel ;; constants directly are not allocated to slots, and their SLOT value
;; assignment problem, with an ordered list of (SRC . DST) moves. This ;; is false. Likewise constants that are only used by calls are not
;; may involve a temporary variable. ;; 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.
;; ;;
;; ((src . dst) ...) (has-constv allocation-has-constv)
(parallel-moves cont-parallel-moves)) (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.
;;
;; 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.
;;
(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) (define (find-first-zero n)
;; Naive implementation. ;; Naive implementation.
@ -90,56 +114,57 @@
(lp (1+ slot)) (lp (1+ slot))
slot))) slot)))
(define (find-first-trailing-zero n count) (define (find-first-trailing-zero n)
(let lp ((slot count)) (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)) (if (or (zero? slot) (logbit? (1- slot) n))
slot slot
(lp (1- slot))))) (lp (1- slot)))))
(define (lookup-allocation sym allocation) (define (lookup-maybe-slot sym allocation)
(let ((res (hashq-ref allocation sym))) (match allocation
(unless res (($ $allocation dfa slots)
(error "Variable or continuation not defined" sym)) (vector-ref slots (dfa-var-idx dfa sym)))))
res))
(define (lookup-slot sym allocation) (define (lookup-slot sym allocation)
(match (lookup-allocation sym allocation) (or (lookup-maybe-slot sym allocation)
(($ $allocation slot has-const? const) slot))) (error "Variable not allocated to a slot" sym)))
(define (lookup-constant-value sym allocation) (define (lookup-constant-value sym allocation)
(match (lookup-allocation sym allocation) (match allocation
(($ $allocation slot #t const) const) (($ $allocation dfa slots has-constv constant-values)
(_ (let ((idx (dfa-var-idx dfa sym)))
(error "Variable does not have constant value" 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) (define (lookup-maybe-constant-value sym allocation)
(match (lookup-allocation sym allocation) (match allocation
(($ $allocation slot has-const? const) (($ $allocation dfa slots has-constv constant-values)
(values has-const? const)))) (let ((idx (dfa-var-idx dfa sym)))
(values (bitvector-ref has-constv idx)
(vector-ref constant-values idx))))))
(define (lookup-call-allocation k allocation)
(or (hashq-ref (allocation-call-allocations allocation) k)
(error "Continuation not a call" k)))
(define (lookup-call-proc-slot k allocation) (define (lookup-call-proc-slot k allocation)
(match (lookup-allocation k allocation) (or (call-allocation-proc-slot (lookup-call-allocation k allocation))
(($ $cont-allocation proc-slot parallel-moves) (error "Call has no proc slot" k)))
(unless proc-slot
(error "Continuation not a call" k))
proc-slot)
(_
(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-parallel-moves k allocation) (define (lookup-parallel-moves k allocation)
(match (lookup-allocation k allocation) (or (call-allocation-moves (lookup-call-allocation k allocation))
(($ $cont-allocation proc-slot parallel-moves) (error "Call has no use parallel moves slot" k)))
(unless parallel-moves
(error "Continuation does not have parallel moves" k)) (define (lookup-nlocals k allocation)
parallel-moves) (or (hashq-ref (allocation-nlocals allocation) k)
(_ (error "Not a clause continuation" k)))
(error "Continuation not a call" k))))
(define (solve-parallel-move src dst tmp) (define (solve-parallel-move src dst tmp)
"Solve the parallel move problem between src and dst slot lists, which "Solve the parallel move problem between src and dst slot lists, which
@ -199,6 +224,24 @@ are comparable with eqv?. A tmp slot may be used."
(not (bitvector-ref (dfa-k-out dfa l) v-idx)))) (not (bitvector-ref (dfa-k-out dfa l) v-idx))))
(define (allocate-slots fun dfg) (define (allocate-slots fun dfg)
(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) (define (empty-live-slots)
#b0) #b0)
@ -213,13 +256,13 @@ are comparable with eqv?. A tmp slot may be used."
hint hint
(find-first-zero live-slots))) (find-first-zero live-slots)))
(define (compute-call-proc-slot live-slots nlocals) (define (compute-call-proc-slot live-slots)
(+ 3 (find-first-trailing-zero live-slots nlocals))) (+ 3 (find-first-trailing-zero live-slots)))
(define (compute-prompt-handler-proc-slot live-slots nlocals) (define (compute-prompt-handler-proc-slot live-slots)
(1- (find-first-trailing-zero live-slots nlocals))) (1- (find-first-trailing-zero live-slots)))
(define (recompute-live-slots k slots nargs dfa) (define (recompute-live-slots k nargs)
(let ((in (dfa-k-in dfa (dfa-k-idx dfa k)))) (let ((in (dfa-k-in dfa (dfa-k-idx dfa k))))
(let lp ((v 0) (live-slots (1- (ash 1 (1+ nargs))))) (let lp ((v 0) (live-slots (1- (ash 1 (1+ nargs)))))
(let ((v (bit-position #t in v))) (let ((v (bit-position #t in v)))
@ -231,227 +274,232 @@ are comparable with eqv?. A tmp slot may be used."
live-slots))) live-slots)))
live-slots))))) live-slots)))))
(define (visit-clause clause dfa allocation slots live-slots) (define* (allocate! var-idx hint live)
(define nlocals (compute-slot live-slots #f)) (cond
(define nargs ((not (bitvector-ref needs-slotv var-idx)) live)
(match clause ((vector-ref slots var-idx) => (cut add-live-slot <> live))
(($ $cont _ ($ $kclause _ ($ $cont _ ($ $kargs names syms)))) (else
(length syms)))) (let ((slot (compute-slot live hint)))
(bump-nlocals! (1+ slot))
(vector-set! slots var-idx slot)
(add-live-slot slot live)))))
(define (allocate! sym k hint live-slots) ;; Although some parallel moves may proceed without a temporary
(match (hashq-ref allocation sym) ;; slot, in general one is needed. That temporary slot must not be
(($ $allocation slot) ;; part of the source or destination sets, and that slot should not
;; Parallel move already allocated this one. ;; correspond to a live variable. Usually the source and
(if slot ;; destination sets are a subset of the union of the live sets
(add-live-slot slot live-slots) ;; before and after the move. However for stack slots that don't
live-slots)) ;; 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)) (call-with-values (lambda () (find-constant-value sym dfg))
(lambda (has-const? const) (lambda (has-const? const)
(cond (when has-const?
((and has-const? (not (constant-needs-allocation? sym const dfg))) (bitvector-set! has-constv n has-const?)
(hashq-set! allocation sym (vector-set! constant-values n const)
(make-allocation #f has-const? const)) (when (not (constant-needs-allocation? sym const dfg))
live-slots) (bitvector-set! needs-slotv n #f)))
(else (lp (1+ n))))))))
(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))
;; 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) (($ $kargs names syms body)
(visit-term body label (vector-set! defv n (map (cut dfa-var-idx dfa <>) syms))
(maybe-recompute-live-slots (vector-set! usev n
(fold maybe-kill-definition (map (cut dfa-var-idx dfa <>)
(fold (cut allocate! <> label #f <>) live-slots syms) (match (find-expression body)
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) (($ $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)) (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) (($ $primcall name args)
(fold use live-slots args)) args)
(($ $values (arg))
(use arg live-slots))
(($ $values args) (($ $values args)
(let ((live-slots* (fold use live-slots args))) 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) (($ $prompt escape? tag handler pop)
(match (lookup-cont handler (dfg-cont-table dfg)) (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) (($ $ktrunc arity kargs)
(let* ((live-slots (allocate-prompt-handler! label live-slots)) (let* ((proc-slot (compute-call-proc-slot post-live))
(proc-slot (lookup-call-proc-slot label allocation)) (call-slots (map (cut + proc-slot <>) (iota (length uses))))
(dst-syms (lookup-bound-syms kargs dfg)) (arg-moves (parallel-move (map (cut vector-ref slots <>) uses)
(nvals (length dst-syms)) call-slots
(src-slots (map (cut + proc-slot 1 <>) (iota nvals))) (compute-tmp-slot pre-live
(live-slots* (fold (cut allocate! <> kargs <> <>) call-slots)))
live-slots dst-syms src-slots)) (result-vars (vector-ref defv (cfa-k-idx cfa kargs)))
(dst-slots (map (cut lookup-slot <> allocation) (value-slots (map (cut + proc-slot 1 <>)
dst-syms))) (iota (length result-vars))))
(parallel-move! handler src-slots live-slots live-slots* dst-slots)))) (result-live (fold allocate!
(use tag live-slots)) 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))))
(_ live-slots))) (_
(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))))))
(match clause (define (allocate-values label k uses pre-live post-live)
(($ $cont k body) (let* ((src-slots (map (cut vector-ref slots <>) uses))
(visit-cont body k live-slots) (dst-slots (match (lookup-cont k cont-table)
(hashq-set! allocation k nlocals)))) (($ $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))))
(match fun (define (allocate-prompt label k handler nargs)
(($ $fun src meta free ($ $cont k ($ $kentry self tail clauses))) (match (lookup-cont handler cont-table)
(let* ((dfa (compute-live-variables fun dfg)) (($ $ktrunc arity kargs)
(allocation (make-hash-table)) (let* ((handler-live (recompute-live-slots handler nargs))
(slots (make-vector (dfa-var-count dfa) #f)) (proc-slot (compute-prompt-handler-proc-slot handler-live))
(live-slots (add-live-slot 0 (empty-live-slots)))) (result-vars (vector-ref defv (cfa-k-idx cfa kargs)))
(vector-set! slots (dfa-var-idx dfa self) 0) (value-slots (map (cut + proc-slot 1 <>)
(hashq-set! allocation self (make-allocation 0 #f #f)) (iota (length result-vars))))
(for-each (cut visit-clause <> dfa allocation slots live-slots) (result-live (fold allocate!
clauses) handler-live result-vars value-slots))
allocation)))) (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)))