mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

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

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2014-04-10 10:50:17 +02:00
parent 1e91d95704
commit 24b611e81c
21 changed files with 160 additions and 154 deletions
Download patch file Download diff file Expand all files Collapse all files

4
.dir-locals.el
View file

@ -26,9 +26,9 @@
(eval . (put '$letconst 'scheme-indent-function 1)) (eval . (put '$letconst 'scheme-indent-function 1))
(eval . (put '$continue 'scheme-indent-function 2)) (eval . (put '$continue 'scheme-indent-function 2))
(eval . (put '$kargs '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 '$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))) (emacs-lisp-mode . ((indent-tabs-mode . nil)))
(texinfo-mode . ((indent-tabs-mode . nil) (texinfo-mode . ((indent-tabs-mode . nil)
(fill-column . 72)))) (fill-column . 72))))

45
module/language/cps.scm
View file

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

11
module/language/cps/arities.scm
View file

@ -34,7 +34,8 @@
(define (fix-clause-arities clause dfg) (define (fix-clause-arities clause dfg)
(let ((ktail (match clause (let ((ktail (match clause
(($ $cont _ ($ $kentry _ ($ $cont ktail) _)) ktail)))) (($ $cont _
($ $kentry src meta _ ($ $cont ktail) _)) ktail))))
(define (visit-term term) (define (visit-term term)
(rewrite-cps-term term (rewrite-cps-term term
(($ $letk conts body) (($ $letk conts body)
@ -181,13 +182,13 @@
,cont))) ,cont)))
(rewrite-cps-cont clause (rewrite-cps-cont clause
(($ $cont sym ($ $kentry self tail clause)) (($ $cont sym ($ $kentry src meta self tail clause))
(sym ($kentry self ,tail ,(and clause (visit-cont clause)))))))) (sym ($kentry src meta self ,tail ,(and clause (visit-cont clause))))))))
(define (fix-arities* fun dfg) (define (fix-arities* fun dfg)
(rewrite-cps-exp fun (rewrite-cps-exp fun
(($ $fun src meta free body) (($ $fun free body)
($fun src meta free ,(fix-clause-arities body dfg))))) ($fun free ,(fix-clause-arities body dfg)))))
(define (fix-arities fun) (define (fix-arities fun)
(let ((dfg (compute-dfg fun))) (let ((dfg (compute-dfg fun)))

27
module/language/cps/closure-conversion.scm
View file

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

21
module/language/cps/compile-bytecode.scm
View file

@ -113,10 +113,12 @@
(emit-load-constant asm slot val) (emit-load-constant asm slot val)
#t))))) #t)))))
(define (compile-entry meta) (define (compile-entry)
(let ((label (dfg-min-label dfg))) (let ((label (dfg-min-label dfg)))
(match (lookup-cont 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) (emit-begin-program asm label meta)
(compile-clause (1+ label)) (compile-clause (1+ label))
(emit-end-program asm))))) (emit-end-program asm)))))
@ -243,9 +245,9 @@
(emit-load-constant asm dst *unspecified*)) (emit-load-constant asm dst *unspecified*))
(($ $const exp) (($ $const exp)
(emit-load-constant asm dst exp)) (emit-load-constant asm dst exp))
(($ $fun src meta () ($ $cont k)) (($ $fun () ($ $cont k))
(emit-load-static-procedure asm dst 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))) (emit-make-closure asm dst k (length free)))
(($ $primcall 'current-module) (($ $primcall 'current-module)
(emit-current-module asm dst)) (emit-current-module asm dst))
@ -469,18 +471,15 @@
(emit-call-label asm proc-slot nargs k)))))) (emit-call-label asm proc-slot nargs k))))))
(match f (match f
(($ $fun src meta free ($ $cont k ($ $kentry self tail clause))) (($ $fun free ($ $cont k ($ $kentry src meta self tail clause)))
;; FIXME: src on kentry instead? (compile-entry)))))
(when src
(emit-source asm src))
(compile-entry (or meta '()))))))
(define (visit-funs proc exp) (define (visit-funs proc exp)
(match exp (match exp
(($ $continue _ _ exp) (($ $continue _ _ exp)
(visit-funs proc exp)) (visit-funs proc exp))
(($ $fun src meta free body) (($ $fun free body)
(proc exp) (proc exp)
(visit-funs proc body)) (visit-funs proc body))
@ -496,7 +495,7 @@
(when alternate (when alternate
(visit-funs proc alternate))) (visit-funs proc alternate)))
(($ $cont sym ($ $kentry self tail clause)) (($ $cont sym ($ $kentry src meta self tail clause))
(when clause (when clause
(visit-funs proc clause))) (visit-funs proc clause)))

8
module/language/cps/constructors.scm
View file

@ -34,8 +34,8 @@
(rewrite-cps-cont cont (rewrite-cps-cont cont
(($ $cont sym ($ $kargs names syms body)) (($ $cont sym ($ $kargs names syms body))
(sym ($kargs names syms ,(visit-term body)))) (sym ($kargs names syms ,(visit-term body))))
(($ $cont sym ($ $kentry self tail clause)) (($ $cont sym ($ $kentry src meta self tail clause))
(sym ($kentry self ,tail ,(and clause (visit-cont clause))))) (sym ($kentry src meta self ,tail ,(and clause (visit-cont clause)))))
(($ $cont sym ($ $kclause arity body alternate)) (($ $cont sym ($ $kclause arity body alternate))
(sym ($kclause ,arity ,(visit-cont body) (sym ($kclause ,arity ,(visit-cont body)
,(and alternate (visit-cont alternate))))) ,(and alternate (visit-cont alternate)))))
@ -95,8 +95,8 @@
,term))) ,term)))
(rewrite-cps-exp fun (rewrite-cps-exp fun
(($ $fun src meta free body) (($ $fun free body)
($fun src meta free ,(visit-cont body))))) ($fun free ,(visit-cont body)))))
(define (inline-constructors fun) (define (inline-constructors fun)
(with-fresh-name-state fun (with-fresh-name-state fun

25
module/language/cps/contification.scm
View file

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

16
module/language/cps/cse.scm
View file

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

12
module/language/cps/dce.scm
View file

@ -71,7 +71,7 @@
(($ $kclause arity ($ $cont kargs ($ $kargs names syms))) (($ $kclause arity ($ $cont kargs ($ $kargs names syms)))
syms) syms)
(($ $kif) #f) (($ $kif) #f)
(($ $kentry self) (list self)) (($ $kentry src meta self) (list self))
(($ $ktail) #f))) (($ $ktail) #f)))
(lp (1+ n)))) (lp (1+ n))))
defs)) defs))
@ -163,7 +163,7 @@
(($ $kif) #f) (($ $kif) #f)
(($ $kclause arity ($ $cont kargs ($ $kargs names syms body))) (($ $kclause arity ($ $cont kargs ($ $kargs names syms body)))
(for-each mark-live! syms)) (for-each mark-live! syms))
(($ $kentry self) (($ $kentry src meta self)
(mark-live! self)) (mark-live! self))
(($ $ktail) #f)) (($ $ktail) #f))
(lp (1- n)))))))) (lp (1- n))))))))
@ -209,10 +209,10 @@
(build-cps-cont (build-cps-cont
(label ($kargs names syms (label ($kargs names syms
,(visit-term body label)))))))) ,(visit-term body label))))))))
(($ $kentry self tail clause) (($ $kentry src meta self tail clause)
(list (list
(build-cps-cont (build-cps-cont
(label ($kentry self ,tail (label ($kentry src meta self ,tail
,(and clause (visit-cont clause))))))) ,(and clause (visit-cont clause)))))))
(($ $kclause arity body alternate) (($ $kclause arity body alternate)
(list (list
@ -275,8 +275,8 @@
($continue adapt src ,exp)))))))) ($continue adapt src ,exp))))))))
(build-cps-term ($continue k src ($values ()))))))) (build-cps-term ($continue k src ($values ())))))))
(rewrite-cps-exp fun (rewrite-cps-exp fun
(($ $fun src meta free body) (($ $fun free body)
($fun src meta free ,(visit-cont body))))))) ($fun free ,(visit-cont body)))))))
(visit-fun fun)) (visit-fun fun))
(define (eliminate-dead-code fun) (define (eliminate-dead-code fun)

10
module/language/cps/dfg.scm
View file

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

8
module/language/cps/elide-values.scm
View file

@ -40,8 +40,8 @@
(rewrite-cps-cont cont (rewrite-cps-cont cont
(($ $cont sym ($ $kargs names syms body)) (($ $cont sym ($ $kargs names syms body))
(sym ($kargs names syms ,(visit-term body)))) (sym ($kargs names syms ,(visit-term body))))
(($ $cont sym ($ $kentry self tail clause)) (($ $cont sym ($ $kentry src meta self tail clause))
(sym ($kentry self ,tail ,(and clause (visit-cont clause))))) (sym ($kentry src meta self ,tail ,(and clause (visit-cont clause)))))
(($ $cont sym ($ $kclause arity body alternate)) (($ $cont sym ($ $kclause arity body alternate))
(sym ($kclause ,arity ,(visit-cont body) (sym ($kclause ,arity ,(visit-cont body)
,(and alternate (visit-cont alternate))))) ,(and alternate (visit-cont alternate)))))
@ -99,8 +99,8 @@
,term))) ,term)))
(rewrite-cps-exp fun (rewrite-cps-exp fun
(($ $fun src meta free body) (($ $fun free body)
($fun src meta free ,(visit-cont body))))) ($fun free ,(visit-cont body)))))
(define (elide-values fun) (define (elide-values fun)
(with-fresh-name-state fun (with-fresh-name-state fun

13
module/language/cps/prune-bailouts.scm
View file

@ -50,8 +50,8 @@
(rewrite-cps-cont cont (rewrite-cps-cont cont
(($ $cont label ($ $kargs names vars body)) (($ $cont label ($ $kargs names vars body))
(label ($kargs names vars ,(visit-term body ktail)))) (label ($kargs names vars ,(visit-term body ktail))))
(($ $cont label ($ $kentry self tail clause)) (($ $cont label ($ $kentry src meta self tail clause))
(label ($kentry self ,tail (label ($kentry src meta self ,tail
,(and clause (visit-cont clause ktail))))) ,(and clause (visit-cont clause ktail)))))
(($ $cont label ($ $kclause arity body alternate)) (($ $cont label ($ $kclause arity body alternate))
(label ($kclause ,arity ,(visit-cont body ktail) (label ($kclause ,arity ,(visit-cont body ktail)
@ -87,10 +87,11 @@
(_ ($continue k src ,exp)))) (_ ($continue k src ,exp))))
(rewrite-cps-exp fun (rewrite-cps-exp fun
(($ $fun src meta free (($ $fun free
($ $cont kentry ($ $kentry self ($ $cont ktail ($ $ktail)) clause))) ($ $cont kentry
($fun src meta free ($ $kentry src meta self ($ $cont ktail ($ $ktail)) clause)))
(kentry ($kentry self (ktail ($ktail)) ($fun free
(kentry ($kentry src meta self (ktail ($ktail))
,(and clause (visit-cont clause ktail)))))))) ,(and clause (visit-cont clause ktail))))))))
(define (prune-bailouts fun) (define (prune-bailouts fun)

12
module/language/cps/prune-top-level-scopes.scm
View file

@ -41,7 +41,7 @@
(hashq-set! k->scope-var k var))) (hashq-set! k->scope-var k var)))
(($ $cont k ($ $kargs names syms body)) (($ $cont k ($ $kargs names syms body))
(visit-term body)) (visit-term body))
(($ $cont k ($ $kentry self tail clause)) (($ $cont k ($ $kentry src meta self tail clause))
(when clause (visit-cont clause))) (when clause (visit-cont clause)))
(($ $cont k ($ $kclause arity body alternate)) (($ $cont k ($ $kclause arity body alternate))
(visit-cont body) (visit-cont body)
@ -82,7 +82,7 @@
(_ #t))))) (_ #t)))))
(define (visit-fun fun) (define (visit-fun fun)
(match fun (match fun
(($ $fun src meta free body) (($ $fun free body)
(visit-cont body)))) (visit-cont body))))
(visit-fun fun) (visit-fun fun)
@ -94,8 +94,8 @@
(rewrite-cps-cont cont (rewrite-cps-cont cont
(($ $cont sym ($ $kargs names syms body)) (($ $cont sym ($ $kargs names syms body))
(sym ($kargs names syms ,(visit-term body)))) (sym ($kargs names syms ,(visit-term body))))
(($ $cont sym ($ $kentry self tail clause)) (($ $cont sym ($ $kentry src meta self tail clause))
(sym ($kentry self ,tail ,(and clause (visit-cont clause))))) (sym ($kentry src meta self ,tail ,(and clause (visit-cont clause)))))
(($ $cont sym ($ $kclause arity body alternate)) (($ $cont sym ($ $kclause arity body alternate))
(sym ($kclause ,arity ,(visit-cont body) (sym ($kclause ,arity ,(visit-cont body)
,(and alternate (visit-cont alternate))))) ,(and alternate (visit-cont alternate)))))
@ -115,5 +115,5 @@
(($ $continue) (($ $continue)
,term))) ,term)))
(rewrite-cps-exp fun (rewrite-cps-exp fun
(($ $fun src meta free body) (($ $fun free body)
($fun src meta free ,(visit-cont body)))))) ($fun free ,(visit-cont body))))))

12
module/language/cps/reify-primitives.scm
View file

@ -111,17 +111,17 @@
(let ((conts (build-cont-table fun))) (let ((conts (build-cont-table fun)))
(define (visit-fun term) (define (visit-fun term)
(rewrite-cps-exp term (rewrite-cps-exp term
(($ $fun src meta free body) (($ $fun free body)
($fun src meta free ,(visit-cont body))))) ($fun free ,(visit-cont body)))))
(define (visit-cont cont) (define (visit-cont cont)
(rewrite-cps-cont cont (rewrite-cps-cont cont
(($ $cont sym ($ $kargs names syms body)) (($ $cont sym ($ $kargs names syms body))
(sym ($kargs names syms ,(visit-term 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. ;; A case-lambda with no clauses. Reify a clause.
(sym ($kentry self ,tail ,(reify-clause ktail)))) (sym ($kentry src meta self ,tail ,(reify-clause ktail))))
(($ $cont sym ($ $kentry self tail clause)) (($ $cont sym ($ $kentry src meta self tail clause))
(sym ($kentry self ,tail ,(visit-cont clause)))) (sym ($kentry src meta self ,tail ,(visit-cont clause))))
(($ $cont sym ($ $kclause arity body alternate)) (($ $cont sym ($ $kclause arity body alternate))
(sym ($kclause ,arity ,(visit-cont body) (sym ($kclause ,arity ,(visit-cont body)
,(and alternate (visit-cont alternate))))) ,(and alternate (visit-cont alternate)))))

16
module/language/cps/renumber.scm
View file

@ -92,7 +92,7 @@
(match cont (match cont
(($ $kargs names vars body) (($ $kargs names vars body)
(visit-term body)) (visit-term body))
(($ $kentry self tail clause) (($ $kentry src meta self tail clause)
(visit-cont tail) (visit-cont tail)
(when clause (when clause
(visit-cont clause))) (visit-cont clause)))
@ -111,7 +111,7 @@
(visit-term body)) (visit-term body))
(($ $continue k src _) #f))) (($ $continue k src _) #f)))
(match fun (match fun
(($ $fun src meta free body) (($ $fun free body)
(visit-cont body)))) (visit-cont body))))
(define (compute-names-in-fun fun) (define (compute-names-in-fun fun)
@ -131,7 +131,7 @@
(when reachable? (when reachable?
(for-each rename! vars)) (for-each rename! vars))
(visit-term body reachable?)) (visit-term body reachable?))
(($ $kentry self tail clause) (($ $kentry src meta self tail clause)
(unless reachable? (error "entry should be reachable")) (unless reachable? (error "entry should be reachable"))
(rename! self) (rename! self)
(visit-cont tail) (visit-cont tail)
@ -168,7 +168,7 @@
(collect-conts fun) (collect-conts fun)
(match 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)) (set! next-label (sort-conts kentry labels next-label))
(visit-cont entry) (visit-cont entry)
(for-each compute-names-in-fun (reverse queue))))) (for-each compute-names-in-fun (reverse queue)))))
@ -211,9 +211,9 @@
(rewrite-cps-cont cont (rewrite-cps-cont cont
(($ $kargs names vars body) (($ $kargs names vars body)
(label ($kargs names (map rename vars) ,(visit-term body)))) (label ($kargs names (map rename vars) ,(visit-term body))))
(($ $kentry self tail clause) (($ $kentry src meta self tail clause)
(label (label
($kentry (rename self) ,(must-visit-cont tail) ($kentry src meta (rename self) ,(must-visit-cont tail)
,(and clause (must-visit-cont clause))))) ,(and clause (must-visit-cont clause)))))
(($ $ktail) (($ $ktail)
(label ($ktail))) (label ($ktail)))
@ -259,6 +259,6 @@
($prompt escape? (rename tag) (relabel handler)))))) ($prompt escape? (rename tag) (relabel handler))))))
(define (visit-fun fun) (define (visit-fun fun)
(rewrite-cps-exp fun (rewrite-cps-exp fun
(($ $fun src meta free body) (($ $fun free body)
($fun src meta (map rename free) ,(must-visit-cont body))))) ($fun (map rename free) ,(must-visit-cont body)))))
(values (visit-fun fun) nlabels nvars)))) (values (visit-fun fun) nlabels nvars))))

