mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-18 10:10:23 +02:00
Source information goes on the $continue, not the $cont.
* module/language/cps.scm ($continue, $cont): Put source information on the $continue, not on the $cont. Otherwise it is difficult for CPS conversion to preserve source information. ($fun): Add a src member to $fun. Otherwise we might miss the source info for the start of the function. * .dir-locals.el: * module/language/cps/arities.scm: * module/language/cps/closure-conversion.scm: * module/language/cps/compile-rtl.scm: * module/language/cps/constructors.scm: * module/language/cps/contification.scm: * module/language/cps/dfg.scm: * module/language/cps/elide-values.scm: * module/language/cps/reify-primitives.scm: * module/language/cps/slot-allocation.scm: * module/language/cps/verify.scm: * module/language/tree-il/compile-cps.scm: Update the whole CPS world for this change.
This commit is contained in:
Andy Wingo
parent
963d95f1d9
commit
6e422a3599
13 changed files with 767 additions and 784 deletions
|
|
@ -21,7 +21,7 @@
|
|||
(eval . (put '$letk 'scheme-indent-function 1))
|
||||
(eval . (put '$letk* 'scheme-indent-function 1))
|
||||
(eval . (put '$letconst 'scheme-indent-function 1))
|
||||
(eval . (put '$continue '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 '$kclause 'scheme-indent-function 1))
|
||||
|
|
|
|||
|
|
@ -25,15 +25,15 @@
|
|||
;;; and terms that call continuations.
|
||||
;;;
|
||||
;;; $letk binds a set of mutually recursive continuations, each one an
|
||||
;;; instance of $cont. A $cont declares the name and source of a
|
||||
;;; continuation, and then contains as a subterm the particular
|
||||
;;; continuation instance: $kif for test continuations, $kargs for
|
||||
;;; continuations that bind values, etc.
|
||||
;;; instance of $cont. A $cont declares the name of a continuation, and
|
||||
;;; then contains as a subterm the particular continuation instance:
|
||||
;;; $kif for test continuations, $kargs for continuations that bind
|
||||
;;; values, etc.
|
||||
;;;
|
||||
;;; $continue nodes call continuations. The expression contained in the
|
||||
;;; $continue node determines the value or values that are passed to the
|
||||
;;; target continuation: $const to pass a constant value, $values to
|
||||
;;; pass multiple named values, etc.
|
||||
;;; pass multiple named values, etc. $continue nodes also record the source at which
|
||||
;;;
|
||||
;;; Additionally there is $letrec, a term that binds mutually recursive
|
||||
;;; functions. The contification pass will turn $letrec into $letk if
|
||||
|
|
@ -71,8 +71,8 @@
|
|||
;;; That's to say that a $fun can be matched like this:
|
||||
;;;
|
||||
;;; (match f
|
||||
;;; (($ $fun meta free
|
||||
;;; ($ $cont kentry src
|
||||
;;; (($ $fun src meta free
|
||||
;;; ($ $cont kentry
|
||||
;;; ($ $kentry self ($ $cont ktail _ ($ $ktail))
|
||||
;;; (($ $kclause arity
|
||||
;;; ($ $cont kbody _ ($ $kargs names syms body)))
|
||||
|
|
@ -165,11 +165,11 @@
|
|||
|
||||
;; Terms.
|
||||
(define-cps-type $letk conts body)
|
||||
(define-cps-type $continue k exp)
|
||||
(define-cps-type $continue k src exp)
|
||||
(define-cps-type $letrec names syms funs body)
|
||||
|
||||
;; Continuations
|
||||
(define-cps-type $cont k src cont)
|
||||
(define-cps-type $cont k cont)
|
||||
(define-cps-type $kif kt kf)
|
||||
(define-cps-type $ktrunc arity k)
|
||||
(define-cps-type $kargs names syms body)
|
||||
|
|
@ -182,7 +182,7 @@
|
|||
(define-cps-type $void)
|
||||
(define-cps-type $const val)
|
||||
(define-cps-type $prim name)
|
||||
(define-cps-type $fun meta free body)
|
||||
(define-cps-type $fun src meta free body)
|
||||
(define-cps-type $call proc args)
|
||||
(define-cps-type $primcall name args)
|
||||
(define-cps-type $values args)
|
||||
|
|
@ -224,7 +224,7 @@
|
|||
(define-syntax build-cps-cont
|
||||
(syntax-rules (unquote)
|
||||
((_ (unquote exp)) exp)
|
||||
((_ (k src cont)) (make-$cont k src (build-cont-body cont)))))
|
||||
((_ (k cont)) (make-$cont k (build-cont-body cont)))))
|
||||
|
||||
(define-syntax build-cps-exp
|
||||
(syntax-rules (unquote
|
||||
|
|
@ -234,7 +234,8 @@
|
|||
((_ ($void)) (make-$void))
|
||||
((_ ($const val)) (make-$const val))
|
||||
((_ ($prim name)) (make-$prim name))
|
||||
((_ ($fun meta free body)) (make-$fun meta free (build-cps-cont body)))
|
||||
((_ ($fun src meta free body))
|
||||
(make-$fun src meta free (build-cps-cont body)))
|
||||
((_ ($call proc (arg ...))) (make-$call proc (list arg ...)))
|
||||
((_ ($call proc args)) (make-$call proc args))
|
||||
((_ ($primcall name (arg ...))) (make-$primcall name (list arg ...)))
|
||||
|
|
@ -262,12 +263,14 @@
|
|||
((_ ($letconst ((name sym val) tail ...) body))
|
||||
(let-gensyms (kconst)
|
||||
(build-cps-term
|
||||
($letk ((kconst #f ($kargs (name) (sym) ($letconst (tail ...) body))))
|
||||
($continue kconst ($const val))))))
|
||||
($letk ((kconst ($kargs (name) (sym) ($letconst (tail ...) body))))
|
||||
($continue kconst (let ((props (source-properties val)))
|
||||
(and (pair? props) props))
|
||||
($const val))))))
|
||||
((_ ($letrec names gensyms funs body))
|
||||
(make-$letrec names gensyms funs (build-cps-term body)))
|
||||
((_ ($continue k exp))
|
||||
(make-$continue k (build-cps-exp exp)))))
|
||||
((_ ($continue k src exp))
|
||||
(make-$continue k src (build-cps-exp exp)))))
|
||||
|
||||
(define-syntax-rule (rewrite-cps-term x (pat body) ...)
|
||||
(match x
|
||||
|
|
@ -287,12 +290,12 @@
|
|||
;; Continuations.
|
||||
(('letconst k (name sym c) body)
|
||||
(build-cps-term
|
||||
($letk ((k (src exp) ($kargs (name) (sym)
|
||||
($letk ((k ($kargs (name) (sym)
|
||||
,(parse-cps body))))
|
||||
($continue k ($const c)))))
|
||||
($continue k (src exp) ($const c)))))
|
||||
(('let k (name sym val) body)
|
||||
(build-cps-term
|
||||
($letk ((k (src exp) ($kargs (name) (sym)
|
||||
($letk ((k ($kargs (name) (sym)
|
||||
,(parse-cps body))))
|
||||
,(parse-cps val))))
|
||||
(('letk (cont ...) body)
|
||||
|
|
@ -300,7 +303,7 @@
|
|||
($letk ,(map parse-cps cont) ,(parse-cps body))))
|
||||
(('k sym body)
|
||||
(build-cps-cont
|
||||
(sym (src exp) ,(parse-cps body))))
|
||||
(sym ,(parse-cps body))))
|
||||
(('kif kt kf)
|
||||
(build-cont-body ($kif kt kf)))
|
||||
(('ktrunc req rest k)
|
||||
|
|
@ -322,7 +325,7 @@
|
|||
|
||||
;; Calls.
|
||||
(('continue k exp)
|
||||
(build-cps-term ($continue k ,(parse-cps exp))))
|
||||
(build-cps-term ($continue k (src exp) ,(parse-cps exp))))
|
||||
(('var sym)
|
||||
(build-cps-exp ($var sym)))
|
||||
(('void)
|
||||
|
|
@ -332,7 +335,7 @@
|
|||
(('prim name)
|
||||
(build-cps-exp ($prim name)))
|
||||
(('fun meta free body)
|
||||
(build-cps-exp ($fun meta free ,(parse-cps body))))
|
||||
(build-cps-exp ($fun (src exp) meta free ,(parse-cps body))))
|
||||
(('letrec ((name sym fun) ...) body)
|
||||
(build-cps-term
|
||||
($letrec name sym (map parse-cps fun) ,(parse-cps body))))
|
||||
|
|
@ -350,16 +353,16 @@
|
|||
(define (unparse-cps exp)
|
||||
(match exp
|
||||
;; Continuations.
|
||||
(($ $letk (($ $cont k src ($ $kargs (name) (sym) body)))
|
||||
($ $continue k ($ $const c)))
|
||||
(($ $letk (($ $cont k ($ $kargs (name) (sym) body)))
|
||||
($ $continue k src ($ $const c)))
|
||||
`(letconst ,k (,name ,sym ,c)
|
||||
,(unparse-cps body)))
|
||||
(($ $letk (($ $cont k src ($ $kargs (name) (sym) body))) val)
|
||||
(($ $letk (($ $cont k ($ $kargs (name) (sym) body))) val)
|
||||
`(let ,k (,name ,sym ,(unparse-cps val))
|
||||
,(unparse-cps body)))
|
||||
(($ $letk conts body)
|
||||
`(letk ,(map unparse-cps conts) ,(unparse-cps body)))
|
||||
(($ $cont sym src body)
|
||||
(($ $cont sym body)
|
||||
`(k ,sym ,(unparse-cps body)))
|
||||
(($ $kif kt kf)
|
||||
`(kif ,kt ,kf))
|
||||
|
|
@ -377,7 +380,7 @@
|
|||
`(kclause (,req ,opt ,rest ,kw ,allow-other-keys?) ,(unparse-cps body)))
|
||||
|
||||
;; Calls.
|
||||
(($ $continue k exp)
|
||||
(($ $continue k src exp)
|
||||
`(continue ,k ,(unparse-cps exp)))
|
||||
(($ $var sym)
|
||||
`(var ,sym))
|
||||
|
|
@ -387,7 +390,7 @@
|
|||
`(const ,val))
|
||||
(($ $prim name)
|
||||
`(prim ,name))
|
||||
(($ $fun meta free body)
|
||||
(($ $fun src meta free body)
|
||||
`(fun ,meta ,free ,(unparse-cps body)))
|
||||
(($ $letrec names syms funs body)
|
||||
`(letrec ,(map (lambda (name sym fun)
|
||||
|
|
@ -408,8 +411,8 @@
|
|||
(define (fold-conts proc seed fun)
|
||||
(define (cont-folder cont seed)
|
||||
(match cont
|
||||
(($ $cont k src cont)
|
||||
(let ((seed (proc k src cont seed)))
|
||||
(($ $cont k cont)
|
||||
(let ((seed (proc k cont seed)))
|
||||
(match cont
|
||||
(($ $kargs names syms body)
|
||||
(term-folder body seed))
|
||||
|
|
@ -424,7 +427,7 @@
|
|||
|
||||
(define (fun-folder fun seed)
|
||||
(match fun
|
||||
(($ $fun meta free body)
|
||||
(($ $fun src meta free body)
|
||||
(cont-folder body seed))))
|
||||
|
||||
(define (term-folder term seed)
|
||||
|
|
@ -432,7 +435,7 @@
|
|||
(($ $letk conts body)
|
||||
(fold cont-folder (term-folder body seed) conts))
|
||||
|
||||
(($ $continue k exp)
|
||||
(($ $continue k src exp)
|
||||
(match exp
|
||||
(($ $fun) (fun-folder exp seed))
|
||||
(_ seed)))
|
||||
|
|
@ -445,8 +448,8 @@
|
|||
(define (fold-local-conts proc seed cont)
|
||||
(define (cont-folder cont seed)
|
||||
(match cont
|
||||
(($ $cont k src cont)
|
||||
(let ((seed (proc k src cont seed)))
|
||||
(($ $cont k cont)
|
||||
(let ((seed (proc k cont seed)))
|
||||
(match cont
|
||||
(($ $kargs names syms body)
|
||||
(term-folder body seed))
|
||||
|
|
|
|||
|
|
@ -35,105 +35,105 @@
|
|||
(define (fix-clause-arities clause)
|
||||
(let ((conts (build-local-cont-table clause))
|
||||
(ktail (match clause
|
||||
(($ $cont _ _ ($ $kentry _ ($ $cont ktail) _)) ktail))))
|
||||
(($ $cont _ ($ $kentry _ ($ $cont ktail) _)) ktail))))
|
||||
(define (visit-term term)
|
||||
(rewrite-cps-term term
|
||||
(($ $letk conts body)
|
||||
($letk ,(map visit-cont conts) ,(visit-term body)))
|
||||
(($ $letrec names syms funs body)
|
||||
($letrec names syms (map fix-arities funs) ,(visit-term body)))
|
||||
(($ $continue k exp)
|
||||
,(visit-exp k exp))))
|
||||
(($ $continue k src exp)
|
||||
,(visit-exp k src exp))))
|
||||
|
||||
(define (adapt-exp nvals k exp)
|
||||
(define (adapt-exp nvals k src exp)
|
||||
(match nvals
|
||||
(0
|
||||
(rewrite-cps-term (lookup-cont k conts)
|
||||
(($ $ktail)
|
||||
,(let-gensyms (kvoid kunspec unspec)
|
||||
(build-cps-term
|
||||
($letk* ((kunspec #f ($kargs (unspec) (unspec)
|
||||
($continue k
|
||||
($letk* ((kunspec ($kargs (unspec) (unspec)
|
||||
($continue k src
|
||||
($primcall 'return (unspec)))))
|
||||
(kvoid #f ($kargs () ()
|
||||
($continue kunspec ($void)))))
|
||||
($continue kvoid ,exp)))))
|
||||
(kvoid ($kargs () ()
|
||||
($continue kunspec src ($void)))))
|
||||
($continue kvoid src ,exp)))))
|
||||
(($ $ktrunc arity kargs)
|
||||
,(rewrite-cps-term arity
|
||||
(($ $arity () () #f () #f)
|
||||
($continue kargs ,exp))
|
||||
($continue kargs src ,exp))
|
||||
(_
|
||||
,(let-gensyms (kvoid kvalues void)
|
||||
(build-cps-term
|
||||
($letk* ((kvalues #f ($kargs ('void) (void)
|
||||
($continue k
|
||||
($letk* ((kvalues ($kargs ('void) (void)
|
||||
($continue k src
|
||||
($primcall 'values (void)))))
|
||||
(kvoid #f ($kargs () ()
|
||||
($continue kvalues
|
||||
(kvoid ($kargs () ()
|
||||
($continue kvalues src
|
||||
($void)))))
|
||||
($continue kvoid ,exp)))))))
|
||||
($continue kvoid src ,exp)))))))
|
||||
(($ $kargs () () _)
|
||||
($continue k ,exp))
|
||||
($continue k src ,exp))
|
||||
(_
|
||||
,(let-gensyms (k*)
|
||||
(build-cps-term
|
||||
($letk ((k* #f ($kargs () () ($continue k ($void)))))
|
||||
($continue k* ,exp)))))))
|
||||
($letk ((k* ($kargs () () ($continue k src ($void)))))
|
||||
($continue k* src ,exp)))))))
|
||||
(1
|
||||
(rewrite-cps-term (lookup-cont k conts)
|
||||
(($ $ktail)
|
||||
,(rewrite-cps-term exp
|
||||
(($var sym)
|
||||
($continue ktail ($primcall 'return (sym))))
|
||||
($continue ktail src ($primcall 'return (sym))))
|
||||
(_
|
||||
,(let-gensyms (k* v)
|
||||
(build-cps-term
|
||||
($letk ((k* #f ($kargs (v) (v)
|
||||
($continue k
|
||||
($letk ((k* ($kargs (v) (v)
|
||||
($continue k src
|
||||
($primcall 'return (v))))))
|
||||
($continue k* ,exp)))))))
|
||||
($continue k* src ,exp)))))))
|
||||
(($ $ktrunc arity kargs)
|
||||
,(rewrite-cps-term arity
|
||||
(($ $arity (_) () #f () #f)
|
||||
($continue kargs ,exp))
|
||||
($continue kargs src ,exp))
|
||||
(_
|
||||
,(let-gensyms (kvalues value)
|
||||
(build-cps-term
|
||||
($letk ((kvalues #f ($kargs ('value) (value)
|
||||
($continue k
|
||||
($letk ((kvalues ($kargs ('value) (value)
|
||||
($continue k src
|
||||
($primcall 'values (value))))))
|
||||
($continue kvalues ,exp)))))))
|
||||
($continue kvalues src ,exp)))))))
|
||||
(($ $kargs () () _)
|
||||
,(let-gensyms (k* drop)
|
||||
(build-cps-term
|
||||
($letk ((k* #f ($kargs ('drop) (drop)
|
||||
($continue k ($values ())))))
|
||||
($continue k* ,exp)))))
|
||||
($letk ((k* ($kargs ('drop) (drop)
|
||||
($continue k src ($values ())))))
|
||||
($continue k* src ,exp)))))
|
||||
(_
|
||||
($continue k ,exp))))))
|
||||
($continue k src ,exp))))))
|
||||
|
||||
(define (visit-exp k exp)
|
||||
(define (visit-exp k src exp)
|
||||
(rewrite-cps-term exp
|
||||
((or ($ $void)
|
||||
($ $const)
|
||||
($ $prim)
|
||||
($ $var))
|
||||
,(adapt-exp 1 k exp))
|
||||
,(adapt-exp 1 k src exp))
|
||||
(($ $fun)
|
||||
,(adapt-exp 1 k (fix-arities exp)))
|
||||
,(adapt-exp 1 k src (fix-arities exp)))
|
||||
(($ $call)
|
||||
;; In general, calls have unknown return arity. For that
|
||||
;; reason every non-tail call has an implicit adaptor
|
||||
;; continuation to adapt the return to the target
|
||||
;; continuation, and we don't need to do any adapting here.
|
||||
($continue k ,exp))
|
||||
($continue k src ,exp))
|
||||
(($ $primcall 'return (arg))
|
||||
;; Primcalls to return are in tail position.
|
||||
($continue ktail ,exp))
|
||||
($continue ktail src ,exp))
|
||||
(($ $primcall (? (lambda (name)
|
||||
(and (not (prim-rtl-instruction name))
|
||||
(not (branching-primitive? name))))))
|
||||
($continue k ,exp))
|
||||
($continue k src ,exp))
|
||||
(($ $primcall 'struct-set! (obj pos val))
|
||||
;; Unhappily, and undocumentedly, struct-set! returns the value
|
||||
;; that was set. There is code that relies on this. Hackety
|
||||
|
|
@ -142,63 +142,63 @@
|
|||
(($ $ktail)
|
||||
,(let-gensyms (kvoid)
|
||||
(build-cps-term
|
||||
($letk* ((kvoid #f ($kargs () ()
|
||||
($continue ktail
|
||||
($letk* ((kvoid ($kargs () ()
|
||||
($continue ktail src
|
||||
($primcall 'return (val))))))
|
||||
($continue kvoid ,exp)))))
|
||||
($continue kvoid src ,exp)))))
|
||||
(($ $ktrunc arity kargs)
|
||||
,(rewrite-cps-term arity
|
||||
(($ $arity () () #f () #f)
|
||||
($continue kargs ,exp))
|
||||
($continue kargs src ,exp))
|
||||
(_
|
||||
,(let-gensyms (kvoid)
|
||||
(build-cps-term
|
||||
($letk* ((kvoid #f ($kargs () ()
|
||||
($continue k
|
||||
($letk* ((kvoid ($kargs () ()
|
||||
($continue k src
|
||||
($primcall 'values (val))))))
|
||||
($continue kvoid ,exp)))))))
|
||||
($continue kvoid src ,exp)))))))
|
||||
(($ $kargs () () _)
|
||||
($continue k ,exp))
|
||||
($continue k src ,exp))
|
||||
(_
|
||||
,(let-gensyms (k*)
|
||||
(build-cps-term
|
||||
($letk ((k* #f ($kargs () () ($continue k ($var val)))))
|
||||
($continue k* ,exp)))))))
|
||||
($letk ((k* ($kargs () () ($continue k src ($var val)))))
|
||||
($continue k* src ,exp)))))))
|
||||
(($ $primcall name args)
|
||||
,(match (prim-arity name)
|
||||
((out . in)
|
||||
(if (= in (length args))
|
||||
(adapt-exp out k
|
||||
(adapt-exp out k src
|
||||
(let ((inst (prim-rtl-instruction name)))
|
||||
(if (and inst (not (eq? inst name)))
|
||||
(build-cps-exp ($primcall inst args))
|
||||
exp)))
|
||||
(let-gensyms (k* p*)
|
||||
(build-cps-term
|
||||
($letk ((k* #f ($kargs ('prim) (p*)
|
||||
($continue k ($call p* args)))))
|
||||
($continue k* ($prim name)))))))))
|
||||
($letk ((k* ($kargs ('prim) (p*)
|
||||
($continue k src ($call p* args)))))
|
||||
($continue k* src ($prim name)))))))))
|
||||
(($ $values)
|
||||
;; Values nodes are inserted by CPS optimization passes, so
|
||||
;; we assume they are correct.
|
||||
($continue k ,exp))
|
||||
($continue k src ,exp))
|
||||
(($ $prompt)
|
||||
($continue k ,exp))))
|
||||
($continue k src ,exp))))
|
||||
|
||||
(define (visit-cont cont)
|
||||
(rewrite-cps-cont cont
|
||||
(($ $cont sym src ($ $kargs names syms body))
|
||||
(sym src ($kargs names syms ,(visit-term body))))
|
||||
(($ $cont sym src ($ $kclause arity body))
|
||||
(sym src ($kclause ,arity ,(visit-cont body))))
|
||||
(($ $cont sym ($ $kargs names syms body))
|
||||
(sym ($kargs names syms ,(visit-term body))))
|
||||
(($ $cont sym ($ $kclause arity body))
|
||||
(sym ($kclause ,arity ,(visit-cont body))))
|
||||
(($ $cont)
|
||||
,cont)))
|
||||
|
||||
(rewrite-cps-cont clause
|
||||
(($ $cont sym src ($ $kentry self tail clauses))
|
||||
(sym src ($kentry self ,tail ,(map visit-cont clauses)))))))
|
||||
(($ $cont sym ($ $kentry self tail clauses))
|
||||
(sym ($kentry self ,tail ,(map visit-cont clauses)))))))
|
||||
|
||||
(define (fix-arities fun)
|
||||
(rewrite-cps-exp fun
|
||||
(($ $fun meta free body)
|
||||
($fun meta free ,(fix-clause-arities body)))))
|
||||
(($ $fun src meta free body)
|
||||
($fun src meta free ,(fix-clause-arities body)))))
|
||||
|
|
|
|||
|
|
@ -63,8 +63,8 @@ values in the term."
|
|||
(let-gensyms (k* sym*)
|
||||
(receive (exp free) (k sym*)
|
||||
(values (build-cps-term
|
||||
($letk ((k* #f ($kargs (sym*) (sym*) ,exp)))
|
||||
($continue k* ($primcall 'free-ref (self sym)))))
|
||||
($letk ((k* ($kargs (sym*) (sym*) ,exp)))
|
||||
($continue k* #f ($primcall 'free-ref (self sym)))))
|
||||
(cons sym free))))))
|
||||
|
||||
(define (convert-free-vars syms self bound k)
|
||||
|
|
@ -88,13 +88,13 @@ performed, and @var{outer-bound} is the list of bound variables there."
|
|||
(fold (lambda (free idx body)
|
||||
(let-gensyms (k idxsym)
|
||||
(build-cps-term
|
||||
($letk ((k src ($kargs () () ,body)))
|
||||
($letk ((k ($kargs () () ,body)))
|
||||
,(convert-free-var
|
||||
free outer-self outer-bound
|
||||
(lambda (free)
|
||||
(values (build-cps-term
|
||||
($letconst (('idx idxsym idx))
|
||||
($continue k
|
||||
($continue k src
|
||||
($primcall 'free-set! (v idxsym free)))))
|
||||
'())))))))
|
||||
body
|
||||
|
|
@ -123,19 +123,19 @@ convert functions to flat closures."
|
|||
(values (build-cps-term ($letk ,conts ,body))
|
||||
(union free free*)))))
|
||||
|
||||
(($ $cont sym src ($ $kargs names syms body))
|
||||
(($ $cont sym ($ $kargs names syms body))
|
||||
(receive (body free) (cc body self (append syms bound))
|
||||
(values (build-cps-cont (sym src ($kargs names syms ,body)))
|
||||
(values (build-cps-cont (sym ($kargs names syms ,body)))
|
||||
free)))
|
||||
|
||||
(($ $cont sym src ($ $kentry self tail clauses))
|
||||
(($ $cont sym ($ $kentry self tail clauses))
|
||||
(receive (clauses free) (cc* clauses self (list self))
|
||||
(values (build-cps-cont (sym src ($kentry self ,tail ,clauses)))
|
||||
(values (build-cps-cont (sym ($kentry self ,tail ,clauses)))
|
||||
free)))
|
||||
|
||||
(($ $cont sym src ($ $kclause arity body))
|
||||
(($ $cont sym ($ $kclause arity body))
|
||||
(receive (body free) (cc body self bound)
|
||||
(values (build-cps-cont (sym src ($kclause ,arity ,body)))
|
||||
(values (build-cps-cont (sym ($kclause ,arity ,body)))
|
||||
free)))
|
||||
|
||||
(($ $cont)
|
||||
|
|
@ -153,76 +153,76 @@ convert functions to flat closures."
|
|||
(free free))
|
||||
(match in
|
||||
(() (values (bindings body) free))
|
||||
(((name sym ($ $fun meta () fun-body)) . in)
|
||||
(((name sym ($ $fun src meta () fun-body)) . in)
|
||||
(receive (fun-body fun-free) (cc fun-body #f '())
|
||||
(lp in
|
||||
(lambda (body)
|
||||
(let-gensyms (k)
|
||||
(build-cps-term
|
||||
($letk ((k #f ($kargs (name) (sym) ,(bindings body))))
|
||||
($continue k
|
||||
($fun meta fun-free ,fun-body))))))
|
||||
(init-closure #f sym fun-free self bound body)
|
||||
($letk ((k ($kargs (name) (sym) ,(bindings body))))
|
||||
($continue k src
|
||||
($fun src meta fun-free ,fun-body))))))
|
||||
(init-closure src sym fun-free self bound body)
|
||||
(union free (difference fun-free bound))))))))))
|
||||
|
||||
(($ $continue k ($ $var sym))
|
||||
(($ $continue k src ($ $var sym))
|
||||
(convert-free-var sym self bound
|
||||
(lambda (sym)
|
||||
(values (build-cps-term ($continue k ($var sym)))
|
||||
(values (build-cps-term ($continue k src ($var sym)))
|
||||
'()))))
|
||||
|
||||
(($ $continue k
|
||||
(($ $continue k src
|
||||
(or ($ $void)
|
||||
($ $const)
|
||||
($ $prim)))
|
||||
(values exp '()))
|
||||
|
||||
(($ $continue k ($ $fun meta () body))
|
||||
(($ $continue k src ($ $fun src* meta () body))
|
||||
(receive (body free) (cc body #f '())
|
||||
(match free
|
||||
(()
|
||||
(values (build-cps-term
|
||||
($continue k ($fun meta free ,body)))
|
||||
($continue k src ($fun src* meta free ,body)))
|
||||
free))
|
||||
(_
|
||||
(values
|
||||
(let-gensyms (kinit v)
|
||||
(build-cps-term
|
||||
($letk ((kinit #f ($kargs (v) (v)
|
||||
,(init-closure #f v free self bound
|
||||
($letk ((kinit ($kargs (v) (v)
|
||||
,(init-closure src v free self bound
|
||||
(build-cps-term
|
||||
($continue k ($var v)))))))
|
||||
($continue kinit ($fun meta free ,body)))))
|
||||
($continue k src ($var v)))))))
|
||||
($continue kinit src ($fun src* meta free ,body)))))
|
||||
(difference free bound))))))
|
||||
|
||||
(($ $continue k ($ $call proc args))
|
||||
(($ $continue k src ($ $call proc args))
|
||||
(convert-free-vars (cons proc args) self bound
|
||||
(match-lambda
|
||||
((proc . args)
|
||||
(values (build-cps-term
|
||||
($continue k ($call proc args)))
|
||||
($continue k src ($call proc args)))
|
||||
'())))))
|
||||
|
||||
(($ $continue k ($ $primcall name args))
|
||||
(($ $continue k src ($ $primcall name args))
|
||||
(convert-free-vars args self bound
|
||||
(lambda (args)
|
||||
(values (build-cps-term
|
||||
($continue k ($primcall name args)))
|
||||
($continue k src ($primcall name args)))
|
||||
'()))))
|
||||
|
||||
(($ $continue k ($ $values args))
|
||||
(($ $continue k src ($ $values args))
|
||||
(convert-free-vars args self bound
|
||||
(lambda (args)
|
||||
(values (build-cps-term
|
||||
($continue k ($values args)))
|
||||
($continue k src ($values args)))
|
||||
'()))))
|
||||
|
||||
(($ $continue k ($ $prompt escape? tag handler pop))
|
||||
(($ $continue k src ($ $prompt escape? tag handler pop))
|
||||
(convert-free-var
|
||||
tag self bound
|
||||
(lambda (tag)
|
||||
(values (build-cps-term
|
||||
($continue k ($prompt escape? tag handler pop)))
|
||||
($continue k src ($prompt escape? tag handler pop)))
|
||||
'()))))
|
||||
|
||||
(_ (error "what" exp))))
|
||||
|
|
@ -237,37 +237,38 @@ convert functions to flat closures."
|
|||
(rewrite-cps-term term
|
||||
(($ $letk conts body)
|
||||
($letk ,(map visit-cont conts) ,(visit-term body)))
|
||||
(($ $continue k ($ $primcall 'free-ref (closure sym)))
|
||||
(($ $continue k src ($ $primcall 'free-ref (closure sym)))
|
||||
,(let-gensyms (idx)
|
||||
(build-cps-term
|
||||
($letconst (('idx idx (free-index sym)))
|
||||
($continue k ($primcall 'free-ref (closure idx)))))))
|
||||
(($ $continue k ($ $fun meta free body))
|
||||
($continue k ($fun meta free ,(convert-to-indices body free))))
|
||||
($continue k src ($primcall 'free-ref (closure idx)))))))
|
||||
(($ $continue k src ($ $fun src* meta free body))
|
||||
($continue k src
|
||||
($fun src* meta free ,(convert-to-indices body free))))
|
||||
(($ $continue)
|
||||
,term)))
|
||||
(define (visit-cont cont)
|
||||
(rewrite-cps-cont cont
|
||||
(($ $cont sym src ($ $kargs names syms body))
|
||||
(sym src ($kargs names syms ,(visit-term body))))
|
||||
(($ $cont sym src ($ $kclause arity body))
|
||||
(sym src ($kclause ,arity ,(visit-cont body))))
|
||||
(($ $cont sym ($ $kargs names syms body))
|
||||
(sym ($kargs names syms ,(visit-term body))))
|
||||
(($ $cont sym ($ $kclause arity body))
|
||||
(sym ($kclause ,arity ,(visit-cont body))))
|
||||
;; Other kinds of continuations don't bind values and don't have
|
||||
;; bodies.
|
||||
(($ $cont)
|
||||
,cont)))
|
||||
|
||||
(rewrite-cps-cont body
|
||||
(($ $cont sym src ($ $kentry self tail clauses))
|
||||
(sym src ($kentry self ,tail ,(map visit-cont clauses))))))
|
||||
(($ $cont sym ($ $kentry self tail clauses))
|
||||
(sym ($kentry self ,tail ,(map visit-cont clauses))))))
|
||||
|
||||
(define (convert-closures exp)
|
||||
"Convert free reference in @var{exp} to primcalls to @code{free-ref},
|
||||
and allocate and initialize flat closures."
|
||||
(match exp
|
||||
(($ $fun meta () body)
|
||||
(($ $fun src meta () 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 meta free ,(convert-to-indices body free)))))))
|
||||
($fun src meta free ,(convert-to-indices body free)))))))
|
||||
|
|
|
|||
|
|
@ -76,39 +76,26 @@
|
|||
exp))
|
||||
|
||||
(define (collect-conts f cfa)
|
||||
(let ((srcv (make-vector (cfa-k-count cfa) #f))
|
||||
(contv (make-vector (cfa-k-count cfa) #f)))
|
||||
(let ((contv (make-vector (cfa-k-count cfa) #f)))
|
||||
(fold-local-conts
|
||||
(lambda (k src cont tail)
|
||||
(lambda (k cont tail)
|
||||
(let ((idx (cfa-k-idx cfa k #:default (lambda (k) #f))))
|
||||
(when idx
|
||||
(when src
|
||||
(vector-set! srcv idx src))
|
||||
(vector-set! contv idx cont))))
|
||||
'()
|
||||
(match f
|
||||
(($ $fun meta free entry)
|
||||
(($ $fun src meta free entry)
|
||||
entry)))
|
||||
(values srcv contv)))
|
||||
contv))
|
||||
|
||||
(define (compile-fun f asm)
|
||||
(let* ((dfg (compute-dfg f #:global? #f))
|
||||
(cfa (analyze-control-flow f dfg))
|
||||
(allocation (allocate-slots f dfg)))
|
||||
(call-with-values (lambda () (collect-conts f cfa))
|
||||
(lambda (srcv contv)
|
||||
(allocation (allocate-slots f dfg))
|
||||
(contv (collect-conts f cfa)))
|
||||
(define (lookup-cont k)
|
||||
(vector-ref contv (cfa-k-idx cfa k)))
|
||||
|
||||
(define (maybe-emit-source n)
|
||||
(let ((src (vector-ref srcv n)))
|
||||
(when src
|
||||
(emit-source asm src))))
|
||||
|
||||
(define (emit-label-and-maybe-source n)
|
||||
(emit-label asm (cfa-k-sym cfa n))
|
||||
(maybe-emit-source n))
|
||||
|
||||
(define (immediate-u8? val)
|
||||
(and (integer? val) (exact? val) (<= 0 val 255)))
|
||||
|
||||
|
|
@ -141,7 +128,6 @@
|
|||
(match (vector-ref contv 0)
|
||||
(($ $kentry self tail clauses)
|
||||
(emit-begin-program asm (cfa-k-sym cfa 0) meta)
|
||||
(maybe-emit-source 0)
|
||||
(let lp ((n 1)
|
||||
(ks (map (match-lambda (($ $cont k) k)) clauses)))
|
||||
(match ks
|
||||
|
|
@ -158,12 +144,13 @@
|
|||
(define (compile-clause n alternate)
|
||||
(match (vector-ref contv n)
|
||||
(($ $kclause ($ $arity req opt rest kw allow-other-keys?))
|
||||
(let ((kw-indices (map (match-lambda
|
||||
(let* ((kw-indices (map (match-lambda
|
||||
((key name sym)
|
||||
(cons key (lookup-slot sym allocation))))
|
||||
kw))
|
||||
(nlocals (lookup-nlocals (cfa-k-sym cfa n) allocation)))
|
||||
(emit-label-and-maybe-source n)
|
||||
(k (cfa-k-sym cfa n))
|
||||
(nlocals (lookup-nlocals k allocation)))
|
||||
(emit-label asm k)
|
||||
(emit-begin-kw-arity asm req opt rest kw-indices
|
||||
allow-other-keys? nlocals alternate)
|
||||
(let ((next (compile-body (1+ n) nlocals)))
|
||||
|
|
@ -177,16 +164,18 @@
|
|||
(match (vector-ref contv n)
|
||||
(($ $kclause) n)
|
||||
(($ $kargs _ _ term)
|
||||
(emit-label-and-maybe-source n)
|
||||
(emit-label asm (cfa-k-sym cfa n))
|
||||
(let find-exp ((term term))
|
||||
(match term
|
||||
(($ $letk conts term)
|
||||
(find-exp term))
|
||||
(($ $continue k exp)
|
||||
(($ $continue k src exp)
|
||||
(when src
|
||||
(emit-source asm src))
|
||||
(compile-expression n k exp nlocals)
|
||||
(compile-cont (1+ n))))))
|
||||
(_
|
||||
(emit-label-and-maybe-source n)
|
||||
(emit-label asm (cfa-k-sym cfa n))
|
||||
(compile-cont (1+ n)))))))
|
||||
|
||||
(define (compile-expression n k exp nlocals)
|
||||
|
|
@ -256,9 +245,9 @@
|
|||
(emit-load-constant asm dst *unspecified*))
|
||||
(($ $const exp)
|
||||
(emit-load-constant asm dst exp))
|
||||
(($ $fun meta () ($ $cont k))
|
||||
(($ $fun src meta () ($ $cont k))
|
||||
(emit-load-static-procedure asm dst k))
|
||||
(($ $fun meta free ($ $cont k))
|
||||
(($ $fun src meta free ($ $cont k))
|
||||
(emit-make-closure asm dst k (length free)))
|
||||
(($ $call proc args)
|
||||
(let ((proc-slot (lookup-call-proc-slot label allocation))
|
||||
|
|
@ -474,15 +463,18 @@
|
|||
(lp (1+ n) args))))))))
|
||||
|
||||
(match f
|
||||
(($ $fun meta free ($ $cont k src ($ $kentry self tail clauses)))
|
||||
(compile-entry (or meta '()))))))))
|
||||
(($ $fun src meta free ($ $cont k ($ $kentry self tail clauses)))
|
||||
;; FIXME: src on kentry instead?
|
||||
(when src
|
||||
(emit-source asm src))
|
||||
(compile-entry (or meta '()))))))
|
||||
|
||||
(define (visit-funs proc exp)
|
||||
(match exp
|
||||
(($ $continue _ exp)
|
||||
(($ $continue _ _ exp)
|
||||
(visit-funs proc exp))
|
||||
|
||||
(($ $fun meta free body)
|
||||
(($ $fun src meta free body)
|
||||
(proc exp)
|
||||
(visit-funs proc body))
|
||||
|
||||
|
|
@ -490,13 +482,13 @@
|
|||
(visit-funs proc body)
|
||||
(for-each (lambda (cont) (visit-funs proc cont)) conts))
|
||||
|
||||
(($ $cont sym src ($ $kargs names syms body))
|
||||
(($ $cont sym ($ $kargs names syms body))
|
||||
(visit-funs proc body))
|
||||
|
||||
(($ $cont sym src ($ $kclause arity body))
|
||||
(($ $cont sym ($ $kclause arity body))
|
||||
(visit-funs proc body))
|
||||
|
||||
(($ $cont sym src ($ $kentry self tail clauses))
|
||||
(($ $cont sym ($ $kentry self tail clauses))
|
||||
(for-each (lambda (clause) (visit-funs proc clause)) clauses))
|
||||
|
||||
(_ (values))))
|
||||
|
|
|
|||
|
|
@ -32,12 +32,12 @@
|
|||
(define (inline-constructors fun)
|
||||
(define (visit-cont cont)
|
||||
(rewrite-cps-cont cont
|
||||
(($ $cont sym src ($ $kargs names syms body))
|
||||
(sym src ($kargs names syms ,(visit-term body))))
|
||||
(($ $cont sym src ($ $kentry self tail clauses))
|
||||
(sym src ($kentry self ,tail ,(map visit-cont clauses))))
|
||||
(($ $cont sym src ($ $kclause arity body))
|
||||
(sym src ($kclause ,arity ,(visit-cont body))))
|
||||
(($ $cont sym ($ $kargs names syms body))
|
||||
(sym ($kargs names syms ,(visit-term body))))
|
||||
(($ $cont sym ($ $kentry self tail clauses))
|
||||
(sym ($kentry self ,tail ,(map visit-cont clauses))))
|
||||
(($ $cont sym ($ $kclause arity body))
|
||||
(sym ($kclause ,arity ,(visit-cont body))))
|
||||
(($ $cont)
|
||||
,cont)))
|
||||
(define (visit-term term)
|
||||
|
|
@ -48,51 +48,51 @@
|
|||
(($ $letrec names syms funs body)
|
||||
($letrec names syms (map inline-constructors funs)
|
||||
,(visit-term body)))
|
||||
(($ $continue k ($ $primcall 'list args))
|
||||
(($ $continue k src ($ $primcall 'list args))
|
||||
,(let-gensyms (kvalues val)
|
||||
(build-cps-term
|
||||
($letk ((kvalues #f ($kargs ('val) (val)
|
||||
($continue k
|
||||
($letk ((kvalues ($kargs ('val) (val)
|
||||
($continue k src
|
||||
($primcall 'values (val))))))
|
||||
,(let lp ((args args) (k kvalues))
|
||||
(match args
|
||||
(()
|
||||
(build-cps-term
|
||||
($continue k ($const '()))))
|
||||
($continue k src ($const '()))))
|
||||
((arg . args)
|
||||
(let-gensyms (ktail tail)
|
||||
(build-cps-term
|
||||
($letk ((ktail #f ($kargs ('tail) (tail)
|
||||
($continue k
|
||||
($letk ((ktail ($kargs ('tail) (tail)
|
||||
($continue k src
|
||||
($primcall 'cons (arg tail))))))
|
||||
,(lp args ktail)))))))))))
|
||||
(($ $continue k ($ $primcall 'vector args))
|
||||
(($ $continue k src ($ $primcall 'vector args))
|
||||
,(let-gensyms (kalloc vec len init)
|
||||
(define (initialize args n)
|
||||
(match args
|
||||
(()
|
||||
(build-cps-term
|
||||
($continue k ($primcall 'values (vec)))))
|
||||
($continue k src ($primcall 'values (vec)))))
|
||||
((arg . args)
|
||||
(let-gensyms (knext idx)
|
||||
(build-cps-term
|
||||
($letk ((knext #f ($kargs () ()
|
||||
($letk ((knext ($kargs () ()
|
||||
,(initialize args (1+ n)))))
|
||||
($letconst (('idx idx n))
|
||||
($continue knext
|
||||
($continue knext src
|
||||
($primcall 'vector-set! (vec idx arg))))))))))
|
||||
(build-cps-term
|
||||
($letk ((kalloc #f ($kargs ('vec) (vec)
|
||||
($letk ((kalloc ($kargs ('vec) (vec)
|
||||
,(initialize args 0))))
|
||||
($letconst (('len len (length args))
|
||||
('init init #f))
|
||||
($continue kalloc
|
||||
($continue kalloc src
|
||||
($primcall 'make-vector (len init))))))))
|
||||
(($ $continue k (and fun ($ $fun)))
|
||||
($continue k ,(inline-constructors fun)))
|
||||
(($ $continue k src (and fun ($ $fun)))
|
||||
($continue k src ,(inline-constructors fun)))
|
||||
(($ $continue)
|
||||
,term)))
|
||||
|
||||
(rewrite-cps-exp fun
|
||||
(($ $fun meta free body)
|
||||
($fun meta free ,(visit-cont body)))))
|
||||
(($ $fun src meta free body)
|
||||
($fun src meta free ,(visit-cont body)))))
|
||||
|
|
|
|||
|
|
@ -95,7 +95,7 @@
|
|||
;; target continuation. Otherwise return #f.
|
||||
(define (call-target use proc)
|
||||
(match (find-call (lookup-cont use cont-table))
|
||||
(($ $continue k ($ $call proc* args))
|
||||
(($ $continue k src ($ $call proc* args))
|
||||
(and (eq? proc proc*) (not (memq proc args)) (applicable? proc args)
|
||||
k))
|
||||
(_ #f)))
|
||||
|
|
@ -141,7 +141,7 @@
|
|||
;; bail.
|
||||
(($ $kentry self tail clauses)
|
||||
(match clauses
|
||||
((($ $cont _ _ ($ $kclause arity ($ $cont kargs))))
|
||||
((($ $cont _ ($ $kclause arity ($ $cont kargs))))
|
||||
kargs)
|
||||
(_ #f)))
|
||||
(_ scope)))))
|
||||
|
|
@ -168,15 +168,15 @@
|
|||
|
||||
(define (visit-fun term)
|
||||
(match term
|
||||
(($ $fun meta free body)
|
||||
(($ $fun src meta free body)
|
||||
(visit-cont body))))
|
||||
(define (visit-cont cont)
|
||||
(match cont
|
||||
(($ $cont sym src ($ $kargs _ _ body))
|
||||
(($ $cont sym ($ $kargs _ _ body))
|
||||
(visit-term body sym))
|
||||
(($ $cont sym src ($ $kentry self tail clauses))
|
||||
(($ $cont sym ($ $kentry self tail clauses))
|
||||
(for-each visit-cont clauses))
|
||||
(($ $cont sym src ($ $kclause arity body))
|
||||
(($ $cont sym ($ $kclause arity body))
|
||||
(visit-cont body))
|
||||
(($ $cont)
|
||||
#t)))
|
||||
|
|
@ -199,7 +199,7 @@
|
|||
(if (null? rec)
|
||||
'()
|
||||
(list rec)))
|
||||
(((and elt (n s ($ $fun meta free ($ $cont kentry))))
|
||||
(((and elt (n s ($ $fun src meta free ($ $cont kentry))))
|
||||
. nsf)
|
||||
(if (recursive? kentry)
|
||||
(lp nsf (cons elt rec))
|
||||
|
|
@ -208,11 +208,11 @@
|
|||
(match component
|
||||
(((name sym fun) ...)
|
||||
(match fun
|
||||
((($ $fun meta free
|
||||
($ $cont fun-k _
|
||||
((($ $fun src meta free
|
||||
($ $cont fun-k
|
||||
($ $kentry self
|
||||
($ $cont tail-k _ ($ $ktail))
|
||||
(($ $cont _ _ ($ $kclause arity body))
|
||||
($ $cont tail-k ($ $ktail))
|
||||
(($ $cont _ ($ $kclause arity body))
|
||||
...))))
|
||||
...)
|
||||
(unless (contify-funs term-k sym self tail-k arity body)
|
||||
|
|
@ -220,13 +220,13 @@
|
|||
(visit-term body term-k)
|
||||
(for-each visit-component
|
||||
(split-components (map list names syms funs))))
|
||||
(($ $continue k exp)
|
||||
(($ $continue k src exp)
|
||||
(match exp
|
||||
(($ $fun meta free
|
||||
($ $cont fun-k _
|
||||
(($ $fun src meta free
|
||||
($ $cont fun-k
|
||||
($ $kentry self
|
||||
($ $cont tail-k _ ($ $ktail))
|
||||
(($ $cont _ _ ($ $kclause arity body)) ...))))
|
||||
($ $cont tail-k ($ $ktail))
|
||||
(($ $cont _ ($ $kclause arity body)) ...))))
|
||||
(if (and=> (bound-symbol k)
|
||||
(lambda (sym)
|
||||
(contify-fun term-k sym self tail-k arity body)))
|
||||
|
|
@ -238,7 +238,7 @@
|
|||
(values call-substs cont-substs fun-elisions cont-splices)))
|
||||
|
||||
(define (apply-contification fun call-substs cont-substs fun-elisions cont-splices)
|
||||
(define (contify-call proc args)
|
||||
(define (contify-call src proc args)
|
||||
(and=> (assq-ref call-substs proc)
|
||||
(lambda (clauses)
|
||||
(let lp ((clauses clauses))
|
||||
|
|
@ -247,11 +247,11 @@
|
|||
(((($ $arity req () #f () #f) . k) . clauses)
|
||||
(if (= (length req) (length args))
|
||||
(build-cps-term
|
||||
($continue k
|
||||
($continue k src
|
||||
($values args)))
|
||||
(lp clauses)))
|
||||
((_ . clauses) (lp clauses)))))))
|
||||
(define (continue k exp)
|
||||
(define (continue k src exp)
|
||||
(define (lookup-return-cont k)
|
||||
(match (assq-ref cont-substs k)
|
||||
(#f k)
|
||||
|
|
@ -260,13 +260,13 @@
|
|||
;; We are contifying this return. It must be a call or a
|
||||
;; primcall to values, return, or return-values.
|
||||
(if (eq? k k*)
|
||||
(build-cps-term ($continue k ,exp))
|
||||
(build-cps-term ($continue k src ,exp))
|
||||
(rewrite-cps-term exp
|
||||
(($ $primcall 'return (val))
|
||||
($continue k* ($primcall 'values (val))))
|
||||
($continue k* src ($primcall 'values (val))))
|
||||
(($ $values vals)
|
||||
($continue k* ($primcall 'values vals)))
|
||||
(_ ($continue k* ,exp))))))
|
||||
($continue k* src ($primcall 'values vals)))
|
||||
(_ ($continue k* src ,exp))))))
|
||||
(define (splice-continuations term-k term)
|
||||
(match (hashq-ref cont-splices term-k)
|
||||
(#f term)
|
||||
|
|
@ -283,19 +283,19 @@
|
|||
,body)))))))
|
||||
(define (visit-fun term)
|
||||
(rewrite-cps-exp term
|
||||
(($ $fun meta free body)
|
||||
($fun meta free ,(visit-cont body)))))
|
||||
(($ $fun src meta free body)
|
||||
($fun src meta free ,(visit-cont body)))))
|
||||
(define (visit-cont cont)
|
||||
(rewrite-cps-cont cont
|
||||
(($ $cont (? (cut assq <> fun-elisions)))
|
||||
;; This cont gets inlined in place of the $fun.
|
||||
,#f)
|
||||
(($ $cont sym src ($ $kargs names syms body))
|
||||
(sym src ($kargs names syms ,(visit-term body sym))))
|
||||
(($ $cont sym src ($ $kentry self tail clauses))
|
||||
(sym src ($kentry self ,tail ,(map visit-cont clauses))))
|
||||
(($ $cont sym src ($ $kclause arity body))
|
||||
(sym src ($kclause ,arity ,(visit-cont body))))
|
||||
(($ $cont sym ($ $kargs names syms body))
|
||||
(sym ($kargs names syms ,(visit-term body sym))))
|
||||
(($ $cont sym ($ $kentry self tail clauses))
|
||||
(sym ($kentry self ,tail ,(map visit-cont clauses))))
|
||||
(($ $cont sym ($ $kclause arity body))
|
||||
(sym ($kclause ,arity ,(visit-cont body))))
|
||||
(($ $cont)
|
||||
,cont)))
|
||||
(define (visit-term term term-k)
|
||||
|
|
@ -324,7 +324,7 @@
|
|||
(((names syms funs) ...)
|
||||
($letrec names syms (map visit-fun funs)
|
||||
,(visit-term body term-k)))))
|
||||
(($ $continue k exp)
|
||||
(($ $continue k src exp)
|
||||
(splice-continuations
|
||||
term-k
|
||||
(match exp
|
||||
|
|
@ -335,11 +335,11 @@
|
|||
(($ $kargs (_) (_) body)
|
||||
(visit-term body k))))
|
||||
(else
|
||||
(continue k (visit-fun exp)))))
|
||||
(continue k src (visit-fun exp)))))
|
||||
(($ $call proc args)
|
||||
(or (contify-call proc args)
|
||||
(continue k exp)))
|
||||
(_ (continue k exp)))))))
|
||||
(or (contify-call src proc args)
|
||||
(continue k src exp)))
|
||||
(_ (continue k src exp)))))))
|
||||
(visit-fun fun))
|
||||
|
||||
(define (contify fun)
|
||||
|
|
|
|||
|
|
@ -73,14 +73,14 @@
|
|||
print-dfa))
|
||||
|
||||
(define (build-cont-table fun)
|
||||
(fold-conts (lambda (k src cont table)
|
||||
(fold-conts (lambda (k cont table)
|
||||
(hashq-set! table k cont)
|
||||
table)
|
||||
(make-hash-table)
|
||||
fun))
|
||||
|
||||
(define (build-local-cont-table cont)
|
||||
(fold-local-conts (lambda (k src cont table)
|
||||
(fold-local-conts (lambda (k cont table)
|
||||
(hashq-set! table k cont)
|
||||
table)
|
||||
(make-hash-table)
|
||||
|
|
@ -206,10 +206,10 @@
|
|||
(reachable-preds k-map block-preds))))
|
||||
(make-cfa k-map order preds)))
|
||||
(match fun
|
||||
(($ $fun meta free
|
||||
($ $cont kentry src
|
||||
(($ $fun src meta free
|
||||
($ $cont kentry
|
||||
(and entry
|
||||
($ $kentry self ($ $cont ktail _ tail) clauses))))
|
||||
($ $kentry self ($ $cont ktail tail) clauses))))
|
||||
(if reverse?
|
||||
(build-cfa ktail block-preds block-succs)
|
||||
(build-cfa kentry block-succs block-preds)))))
|
||||
|
|
@ -549,13 +549,13 @@
|
|||
(map (cut hashq-ref mapping <>)
|
||||
((block-accessor blocks accessor) k))))
|
||||
(match fun
|
||||
(($ $fun meta free
|
||||
(($ $fun src meta free
|
||||
(and entry
|
||||
($ $cont kentry src ($ $kentry self ($ $cont ktail _ tail)))))
|
||||
($ $cont kentry ($ $kentry self ($ $cont ktail tail)))))
|
||||
(call-with-values (lambda () (make-variable-mapping (dfg-use-maps dfg)))
|
||||
(lambda (var-map nvars)
|
||||
(define (fold-all-conts f seed)
|
||||
(fold-local-conts (lambda (k src cont seed) (f k seed))
|
||||
(fold-local-conts (lambda (k cont seed) (f k seed))
|
||||
seed entry))
|
||||
(let* ((blocks (dfg-blocks dfg))
|
||||
(order (reverse-post-order ktail
|
||||
|
|
@ -662,7 +662,7 @@
|
|||
(define (recur exp)
|
||||
(visit exp exp-k))
|
||||
(match exp
|
||||
(($ $letk (($ $cont k src cont) ...) body)
|
||||
(($ $letk (($ $cont k cont) ...) body)
|
||||
;; Set up recursive environment before visiting cont bodies.
|
||||
(for-each (lambda (cont k)
|
||||
(declare-block! k cont exp-k))
|
||||
|
|
@ -688,7 +688,7 @@
|
|||
(for-each (cut visit-fun <> conts blocks use-maps global?) funs)
|
||||
(visit body exp-k))
|
||||
|
||||
(($ $continue k exp)
|
||||
(($ $continue k src exp)
|
||||
(use-k! k)
|
||||
(match exp
|
||||
(($ $var sym)
|
||||
|
|
@ -726,10 +726,10 @@
|
|||
(_ #f)))))
|
||||
|
||||
(match fun
|
||||
(($ $fun meta free
|
||||
($ $cont kentry src
|
||||
(($ $fun src meta free
|
||||
($ $cont kentry
|
||||
(and entry
|
||||
($ $kentry self ($ $cont ktail _ tail) clauses))))
|
||||
($ $kentry self ($ $cont ktail tail) clauses))))
|
||||
(declare-block! kentry entry #f 0)
|
||||
(add-def! #f self kentry)
|
||||
|
||||
|
|
@ -737,8 +737,8 @@
|
|||
|
||||
(for-each
|
||||
(match-lambda
|
||||
(($ $cont kclause _
|
||||
(and clause ($ $kclause arity ($ $cont kbody _ body))))
|
||||
(($ $cont kclause
|
||||
(and clause ($ $kclause arity ($ $cont kbody body))))
|
||||
(declare-block! kclause clause kentry)
|
||||
(link-blocks! kentry kclause)
|
||||
|
||||
|
|
@ -811,7 +811,7 @@
|
|||
|
||||
(define (call-expression call)
|
||||
(match call
|
||||
(($ $continue k exp) exp)))
|
||||
(($ $continue k src exp) exp)))
|
||||
|
||||
(define (find-expression term)
|
||||
(call-expression (find-call term)))
|
||||
|
|
@ -827,7 +827,7 @@
|
|||
(match (find-defining-expression sym dfg)
|
||||
(($ $const val)
|
||||
(values #t val))
|
||||
(($ $continue k ($ $void))
|
||||
(($ $continue k src ($ $void))
|
||||
(values #t *unspecified*))
|
||||
(else
|
||||
(values #f #f))))
|
||||
|
|
|
|||
|
|
@ -37,15 +37,15 @@
|
|||
|
||||
(define (elide-values fun)
|
||||
(let ((conts (build-local-cont-table
|
||||
(match fun (($ $fun meta free body) body)))))
|
||||
(match fun (($ $fun src meta free body) body)))))
|
||||
(define (visit-cont cont)
|
||||
(rewrite-cps-cont cont
|
||||
(($ $cont sym src ($ $kargs names syms body))
|
||||
(sym src ($kargs names syms ,(visit-term body))))
|
||||
(($ $cont sym src ($ $kentry self tail clauses))
|
||||
(sym src ($kentry self ,tail ,(map visit-cont clauses))))
|
||||
(($ $cont sym src ($ $kclause arity body))
|
||||
(sym src ($kclause ,arity ,(visit-cont body))))
|
||||
(($ $cont sym ($ $kargs names syms body))
|
||||
(sym ($kargs names syms ,(visit-term body))))
|
||||
(($ $cont sym ($ $kentry self tail clauses))
|
||||
(sym ($kentry self ,tail ,(map visit-cont clauses))))
|
||||
(($ $cont sym ($ $kclause arity body))
|
||||
(sym ($kclause ,arity ,(visit-cont body))))
|
||||
(($ $cont)
|
||||
,cont)))
|
||||
(define (visit-term term)
|
||||
|
|
@ -56,27 +56,27 @@
|
|||
(($ $letrec names syms funs body)
|
||||
($letrec names syms (map elide-values funs)
|
||||
,(visit-term body)))
|
||||
(($ $continue k ($ $primcall 'values vals))
|
||||
(($ $continue k src ($ $primcall 'values vals))
|
||||
,(rewrite-cps-term (lookup-cont k conts)
|
||||
(($ $ktail)
|
||||
($continue k ($values vals)))
|
||||
($continue k src ($values vals)))
|
||||
(($ $ktrunc ($ $arity req () rest () #f) kargs)
|
||||
,(if (or rest (< (length vals) (length req)))
|
||||
term
|
||||
(let ((vals (list-head vals (length req))))
|
||||
(build-cps-term
|
||||
($continue kargs ($values vals))))))
|
||||
($continue kargs src ($values vals))))))
|
||||
(($ $kargs args)
|
||||
,(if (< (length vals) (length args))
|
||||
term
|
||||
(let ((vals (list-head vals (length args))))
|
||||
(build-cps-term
|
||||
($continue k ($values vals))))))))
|
||||
(($ $continue k (and fun ($ $fun)))
|
||||
($continue k ,(elide-values fun)))
|
||||
($continue k src ($values vals))))))))
|
||||
(($ $continue k src (and fun ($ $fun)))
|
||||
($continue k src ,(elide-values fun)))
|
||||
(($ $continue)
|
||||
,term)))
|
||||
|
||||
(rewrite-cps-exp fun
|
||||
(($ $fun meta free body)
|
||||
($fun meta free ,(visit-cont body))))))
|
||||
(($ $fun src meta free body)
|
||||
($fun src meta free ,(visit-cont body))))))
|
||||
|
|
|
|||
|
|
@ -39,8 +39,8 @@
|
|||
('name name-sym name)
|
||||
('public? public?-sym public?)
|
||||
('bound? bound?-sym bound?))
|
||||
($letk ((kbox src ($kargs ('box) (box) ,(val-proc box))))
|
||||
($continue kbox
|
||||
($letk ((kbox ($kargs ('box) (box) ,(val-proc box))))
|
||||
($continue kbox src
|
||||
($primcall 'cached-module-box
|
||||
(module-sym name-sym public?-sym bound?-sym))))))))
|
||||
|
||||
|
|
@ -72,63 +72,61 @@
|
|||
((class-of @slot-ref @slot-set!) '(oop goops))
|
||||
(else '(guile))))
|
||||
|
||||
(define (primitive-ref name k)
|
||||
(define (primitive-ref name k src)
|
||||
(module-box #f (primitive-module name) name #f #t
|
||||
(lambda (box)
|
||||
(build-cps-term
|
||||
($continue k ($primcall 'box-ref (box)))))))
|
||||
($continue k src ($primcall 'box-ref (box)))))))
|
||||
|
||||
(define (builtin-ref idx k)
|
||||
(define (builtin-ref idx k src)
|
||||
(let-gensyms (idx-sym)
|
||||
(build-cps-term
|
||||
($letconst (('idx idx-sym idx))
|
||||
($continue k
|
||||
($continue k src
|
||||
($primcall 'builtin-ref (idx-sym)))))))
|
||||
|
||||
(define (reify-clause ktail)
|
||||
(let-gensyms (kclause kbody wna false str eol kthrow throw)
|
||||
(build-cps-cont
|
||||
(kclause #f ($kclause ('() '() #f '() #f)
|
||||
(kclause ($kclause ('() '() #f '() #f)
|
||||
(kbody
|
||||
#f
|
||||
($kargs () ()
|
||||
($letconst (('wna wna 'wrong-number-of-args)
|
||||
('false false #f)
|
||||
('str str "Wrong number of arguments")
|
||||
('eol eol '()))
|
||||
($letk ((kthrow
|
||||
#f
|
||||
($kargs ('throw) (throw)
|
||||
($continue ktail
|
||||
($continue ktail #f
|
||||
($call throw
|
||||
(wna false str eol false))))))
|
||||
,(primitive-ref 'throw kthrow))))))))))
|
||||
,(primitive-ref 'throw kthrow #f))))))))))
|
||||
|
||||
;; FIXME: Operate on one function at a time, for efficiency.
|
||||
(define (reify-primitives fun)
|
||||
(let ((conts (build-cont-table fun)))
|
||||
(define (visit-fun term)
|
||||
(rewrite-cps-exp term
|
||||
(($ $fun meta free body)
|
||||
($fun meta free ,(visit-cont body)))))
|
||||
(($ $fun src meta free body)
|
||||
($fun src meta free ,(visit-cont body)))))
|
||||
(define (visit-cont cont)
|
||||
(rewrite-cps-cont cont
|
||||
(($ $cont sym src ($ $kargs names syms body))
|
||||
(sym src ($kargs names syms ,(visit-term body))))
|
||||
(($ $cont sym src ($ $kentry self (and tail ($ $cont ktail)) ()))
|
||||
(($ $cont sym ($ $kargs names syms body))
|
||||
(sym ($kargs names syms ,(visit-term body))))
|
||||
(($ $cont sym ($ $kentry self (and tail ($ $cont ktail)) ()))
|
||||
;; A case-lambda with no clauses. Reify a clause.
|
||||
(sym src ($kentry self ,tail (,(reify-clause ktail)))))
|
||||
(($ $cont sym src ($ $kentry self tail clauses))
|
||||
(sym src ($kentry self ,tail ,(map visit-cont clauses))))
|
||||
(($ $cont sym src ($ $kclause arity body))
|
||||
(sym src ($kclause ,arity ,(visit-cont body))))
|
||||
(sym ($kentry self ,tail (,(reify-clause ktail)))))
|
||||
(($ $cont sym ($ $kentry self tail clauses))
|
||||
(sym ($kentry self ,tail ,(map visit-cont clauses))))
|
||||
(($ $cont sym ($ $kclause arity body))
|
||||
(sym ($kclause ,arity ,(visit-cont body))))
|
||||
(($ $cont)
|
||||
,cont)))
|
||||
(define (visit-term term)
|
||||
(rewrite-cps-term term
|
||||
(($ $letk conts body)
|
||||
($letk ,(map visit-cont conts) ,(visit-term body)))
|
||||
(($ $continue k exp)
|
||||
(($ $continue k src exp)
|
||||
,(match exp
|
||||
(($ $prim name)
|
||||
(match (lookup-cont k conts)
|
||||
|
|
@ -136,14 +134,14 @@
|
|||
(cond
|
||||
((builtin-name->index name)
|
||||
=> (lambda (idx)
|
||||
(builtin-ref idx k)))
|
||||
(else (primitive-ref name k))))
|
||||
(_ (build-cps-term ($continue k ($void))))))
|
||||
(builtin-ref idx k src)))
|
||||
(else (primitive-ref name k src))))
|
||||
(_ (build-cps-term ($continue k src ($void))))))
|
||||
(($ $fun)
|
||||
(build-cps-term ($continue k ,(visit-fun exp))))
|
||||
(build-cps-term ($continue k src ,(visit-fun exp))))
|
||||
(($ $primcall 'call-thunk/no-inline (proc))
|
||||
(build-cps-term
|
||||
($continue k ($call proc ()))))
|
||||
($continue k src ($call proc ()))))
|
||||
(($ $primcall name args)
|
||||
(cond
|
||||
((or (prim-rtl-instruction name) (branching-primitive? name))
|
||||
|
|
@ -152,13 +150,13 @@
|
|||
(else
|
||||
(let-gensyms (k* v)
|
||||
(build-cps-term
|
||||
($letk ((k* #f ($kargs (v) (v)
|
||||
($continue k ($call v args)))))
|
||||
($letk ((k* ($kargs (v) (v)
|
||||
($continue k src ($call v args)))))
|
||||
,(cond
|
||||
((builtin-name->index name)
|
||||
=> (lambda (idx)
|
||||
(builtin-ref idx k*)))
|
||||
(else (primitive-ref name k*)))))))))
|
||||
(builtin-ref idx k* src)))
|
||||
(else (primitive-ref name k* src)))))))))
|
||||
(_ term)))))
|
||||
|
||||
(visit-fun fun)))
|
||||
|
|
|
|||
|
|
@ -235,7 +235,7 @@ are comparable with eqv?. A tmp slot may be used."
|
|||
(define nlocals (compute-slot live-slots #f))
|
||||
(define nargs
|
||||
(match clause
|
||||
(($ $cont _ _ ($ $kclause _ ($ $cont _ _ ($ $kargs names syms))))
|
||||
(($ $cont _ ($ $kclause _ ($ $cont _ ($ $kargs names syms))))
|
||||
(length syms))))
|
||||
|
||||
(define (allocate! sym k hint live-slots)
|
||||
|
|
@ -310,7 +310,7 @@ are comparable with eqv?. A tmp slot may be used."
|
|||
live-slots))
|
||||
|
||||
(match cont
|
||||
(($ $kclause arity ($ $cont k src body))
|
||||
(($ $kclause arity ($ $cont k body))
|
||||
(visit-cont body k live-slots))
|
||||
|
||||
(($ $kargs names syms body)
|
||||
|
|
@ -328,12 +328,12 @@ are comparable with eqv?. A tmp slot may be used."
|
|||
(($ $letk conts body)
|
||||
(let ((live-slots (visit-term body label live-slots)))
|
||||
(for-each (match-lambda
|
||||
(($ $cont k src cont)
|
||||
(($ $cont k cont)
|
||||
(visit-cont cont k live-slots)))
|
||||
conts))
|
||||
live-slots)
|
||||
|
||||
(($ $continue k exp)
|
||||
(($ $continue k src exp)
|
||||
(visit-exp exp label k live-slots))))
|
||||
|
||||
(define (visit-exp exp label k live-slots)
|
||||
|
|
@ -420,12 +420,12 @@ are comparable with eqv?. A tmp slot may be used."
|
|||
(_ live-slots)))
|
||||
|
||||
(match clause
|
||||
(($ $cont k _ body)
|
||||
(($ $cont k body)
|
||||
(visit-cont body k live-slots)
|
||||
(hashq-set! allocation k nlocals))))
|
||||
|
||||
(match fun
|
||||
(($ $fun meta free ($ $cont k _ ($ $kentry self tail clauses)))
|
||||
(($ $fun src meta free ($ $cont k ($ $kentry self tail clauses)))
|
||||
(let* ((dfa (compute-live-variables fun dfg))
|
||||
(allocation (make-hash-table))
|
||||
(slots (make-vector (dfa-var-count dfa) #f))
|
||||
|
|
|
|||
|
|
@ -71,7 +71,7 @@
|
|||
|
||||
(define (visit-clause clause k-env v-env)
|
||||
(match clause
|
||||
(($ $cont kclause src*
|
||||
(($ $cont kclause
|
||||
($ $kclause
|
||||
($ $arity
|
||||
((? symbol? req) ...)
|
||||
|
|
@ -79,9 +79,7 @@
|
|||
(and rest (or #f (? symbol?)))
|
||||
(((? keyword? kw) (? symbol? kwname) (? symbol? kwsym)) ...)
|
||||
(or #f #t))
|
||||
($ $cont kbody src (and body ($ $kargs names syms _)))))
|
||||
(check-src src*)
|
||||
(check-src src)
|
||||
($ $cont kbody (and body ($ $kargs names syms _)))))
|
||||
(for-each (lambda (sym)
|
||||
(unless (memq sym syms)
|
||||
(error "bad keyword sym" sym)))
|
||||
|
|
@ -98,9 +96,9 @@
|
|||
|
||||
(define (visit-fun fun k-env v-env)
|
||||
(match fun
|
||||
(($ $fun meta ((? symbol? free) ...)
|
||||
($ $cont kbody src
|
||||
($ $kentry (? symbol? self) ($ $cont ktail _ ($ $ktail)) clauses)))
|
||||
(($ $fun src meta ((? symbol? free) ...)
|
||||
($ $cont kbody
|
||||
($ $kentry (? symbol? self) ($ $cont ktail ($ $ktail)) clauses)))
|
||||
(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)
|
||||
|
|
@ -142,9 +140,8 @@
|
|||
|
||||
(define (visit-term term k-env v-env)
|
||||
(match term
|
||||
(($ $letk (($ $cont (? symbol? k) src cont) ...) body)
|
||||
(($ $letk (($ $cont (? symbol? k) cont) ...) body)
|
||||
(let ((k-env (add-env k k-env)))
|
||||
(for-each check-src src)
|
||||
(for-each (cut visit-cont-body <> k-env v-env) cont)
|
||||
(visit-term body k-env v-env)))
|
||||
|
||||
|
|
@ -155,8 +152,9 @@
|
|||
(for-each (cut visit-fun <> k-env v-env) fun)
|
||||
(visit-term body k-env v-env)))
|
||||
|
||||
(($ $continue k exp)
|
||||
(($ $continue k src exp)
|
||||
(check-var k k-env)
|
||||
(check-src src)
|
||||
(visit-expression exp k-env v-env))
|
||||
|
||||
(_
|
||||
|
|
|
|||
|
|
@ -81,18 +81,18 @@
|
|||
(build-cps-term
|
||||
($letconst (('name name-sym name)
|
||||
('bound? bound?-sym bound?))
|
||||
($letk ((kbox src ($kargs ('box) (box) ,(val-proc box))))
|
||||
($letk ((kbox ($kargs ('box) (box) ,(val-proc box))))
|
||||
,(match (current-topbox-scope)
|
||||
(#f
|
||||
(build-cps-term
|
||||
($continue kbox
|
||||
($continue kbox src
|
||||
($primcall 'resolve
|
||||
(name-sym bound?-sym)))))
|
||||
(scope
|
||||
(let-gensyms (scope-sym)
|
||||
(build-cps-term
|
||||
($letconst (('scope scope-sym scope))
|
||||
($continue kbox
|
||||
($continue kbox src
|
||||
($primcall 'cached-toplevel-box
|
||||
(scope-sym name-sym bound?-sym)))))))))))))
|
||||
|
||||
|
|
@ -103,8 +103,8 @@
|
|||
('name name-sym name)
|
||||
('public? public?-sym public?)
|
||||
('bound? bound?-sym bound?))
|
||||
($letk ((kbox src ($kargs ('box) (box) ,(val-proc box))))
|
||||
($continue kbox
|
||||
($letk ((kbox ($kargs ('box) (box) ,(val-proc box))))
|
||||
($continue kbox src
|
||||
($primcall 'cached-module-box
|
||||
(module-sym name-sym public?-sym bound?-sym))))))))
|
||||
|
||||
|
|
@ -112,11 +112,11 @@
|
|||
(let-gensyms (module scope-sym kmodule)
|
||||
(build-cps-term
|
||||
($letconst (('scope scope-sym scope))
|
||||
($letk ((kmodule src ($kargs ('module) (module)
|
||||
($continue k
|
||||
($letk ((kmodule ($kargs ('module) (module)
|
||||
($continue k src
|
||||
($primcall 'cache-current-module!
|
||||
(module scope-sym))))))
|
||||
($continue kmodule
|
||||
($continue kmodule src
|
||||
($primcall 'current-module ())))))))
|
||||
|
||||
(define (fold-formals proc seed arity gensyms inits)
|
||||
|
|
@ -162,8 +162,8 @@
|
|||
(let-gensyms (unbound ktest)
|
||||
(build-cps-term
|
||||
($letconst (('unbound unbound (pointer->scm (make-pointer unbound-bits))))
|
||||
($letk ((ktest src ($kif kt kf)))
|
||||
($continue ktest
|
||||
($letk ((ktest ($kif kt kf)))
|
||||
($continue ktest src
|
||||
($primcall 'eq? (sym unbound))))))))
|
||||
|
||||
(define (init-default-value name sym subst init body)
|
||||
|
|
@ -174,19 +174,19 @@
|
|||
(if box?
|
||||
(let-gensyms (kbox phi)
|
||||
(build-cps-term
|
||||
($letk ((kbox src ($kargs (name) (phi)
|
||||
($continue k ($primcall 'box (phi))))))
|
||||
($letk ((kbox ($kargs (name) (phi)
|
||||
($continue k src ($primcall 'box (phi))))))
|
||||
,(make-body kbox))))
|
||||
(make-body k)))
|
||||
(let-gensyms (knext kbound kunbound)
|
||||
(build-cps-term
|
||||
($letk ((knext src ($kargs (name) (subst-sym) ,body)))
|
||||
($letk ((knext ($kargs (name) (subst-sym) ,body)))
|
||||
,(maybe-box
|
||||
knext
|
||||
(lambda (k)
|
||||
(build-cps-term
|
||||
($letk ((kbound src ($kargs () () ($continue k ($var sym))))
|
||||
(kunbound src ($kargs () () ,(convert init k subst))))
|
||||
($letk ((kbound ($kargs () () ($continue k src ($var sym))))
|
||||
(kunbound ($kargs () () ,(convert init k subst))))
|
||||
,(unbound? src sym kunbound kbound))))))))))))
|
||||
|
||||
;; exp k-name alist -> term
|
||||
|
|
@ -199,16 +199,15 @@
|
|||
((box #t)
|
||||
(let-gensyms (kunboxed unboxed)
|
||||
(build-cps-term
|
||||
($letk ((kunboxed src ($kargs ('unboxed) (unboxed) ,(k unboxed))))
|
||||
($continue kunboxed ($primcall 'box-ref (box)))))))
|
||||
($letk ((kunboxed ($kargs ('unboxed) (unboxed) ,(k unboxed))))
|
||||
($continue kunboxed src ($primcall 'box-ref (box)))))))
|
||||
((subst #f) (k subst))
|
||||
(#f (k sym))))
|
||||
(else
|
||||
(let ((src (tree-il-src exp)))
|
||||
(let-gensyms (karg arg)
|
||||
(build-cps-term
|
||||
($letk ((karg src ($kargs ('arg) (arg) ,(k arg))))
|
||||
,(convert exp karg subst))))))))
|
||||
($letk ((karg ($kargs ('arg) (arg) ,(k arg))))
|
||||
,(convert exp karg subst)))))))
|
||||
;; (exp ...) ((v-name ...) -> term) -> term
|
||||
(define (convert-args exps k)
|
||||
(match exps
|
||||
|
|
@ -224,25 +223,25 @@
|
|||
((box #t)
|
||||
(let-gensyms (k)
|
||||
(build-cps-term
|
||||
($letk ((k #f ($kargs (name) (box) ,body)))
|
||||
($continue k ($primcall 'box (sym)))))))
|
||||
($letk ((k ($kargs (name) (box) ,body)))
|
||||
($continue k #f ($primcall 'box (sym)))))))
|
||||
(else body)))
|
||||
|
||||
(match exp
|
||||
(($ <lexical-ref> src name sym)
|
||||
(match (assq-ref subst sym)
|
||||
((box #t) (build-cps-term ($continue k ($primcall 'box-ref (box)))))
|
||||
((subst #f) (build-cps-term ($continue k ($var subst))))
|
||||
(#f (build-cps-term ($continue k ($var sym))))))
|
||||
((box #t) (build-cps-term ($continue k src ($primcall 'box-ref (box)))))
|
||||
((subst #f) (build-cps-term ($continue k src ($var subst))))
|
||||
(#f (build-cps-term ($continue k src ($var sym))))))
|
||||
|
||||
(($ <void> src)
|
||||
(build-cps-term ($continue k ($void))))
|
||||
(build-cps-term ($continue k src ($void))))
|
||||
|
||||
(($ <const> src exp)
|
||||
(build-cps-term ($continue k ($const exp))))
|
||||
(build-cps-term ($continue k src ($const exp))))
|
||||
|
||||
(($ <primitive-ref> src name)
|
||||
(build-cps-term ($continue k ($prim name))))
|
||||
(build-cps-term ($continue k src ($prim name))))
|
||||
|
||||
(($ <lambda> fun-src meta body)
|
||||
(let ()
|
||||
|
|
@ -260,10 +259,8 @@
|
|||
(let-gensyms (kclause kargs)
|
||||
(build-cps-cont
|
||||
(kclause
|
||||
src
|
||||
($kclause ,arity
|
||||
(kargs
|
||||
src
|
||||
($kargs names gensyms
|
||||
,(fold-formals
|
||||
(lambda (name sym init body)
|
||||
|
|
@ -276,15 +273,13 @@
|
|||
(if (current-topbox-scope)
|
||||
(let-gensyms (kentry self ktail)
|
||||
(build-cps-term
|
||||
($continue k
|
||||
($fun meta '()
|
||||
(kentry fun-src
|
||||
($kentry self (ktail #f ($ktail))
|
||||
($continue k fun-src
|
||||
($fun fun-src meta '()
|
||||
(kentry ($kentry self (ktail ($ktail))
|
||||
,(convert-clauses body ktail)))))))
|
||||
(let-gensyms (scope kscope)
|
||||
(build-cps-term
|
||||
($letk ((kscope fun-src
|
||||
($kargs () ()
|
||||
($letk ((kscope ($kargs () ()
|
||||
,(parameterize ((current-topbox-scope scope))
|
||||
(convert exp k subst)))))
|
||||
,(capture-toplevel-scope fun-src scope kscope)))))))
|
||||
|
|
@ -293,7 +288,7 @@
|
|||
(module-box
|
||||
src mod name public? #t
|
||||
(lambda (box)
|
||||
(build-cps-term ($continue k ($primcall 'box-ref (box)))))))
|
||||
(build-cps-term ($continue k src ($primcall 'box-ref (box)))))))
|
||||
|
||||
(($ <module-set> src mod name public? exp)
|
||||
(convert-arg exp
|
||||
|
|
@ -301,13 +296,14 @@
|
|||
(module-box
|
||||
src mod name public? #f
|
||||
(lambda (box)
|
||||
(build-cps-term ($continue k ($primcall 'box-set! (box val)))))))))
|
||||
(build-cps-term
|
||||
($continue k src ($primcall 'box-set! (box val)))))))))
|
||||
|
||||
(($ <toplevel-ref> src name)
|
||||
(toplevel-box
|
||||
src name #t
|
||||
(lambda (box)
|
||||
(build-cps-term ($continue k ($primcall 'box-ref (box)))))))
|
||||
(build-cps-term ($continue k src ($primcall 'box-ref (box)))))))
|
||||
|
||||
(($ <toplevel-set> src name exp)
|
||||
(convert-arg exp
|
||||
|
|
@ -315,7 +311,8 @@
|
|||
(toplevel-box
|
||||
src name #f
|
||||
(lambda (box)
|
||||
(build-cps-term ($continue k ($primcall 'box-set! (box val)))))))))
|
||||
(build-cps-term
|
||||
($continue k src ($primcall 'box-set! (box val)))))))))
|
||||
|
||||
(($ <toplevel-define> src name exp)
|
||||
(convert-arg exp
|
||||
|
|
@ -323,13 +320,13 @@
|
|||
(let-gensyms (kname name-sym)
|
||||
(build-cps-term
|
||||
($letconst (('name name-sym name))
|
||||
($continue k ($primcall 'define! (name-sym val)))))))))
|
||||
($continue k src ($primcall 'define! (name-sym val)))))))))
|
||||
|
||||
(($ <call> src proc args)
|
||||
(convert-args (cons proc args)
|
||||
(match-lambda
|
||||
((proc . args)
|
||||
(build-cps-term ($continue k ($call proc args)))))))
|
||||
(build-cps-term ($continue k src ($call proc args)))))))
|
||||
|
||||
(($ <primcall> src name args)
|
||||
(cond
|
||||
|
|
@ -389,22 +386,21 @@
|
|||
(match args
|
||||
(()
|
||||
(build-cps-term
|
||||
($continue k ($const '()))))
|
||||
($continue k src ($const '()))))
|
||||
((arg . args)
|
||||
(let-gensyms (ktail tail)
|
||||
(build-cps-term
|
||||
($letk ((ktail src
|
||||
($kargs ('tail) (tail)
|
||||
($letk ((ktail ($kargs ('tail) (tail)
|
||||
,(convert-arg arg
|
||||
(lambda (head)
|
||||
(build-cps-term
|
||||
($continue k
|
||||
($continue k src
|
||||
($primcall 'cons (head tail)))))))))
|
||||
,(lp args ktail))))))))
|
||||
(else
|
||||
(convert-args args
|
||||
(lambda (args)
|
||||
(build-cps-term ($continue k ($primcall name args))))))))
|
||||
(build-cps-term ($continue k src ($primcall name args))))))))
|
||||
|
||||
;; Prompts with inline handlers.
|
||||
(($ <prompt> src escape-only? tag body
|
||||
|
|
@ -427,42 +423,38 @@
|
|||
(let ((hnames (append hreq (if hrest (list hrest) '()))))
|
||||
(let-gensyms (khargs khbody kret kprim prim kpop krest vals kbody)
|
||||
(build-cps-term
|
||||
($letk* ((khbody hsrc ($kargs hnames hsyms
|
||||
;; FIXME: Attach hsrc to $ktrunc.
|
||||
($letk* ((khbody ($kargs hnames hsyms
|
||||
,(fold box-bound-var
|
||||
(convert hbody k subst)
|
||||
hnames hsyms)))
|
||||
(khargs hsrc ($ktrunc hreq hrest khbody))
|
||||
(kpop src
|
||||
($kargs ('rest) (vals)
|
||||
(khargs ($ktrunc hreq hrest khbody))
|
||||
(kpop ($kargs ('rest) (vals)
|
||||
($letk ((kret
|
||||
src
|
||||
($kargs () ()
|
||||
($letk ((kprim
|
||||
src
|
||||
($kargs ('prim) (prim)
|
||||
($continue k
|
||||
($continue k src
|
||||
($primcall 'apply
|
||||
(prim vals))))))
|
||||
($continue kprim
|
||||
($continue kprim src
|
||||
($prim 'values))))))
|
||||
($continue kret
|
||||
($continue kret src
|
||||
($primcall 'unwind ())))))
|
||||
(krest src ($ktrunc '() 'rest kpop)))
|
||||
(krest ($ktrunc '() 'rest kpop)))
|
||||
,(if escape-only?
|
||||
(build-cps-term
|
||||
($letk ((kbody (tree-il-src body)
|
||||
($kargs () ()
|
||||
($letk ((kbody ($kargs () ()
|
||||
,(convert body krest subst))))
|
||||
($continue kbody ($prompt #t tag khargs kpop))))
|
||||
($continue kbody src ($prompt #t tag khargs kpop))))
|
||||
(convert-arg body
|
||||
(lambda (thunk)
|
||||
(build-cps-term
|
||||
($letk ((kbody (tree-il-src body)
|
||||
($kargs () ()
|
||||
($continue krest
|
||||
($letk ((kbody ($kargs () ()
|
||||
($continue krest (tree-il-src body)
|
||||
($primcall 'call-thunk/no-inline
|
||||
(thunk))))))
|
||||
($continue kbody
|
||||
($continue kbody (tree-il-src body)
|
||||
($prompt #f tag khargs kpop))))))))))))))
|
||||
|
||||
;; Eta-convert prompts without inline handlers.
|
||||
|
|
@ -503,7 +495,8 @@
|
|||
(convert-args (cons tag args)
|
||||
(lambda (args*)
|
||||
(build-cps-term
|
||||
($continue k ($primcall 'abort-to-prompt args*))))))
|
||||
($continue k src
|
||||
($primcall 'abort-to-prompt args*))))))
|
||||
|
||||
(($ <abort> src tag args tail)
|
||||
(convert-args (append (list (make-primitive-ref #f 'abort-to-prompt)
|
||||
|
|
@ -512,24 +505,24 @@
|
|||
(list tail))
|
||||
(lambda (args*)
|
||||
(build-cps-term
|
||||
($continue k ($primcall 'apply args*))))))
|
||||
($continue k src ($primcall 'apply args*))))))
|
||||
|
||||
(($ <conditional> src test consequent alternate)
|
||||
(let-gensyms (kif kt kf)
|
||||
(build-cps-term
|
||||
($letk* ((kt (tree-il-src consequent) ($kargs () ()
|
||||
,(convert consequent k subst)))
|
||||
(kf (tree-il-src alternate) ($kargs () ()
|
||||
,(convert alternate k subst)))
|
||||
(kif src ($kif kt kf)))
|
||||
($letk* ((kt ($kargs () () ,(convert consequent k subst)))
|
||||
(kf ($kargs () () ,(convert alternate k subst)))
|
||||
(kif ($kif kt kf)))
|
||||
,(match test
|
||||
(($ <primcall> src (? branching-primitive? name) args)
|
||||
(convert-args args
|
||||
(lambda (args)
|
||||
(build-cps-term ($continue kif ($primcall name args))))))
|
||||
(build-cps-term
|
||||
($continue kif src ($primcall name args))))))
|
||||
(_ (convert-arg test
|
||||
(lambda (test)
|
||||
(build-cps-term ($continue kif ($var test)))))))))))
|
||||
(build-cps-term
|
||||
($continue kif src ($var test)))))))))))
|
||||
|
||||
(($ <lexical-set> src name gensym exp)
|
||||
(convert-arg exp
|
||||
|
|
@ -537,14 +530,14 @@
|
|||
(match (assq-ref subst gensym)
|
||||
((box #t)
|
||||
(build-cps-term
|
||||
($continue k ($primcall 'box-set! (box exp)))))))))
|
||||
($continue k src ($primcall 'box-set! (box exp)))))))))
|
||||
|
||||
(($ <seq> src head tail)
|
||||
(let-gensyms (ktrunc kseq)
|
||||
(build-cps-term
|
||||
($letk* ((kseq (tree-il-src tail) ($kargs () ()
|
||||
($letk* ((kseq ($kargs () ()
|
||||
,(convert tail k subst)))
|
||||
(ktrunc src ($ktrunc '() #f kseq)))
|
||||
(ktrunc ($ktrunc '() #f kseq)))
|
||||
,(convert head ktrunc subst)))))
|
||||
|
||||
(($ <let> src names syms vals body)
|
||||
|
|
@ -554,7 +547,7 @@
|
|||
(((name . names) (sym . syms) (val . vals))
|
||||
(let-gensyms (klet)
|
||||
(build-cps-term
|
||||
($letk ((klet src ($kargs (name) (sym)
|
||||
($letk ((klet ($kargs (name) (sym)
|
||||
,(box-bound-var name sym
|
||||
(lp names syms vals)))))
|
||||
,(convert val klet subst))))))))
|
||||
|
|
@ -568,13 +561,13 @@
|
|||
gensyms
|
||||
(map (lambda (fun)
|
||||
(match (convert fun k subst)
|
||||
(($ $continue _ (and fun ($ $fun)))
|
||||
(($ $continue _ _ (and fun ($ $fun)))
|
||||
fun)))
|
||||
funs)
|
||||
,(convert body k subst))))
|
||||
(let-gensyms (scope kscope)
|
||||
(build-cps-term
|
||||
($letk ((kscope src ($kargs () ()
|
||||
($letk ((kscope ($kargs () ()
|
||||
,(parameterize ((current-topbox-scope scope))
|
||||
(convert exp k subst)))))
|
||||
,(capture-toplevel-scope src scope kscope))))))
|
||||
|
|
@ -584,11 +577,11 @@
|
|||
(let ((names (append req (if rest (list rest) '()))))
|
||||
(let-gensyms (ktrunc kargs)
|
||||
(build-cps-term
|
||||
($letk* ((kargs src ($kargs names syms
|
||||
($letk* ((kargs ($kargs names syms
|
||||
,(fold box-bound-var
|
||||
(convert body k subst)
|
||||
names syms)))
|
||||
(ktrunc src ($ktrunc req rest kargs)))
|
||||
(ktrunc ($ktrunc req rest kargs)))
|
||||
,(convert exp ktrunc subst))))))))
|
||||
|
||||
(define (build-subst exp)
|
||||
|
|
@ -628,14 +621,12 @@ indicates that the replacement variable is in a box."
|
|||
(let ((src (tree-il-src exp)))
|
||||
(let-gensyms (kinit init ktail kclause kbody)
|
||||
(build-cps-exp
|
||||
($fun '() '()
|
||||
(kinit src
|
||||
($kentry init
|
||||
(ktail #f ($ktail))
|
||||
((kclause src
|
||||
($fun src '() '()
|
||||
(kinit ($kentry init
|
||||
(ktail ($ktail))
|
||||
((kclause
|
||||
($kclause ('() '() #f '() #f)
|
||||
(kbody src
|
||||
($kargs () ()
|
||||
(kbody ($kargs () ()
|
||||
,(convert exp ktail
|
||||
(build-subst exp))))))))))))))
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue