From 24b611e81ce18b1e311c66d849524b4a1f0f571c Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 10 Apr 2014 10:50:17 +0200 Subject: [PATCH] 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. --- .dir-locals.el | 4 +- module/language/cps.scm | 45 ++++++++++--------- module/language/cps/arities.scm | 11 ++--- module/language/cps/closure-conversion.scm | 27 +++++------ module/language/cps/compile-bytecode.scm | 21 +++++---- module/language/cps/constructors.scm | 8 ++-- module/language/cps/contification.scm | 25 ++++++----- module/language/cps/cse.scm | 16 +++---- module/language/cps/dce.scm | 12 ++--- module/language/cps/dfg.scm | 10 ++--- module/language/cps/elide-values.scm | 8 ++-- module/language/cps/prune-bailouts.scm | 13 +++--- .../language/cps/prune-top-level-scopes.scm | 12 ++--- module/language/cps/reify-primitives.scm | 12 ++--- module/language/cps/renumber.scm | 16 +++---- module/language/cps/self-references.scm | 10 ++--- module/language/cps/simplify.scm | 25 ++++++----- module/language/cps/slot-allocation.scm | 4 +- module/language/cps/specialize-primcalls.scm | 9 ++-- module/language/cps/verify.scm | 4 +- module/language/tree-il/compile-cps.scm | 22 ++++----- 21 files changed, 160 insertions(+), 154 deletions(-) diff --git a/.dir-locals.el b/.dir-locals.el index 597f74177..b9e2f2cf1 100644 --- 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 f5466283a..079da59c1 100644 --- 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 8b9ce411c..34b32692f 100644 --- 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 89c491fdb..16711f45c 100644 --- 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 bf87f2c22..35cc12b7b 100644 --- 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 4bb8670a9..9cebf572a 100644 --- 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 a7e3d36a6..477e00318 100644 --- 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 a0dea1a8c..89ea5465c 100644 --- 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 0aa08f77c..ef6f3c4cf 100644 --- 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 3180e3d74..af9130e37 100644 --- 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 c770f88e3..1eb94c5bf 100644 --- 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 91afc180b..9a8d51712 100644 --- 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 84f3730f7..b15928d97 100644 --- 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 e6d3736fd..33b6aa7f5 100644 --- 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 913624768..38dabf391 100644 --- 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 bde37a60e..4f597f12e 100644 --- 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 8c7b89815..cae5c21e0 100644 --- 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 e5f3117a3..85f69b53d 100644 --- 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 e1283e452..f10a76a37 100644 --- 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 d52135193..ada8b7cd0 100644 --- 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 5e7e66fa2..f0d4667ae 100644 --- 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)) -- 2.20.1