guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] GNU Guile branch, master, updated. v2.1.0-389-g0c247a2


From: Andy Wingo
Subject: [Guile-commits] GNU Guile branch, master, updated. v2.1.0-389-g0c247a2
Date: Fri, 15 Nov 2013 14:22:33 +0000

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=0c247a2fb6a9872b262eb7558e62481ac1967063

The branch, master has been updated
       via  0c247a2fb6a9872b262eb7558e62481ac1967063 (commit)
       via  987c1f5ff333dfa57e1e08b472d79f194e40ad0b (commit)
       via  13085a828f6d31c6aaf1e0c403dbe4d1b9dd1449 (commit)
      from  4c906ad5a5e0404e8b488b525f6b62f405b4d560 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 0c247a2fb6a9872b262eb7558e62481ac1967063
Author: Andy Wingo <address@hidden>
Date:   Fri Nov 15 14:57:05 2013 +0100

    Try to allocate arguments directly in call frames
    
    * module/language/cps/slot-allocation.scm (allocate-slots): Convert
      cont-table to a vector, for ease of access.  Run a pass before
      allocation that determines the set of variables whose slot allocation
      can and should be delayed, so that they can ideally be allocated
      directly in an argument slot.

commit 987c1f5ff333dfa57e1e08b472d79f194e40ad0b
Author: Andy Wingo <address@hidden>
Date:   Fri Nov 15 11:17:18 2013 +0100

    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.

commit 13085a828f6d31c6aaf1e0c403dbe4d1b9dd1449
Author: Andy Wingo <address@hidden>
Date:   Wed Nov 13 19:58:55 2013 +0100

    Replace ($var sym) with ($values (sym)).
    
    * module/language/cps.scm: Remove $var.  Replaced by $values with one
      value.
    
    * module/language/cps/arities.scm:
    * module/language/cps/closure-conversion.scm:
    * module/language/cps/compile-rtl.scm:
    * module/language/cps/dfg.scm:
    * module/language/cps/slot-allocation.scm:
    * module/language/cps/verify.scm:
    * module/language/tree-il/compile-cps.scm: Adapt all the world.

-----------------------------------------------------------------------

Summary of changes:
 module/language/cps.scm                    |   10 +-
 module/language/cps/arities.scm            |    8 +-
 module/language/cps/closure-conversion.scm |   13 +-
 module/language/cps/compile-rtl.scm        |   99 ++--
 module/language/cps/dfg.scm                |    5 +-
 module/language/cps/slot-allocation.scm    |  795 +++++++++++++++++-----------
 module/language/cps/verify.scm             |    2 -
 module/language/tree-il/compile-cps.scm    |    9 +-
 8 files changed, 549 insertions(+), 392 deletions(-)

diff --git a/module/language/cps.scm b/module/language/cps.scm
index 4dc88eb..57d95d4 100644
--- a/module/language/cps.scm
+++ b/module/language/cps.scm
@@ -122,7 +122,7 @@
             $kif $ktrunc $kargs $kentry $ktail $kclause
 
             ;; Expressions.
-            $var $void $const $prim $fun $call $primcall $values $prompt
+            $void $const $prim $fun $call $primcall $values $prompt
 
             ;; Building macros.
             let-gensyms
@@ -178,7 +178,6 @@
 (define-cps-type $kclause arity cont)
 
 ;; Expressions.
-(define-cps-type $var sym)
 (define-cps-type $void)
 (define-cps-type $const val)
 (define-cps-type $prim name)
