Add $code CPS expression type

* module/language/cps.scm ($code): New CPS type, for labels as values.
  Add cases to all CPS type dispatches.  $closure now indicates only
  statically allocated closures.
* module/language/cps/closure-conversion.scm (convert-one): Only reify
  $closure for statically allocated procedures.  Otherwise allocate an
  object using low-level primitives.
* module/language/cps/compile-bytecode.scm (compile-function): Remove
  make-closure case.
* module/language/cps/slot-allocation.scm (compute-var-representations):
  $code produces a u64 value.
* module/system/vm/assembler.scm: Remove make-closure export.
* module/language/cps/contification.scm:
* module/language/cps/cse.scm:
* module/language/cps/dce.scm:
* module/language/cps/devirtualize-integers.scm:
* module/language/cps/effects-analysis.scm:
* module/language/cps/licm.scm:
* module/language/cps/peel-loops.scm:
* module/language/cps/renumber.scm:
* module/language/cps/rotate-loops.scm:
* module/language/cps/simplify.scm:
* module/language/cps/specialize-numbers.scm:
* module/language/cps/types.scm:
* module/language/cps/utils.scm:
* module/language/cps/verify.scm: Add cases for $code.

19 files changed, 68 insertions, 22 deletions

diff --git a/module/language/cps.scm b/module/language/cps.scm
index 55b34c949..d4c42ac09 100644
--- a/module/language/cps.scm
+++ b/module/language/cps.scm
@@ -130,7 +130,7 @@
             $continue $branch $prompt $throw
 
             ;; Expressions.
-            $const $prim $fun $rec $closure
+            $const $prim $fun $rec $closure $code
             $call $callk $primcall $values
 
             ;; Building macros.
@@ -189,6 +189,7 @@
 (define-cps-type $fun body) ; Higher-order.
 (define-cps-type $rec names syms funs) ; Higher-order.
 (define-cps-type $closure label nfree) ; First-order.
+(define-cps-type $code label) ; First-order.
 (define-cps-type $call proc args)
 (define-cps-type $callk k proc args) ; First-order.
 (define-cps-type $primcall name param args)
