src and meta are fields of $kentry, not $fun

* module/language/cps.scm ($kentry, $fun): Attach "src" and "meta" on
  the $kentry, not the $fun.  This prepares us for $callk to $kentry
  continuations that have no corresponding $fun.

* module/language/cps/arities.scm:
* module/language/cps/closure-conversion.scm:
* module/language/cps/compile-bytecode.scm:
* module/language/cps/constructors.scm:
* module/language/cps/contification.scm:
* module/language/cps/cse.scm:
* module/language/cps/dce.scm:
* module/language/cps/dfg.scm:
* module/language/cps/elide-values.scm:
* module/language/cps/prune-bailouts.scm:
* module/language/cps/prune-top-level-scopes.scm:
* module/language/cps/reify-primitives.scm:
* module/language/cps/renumber.scm:
* module/language/cps/self-references.scm:
* module/language/cps/simplify.scm:
* module/language/cps/slot-allocation.scm:
* module/language/cps/specialize-primcalls.scm:
* module/language/cps/verify.scm:
* module/language/tree-il/compile-cps.scm: Adapt.

diff --git a/.dir-locals.el b/.dir-locals.el
index 597f741..b9e2f2c 100644 (file)
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -26,9 +26,9 @@
      (eval . (put '$letconst           'scheme-indent-function 1))
      (eval . (put '$continue           'scheme-indent-function 2))
      (eval . (put '$kargs              'scheme-indent-function 2))
-     (eval . (put '$kentry             'scheme-indent-function 2))
+     (eval . (put '$kentry             'scheme-indent-function 4))
      (eval . (put '$kclause            'scheme-indent-function 1))
-     (eval . (put '$fun                'scheme-indent-function 2))))
+     (eval . (put '$fun                'scheme-indent-function 1))))
  (emacs-lisp-mode . ((indent-tabs-mode . nil)))
  (texinfo-mode    . ((indent-tabs-mode . nil)
                      (fill-column . 72))))