10
module/language/cps/self-references.scm
View file

@ -35,8 +35,8 @@
(rewrite-cps-cont cont (rewrite-cps-cont cont
(($ $cont label ($ $kargs names vars body)) (($ $cont label ($ $kargs names vars body))
(label ($kargs names vars ,(visit-term body)))) (label ($kargs names vars ,(visit-term body))))
(($ $cont label ($ $kentry self tail clause)) (($ $cont label ($ $kentry src meta self tail clause))
(label ($kentry self ,tail (label ($kentry src meta self ,tail
,(and clause (visit-cont clause))))) ,(and clause (visit-cont clause)))))
(($ $cont label ($ $kclause arity body alternate)) (($ $cont label ($ $kclause arity body alternate))
(label ($kclause ,arity ,(visit-cont body) (label ($kclause ,arity ,(visit-cont body)
@ -71,9 +71,9 @@
(define (visit-recursive-fun fun var) (define (visit-recursive-fun fun var)
(match fun (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))))) (resolve-self-references fun (acons var self env)))))
(rewrite-cps-exp fun (rewrite-cps-exp fun
(($ $fun src meta free cont) (($ $fun free cont)
($fun src meta (map subst free) ,(visit-cont cont))))) ($fun (map subst free) ,(visit-cont cont)))))

25
module/language/cps/simplify.scm
View file

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

4
module/language/cps/slot-allocation.scm
View file

@ -337,7 +337,7 @@ are comparable with eqv?. A tmp slot may be used."
(let lp ((n 0)) (let lp ((n 0))
(when (< n (vector-length usev)) (when (< n (vector-length usev))
(match (lookup-cont (idx->label n) dfg) (match (lookup-cont (idx->label n) dfg)
(($ $kentry self) (($ $kentry src meta self)
(vector-set! defv n (list (dfa-var-idx dfa self)))) (vector-set! defv n (list (dfa-var-idx dfa self))))
(($ $kargs names syms body) (($ $kargs names syms body)
(vector-set! defv n (map (cut dfa-var-idx dfa <>) syms)) (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")))) (error "Unexpected clause order"))))
(visit-clauses next live)))))) (visit-clauses next live))))))
(match (lookup-cont (idx->label 0) dfg) (match (lookup-cont (idx->label 0) dfg)
(($ $kentry self) (($ $kentry src meta self)
(visit-clauses 1 (allocate-defs! 0 (empty-live-slots)))))) (visit-clauses 1 (allocate-defs! 0 (empty-live-slots))))))
(compute-constants!) (compute-constants!)

