;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
#:use-module (srfi srfi-26)
#:use-module (language cps)
#:use-module (language cps dfg)
+ #:use-module (language cps intset)
#:export (allocate-slots
lookup-slot
lookup-maybe-slot
lookup-maybe-constant-value
lookup-nlocals
lookup-call-proc-slot
- lookup-parallel-moves))
+ lookup-parallel-moves
+ lookup-dead-slot-map))
(define-record-type $allocation
(make-allocation dfa slots
;; 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".
+ ;; A call allocation contains three pieces of information: the call's
+ ;; /proc slot/, a set of /parallel moves/, and a /dead slot map/. 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". The dead slot map indicates, for a
+ ;; call, what slots should be ignored by GC when marking the frame.
;;
- ;; $ktrunc continuations record a proc slot and a set of return moves
+ ;; $kreceive 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.
+ ;; Non-tail calls record arg moves, a call slot, and a dead slot map.
+ ;; Multiple-valued returns will have an associated $kreceive
+ ;; continuation, which records the same proc slot, but has return
+ ;; moves and no dead slot map.
;;
- ;; $prompt handlers are $ktrunc continuations like any other.
+ ;; $prompt handlers are $kreceive continuations like any other.
;;
;; $values expressions with more than 1 value record moves but have no
- ;; proc slot.
+ ;; proc slot or dead slot map.
;;
;; 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.
+ ;; variable. A dead slot map is a bitfield, as an integer.
;;
(call-allocations allocation-call-allocations)
(nlocals allocation-nlocals))
(define-record-type $call-allocation
- (make-call-allocation proc-slot moves)
+ (make-call-allocation proc-slot moves dead-slot-map)
call-allocation?
(proc-slot call-allocation-proc-slot)
- (moves call-allocation-moves))
+ (moves call-allocation-moves)
+ (dead-slot-map call-allocation-dead-slot-map))
(define (find-first-zero n)
;; Naive implementation.
(or (call-allocation-moves (lookup-call-allocation k allocation))
(error "Call has no use parallel moves slot" k)))
+(define (lookup-dead-slot-map k allocation)
+ (or (call-allocation-dead-slot-map (lookup-call-allocation k allocation))
+ (error "Call has no dead slot map" k)))
+
(define (lookup-nlocals k allocation)
(or (hashq-ref (allocation-nlocals allocation) k)
(error "Not a clause continuation" k)))
tmp)
(loop to-move b (cons s+d moved) last-source))))))))))
-(define (dead-after-def? def-k v-idx dfa)
- (let ((l (dfa-k-idx dfa def-k)))
- (not (bitvector-ref (dfa-k-in dfa l) v-idx))))
+(define (dead-after-def? k-idx v-idx dfa)
+ (not (intset-ref (dfa-k-in dfa k-idx) v-idx)))
-(define (dead-after-use? use-k v-idx dfa)
- (let ((l (dfa-k-idx dfa use-k)))
- (not (bitvector-ref (dfa-k-out dfa l) v-idx))))
+(define (dead-after-use? k-idx v-idx dfa)
+ (not (intset-ref (dfa-k-out dfa k-idx) v-idx)))
(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) '()))
- (contv (make-vector (cfa-k-count cfa) #f))
+ (min-label (dfg-min-label dfg))
+ (label-count (dfg-label-count dfg))
+ (usev (make-vector label-count '()))
+ (defv (make-vector label-count '()))
(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))
(nlocals 0) ; Mutable. It pains me.
(nlocals-table (make-hash-table)))
+ (define (label->idx label) (- label min-label))
+ (define (idx->label idx) (+ idx min-label))
+
(define (bump-nlocals! nlocals*)
(when (< nlocals nlocals*)
(set! nlocals nlocals*)))
(logand live-slots (lognot (ash 1 slot))))
(define (compute-slot live-slots hint)
- (if (and hint (not (logbit? hint live-slots)))
+ ;; Slots 253-255 are reserved for shuffling; see comments in
+ ;; assembler.scm.
+ (if (and hint (not (logbit? hint live-slots))
+ (or (< hint 253) (> hint 255)))
hint
- (find-first-zero live-slots)))
+ (let ((slot (find-first-zero live-slots)))
+ (if (or (< slot 253) (> slot 255))
+ slot
+ (+ 256 (find-first-zero (ash live-slots -256)))))))
(define (compute-call-proc-slot live-slots)
(+ 2 (find-first-trailing-zero live-slots)))
(define (compute-prompt-handler-proc-slot live-slots)
- (1- (find-first-trailing-zero live-slots)))
+ (if (zero? live-slots)
+ 0
+ (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)))
+ (let ((in (dfa-k-in dfa (label->idx k))))
+ (let lp ((v 0) (live-slots 0))
+ (let ((v (intset-next in v)))
(if v
(let ((slot (vector-ref slots v)))
(lp (1+ v)
(define* (allocate! var-idx hint live)
(cond
((not (bitvector-ref needs-slotv var-idx)) live)
- ((and (not hint) (bitvector-ref needs-hintv var-idx)) live)
((vector-ref slots var-idx) => (cut add-live-slot <> live))
+ ((and (not hint) (bitvector-ref needs-hintv var-idx)) live)
(else
(let ((slot (compute-slot live hint)))
(bump-nlocals! (1+ slot))
;; 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.
+ ;;
+ ;; Note that although we reserve slots 253-255 for shuffling
+ ;; operands that address less than the full 24-bit range of locals,
+ ;; that reservation doesn't apply here, because this temporary
+ ;; itself is used while doing parallel assignment via "mov", and
+ ;; "mov" does not need shuffling.
(define (compute-tmp-slot live stack-slots)
(find-first-zero (fold add-live-slot live stack-slots)))
(bitvector-set! needs-slotv n #f)))
(lp (1+ n))))))))
- ;; Transform the DFG's continuation table to a vector, for easy
- ;; access.
- (define (compute-conts!)
- (let ((cont-table (dfg-cont-table dfg)))
- (let lp ((n 0))
- (when (< n (vector-length contv))
- (vector-set! contv n (lookup-cont (cfa-k-sym cfa n) cont-table))
- (lp (1+ n))))))
-
;; Record uses and defs, as lists of variable indexes, indexed by
- ;; CFA continuation index.
+ ;; label index.
(define (compute-uses-and-defs!)
(let lp ((n 0))
(when (< n (vector-length usev))
- (match (vector-ref contv n)
- (($ $kentry self)
+ (match (lookup-cont (idx->label n) dfg)
+ (($ $kfun src meta 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))
(match (find-expression body)
(($ $call proc args)
(cons proc args))
+ (($ $callk k proc args)
+ (cons proc args))
(($ $primcall name args)
args)
+ (($ $branch kt ($ $primcall name args))
+ args)
+ (($ $branch kt ($ $values args))
+ args)
(($ $values args)
args)
- (($ $prompt escape? tag handler pop)
+ (($ $prompt escape? tag handler)
(list tag))
(_ '())))))
(_ #f))
(lp (1+ n)))))
+ ;; Results of function calls that are not used don't need to be
+ ;; allocated to slots.
+ (define (compute-unused-results!)
+ (define (kreceive-get-kargs kreceive)
+ (match (lookup-cont kreceive dfg)
+ (($ $kreceive arity kargs) kargs)
+ (_ #f)))
+ (let ((candidates (make-bitvector label-count #f)))
+ ;; Find all $kargs that are the successors of $kreceive nodes.
+ (let lp ((n 0))
+ (when (< n label-count)
+ (and=> (kreceive-get-kargs (idx->label n))
+ (lambda (kargs)
+ (bitvector-set! candidates (label->idx kargs) #t)))
+ (lp (1+ n))))
+ ;; For $kargs that only have $kreceive predecessors, remove unused
+ ;; variables from the needs-slotv set.
+ (let lp ((n 0))
+ (let ((n (bit-position #t candidates n)))
+ (when n
+ (match (lookup-predecessors (idx->label n) dfg)
+ ;; At least one kreceive is in the predecessor set, so we
+ ;; only need to do the check for nodes with >1
+ ;; predecessor.
+ ((or (_) ((? kreceive-get-kargs) ...))
+ (for-each (lambda (var)
+ (when (dead-after-def? n var dfa)
+ (bitvector-set! needs-slotv var #f)))
+ (vector-ref defv n)))
+ (_ #f))
+ (lp (1+ n)))))))
+
;; Compute the set of variables whose allocation should be delayed
;; until a "hint" is known about where to allocate them. This is
;; the case for some procedure arguments.
;; frames as soon as it's known that a call will happen. It would
;; be nice to recast this as a proper data-flow problem.
(define (compute-needs-hint!)
- ;; We traverse the graph using reverse-post-order on a forward
- ;; control-flow graph, but we did the live variable analysis in
- ;; the opposite direction -- so the continuation numbers don't
- ;; correspond. This helper adapts them.
- (define (cfa-k-idx->dfa-k-idx n)
- (dfa-k-idx dfa (cfa-k-sym cfa n)))
-
(define (live-before n)
- (dfa-k-in dfa (cfa-k-idx->dfa-k-idx n)))
+ (dfa-k-in dfa n))
(define (live-after n)
- (dfa-k-out dfa (cfa-k-idx->dfa-k-idx n)))
+ (dfa-k-out dfa n))
+ (define needs-slot
+ (bitvector->intset needs-slotv))
;; Walk backwards. At a call, compute the set of variables that
;; have allocated slots and are live before but not after. This
;; set contains candidates for needs-hintv.
(define (scan-for-call n)
(when (<= 0 n)
- (match (vector-ref contv n)
+ (match (lookup-cont (idx->label n) dfg)
(($ $kargs names syms body)
(match (find-expression body)
- (($ $call)
- (let ((args (make-bitvector (bitvector-length needs-slotv) #f)))
- (bit-set*! args (live-before n) #t)
- (bit-set*! args (live-after n) #f)
- (bit-set*! args no-slot-needed #f)
- (if (bit-position #t args 0)
- (scan-for-hints (1- n) args)
+ ((or ($ $call) ($ $callk))
+ (let* ((args (intset-subtract (live-before n) (live-after n)))
+ (args-needing-slots (intset-intersect args needs-slot)))
+ (if (intset-next args-needing-slots #f)
+ (scan-for-hints (1- n) args-needing-slots)
(scan-for-call (1- n)))))
(_ (scan-for-call (1- n)))))
(_ (scan-for-call (1- n))))))
;; ends, we reach a call, or when an expression kills a value.
(define (scan-for-hints n args)
(when (< 0 n)
- (match (vector-ref contv n)
+ (match (lookup-cont (idx->label n) dfg)
(($ $kargs names syms body)
- (match (cfa-predecessors cfa (1+ n))
- (((? (cut eqv? <> n)))
+ (match (lookup-predecessors (idx->label (1+ n)) dfg)
+ (((? (cut eqv? <> (idx->label n))))
;; If we are indeed in the same basic block, then if we
;; are finished with the scan, we kill uses of the
;; terminator, but leave its definitions.
(match (find-expression body)
- ((or ($ $void) ($ $const) ($ $prim) ($ $fun)
- ($ $primcall) ($ $prompt))
- (let ((dead (make-bitvector (bitvector-length args) #f)))
- (bit-set*! dead (live-before n) #t)
- (bit-set*! dead (live-after n) #f)
- (bit-set*! dead no-slot-needed #f)
- (if (bit-position #t dead 0)
+ ((or ($ $const) ($ $prim) ($ $closure)
+ ($ $primcall) ($ $prompt)
+ ;; If $values has more than one argument, it may
+ ;; use a temporary, which would invalidate our
+ ;; assumptions that slots not allocated are not
+ ;; used.
+ ($ $values (or () (_))))
+ (let ((killed (intset-subtract (live-before n) (live-after n))))
+ (if (intset-next (intset-intersect killed needs-slot) #f)
(finish-hints n (live-before n) args)
(scan-for-hints (1- n) args))))
- ((or ($ $call) ($ $values))
+ ((or ($ $call) ($ $callk) ($ $values) ($ $branch))
(finish-hints n (live-before n) args))))
;; Otherwise we kill uses of the block entry.
(_ (finish-hints n (live-before (1+ n)) args))))
;; Add definitions ARGS minus KILL to NEED-HINTS, and go back to
;; looking for calls.
(define (finish-hints n kill args)
- (bit-invert! args)
- (bit-set*! args kill #t)
- (bit-invert! args)
- (bit-set*! needs-hintv args #t)
+ (let ((new-hints (intset-subtract args kill)))
+ (let lp ((n 0))
+ (let ((n (intset-next new-hints n)))
+ (when n
+ (bitvector-set! needs-hintv n #t)
+ (lp (1+ n))))))
(scan-for-call n))
- (define no-slot-needed
- (make-bitvector (bitvector-length needs-slotv) #f))
-
- (bit-set*! no-slot-needed needs-slotv #t)
- (bit-invert! no-slot-needed)
- (scan-for-call (1- (vector-length contv))))
+ (scan-for-call (1- label-count)))
(define (allocate-call label k uses pre-live post-live)
- (match (vector-ref contv (cfa-k-idx cfa k))
+ (match (lookup-cont k dfg)
(($ $ktail)
(let* ((tail-nlocals (length uses))
(tail-slots (iota tail-nlocals))
(compute-tmp-slot pre-live tail-slots))))
(bump-nlocals! tail-nlocals)
(hashq-set! call-allocations label
- (make-call-allocation #f moves))))
- (($ $ktrunc arity kargs)
+ (make-call-allocation #f moves #f))))
+ (($ $kreceive arity kargs)
(let* ((proc-slot (compute-call-proc-slot post-live))
(call-slots (map (cut + proc-slot <>) (iota (length uses))))
(pre-live (fold allocate! pre-live uses call-slots))
call-slots
(compute-tmp-slot pre-live
call-slots)))
- (result-vars (vector-ref defv (cfa-k-idx cfa kargs)))
+ (result-vars (vector-ref defv (label->idx kargs)))
(value-slots (map (cut + proc-slot 1 <>)
(iota (length result-vars))))
- (result-live (fold allocate!
- post-live result-vars value-slots))
+ ;; Shuffle the first result down to the lowest slot, and
+ ;; leave any remaining results where they are. This
+ ;; strikes a balance between avoiding shuffling,
+ ;; especially for unused extra values, and avoiding
+ ;; frame size growth due to sparse locals.
+ (result-live (match (cons result-vars value-slots)
+ ((() . ()) post-live)
+ (((var . vars) . (slot . slots))
+ (fold allocate!
+ (allocate! var #f post-live)
+ vars slots))))
(result-slots (map (cut vector-ref slots <>) result-vars))
+ ;; Filter out unused results.
+ (value-slots (filter-map (lambda (val result) (and result val))
+ value-slots result-slots))
+ (result-slots (filter (lambda (x) x) result-slots))
(result-moves (parallel-move value-slots
result-slots
(compute-tmp-slot result-live
- value-slots))))
+ value-slots)))
+ (dead-slot-map (logand (1- (ash 1 (- proc-slot 2)))
+ (lognot post-live))))
(bump-nlocals! (+ proc-slot (length uses)))
(hashq-set! call-allocations label
- (make-call-allocation proc-slot arg-moves))
+ (make-call-allocation proc-slot arg-moves dead-slot-map))
(hashq-set! call-allocations k
- (make-call-allocation proc-slot result-moves))))
+ (make-call-allocation proc-slot result-moves #f))))
(_
(let* ((proc-slot (compute-call-proc-slot post-live))
call-slots))))
(bump-nlocals! (+ proc-slot (length uses)))
(hashq-set! call-allocations label
- (make-call-allocation proc-slot arg-moves))))))
+ (make-call-allocation proc-slot arg-moves #f))))))
(define (allocate-values label k uses pre-live post-live)
- (let* ((src-slots (map (cut vector-ref slots <>) uses))
- (dst-slots (match (vector-ref contv (cfa-k-idx cfa k))
- (($ $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 (lookup-cont k dfg)
+ (($ $ktail)
+ (let* ((src-slots (map (cut vector-ref slots <>) uses))
+ (tail-nlocals (1+ (length uses)))
+ (dst-slots (cdr (iota tail-nlocals)))
+ (moves (parallel-move src-slots dst-slots
+ (compute-tmp-slot pre-live dst-slots))))
+ (bump-nlocals! tail-nlocals)
+ (hashq-set! call-allocations label
+ (make-call-allocation #f moves #f))))
+ (($ $kargs (_) (_))
+ ;; When there is only one value in play, we allow the dst to be
+ ;; hinted (see scan-for-hints). If the src doesn't have a
+ ;; slot, then the actual slot for the dst would end up being
+ ;; decided by the call that uses it. Because we don't know the
+ ;; slot, we can't really compute the parallel moves in that
+ ;; case, so just bail and rely on the bytecode emitter to
+ ;; handle the one-value case specially.
+ (match (cons uses (vector-ref defv (label->idx k)))
+ (((src) . (dst))
+ (allocate! dst (vector-ref slots src) post-live))))
+ (($ $kargs)
+ (let* ((src-slots (map (cut vector-ref slots <>) uses))
+ (dst-vars (vector-ref defv (label->idx k)))
+ (result-live (fold allocate! post-live dst-vars src-slots))
+ (dst-slots (map (cut vector-ref slots <>) dst-vars))
+ (moves (parallel-move src-slots dst-slots
+ (compute-tmp-slot (logior pre-live result-live)
+ '()))))
+ (hashq-set! call-allocations label
+ (make-call-allocation #f moves #f))))))
(define (allocate-prompt label k handler nargs)
- (match (vector-ref contv (cfa-k-idx cfa handler))
- (($ $ktrunc arity kargs)
+ (match (lookup-cont handler dfg)
+ (($ $kreceive 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)))
+ (result-vars (vector-ref defv (label->idx 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))
+ ;; Filter out unused results.
+ (value-slots (filter-map (lambda (val result) (and result val))
+ value-slots result-slots))
+ (result-slots (filter (lambda (x) x) result-slots))
(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))))))
+ (make-call-allocation proc-slot moves #f))))))
(define (allocate-defs! n live)
(fold (cut allocate! <> #f <>) live (vector-ref defv n)))
;; 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)
+ (let lp ((n n) (live (recompute-live-slots (idx->label n) nargs)))
+ (define (kill-dead live vars-by-label-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))
+ (if (and slot (pred n v dfa))
(kill-dead-slot slot live)
live)))
live
- (vector-ref vars-by-cfa-idx n)))
+ (vector-ref vars-by-label-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))
+ (if (= n label-count)
n
- (let* ((label (cfa-k-sym cfa n))
+ (let* ((label (idx->label n))
(live (if (control-point? label dfg)
(recompute-live-slots label nargs)
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 (vector-ref contv n)
+ (match (lookup-cont (idx->label n) dfg)
(($ $kclause) n)
(($ $kargs names syms body)
+ (define (compute-k-live k)
+ (match (lookup-predecessors k dfg)
+ ((_) post-live)
+ (_ (recompute-live-slots k nargs))))
(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 (or ($ $call) ($ $callk)))
+ (allocate-call label k uses live (compute-k-live k)))
(($ $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))
+ (($ $continue k src ($ $values))
+ (allocate-values label k uses live (compute-k-live k)))
+ (($ $continue k src ($ $prompt escape? tag handler))
(allocate-prompt label k handler nargs))
(_ #f)))
(lp (1+ n) post-live))
- ((or ($ $ktrunc) ($ $kif) ($ $ktail))
+ ((or ($ $kreceive) ($ $ktail))
(lp (1+ n) post-live)))))))
(define (visit-entry)
(unless (eqv? live (add-live-slot 0 (empty-live-slots)))
(error "Unexpected clause live set"))
(set! nlocals 1)
- (match (vector-ref contv n)
- (($ $kclause arity ($ $cont kbody ($ $kargs names)))
- (unless (eq? (cfa-k-sym cfa (1+ n)) kbody)
- (error "Unexpected CFA order"))
+ (match (lookup-cont (idx->label n) dfg)
+ (($ $kclause arity ($ $cont kbody ($ $kargs names)) alternate)
+ (unless (eq? (idx->label (1+ n)) kbody)
+ (error "Unexpected label order"))
(let* ((nargs (length names))
(next (visit-clause (1+ n)
nargs
(fold allocate! live
(vector-ref defv (1+ n))
(cdr (iota (1+ nargs)))))))
- (hashq-set! nlocals-table (cfa-k-sym cfa n) nlocals)
- (when (< next (cfa-k-count cfa))
+ (hashq-set! nlocals-table (idx->label n) nlocals)
+ (when (< next label-count)
+ (match alternate
+ (($ $cont kalt)
+ (unless (eq? kalt (idx->label next))
+ (error "Unexpected clause order"))))
(visit-clauses next live))))))
- (match (vector-ref contv 0)
- (($ $kentry self)
+ (match (lookup-cont (idx->label 0) dfg)
+ (($ $kfun src meta self)
(visit-clauses 1 (allocate-defs! 0 (empty-live-slots))))))
- (compute-conts!)
(compute-constants!)
(compute-uses-and-defs!)
+ (compute-unused-results!)
(compute-needs-hint!)
(visit-entry)
HCoop / bpt / guile.git / blobdiff