diff --git a/module/language/cps.scm b/module/language/cps.scm
index f546628..079da59 100644 (file)
--- a/module/language/cps.scm
+++ b/module/language/cps.scm
@@ -71,11 +71,11 @@
 ;;;     That's to say that a $fun can be matched like this:
 ;;;
 ;;;     (match f
-;;;       (($ $fun src meta free
+;;;       (($ $fun free
 ;;;           ($ $cont kentry
-;;;              ($ $kentry self ($ $cont ktail _ ($ $ktail))
+;;;              ($ $kentry src meta self ($ $cont ktail ($ $ktail))
 ;;;                 ($ $kclause arity
-;;;                    ($ $cont kbody _ ($ $kargs names syms body))
+;;;                    ($ $cont kbody ($ $kargs names syms body))
 ;;;                    alternate))))
 ;;;         #t))
 ;;;
@@ -179,7 +179,7 @@
 (define-cps-type $kif kt kf)
 (define-cps-type $kreceive arity k)
 (define-cps-type $kargs names syms body)
-(define-cps-type $kentry self tail clause)
+(define-cps-type $kentry src meta self tail clause)
 (define-cps-type $ktail)
 (define-cps-type $kclause arity cont alternate)
 
@@ -187,7 +187,7 @@
 (define-cps-type $void)
 (define-cps-type $const val)
 (define-cps-type $prim name)
-(define-cps-type $fun src meta free body)
+(define-cps-type $fun free body)
 (define-cps-type $call proc args)
 (define-cps-type $callk k proc args)
 (define-cps-type $primcall name args)
@@ -242,8 +242,8 @@
      (make-$kargs (list name ...) (list sym ...) (build-cps-term body)))
     ((_ ($kargs names syms body))
      (make-$kargs names syms (build-cps-term body)))
-    ((_ ($kentry self tail clause))
-     (make-$kentry self (build-cps-cont tail) (build-cps-cont clause)))
+    ((_ ($kentry src meta self tail clause))
+     (make-$kentry src meta self (build-cps-cont tail) (build-cps-cont clause)))
     ((_ ($ktail))
      (make-$ktail))
     ((_ ($kclause arity cont alternate))
@@ -262,8 +262,8 @@
     ((_ ($void)) (make-$void))
     ((_ ($const val)) (make-$const val))
     ((_ ($prim name)) (make-$prim name))
-    ((_ ($fun src meta free body))
-     (make-$fun src meta free (build-cps-cont body)))
+    ((_ ($fun free body))
+     (make-$fun free (build-cps-cont body)))
     ((_ ($call proc (unquote args))) (make-$call proc args))
     ((_ ($call proc (arg ...))) (make-$call proc (list arg ...)))
     ((_ ($call proc args)) (make-$call proc args))
@@ -344,9 +344,10 @@
      (build-cont-body ($kreceive req rest k)))
     (('kargs names syms body)
      (build-cont-body ($kargs names syms ,(parse-cps body))))
-    (('kentry self tail clause)
+    (('kentry src meta self tail clause)
      (build-cont-body
-      ($kentry self ,(parse-cps tail) ,(and=> clause parse-cps))))
+      ($kentry (src exp) meta self ,(parse-cps tail)
+        ,(and=> clause parse-cps))))
     (('ktail)
      (build-cont-body
       ($ktail)))
@@ -372,8 +373,8 @@
      (build-cps-exp ($const exp)))
     (('prim name)
      (build-cps-exp ($prim name)))
-    (('fun meta free body)
-     (build-cps-exp ($fun (src exp) meta free ,(parse-cps body))))
+    (('fun free body)
+     (build-cps-exp ($fun free ,(parse-cps body))))
     (('letrec ((name sym fun) ...) body)
      (build-cps-term
        ($letrec name sym (map parse-cps fun) ,(parse-cps body))))
@@ -412,8 +413,8 @@
      `(kseq ,(unparse-cps body)))
     (($ $kargs names syms body)
      `(kargs ,names ,syms ,(unparse-cps body)))
-    (($ $kentry self tail clause)
-     `(kentry ,self ,(unparse-cps tail) ,(unparse-cps clause)))
+    (($ $kentry src meta self tail clause)
+     `(kentry ,meta ,self ,(unparse-cps tail) ,(unparse-cps clause)))
     (($ $ktail)
      `(ktail))
     (($ $kclause ($ $arity req opt rest kw allow-other-keys?) body alternate)
@@ -429,8 +430,8 @@
      `(const ,val))
     (($ $prim name)
      `(prim ,name))
-    (($ $fun src meta free body)
-     `(fun ,meta ,free ,(unparse-cps body)))
+    (($ $fun free body)
+     `(fun ,free ,(unparse-cps body)))
     (($ $letrec names syms funs body)
      `(letrec ,(map (lambda (name sym fun)
                       (list name sym (unparse-cps fun)))
@@ -465,7 +466,7 @@
              (($ $kargs names syms body)
               (term-folder body seed ...))
 
-             (($ $kentry self tail clause)
+             (($ $kentry src meta self tail clause)
               (let-values (((seed ...) (cont-folder tail seed ...)))
                 (if clause
                     (cont-folder clause seed ...)
@@ -481,7 +482,7 @@
 
     (define (fun-folder fun seed ...)
       (match fun
-        (($ $fun src meta free body)
+        (($ $fun free body)
          (cont-folder body seed ...))))
 
     (define (term-folder term seed ...)
@@ -518,7 +519,7 @@
                     (($ $letrec names vars funs body)
                      (lp body (fold max max-var vars)))
                     (_ max-var))))
-               (($ $kentry self)
+               (($ $kentry src meta self)
                 (max self max-var))
                (_ max-var))))
    fun
@@ -551,8 +552,8 @@
 
     (($ $kclause arity ($ $cont kbody) ($ $cont kalt)) (proc kbody kalt))
 
-    (($ $kentry self tail ($ $cont clause)) (proc clause))
+    (($ $kentry src meta self tail ($ $cont clause)) (proc clause))
 
-    (($ $kentry self tail #f) (proc))
+    (($ $kentry src meta self tail #f) (proc))
 
     (($ $ktail) (proc))))

diff --git a/module/language/cps/arities.scm b/module/language/cps/arities.scm
index 8b9ce41..34b3269 100644 (file)
--- a/module/language/cps/arities.scm
+++ b/module/language/cps/arities.scm
@@ -34,7 +34,8 @@
 
 (define (fix-clause-arities clause dfg)
   (let ((ktail (match clause
-                 (($ $cont _ ($ $kentry _ ($ $cont ktail) _)) ktail))))
+                 (($ $cont _
+                     ($ $kentry src meta _ ($ $cont ktail) _)) ktail))))
     (define (visit-term term)
       (rewrite-cps-term term
         (($ $letk conts body)
@@ -181,13 +182,13 @@
          ,cont)))
 
     (rewrite-cps-cont clause
-      (($ $cont sym ($ $kentry self tail clause))
-       (sym ($kentry self ,tail ,(and clause (visit-cont clause))))))))
+      (($ $cont sym ($ $kentry src meta self tail clause))
+       (sym ($kentry src meta self ,tail ,(and clause (visit-cont clause))))))))
 
 (define (fix-arities* fun dfg)
   (rewrite-cps-exp fun
-    (($ $fun src meta free body)
-     ($fun src meta free ,(fix-clause-arities body dfg)))))
+    (($ $fun free body)
+     ($fun free ,(fix-clause-arities body dfg)))))
 
 (define (fix-arities fun)
   (let ((dfg (compute-dfg fun)))

diff --git a/module/language/cps/closure-conversion.scm b/module/language/cps/closure-conversion.scm
index 89c491f..16711f4 100644 (file)
--- a/module/language/cps/closure-conversion.scm
+++ b/module/language/cps/closure-conversion.scm
@@ -128,11 +128,11 @@ convert functions to flat closures."
        (values (build-cps-cont (sym ($kargs names syms ,body)))
                free)))
 
-    (($ $cont sym ($ $kentry self tail clause))
+    (($ $cont sym ($ $kentry src meta self tail clause))
      (receive (clause free) (if clause
                                 (cc clause self (list self))
                                 (values #f '()))
-       (values (build-cps-cont (sym ($kentry self ,tail ,clause)))
+       (values (build-cps-cont (sym ($kentry src meta self ,tail ,clause)))
                free)))
 
     (($ $cont sym ($ $kclause arity body alternate))
@@ -158,7 +158,8 @@ convert functions to flat closures."
                   (free free))
            (match in
              (() (values (bindings body) free))
-             (((name sym ($ $fun src meta () fun-body)) . in)
+             (((name sym ($ $fun () (and fun-body
+                                         ($ $cont _ ($ $kentry src))))) . in)
               (receive (fun-body fun-free) (cc fun-body #f '())
                 (lp in
                     (lambda (body)
@@ -166,7 +167,7 @@ convert functions to flat closures."
                         (build-cps-term
                           ($letk ((k ($kargs (name) (sym) ,(bindings body))))
                             ($continue k src
-                              ($fun src meta fun-free ,fun-body))))))
+                              ($fun fun-free ,fun-body))))))
                     (init-closure src sym fun-free self bound body)
                     (union free (difference fun-free bound))))))))))
 
@@ -176,12 +177,12 @@ convert functions to flat closures."
             ($ $prim)))
      (values exp '()))
 
-    (($ $continue k src ($ $fun src* meta () body))
+    (($ $continue k src ($ $fun () body))
      (receive (body free) (cc body #f '())
        (match free
          (()
           (values (build-cps-term
-                    ($continue k src ($fun src* meta free ,body)))
+                    ($continue k src ($fun free ,body)))
                   free))
          (_
           (values
@@ -192,7 +193,7 @@ convert functions to flat closures."
                                   src v free self bound
                                   (build-cps-term
                                     ($continue k src ($values (v))))))))
-                 ($continue kinit src ($fun src* meta free ,body)))))
+                 ($continue kinit src ($fun free ,body)))))
            (difference free bound))))))
 
     (($ $continue k src ($ $call proc args))
@@ -250,9 +251,9 @@ convert functions to flat closures."
           (build-cps-term
             ($letconst (('idx idx (free-index sym)))
               ($continue k src ($primcall 'free-ref (closure idx)))))))
-      (($ $continue k src ($ $fun src* meta free body))
+      (($ $continue k src ($ $fun free body))
        ($continue k src
-         ($fun src* meta free ,(convert-to-indices body free))))
+         ($fun free ,(convert-to-indices body free))))
       (($ $continue)
        ,term)))
   (define (visit-cont cont)
@@ -268,17 +269,17 @@ convert functions to flat closures."
        ,cont)))
 
   (rewrite-cps-cont body
-    (($ $cont sym ($ $kentry self tail clause))
-     (sym ($kentry self ,tail ,(and clause (visit-cont clause)))))))
+    (($ $cont sym ($ $kentry src meta self tail clause))
+     (sym ($kentry src meta self ,tail ,(and clause (visit-cont clause)))))))
 
 (define (convert-closures exp)
   "Convert free reference in @var{exp} to primcalls to @code{free-ref},
 and allocate and initialize flat closures."
   (with-fresh-name-state exp
     (match exp
-      (($ $fun src meta () body)
+      (($ $fun () body)
        (receive (body free) (cc body #f '())
          (unless (null? free)
            (error "Expected no free vars in toplevel thunk" exp body free))
          (build-cps-exp
-           ($fun src meta free ,(convert-to-indices body free))))))))
+           ($fun free ,(convert-to-indices body free))))))))

diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm
index bf87f2c..35cc12b 100644 (file)
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -113,10 +113,12 @@
                  (emit-load-constant asm slot val)
                  #t)))))
 
-    (define (compile-entry meta)
+    (define (compile-entry)
       (let ((label (dfg-min-label dfg)))
         (match (lookup-cont label dfg)
-          (($ $kentry self tail clause)
+          (($ $kentry src meta self tail clause)
+           (when src
+             (emit-source asm src))
            (emit-begin-program asm label meta)
            (compile-clause (1+ label))
            (emit-end-program asm)))))
@@ -243,9 +245,9 @@
          (emit-load-constant asm dst *unspecified*))
         (($ $const exp)
          (emit-load-constant asm dst exp))
-        (($ $fun src meta () ($ $cont k))
+        (($ $fun () ($ $cont k))
          (emit-load-static-procedure asm dst k))
-        (($ $fun src meta free ($ $cont k))
+        (($ $fun free ($ $cont k))
          (emit-make-closure asm dst k (length free)))
         (($ $primcall 'current-module)
          (emit-current-module asm dst))
@@ -469,18 +471,15 @@
                     (emit-call-label asm proc-slot nargs k))))))
 
     (match f
-      (($ $fun src meta free ($ $cont k ($ $kentry self tail clause)))
-       ;; FIXME: src on kentry instead?
-       (when src
-         (emit-source asm src))
-       (compile-entry (or meta '()))))))
+      (($ $fun free ($ $cont k ($ $kentry src meta self tail clause)))
+       (compile-entry)))))
 
 (define (visit-funs proc exp)
   (match exp
     (($ $continue _ _ exp)
      (visit-funs proc exp))
 
-    (($ $fun src meta free body)
+    (($ $fun free body)
      (proc exp)
      (visit-funs proc body))
 
@@ -496,7 +495,7 @@
      (when alternate
        (visit-funs proc alternate)))
 
-    (($ $cont sym ($ $kentry self tail clause))
+    (($ $cont sym ($ $kentry src meta self tail clause))
      (when clause
        (visit-funs proc clause)))
 

diff --git a/module/language/cps/constructors.scm b/module/language/cps/constructors.scm
index 4bb8670..9cebf57 100644 (file)
--- a/module/language/cps/constructors.scm
+++ b/module/language/cps/constructors.scm
@@ -34,8 +34,8 @@
     (rewrite-cps-cont cont
       (($ $cont sym ($ $kargs names syms body))
        (sym ($kargs names syms ,(visit-term body))))
-      (($ $cont sym ($ $kentry self tail clause))
-       (sym ($kentry self ,tail ,(and clause (visit-cont clause)))))
+      (($ $cont sym ($ $kentry src meta self tail clause))
+       (sym ($kentry src meta self ,tail ,(and clause (visit-cont clause)))))
       (($ $cont sym ($ $kclause arity body alternate))
        (sym ($kclause ,arity ,(visit-cont body)
                       ,(and alternate (visit-cont alternate)))))
@@ -95,8 +95,8 @@
        ,term)))
 
   (rewrite-cps-exp fun
-    (($ $fun src meta free body)
-     ($fun src meta free ,(visit-cont body)))))
+    (($ $fun free body)
+     ($fun free ,(visit-cont body)))))
 
 (define (inline-constructors fun)
   (with-fresh-name-state fun

diff --git a/module/language/cps/contification.scm b/module/language/cps/contification.scm
index a7e3d36..477e003 100644 (file)
--- a/module/language/cps/contification.scm
+++ b/module/language/cps/contification.scm
@@ -187,7 +187,7 @@
           (if (scope-contains? k-scope term-k)
               term-k
               (match (lookup-cont k-scope dfg)
-                (($ $kentry self tail clause)
+                (($ $kentry src meta self tail clause)
                  ;; K is the tail of some function.  If that function
                  ;; has just one clause, return that clause.  Otherwise
                  ;; bail.
@@ -219,13 +219,13 @@
 
     (define (visit-fun term)
       (match term
-        (($ $fun src meta free body)
+        (($ $fun free body)
          (visit-cont body))))
     (define (visit-cont cont)
       (match cont
         (($ $cont sym ($ $kargs _ _ body))
          (visit-term body sym))
-        (($ $cont sym ($ $kentry self tail clause))
+        (($ $cont sym ($ $kentry src meta self tail clause))
          (when clause (visit-cont clause)))
         (($ $cont sym ($ $kclause arity body alternate))
          (visit-cont body)
@@ -251,7 +251,7 @@
                 (if (null? rec)
                     '()
                     (list rec)))
-               (((and elt (n s ($ $fun src meta free ($ $cont kentry))))
+               (((and elt (n s ($ $fun free ($ $cont kentry))))
                  . nsf)
                 (if (recursive? kentry)
                     (lp nsf (cons elt rec))
@@ -263,9 +263,10 @@
            (match component
              (((name sym fun) ...)
               (match fun
-                ((($ $fun src meta free
+                ((($ $fun free
                      ($ $cont fun-k
-                        ($ $kentry self ($ $cont tail-k ($ $ktail)) clause)))
+                        ($ $kentry src meta self ($ $cont tail-k ($ $ktail))
+                           clause)))
                   ...)
                  (call-with-values (lambda () (extract-arities+bodies clause))
                    (lambda (arities bodies)
@@ -277,9 +278,9 @@
                    (split-components (map list names syms funs))))
         (($ $continue k src exp)
          (match exp
-           (($ $fun src meta free
+           (($ $fun free
                ($ $cont fun-k
-                  ($ $kentry self ($ $cont tail-k ($ $ktail)) clause)))
+                  ($ $kentry src meta self ($ $cont tail-k ($ $ktail)) clause)))
             (if (and=> (bound-symbol k)
                        (lambda (sym)
                          (contify-fun term-k sym self tail-k
@@ -340,8 +341,8 @@
               ,body)))))))
   (define (visit-fun term)
     (rewrite-cps-exp term
-      (($ $fun src meta free body)
-       ($fun src meta free ,(visit-cont body)))))
+      (($ $fun free body)
+       ($fun free ,(visit-cont body)))))
   (define (visit-cont cont)
     (rewrite-cps-cont cont
       (($ $cont (? (cut assq <> fun-elisions)))
@@ -349,8 +350,8 @@
        ,#f)
       (($ $cont sym ($ $kargs names syms body))
        (sym ($kargs names syms ,(visit-term body sym))))
-      (($ $cont sym ($ $kentry self tail clause))
-       (sym ($kentry self ,tail ,(and clause (visit-cont clause)))))
+      (($ $cont sym ($ $kentry src meta self tail clause))
+       (sym ($kentry src meta self ,tail ,(and clause (visit-cont clause)))))
       (($ $cont sym ($ $kclause arity body alternate))
        (sym ($kclause ,arity ,(visit-cont body)
                       ,(and alternate (visit-cont alternate)))))

diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index a0dea1a..89ea546 100644 (file)
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.scm
@@ -222,14 +222,14 @@ be that both true and false proofs are available."
            (($ $kclause arity ($ $cont kargs ($ $kargs names syms)))
             syms)
            (($ $kif) '())
-           (($ $kentry self) (list self))
+           (($ $kentry src meta self) (list self))
            (($ $ktail) '())))
         (lp (1+ n))))
     defs))
 
 (define (compute-label-and-var-ranges fun)
   (match fun
-    (($ $fun src meta free ($ $cont kentry ($ $kentry self)))
+    (($ $fun free ($ $cont kentry ($ $kentry 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))
@@ -246,7 +246,7 @@ be that both true and false proofs are available."
                       (+ var-count (length vars))))
                  (($ $letk conts body) (lp body min-var var-count))
                  (_ (values min-label label-count min-var var-count)))))
-            (($ $kentry self)
+            (($ $kentry src meta self)
              (values min-label label-count (min self min-var) (1+ var-count)))
             (_
              (values min-label label-count min-var var-count)))))
@@ -349,7 +349,7 @@ be that both true and false proofs are available."
           (($ $void) 'void)
           (($ $const val) (cons 'const val))
           (($ $prim name) (cons 'prim name))
-          (($ $fun src meta free body) #f)
+          (($ $fun free body) #f)
           (($ $call proc args) #f)
           (($ $callk k proc args) #f)
           (($ $primcall name args)
@@ -427,8 +427,8 @@ be that both true and false proofs are available."
     (rewrite-cps-cont cont
       (($ $cont label ($ $kargs names vars body))
        (label ($kargs names vars ,(visit-term body label))))
-      (($ $cont label ($ $kentry self tail clause))
-       (label ($kentry self ,tail
+      (($ $cont label ($ $kentry src meta self tail clause))
+       (label ($kentry src meta self ,tail
                 ,(and clause (visit-entry-cont clause)))))
       (($ $cont label ($ $kclause arity ($ $cont kbody body) alternate))
        (label ($kclause ,arity ,(visit-cont kbody body)
@@ -512,8 +512,8 @@ be that both true and false proofs are available."
                 ($letk ,conts ,(visit-exp* k src exp))))))))
 
   (rewrite-cps-exp fun
-    (($ $fun src meta free body)
-     ($fun src meta (map subst-var free) ,(visit-entry-cont body)))))
+    (($ $fun free body)
+     ($fun (map subst-var free) ,(visit-entry-cont body)))))
 
 (define (cse fun dfg)
   (call-with-values (lambda () (compute-equivalent-subexpressions fun dfg))

diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm
index 0aa08f7..ef6f3c4 100644 (file)
--- a/module/language/cps/dce.scm
+++ b/module/language/cps/dce.scm
@@ -71,7 +71,7 @@
            (($ $kclause arity ($ $cont kargs ($ $kargs names syms)))
             syms)
            (($ $kif) #f)
-           (($ $kentry self) (list self))
+           (($ $kentry src meta self) (list self))
            (($ $ktail) #f)))
         (lp (1+ n))))
     defs))
@@ -163,7 +163,7 @@
                  (($ $kif) #f)
                  (($ $kclause arity ($ $cont kargs ($ $kargs names syms body)))
                   (for-each mark-live! syms))
-                 (($ $kentry self)
+                 (($ $kentry src meta self)
                   (mark-live! self))
                  (($ $ktail) #f))
                (lp (1- n))))))))
@@ -209,10 +209,10 @@
                    (build-cps-cont
                      (label ($kargs names syms
                               ,(visit-term body label))))))))
-              (($ $kentry self tail clause)
+              (($ $kentry src meta self tail clause)
                (list
                 (build-cps-cont
-                  (label ($kentry self ,tail
+                  (label ($kentry src meta self ,tail
                            ,(and clause (visit-cont clause)))))))
               (($ $kclause arity body alternate)
                (list
@@ -275,8 +275,8 @@
                              ($continue adapt src ,exp))))))))
                 (build-cps-term ($continue k src ($values ())))))))
        (rewrite-cps-exp fun
-         (($ $fun src meta free body)
-          ($fun src meta free ,(visit-cont body)))))))
+         (($ $fun free body)
+          ($fun free ,(visit-cont body)))))))
   (visit-fun fun))
 
 (define (eliminate-dead-code fun)

diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm
index 3180e3d..af9130e 100644 (file)
--- a/module/language/cps/dfg.scm
+++ b/module/language/cps/dfg.scm
@@ -325,8 +325,8 @@ body continuation in the prompt."
       succs))
 
   (match fun
-    (($ $fun src meta free
-        ($ $cont kentry ($ $kentry self ($ $cont ktail tail))))
+    (($ $fun free
+        ($ $cont kentry ($ $kentry src meta self ($ $cont ktail tail))))
      (call-with-values
          (lambda ()
            (compute-reverse-control-flow-order ktail dfg))
@@ -821,10 +821,10 @@ body continuation in the prompt."
          (_ #f)))))
 
   (match fun
-    (($ $fun src meta free
+    (($ $fun free
         ($ $cont kentry
            (and entry
-                ($ $kentry self ($ $cont ktail tail) clause))))
+                ($ $kentry src meta self ($ $cont ktail tail) clause))))
      (declare-block! kentry entry #f 0)
      (add-def! self kentry)
 
@@ -883,7 +883,7 @@ body continuation in the prompt."
                               (else min-var))
                         (fold max max-var vars)
                         (+ var-count (length vars))))))
-           (($ $kentry self)
+           (($ $kentry src meta self)
             (values min-label max-label (1+ label-count)
                     (min* self min-var) (max self max-var) (1+ var-count)))
            (_ (values min-label max-label (1+ label-count)

diff --git a/module/language/cps/elide-values.scm b/module/language/cps/elide-values.scm
index c770f88..1eb94c5 100644 (file)
--- a/module/language/cps/elide-values.scm
+++ b/module/language/cps/elide-values.scm
@@ -40,8 +40,8 @@
     (rewrite-cps-cont cont
       (($ $cont sym ($ $kargs names syms body))
        (sym ($kargs names syms ,(visit-term body))))
-      (($ $cont sym ($ $kentry self tail clause))
-       (sym ($kentry self ,tail ,(and clause (visit-cont clause)))))
+      (($ $cont sym ($ $kentry src meta self tail clause))
+       (sym ($kentry src meta self ,tail ,(and clause (visit-cont clause)))))
       (($ $cont sym ($ $kclause arity body alternate))
        (sym ($kclause ,arity ,(visit-cont body)
                       ,(and alternate (visit-cont alternate)))))
@@ -99,8 +99,8 @@
        ,term)))
 
   (rewrite-cps-exp fun
-    (($ $fun src meta free body)
-     ($fun src meta free ,(visit-cont body)))))
+    (($ $fun free body)
+     ($fun free ,(visit-cont body)))))
 
 (define (elide-values fun)
   (with-fresh-name-state fun

diff --git a/module/language/cps/prune-bailouts.scm b/module/language/cps/prune-bailouts.scm
index 91afc18..9a8d517 100644 (file)
--- a/module/language/cps/prune-bailouts.scm
+++ b/module/language/cps/prune-bailouts.scm
@@ -50,8 +50,8 @@
     (rewrite-cps-cont cont
       (($ $cont label ($ $kargs names vars body))
        (label ($kargs names vars ,(visit-term body ktail))))
-      (($ $cont label ($ $kentry self tail clause))
-       (label ($kentry self ,tail
+      (($ $cont label ($ $kentry src meta self tail clause))
+       (label ($kentry src meta self ,tail
                 ,(and clause (visit-cont clause ktail)))))
       (($ $cont label ($ $kclause arity body alternate))
        (label ($kclause ,arity ,(visit-cont body ktail)
@@ -87,10 +87,11 @@
       (_ ($continue k src ,exp))))
 
   (rewrite-cps-exp fun
-    (($ $fun src meta free
-        ($ $cont kentry ($ $kentry self ($ $cont ktail ($ $ktail)) clause)))
-     ($fun src meta free
-           (kentry ($kentry self (ktail ($ktail))
+    (($ $fun free
+        ($ $cont kentry
+           ($ $kentry src meta self ($ $cont ktail ($ $ktail)) clause)))
+     ($fun free
+           (kentry ($kentry src meta self (ktail ($ktail))
                      ,(and clause (visit-cont clause ktail))))))))
 
 (define (prune-bailouts fun)

diff --git a/module/language/cps/prune-top-level-scopes.scm b/module/language/cps/prune-top-level-scopes.scm
index 84f3730..b15928d 100644 (file)
--- a/module/language/cps/prune-top-level-scopes.scm
+++ b/module/language/cps/prune-top-level-scopes.scm
@@ -41,7 +41,7 @@
            (hashq-set! k->scope-var k var)))
         (($ $cont k ($ $kargs names syms body))
          (visit-term body))
-        (($ $cont k ($ $kentry self tail clause))
+        (($ $cont k ($ $kentry src meta self tail clause))
          (when clause (visit-cont clause)))
         (($ $cont k ($ $kclause arity body alternate))
          (visit-cont body)
@@ -82,7 +82,7 @@
            (_ #t)))))
     (define (visit-fun fun)
       (match fun
-        (($ $fun src meta free body)
+        (($ $fun free body)
          (visit-cont body))))
 
     (visit-fun fun)
@@ -94,8 +94,8 @@
       (rewrite-cps-cont cont
         (($ $cont sym ($ $kargs names syms body))
          (sym ($kargs names syms ,(visit-term body))))
-        (($ $cont sym ($ $kentry self tail clause))
-         (sym ($kentry self ,tail ,(and clause (visit-cont clause)))))
+        (($ $cont sym ($ $kentry src meta self tail clause))
+         (sym ($kentry src meta self ,tail ,(and clause (visit-cont clause)))))
         (($ $cont sym ($ $kclause arity body alternate))
          (sym ($kclause ,arity ,(visit-cont body)
                         ,(and alternate (visit-cont alternate)))))
@@ -115,5 +115,5 @@
         (($ $continue)
          ,term)))
     (rewrite-cps-exp fun
-      (($ $fun src meta free body)
-       ($fun src meta free ,(visit-cont body))))))
+      (($ $fun free body)
+       ($fun free ,(visit-cont body))))))

diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm
index e6d3736..33b6aa7 100644 (file)
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -111,17 +111,17 @@
     (let ((conts (build-cont-table fun)))
       (define (visit-fun term)
         (rewrite-cps-exp term
-          (($ $fun src meta free body)
-           ($fun src meta free ,(visit-cont body)))))
+          (($ $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 ($ $kentry self (and tail ($ $cont ktail)) #f))
+          (($ $cont sym ($ $kentry src meta self (and tail ($ $cont ktail)) #f))
            ;; A case-lambda with no clauses.  Reify a clause.
-           (sym ($kentry self ,tail ,(reify-clause ktail))))
-          (($ $cont sym ($ $kentry self tail clause))
-           (sym ($kentry self ,tail ,(visit-cont clause))))
+           (sym ($kentry src meta self ,tail ,(reify-clause ktail))))
+          (($ $cont sym ($ $kentry src meta self tail clause))
+           (sym ($kentry src meta self ,tail ,(visit-cont clause))))
           (($ $cont sym ($ $kclause arity body alternate))
            (sym ($kclause ,arity ,(visit-cont body)
                           ,(and alternate (visit-cont alternate)))))

diff --git a/module/language/cps/renumber.scm b/module/language/cps/renumber.scm
index 9136247..38dabf3 100644 (file)
--- a/module/language/cps/renumber.scm
+++ b/module/language/cps/renumber.scm
@@ -92,7 +92,7 @@
                (match cont
                  (($ $kargs names vars body)
                   (visit-term body))
-                 (($ $kentry self tail clause)
+                 (($ $kentry src meta self tail clause)
                   (visit-cont tail)
                   (when clause
                     (visit-cont clause)))
@@ -111,7 +111,7 @@
                (visit-term body))
               (($ $continue k src _) #f)))
           (match fun
-            (($ $fun src meta free body)
+            (($ $fun free body)
              (visit-cont body))))
 
         (define (compute-names-in-fun fun)
@@ -131,7 +131,7 @@
                     (when reachable?
                       (for-each rename! vars))
                     (visit-term body reachable?))
-                   (($ $kentry self tail clause)
+                   (($ $kentry src meta self tail clause)
                     (unless reachable? (error "entry should be reachable"))
                     (rename! self)
                     (visit-cont tail)
@@ -168,7 +168,7 @@
 
           (collect-conts fun)
           (match fun
-            (($ $fun src meta free (and entry ($ $cont kentry)))
+            (($ $fun free (and entry ($ $cont kentry)))
              (set! next-label (sort-conts kentry labels next-label))
              (visit-cont entry)
              (for-each compute-names-in-fun (reverse queue)))))
@@ -211,9 +211,9 @@
               (rewrite-cps-cont cont
                 (($ $kargs names vars body)
                  (label ($kargs names (map rename vars) ,(visit-term body))))
-                (($ $kentry self tail clause)
+                (($ $kentry src meta self tail clause)
                  (label
-                  ($kentry (rename self) ,(must-visit-cont tail)
+                  ($kentry src meta (rename self) ,(must-visit-cont tail)
                     ,(and clause (must-visit-cont clause)))))
                 (($ $ktail)
                  (label ($ktail)))
@@ -259,6 +259,6 @@
              ($prompt escape? (rename tag) (relabel handler))))))
       (define (visit-fun fun)
         (rewrite-cps-exp fun
-          (($ $fun src meta free body)
-           ($fun src meta (map rename free) ,(must-visit-cont body)))))
+          (($ $fun free body)
+           ($fun (map rename free) ,(must-visit-cont body)))))
       (values (visit-fun fun) nlabels nvars))))

diff --git a/module/language/cps/self-references.scm b/module/language/cps/self-references.scm
index bde37a6..4f597f1 100644 (file)
--- a/module/language/cps/self-references.scm
+++ b/module/language/cps/self-references.scm
@@ -35,8 +35,8 @@
     (rewrite-cps-cont cont
       (($ $cont label ($ $kargs names vars body))
        (label ($kargs names vars ,(visit-term body))))
-      (($ $cont label ($ $kentry self tail clause))
-       (label ($kentry self ,tail
+      (($ $cont label ($ $kentry src meta self tail clause))
+       (label ($kentry src meta self ,tail
                 ,(and clause (visit-cont clause)))))
       (($ $cont label ($ $kclause arity body alternate))
        (label ($kclause ,arity ,(visit-cont body)
@@ -71,9 +71,9 @@
 
   (define (visit-recursive-fun fun var)
     (match fun
-      (($ $fun src meta free (and cont ($ $cont _ ($ $kentry self))))
+      (($ $fun free (and cont ($ $cont _ ($ $kentry src meta self))))
        (resolve-self-references fun (acons var self env)))))
 
   (rewrite-cps-exp fun
-    (($ $fun src meta free cont)
-     ($fun src meta (map subst free) ,(visit-cont cont)))))
+    (($ $fun free cont)
+     ($fun (map subst free) ,(visit-cont cont)))))

diff --git a/module/language/cps/simplify.scm b/module/language/cps/simplify.scm
index 8c7b898..cae5c21 100644 (file)
--- a/module/language/cps/simplify.scm
+++ b/module/language/cps/simplify.scm
@@ -39,7 +39,7 @@
       (match cont
         (($ $cont sym ($ $kargs names syms body))
          (visit-term body sym syms))
-        (($ $cont sym ($ $kentry self tail clause))
+        (($ $cont sym ($ $kentry src meta self tail clause))
          (when clause (visit-cont clause)))
         (($ $cont sym ($ $kclause arity body alternate))
          (visit-cont body)
@@ -62,7 +62,7 @@
          #f)))
     (define (visit-fun fun)
       (match fun
-        (($ $fun src meta free body)
+        (($ $fun free body)
          (visit-cont body))))
     (visit-fun fun)
     table))
@@ -89,8 +89,9 @@
       (rewrite-cps-cont cont
         (($ $cont sym ($ $kargs names syms body))
          (sym ($kargs names syms ,(visit-term body sym))))
-        (($ $cont sym ($ $kentry self tail clause))
-         (sym ($kentry self ,tail ,(and clause (visit-cont clause sym)))))
+        (($ $cont sym ($ $kentry src meta self tail clause))
+         (sym ($kentry src meta self ,tail
+                ,(and clause (visit-cont clause sym)))))
         (($ $cont sym ($ $kclause arity body alternate))
          (sym ($kclause ,arity ,(visit-cont body sym)
                         ,(and alternate (visit-cont alternate sym)))))
@@ -114,8 +115,8 @@
          ($continue (reduce k scope) src ,exp))))
     (define (visit-fun fun)
       (rewrite-cps-exp fun
-        (($ $fun src meta free body)
-         ($fun src meta free ,(visit-cont body #f)))))
+        (($ $fun free body)
+         ($fun free ,(visit-cont body #f)))))
     (visit-fun fun)))
 
 (define (compute-beta-reductions fun)
@@ -129,7 +130,7 @@
       (match cont
         (($ $cont sym ($ $kargs names syms body))
          (visit-term body))
-        (($ $cont sym ($ $kentry self tail clause))
+        (($ $cont sym ($ $kentry src meta self tail clause))
          (when clause (visit-cont clause)))
         (($ $cont sym ($ $kclause arity body alternate))
          (visit-cont body)
@@ -165,7 +166,7 @@
          #f)))
     (define (visit-fun fun)
       (match fun
-        (($ $fun src meta free body)
+        (($ $fun free body)
          (visit-cont body))))
     (visit-fun fun)
     (values var-table k-table)))
@@ -185,8 +186,8 @@
               (rewrite-cps-cont cont
                 (($ $kargs names syms body)
                  (sym ($kargs names syms ,(visit-term body))))
-                (($ $kentry self tail clause)
-                 (sym ($kentry self ,tail
+                (($ $kentry src meta self tail clause)
+                 (sym ($kentry src meta self ,tail
                         ,(and clause (must-visit-cont clause)))))
                 (($ $kclause arity body alternate)
                  (sym ($kclause ,arity ,(must-visit-cont body)
@@ -229,8 +230,8 @@
                    (build-cps-exp ($prompt escape? (subst tag) handler)))))))))))
     (define (visit-fun fun)
       (rewrite-cps-exp fun
-        (($ $fun src meta free body)
-         ($fun src meta (map subst free) ,(must-visit-cont body)))))
+        (($ $fun free body)
+         ($fun (map subst free) ,(must-visit-cont body)))))
     (visit-fun fun)))
 
 (define (simplify fun)

diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm
index e5f3117..85f69b5 100644 (file)
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -337,7 +337,7 @@ are comparable with eqv?.  A tmp slot may be used."
       (let lp ((n 0))
         (when (< n (vector-length usev))
           (match (lookup-cont (idx->label n) dfg)
-            (($ $kentry self)
+            (($ $kentry src meta self)
              (vector-set! defv n (list (dfa-var-idx dfa self))))
             (($ $kargs names syms body)
              (vector-set! defv n (map (cut dfa-var-idx dfa <>) syms))
@@ -671,7 +671,7 @@ are comparable with eqv?.  A tmp slot may be used."
                     (error "Unexpected clause order"))))
                (visit-clauses next live))))))
       (match (lookup-cont (idx->label 0) dfg)
-        (($ $kentry self)
+        (($ $kentry src meta self)
          (visit-clauses 1 (allocate-defs! 0 (empty-live-slots))))))
 
     (compute-constants!)

diff --git a/module/language/cps/specialize-primcalls.scm b/module/language/cps/specialize-primcalls.scm
index e1283e4..f10a76a 100644 (file)
--- a/module/language/cps/specialize-primcalls.scm
+++ b/module/language/cps/specialize-primcalls.scm
@@ -41,8 +41,9 @@
         (rewrite-cps-cont cont
           (($ $cont sym ($ $kargs names syms body))
            (sym ($kargs names syms ,(visit-term body))))
-          (($ $cont sym ($ $kentry self tail clause))
-           (sym ($kentry self ,tail ,(and clause (visit-cont clause)))))
+          (($ $cont sym ($ $kentry src meta self tail clause))
+           (sym ($kentry src meta self ,tail
+                  ,(and clause (visit-cont clause)))))
           (($ $cont sym ($ $kclause arity body alternate))
            (sym ($kclause ,arity ,(visit-cont body)
                           ,(and alternate (visit-cont alternate)))))
@@ -107,7 +108,7 @@
 
       (define (visit-fun fun)
         (rewrite-cps-exp fun
-          (($ $fun src meta free body)
-           ($fun src meta free ,(visit-cont body)))))
+          (($ $fun free body)
+           ($fun free ,(visit-cont body)))))
 
       (visit-fun fun))))

diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm
index d521351..ada8b7c 100644 (file)
--- a/module/language/cps/verify.scm
+++ b/module/language/cps/verify.scm
@@ -115,9 +115,9 @@
 
   (define (visit-fun fun k-env v-env)
     (match fun
-      (($ $fun src meta (free ...)
+      (($ $fun (free ...)
           ($ $cont kbody
-             ($ $kentry self ($ $cont ktail ($ $ktail)) clause)))
+             ($ $kentry src meta self ($ $cont ktail ($ $ktail)) clause)))
        (when (and meta (not (and (list? meta) (and-map pair? meta))))
          (error "meta should be alist" meta))
        (for-each (cut check-var <> v-env) free)

diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm
index 5e7e66f..f0d4667 100644 (file)
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -297,9 +297,9 @@
            (let-fresh (kentry ktail) (self)
              (build-cps-term
                ($continue k fun-src
-                 ($fun fun-src meta '()
-                       (kentry ($kentry self (ktail ($ktail))
-                                 ,(convert-clauses body ktail)))))))
+                 ($fun '()
+                   (kentry ($kentry fun-src meta self (ktail ($ktail))
+                             ,(convert-clauses body ktail)))))))
            (let ((scope-id (fresh-scope-id)))
              (let-fresh (kscope) ()
                (build-cps-term
@@ -604,14 +604,14 @@ integer."
     (let ((src (tree-il-src exp)))
       (let-fresh (kinit ktail kclause kbody) (init)
         (build-cps-exp
-          ($fun src '() '()
-                (kinit ($kentry init (ktail ($ktail))
-                         (kclause
-                          ($kclause ('() '() #f '() #f)
-                            (kbody ($kargs () ()
-                                     ,(convert exp ktail
-                                               (build-subst exp))))
-                            ,#f))))))))))
+          ($fun '()
+            (kinit ($kentry src '() init (ktail ($ktail))
+                     (kclause
+                      ($kclause ('() '() #f '() #f)
+                        (kbody ($kargs () ()
+                                 ,(convert exp ktail
+                                           (build-subst exp))))
+                        ,#f))))))))))
 
 (define *comp-module* (make-fluid))