9
module/language/cps/specialize-primcalls.scm
View file

@ -41,8 +41,9 @@
(rewrite-cps-cont cont (rewrite-cps-cont cont
(($ $cont sym ($ $kargs names syms body)) (($ $cont sym ($ $kargs names syms body))
(sym ($kargs names syms ,(visit-term body)))) (sym ($kargs names syms ,(visit-term body))))
(($ $cont sym ($ $kentry self tail clause)) (($ $cont sym ($ $kentry src meta self tail clause))
(sym ($kentry self ,tail ,(and clause (visit-cont clause))))) (sym ($kentry src meta self ,tail
,(and clause (visit-cont clause)))))
(($ $cont sym ($ $kclause arity body alternate)) (($ $cont sym ($ $kclause arity body alternate))
(sym ($kclause ,arity ,(visit-cont body) (sym ($kclause ,arity ,(visit-cont body)
,(and alternate (visit-cont alternate))))) ,(and alternate (visit-cont alternate)))))
@ -107,7 +108,7 @@
(define (visit-fun fun) (define (visit-fun fun)
(rewrite-cps-exp fun (rewrite-cps-exp fun
(($ $fun src meta free body) (($ $fun free body)
($fun src meta free ,(visit-cont body))))) ($fun free ,(visit-cont body)))))
(visit-fun fun)))) (visit-fun fun))))

