Function defined by make-cont-folder takes a cont, not a $fun

* module/language/cps.scm (make-cont-folder): Take a cont instead of a
  $fun.
  (with-fresh-name-state): Adapt.

* module/language/cps/cse.scm (compute-label-and-var-ranges):
* module/language/cps/dce.scm (compute-live-code):
* module/language/cps/dfg.scm (compute-dfg):
* module/language/cps/elide-values.scm (elide-values):
* module/language/cps/reify-primitives.scm (reify-primitives):
* module/language/cps/renumber.scm (compute-new-labels-and-vars):
  (renumber): Adapt.

diff --git a/module/language/cps.scm b/module/language/cps.scm
index 056a71f..e6cb3cb 100644 (file)
--- a/module/language/cps.scm
+++ b/module/language/cps.scm
@@ -216,7 +216,9 @@
 
 (define-syntax-rule (with-fresh-name-state fun body ...)
   (call-with-values (lambda ()
-                      (compute-max-label-and-var fun))
+                      (match fun
+                        (($ $fun free fun-k)
+                         (compute-max-label-and-var fun-k))))
     (lambda (max-label max-var)
       (parameterize ((label-counter (1+ max-label))
                      (var-counter (1+ max-var)))
@@ -451,7 +453,7 @@
      (error "unexpected cps" exp))))
 
 (define-syntax-rule (make-cont-folder global? seed ...)
-  (lambda (proc fun seed ...)
+  (lambda (proc cont seed ...)
     (define (fold-values proc in seed ...)
       (if (null? in)
           (values seed ...)
@@ -505,7 +507,7 @@
                (fold-values fun-folder funs seed ...)
                (values seed ...))))))
 
-    (fun-folder fun seed ...)))
+    (cont-folder cont seed ...)))
 
 (define (compute-max-label-and-var fun)
   ((make-cont-folder #t max-label max-var)

diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index 9ce4975..5b97c59 100644 (file)
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.scm
@@ -229,7 +229,7 @@ be that both true and false proofs are available."
 
 (define (compute-label-and-var-ranges fun)
   (match fun
-    (($ $fun free ($ $cont kfun ($ $kfun src meta self)))
+    (($ $fun free (and body ($ $cont kfun ($ $kfun src meta self))))
      ((make-cont-folder #f min-label label-count min-var var-count)
       (lambda (k cont min-label label-count min-var var-count)
         (let ((min-label (min k min-label))
@@ -250,7 +250,7 @@ be that both true and false proofs are available."
              (values min-label label-count (min self min-var) (1+ var-count)))
             (_
              (values min-label label-count min-var var-count)))))
-      fun kfun 0 self 0))))
+      body kfun 0 self 0))))
 
 (define (compute-idoms dfg min-label label-count)
   (define (label->idx label) (- label min-label))

diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm
index 73ae7e3..6c96fde 100644 (file)
--- a/module/language/cps/dce.scm
+++ b/module/language/cps/dce.scm
@@ -90,10 +90,12 @@
     (define (ensure-fun-data fun)
       (or (hashq-ref fun-data-table fun)
           (call-with-values (lambda ()
-                              ((make-cont-folder #f label-count max-label)
-                               (lambda (k cont label-count max-label)
-                                 (values (1+ label-count) (max k max-label)))
-                               fun 0 -1))
+                              (match fun
+                                (($ $fun free body)
+                                 ((make-cont-folder #f label-count max-label)
+                                  (lambda (k cont label-count max-label)
+                                    (values (1+ label-count) (max k max-label)))
+                                  body 0 -1))))
             (lambda (label-count max-label)
               (let* ((min-label (- (1+ max-label) label-count))
                      (effects (compute-effects dfg min-label label-count))

diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm
index a3d6b5a..816a8dc 100644 (file)
--- a/module/language/cps/dfg.scm
+++ b/module/language/cps/dfg.scm
@@ -895,23 +895,25 @@ body continuation in the prompt."
       (do-fold #f)))
 
 (define* (compute-dfg fun #:key (global? #t))
-  (call-with-values (lambda () (compute-label-and-var-ranges fun global?))
-    (lambda (min-label max-label label-count min-var max-var var-count)
-      (when (or (zero? label-count) (zero? var-count))
-        (error "internal error (no vars or labels for fun?)"))
-      (let* ((nlabels (- (1+ max-label) min-label))
-             (nvars (- (1+ max-var) min-var))
-             (conts (make-vector nlabels #f))
-             (preds (make-vector nlabels '()))
-             (defs (make-vector nvars #f))
-             (uses (make-vector nvars '()))
-             (scopes (make-vector nlabels #f))
-             (scope-levels (make-vector nlabels #f)))
-        (visit-fun fun conts preds defs uses scopes scope-levels
-                   min-label min-var global?)
-        (make-dfg conts preds defs uses scopes scope-levels
-                  min-label max-label label-count
-                  min-var max-var var-count)))))
+  (match fun
+    (($ $fun free body)
+     (call-with-values (lambda () (compute-label-and-var-ranges body global?))
+       (lambda (min-label max-label label-count min-var max-var var-count)
+         (when (or (zero? label-count) (zero? var-count))
+           (error "internal error (no vars or labels for fun?)"))
+         (let* ((nlabels (- (1+ max-label) min-label))
+                (nvars (- (1+ max-var) min-var))
+                (conts (make-vector nlabels #f))
+                (preds (make-vector nlabels '()))
+                (defs (make-vector nvars #f))
+                (uses (make-vector nvars '()))
+                (scopes (make-vector nlabels #f))
+                (scope-levels (make-vector nlabels #f)))
+           (visit-fun fun conts preds defs uses scopes scope-levels
+                      min-label min-var global?)
+           (make-dfg conts preds defs uses scopes scope-levels
+                     min-label max-label label-count
+                     min-var max-var var-count)))))))
 
 (define-syntax-rule (with-fresh-name-state-from-dfg dfg body ...)
   (parameterize ((label-counter (1+ (dfg-max-label dfg)))

diff --git a/module/language/cps/elide-values.scm b/module/language/cps/elide-values.scm
index e75aa98..754bcc7 100644 (file)
--- a/module/language/cps/elide-values.scm
+++ b/module/language/cps/elide-values.scm
@@ -103,6 +103,8 @@
      ($fun free ,(visit-cont body)))))
 
 (define (elide-values fun)
-  (with-fresh-name-state fun
-    (let ((conts (build-cont-table fun)))
-      (elide-values* fun conts))))
+  (match fun
+    (($ $fun free funk)
+     (with-fresh-name-state fun
+       (let ((conts (build-cont-table funk)))
+         (elide-values* fun conts))))))

diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm
index 3c5e5bc..c34d6c6 100644 (file)
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -107,61 +107,63 @@
 
 ;; FIXME: Operate on one function at a time, for efficiency.
 (define (reify-primitives fun)
-  (with-fresh-name-state fun
-    (let ((conts (build-cont-table fun)))
-      (define (visit-fun term)
-        (rewrite-cps-exp term
-          (($ $fun free body)
-           ($fun free ,(visit-cont body)))))
-      (define (visit-cont cont)
-        (rewrite-cps-cont cont
-          (($ $cont sym ($ $kargs names syms body))
-           (sym ($kargs names syms ,(visit-term body))))
-          (($ $cont sym ($ $kfun src meta self (and tail ($ $cont ktail)) #f))
-           ;; A case-lambda with no clauses.  Reify a clause.
-           (sym ($kfun src meta self ,tail ,(reify-clause ktail))))
-          (($ $cont sym ($ $kfun src meta self tail clause))
-           (sym ($kfun src meta self ,tail ,(visit-cont clause))))
-          (($ $cont sym ($ $kclause arity body alternate))
-           (sym ($kclause ,arity ,(visit-cont body)
-                          ,(and alternate (visit-cont alternate)))))
-          (($ $cont)
-           ,cont)))
-      (define (visit-term term)
-        (rewrite-cps-term term
-          (($ $letk conts body)
-           ($letk ,(map visit-cont conts) ,(visit-term body)))
-          (($ $continue k src exp)
-           ,(match exp
-              (($ $prim name)
-               (match (vector-ref conts k)
-                 (($ $kargs (_))
+  (match fun
+    (($ $fun free body)
+     (with-fresh-name-state fun
+       (let ((conts (build-cont-table body)))
+         (define (visit-fun term)
+           (rewrite-cps-exp term
+             (($ $fun free body)
+              ($fun free ,(visit-cont body)))))
+         (define (visit-cont cont)
+           (rewrite-cps-cont cont
+             (($ $cont sym ($ $kargs names syms body))
+              (sym ($kargs names syms ,(visit-term body))))
+             (($ $cont sym ($ $kfun src meta self (and tail ($ $cont ktail)) #f))
+              ;; A case-lambda with no clauses.  Reify a clause.
+              (sym ($kfun src meta self ,tail ,(reify-clause ktail))))
+             (($ $cont sym ($ $kfun src meta self tail clause))
+              (sym ($kfun src meta self ,tail ,(visit-cont clause))))
+             (($ $cont sym ($ $kclause arity body alternate))
+              (sym ($kclause ,arity ,(visit-cont body)
+                             ,(and alternate (visit-cont alternate)))))
+             (($ $cont)
+              ,cont)))
+         (define (visit-term term)
+           (rewrite-cps-term term
+             (($ $letk conts body)
+              ($letk ,(map visit-cont conts) ,(visit-term body)))
+             (($ $continue k src exp)
+              ,(match exp
+                 (($ $prim name)
+                  (match (vector-ref conts k)
+                    (($ $kargs (_))
+                     (cond
+                      ((builtin-name->index name)
+                       => (lambda (idx)
+                            (builtin-ref idx k src)))
+                      (else (primitive-ref name k src))))
+                    (_ (build-cps-term ($continue k src ($void))))))
+                 (($ $fun)
+                  (build-cps-term ($continue k src ,(visit-fun exp))))
+                 (($ $primcall 'call-thunk/no-inline (proc))
+                  (build-cps-term
+                    ($continue k src ($call proc ()))))
+                 (($ $primcall name args)
                   (cond
-                   ((builtin-name->index name)
-                    => (lambda (idx)
-                         (builtin-ref idx k src)))
-                   (else (primitive-ref name k src))))
-                 (_ (build-cps-term ($continue k src ($void))))))
-              (($ $fun)
-               (build-cps-term ($continue k src ,(visit-fun exp))))
-              (($ $primcall 'call-thunk/no-inline (proc))
-               (build-cps-term
-                 ($continue k src ($call proc ()))))
-              (($ $primcall name args)
-               (cond
-                ((or (prim-instruction name) (branching-primitive? name))
-                 ;; Assume arities are correct.
-                 term)
-                (else
-                 (let-fresh (k*) (v)
-                   (build-cps-term
-                     ($letk ((k* ($kargs (v) (v)
-                                   ($continue k src ($call v args)))))
-                       ,(cond
-                         ((builtin-name->index name)
-                          => (lambda (idx)
-                               (builtin-ref idx k* src)))
-                         (else (primitive-ref name k* src)))))))))
-              (_ term)))))
-
-      (visit-fun fun))))
+                   ((or (prim-instruction name) (branching-primitive? name))
+                    ;; Assume arities are correct.
+                    term)
+                   (else
+                    (let-fresh (k*) (v)
+                      (build-cps-term
+                        ($letk ((k* ($kargs (v) (v)
+                                      ($continue k src ($call v args)))))
+                          ,(cond
+                            ((builtin-name->index name)
+                             => (lambda (idx)
+                                  (builtin-ref idx k* src)))
+                            (else (primitive-ref name k* src)))))))))
+                 (_ term)))))
+
+         (visit-fun fun))))))

diff --git a/module/language/cps/renumber.scm b/module/language/cps/renumber.scm
index 1415f8c..217d6b0 100644 (file)
--- a/module/language/cps/renumber.scm
+++ b/module/language/cps/renumber.scm
@@ -74,7 +74,10 @@
             (lp (1+ n) next))))))
 
 (define (compute-new-labels-and-vars fun)
-  (call-with-values (lambda () (compute-max-label-and-var fun))
+  (call-with-values (lambda ()
+                      (match fun
+                        (($ $fun free body)
+                         (compute-max-label-and-var body))))
     (lambda (max-label max-var)
       (let ((labels (make-vector (1+ max-label) #f))
             (next-label 0)
@@ -177,88 +180,90 @@
         (values labels vars next-label next-var)))))
 
 (define (renumber fun)
-  (call-with-values (lambda () (compute-new-labels-and-vars fun))
-    (lambda (labels vars nlabels nvars)
-      (define (relabel label) (vector-ref labels label))
-      (define (rename var) (vector-ref vars var))
-      (define (rename-kw-arity arity)
-        (match arity
-          (($ $arity req opt rest kw aok?)
-           (make-$arity req opt rest
-                        (map (match-lambda
-                              ((kw kw-name kw-var)
-                               (list kw kw-name (rename kw-var))))
-                             kw)
-                        aok?))))
-      (define (must-visit-cont cont)
-        (or (visit-cont cont)
-            (error "internal error -- failed to visit cont")))
-      (define (visit-conts conts)
-        (match conts
-          (() '())
-          ((cont . conts)
-           (cond
-            ((visit-cont cont)
-             => (lambda (cont)
-                  (cons cont (visit-conts conts))))
-            (else (visit-conts conts))))))
-      (define (visit-cont cont)
-        (match cont
-          (($ $cont label cont)
-           (let ((label (relabel label)))
-             (and
-              label
-              (rewrite-cps-cont cont
-                (($ $kargs names vars body)
-                 (label ($kargs names (map rename vars) ,(visit-term body))))
-                (($ $kfun src meta self tail clause)
-                 (label
-                  ($kfun src meta (rename self) ,(must-visit-cont tail)
-                    ,(and clause (must-visit-cont clause)))))
-                (($ $ktail)
-                 (label ($ktail)))
-                (($ $kclause arity body alternate)
-                 (label
-                  ($kclause ,(rename-kw-arity arity) ,(must-visit-cont body)
-                            ,(and alternate (must-visit-cont alternate)))))
-                (($ $kreceive ($ $arity req () rest () #f) kargs)
-                 (label ($kreceive req rest (relabel kargs))))
-                (($ $kif kt kf)
-                 (label ($kif (relabel kt) (relabel kf))))))))))
-      (define (visit-term term)
-        (rewrite-cps-term term
-          (($ $letk conts body)
-           ,(match (visit-conts conts)
-              (() (visit-term body))
-              (conts (build-cps-term ($letk ,conts ,(visit-term body))))))
-          (($ $letrec names vars funs body)
-           ($letrec names (map rename vars) (map visit-fun funs)
-                    ,(visit-term body)))
-          (($ $continue k src exp)
-           ($continue (relabel k) src ,(visit-exp exp)))))
-      (define (visit-exp exp)
-        (match exp
-          ((or ($ $void) ($ $const) ($ $prim))
-           exp)
-          (($ $fun)
-           (visit-fun exp))
-          (($ $values args)
-           (let ((args (map rename args)))
-             (build-cps-exp ($values args))))
-          (($ $call proc args)
-           (let ((args (map rename args)))
-             (build-cps-exp ($call (rename proc) args))))
-          (($ $callk k proc args)
-           (let ((args (map rename args)))
-             (build-cps-exp ($callk (relabel k) (rename proc) args))))
-          (($ $primcall name args)
-           (let ((args (map rename args)))
-             (build-cps-exp ($primcall name args))))
-          (($ $prompt escape? tag handler)
-           (build-cps-exp
-             ($prompt escape? (rename tag) (relabel handler))))))
-      (define (visit-fun fun)
-        (rewrite-cps-exp fun
-          (($ $fun free body)
-           ($fun (map rename free) ,(must-visit-cont body)))))
-      (values (visit-fun fun) nlabels nvars))))
+  (match fun
+    (($ $fun free cont)
+     (call-with-values (lambda () (compute-new-labels-and-vars fun))
+       (lambda (labels vars nlabels nvars)
+         (define (relabel label) (vector-ref labels label))
+         (define (rename var) (vector-ref vars var))
+         (define (rename-kw-arity arity)
+           (match arity
+             (($ $arity req opt rest kw aok?)
+              (make-$arity req opt rest
+                           (map (match-lambda
+                                 ((kw kw-name kw-var)
+                                  (list kw kw-name (rename kw-var))))
+                                kw)
+                           aok?))))
+         (define (must-visit-cont cont)
+           (or (visit-cont cont)
+               (error "internal error -- failed to visit cont")))
+         (define (visit-conts conts)
+           (match conts
+             (() '())
+             ((cont . conts)
+              (cond
+               ((visit-cont cont)
+                => (lambda (cont)
+                     (cons cont (visit-conts conts))))
+               (else (visit-conts conts))))))
+         (define (visit-cont cont)
+           (match cont
+             (($ $cont label cont)
+              (let ((label (relabel label)))
+                (and
+                 label
+                 (rewrite-cps-cont cont
+                   (($ $kargs names vars body)
+                    (label ($kargs names (map rename vars) ,(visit-term body))))
+                   (($ $kfun src meta self tail clause)
+                    (label
+                     ($kfun src meta (rename self) ,(must-visit-cont tail)
+                       ,(and clause (must-visit-cont clause)))))
+                   (($ $ktail)
+                    (label ($ktail)))
+                   (($ $kclause arity body alternate)
+                    (label
+                     ($kclause ,(rename-kw-arity arity) ,(must-visit-cont body)
+                               ,(and alternate (must-visit-cont alternate)))))
+                   (($ $kreceive ($ $arity req () rest () #f) kargs)
+                    (label ($kreceive req rest (relabel kargs))))
+                   (($ $kif kt kf)
+                    (label ($kif (relabel kt) (relabel kf))))))))))
+         (define (visit-term term)
+           (rewrite-cps-term term
+             (($ $letk conts body)
+              ,(match (visit-conts conts)
+                 (() (visit-term body))
+                 (conts (build-cps-term ($letk ,conts ,(visit-term body))))))
+             (($ $letrec names vars funs body)
+              ($letrec names (map rename vars) (map visit-fun funs)
+                       ,(visit-term body)))
+             (($ $continue k src exp)
+              ($continue (relabel k) src ,(visit-exp exp)))))
+         (define (visit-exp exp)
+           (match exp
+             ((or ($ $void) ($ $const) ($ $prim))
+              exp)
+             (($ $fun)
+              (visit-fun exp))
+             (($ $values args)
+              (let ((args (map rename args)))
+                (build-cps-exp ($values args))))
+             (($ $call proc args)
+              (let ((args (map rename args)))
+                (build-cps-exp ($call (rename proc) args))))
+             (($ $callk k proc args)
+              (let ((args (map rename args)))
+                (build-cps-exp ($callk (relabel k) (rename proc) args))))
+             (($ $primcall name args)
+              (let ((args (map rename args)))
+                (build-cps-exp ($primcall name args))))
+             (($ $prompt escape? tag handler)
+              (build-cps-exp
+                ($prompt escape? (rename tag) (relabel handler))))))
+         (define (visit-fun fun)
+           (rewrite-cps-exp fun
+             (($ $fun free body)
+              ($fun (map rename free) ,(must-visit-cont body)))))
+         (values (visit-fun fun) nlabels nvars))))))