@@ -228,9 +227,8 @@
 
 (define-syntax build-cps-exp
   (syntax-rules (unquote
-                 $var $void $const $prim $fun $call $primcall $values $prompt)
+                 $void $const $prim $fun $call $primcall $values $prompt)
     ((_ (unquote exp)) exp)
-    ((_ ($var sym)) (make-$var sym))
     ((_ ($void)) (make-$void))
     ((_ ($const val)) (make-$const val))
     ((_ ($prim name)) (make-$prim name))
@@ -326,8 +324,6 @@
     ;; Calls.
     (('continue k exp)
      (build-cps-term ($continue k (src exp) ,(parse-cps exp))))
-    (('var sym)
-     (build-cps-exp ($var sym)))
     (('void)
      (build-cps-exp ($void)))
     (('const exp)
@@ -382,8 +378,6 @@
     ;; Calls.
     (($ $continue k src exp)
      `(continue ,k ,(unparse-cps exp)))
-    (($ $var sym)
-     `(var ,sym))
     (($ $void)
      `(void))
     (($ $const val)
diff --git a/module/language/cps/arities.scm b/module/language/cps/arities.scm
index 387187c..1005683 100644
--- a/module/language/cps/arities.scm
+++ b/module/language/cps/arities.scm
@@ -83,7 +83,7 @@
          (rewrite-cps-term (lookup-cont k conts)
            (($ $ktail)
             ,(rewrite-cps-term exp
-               (($var sym)
+               (($values (sym))
                 ($continue ktail src ($primcall 'return (sym))))
                (_
                 ,(let-gensyms (k* v)
@@ -117,7 +117,7 @@
         ((or ($ $void)
              ($ $const)
              ($ $prim)
-             ($ $var))
+             ($ $values (_)))
          ,(adapt-exp 1 k src exp))
         (($ $fun)
          ,(adapt-exp 1 k src (fix-arities exp)))
@@ -149,8 +149,8 @@
                                    ($continue k src ($call p* args)))))
                        ($continue k* src ($prim name)))))))))
         (($ $values)
-         ;; Values nodes are inserted by CPS optimization passes, so
-         ;; we assume they are correct.
+         ;; Non-unary values nodes are inserted by CPS optimization
+         ;; passes, so we assume they are correct.
          ($continue k src ,exp))
         (($ $prompt)
          ($continue k src ,exp))))
diff --git a/module/language/cps/closure-conversion.scm 
b/module/language/cps/closure-conversion.scm
index 3cea53a..11d388b 100644
--- a/module/language/cps/closure-conversion.scm
+++ b/module/language/cps/closure-conversion.scm
@@ -165,12 +165,6 @@ convert functions to flat closures."
                     (init-closure src sym fun-free self bound body)
                     (union free (difference fun-free bound))))))))))
 
-    (($ $continue k src ($ $var sym))
-     (convert-free-var sym self bound
-                       (lambda (sym)
-                         (values (build-cps-term ($continue k src ($var sym)))
-                                 '()))))
-
     (($ $continue k src
         (or ($ $void)
             ($ $const)
@@ -189,9 +183,10 @@ convert functions to flat closures."
            (let-gensyms (kinit v)
              (build-cps-term
                ($letk ((kinit ($kargs (v) (v)
-                                ,(init-closure src v free self bound
-                                               (build-cps-term
-                                                 ($continue k src ($var 
v)))))))
+                                ,(init-closure
+                                  src v free self bound
+                                  (build-cps-term
+                                    ($continue k src ($values (v))))))))
                  ($continue kinit src ($fun src* meta free ,body)))))
            (difference free bound))))))
 
diff --git a/module/language/cps/compile-rtl.scm 
b/module/language/cps/compile-rtl.scm
index e45773f..6ad5d8b 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,11 +218,20 @@
          (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 (maybe-slot arg)
+             (emit-return asm (slot arg))
+             (begin
+               (emit-load-constant asm 1 (constant arg))
+               (emit-return asm 1))))
         (($ $values args)
+         (for-each (match-lambda
+                    ((src . dst) (emit-mov asm dst src)))
+                   (lookup-parallel-moves label allocation))
          (let ((tail-slots (cdr (iota (1+ (length args))))))
-           (for-each (match-lambda
-                      ((src . dst) (emit-mov asm dst src)))
-                     (lookup-parallel-moves label allocation))
            (for-each maybe-load-constant tail-slots args))
          (emit-reset-frame asm (1+ (length args)))
          (emit-return-values asm))
@@ -228,9 +240,6 @@
 
     (define (compile-value label exp dst nlocals)
       (match exp
-        (($ $var sym)
-         (maybe-mov dst (slot sym)))
-        ;; FIXME: Remove ($var sym), replace with ($values (sym))
         (($ $values (arg))
          (or (maybe-load-constant dst arg)
              (maybe-mov dst (slot arg))))
@@ -243,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?))
@@ -311,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)
@@ -397,7 +402,7 @@
           (unless (eq? kf next-label)
             (emit-br asm kf)))))
       (match exp
-        (($ $var sym) (unary emit-br-if-true sym))
+        (($ $values (sym)) (unary emit-br-if-true sym))
         (($ $primcall 'null? (a)) (unary emit-br-if-null a))
         (($ $primcall 'nil? (a)) (unary emit-br-if-nil a))
         (($ $primcall 'pair? (a)) (unary emit-br-if-pair a))
@@ -420,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/dfg.scm b/module/language/cps/dfg.scm
index 365f455..d6cfcf3 100644
--- a/module/language/cps/dfg.scm
+++ b/module/language/cps/dfg.scm
@@ -691,9 +691,6 @@
       (($ $continue k src exp)
        (use-k! k)
        (match exp
-         (($ $var sym)
-          (use! sym))
-
          (($ $call proc args)
           (use! proc)
           (for-each use! args))
@@ -849,7 +846,7 @@
          (lambda (use)
            (match (find-expression (lookup-cont use conts))
              (($ $call) #f)
-             (($ $values) #f)
+             (($ $values (_ _ . _)) #f)
              (($ $primcall 'free-ref (closure slot))
               (not (eq? sym slot)))
              (($ $primcall 'free-set! (closure slot value))
diff --git a/module/language/cps/slot-allocation.scm 
b/module/language/cps/slot-allocation.scm
index 580d0f9..066b42d 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,239 +224,385 @@ 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) '()))
+         (contv (make-vector (cfa-k-count cfa) #f))
+         (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))
+         (needs-hintv (make-bitvector (dfa-var-count dfa) #f))
+         (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)
+       ((and (not hint) (bitvector-ref needs-hintv 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))))))))
+
+    ;; 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.
+    (define (compute-uses-and-defs!)
+      (let lp ((n 0))
+        (when (< n (vector-length usev))
+          (match (vector-ref contv n)
+            (($ $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)))))
+
+    ;; 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.
+    ;;
+    ;; This algorithm used is a conservative approximation of what
+    ;; really should happen, which would be eager allocation of call
+    ;; 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)))
+      (define (live-after n)
+        (dfa-k-out dfa (cfa-k-idx->dfa-k-idx n)))
+
+      ;; 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)
+            (($ $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)
+                      (scan-for-call (1- n)))))
+               (_ (scan-for-call (1- n)))))
+            (_ (scan-for-call (1- n))))))
+
+      ;; Walk backwards in the current basic block.  Stop when the block
+      ;; 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)
+            (($ $kargs names syms body)
+             (match (cfa-predecessors cfa (1+ n))
+               (((? (cut eqv? <> 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)
+                         (finish-hints n (live-before n) args)
+                         (scan-for-hints (1- n) args))))
+                  ((or ($ $call) ($ $values))
+                   (finish-hints n (live-before n) args))))
+               ;; Otherwise we kill uses of the block entry.
+               (_ (finish-hints n (live-before (1+ n)) args))))
+            (_ (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)
+        (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))))
+
+    (define (allocate-call label k uses pre-live post-live)
+      (match (vector-ref contv (cfa-k-idx cfa k))
+        (($ $ktail)
+         (let* ((tail-nlocals (length uses))
+                (tail-slots (iota tail-nlocals))
+                (pre-live (fold allocate! pre-live uses tail-slots))
+                (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))))
+                (pre-live (fold allocate! pre-live uses call-slots))
+                (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
-        (($ $var sym)
-         (use sym live-slots))
-
-        (($ $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 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))))
+                (pre-live (fold allocate! pre-live uses call-slots))
+                (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 (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))))
+
+    (define (allocate-prompt label k handler nargs)
+      (match (vector-ref contv (cfa-k-idx cfa handler))
+        (($ $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 (vector-ref contv n)
+                (($ $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)
+        (match (vector-ref contv n)
+          (($ $kclause arity ($ $cont kbody ($ $kargs names)))
+           (unless (eq? (cfa-k-sym cfa (1+ n)) kbody)
+             (error "Unexpected CFA 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))
+               (visit-clauses next live))))))
+      (match (vector-ref contv 0)
+        (($ $kentry self)
+         (visit-clauses 1 (allocate-defs! 0 (empty-live-slots))))))
+
+    (compute-conts!)
+    (compute-constants!)
+    (compute-uses-and-defs!)
+    (compute-needs-hint!)
+    (visit-entry)
+
+    (make-allocation dfa slots
+                     has-constv constant-values
+                     call-allocations
+                     nlocals-table)))
diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm
index 3772f21..ff23aa3 100644
--- a/module/language/cps/verify.scm
+++ b/module/language/cps/verify.scm
@@ -113,8 +113,6 @@
 
   (define (visit-expression exp k-env v-env)
     (match exp
-      (($ $var sym)
-       (check-var sym v-env))
       (($ $void)
        #t)
       (($ $const val)
diff --git a/module/language/tree-il/compile-cps.scm 
b/module/language/tree-il/compile-cps.scm
index c705694..6375118 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -185,7 +185,8 @@
                knext
                (lambda (k)
                  (build-cps-term
-                   ($letk ((kbound ($kargs () () ($continue k src ($var sym))))
+                   ($letk ((kbound ($kargs () () ($continue k src
+                                                   ($values (sym)))))
                            (kunbound ($kargs () () ,(convert init k subst))))
                      ,(unbound? src sym kunbound kbound))))))))))))
 
@@ -231,8 +232,8 @@
     (($ <lexical-ref> src name sym)
      (match (assq-ref subst sym)
        ((box #t) (build-cps-term ($continue k src ($primcall 'box-ref (box)))))
-       ((subst #f) (build-cps-term ($continue k src ($var subst))))
-       (#f (build-cps-term ($continue k src ($var sym))))))
+       ((subst #f) (build-cps-term ($continue k src ($values (subst)))))
+       (#f (build-cps-term ($continue k src ($values (sym)))))))
 
     (($ <void> src)
      (build-cps-term ($continue k src ($void))))
@@ -522,7 +523,7 @@
               (_ (convert-arg test
                    (lambda (test)
                      (build-cps-term
-                       ($continue kif src ($var test)))))))))))
+                       ($continue kif src ($values (test))))))))))))
 
     (($ <lexical-set> src name gensym exp)
      (convert-arg exp


hooks/post-receive
-- 
GNU Guile



reply via email to

[Prev in Thread] Current Thread [Next in Thread]