4
module/language/cps/verify.scm
View file

@ -115,9 +115,9 @@
(define (visit-fun fun k-env v-env) (define (visit-fun fun k-env v-env)
(match fun (match fun
(($ $fun src meta (free ...) (($ $fun (free ...)
($ $cont kbody ($ $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)))) (when (and meta (not (and (list? meta) (and-map pair? meta))))
(error "meta should be alist" meta)) (error "meta should be alist" meta))
(for-each (cut check-var <> v-env) free) (for-each (cut check-var <> v-env) free)

22
module/language/tree-il/compile-cps.scm
View file

@ -297,9 +297,9 @@
(let-fresh (kentry ktail) (self) (let-fresh (kentry ktail) (self)
(build-cps-term (build-cps-term
($continue k fun-src ($continue k fun-src
($fun fun-src meta '() ($fun '()
(kentry ($kentry self (ktail ($ktail)) (kentry ($kentry fun-src meta self (ktail ($ktail))
,(convert-clauses body ktail))))))) ,(convert-clauses body ktail)))))))
(let ((scope-id (fresh-scope-id))) (let ((scope-id (fresh-scope-id)))
(let-fresh (kscope) () (let-fresh (kscope) ()
(build-cps-term (build-cps-term
@ -604,14 +604,14 @@ integer."
(let ((src (tree-il-src exp))) (let ((src (tree-il-src exp)))
(let-fresh (kinit ktail kclause kbody) (init) (let-fresh (kinit ktail kclause kbody) (init)
(build-cps-exp (build-cps-exp
($fun src '() '() ($fun '()
(kinit ($kentry init (ktail ($ktail)) (kinit ($kentry src '() init (ktail ($ktail))
(kclause (kclause
($kclause ('() '() #f '() #f) ($kclause ('() '() #f '() #f)
(kbody ($kargs () () (kbody ($kargs () ()
,(convert exp ktail ,(convert exp ktail
(build-subst exp)))) (build-subst exp))))
,#f)))))))))) ,#f))))))))))
(define *comp-module* (make-fluid)) (define *comp-module* (make-fluid))