@@ -242,7 +243,7 @@
 
 (define-syntax build-exp
   (syntax-rules (unquote
-                 $const $prim $fun $rec $closure
+                 $const $prim $fun $rec $closure $code
                  $call $callk $primcall $values)
     ((_ (unquote exp)) exp)
     ((_ ($const val)) (make-$const val))
@@ -250,6 +251,7 @@
     ((_ ($fun kentry)) (make-$fun kentry))
     ((_ ($rec names gensyms funs)) (make-$rec names gensyms funs))
     ((_ ($closure k nfree)) (make-$closure k nfree))
+    ((_ ($code k)) (make-$code k))
     ((_ ($call proc (unquote args))) (make-$call proc args))
     ((_ ($call proc (arg ...))) (make-$call proc (list arg ...)))
     ((_ ($call proc args)) (make-$call proc args))
@@ -313,6 +315,8 @@
      (build-exp ($fun kbody)))
     (('closure k nfree)
      (build-exp ($closure k nfree)))
+    (('code k)
+     (build-exp ($code k)))
     (('rec (name sym fun) ...)
      (build-exp ($rec name sym (map parse-cps fun))))
     (('call proc arg ...)
@@ -362,6 +366,8 @@
      `(fun ,kbody))
     (($ $closure k nfree)
      `(closure ,k ,nfree))
+    (($ $code k)
+     `(code ,k))
     (($ $rec names syms funs)
      `(rec ,@(map (lambda (name sym fun)
                     (list name sym (unparse-cps fun)))
diff --git a/module/language/cps/closure-conversion.scm b/module/language/cps/closure-conversion.scm
index 4f9296397..746e5cebe 100644
--- a/module/language/cps/closure-conversion.scm
+++ b/module/language/cps/closure-conversion.scm
@@ -19,9 +19,8 @@
 ;;; Commentary:
 ;;;
 ;;; This pass converts a CPS term in such a way that no function has any
-;;; free variables.  Instead, closures are built explicitly with
-;;; make-closure primcalls, and free variables are referenced through
-;;; the closure.
+;;; free variables.  Instead, closures are built explicitly as heap
+;;; objects, and free variables are referenced through the closure.
 ;;;
 ;;; Closure conversion also removes any $rec expressions that
 ;;; contification did not handle.  See (language cps) for a further
@@ -520,10 +519,36 @@ term."
     (define (allocate-closure cps k src label known? nfree)
       "Allocate a new closure, and pass it to $var{k}."
       (match (vector known? nfree)
+        (#(#f 0)
+         ;; The call sites cannot be enumerated, but the closure has no
+         ;; identity; statically allocate it.
+         (with-cps cps
+           (build-term ($continue k src ($closure label 0)))))
         (#(#f nfree)
          ;; The call sites cannot be enumerated; allocate a closure.
          (with-cps cps
-           (build-term ($continue k src ($closure label nfree)))))
+           (letv closure tag code)
+           (letk k* ($kargs () ()
+                      ($continue k src ($values (closure)))))
+           (letk kinit ($kargs ('code) (code)
+                         ($continue k* src
+                           ($primcall 'word-set!/immediate '(closure . 1)
+                                      (closure code)))))
+           (letk kcode ($kargs () ()
+                         ($continue kinit src ($code label))))
+           (letk ktag1
+                 ($kargs ('tag) (tag)
+                   ($continue kcode src
+                     ($primcall 'word-set!/immediate '(closure . 0)
+                                (closure tag)))))
+           (letk ktag0
+                 ($kargs ('closure) (closure)
+                   ($continue ktag1 src
+                     ($primcall 'load-u64 (+ %tc7-program (ash nfree 16)) ()))))
+           (build-term
+             ($continue ktag0 src
+               ($primcall 'allocate-words/immediate `(closure . ,(+ nfree 2))
+                          ())))))
         (#(#t 2)
          ;; Well-known closure with two free variables; the closure is a
          ;; pair.
diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm
index bcd535f0c..f9eb8a44d 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -137,8 +137,8 @@
          (emit-load-constant asm (from-sp dst) exp))
         (($ $closure k 0)
          (emit-load-static-procedure asm (from-sp dst) k))
-        (($ $closure k nfree)
-         (emit-make-closure asm (from-sp dst) k nfree))
+        (($ $code k)
+         (emit-load-label asm (from-sp dst) k))
         (($ $primcall 'current-module)
          (emit-current-module asm (from-sp dst)))
         (($ $primcall 'current-thread)
diff --git a/module/language/cps/contification.scm b/module/language/cps/contification.scm
index 934ae5eea..6401a0b0a 100644
--- a/module/language/cps/contification.scm
+++ b/module/language/cps/contification.scm
@@ -169,7 +169,7 @@ $call, and are always called with a compatible arity."
       (match cont
         (($ $kargs _ _ ($ $continue _ _ exp))
          (match exp
-           ((or ($ $const) ($ $prim) ($ $closure) ($ $fun) ($ $rec))
+           ((or ($ $const) ($ $prim) ($ $closure) ($ $code) ($ $fun) ($ $rec))
             functions)
            (($ $values args)
             (exclude-vars functions args))
diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index 395614547..01b38b6e6 100644
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.scm
@@ -215,6 +215,7 @@ false.  It could be that both true and false proofs are available."
              (($ $fun body) #f)
              (($ $rec names syms funs) #f)
              (($ $closure label nfree) #f)
+             (($ $code label) (cons 'code label))
              (($ $call proc args) #f)
              (($ $callk k proc args) #f)
              (($ $primcall name param args)
@@ -360,7 +361,7 @@ false.  It could be that both true and false proofs are available."
 
   (define (visit-exp exp)
     (rewrite-exp exp
-      ((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure)) ,exp)
+      ((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure) ($ $code)) ,exp)
       (($ $call proc args)
        ($call (subst-var proc) ,(map subst-var args)))
       (($ $callk k proc args)
diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm
index 40f501a9d..3ee0f00f0 100644
--- a/module/language/cps/dce.scm
+++ b/module/language/cps/dce.scm
@@ -136,6 +136,8 @@ sites."
          (values (intset-add live-labels body) live-vars))
         (($ $closure body)
          (values (intset-add live-labels body) live-vars))
+        (($ $code body)
+         (values (intset-add live-labels body) live-vars))
         (($ $rec names vars (($ $fun kfuns) ...))
          (let lp ((vars vars) (kfuns kfuns)
                   (live-labels live-labels) (live-vars live-vars))
diff --git a/module/language/cps/devirtualize-integers.scm b/module/language/cps/devirtualize-integers.scm
index c4b875d35..d45287baf 100644
--- a/module/language/cps/devirtualize-integers.scm
+++ b/module/language/cps/devirtualize-integers.scm
@@ -63,7 +63,7 @@
          (match term
            (($ $continue k src exp)
             (match exp
-              ((or ($ $const) ($ $prim) ($ $fun) ($ $closure) ($ $rec))
+              ((or ($ $const) ($ $prim) ($ $fun) ($ $closure) ($ $code) ($ $rec))
                use-counts)
               (($ $values args)
                (add-uses use-counts args))
diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm
index b19027df9..684adef90 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -558,7 +558,7 @@ the LABELS that are clobbered by the effects of LABEL."
 
 (define (expression-effects exp)
   (match exp
-    ((or ($ $const) ($ $prim) ($ $values))
+    ((or ($ $const) ($ $prim) ($ $values) ($ $code))
      &no-effects)
     (($ $closure _ 0)
      &no-effects)
diff --git a/module/language/cps/licm.scm b/module/language/cps/licm.scm
index 4a8252885..622940ed8 100644
--- a/module/language/cps/licm.scm
+++ b/module/language/cps/licm.scm
@@ -67,7 +67,7 @@
                              (not (effect-clobbers? fx* fx))))
                       loop-effects #t))
      (match exp
-       ((or ($ $const) ($ $prim) ($ $closure)) #t)
+       ((or ($ $const) ($ $prim) ($ $closure) ($ $code)) #t)
        (($ $primcall name param args)
         (and-map (lambda (arg) (not (intset-ref loop-vars arg)))
                  args))
diff --git a/module/language/cps/peel-loops.scm b/module/language/cps/peel-loops.scm
index 43e986935..46a44622a 100644
--- a/module/language/cps/peel-loops.scm
+++ b/module/language/cps/peel-loops.scm
@@ -142,7 +142,7 @@
     (intmap-ref fresh-vars var (lambda (var) var)))
   (define (rename-exp exp)
     (rewrite-exp exp
-      ((or ($ $const) ($ $prim) ($ $closure) ($ $rec ())) ,exp)
+      ((or ($ $const) ($ $prim) ($ $closure) ($ $code) ($ $rec ())) ,exp)
       (($ $values args)
        ($values ,(map rename-var args)))
       (($ $call proc args)
diff --git a/module/language/cps/renumber.scm b/module/language/cps/renumber.scm
index 8b4996ed7..73a00cb5a 100644
--- a/module/language/cps/renumber.scm
+++ b/module/language/cps/renumber.scm
@@ -145,6 +145,8 @@
        ;; Closures with zero free vars get copy-propagated so it's
        ;; possible to already have visited them.
        (maybe-visit-fun kfun labels vars))
+      (($ $kargs names syms ($ $continue k src ($ $code kfun)))
+       (maybe-visit-fun kfun labels vars))
       (($ $kargs names syms ($ $continue k src ($ $callk kfun)))
        ;; Well-known functions never have a $closure created for them
        ;; and are only referenced by their $callk call sites.
@@ -169,6 +171,8 @@
         ((or ($ $const) ($ $prim)) ,exp)
         (($ $closure k nfree)
          ($closure (rename-label k) nfree))
+        (($ $code k)
+         ($code (rename-label k)))
         (($ $fun body)
          ($fun (rename-label body)))
         (($ $rec names vars funs)
diff --git a/module/language/cps/rotate-loops.scm b/module/language/cps/rotate-loops.scm
index 48be0d901..92198dffa 100644
--- a/module/language/cps/rotate-loops.scm
+++ b/module/language/cps/rotate-loops.scm
@@ -110,7 +110,7 @@ corresponding var from REPLACEMENTS; otherwise return VAR."
            (($ $continue k src exp)
             ($continue k src
               ,(rewrite-exp exp
-                 ((or ($ $const) ($ $prim) ($ $closure)) ,exp)
+                 ((or ($ $const) ($ $prim) ($ $closure) ($ $code)) ,exp)
                  (($ $values args)
                   ($values ,(rename* args)))
                  (($ $call proc args)
diff --git a/module/language/cps/simplify.scm b/module/language/cps/simplify.scm
index c50372b90..24963bc2d 100644
--- a/module/language/cps/simplify.scm
+++ b/module/language/cps/simplify.scm
@@ -68,7 +68,7 @@
     (match cont
       (($ $kargs _ _ ($ $continue _ _ exp))
        (match exp
-         ((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure))
+         ((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure) ($ $code))
           (values single multiple))
          (($ $call proc args)
           (ref* (cons proc args)))
@@ -250,7 +250,8 @@
             (($ $continue k src exp)
              ($continue k src
                ,(rewrite-exp exp
-                  ((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure))
+                  ((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure)
+                       ($ $code))
                    ,exp)
                   (($ $call proc args)
                    ($call (subst proc) ,(map subst args)))
diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm
index d3f7ce3de..a7a9ab57c 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -146,7 +146,7 @@ by a label, respectively."
          (return (intset self) empty-intset))
         (($ $kargs _ _ ($ $continue k src exp))
          (match exp
-           ((or ($ $const) ($ $closure))
+           ((or ($ $const) ($ $closure) ($ $code))
             (return (get-defs k) empty-intset))
            (($ $call proc args)
             (return (get-defs k) (intset-add (vars->intset args) proc)))
@@ -770,6 +770,8 @@ are comparable with eqv?.  A tmp slot may be used."
              (($ $primcall (or 'pointer-ref/immediate
                                'tail-pointer-ref/immediate))
               (intmap-add representations var 'ptr))
+             (($ $code)
+              (intmap-add representations var 'u64))
              (_
               (intmap-add representations var 'scm))))
           (vars
diff --git a/module/language/cps/specialize-numbers.scm b/module/language/cps/specialize-numbers.scm
index 578a04289..e7405a939 100644
--- a/module/language/cps/specialize-numbers.scm
+++ b/module/language/cps/specialize-numbers.scm
@@ -311,7 +311,8 @@ BITS indicating the significant bits needed for a variable.  BITS may be
                  (match term
                    (($ $continue k src exp)
                     (match exp
-                      ((or ($ $const) ($ $prim) ($ $fun) ($ $closure) ($ $rec))
+                      ((or ($ $const) ($ $prim) ($ $fun) ($ $closure)
+                           ($ $code) ($ $rec))
                        ;; No uses, so no info added to sigbits.
                        out)
                       (($ $values args)
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 9fb0df966..74a73bb84 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -1786,7 +1786,7 @@ maximum, where type is a bitset as a fixnum."
           (let ((entry (match exp
                          (($ $const val)
                           (constant-type val))
-                         ((or ($ $prim) ($ $fun) ($ $closure))
+                         ((or ($ $prim) ($ $fun) ($ $closure) ($ $code))
                           ;; Could be more precise here.
                           (make-type-entry &procedure -inf.0 +inf.0)))))
             (propagate1 k (adjoin-var types var entry))))))))
diff --git a/module/language/cps/utils.scm b/module/language/cps/utils.scm
index 77431b898..d1b207374 100644
--- a/module/language/cps/utils.scm
+++ b/module/language/cps/utils.scm
@@ -226,6 +226,7 @@ intset."
             (($ $fun label) (return1 label))
             (($ $rec _ _ (($ $fun labels) ...)) (return labels))
             (($ $closure label nfree) (return1 label))
+            (($ $code label) (return1 label))
             (($ $callk label) (return1 label))
             (_ (return0))))
          (_ (return0))))
diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm
index 938c37a52..e72d39522 100644
--- a/module/language/cps/verify.scm
+++ b/module/language/cps/verify.scm
@@ -148,6 +148,8 @@ definitions that are available at LABEL."
          (visit-fun kfun bound first-order))
         (($ $closure kfun)
          (visit-first-order kfun))
+        (($ $code kfun)
+         (visit-first-order kfun))
         (($ $rec names vars (($ $fun kfuns) ...))
          (let ((bound (fold1 adjoin-def vars bound)))
            (fold1 (lambda (kfun first-order)
@@ -184,6 +186,8 @@ definitions that are available at LABEL."
             (visit-fun kfun bound first-order))
            (($ $closure kfun)
             (visit-first-order kfun))
+           (($ $code kfun)
+            (visit-first-order kfun))
            (($ $rec names vars (($ $fun kfuns) ...))
             (let ((bound (fold1 adjoin-def vars bound)))
               (fold1 (lambda (kfun first-order)
@@ -262,7 +266,7 @@ definitions that are available at LABEL."
         ((or ($ $kreceive) ($ $ktail)) #t)
         (_ (error "expected $kreceive or $ktail continuation" cont))))
     (match exp
-      ((or ($ $const) ($ $prim) ($ $closure) ($ $fun))
+      ((or ($ $const) ($ $prim) ($ $closure) ($ $code) ($ $fun))
        (assert-unary))
       (($ $rec names vars funs)
        (unless (= (length names) (length vars) (length funs))
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index b3d2bb2f2..3e36dfe5b 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -215,7 +215,6 @@
             emit-assert-nargs-ee/locals
             emit-bind-kwargs
             emit-bind-rest
-            emit-make-closure
             emit-load-label
             emit-current-module
             emit-resolve