X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/d511a2e160ae808336d94683fe515a34247d3e4f..a9ec16f9c5574d80f66c173b495285579f5894b4:/module/language/cps/slot-allocation.scm diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index ba8398222..f9a86951d 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -1,6 +1,6 @@ ;;; 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 @@ -29,6 +29,7 @@ #: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 @@ -36,7 +37,8 @@ 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 @@ -68,32 +70,34 @@ ;; 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) @@ -102,10 +106,11 @@ (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. @@ -162,6 +167,10 @@ (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))) @@ -215,20 +224,18 @@ are comparable with eqv?. A tmp slot may be used." 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)) @@ -239,6 +246,9 @@ are comparable with eqv?. A tmp slot may be used." (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*))) @@ -253,20 +263,28 @@ are comparable with eqv?. A tmp slot may be used." (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) @@ -278,8 +296,8 @@ are comparable with eqv?. A tmp slot may be used." (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)) @@ -296,6 +314,12 @@ are comparable with eqv?. A tmp slot may be used." ;; 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))) @@ -320,22 +344,13 @@ are comparable with eqv?. A tmp slot may be used." (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)) @@ -344,16 +359,54 @@ are comparable with eqv?. A tmp slot may be used." (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. @@ -363,33 +416,26 @@ are comparable with eqv?. A tmp slot may be used." ;; 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)))))) @@ -398,24 +444,26 @@ are comparable with eqv?. A tmp slot may be used." ;; 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)))) @@ -424,21 +472,18 @@ are comparable with eqv?. A tmp slot may be used." ;; 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)) @@ -448,8 +493,8 @@ are comparable with eqv?. A tmp slot may be used." (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)) @@ -457,21 +502,36 @@ are comparable with eqv?. A tmp slot may be used." 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)) @@ -483,43 +543,63 @@ are comparable with eqv?. A tmp slot may be used." 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))) @@ -528,24 +608,22 @@ are comparable with eqv?. A tmp slot may be used." ;; 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)) @@ -554,24 +632,25 @@ are comparable with eqv?. A tmp slot may be used." ;; 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) @@ -579,26 +658,30 @@ are comparable with eqv?. A tmp slot may be used." (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)