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

Source information goes on the $continue, not the $cont.

Browse source 
* 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 2013-11-07 10:32:21 +01:00
parent 963d95f1d9
commit 6e422a3599
13 changed files with 767 additions and 784 deletions
Download patch file Download diff file Expand all files Collapse all files

2
.dir-locals.el
View file

@ -21,7 +21,7 @@
(eval . (put '$letk 'scheme-indent-function 1)) (eval . (put '$letk 'scheme-indent-function 1))
(eval . (put '$letk* 'scheme-indent-function 1)) (eval . (put '$letk* 'scheme-indent-function 1))
(eval . (put '$letconst '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 '$kargs 'scheme-indent-function 2))
(eval . (put '$kentry 'scheme-indent-function 2)) (eval . (put '$kentry 'scheme-indent-function 2))
(eval . (put '$kclause 'scheme-indent-function 1)) (eval . (put '$kclause 'scheme-indent-function 1))

75
module/language/cps.scm
View file

@ -25,15 +25,15 @@
;;; and terms that call continuations. ;;; and terms that call continuations.
;;; ;;;
;;; $letk binds a set of mutually recursive continuations, each one an ;;; $letk binds a set of mutually recursive continuations, each one an
;;; instance of $cont. A $cont declares the name and source of a ;;; instance of $cont. A $cont declares the name of a continuation, and
;;; continuation, and then contains as a subterm the particular ;;; then contains as a subterm the particular continuation instance:
;;; continuation instance: $kif for test continuations, $kargs for ;;; $kif for test continuations, $kargs for continuations that bind
;;; continuations that bind values, etc. ;;; values, etc.
;;; ;;;
;;; $continue nodes call continuations. The expression contained in the ;;; $continue nodes call continuations. The expression contained in the
;;; $continue node determines the value or values that are passed to the ;;; $continue node determines the value or values that are passed to the
;;; target continuation: $const to pass a constant value, $values to ;;; 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 ;;; Additionally there is $letrec, a term that binds mutually recursive
;;; functions. The contification pass will turn $letrec into $letk if ;;; 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: ;;; That's to say that a $fun can be matched like this:
;;; ;;;
;;; (match f ;;; (match f
;;; (($ $fun meta free ;;; (($ $fun src meta free
;;; ($ $cont kentry src ;;; ($ $cont kentry
;;; ($ $kentry self ($ $cont ktail _ ($ $ktail)) ;;; ($ $kentry self ($ $cont ktail _ ($ $ktail))
;;; (($ $kclause arity ;;; (($ $kclause arity
;;; ($ $cont kbody _ ($ $kargs names syms body))) ;;; ($ $cont kbody _ ($ $kargs names syms body)))
@ -165,11 +165,11 @@
;; Terms. ;; Terms.
(define-cps-type $letk conts body) (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) (define-cps-type $letrec names syms funs body)
;; Continuations ;; Continuations
(define-cps-type $cont k src cont) (define-cps-type $cont k cont)
(define-cps-type $kif kt kf) (define-cps-type $kif kt kf)
(define-cps-type $ktrunc arity k) (define-cps-type $ktrunc arity k)
(define-cps-type $kargs names syms body) (define-cps-type $kargs names syms body)
@ -182,7 +182,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 meta free body) (define-cps-type $fun src meta free body)
(define-cps-type $call proc args) (define-cps-type $call proc args)
(define-cps-type $primcall name args) (define-cps-type $primcall name args)
(define-cps-type $values args) (define-cps-type $values args)
@ -224,7 +224,7 @@
(define-syntax build-cps-cont (define-syntax build-cps-cont
(syntax-rules (unquote) (syntax-rules (unquote)
((_ (unquote exp)) exp) ((_ (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 (define-syntax build-cps-exp
(syntax-rules (unquote (syntax-rules (unquote
@ -234,7 +234,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 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 (arg ...))) (make-$call proc (list arg ...)))
((_ ($call proc args)) (make-$call proc args)) ((_ ($call proc args)) (make-$call proc args))
((_ ($primcall name (arg ...))) (make-$primcall name (list arg ...))) ((_ ($primcall name (arg ...))) (make-$primcall name (list arg ...)))
@ -262,12 +263,14 @@
((_ ($letconst ((name sym val) tail ...) body)) ((_ ($letconst ((name sym val) tail ...) body))
(let-gensyms (kconst) (let-gensyms (kconst)
(build-cps-term (build-cps-term
($letk ((kconst #f ($kargs (name) (sym) ($letconst (tail ...) body)))) ($letk ((kconst ($kargs (name) (sym) ($letconst (tail ...) body))))
($continue kconst ($const val)))))) ($continue kconst (let ((props (source-properties val)))
(and (pair? props) props))
($const val))))))
((_ ($letrec names gensyms funs body)) ((_ ($letrec names gensyms funs body))
(make-$letrec names gensyms funs (build-cps-term body))) (make-$letrec names gensyms funs (build-cps-term body)))
((_ ($continue k exp)) ((_ ($continue k src exp))
(make-$continue k (build-cps-exp exp))))) (make-$continue k src (build-cps-exp exp)))))
(define-syntax-rule (rewrite-cps-term x (pat body) ...) (define-syntax-rule (rewrite-cps-term x (pat body) ...)
(match x (match x
@ -287,20 +290,20 @@
;; Continuations. ;; Continuations.
(('letconst k (name sym c) body) (('letconst k (name sym c) body)
(build-cps-term (build-cps-term
($letk ((k (src exp) ($kargs (name) (sym) ($letk ((k ($kargs (name) (sym)
,(parse-cps body)))) ,(parse-cps body))))
($continue k ($const c))))) ($continue k (src exp) ($const c)))))
(('let k (name sym val) body) (('let k (name sym val) body)
(build-cps-term (build-cps-term
($letk ((k (src exp) ($kargs (name) (sym) ($letk ((k ($kargs (name) (sym)
,(parse-cps body)))) ,(parse-cps body))))
,(parse-cps val)))) ,(parse-cps val))))
(('letk (cont ...) body) (('letk (cont ...) body)
(build-cps-term (build-cps-term
($letk ,(map parse-cps cont) ,(parse-cps body)))) ($letk ,(map parse-cps cont) ,(parse-cps body))))
(('k sym body) (('k sym body)
(build-cps-cont (build-cps-cont
(sym (src exp) ,(parse-cps body)))) (sym ,(parse-cps body))))
(('kif kt kf) (('kif kt kf)
(build-cont-body ($kif kt kf))) (build-cont-body ($kif kt kf)))
(('ktrunc req rest k) (('ktrunc req rest k)
@ -322,7 +325,7 @@
;; Calls. ;; Calls.
(('continue k exp) (('continue k exp)
(build-cps-term ($continue k ,(parse-cps exp)))) (build-cps-term ($continue k (src exp) ,(parse-cps exp))))
(('var sym) (('var sym)
(build-cps-exp ($var sym))) (build-cps-exp ($var sym)))
(('void) (('void)
@ -332,7 +335,7 @@
(('prim name) (('prim name)
(build-cps-exp ($prim name))) (build-cps-exp ($prim name)))
(('fun meta free body) (('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) (('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))))
@ -350,16 +353,16 @@
(define (unparse-cps exp) (define (unparse-cps exp)
(match exp (match exp
;; Continuations. ;; Continuations.
(($ $letk (($ $cont k src ($ $kargs (name) (sym) body))) (($ $letk (($ $cont k ($ $kargs (name) (sym) body)))
($ $continue k ($ $const c))) ($ $continue k src ($ $const c)))
`(letconst ,k (,name ,sym ,c) `(letconst ,k (,name ,sym ,c)
,(unparse-cps body))) ,(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)) `(let ,k (,name ,sym ,(unparse-cps val))
,(unparse-cps body))) ,(unparse-cps body)))
(($ $letk conts body) (($ $letk conts body)
`(letk ,(map unparse-cps conts) ,(unparse-cps body))) `(letk ,(map unparse-cps conts) ,(unparse-cps body)))
(($ $cont sym src body) (($ $cont sym body)
`(k ,sym ,(unparse-cps body))) `(k ,sym ,(unparse-cps body)))
(($ $kif kt kf) (($ $kif kt kf)
`(kif ,kt ,kf)) `(kif ,kt ,kf))
@ -377,7 +380,7 @@
`(kclause (,req ,opt ,rest ,kw ,allow-other-keys?) ,(unparse-cps body))) `(kclause (,req ,opt ,rest ,kw ,allow-other-keys?) ,(unparse-cps body)))
;; Calls. ;; Calls.
(($ $continue k exp) (($ $continue k src exp)
`(continue ,k ,(unparse-cps exp))) `(continue ,k ,(unparse-cps exp)))
(($ $var sym) (($ $var sym)
`(var ,sym)) `(var ,sym))
@ -387,7 +390,7 @@
`(const ,val)) `(const ,val))
(($ $prim name) (($ $prim name)
`(prim ,name)) `(prim ,name))
(($ $fun meta free body) (($ $fun src meta free body)
`(fun ,meta ,free ,(unparse-cps body))) `(fun ,meta ,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)
@ -408,8 +411,8 @@
(define (fold-conts proc seed fun) (define (fold-conts proc seed fun)
(define (cont-folder cont seed) (define (cont-folder cont seed)
(match cont (match cont
(($ $cont k src cont) (($ $cont k cont)
(let ((seed (proc k src cont seed))) (let ((seed (proc k cont seed)))
(match cont (match cont
(($ $kargs names syms body) (($ $kargs names syms body)
(term-folder body seed)) (term-folder body seed))
@ -424,7 +427,7 @@
(define (fun-folder fun seed) (define (fun-folder fun seed)
(match fun (match fun
(($ $fun meta free body) (($ $fun src meta free body)
(cont-folder body seed)))) (cont-folder body seed))))
(define (term-folder term seed) (define (term-folder term seed)
@ -432,7 +435,7 @@
(($ $letk conts body) (($ $letk conts body)
(fold cont-folder (term-folder body seed) conts)) (fold cont-folder (term-folder body seed) conts))
(($ $continue k exp) (($ $continue k src exp)
(match exp (match exp
(($ $fun) (fun-folder exp seed)) (($ $fun) (fun-folder exp seed))
(_ seed))) (_ seed)))
@ -445,8 +448,8 @@
(define (fold-local-conts proc seed cont) (define (fold-local-conts proc seed cont)
(define (cont-folder cont seed) (define (cont-folder cont seed)
(match cont (match cont
(($ $cont k src cont) (($ $cont k cont)
(let ((seed (proc k src cont seed))) (let ((seed (proc k cont seed)))
(match cont (match cont
(($ $kargs names syms body) (($ $kargs names syms body)
(term-folder body seed)) (term-folder body seed))

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

@ -35,105 +35,105 @@
(define (fix-clause-arities clause) (define (fix-clause-arities clause)
(let ((conts (build-local-cont-table clause)) (let ((conts (build-local-cont-table clause))
(ktail (match clause (ktail (match clause
(($ $cont _ _ ($ $kentry _ ($ $cont ktail) _)) ktail)))) (($ $cont _ ($ $kentry _ ($ $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)
($letk ,(map visit-cont conts) ,(visit-term body))) ($letk ,(map visit-cont conts) ,(visit-term body)))
(($ $letrec names syms funs body) (($ $letrec names syms funs body)
($letrec names syms (map fix-arities funs) ,(visit-term body))) ($letrec names syms (map fix-arities funs) ,(visit-term body)))
(($ $continue k exp) (($ $continue k src exp)
,(visit-exp k exp)))) ,(visit-exp k src exp))))
(define (adapt-exp nvals k exp) (define (adapt-exp nvals k src exp)
(match nvals (match nvals
(0 (0
(rewrite-cps-term (lookup-cont k conts) (rewrite-cps-term (lookup-cont k conts)
(($ $ktail) (($ $ktail)
,(let-gensyms (kvoid kunspec unspec) ,(let-gensyms (kvoid kunspec unspec)
(build-cps-term (build-cps-term
($letk* ((kunspec #f ($kargs (unspec) (unspec) ($letk* ((kunspec ($kargs (unspec) (unspec)
($continue k ($continue k src
($primcall 'return (unspec))))) ($primcall 'return (unspec)))))
(kvoid #f ($kargs () () (kvoid ($kargs () ()
($continue kunspec ($void))))) ($continue kunspec src ($void)))))
($continue kvoid ,exp))))) ($continue kvoid src ,exp)))))
(($ $ktrunc arity kargs) (($ $ktrunc arity kargs)
,(rewrite-cps-term arity ,(rewrite-cps-term arity
(($ $arity () () #f () #f) (($ $arity () () #f () #f)
($continue kargs ,exp)) ($continue kargs src ,exp))
(_ (_
,(let-gensyms (kvoid kvalues void) ,(let-gensyms (kvoid kvalues void)
(build-cps-term (build-cps-term
($letk* ((kvalues #f ($kargs ('void) (void) ($letk* ((kvalues ($kargs ('void) (void)
($continue k ($continue k src
($primcall 'values (void))))) ($primcall 'values (void)))))
(kvoid #f ($kargs () () (kvoid ($kargs () ()
($continue kvalues ($continue kvalues src
($void))))) ($void)))))
($continue kvoid ,exp))))))) ($continue kvoid src ,exp)))))))
(($ $kargs () () _) (($ $kargs () () _)
($continue k ,exp)) ($continue k src ,exp))
(_ (_
,(let-gensyms (k*) ,(let-gensyms (k*)
(build-cps-term (build-cps-term
($letk ((k* #f ($kargs () () ($continue k ($void))))) ($letk ((k* ($kargs () () ($continue k src ($void)))))
($continue k* ,exp))))))) ($continue k* src ,exp)))))))
(1 (1
(rewrite-cps-term (lookup-cont k conts) (rewrite-cps-term (lookup-cont k conts)
(($ $ktail) (($ $ktail)
,(rewrite-cps-term exp ,(rewrite-cps-term exp
(($var sym) (($var sym)
($continue ktail ($primcall 'return (sym)))) ($continue ktail src ($primcall 'return (sym))))
(_ (_
,(let-gensyms (k* v) ,(let-gensyms (k* v)
(build-cps-term (build-cps-term
($letk ((k* #f ($kargs (v) (v) ($letk ((k* ($kargs (v) (v)
($continue k ($continue k src
($primcall 'return (v)))))) ($primcall 'return (v))))))
($continue k* ,exp))))))) ($continue k* src ,exp)))))))
(($ $ktrunc arity kargs) (($ $ktrunc arity kargs)
,(rewrite-cps-term arity ,(rewrite-cps-term arity
(($ $arity (_) () #f () #f) (($ $arity (_) () #f () #f)
($continue kargs ,exp)) ($continue kargs src ,exp))
(_ (_
,(let-gensyms (kvalues value) ,(let-gensyms (kvalues value)
(build-cps-term (build-cps-term
($letk ((kvalues #f ($kargs ('value) (value) ($letk ((kvalues ($kargs ('value) (value)
($continue k ($continue k src
($primcall 'values (value)))))) ($primcall 'values (value))))))
($continue kvalues ,exp))))))) ($continue kvalues src ,exp)))))))
(($ $kargs () () _) (($ $kargs () () _)
,(let-gensyms (k* drop) ,(let-gensyms (k* drop)
(build-cps-term (build-cps-term
($letk ((k* #f ($kargs ('drop) (drop) ($letk ((k* ($kargs ('drop) (drop)
($continue k ($values ()))))) ($continue k src ($values ())))))
($continue k* ,exp))))) ($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 (rewrite-cps-term exp
((or ($ $void) ((or ($ $void)
($ $const) ($ $const)
($ $prim) ($ $prim)
($ $var)) ($ $var))
,(adapt-exp 1 k exp)) ,(adapt-exp 1 k src exp))
(($ $fun) (($ $fun)
,(adapt-exp 1 k (fix-arities exp))) ,(adapt-exp 1 k src (fix-arities exp)))
(($ $call) (($ $call)
;; In general, calls have unknown return arity. For that ;; In general, calls have unknown return arity. For that
;; reason every non-tail call has an implicit adaptor ;; reason every non-tail call has an implicit adaptor
;; continuation to adapt the return to the target ;; continuation to adapt the return to the target
;; continuation, and we don't need to do any adapting here. ;; continuation, and we don't need to do any adapting here.
($continue k ,exp)) ($continue k src ,exp))
(($ $primcall 'return (arg)) (($ $primcall 'return (arg))
;; Primcalls to return are in tail position. ;; Primcalls to return are in tail position.
($continue ktail ,exp)) ($continue ktail src ,exp))
(($ $primcall (? (lambda (name) (($ $primcall (? (lambda (name)
(and (not (prim-rtl-instruction name)) (and (not (prim-rtl-instruction name))
(not (branching-primitive? name)))))) (not (branching-primitive? name))))))
($continue k ,exp)) ($continue k src ,exp))
(($ $primcall 'struct-set! (obj pos val)) (($ $primcall 'struct-set! (obj pos val))
;; Unhappily, and undocumentedly, struct-set! returns the value ;; Unhappily, and undocumentedly, struct-set! returns the value
;; that was set. There is code that relies on this. Hackety ;; that was set. There is code that relies on this. Hackety
@ -142,63 +142,63 @@
(($ $ktail) (($ $ktail)
,(let-gensyms (kvoid) ,(let-gensyms (kvoid)
(build-cps-term (build-cps-term
($letk* ((kvoid #f ($kargs () () ($letk* ((kvoid ($kargs () ()
($continue ktail ($continue ktail src
($primcall 'return (val)))))) ($primcall 'return (val))))))
($continue kvoid ,exp))))) ($continue kvoid src ,exp)))))
(($ $ktrunc arity kargs) (($ $ktrunc arity kargs)
,(rewrite-cps-term arity ,(rewrite-cps-term arity
(($ $arity () () #f () #f) (($ $arity () () #f () #f)
($continue kargs ,exp)) ($continue kargs src ,exp))
(_ (_
,(let-gensyms (kvoid) ,(let-gensyms (kvoid)
(build-cps-term (build-cps-term
($letk* ((kvoid #f ($kargs () () ($letk* ((kvoid ($kargs () ()
($continue k ($continue k src
($primcall 'values (val)))))) ($primcall 'values (val))))))
($continue kvoid ,exp))))))) ($continue kvoid src ,exp)))))))
(($ $kargs () () _) (($ $kargs () () _)
($continue k ,exp)) ($continue k src ,exp))
(_ (_
,(let-gensyms (k*) ,(let-gensyms (k*)
(build-cps-term (build-cps-term
($letk ((k* #f ($kargs () () ($continue k ($var val))))) ($letk ((k* ($kargs () () ($continue k src ($var val)))))
($continue k* ,exp))))))) ($continue k* src ,exp)))))))
(($ $primcall name args) (($ $primcall name args)
,(match (prim-arity name) ,(match (prim-arity name)
((out . in) ((out . in)
(if (= in (length args)) (if (= in (length args))
(adapt-exp out k (adapt-exp out k src
(let ((inst (prim-rtl-instruction name))) (let ((inst (prim-rtl-instruction name)))
(if (and inst (not (eq? inst name))) (if (and inst (not (eq? inst name)))
(build-cps-exp ($primcall inst args)) (build-cps-exp ($primcall inst args))
exp))) exp)))
(let-gensyms (k* p*) (let-gensyms (k* p*)
(build-cps-term (build-cps-term
($letk ((k* #f ($kargs ('prim) (p*) ($letk ((k* ($kargs ('prim) (p*)
($continue k ($call p* args))))) ($continue k src ($call p* args)))))
($continue k* ($prim name))))))))) ($continue k* src ($prim name)))))))))
(($ $values) (($ $values)
;; Values nodes are inserted by CPS optimization passes, so ;; Values nodes are inserted by CPS optimization passes, so
;; we assume they are correct. ;; we assume they are correct.
($continue k ,exp)) ($continue k src ,exp))
(($ $prompt) (($ $prompt)
($continue k ,exp)))) ($continue k src ,exp))))
(define (visit-cont cont) (define (visit-cont cont)
(rewrite-cps-cont cont (rewrite-cps-cont cont
(($ $cont sym src ($ $kargs names syms body)) (($ $cont sym ($ $kargs names syms body))
(sym src ($kargs names syms ,(visit-term body)))) (sym ($kargs names syms ,(visit-term body))))
(($ $cont sym src ($ $kclause arity body)) (($ $cont sym ($ $kclause arity body))
(sym src ($kclause ,arity ,(visit-cont body)))) (sym ($kclause ,arity ,(visit-cont body))))
(($ $cont) (($ $cont)
,cont))) ,cont)))
(rewrite-cps-cont clause (rewrite-cps-cont clause
(($ $cont sym src ($ $kentry self tail clauses)) (($ $cont sym ($ $kentry self tail clauses))
(sym src ($kentry self ,tail ,(map visit-cont clauses))))))) (sym ($kentry self ,tail ,(map visit-cont clauses)))))))
(define (fix-arities fun) (define (fix-arities fun)
(rewrite-cps-exp fun (rewrite-cps-exp fun
(($ $fun meta free body) (($ $fun src meta free body)
($fun meta free ,(fix-clause-arities body))))) ($fun src meta free ,(fix-clause-arities body)))))

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

@ -63,8 +63,8 @@ values in the term."
(let-gensyms (k* sym*) (let-gensyms (k* sym*)
(receive (exp free) (k sym*) (receive (exp free) (k sym*)
(values (build-cps-term (values (build-cps-term
($letk ((k* #f ($kargs (sym*) (sym*) ,exp))) ($letk ((k* ($kargs (sym*) (sym*) ,exp)))
($continue k* ($primcall 'free-ref (self sym))))) ($continue k* #f ($primcall 'free-ref (self sym)))))
(cons sym free)))))) (cons sym free))))))
(define (convert-free-vars syms self bound k) (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) (fold (lambda (free idx body)
(let-gensyms (k idxsym) (let-gensyms (k idxsym)
(build-cps-term (build-cps-term
($letk ((k src ($kargs () () ,body))) ($letk ((k ($kargs () () ,body)))
,(convert-free-var ,(convert-free-var
free outer-self outer-bound free outer-self outer-bound
(lambda (free) (lambda (free)
(values (build-cps-term (values (build-cps-term
($letconst (('idx idxsym idx)) ($letconst (('idx idxsym idx))
($continue k ($continue k src
($primcall 'free-set! (v idxsym free))))) ($primcall 'free-set! (v idxsym free)))))
'()))))))) '())))))))
body body
@ -123,19 +123,19 @@ convert functions to flat closures."
(values (build-cps-term ($letk ,conts ,body)) (values (build-cps-term ($letk ,conts ,body))
(union free free*))))) (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)) (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))) free)))
(($ $cont sym src ($ $kentry self tail clauses)) (($ $cont sym ($ $kentry self tail clauses))
(receive (clauses free) (cc* clauses self (list self)) (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))) free)))
(($ $cont sym src ($ $kclause arity body)) (($ $cont sym ($ $kclause arity body))
(receive (body free) (cc body self bound) (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))) free)))
(($ $cont) (($ $cont)
@ -153,76 +153,76 @@ convert functions to flat closures."
(free free)) (free free))
(match in (match in
(() (values (bindings body) free)) (() (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 '()) (receive (fun-body fun-free) (cc fun-body #f '())
(lp in (lp in
(lambda (body) (lambda (body)
(let-gensyms (k) (let-gensyms (k)
(build-cps-term (build-cps-term
($letk ((k #f ($kargs (name) (sym) ,(bindings body)))) ($letk ((k ($kargs (name) (sym) ,(bindings body))))
($continue k ($continue k src
($fun meta fun-free ,fun-body)))))) ($fun src meta fun-free ,fun-body))))))
(init-closure #f 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))))))))))
(($ $continue k ($ $var sym)) (($ $continue k src ($ $var sym))
(convert-free-var sym self bound (convert-free-var sym self bound
(lambda (sym) (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) (or ($ $void)
($ $const) ($ $const)
($ $prim))) ($ $prim)))
(values exp '())) (values exp '()))
(($ $continue k ($ $fun meta () body)) (($ $continue k src ($ $fun src* meta () 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 ($fun meta free ,body))) ($continue k src ($fun src* meta free ,body)))
free)) free))
(_ (_
(values (values
(let-gensyms (kinit v) (let-gensyms (kinit v)
(build-cps-term (build-cps-term
($letk ((kinit #f ($kargs (v) (v) ($letk ((kinit ($kargs (v) (v)
,(init-closure #f v free self bound ,(init-closure src v free self bound
(build-cps-term (build-cps-term
($continue k ($var v))))))) ($continue k src ($var v)))))))
($continue kinit ($fun meta free ,body))))) ($continue kinit src ($fun src* meta free ,body)))))
(difference free bound)))))) (difference free bound))))))
(($ $continue k ($ $call proc args)) (($ $continue k src ($ $call proc args))
(convert-free-vars (cons proc args) self bound (convert-free-vars (cons proc args) self bound
(match-lambda (match-lambda
((proc . args) ((proc . args)
(values (build-cps-term (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 (convert-free-vars args self bound
(lambda (args) (lambda (args)
(values (build-cps-term (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 (convert-free-vars args self bound
(lambda (args) (lambda (args)
(values (build-cps-term (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 (convert-free-var
tag self bound tag self bound
(lambda (tag) (lambda (tag)
(values (build-cps-term (values (build-cps-term
($continue k ($prompt escape? tag handler pop))) ($continue k src ($prompt escape? tag handler pop)))
'())))) '()))))
(_ (error "what" exp)))) (_ (error "what" exp))))
@ -237,37 +237,38 @@ convert functions to flat closures."
(rewrite-cps-term term (rewrite-cps-term term
(($ $letk conts body) (($ $letk conts body)
($letk ,(map visit-cont conts) ,(visit-term 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) ,(let-gensyms (idx)
(build-cps-term (build-cps-term
($letconst (('idx idx (free-index sym))) ($letconst (('idx idx (free-index sym)))
($continue k ($primcall 'free-ref (closure idx))))))) ($continue k src ($primcall 'free-ref (closure idx)))))))
(($ $continue k ($ $fun meta free body)) (($ $continue k src ($ $fun src* meta free body))
($continue k ($fun meta free ,(convert-to-indices body free)))) ($continue k src
($fun src* meta free ,(convert-to-indices body free))))
(($ $continue) (($ $continue)
,term))) ,term)))
(define (visit-cont cont) (define (visit-cont cont)
(rewrite-cps-cont cont (rewrite-cps-cont cont
(($ $cont sym src ($ $kargs names syms body)) (($ $cont sym ($ $kargs names syms body))
(sym src ($kargs names syms ,(visit-term body)))) (sym ($kargs names syms ,(visit-term body))))
(($ $cont sym src ($ $kclause arity body)) (($ $cont sym ($ $kclause arity body))
(sym src ($kclause ,arity ,(visit-cont body)))) (sym ($kclause ,arity ,(visit-cont body))))
;; Other kinds of continuations don't bind values and don't have ;; Other kinds of continuations don't bind values and don't have
;; bodies. ;; bodies.
(($ $cont) (($ $cont)
,cont))) ,cont)))
(rewrite-cps-cont body (rewrite-cps-cont body
(($ $cont sym src ($ $kentry self tail clauses)) (($ $cont sym ($ $kentry self tail clauses))
(sym src ($kentry self ,tail ,(map visit-cont clauses)))))) (sym ($kentry self ,tail ,(map visit-cont clauses))))))
(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."
(match exp (match exp
(($ $fun meta () body) (($ $fun src meta () 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 meta free ,(convert-to-indices body free))))))) ($fun src meta free ,(convert-to-indices body free)))))))

746
module/language/cps/compile-rtl.scm
View file

@ -76,413 +76,405 @@
exp)) exp))
(define (collect-conts f cfa) (define (collect-conts f cfa)
(let ((srcv (make-vector (cfa-k-count cfa) #f)) (let ((contv (make-vector (cfa-k-count cfa) #f)))
(contv (make-vector (cfa-k-count cfa) #f)))
(fold-local-conts (fold-local-conts
(lambda (k src cont tail) (lambda (k cont tail)
(let ((idx (cfa-k-idx cfa k #:default (lambda (k) #f)))) (let ((idx (cfa-k-idx cfa k #:default (lambda (k) #f))))
(when idx (when idx
(when src
(vector-set! srcv idx src))
(vector-set! contv idx cont)))) (vector-set! contv idx cont))))
'() '()
(match f (match f
(($ $fun meta free entry) (($ $fun src meta free entry)
entry))) entry)))
(values srcv contv))) contv))
(define (compile-fun f asm) (define (compile-fun f asm)
(let* ((dfg (compute-dfg f #:global? #f)) (let* ((dfg (compute-dfg f #:global? #f))
(cfa (analyze-control-flow f dfg)) (cfa (analyze-control-flow f dfg))
(allocation (allocate-slots f dfg))) (allocation (allocate-slots f dfg))
(call-with-values (lambda () (collect-conts f cfa)) (contv (collect-conts f cfa)))
(lambda (srcv contv) (define (lookup-cont k)
(define (lookup-cont k) (vector-ref contv (cfa-k-idx cfa k)))
(vector-ref contv (cfa-k-idx cfa k)))
(define (maybe-emit-source n) (define (immediate-u8? val)
(let ((src (vector-ref srcv n))) (and (integer? val) (exact? val) (<= 0 val 255)))
(when src
(emit-source asm src))))
(define (emit-label-and-maybe-source n) (define (maybe-immediate-u8 sym)
(emit-label asm (cfa-k-sym cfa n)) (call-with-values (lambda ()
(maybe-emit-source n)) (lookup-maybe-constant-value sym allocation))
(lambda (has-const? val)
(and has-const? (immediate-u8? val) val))))
(define (immediate-u8? val) (define (slot sym)
(and (integer? val) (exact? val) (<= 0 val 255))) (lookup-slot sym allocation))
(define (maybe-immediate-u8 sym) (define (constant sym)
(call-with-values (lambda () (lookup-constant-value sym allocation))
(lookup-maybe-constant-value sym allocation))
(lambda (has-const? val)
(and has-const? (immediate-u8? val) val))))
(define (slot sym) (define (maybe-mov dst src)
(lookup-slot sym allocation)) (unless (= dst src)
(emit-mov asm dst src)))
(define (constant sym) (define (maybe-load-constant slot src)
(lookup-constant-value sym allocation)) (call-with-values (lambda ()
(lookup-maybe-constant-value src allocation))
(lambda (has-const? val)
(and has-const?
(begin
(emit-load-constant asm slot val)
#t)))))
(define (maybe-mov dst src) (define (compile-entry meta)
(unless (= dst src) (match (vector-ref contv 0)
(emit-mov asm dst src))) (($ $kentry self tail clauses)
(emit-begin-program asm (cfa-k-sym cfa 0) meta)
(let lp ((n 1)
(ks (map (match-lambda (($ $cont k) k)) clauses)))
(match ks
(()
(unless (= n (vector-length contv))
(error "unexpected end of clauses"))
(emit-end-program asm))
((k . ks)
(unless (eq? (cfa-k-sym cfa n) k)
(error "unexpected k" k))
(lp (compile-clause n (and (pair? ks) (car ks)))
ks)))))))
(define (maybe-load-constant slot src) (define (compile-clause n alternate)
(call-with-values (lambda () (match (vector-ref contv n)
(lookup-maybe-constant-value src allocation)) (($ $kclause ($ $arity req opt rest kw allow-other-keys?))
(lambda (has-const? val) (let* ((kw-indices (map (match-lambda
(and has-const? ((key name sym)
(begin (cons key (lookup-slot sym allocation))))
(emit-load-constant asm slot val) kw))
#t))))) (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)))
(emit-end-arity asm)
next)))))
(define (compile-entry meta) (define (compile-body n nlocals)
(match (vector-ref contv 0) (let compile-cont ((n n))
(($ $kentry self tail clauses) (if (= n (vector-length contv))
(emit-begin-program asm (cfa-k-sym cfa 0) meta) n
(maybe-emit-source 0) (match (vector-ref contv n)
(let lp ((n 1) (($ $kclause) n)
(ks (map (match-lambda (($ $cont k) k)) clauses))) (($ $kargs _ _ term)
(match ks (emit-label asm (cfa-k-sym cfa n))
(() (let find-exp ((term term))
(unless (= n (vector-length contv)) (match term
(error "unexpected end of clauses")) (($ $letk conts term)
(emit-end-program asm)) (find-exp term))
((k . ks) (($ $continue k src exp)
(unless (eq? (cfa-k-sym cfa n) k) (when src
(error "unexpected k" k)) (emit-source asm src))
(lp (compile-clause n (and (pair? ks) (car ks))) (compile-expression n k exp nlocals)
ks))))))) (compile-cont (1+ n))))))
(_
(emit-label asm (cfa-k-sym cfa n))
(compile-cont (1+ n)))))))
(define (compile-clause n alternate) (define (compile-expression n k exp nlocals)
(match (vector-ref contv n) (let* ((label (cfa-k-sym cfa n))
(($ $kclause ($ $arity req opt rest kw allow-other-keys?)) (k-idx (cfa-k-idx cfa k))
(let ((kw-indices (map (match-lambda (fallthrough? (= k-idx (1+ n))))
((key name sym) (define (maybe-emit-jump)
(cons key (lookup-slot sym allocation)))) (unless (= k-idx (1+ n))
kw)) (emit-br asm k)))
(nlocals (lookup-nlocals (cfa-k-sym cfa n) allocation))) (match (vector-ref contv k-idx)
(emit-label-and-maybe-source n) (($ $ktail)
(emit-begin-kw-arity asm req opt rest kw-indices (compile-tail label exp))
allow-other-keys? nlocals alternate) (($ $kargs (name) (sym))
(let ((next (compile-body (1+ n) nlocals))) (let ((dst (slot sym)))
(emit-end-arity asm) (when dst
next))))) (compile-value label exp dst nlocals)))
(maybe-emit-jump))
(($ $kargs () ())
(compile-effect label exp k nlocals)
(maybe-emit-jump))
(($ $kargs names syms)
(compile-values label exp syms)
(maybe-emit-jump))
(($ $kif kt kf)
(compile-test label exp kt kf
(and (= k-idx (1+ n))
(< (+ n 2) (cfa-k-count cfa))
(cfa-k-sym cfa (+ n 2)))))
(($ $ktrunc ($ $arity req () rest () #f) k)
(compile-trunc label exp (length req) (and rest #t) nlocals)
(unless (and (= k-idx (1+ n))
(< (+ n 2) (cfa-k-count cfa))
(eq? (cfa-k-sym cfa (+ n 2)) k))
(emit-br asm k))))))
(define (compile-body n nlocals) (define (compile-tail label exp)
(let compile-cont ((n n)) ;; There are only three kinds of expressions in tail position:
(if (= n (vector-length contv)) ;; tail calls, multiple-value returns, and single-value returns.
n (match exp
(match (vector-ref contv n) (($ $call proc args)
(($ $kclause) n) (for-each (match-lambda
(($ $kargs _ _ term) ((src . dst) (emit-mov asm dst src)))
(emit-label-and-maybe-source n) (lookup-parallel-moves label allocation))
(let find-exp ((term term)) (let ((tail-slots (cdr (iota (1+ (length args))))))
(match term (for-each maybe-load-constant tail-slots args))
(($ $letk conts term) (emit-tail-call asm (1+ (length args))))
(find-exp term)) (($ $values args)
(($ $continue k exp) (let ((tail-slots (cdr (iota (1+ (length args))))))
(compile-expression n k exp nlocals) (for-each (match-lambda
(compile-cont (1+ n)))))) ((src . dst) (emit-mov asm dst src)))
(_ (lookup-parallel-moves label allocation))
(emit-label-and-maybe-source n) (for-each maybe-load-constant tail-slots args))
(compile-cont (1+ n))))))) (emit-reset-frame asm (1+ (length args)))
(emit-return-values asm))
(($ $primcall 'return (arg))
(emit-return asm (slot arg)))))
(define (compile-expression n k exp nlocals) (define (compile-value label exp dst nlocals)
(let* ((label (cfa-k-sym cfa n)) (match exp
(k-idx (cfa-k-idx cfa k)) (($ $var sym)
(fallthrough? (= k-idx (1+ n)))) (maybe-mov dst (slot sym)))
(define (maybe-emit-jump) ;; FIXME: Remove ($var sym), replace with ($values (sym))
(unless (= k-idx (1+ n)) (($ $values (arg))
(emit-br asm k))) (or (maybe-load-constant dst arg)
(match (vector-ref contv k-idx) (maybe-mov dst (slot arg))))
(($ $ktail) (($ $void)
(compile-tail label exp)) (emit-load-constant asm dst *unspecified*))
(($ $kargs (name) (sym)) (($ $const exp)
(let ((dst (slot sym))) (emit-load-constant asm dst exp))
(when dst (($ $fun src meta () ($ $cont k))
(compile-value label exp dst nlocals))) (emit-load-static-procedure asm dst k))
(maybe-emit-jump)) (($ $fun src meta free ($ $cont k))
(($ $kargs () ()) (emit-make-closure asm dst k (length free)))
(compile-effect label exp k nlocals) (($ $call proc args)
(maybe-emit-jump)) (let ((proc-slot (lookup-call-proc-slot label allocation))
(($ $kargs names syms) (nargs (length args)))
(compile-values label exp syms) (or (maybe-load-constant proc-slot proc)
(maybe-emit-jump)) (maybe-mov proc-slot (slot proc)))
(($ $kif kt kf) (let lp ((n (1+ proc-slot)) (args args))
(compile-test label exp kt kf (match args
(and (= k-idx (1+ n)) (()
(< (+ n 2) (cfa-k-count cfa)) (emit-call asm proc-slot (+ nargs 1))
(cfa-k-sym cfa (+ n 2))))) (emit-receive asm dst proc-slot nlocals))
(($ $ktrunc ($ $arity req () rest () #f) k) ((arg . args)
(compile-trunc label exp (length req) (and rest #t) nlocals) (or (maybe-load-constant n arg)
(unless (and (= k-idx (1+ n)) (maybe-mov n (slot arg)))
(< (+ n 2) (cfa-k-count cfa)) (lp (1+ n) args))))))
(eq? (cfa-k-sym cfa (+ n 2)) k)) (($ $primcall 'current-module)
(emit-br asm k)))))) (emit-current-module asm dst))
(($ $primcall 'cached-toplevel-box (scope name bound?))
(emit-cached-toplevel-box asm dst (constant scope) (constant name)
(constant bound?)))
(($ $primcall 'cached-module-box (mod name public? bound?))
(emit-cached-module-box asm dst (constant mod) (constant name)
(constant public?) (constant bound?)))
(($ $primcall 'resolve (name bound?))
(emit-resolve asm dst (constant bound?) (slot name)))
(($ $primcall 'free-ref (closure idx))
(emit-free-ref asm dst (slot closure) (constant idx)))
(($ $primcall 'make-vector (length init))
(cond
((maybe-immediate-u8 length)
=> (lambda (length)
(emit-constant-make-vector asm dst length (slot init))))
(else
(emit-make-vector asm dst (slot length) (slot init)))))
(($ $primcall 'vector-ref (vector index))
(cond
((maybe-immediate-u8 index)
=> (lambda (index)
(emit-constant-vector-ref asm dst (slot vector) index)))
(else
(emit-vector-ref asm dst (slot vector) (slot index)))))
(($ $primcall 'builtin-ref (name))
(emit-builtin-ref asm dst (constant name)))
(($ $primcall 'bv-u8-ref (bv idx))
(emit-bv-u8-ref asm dst (slot bv) (slot idx)))
(($ $primcall 'bv-u16-ref (bv idx))
(emit-bv-u16-ref asm dst (slot bv) (slot idx)))
(($ $primcall 'bv-s16-ref (bv idx))
(emit-bv-s16-ref asm dst (slot bv) (slot idx)))
(($ $primcall 'bv-u32-ref (bv idx val))
(emit-bv-u32-ref asm dst (slot bv) (slot idx)))
(($ $primcall 'bv-s32-ref (bv idx val))
(emit-bv-s32-ref asm dst (slot bv) (slot idx)))
(($ $primcall 'bv-u64-ref (bv idx val))
(emit-bv-u64-ref asm dst (slot bv) (slot idx)))
(($ $primcall 'bv-s64-ref (bv idx val))
(emit-bv-s64-ref asm dst (slot bv) (slot idx)))
(($ $primcall 'bv-f32-ref (bv idx val))
(emit-bv-f32-ref asm dst (slot bv) (slot idx)))
(($ $primcall 'bv-f64-ref (bv idx val))
(emit-bv-f64-ref asm dst (slot bv) (slot idx)))
(($ $primcall name args)
;; FIXME: Inline all the cases.
(let ((inst (prim-rtl-instruction name)))
(emit-text asm `((,inst ,dst ,@(map slot args))))))))
(define (compile-tail label exp) (define (compile-effect label exp k nlocals)
;; There are only three kinds of expressions in tail position: (match exp
;; tail calls, multiple-value returns, and single-value returns. (($ $values ()) #f)
(match exp (($ $prompt escape? tag handler pop)
(($ $call proc args) (match (lookup-cont handler)
(for-each (match-lambda (($ $ktrunc ($ $arity req () rest () #f) khandler-body)
((src . dst) (emit-mov asm dst src))) (let ((receive-args (gensym "handler"))
(lookup-parallel-moves label allocation)) (nreq (length req))
(let ((tail-slots (cdr (iota (1+ (length args)))))) (proc-slot (lookup-call-proc-slot label allocation)))
(for-each maybe-load-constant tail-slots args)) (emit-prompt asm (slot tag) escape? proc-slot receive-args)
(emit-tail-call asm (1+ (length args)))) (emit-br asm k)
(($ $values args) (emit-label asm receive-args)
(let ((tail-slots (cdr (iota (1+ (length args)))))) (emit-receive-values asm proc-slot (->bool rest) nreq)
(for-each (match-lambda (when rest
((src . dst) (emit-mov asm dst src))) (emit-bind-rest asm (+ proc-slot 1 nreq)))
(lookup-parallel-moves label allocation)) (for-each (match-lambda
(for-each maybe-load-constant tail-slots args)) ((src . dst) (emit-mov asm dst src)))
(emit-reset-frame asm (1+ (length args))) (lookup-parallel-moves handler allocation))
(emit-return-values asm)) (emit-reset-frame asm nlocals)
(($ $primcall 'return (arg)) (emit-br asm khandler-body)))))
(emit-return asm (slot arg))))) (($ $primcall 'cache-current-module! (sym scope))
(emit-cache-current-module! asm (slot sym) (constant scope)))
(($ $primcall 'free-set! (closure idx value))
(emit-free-set! asm (slot closure) (slot value) (constant idx)))
(($ $primcall 'box-set! (box value))
(emit-box-set! asm (slot box) (slot value)))
(($ $primcall 'struct-set! (struct index value))
(emit-struct-set! asm (slot struct) (slot index) (slot value)))
(($ $primcall 'vector-set! (vector index value))
(call-with-values (lambda ()
(lookup-maybe-constant-value index allocation))
(lambda (has-const? index-val)
(if (and has-const? (integer? index-val) (exact? index-val)
(<= 0 index-val 255))
(emit-constant-vector-set! asm (slot vector) index-val
(slot value))
(emit-vector-set! asm (slot vector) (slot index)
(slot value))))))
(($ $primcall 'variable-set! (var val))
(emit-box-set! asm (slot var) (slot val)))
(($ $primcall 'set-car! (pair value))
(emit-set-car! asm (slot pair) (slot value)))
(($ $primcall 'set-cdr! (pair value))
(emit-set-cdr! asm (slot pair) (slot value)))
(($ $primcall 'define! (sym value))
(emit-define! asm (slot sym) (slot value)))
(($ $primcall 'push-fluid (fluid val))
(emit-push-fluid asm (slot fluid) (slot val)))
(($ $primcall 'pop-fluid ())
(emit-pop-fluid asm))
(($ $primcall 'wind (winder unwinder))
(emit-wind asm (slot winder) (slot unwinder)))
(($ $primcall 'bv-u8-set! (bv idx val))
(emit-bv-u8-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'bv-u16-set! (bv idx val))
(emit-bv-u16-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'bv-s16-set! (bv idx val))
(emit-bv-s16-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'bv-u32-set! (bv idx val))
(emit-bv-u32-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'bv-s32-set! (bv idx val))
(emit-bv-s32-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'bv-u64-set! (bv idx val))
(emit-bv-u64-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'bv-s64-set! (bv idx val))
(emit-bv-s64-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'bv-f32-set! (bv idx val))
(emit-bv-f32-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'bv-f64-set! (bv idx val))
(emit-bv-f64-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'unwind ())
(emit-unwind asm))))
(define (compile-value label exp dst nlocals) (define (compile-values label exp syms)
(match exp (match exp
(($ $var sym) (($ $values args)
(maybe-mov dst (slot sym))) (for-each (match-lambda
;; FIXME: Remove ($var sym), replace with ($values (sym)) ((src . dst) (emit-mov asm dst src)))
(($ $values (arg)) (lookup-parallel-moves label allocation))
(or (maybe-load-constant dst arg) (for-each maybe-load-constant (map slot syms) args))))
(maybe-mov dst (slot arg))))
(($ $void)
(emit-load-constant asm dst *unspecified*))
(($ $const exp)
(emit-load-constant asm dst exp))
(($ $fun meta () ($ $cont k))
(emit-load-static-procedure asm dst k))
(($ $fun meta free ($ $cont k))
(emit-make-closure asm dst k (length free)))
(($ $call proc args)
(let ((proc-slot (lookup-call-proc-slot label allocation))
(nargs (length args)))
(or (maybe-load-constant proc-slot proc)
(maybe-mov proc-slot (slot proc)))
(let lp ((n (1+ proc-slot)) (args args))
(match args
(()
(emit-call asm proc-slot (+ nargs 1))
(emit-receive asm dst proc-slot nlocals))
((arg . args)
(or (maybe-load-constant n arg)
(maybe-mov n (slot arg)))
(lp (1+ n) args))))))
(($ $primcall 'current-module)
(emit-current-module asm dst))
(($ $primcall 'cached-toplevel-box (scope name bound?))
(emit-cached-toplevel-box asm dst (constant scope) (constant name)
(constant bound?)))
(($ $primcall 'cached-module-box (mod name public? bound?))
(emit-cached-module-box asm dst (constant mod) (constant name)
(constant public?) (constant bound?)))
(($ $primcall 'resolve (name bound?))
(emit-resolve asm dst (constant bound?) (slot name)))
(($ $primcall 'free-ref (closure idx))
(emit-free-ref asm dst (slot closure) (constant idx)))
(($ $primcall 'make-vector (length init))
(cond
((maybe-immediate-u8 length)
=> (lambda (length)
(emit-constant-make-vector asm dst length (slot init))))
(else
(emit-make-vector asm dst (slot length) (slot init)))))
(($ $primcall 'vector-ref (vector index))
(cond
((maybe-immediate-u8 index)
=> (lambda (index)
(emit-constant-vector-ref asm dst (slot vector) index)))
(else
(emit-vector-ref asm dst (slot vector) (slot index)))))
(($ $primcall 'builtin-ref (name))
(emit-builtin-ref asm dst (constant name)))
(($ $primcall 'bv-u8-ref (bv idx))
(emit-bv-u8-ref asm dst (slot bv) (slot idx)))
(($ $primcall 'bv-u16-ref (bv idx))
(emit-bv-u16-ref asm dst (slot bv) (slot idx)))
(($ $primcall 'bv-s16-ref (bv idx))
(emit-bv-s16-ref asm dst (slot bv) (slot idx)))
(($ $primcall 'bv-u32-ref (bv idx val))
(emit-bv-u32-ref asm dst (slot bv) (slot idx)))
(($ $primcall 'bv-s32-ref (bv idx val))
(emit-bv-s32-ref asm dst (slot bv) (slot idx)))
(($ $primcall 'bv-u64-ref (bv idx val))
(emit-bv-u64-ref asm dst (slot bv) (slot idx)))
(($ $primcall 'bv-s64-ref (bv idx val))
(emit-bv-s64-ref asm dst (slot bv) (slot idx)))
(($ $primcall 'bv-f32-ref (bv idx val))
(emit-bv-f32-ref asm dst (slot bv) (slot idx)))
(($ $primcall 'bv-f64-ref (bv idx val))
(emit-bv-f64-ref asm dst (slot bv) (slot idx)))
(($ $primcall name args)
;; FIXME: Inline all the cases.
(let ((inst (prim-rtl-instruction name)))
(emit-text asm `((,inst ,dst ,@(map slot args))))))))
(define (compile-effect label exp k nlocals) (define (compile-test label exp kt kf next-label)
(match exp (define (unary op sym)
(($ $values ()) #f) (cond
(($ $prompt escape? tag handler pop) ((eq? kt next-label)
(match (lookup-cont handler) (op asm (slot sym) #t kf))
(($ $ktrunc ($ $arity req () rest () #f) khandler-body) (else
(let ((receive-args (gensym "handler")) (op asm (slot sym) #f kt)
(nreq (length req)) (unless (eq? kf next-label)
(proc-slot (lookup-call-proc-slot label allocation))) (emit-br asm kf)))))
(emit-prompt asm (slot tag) escape? proc-slot receive-args) (define (binary op a b)
(emit-br asm k) (cond
(emit-label asm receive-args) ((eq? kt next-label)
(emit-receive-values asm proc-slot (->bool rest) nreq) (op asm (slot a) (slot b) #t kf))
(when rest (else
(emit-bind-rest asm (+ proc-slot 1 nreq))) (op asm (slot a) (slot b) #f kt)
(for-each (match-lambda (unless (eq? kf next-label)
((src . dst) (emit-mov asm dst src))) (emit-br asm kf)))))
(lookup-parallel-moves handler allocation)) (match exp
(emit-reset-frame asm nlocals) (($ $var sym) (unary emit-br-if-true sym))
(emit-br asm khandler-body))))) (($ $primcall 'null? (a)) (unary emit-br-if-null a))
(($ $primcall 'cache-current-module! (sym scope)) (($ $primcall 'nil? (a)) (unary emit-br-if-nil a))
(emit-cache-current-module! asm (slot sym) (constant scope))) (($ $primcall 'pair? (a)) (unary emit-br-if-pair a))
(($ $primcall 'free-set! (closure idx value)) (($ $primcall 'struct? (a)) (unary emit-br-if-struct a))
(emit-free-set! asm (slot closure) (slot value) (constant idx))) (($ $primcall 'char? (a)) (unary emit-br-if-char a))
(($ $primcall 'box-set! (box value)) (($ $primcall 'symbol? (a)) (unary emit-br-if-symbol a))
(emit-box-set! asm (slot box) (slot value))) (($ $primcall 'variable? (a)) (unary emit-br-if-variable a))
(($ $primcall 'struct-set! (struct index value)) (($ $primcall 'vector? (a)) (unary emit-br-if-vector a))
(emit-struct-set! asm (slot struct) (slot index) (slot value))) (($ $primcall 'string? (a)) (unary emit-br-if-string a))
(($ $primcall 'vector-set! (vector index value)) (($ $primcall 'bytevector? (a)) (unary emit-br-if-bytevector a))
(call-with-values (lambda () ;; Add more TC7 tests here. Keep in sync with
(lookup-maybe-constant-value index allocation)) ;; *branching-primcall-arities* in (language cps primitives) and
(lambda (has-const? index-val) ;; the set of macro-instructions in assembly.scm.
(if (and has-const? (integer? index-val) (exact? index-val) (($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b))
(<= 0 index-val 255)) (($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b))
(emit-constant-vector-set! asm (slot vector) index-val (($ $primcall 'equal? (a b)) (binary emit-br-if-equal a b))
(slot value)) (($ $primcall '< (a b)) (binary emit-br-if-< a b))
(emit-vector-set! asm (slot vector) (slot index) (($ $primcall '<= (a b)) (binary emit-br-if-<= a b))
(slot value)))))) (($ $primcall '= (a b)) (binary emit-br-if-= a b))
(($ $primcall 'variable-set! (var val)) (($ $primcall '>= (a b)) (binary emit-br-if-<= b a))
(emit-box-set! asm (slot var) (slot val))) (($ $primcall '> (a b)) (binary emit-br-if-< b a))))
(($ $primcall 'set-car! (pair value))
(emit-set-car! asm (slot pair) (slot value)))
(($ $primcall 'set-cdr! (pair value))
(emit-set-cdr! asm (slot pair) (slot value)))
(($ $primcall 'define! (sym value))
(emit-define! asm (slot sym) (slot value)))
(($ $primcall 'push-fluid (fluid val))
(emit-push-fluid asm (slot fluid) (slot val)))
(($ $primcall 'pop-fluid ())
(emit-pop-fluid asm))
(($ $primcall 'wind (winder unwinder))
(emit-wind asm (slot winder) (slot unwinder)))
(($ $primcall 'bv-u8-set! (bv idx val))
(emit-bv-u8-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'bv-u16-set! (bv idx val))
(emit-bv-u16-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'bv-s16-set! (bv idx val))
(emit-bv-s16-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'bv-u32-set! (bv idx val))
(emit-bv-u32-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'bv-s32-set! (bv idx val))
(emit-bv-s32-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'bv-u64-set! (bv idx val))
(emit-bv-u64-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'bv-s64-set! (bv idx val))
(emit-bv-s64-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'bv-f32-set! (bv idx val))
(emit-bv-f32-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'bv-f64-set! (bv idx val))
(emit-bv-f64-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'unwind ())
(emit-unwind asm))))
(define (compile-values label exp syms) (define (compile-trunc label exp nreq rest? nlocals)
(match exp (match exp
(($ $values args) (($ $call proc args)
(for-each (match-lambda (let ((proc-slot (lookup-call-proc-slot label allocation))
((src . dst) (emit-mov asm dst src))) (nargs (length args)))
(lookup-parallel-moves label allocation)) (or (maybe-load-constant proc-slot proc)
(for-each maybe-load-constant (map slot syms) args)))) (maybe-mov proc-slot (slot proc)))
(let lp ((n (1+ proc-slot)) (args args))
(match args
(()
(emit-call asm proc-slot (+ nargs 1))
;; FIXME: Only allow more values if there is a rest arg.
;; Express values truncation by the presence of an
;; unused rest arg instead of implicitly.
(emit-receive-values asm proc-slot #t nreq)
(when rest?
(emit-bind-rest asm (+ proc-slot 1 nreq)))
(for-each (match-lambda
((src . dst) (emit-mov asm dst src)))
(lookup-parallel-moves label allocation))
(emit-reset-frame asm nlocals))
((arg . args)
(or (maybe-load-constant n arg)
(maybe-mov n (slot arg)))
(lp (1+ n) args))))))))
(define (compile-test label exp kt kf next-label) (match f
(define (unary op sym) (($ $fun src meta free ($ $cont k ($ $kentry self tail clauses)))
(cond ;; FIXME: src on kentry instead?
((eq? kt next-label) (when src
(op asm (slot sym) #t kf)) (emit-source asm src))
(else (compile-entry (or meta '()))))))
(op asm (slot sym) #f kt)
(unless (eq? kf next-label)
(emit-br asm kf)))))
(define (binary op a b)
(cond
((eq? kt next-label)
(op asm (slot a) (slot b) #t kf))
(else
(op asm (slot a) (slot b) #f kt)
(unless (eq? kf next-label)
(emit-br asm kf)))))
(match exp
(($ $var sym) (unary emit-br-if-true sym))
(($ $primcall 'null? (a)) (unary emit-br-if-null a))
(($ $primcall 'nil? (a)) (unary emit-br-if-nil a))
(($ $primcall 'pair? (a)) (unary emit-br-if-pair a))
(($ $primcall 'struct? (a)) (unary emit-br-if-struct a))
(($ $primcall 'char? (a)) (unary emit-br-if-char a))
(($ $primcall 'symbol? (a)) (unary emit-br-if-symbol a))
(($ $primcall 'variable? (a)) (unary emit-br-if-variable a))
(($ $primcall 'vector? (a)) (unary emit-br-if-vector a))
(($ $primcall 'string? (a)) (unary emit-br-if-string a))
(($ $primcall 'bytevector? (a)) (unary emit-br-if-bytevector a))
;; Add more TC7 tests here. Keep in sync with
;; *branching-primcall-arities* in (language cps primitives) and
;; the set of macro-instructions in assembly.scm.
(($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b))
(($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b))
(($ $primcall 'equal? (a b)) (binary emit-br-if-equal a b))
(($ $primcall '< (a b)) (binary emit-br-if-< a b))
(($ $primcall '<= (a b)) (binary emit-br-if-<= a b))
(($ $primcall '= (a b)) (binary emit-br-if-= a b))
(($ $primcall '>= (a b)) (binary emit-br-if-<= b a))
(($ $primcall '> (a b)) (binary emit-br-if-< b a))))
(define (compile-trunc label exp nreq rest? nlocals)
(match exp
(($ $call proc args)
(let ((proc-slot (lookup-call-proc-slot label allocation))
(nargs (length args)))
(or (maybe-load-constant proc-slot proc)
(maybe-mov proc-slot (slot proc)))
(let lp ((n (1+ proc-slot)) (args args))
(match args
(()
(emit-call asm proc-slot (+ nargs 1))
;; FIXME: Only allow more values if there is a rest arg.
;; Express values truncation by the presence of an
;; unused rest arg instead of implicitly.
(emit-receive-values asm proc-slot #t nreq)
(when rest?
(emit-bind-rest asm (+ proc-slot 1 nreq)))
(for-each (match-lambda
((src . dst) (emit-mov asm dst src)))
(lookup-parallel-moves label allocation))
(emit-reset-frame asm nlocals))
((arg . args)
(or (maybe-load-constant n arg)
(maybe-mov n (slot arg)))
(lp (1+ n) args))))))))
(match f
(($ $fun meta free ($ $cont k src ($ $kentry self tail clauses)))
(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 meta free body) (($ $fun src meta free body)
(proc exp) (proc exp)
(visit-funs proc body)) (visit-funs proc body))
@ -490,13 +482,13 @@
(visit-funs proc body) (visit-funs proc body)
(for-each (lambda (cont) (visit-funs proc cont)) conts)) (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)) (visit-funs proc body))
(($ $cont sym src ($ $kclause arity body)) (($ $cont sym ($ $kclause arity body))
(visit-funs proc 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)) (for-each (lambda (clause) (visit-funs proc clause)) clauses))
(_ (values)))) (_ (values))))

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

@ -32,12 +32,12 @@
(define (inline-constructors fun) (define (inline-constructors fun)
(define (visit-cont cont) (define (visit-cont cont)
(rewrite-cps-cont cont (rewrite-cps-cont cont
(($ $cont sym src ($ $kargs names syms body)) (($ $cont sym ($ $kargs names syms body))
(sym src ($kargs names syms ,(visit-term body)))) (sym ($kargs names syms ,(visit-term body))))
(($ $cont sym src ($ $kentry self tail clauses)) (($ $cont sym ($ $kentry self tail clauses))
(sym src ($kentry self ,tail ,(map visit-cont clauses)))) (sym ($kentry self ,tail ,(map visit-cont clauses))))
(($ $cont sym src ($ $kclause arity body)) (($ $cont sym ($ $kclause arity body))
(sym src ($kclause ,arity ,(visit-cont body)))) (sym ($kclause ,arity ,(visit-cont body))))
(($ $cont) (($ $cont)
,cont))) ,cont)))
(define (visit-term term) (define (visit-term term)
@ -48,51 +48,51 @@
(($ $letrec names syms funs body) (($ $letrec names syms funs body)
($letrec names syms (map inline-constructors funs) ($letrec names syms (map inline-constructors funs)
,(visit-term body))) ,(visit-term body)))
(($ $continue k ($ $primcall 'list args)) (($ $continue k src ($ $primcall 'list args))
,(let-gensyms (kvalues val) ,(let-gensyms (kvalues val)
(build-cps-term (build-cps-term
($letk ((kvalues #f ($kargs ('val) (val) ($letk ((kvalues ($kargs ('val) (val)
($continue k ($continue k src
($primcall 'values (val)))))) ($primcall 'values (val))))))
,(let lp ((args args) (k kvalues)) ,(let lp ((args args) (k kvalues))
(match args (match args
(() (()
(build-cps-term (build-cps-term
($continue k ($const '())))) ($continue k src ($const '()))))
((arg . args) ((arg . args)
(let-gensyms (ktail tail) (let-gensyms (ktail tail)
(build-cps-term (build-cps-term
($letk ((ktail #f ($kargs ('tail) (tail) ($letk ((ktail ($kargs ('tail) (tail)
($continue k ($continue k src
($primcall 'cons (arg tail)))))) ($primcall 'cons (arg tail))))))
,(lp args ktail))))))))))) ,(lp args ktail)))))))))))
(($ $continue k ($ $primcall 'vector args)) (($ $continue k src ($ $primcall 'vector args))
,(let-gensyms (kalloc vec len init) ,(let-gensyms (kalloc vec len init)
(define (initialize args n) (define (initialize args n)
(match args (match args
(() (()
(build-cps-term (build-cps-term
($continue k ($primcall 'values (vec))))) ($continue k src ($primcall 'values (vec)))))
((arg . args) ((arg . args)
(let-gensyms (knext idx) (let-gensyms (knext idx)
(build-cps-term (build-cps-term
($letk ((knext #f ($kargs () () ($letk ((knext ($kargs () ()
,(initialize args (1+ n))))) ,(initialize args (1+ n)))))
($letconst (('idx idx n)) ($letconst (('idx idx n))
($continue knext ($continue knext src
($primcall 'vector-set! (vec idx arg)))))))))) ($primcall 'vector-set! (vec idx arg))))))))))
(build-cps-term (build-cps-term
($letk ((kalloc #f ($kargs ('vec) (vec) ($letk ((kalloc ($kargs ('vec) (vec)
,(initialize args 0)))) ,(initialize args 0))))
($letconst (('len len (length args)) ($letconst (('len len (length args))
('init init #f)) ('init init #f))
($continue kalloc ($continue kalloc src
($primcall 'make-vector (len init)))))))) ($primcall 'make-vector (len init))))))))
(($ $continue k (and fun ($ $fun))) (($ $continue k src (and fun ($ $fun)))
($continue k ,(inline-constructors fun))) ($continue k src ,(inline-constructors fun)))
(($ $continue) (($ $continue)
,term))) ,term)))
(rewrite-cps-exp fun (rewrite-cps-exp fun
(($ $fun meta free body) (($ $fun src meta free body)
($fun meta free ,(visit-cont body))))) ($fun src meta free ,(visit-cont body)))))

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

@ -95,7 +95,7 @@
;; target continuation. Otherwise return #f. ;; target continuation. Otherwise return #f.
(define (call-target use proc) (define (call-target use proc)
(match (find-call (lookup-cont use cont-table)) (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) (and (eq? proc proc*) (not (memq proc args)) (applicable? proc args)
k)) k))
(_ #f))) (_ #f)))
@ -141,7 +141,7 @@
;; bail. ;; bail.
(($ $kentry self tail clauses) (($ $kentry self tail clauses)
(match clauses (match clauses
((($ $cont _ _ ($ $kclause arity ($ $cont kargs)))) ((($ $cont _ ($ $kclause arity ($ $cont kargs))))
kargs) kargs)
(_ #f))) (_ #f)))
(_ scope))))) (_ scope)))))
@ -168,15 +168,15 @@
(define (visit-fun term) (define (visit-fun term)
(match term (match term
(($ $fun meta free body) (($ $fun src meta free body)
(visit-cont body)))) (visit-cont body))))
(define (visit-cont cont) (define (visit-cont cont)
(match cont (match cont
(($ $cont sym src ($ $kargs _ _ body)) (($ $cont sym ($ $kargs _ _ body))
(visit-term body sym)) (visit-term body sym))
(($ $cont sym src ($ $kentry self tail clauses)) (($ $cont sym ($ $kentry self tail clauses))
(for-each visit-cont clauses)) (for-each visit-cont clauses))
(($ $cont sym src ($ $kclause arity body)) (($ $cont sym ($ $kclause arity body))
(visit-cont body)) (visit-cont body))
(($ $cont) (($ $cont)
#t))) #t)))
@ -199,7 +199,7 @@
(if (null? rec) (if (null? rec)
'() '()
(list rec))) (list rec)))
(((and elt (n s ($ $fun meta free ($ $cont kentry)))) (((and elt (n s ($ $fun src meta free ($ $cont kentry))))
. nsf) . nsf)
(if (recursive? kentry) (if (recursive? kentry)
(lp nsf (cons elt rec)) (lp nsf (cons elt rec))
@ -208,11 +208,11 @@
(match component (match component
(((name sym fun) ...) (((name sym fun) ...)
(match fun (match fun
((($ $fun meta free ((($ $fun src meta free
($ $cont fun-k _ ($ $cont fun-k
($ $kentry self ($ $kentry self
($ $cont tail-k _ ($ $ktail)) ($ $cont tail-k ($ $ktail))
(($ $cont _ _ ($ $kclause arity body)) (($ $cont _ ($ $kclause arity body))
...)))) ...))))
...) ...)
(unless (contify-funs term-k sym self tail-k arity body) (unless (contify-funs term-k sym self tail-k arity body)
@ -220,13 +220,13 @@
(visit-term body term-k) (visit-term body term-k)
(for-each visit-component (for-each visit-component
(split-components (map list names syms funs)))) (split-components (map list names syms funs))))
(($ $continue k exp) (($ $continue k src exp)
(match exp (match exp
(($ $fun meta free (($ $fun src meta free
($ $cont fun-k _ ($ $cont fun-k
($ $kentry self ($ $kentry self
($ $cont tail-k _ ($ $ktail)) ($ $cont tail-k ($ $ktail))
(($ $cont _ _ ($ $kclause arity body)) ...)))) (($ $cont _ ($ $kclause arity body)) ...))))
(if (and=> (bound-symbol k) (if (and=> (bound-symbol k)
(lambda (sym) (lambda (sym)
(contify-fun term-k sym self tail-k arity body))) (contify-fun term-k sym self tail-k arity body)))
@ -238,7 +238,7 @@
(values call-substs cont-substs fun-elisions cont-splices))) (values call-substs cont-substs fun-elisions cont-splices)))
(define (apply-contification fun 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) (and=> (assq-ref call-substs proc)
(lambda (clauses) (lambda (clauses)
(let lp ((clauses clauses)) (let lp ((clauses clauses))
@ -247,11 +247,11 @@
(((($ $arity req () #f () #f) . k) . clauses) (((($ $arity req () #f () #f) . k) . clauses)
(if (= (length req) (length args)) (if (= (length req) (length args))
(build-cps-term (build-cps-term
($continue k ($continue k src
($values args))) ($values args)))
(lp clauses))) (lp clauses)))
((_ . clauses) (lp clauses))))))) ((_ . clauses) (lp clauses)))))))
(define (continue k exp) (define (continue k src exp)
(define (lookup-return-cont k) (define (lookup-return-cont k)
(match (assq-ref cont-substs k) (match (assq-ref cont-substs k)
(#f k) (#f k)
@ -260,13 +260,13 @@
;; We are contifying this return. It must be a call or a ;; We are contifying this return. It must be a call or a
;; primcall to values, return, or return-values. ;; primcall to values, return, or return-values.
(if (eq? k k*) (if (eq? k k*)
(build-cps-term ($continue k ,exp)) (build-cps-term ($continue k src ,exp))
(rewrite-cps-term exp (rewrite-cps-term exp
(($ $primcall 'return (val)) (($ $primcall 'return (val))
($continue k* ($primcall 'values (val)))) ($continue k* src ($primcall 'values (val))))
(($ $values vals) (($ $values vals)
($continue k* ($primcall 'values vals))) ($continue k* src ($primcall 'values vals)))
(_ ($continue k* ,exp)))))) (_ ($continue k* src ,exp))))))
(define (splice-continuations term-k term) (define (splice-continuations term-k term)
(match (hashq-ref cont-splices term-k) (match (hashq-ref cont-splices term-k)
(#f term) (#f term)
@ -283,19 +283,19 @@
,body))))))) ,body)))))))
(define (visit-fun term) (define (visit-fun term)
(rewrite-cps-exp term (rewrite-cps-exp term
(($ $fun meta free body) (($ $fun src meta free body)
($fun meta free ,(visit-cont body))))) ($fun src meta 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)))
;; This cont gets inlined in place of the $fun. ;; This cont gets inlined in place of the $fun.
,#f) ,#f)
(($ $cont sym src ($ $kargs names syms body)) (($ $cont sym ($ $kargs names syms body))
(sym src ($kargs names syms ,(visit-term body sym)))) (sym ($kargs names syms ,(visit-term body sym))))
(($ $cont sym src ($ $kentry self tail clauses)) (($ $cont sym ($ $kentry self tail clauses))
(sym src ($kentry self ,tail ,(map visit-cont clauses)))) (sym ($kentry self ,tail ,(map visit-cont clauses))))
(($ $cont sym src ($ $kclause arity body)) (($ $cont sym ($ $kclause arity body))
(sym src ($kclause ,arity ,(visit-cont body)))) (sym ($kclause ,arity ,(visit-cont body))))
(($ $cont) (($ $cont)
,cont))) ,cont)))
(define (visit-term term term-k) (define (visit-term term term-k)
@ -324,7 +324,7 @@
(((names syms funs) ...) (((names syms funs) ...)
($letrec names syms (map visit-fun funs) ($letrec names syms (map visit-fun funs)
,(visit-term body term-k))))) ,(visit-term body term-k)))))
(($ $continue k exp) (($ $continue k src exp)
(splice-continuations (splice-continuations
term-k term-k
(match exp (match exp
@ -335,11 +335,11 @@
(($ $kargs (_) (_) body) (($ $kargs (_) (_) body)
(visit-term body k)))) (visit-term body k))))
(else (else
(continue k (visit-fun exp))))) (continue k src (visit-fun exp)))))
(($ $call proc args) (($ $call proc args)
(or (contify-call proc args) (or (contify-call src proc args)
(continue k exp))) (continue k src exp)))
(_ (continue k exp))))))) (_ (continue k src exp)))))))
(visit-fun fun)) (visit-fun fun))
(define (contify fun) (define (contify fun)

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

@ -73,14 +73,14 @@
print-dfa)) print-dfa))
(define (build-cont-table fun) (define (build-cont-table fun)
(fold-conts (lambda (k src cont table) (fold-conts (lambda (k cont table)
(hashq-set! table k cont) (hashq-set! table k cont)
table) table)
(make-hash-table) (make-hash-table)
fun)) fun))
(define (build-local-cont-table cont) (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) (hashq-set! table k cont)
table) table)
(make-hash-table) (make-hash-table)
@ -206,10 +206,10 @@
(reachable-preds k-map block-preds)))) (reachable-preds k-map block-preds))))
(make-cfa k-map order preds))) (make-cfa k-map order preds)))
(match fun (match fun
(($ $fun meta free (($ $fun src meta free
($ $cont kentry src ($ $cont kentry
(and entry (and entry
($ $kentry self ($ $cont ktail _ tail) clauses)))) ($ $kentry self ($ $cont ktail tail) clauses))))
(if reverse? (if reverse?
(build-cfa ktail block-preds block-succs) (build-cfa ktail block-preds block-succs)
(build-cfa kentry block-succs block-preds))))) (build-cfa kentry block-succs block-preds)))))
@ -549,13 +549,13 @@
(map (cut hashq-ref mapping <>) (map (cut hashq-ref mapping <>)
((block-accessor blocks accessor) k)))) ((block-accessor blocks accessor) k))))
(match fun (match fun
(($ $fun meta free (($ $fun src meta free
(and entry (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))) (call-with-values (lambda () (make-variable-mapping (dfg-use-maps dfg)))
(lambda (var-map nvars) (lambda (var-map nvars)
(define (fold-all-conts f seed) (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)) seed entry))
(let* ((blocks (dfg-blocks dfg)) (let* ((blocks (dfg-blocks dfg))
(order (reverse-post-order ktail (order (reverse-post-order ktail
@ -662,7 +662,7 @@
(define (recur exp) (define (recur exp)
(visit exp exp-k)) (visit exp exp-k))
(match exp (match exp
(($ $letk (($ $cont k src cont) ...) body) (($ $letk (($ $cont k cont) ...) body)
;; Set up recursive environment before visiting cont bodies. ;; Set up recursive environment before visiting cont bodies.
(for-each (lambda (cont k) (for-each (lambda (cont k)
(declare-block! k cont exp-k)) (declare-block! k cont exp-k))
@ -688,7 +688,7 @@
(for-each (cut visit-fun <> conts blocks use-maps global?) funs) (for-each (cut visit-fun <> conts blocks use-maps global?) funs)
(visit body exp-k)) (visit body exp-k))
(($ $continue k exp) (($ $continue k src exp)
(use-k! k) (use-k! k)
(match exp (match exp
(($ $var sym) (($ $var sym)
@ -726,10 +726,10 @@
(_ #f))))) (_ #f)))))
(match fun (match fun
(($ $fun meta free (($ $fun src meta free
($ $cont kentry src ($ $cont kentry
(and entry (and entry
($ $kentry self ($ $cont ktail _ tail) clauses)))) ($ $kentry self ($ $cont ktail tail) clauses))))
(declare-block! kentry entry #f 0) (declare-block! kentry entry #f 0)
(add-def! #f self kentry) (add-def! #f self kentry)
@ -737,8 +737,8 @@
(for-each (for-each
(match-lambda (match-lambda
(($ $cont kclause _ (($ $cont kclause
(and clause ($ $kclause arity ($ $cont kbody _ body)))) (and clause ($ $kclause arity ($ $cont kbody body))))
(declare-block! kclause clause kentry) (declare-block! kclause clause kentry)
(link-blocks! kentry kclause) (link-blocks! kentry kclause)
@ -811,7 +811,7 @@
(define (call-expression call) (define (call-expression call)
(match call (match call
(($ $continue k exp) exp))) (($ $continue k src exp) exp)))
(define (find-expression term) (define (find-expression term)
(call-expression (find-call term))) (call-expression (find-call term)))
@ -827,7 +827,7 @@
(match (find-defining-expression sym dfg) (match (find-defining-expression sym dfg)
(($ $const val) (($ $const val)
(values #t val)) (values #t val))
(($ $continue k ($ $void)) (($ $continue k src ($ $void))
(values #t *unspecified*)) (values #t *unspecified*))
(else (else
(values #f #f)))) (values #f #f))))

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

@ -37,15 +37,15 @@
(define (elide-values fun) (define (elide-values fun)
(let ((conts (build-local-cont-table (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) (define (visit-cont cont)
(rewrite-cps-cont cont (rewrite-cps-cont cont
(($ $cont sym src ($ $kargs names syms body)) (($ $cont sym ($ $kargs names syms body))
(sym src ($kargs names syms ,(visit-term body)))) (sym ($kargs names syms ,(visit-term body))))
(($ $cont sym src ($ $kentry self tail clauses)) (($ $cont sym ($ $kentry self tail clauses))
(sym src ($kentry self ,tail ,(map visit-cont clauses)))) (sym ($kentry self ,tail ,(map visit-cont clauses))))
(($ $cont sym src ($ $kclause arity body)) (($ $cont sym ($ $kclause arity body))
(sym src ($kclause ,arity ,(visit-cont body)))) (sym ($kclause ,arity ,(visit-cont body))))
(($ $cont) (($ $cont)
,cont))) ,cont)))
(define (visit-term term) (define (visit-term term)
@ -56,27 +56,27 @@
(($ $letrec names syms funs body) (($ $letrec names syms funs body)
($letrec names syms (map elide-values funs) ($letrec names syms (map elide-values funs)
,(visit-term body))) ,(visit-term body)))
(($ $continue k ($ $primcall 'values vals)) (($ $continue k src ($ $primcall 'values vals))
,(rewrite-cps-term (lookup-cont k conts) ,(rewrite-cps-term (lookup-cont k conts)
(($ $ktail) (($ $ktail)
($continue k ($values vals))) ($continue k src ($values vals)))
(($ $ktrunc ($ $arity req () rest () #f) kargs) (($ $ktrunc ($ $arity req () rest () #f) kargs)
,(if (or rest (< (length vals) (length req))) ,(if (or rest (< (length vals) (length req)))
term term
(let ((vals (list-head vals (length req)))) (let ((vals (list-head vals (length req))))
(build-cps-term (build-cps-term
($continue kargs ($values vals)))))) ($continue kargs src ($values vals))))))
(($ $kargs args) (($ $kargs args)
,(if (< (length vals) (length args)) ,(if (< (length vals) (length args))
term term
(let ((vals (list-head vals (length args)))) (let ((vals (list-head vals (length args))))
(build-cps-term (build-cps-term
($continue k ($values vals)))))))) ($continue k src ($values vals))))))))
(($ $continue k (and fun ($ $fun))) (($ $continue k src (and fun ($ $fun)))
($continue k ,(elide-values fun))) ($continue k src ,(elide-values fun)))
(($ $continue) (($ $continue)
,term))) ,term)))
(rewrite-cps-exp fun (rewrite-cps-exp fun
(($ $fun meta free body) (($ $fun src meta free body)
($fun meta free ,(visit-cont body)))))) ($fun src meta free ,(visit-cont body))))))

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

@ -39,8 +39,8 @@
('name name-sym name) ('name name-sym name)
('public? public?-sym public?) ('public? public?-sym public?)
('bound? bound?-sym bound?)) ('bound? bound?-sym bound?))
($letk ((kbox src ($kargs ('box) (box) ,(val-proc box)))) ($letk ((kbox ($kargs ('box) (box) ,(val-proc box))))
($continue kbox ($continue kbox src
($primcall 'cached-module-box ($primcall 'cached-module-box
(module-sym name-sym public?-sym bound?-sym)))))))) (module-sym name-sym public?-sym bound?-sym))))))))
@ -72,63 +72,61 @@
((class-of @slot-ref @slot-set!) '(oop goops)) ((class-of @slot-ref @slot-set!) '(oop goops))
(else '(guile)))) (else '(guile))))
(define (primitive-ref name k) (define (primitive-ref name k src)
(module-box #f (primitive-module name) name #f #t (module-box #f (primitive-module name) name #f #t
(lambda (box) (lambda (box)
(build-cps-term (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) (let-gensyms (idx-sym)
(build-cps-term (build-cps-term
($letconst (('idx idx-sym idx)) ($letconst (('idx idx-sym idx))
($continue k ($continue k src
($primcall 'builtin-ref (idx-sym))))))) ($primcall 'builtin-ref (idx-sym)))))))
(define (reify-clause ktail) (define (reify-clause ktail)
(let-gensyms (kclause kbody wna false str eol kthrow throw) (let-gensyms (kclause kbody wna false str eol kthrow throw)
(build-cps-cont (build-cps-cont
(kclause #f ($kclause ('() '() #f '() #f) (kclause ($kclause ('() '() #f '() #f)
(kbody (kbody
#f ($kargs () ()
($kargs () () ($letconst (('wna wna 'wrong-number-of-args)
($letconst (('wna wna 'wrong-number-of-args) ('false false #f)
('false false #f) ('str str "Wrong number of arguments")
('str str "Wrong number of arguments") ('eol eol '()))
('eol eol '())) ($letk ((kthrow
($letk ((kthrow ($kargs ('throw) (throw)
#f ($continue ktail #f
($kargs ('throw) (throw) ($call throw
($continue ktail (wna false str eol false))))))
($call throw ,(primitive-ref 'throw kthrow #f))))))))))
(wna false str eol false))))))
,(primitive-ref 'throw kthrow))))))))))
;; FIXME: Operate on one function at a time, for efficiency. ;; FIXME: Operate on one function at a time, for efficiency.
(define (reify-primitives fun) (define (reify-primitives fun)
(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 meta free body) (($ $fun src meta free body)
($fun meta free ,(visit-cont body))))) ($fun src meta free ,(visit-cont body)))))
(define (visit-cont cont) (define (visit-cont cont)
(rewrite-cps-cont cont (rewrite-cps-cont cont
(($ $cont sym src ($ $kargs names syms body)) (($ $cont sym ($ $kargs names syms body))
(sym src ($kargs names syms ,(visit-term body)))) (sym ($kargs names syms ,(visit-term body))))
(($ $cont sym src ($ $kentry self (and tail ($ $cont ktail)) ())) (($ $cont sym ($ $kentry self (and tail ($ $cont ktail)) ()))
;; A case-lambda with no clauses. Reify a clause. ;; A case-lambda with no clauses. Reify a clause.
(sym src ($kentry self ,tail (,(reify-clause ktail))))) (sym ($kentry self ,tail (,(reify-clause ktail)))))
(($ $cont sym src ($ $kentry self tail clauses)) (($ $cont sym ($ $kentry self tail clauses))
(sym src ($kentry self ,tail ,(map visit-cont clauses)))) (sym ($kentry self ,tail ,(map visit-cont clauses))))
(($ $cont sym src ($ $kclause arity body)) (($ $cont sym ($ $kclause arity body))
(sym src ($kclause ,arity ,(visit-cont body)))) (sym ($kclause ,arity ,(visit-cont body))))
(($ $cont) (($ $cont)
,cont))) ,cont)))
(define (visit-term term) (define (visit-term term)
(rewrite-cps-term term (rewrite-cps-term term
(($ $letk conts body) (($ $letk conts body)
($letk ,(map visit-cont conts) ,(visit-term body))) ($letk ,(map visit-cont conts) ,(visit-term body)))
(($ $continue k exp) (($ $continue k src exp)
,(match exp ,(match exp
(($ $prim name) (($ $prim name)
(match (lookup-cont k conts) (match (lookup-cont k conts)
@ -136,14 +134,14 @@
(cond (cond
((builtin-name->index name) ((builtin-name->index name)
=> (lambda (idx) => (lambda (idx)
(builtin-ref idx k))) (builtin-ref idx k src)))
(else (primitive-ref name k)))) (else (primitive-ref name k src))))
(_ (build-cps-term ($continue k ($void)))))) (_ (build-cps-term ($continue k src ($void))))))
(($ $fun) (($ $fun)
(build-cps-term ($continue k ,(visit-fun exp)))) (build-cps-term ($continue k src ,(visit-fun exp))))
(($ $primcall 'call-thunk/no-inline (proc)) (($ $primcall 'call-thunk/no-inline (proc))
(build-cps-term (build-cps-term
($continue k ($call proc ())))) ($continue k src ($call proc ()))))
(($ $primcall name args) (($ $primcall name args)
(cond (cond
((or (prim-rtl-instruction name) (branching-primitive? name)) ((or (prim-rtl-instruction name) (branching-primitive? name))
@ -152,13 +150,13 @@
(else (else
(let-gensyms (k* v) (let-gensyms (k* v)
(build-cps-term (build-cps-term
($letk ((k* #f ($kargs (v) (v) ($letk ((k* ($kargs (v) (v)
($continue k ($call v args))))) ($continue k src ($call v args)))))
,(cond ,(cond
((builtin-name->index name) ((builtin-name->index name)
=> (lambda (idx) => (lambda (idx)
(builtin-ref idx k*))) (builtin-ref idx k* src)))
(else (primitive-ref name k*))))))))) (else (primitive-ref name k* src)))))))))
(_ term))))) (_ term)))))
(visit-fun fun))) (visit-fun fun)))

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

@ -235,7 +235,7 @@ are comparable with eqv?. A tmp slot may be used."
(define nlocals (compute-slot live-slots #f)) (define nlocals (compute-slot live-slots #f))
(define nargs (define nargs
(match clause (match clause
(($ $cont _ _ ($ $kclause _ ($ $cont _ _ ($ $kargs names syms)))) (($ $cont _ ($ $kclause _ ($ $cont _ ($ $kargs names syms))))
(length syms)))) (length syms))))
(define (allocate! sym k hint live-slots) (define (allocate! sym k hint live-slots)
@ -310,7 +310,7 @@ are comparable with eqv?. A tmp slot may be used."
live-slots)) live-slots))
(match cont (match cont
(($ $kclause arity ($ $cont k src body)) (($ $kclause arity ($ $cont k body))
(visit-cont body k live-slots)) (visit-cont body k live-slots))
(($ $kargs names syms body) (($ $kargs names syms body)
@ -328,12 +328,12 @@ are comparable with eqv?. A tmp slot may be used."
(($ $letk conts body) (($ $letk conts body)
(let ((live-slots (visit-term body label live-slots))) (let ((live-slots (visit-term body label live-slots)))
(for-each (match-lambda (for-each (match-lambda
(($ $cont k src cont) (($ $cont k cont)
(visit-cont cont k live-slots))) (visit-cont cont k live-slots)))
conts)) conts))
live-slots) live-slots)
(($ $continue k exp) (($ $continue k src exp)
(visit-exp exp label k live-slots)))) (visit-exp exp label k live-slots))))
(define (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))) (_ live-slots)))
(match clause (match clause
(($ $cont k _ body) (($ $cont k body)
(visit-cont body k live-slots) (visit-cont body k live-slots)
(hashq-set! allocation k nlocals)))) (hashq-set! allocation k nlocals))))
(match fun (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)) (let* ((dfa (compute-live-variables fun dfg))
(allocation (make-hash-table)) (allocation (make-hash-table))
(slots (make-vector (dfa-var-count dfa) #f)) (slots (make-vector (dfa-var-count dfa) #f))

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

@ -71,7 +71,7 @@
(define (visit-clause clause k-env v-env) (define (visit-clause clause k-env v-env)
(match clause (match clause
(($ $cont kclause src* (($ $cont kclause
($ $kclause ($ $kclause
($ $arity ($ $arity
((? symbol? req) ...) ((? symbol? req) ...)
@ -79,9 +79,7 @@
(and rest (or #f (? symbol?))) (and rest (or #f (? symbol?)))
(((? keyword? kw) (? symbol? kwname) (? symbol? kwsym)) ...) (((? keyword? kw) (? symbol? kwname) (? symbol? kwsym)) ...)
(or #f #t)) (or #f #t))
($ $cont kbody src (and body ($ $kargs names syms _))))) ($ $cont kbody (and body ($ $kargs names syms _)))))
(check-src src*)
(check-src src)
(for-each (lambda (sym) (for-each (lambda (sym)
(unless (memq sym syms) (unless (memq sym syms)
(error "bad keyword sym" sym))) (error "bad keyword sym" sym)))
@ -98,9 +96,9 @@
(define (visit-fun fun k-env v-env) (define (visit-fun fun k-env v-env)
(match fun (match fun
(($ $fun meta ((? symbol? free) ...) (($ $fun src meta ((? symbol? free) ...)
($ $cont kbody src ($ $cont kbody
($ $kentry (? symbol? self) ($ $cont ktail _ ($ $ktail)) clauses))) ($ $kentry (? symbol? self) ($ $cont ktail ($ $ktail)) clauses)))
(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)
@ -142,9 +140,8 @@
(define (visit-term term k-env v-env) (define (visit-term term k-env v-env)
(match term (match term
(($ $letk (($ $cont (? symbol? k) src cont) ...) body) (($ $letk (($ $cont (? symbol? k) cont) ...) body)
(let ((k-env (add-env k k-env))) (let ((k-env (add-env k k-env)))
(for-each check-src src)
(for-each (cut visit-cont-body <> k-env v-env) cont) (for-each (cut visit-cont-body <> k-env v-env) cont)
(visit-term body k-env v-env))) (visit-term body k-env v-env)))
@ -155,8 +152,9 @@
(for-each (cut visit-fun <> k-env v-env) fun) (for-each (cut visit-fun <> k-env v-env) fun)
(visit-term body k-env v-env))) (visit-term body k-env v-env)))
(($ $continue k exp) (($ $continue k src exp)
(check-var k k-env) (check-var k k-env)
(check-src src)
(visit-expression exp k-env v-env)) (visit-expression exp k-env v-env))
(_ (_

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

@ -81,18 +81,18 @@
(build-cps-term (build-cps-term
($letconst (('name name-sym name) ($letconst (('name name-sym name)
('bound? bound?-sym bound?)) ('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) ,(match (current-topbox-scope)
(#f (#f
(build-cps-term (build-cps-term
($continue kbox ($continue kbox src
($primcall 'resolve ($primcall 'resolve
(name-sym bound?-sym))))) (name-sym bound?-sym)))))
(scope (scope
(let-gensyms (scope-sym) (let-gensyms (scope-sym)
(build-cps-term (build-cps-term
($letconst (('scope scope-sym scope)) ($letconst (('scope scope-sym scope))
($continue kbox ($continue kbox src
($primcall 'cached-toplevel-box ($primcall 'cached-toplevel-box
(scope-sym name-sym bound?-sym))))))))))))) (scope-sym name-sym bound?-sym)))))))))))))
@ -103,8 +103,8 @@
('name name-sym name) ('name name-sym name)
('public? public?-sym public?) ('public? public?-sym public?)
('bound? bound?-sym bound?)) ('bound? bound?-sym bound?))
($letk ((kbox src ($kargs ('box) (box) ,(val-proc box)))) ($letk ((kbox ($kargs ('box) (box) ,(val-proc box))))
($continue kbox ($continue kbox src
($primcall 'cached-module-box ($primcall 'cached-module-box
(module-sym name-sym public?-sym bound?-sym)))))))) (module-sym name-sym public?-sym bound?-sym))))))))
@ -112,11 +112,11 @@
(let-gensyms (module scope-sym kmodule) (let-gensyms (module scope-sym kmodule)
(build-cps-term (build-cps-term
($letconst (('scope scope-sym scope)) ($letconst (('scope scope-sym scope))
($letk ((kmodule src ($kargs ('module) (module) ($letk ((kmodule ($kargs ('module) (module)
($continue k ($continue k src
($primcall 'cache-current-module! ($primcall 'cache-current-module!
(module scope-sym)))))) (module scope-sym))))))
($continue kmodule ($continue kmodule src
($primcall 'current-module ()))))))) ($primcall 'current-module ())))))))
(define (fold-formals proc seed arity gensyms inits) (define (fold-formals proc seed arity gensyms inits)
@ -162,8 +162,8 @@
(let-gensyms (unbound ktest) (let-gensyms (unbound ktest)
(build-cps-term (build-cps-term
($letconst (('unbound unbound (pointer->scm (make-pointer unbound-bits)))) ($letconst (('unbound unbound (pointer->scm (make-pointer unbound-bits))))
($letk ((ktest src ($kif kt kf))) ($letk ((ktest ($kif kt kf)))
($continue ktest ($continue ktest src
($primcall 'eq? (sym unbound)))))))) ($primcall 'eq? (sym unbound))))))))
(define (init-default-value name sym subst init body) (define (init-default-value name sym subst init body)
@ -174,19 +174,19 @@
(if box? (if box?
(let-gensyms (kbox phi) (let-gensyms (kbox phi)
(build-cps-term (build-cps-term
($letk ((kbox src ($kargs (name) (phi) ($letk ((kbox ($kargs (name) (phi)
($continue k ($primcall 'box (phi)))))) ($continue k src ($primcall 'box (phi))))))
,(make-body kbox)))) ,(make-body kbox))))
(make-body k))) (make-body k)))
(let-gensyms (knext kbound kunbound) (let-gensyms (knext kbound kunbound)
(build-cps-term (build-cps-term
($letk ((knext src ($kargs (name) (subst-sym) ,body))) ($letk ((knext ($kargs (name) (subst-sym) ,body)))
,(maybe-box ,(maybe-box
knext knext
(lambda (k) (lambda (k)
(build-cps-term (build-cps-term
($letk ((kbound src ($kargs () () ($continue k ($var sym)))) ($letk ((kbound ($kargs () () ($continue k src ($var sym))))
(kunbound src ($kargs () () ,(convert init k subst)))) (kunbound ($kargs () () ,(convert init k subst))))
,(unbound? src sym kunbound kbound)))))))))))) ,(unbound? src sym kunbound kbound))))))))))))
;; exp k-name alist -> term ;; exp k-name alist -> term
@ -199,16 +199,15 @@
((box #t) ((box #t)
(let-gensyms (kunboxed unboxed) (let-gensyms (kunboxed unboxed)
(build-cps-term (build-cps-term
($letk ((kunboxed src ($kargs ('unboxed) (unboxed) ,(k unboxed)))) ($letk ((kunboxed ($kargs ('unboxed) (unboxed) ,(k unboxed))))
($continue kunboxed ($primcall 'box-ref (box))))))) ($continue kunboxed src ($primcall 'box-ref (box)))))))
((subst #f) (k subst)) ((subst #f) (k subst))
(#f (k sym)))) (#f (k sym))))
(else (else
(let ((src (tree-il-src exp))) (let-gensyms (karg arg)
(let-gensyms (karg arg) (build-cps-term
(build-cps-term ($letk ((karg ($kargs ('arg) (arg) ,(k arg))))
($letk ((karg src ($kargs ('arg) (arg) ,(k arg)))) ,(convert exp karg subst)))))))
,(convert exp karg subst))))))))
;; (exp ...) ((v-name ...) -> term) -> term ;; (exp ...) ((v-name ...) -> term) -> term
(define (convert-args exps k) (define (convert-args exps k)
(match exps (match exps
@ -224,25 +223,25 @@
((box #t) ((box #t)
(let-gensyms (k) (let-gensyms (k)
(build-cps-term (build-cps-term
($letk ((k #f ($kargs (name) (box) ,body))) ($letk ((k ($kargs (name) (box) ,body)))
($continue k ($primcall 'box (sym))))))) ($continue k #f ($primcall 'box (sym)))))))
(else body))) (else body)))
(match exp (match exp
(($ <lexical-ref> src name sym) (($ <lexical-ref> src name sym)
(match (assq-ref subst sym) (match (assq-ref subst sym)
((box #t) (build-cps-term ($continue k ($primcall 'box-ref (box))))) ((box #t) (build-cps-term ($continue k src ($primcall 'box-ref (box)))))
((subst #f) (build-cps-term ($continue k ($var subst)))) ((subst #f) (build-cps-term ($continue k src ($var subst))))
(#f (build-cps-term ($continue k ($var sym)))))) (#f (build-cps-term ($continue k src ($var sym))))))
(($ <void> src) (($ <void> src)
(build-cps-term ($continue k ($void)))) (build-cps-term ($continue k src ($void))))
(($ <const> src exp) (($ <const> src exp)
(build-cps-term ($continue k ($const exp)))) (build-cps-term ($continue k src ($const exp))))
(($ <primitive-ref> src name) (($ <primitive-ref> src name)
(build-cps-term ($continue k ($prim name)))) (build-cps-term ($continue k src ($prim name))))
(($ <lambda> fun-src meta body) (($ <lambda> fun-src meta body)
(let () (let ()
@ -260,10 +259,8 @@
(let-gensyms (kclause kargs) (let-gensyms (kclause kargs)
(build-cps-cont (build-cps-cont
(kclause (kclause
src
($kclause ,arity ($kclause ,arity
(kargs (kargs
src
($kargs names gensyms ($kargs names gensyms
,(fold-formals ,(fold-formals
(lambda (name sym init body) (lambda (name sym init body)
@ -276,15 +273,13 @@
(if (current-topbox-scope) (if (current-topbox-scope)
(let-gensyms (kentry self ktail) (let-gensyms (kentry self ktail)
(build-cps-term (build-cps-term
($continue k ($continue k fun-src
($fun meta '() ($fun fun-src meta '()
(kentry fun-src (kentry ($kentry self (ktail ($ktail))
($kentry self (ktail #f ($ktail)) ,(convert-clauses body ktail)))))))
,(convert-clauses body ktail)))))))
(let-gensyms (scope kscope) (let-gensyms (scope kscope)
(build-cps-term (build-cps-term
($letk ((kscope fun-src ($letk ((kscope ($kargs () ()
($kargs () ()
,(parameterize ((current-topbox-scope scope)) ,(parameterize ((current-topbox-scope scope))
(convert exp k subst))))) (convert exp k subst)))))
,(capture-toplevel-scope fun-src scope kscope))))))) ,(capture-toplevel-scope fun-src scope kscope)))))))
@ -293,7 +288,7 @@
(module-box (module-box
src mod name public? #t src mod name public? #t
(lambda (box) (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) (($ <module-set> src mod name public? exp)
(convert-arg exp (convert-arg exp
@ -301,13 +296,14 @@
(module-box (module-box
src mod name public? #f src mod name public? #f
(lambda (box) (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-ref> src name)
(toplevel-box (toplevel-box
src name #t src name #t
(lambda (box) (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) (($ <toplevel-set> src name exp)
(convert-arg exp (convert-arg exp
@ -315,7 +311,8 @@
(toplevel-box (toplevel-box
src name #f src name #f
(lambda (box) (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) (($ <toplevel-define> src name exp)
(convert-arg exp (convert-arg exp
@ -323,13 +320,13 @@
(let-gensyms (kname name-sym) (let-gensyms (kname name-sym)
(build-cps-term (build-cps-term
($letconst (('name name-sym name)) ($letconst (('name name-sym name))
($continue k ($primcall 'define! (name-sym val))))))))) ($continue k src ($primcall 'define! (name-sym val)))))))))
(($ <call> src proc args) (($ <call> src proc args)
(convert-args (cons proc args) (convert-args (cons proc args)
(match-lambda (match-lambda
((proc . args) ((proc . args)
(build-cps-term ($continue k ($call proc args))))))) (build-cps-term ($continue k src ($call proc args)))))))
(($ <primcall> src name args) (($ <primcall> src name args)
(cond (cond
@ -389,22 +386,21 @@
(match args (match args
(() (()
(build-cps-term (build-cps-term
($continue k ($const '())))) ($continue k src ($const '()))))
((arg . args) ((arg . args)
(let-gensyms (ktail tail) (let-gensyms (ktail tail)
(build-cps-term (build-cps-term
($letk ((ktail src ($letk ((ktail ($kargs ('tail) (tail)
($kargs ('tail) (tail)
,(convert-arg arg ,(convert-arg arg
(lambda (head) (lambda (head)
(build-cps-term (build-cps-term
($continue k ($continue k src
($primcall 'cons (head tail))))))))) ($primcall 'cons (head tail)))))))))
,(lp args ktail)))))))) ,(lp args ktail))))))))
(else (else
(convert-args args (convert-args args
(lambda (args) (lambda (args)
(build-cps-term ($continue k ($primcall name args)))))))) (build-cps-term ($continue k src ($primcall name args))))))))
;; Prompts with inline handlers. ;; Prompts with inline handlers.
(($ <prompt> src escape-only? tag body (($ <prompt> src escape-only? tag body
@ -427,42 +423,38 @@
(let ((hnames (append hreq (if hrest (list hrest) '())))) (let ((hnames (append hreq (if hrest (list hrest) '()))))
(let-gensyms (khargs khbody kret kprim prim kpop krest vals kbody) (let-gensyms (khargs khbody kret kprim prim kpop krest vals kbody)
(build-cps-term (build-cps-term
($letk* ((khbody hsrc ($kargs hnames hsyms ;; FIXME: Attach hsrc to $ktrunc.
,(fold box-bound-var ($letk* ((khbody ($kargs hnames hsyms
(convert hbody k subst) ,(fold box-bound-var
hnames hsyms))) (convert hbody k subst)
(khargs hsrc ($ktrunc hreq hrest khbody)) hnames hsyms)))
(kpop src (khargs ($ktrunc hreq hrest khbody))
($kargs ('rest) (vals) (kpop ($kargs ('rest) (vals)
($letk ((kret ($letk ((kret
src
($kargs () () ($kargs () ()
($letk ((kprim ($letk ((kprim
src
($kargs ('prim) (prim) ($kargs ('prim) (prim)
($continue k ($continue k src
($primcall 'apply ($primcall 'apply
(prim vals)))))) (prim vals))))))
($continue kprim ($continue kprim src
($prim 'values)))))) ($prim 'values))))))
($continue kret ($continue kret src
($primcall 'unwind ()))))) ($primcall 'unwind ())))))
(krest src ($ktrunc '() 'rest kpop))) (krest ($ktrunc '() 'rest kpop)))
,(if escape-only? ,(if escape-only?
(build-cps-term (build-cps-term
($letk ((kbody (tree-il-src body) ($letk ((kbody ($kargs () ()
($kargs () ()
,(convert body krest subst)))) ,(convert body krest subst))))
($continue kbody ($prompt #t tag khargs kpop)))) ($continue kbody src ($prompt #t tag khargs kpop))))
(convert-arg body (convert-arg body
(lambda (thunk) (lambda (thunk)
(build-cps-term (build-cps-term
($letk ((kbody (tree-il-src body) ($letk ((kbody ($kargs () ()
($kargs () () ($continue krest (tree-il-src body)
($continue krest
($primcall 'call-thunk/no-inline ($primcall 'call-thunk/no-inline
(thunk)))))) (thunk))))))
($continue kbody ($continue kbody (tree-il-src body)
($prompt #f tag khargs kpop)))))))))))))) ($prompt #f tag khargs kpop))))))))))))))
;; Eta-convert prompts without inline handlers. ;; Eta-convert prompts without inline handlers.
@ -503,7 +495,8 @@
(convert-args (cons tag args) (convert-args (cons tag args)
(lambda (args*) (lambda (args*)
(build-cps-term (build-cps-term
($continue k ($primcall 'abort-to-prompt args*)))))) ($continue k src
($primcall 'abort-to-prompt args*))))))
(($ <abort> src tag args tail) (($ <abort> src tag args tail)
(convert-args (append (list (make-primitive-ref #f 'abort-to-prompt) (convert-args (append (list (make-primitive-ref #f 'abort-to-prompt)
@ -512,24 +505,24 @@
(list tail)) (list tail))
(lambda (args*) (lambda (args*)
(build-cps-term (build-cps-term
($continue k ($primcall 'apply args*)))))) ($continue k src ($primcall 'apply args*))))))
(($ <conditional> src test consequent alternate) (($ <conditional> src test consequent alternate)
(let-gensyms (kif kt kf) (let-gensyms (kif kt kf)
(build-cps-term (build-cps-term
($letk* ((kt (tree-il-src consequent) ($kargs () () ($letk* ((kt ($kargs () () ,(convert consequent k subst)))
,(convert consequent k subst))) (kf ($kargs () () ,(convert alternate k subst)))
(kf (tree-il-src alternate) ($kargs () () (kif ($kif kt kf)))
,(convert alternate k subst)))
(kif src ($kif kt kf)))
,(match test ,(match test
(($ <primcall> src (? branching-primitive? name) args) (($ <primcall> src (? branching-primitive? name) args)
(convert-args args (convert-args args
(lambda (args) (lambda (args)
(build-cps-term ($continue kif ($primcall name args)))))) (build-cps-term
($continue kif src ($primcall name args))))))
(_ (convert-arg test (_ (convert-arg test
(lambda (test) (lambda (test)
(build-cps-term ($continue kif ($var test))))))))))) (build-cps-term
($continue kif src ($var test)))))))))))
(($ <lexical-set> src name gensym exp) (($ <lexical-set> src name gensym exp)
(convert-arg exp (convert-arg exp
@ -537,14 +530,14 @@
(match (assq-ref subst gensym) (match (assq-ref subst gensym)
((box #t) ((box #t)
(build-cps-term (build-cps-term
($continue k ($primcall 'box-set! (box exp))))))))) ($continue k src ($primcall 'box-set! (box exp)))))))))
(($ <seq> src head tail) (($ <seq> src head tail)
(let-gensyms (ktrunc kseq) (let-gensyms (ktrunc kseq)
(build-cps-term (build-cps-term
($letk* ((kseq (tree-il-src tail) ($kargs () () ($letk* ((kseq ($kargs () ()
,(convert tail k subst))) ,(convert tail k subst)))
(ktrunc src ($ktrunc '() #f kseq))) (ktrunc ($ktrunc '() #f kseq)))
,(convert head ktrunc subst))))) ,(convert head ktrunc subst)))))
(($ <let> src names syms vals body) (($ <let> src names syms vals body)
@ -554,9 +547,9 @@
(((name . names) (sym . syms) (val . vals)) (((name . names) (sym . syms) (val . vals))
(let-gensyms (klet) (let-gensyms (klet)
(build-cps-term (build-cps-term
($letk ((klet src ($kargs (name) (sym) ($letk ((klet ($kargs (name) (sym)
,(box-bound-var name sym ,(box-bound-var name sym
(lp names syms vals))))) (lp names syms vals)))))
,(convert val klet subst)))))))) ,(convert val klet subst))))))))
(($ <fix> src names gensyms funs body) (($ <fix> src names gensyms funs body)
@ -568,15 +561,15 @@
gensyms gensyms
(map (lambda (fun) (map (lambda (fun)
(match (convert fun k subst) (match (convert fun k subst)
(($ $continue _ (and fun ($ $fun))) (($ $continue _ _ (and fun ($ $fun)))
fun))) fun)))
funs) funs)
,(convert body k subst)))) ,(convert body k subst))))
(let-gensyms (scope kscope) (let-gensyms (scope kscope)
(build-cps-term (build-cps-term
($letk ((kscope src ($kargs () () ($letk ((kscope ($kargs () ()
,(parameterize ((current-topbox-scope scope)) ,(parameterize ((current-topbox-scope scope))
(convert exp k subst))))) (convert exp k subst)))))
,(capture-toplevel-scope src scope kscope)))))) ,(capture-toplevel-scope src scope kscope))))))
(($ <let-values> src exp (($ <let-values> src exp
@ -584,11 +577,11 @@
(let ((names (append req (if rest (list rest) '())))) (let ((names (append req (if rest (list rest) '()))))
(let-gensyms (ktrunc kargs) (let-gensyms (ktrunc kargs)
(build-cps-term (build-cps-term
($letk* ((kargs src ($kargs names syms ($letk* ((kargs ($kargs names syms
,(fold box-bound-var ,(fold box-bound-var
(convert body k subst) (convert body k subst)
names syms))) names syms)))
(ktrunc src ($ktrunc req rest kargs))) (ktrunc ($ktrunc req rest kargs)))
,(convert exp ktrunc subst)))))))) ,(convert exp ktrunc subst))))))))
(define (build-subst exp) (define (build-subst exp)
@ -628,16 +621,14 @@ indicates that the replacement variable is in a box."
(let ((src (tree-il-src exp))) (let ((src (tree-il-src exp)))
(let-gensyms (kinit init ktail kclause kbody) (let-gensyms (kinit init ktail kclause kbody)
(build-cps-exp (build-cps-exp
($fun '() '() ($fun src '() '()
(kinit src (kinit ($kentry init
($kentry init (ktail ($ktail))
(ktail #f ($ktail)) ((kclause
((kclause src ($kclause ('() '() #f '() #f)
($kclause ('() '() #f '() #f) (kbody ($kargs () ()
(kbody src ,(convert exp ktail
($kargs () () (build-subst exp))))))))))))))
,(convert exp ktail
(build-subst exp))))))))))))))
(define *comp-module* (make-fluid)) (define *comp-module* (make-fluid))