[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, wip-cps-bis, updated. v2.1.0-186-g239b
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, wip-cps-bis, updated. v2.1.0-186-g239b4dc |
|
Date: |
Thu, 15 Aug 2013 21:09:28 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=239b4dc4b0bf26f40510e256dec1c4299eccb015
The branch, wip-cps-bis has been updated
via 239b4dc4b0bf26f40510e256dec1c4299eccb015 (commit)
via dadad2eb4a51cfd5f1c766c41fa1f2eb48280b7f (commit)
from fa798547e4bc6c687581f937ef6756f1c74f5bf3 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 239b4dc4b0bf26f40510e256dec1c4299eccb015
Author: Andy Wingo <address@hidden>
Date: Thu Aug 15 23:07:56 2013 +0200
closure-conversion using build-cps-term
* module/language/cps/closure-conversion.scm: Rewrite to use the
build-cps forms.
(convert-to-indices): Refactor a bit.
commit dadad2eb4a51cfd5f1c766c41fa1f2eb48280b7f
Author: Andy Wingo <address@hidden>
Date: Thu Aug 15 22:42:18 2013 +0200
Move build-cps-term and friends to (language cps)
* module/language/cps.scm (let-gensyms):
(build-cps-cont, build-cps-call, build-cps-term): New public
interfaces, factored out of (language tree-il compile-cps).
* module/language/tree-il/compile-cps.scm: Update.
-----------------------------------------------------------------------
Summary of changes:
module/language/cps.scm | 96 +++++-
module/language/cps/closure-conversion.scm | 127 +++-----
module/language/tree-il/compile-cps.scm | 513 ++++++++++++----------------
3 files changed, 367 insertions(+), 369 deletions(-)
diff --git a/module/language/cps.scm b/module/language/cps.scm
index 29c688a..35cf43d 100644
--- a/module/language/cps.scm
+++ b/module/language/cps.scm
@@ -70,7 +70,13 @@
make-$call make-$primcall make-$values make-$prompt
parse-cps
- unparse-cps))
+ unparse-cps
+
+ ;; Building macros.
+ let-gensyms
+ build-cps-term
+ build-cps-call
+ build-cps-cont))
;; FIXME: Use SRFI-99, when Guile adds it.
(define-syntax define-record-type*
@@ -226,3 +232,91 @@
`(prompt ,escape? ,tag ,handler))
(_
(error "unexpected cps" exp))))
+
+;; FIXME: Figure out how to evaluate this automatically when Emacs
+;; visits this buffer.
+;;
+;; (put 'let-gensyms 'scheme-indent-function 1)
+;; (put 'build-cps-term 'scheme-indent-function 0)
+;; (put 'build-cps-call 'scheme-indent-function 0)
+;; (put 'build-cps-cont 'scheme-indent-function 0)
+;; (put '$letk 'scheme-indent-function 1)
+;; (put '$letk* 'scheme-indent-function 1)
+;; (put '$letconst 'scheme-indent-function 1)
+;; (put '$continue 'scheme-indent-function 1)
+;; (put '$kargs 'scheme-indent-function 2)
+
+(define-syntax let-gensyms
+ (syntax-rules ()
+ ((_ (sym ...) body body* ...)
+ (let ((sym (gensym (symbol->string 'sym))) ...)
+ body body* ...))))
+
+(define-syntax build-arity
+ (syntax-rules (unquote)
+ ((_ (unquote exp)) exp)
+ ((_ (req opt rest kw allow-other-keys?))
+ (make-$arity req opt rest kw allow-other-keys?))))
+
+(define-syntax build-cont-body
+ (syntax-rules (unquote $kif $ktrunc $kargs $kentry)
+ ((_ (unquote exp))
+ exp)
+ ((_ ($kif kt kf))
+ (make-$kif kt kf))
+ ((_ ($ktrunc req rest kargs))
+ (make-$ktrunc (make-$arity req '() rest '() #f) kargs))
+ ((_ ($kargs (name ...) (sym ...) body))
+ (make-$kargs (list name ...) (list sym ...) (build-cps-term body)))
+ ((_ ($kargs names syms body))
+ (make-$kargs names syms (build-cps-term body)))
+ ((_ ($kentry arity cont))
+ (make-$kentry (build-arity arity) (build-cps-cont cont)))))
+
+(define-syntax build-cps-cont
+ (syntax-rules (unquote)
+ ((_ (unquote exp)) exp)
+ ((_ (k src cont)) (make-$cont src k (build-cont-body cont)))))
+
+(define-syntax build-cps-call
+ (syntax-rules (unquote
+ $var $void $const $prim $fun $call $primcall $values $prompt)
+ ((_ (unquote exp)) exp)
+ ((_ ($var sym)) (make-$var sym))
+ ((_ ($void)) (make-$void))
+ ((_ ($const val)) (make-$const val))
+ ((_ ($prim name)) (make-$prim name))
+ ((_ ($fun meta self free (unquote entries)))
+ (make-$fun meta self free entries))
+ ((_ ($fun meta self free (entry ...)))
+ (make-$fun meta self free (list (build-cps-cont entry) ...)))
+ ((_ ($call proc (arg ...))) (make-$call proc (list arg ...)))
+ ((_ ($call proc args)) (make-$call proc args))
+ ((_ ($primcall name (arg ...))) (make-$primcall name (list arg ...)))
+ ((_ ($primcall name args)) (make-$primcall name args))
+ ((_ ($values (arg ...))) (make-$values (list arg ...)))
+ ((_ ($values args)) (make-$values args))
+ ((_ ($prompt escape? tag handler)) (make-$prompt escape? tag handler))))
+
+(define-syntax build-cps-term
+ (syntax-rules (unquote $letk $letk* $letconst $letrec $continue)
+ ((_ (unquote exp))
+ exp)
+ ((_ ($letk (cont ...) body))
+ (make-$letk (list (build-cps-cont cont) ...)
+ (build-cps-term body)))
+ ((_ ($letk* () body))
+ (build-cps-term body))
+ ((_ ($letk* (cont conts ...) body))
+ (build-cps-term ($letk (cont) ($letk* (conts ...) body))))
+ ((_ ($letconst () body))
+ (build-cps-term body))
+ ((_ ($letconst ((name sym val) tail ...) body))
+ (let-gensyms (kconst)
+ (build-cps-term
+ ($letk ((kconst #f ($kargs (name) (sym) ($letconst (tail ...) body))))
+ ($continue kconst ($const val))))))
+ ((_ ($letrec names gensyms funs body))
+ (make-$letrec names gensyms funs (build-cps-term body)))
+ ((_ ($continue k exp))
+ (make-$continue k (build-cps-call exp)))))
diff --git a/module/language/cps/closure-conversion.scm
b/module/language/cps/closure-conversion.scm
index 7b33dd7..14a7282 100644
--- a/module/language/cps/closure-conversion.scm
+++ b/module/language/cps/closure-conversion.scm
@@ -23,7 +23,9 @@
(define-module (language cps closure-conversion)
#:use-module (ice-9 match)
- #:use-module ((srfi srfi-1) #:select (fold lset-union lset-difference))
+ #:use-module ((srfi srfi-1) #:select (fold
+ lset-union lset-difference
+ list-index))
#:use-module (ice-9 receive)
#:use-module (srfi srfi-26)
#:use-module (language cps)
@@ -35,19 +37,6 @@
(define (difference s1 s2)
(lset-difference eq? s1 s2))
-(define (make-$let1k cont body)
- (make-$letk (list cont) body))
-
-(define (make-$let1v src k name sym cont-body body)
- (make-$let1k (make-$cont src k (make-$kargs (list name) (list sym)
cont-body))
- body))
-
-(define (make-$letk* conts body)
- (match conts
- (() body)
- ((cont . conts)
- (make-$let1k cont (make-$letk* conts body)))))
-
;; bound := sym ...
;; free := sym ...
@@ -63,12 +52,11 @@ called with @var{sym}.
values in the term."
(if (memq sym bound)
(k sym)
- (let* ((k* (gensym "k"))
- (sym* (gensym "v")))
+ (let-gensyms (k* sym*)
(receive (exp free) (k sym*)
- (values (make-$let1v
- #f k* sym* sym* exp
- (make-$continue k* (make-$primcall 'free-ref (list self
sym))))
+ (values (build-cps-term
+ ($letk ((k* #f ($kargs (sym*) (sym*) ,exp)))
+ ($continue k* ($primcall 'free-ref (self sym)))))
(cons sym free))))))
(define (convert-free-vars syms self bound k)
@@ -88,15 +76,13 @@ values: the term and a list of additional free variables in
the term."
"Initialize the free variables in a closure bound to @var{sym}, and
continue with @var{body}."
(fold (lambda (free idx body)
- (let ((k (gensym "k"))
- (k* (gensym "k*"))
- (idxsym (gensym "idx")))
- (make-$let1k
- (make-$cont src k (make-$kargs '() '() body))
- (make-$let1v
- src k* 'idx idxsym
- (make-$continue k (make-$primcall 'free-set! (list v idxsym
free)))
- (make-$continue k* (make-$const idx))))))
+ (let-gensyms (k k* idxsym)
+ (build-cps-term
+ ($letk ((k src ($kargs () () ,body)))
+ ($letk ((k* src ($kargs ('idx) (idxsym)
+ ($continue k
+ ($primcall 'free-set! (v idxsym free))))))
+ ($continue k* ($const idx)))))))
body
free
(iota (length free))))
@@ -125,12 +111,12 @@ convert functions to flat closures."
(($ $cont src sym ($ $kargs names syms body))
(receive (body free) (cc body self (append syms bound))
- (values (make-$cont src sym (make-$kargs names syms body))
+ (values (build-cps-cont (sym src ($kargs names syms ,body)))
free)))
(($ $cont src sym ($ $kentry arity body))
(receive (body free) (cc body self bound)
- (values (make-$cont src sym (make-$kentry arity body))
+ (values (build-cps-cont (sym src ($kentry ,arity ,body)))
free)))
(($ $cont)
@@ -152,17 +138,17 @@ convert functions to flat closures."
(receive (entries fun-free) (cc* entries self (list self))
(lp in
(lambda (body)
- (let ((k (gensym "k")))
- (make-$let1v
- #f k name sym (bindings body)
- (make-$continue k (make-$fun meta self fun-free
entries)))))
+ (let-gensyms (k)
+ (build-cps-term
+ ($letk ((k #f ($kargs (name) (sym) ,(bindings
body))))
+ ($continue k ($fun meta self fun-free
,entries))))))
(init-closure #f sym fun-free body)
(union free (difference fun-free bound))))))))))
(($ $continue k ($ $var sym))
(convert-free-var sym self bound
(lambda (sym)
- (values (make-$continue k (make-$var sym))
+ (values (build-cps-term ($continue k ($var sym)))
'()))))
(($ $continue k
@@ -175,43 +161,47 @@ convert functions to flat closures."
(receive (entries free) (cc* entries self (list self))
(match free
(()
- (values (make-$continue k (make-$fun meta self free entries))
+ (values (build-cps-term ($continue k ($fun meta self free ,entries)))
free))
(else
(values
- (let ((kinit (gensym "kinit"))
- (v (gensym "v")))
- (make-$let1v
- #f kinit v v
- (init-closure #f v free
- (make-$continue k (make-$var v)))
- (make-$continue kinit (make-$fun meta self free entries))))
+ (let-gensyms (kinit v)
+ (build-cps-term
+ ($letk ((kinit #f ($kargs (v) (v)
+ ,(init-closure #f v free
+ (build-cps-term
+ ($continue k ($var v)))))))
+ ($continue kinit ($fun meta self free ,entries)))))
(difference free bound))))))
(($ $continue k ($ $call proc args))
(convert-free-vars (cons proc args) self bound
(match-lambda
((proc . args)
- (values (make-$continue k (make-$call proc args))
+ (values (build-cps-term
+ ($continue k ($call proc args)))
'())))))
(($ $continue k ($ $primcall name args))
(convert-free-vars args self bound
(lambda (args)
- (values (make-$continue k (make-$primcall name args))
+ (values (build-cps-term
+ ($continue k ($primcall name args)))
'()))))
(($ $continue k ($ $values args))
(convert-free-vars args self bound
(lambda (args)
- (values (make-$continue k (make-$values args))
+ (values (build-cps-term
+ ($continue k ($values args)))
'()))))
(($ $continue k ($ $prompt escape? tag handler))
(convert-free-var
tag self bound
(lambda (tag)
- (values (make-$continue k (make-$prompt escape? tag handler))
+ (values (build-cps-term
+ ($continue k ($prompt escape? tag handler)))
'()))))
(_ (error "what" exp))))
@@ -225,41 +215,24 @@ convert functions to flat closures."
(($ $letk conts body)
(make-$letk (map lp conts) (lp body)))
(($ $cont src sym ($ $kargs names syms body))
- (make-$cont src sym (make-$kargs names syms (lp body))))
+ (build-cps-cont (sym src ($kargs names syms ,(lp body)))))
(($ $cont src sym ($ $kentry arity body))
- (make-$cont src sym (make-$kentry arity (lp body))))
+ (build-cps-cont (sym src ($kentry ,arity ,(lp body)))))
;; Other kinds of continuations don't
;; bind values and don't have bodies.
(($ $cont) exp)
- (($ $kif kt kf) exp)
- (($ $ktrunc arity k) exp)
- (($ $letrec names syms funs body)
- (make-$letrec names syms (map lp funs) (lp body)))
- (($ $call proc args) exp)
- (($ $continue k ($ $primcall 'free-ref args))
- (match args
- ((closure sym)
- (let ((idx (let lp ((i 0) (f free))
- (cond ((null? f)
- ((error "convert-to-indices: free variable not
found!"
- sym free exp)))
- ((eq? sym (car f))
- i)
- (else (lp (+ i 1) (cdr f))))))
- (idxsym (gensym "idx"))
- (k* (gensym "k")))
- (make-$let1v #f k* 'idx idxsym
- (make-$continue k (make-$primcall
- 'free-ref (list closure idxsym)))
- (make-$continue k* (make-$const idx)))))))
- (($ $continue k (or ($ $var) ($ $void) ($ $const) ($ $prim)
- ($ $call) ($ $values) ($ $prompt) ($ $primcall)))
- exp)
+ (($ $continue k ($ $primcall 'free-ref (closure sym)))
+ (let ((idx (or (list-index (cut eq? <> sym) free)
+ (error "free variable not found!" sym free exp))))
+ (let-gensyms (idxsym)
+ (build-cps-term
+ ($letconst (('idx idxsym idx))
+ ($continue k ($primcall 'free-ref (closure idxsym))))))))
(($ $continue k ($ $fun meta self free entries))
- (make-$continue k (make-$fun meta self free
- (map (cut lpfree <> free) entries))))
- (($ $values args) exp)
- (_ ((error "convert-to-indices: unhandled case")))))))
+ (build-cps-term
+ ($continue k ($fun meta self free
+ ,(map (cut lpfree <> free) entries)))))
+ (($ $continue) exp)))))
(define (convert-closures exp)
"Convert free reference in @var{exp} to primcalls to @code{free-ref},
diff --git a/module/language/tree-il/compile-cps.scm
b/module/language/tree-il/compile-cps.scm
index d77b9d4..236d46a 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -47,98 +47,9 @@
tree-il-fold))
#:export (compile-cps))
-;; (put 'build-cps 'scheme-indent-function 0)
-;; (put 'build-cps* 'scheme-indent-function 1)
-;; (put '$letk 'scheme-indent-function 1)
-;; (put '$letk* 'scheme-indent-function 1)
-;; (put '$letconst 'scheme-indent-function 1)
-;; (put '$continue 'scheme-indent-function 1)
-;; (put '$kargs 'scheme-indent-function 2)
;; (put 'convert-arg 'scheme-indent-function 1)
;; (put 'convert-args 'scheme-indent-function 1)
-(define-syntax build-cont
- (syntax-rules (unquote $kif $ktrunc $kargs)
- ((_ (unquote exp))
- exp)
- ((_ ($kif kt kf))
- (make-$kif kt kf))
- ((_ ($ktrunc req rest kargs))
- (make-$ktrunc (make-$arity req '() rest '() #f) kargs))
- ((_ ($kargs (name ...) (sym ...) body))
- (make-$kargs (list name ...) (list sym ...) (build-cps body)))
- ((_ ($kargs names syms body))
- (make-$kargs names syms (build-cps body)))))
-
-(define-syntax build-cont-decl
- (syntax-rules (unquote)
- ((_ (unquote exp)) exp)
- ((_ (k src cont)) (make-$cont src k (build-cont cont)))))
-
-(define-syntax build-arity
- (syntax-rules (unquote)
- ((_ (unquote exp)) exp)
- ((_ (req opt rest kw allow-other-keys?))
- (make-$arity req opt rest kw allow-other-keys?))))
-
-(define-syntax build-fun-entry
- (syntax-rules (unquote)
- ((_ (unquote exp)) exp)
- ((_ ($kentry k src arity cont-decl))
- (make-$cont src k (make-$kentry (build-arity arity)
- (build-cont-decl cont-decl))))))
-
-(define-syntax build-fun
- (syntax-rules (unquote)
- ((_ ($fun meta self free (unquote body)))
- (make-$fun meta self free body))
- ((_ ($fun meta self free (entry ...)))
- (make-$fun meta self free (list (build-fun-entry entry) ...)))))
-
-(define-syntax build-call
- (syntax-rules (unquote
- $var $void $const $prim $fun $call $primcall $values $prompt)
- ((_ (unquote exp)) exp)
- ((_ ($var sym)) (make-$var sym))
- ((_ ($void)) (make-$void))
- ((_ ($const val)) (make-$const val))
- ((_ ($prim name)) (make-$prim name))
- ((_ ($fun . args)) (build-fun ($fun . args)))
- ((_ ($call proc (arg ...))) (make-$call proc (list arg ...)))
- ((_ ($call proc args)) (make-$call proc args))
- ((_ ($primcall name (arg ...))) (make-$primcall name (list arg ...)))
- ((_ ($primcall name args)) (make-$primcall name args))
- ((_ ($values (arg ...))) (make-$values (list arg ...)))
- ((_ ($values args)) (make-$values args))
- ((_ ($prompt escape? tag handler)) (make-$prompt escape? tag handler))))
-
-(define-syntax build-cps
- (syntax-rules (unquote $letk $letk* $letconst $letrec $continue)
- ((_ (unquote exp))
- exp)
- ((_ ($letk (cont-decl ...) body))
- (make-$letk (list (build-cont-decl cont-decl) ...)
- (build-cps body)))
- ((_ ($letk* () body))
- (build-cps body))
- ((_ ($letk* (cont-decl cont-decls ...) body))
- (build-cps ($letk (cont-decl) ($letk* (cont-decls ...) body))))
- ((_ ($letconst () body))
- (build-cps body))
- ((_ ($letconst ((name sym val) tail ...) body))
- (build-cps* (kconst)
- ($letk ((kconst #f ($kargs (name) (sym) ($letconst (tail ...) body))))
- ($continue kconst ($const val)))))
- ((_ ($letrec names gensyms funs body))
- (make-$letrec names gensyms funs (build-cps body)))
- ((_ ($continue k exp)) (make-$continue k (build-call exp)))))
-
-(define-syntax build-cps*
- (syntax-rules ()
- ((_ (sym ...) form)
- (let ((sym (gensym (symbol->string 'sym))) ...)
- (build-cps form)))))
-
;; Guile's semantics are that a toplevel lambda captures a reference on
;; the current module, and that all contained lambdas use that module to
;; resolve toplevel variables. This parameter tracks whether or not we
@@ -155,43 +66,47 @@
(define current-topbox-scope (make-parameter #f))
(define (toplevel-box src name bound? val-proc)
- (build-cps* (name-sym bound?-sym kbox box)
- ($letconst (('name name-sym name)
- ('bound? bound?-sym bound?))
- ($letk ((kbox src ($kargs ('box) (box) ,(val-proc box))))
- ,(match (current-topbox-scope)
- (#f
- (build-cps
- ($continue kbox
- ($primcall 'resolve
- (name-sym bound?-sym)))))
- (scope
- (build-cps* (scope-sym)
- ($letconst (('scope scope-sym scope))
+ (let-gensyms (name-sym bound?-sym kbox box)
+ (build-cps-term
+ ($letconst (('name name-sym name)
+ ('bound? bound?-sym bound?))
+ ($letk ((kbox src ($kargs ('box) (box) ,(val-proc box))))
+ ,(match (current-topbox-scope)
+ (#f
+ (build-cps-term
($continue kbox
- ($primcall 'cached-toplevel-box
- (scope-sym name-sym bound?-sym)))))))))))
+ ($primcall 'resolve
+ (name-sym bound?-sym)))))
+ (scope
+ (let-gensyms (scope-sym)
+ (build-cps-term
+ ($letconst (('scope scope-sym scope))
+ ($continue kbox
+ ($primcall 'cached-toplevel-box
+ (scope-sym name-sym bound?-sym)))))))))))))
(define (module-box src module name public? bound? val-proc)
- (build-cps* (module-sym name-sym public?-sym bound?-sym kbox box)
- ($letconst (('module module-sym module)
- ('name name-sym name)
- ('public? public?-sym public?)
- ('bound? bound?-sym bound?))
- ($letk ((kbox src ($kargs ('box) (box) ,(val-proc box))))
- ($continue kbox
- ($primcall 'cached-module-box
- (module-sym name-sym public?-sym bound?-sym)))))))
+ (let-gensyms (module-sym name-sym public?-sym bound?-sym kbox box)
+ (build-cps-term
+ ($letconst (('module module-sym module)
+ ('name name-sym name)
+ ('public? public?-sym public?)
+ ('bound? bound?-sym bound?))
+ ($letk ((kbox src ($kargs ('box) (box) ,(val-proc box))))
+ ($continue kbox
+ ($primcall 'cached-module-box
+ (module-sym name-sym public?-sym bound?-sym))))))))
(define (capture-toplevel-scope src scope k)
- (build-cps* (module scope-sym kmodule)
- ($letconst (('scope scope-sym scope))
- ($letk ((kmodule src ($kargs ('module) (module)
- ($continue k
- ($primcall 'cache-current-module!
- (module scope-sym))))))
- ($continue kmodule
- ($primcall 'current-module ()))))))
+ (let-gensyms (module scope-sym kmodule)
+ (build-cps-term
+ ($letconst (('scope scope-sym scope))
+ ($letk ((kmodule src ($kargs ('module) (module)
+ ($continue k
+ ($primcall 'cache-current-module!
+ (module scope-sym))))))
+ ($continue kmodule
+ ($primcall 'current-module ())))))))
(define (fold-formals proc seed arity gensyms inits)
(match arity
@@ -233,11 +148,12 @@
(define tc8-iflag 4)
(define unbound-val 9)
(define unbound-bits (logior (ash unbound-val 8) tc8-iflag))
- (build-cps* (unbound ktest)
- ($letconst (('unbound unbound (pointer->scm (make-pointer unbound-bits))))
- ($letk ((ktest src ($kif kt kf)))
- ($continue ktest
- ($primcall 'eq? (sym unbound)))))))
+ (let-gensyms (unbound ktest)
+ (build-cps-term
+ ($letconst (('unbound unbound (pointer->scm (make-pointer
unbound-bits))))
+ ($letk ((ktest src ($kif kt kf)))
+ ($continue ktest
+ ($primcall 'eq? (sym unbound))))))))
(define (init-default-value name sym subst init body)
(match (assq-ref subst sym)
@@ -245,20 +161,22 @@
(let ((src (tree-il-src init)))
(define (maybe-box k make-body)
(if box?
- (build-cps* (kbox phi)
- ($letk ((kbox src ($kargs (name) (phi)
- ($continue k ($primcall 'box (phi))))))
- ,(make-body kbox)))
+ (let-gensyms (kbox phi)
+ (build-cps-term
+ ($letk ((kbox src ($kargs (name) (phi)
+ ($continue k ($primcall 'box (phi))))))
+ ,(make-body kbox))))
(make-body k)))
- (build-cps* (knext kbound kunbound)
- ($letk ((knext src ($kargs (name) (subst-sym) ,body)))
- ,(maybe-box
- knext
- (lambda (k)
- (build-cps
- ($letk ((kbound src ($kargs () () ($continue k ($var sym))))
- (kunbound src ($kargs () () ,(convert init k subst))))
- ,(unbound? src sym kunbound kbound)))))))))))
+ (let-gensyms (knext kbound kunbound)
+ (build-cps-term
+ ($letk ((knext src ($kargs (name) (subst-sym) ,body)))
+ ,(maybe-box
+ knext
+ (lambda (k)
+ (build-cps-term
+ ($letk ((kbound src ($kargs () () ($continue k ($var sym))))
+ (kunbound src ($kargs () () ,(convert init k
subst))))
+ ,(unbound? src sym kunbound kbound))))))))))))
;; exp k-name alist -> term
(define (convert exp k subst)
@@ -268,16 +186,18 @@
(($ <lexical-ref> src name sym)
(match (assq-ref subst sym)
((box #t)
- (build-cps* (kunboxed unboxed)
- ($letk ((kunboxed src ($kargs ('unboxed) (unboxed) ,(k unboxed))))
- ($continue kunboxed ($primcall 'box-ref (box))))))
+ (let-gensyms (kunboxed unboxed)
+ (build-cps-term
+ ($letk ((kunboxed src ($kargs ('unboxed) (unboxed) ,(k
unboxed))))
+ ($continue kunboxed ($primcall 'box-ref (box)))))))
((subst #f) (k subst))
(#f (k sym))))
(else
(let ((src (tree-il-src exp)))
- (build-cps* (karg arg)
- ($letk ((karg src ($kargs ('arg) (arg) ,(k arg))))
- ,(convert exp karg subst)))))))
+ (let-gensyms (karg arg)
+ (build-cps-term
+ ($letk ((karg src ($kargs ('arg) (arg) ,(k arg))))
+ ,(convert exp karg subst))))))))
;; (exp ...) ((v-name ...) -> term) -> term
(define (convert-args exps k)
(match exps
@@ -291,26 +211,27 @@
(define (box-bound-var name sym body)
(match (assq-ref subst sym)
((box #t)
- (build-cps* (k)
- ($letk ((k #f ($kargs (name) (sym) ,body)))
- ($continue k ($primcall 'box (sym))))))
+ (let-gensyms (k)
+ (build-cps-term
+ ($letk ((k #f ($kargs (name) (sym) ,body)))
+ ($continue k ($primcall 'box (sym)))))))
(else body)))
(match exp
(($ <lexical-ref> src name sym)
(match (assq-ref subst sym)
- ((box #t) (build-cps ($continue k ($primcall 'box-ref (box)))))
- ((subst #f) (build-cps ($continue k ($var subst))))
- (#f (build-cps ($continue k ($var sym))))))
+ ((box #t) (build-cps-term ($continue k ($primcall 'box-ref (box)))))
+ ((subst #f) (build-cps-term ($continue k ($var subst))))
+ (#f (build-cps-term ($continue k ($var sym))))))
(($ <void> src)
- (build-cps ($continue k ($void))))
+ (build-cps-term ($continue k ($void))))
(($ <const> src exp)
- (build-cps ($continue k ($const exp))))
+ (build-cps-term ($continue k ($const exp))))
(($ <primitive-ref> src name)
- (build-cps ($continue k ($prim name))))
+ (build-cps-term ($continue k ($prim name))))
(($ <lambda> src meta body)
;; FIXME: add src field to fun, add tail field also
@@ -325,36 +246,40 @@
'()
arity gensyms inits)))
(cons
- (build-cps* (kentry kargs)
- ,(build-fun-entry
- ($kentry
- kentry src ,arity
- (kargs
- src
- ($kargs names gensyms
- ,(fold-formals
- (lambda (name sym init body)
- (if init
- (init-default-value name sym subst init body)
- (box-bound-var name sym body)))
- (convert body 'ktail subst)
- arity gensyms inits))))))
+ (let-gensyms (kentry kargs)
+ (build-cps-cont
+ (kentry
+ src
+ ($kentry
+ ,arity
+ (kargs
+ src
+ ($kargs names gensyms
+ ,(fold-formals
+ (lambda (name sym init body)
+ (if init
+ (init-default-value name sym subst init body)
+ (box-bound-var name sym body)))
+ (convert body 'ktail subst)
+ arity gensyms inits)))))))
(if alternate (convert-entries alternate) '()))))))
(if (current-topbox-scope)
- (build-cps* (self)
- ($continue k
- ($fun meta self '() ,(convert-entries body))))
- (build-cps* (scope kscope)
- ($letk ((kscope src ($kargs () ()
- ,(parameterize ((current-topbox-scope
scope))
- (convert exp k subst)))))
- ,(capture-toplevel-scope src scope kscope))))))
+ (let-gensyms (self)
+ (build-cps-term
+ ($continue k
+ ($fun meta self '() ,(convert-entries body)))))
+ (let-gensyms (scope kscope)
+ (build-cps-term
+ ($letk ((kscope src ($kargs () ()
+ ,(parameterize ((current-topbox-scope
scope))
+ (convert exp k subst)))))
+ ,(capture-toplevel-scope src scope kscope)))))))
(($ <module-ref> src mod name public?)
(module-box
src mod name public? #t
(lambda (box)
- (build-cps ($continue k ($primcall 'box-ref (box)))))))
+ (build-cps-term ($continue k ($primcall 'box-ref (box)))))))
(($ <module-set> src mod name public? exp)
(convert-arg exp
@@ -362,13 +287,13 @@
(module-box
src mod name public? #f
(lambda (box)
- (build-cps ($continue k ($primcall 'box-set! (box val)))))))))
+ (build-cps-term ($continue k ($primcall 'box-set! (box val)))))))))
(($ <toplevel-ref> src name)
(toplevel-box
src name #t
(lambda (box)
- (build-cps ($continue k ($primcall 'box-ref (box)))))))
+ (build-cps-term ($continue k ($primcall 'box-ref (box)))))))
(($ <toplevel-set> src name exp)
(convert-arg exp
@@ -376,20 +301,21 @@
(toplevel-box
src name #f
(lambda (box)
- (build-cps ($continue k ($primcall 'box-set! (box val)))))))))
+ (build-cps-term ($continue k ($primcall 'box-set! (box val)))))))))
(($ <toplevel-define> src name exp)
(convert-arg exp
(lambda (val)
- (build-cps* (kname name-sym)
- ($letconst (('name name-sym name))
- ($continue k ($primcall 'define! (name-sym val))))))))
+ (let-gensyms (kname name-sym)
+ (build-cps-term
+ ($letconst (('name name-sym name))
+ ($continue k ($primcall 'define! (name-sym val)))))))))
(($ <call> src proc args)
(convert-args (cons proc args)
(match-lambda
((proc . args)
- (build-cps ($continue k ($call proc args)))))))
+ (build-cps-term ($continue k ($call proc args)))))))
(($ <primcall> src name args)
(if (branching-primitive? name)
@@ -398,7 +324,7 @@
k subst)
(convert-args args
(lambda (args)
- (build-cps ($continue k ($primcall name args)))))))
+ (build-cps-term ($continue k ($primcall name args)))))))
;; Prompts with inline handlers.
(($ <prompt> src escape-only? tag body
@@ -416,133 +342,137 @@
;;
;; Escape prompts evaluate the body with the continuation of krest.
;; Otherwise we do a no-inline call to body, continuing to krest.
- (convert-arg
- tag
- (lambda (tag)
- (let ((hnames (append hreq (if hrest (list hrest) '()))))
- (build-cps* (khargs khbody kret kprim prim kpop krest vals kbody)
- ($letk* ((khbody hsrc ($kargs hnames hsyms
- ,(fold box-bound-var
- (convert hbody k subst)
- hnames hsyms)))
- (khargs hsrc ($ktrunc hreq hrest khbody))
- (kpop src
- ($kargs ('rest) (vals)
- ($letk ((kret
- src
- ($kargs () ()
- ($letk ((kprim
- src
- ($kargs ('prim) (prim)
- ($continue k
- ($primcall 'apply
- (prim
vals))))))
- ($continue kprim
- ($prim 'values))))))
- ($continue kret
- ($primcall 'pop-prompt ())))))
- (krest src ($ktrunc '() 'rest kpop)))
- ,(if escape-only?
- (build-cps
- ($letk ((kbody (tree-il-src body)
- ($kargs () ()
- ,(convert body krest subst))))
- ($continue kbody ($prompt #t tag khargs))))
- (convert-arg body
- (lambda (thunk)
- (build-cps
- ($letk ((kbody (tree-il-src body)
- ($kargs () ()
- ($continue krest
- ($primcall 'call-thunk/no-inline
- (thunk))))))
- ($continue kbody
- ($prompt #f tag khargs)))))))))))))
+ (convert-arg tag
+ (lambda (tag)
+ (let ((hnames (append hreq (if hrest (list hrest) '()))))
+ (let-gensyms (khargs khbody kret kprim prim kpop krest vals kbody)
+ (build-cps-term
+ ($letk* ((khbody hsrc ($kargs hnames hsyms
+ ,(fold box-bound-var
+ (convert hbody k subst)
+ hnames hsyms)))
+ (khargs hsrc ($ktrunc hreq hrest khbody))
+ (kpop src
+ ($kargs ('rest) (vals)
+ ($letk ((kret
+ src
+ ($kargs () ()
+ ($letk ((kprim
+ src
+ ($kargs ('prim) (prim)
+ ($continue k
+ ($primcall 'apply
+ (prim
vals))))))
+ ($continue kprim
+ ($prim 'values))))))
+ ($continue kret
+ ($primcall 'pop-prompt ())))))
+ (krest src ($ktrunc '() 'rest kpop)))
+ ,(if escape-only?
+ (build-cps-term
+ ($letk ((kbody (tree-il-src body)
+ ($kargs () ()
+ ,(convert body krest subst))))
+ ($continue kbody ($prompt #t tag khargs))))
+ (convert-arg body
+ (lambda (thunk)
+ (build-cps-term
+ ($letk ((kbody (tree-il-src body)
+ ($kargs () ()
+ ($continue krest
+ ($primcall 'call-thunk/no-inline
+ (thunk))))))
+ ($continue kbody
+ ($prompt #f tag khargs))))))))))))))
;; Eta-convert prompts without inline handlers.
(($ <prompt> src escape-only? tag body handler)
- (convert-args
- (list tag body handler)
- (lambda (args)
- (build-cps
- ($continue k ($primcall 'call-with-prompt args))))))
+ (convert-args (list tag body handler)
+ (lambda (args)
+ (build-cps-term
+ ($continue k ($primcall 'call-with-prompt args))))))
(($ <abort> src tag args tail)
(convert-args (append (list tag) args (list tail))
- (lambda (args*)
- (build-cps ($continue k ($primcall 'abort args*))))))
+ (lambda (args*)
+ (build-cps-term ($continue k ($primcall 'abort args*))))))
(($ <conditional> src test consequent alternate)
- (build-cps* (kif kt kf)
- ($letk* ((kt (tree-il-src consequent) ($kargs () ()
- ,(convert consequent k subst)))
- (kf (tree-il-src alternate) ($kargs () ()
- ,(convert alternate k subst)))
- (kif src ($kif kt kf)))
- ,(match test
- (($ <primcall> src (? branching-primitive? name) args)
- (convert-args args
- (lambda (args)
- (build-cps ($continue kif ($primcall name args))))))
- (_ (convert-arg test
- (lambda (test)
- (build-cps ($continue kif ($var test))))))))))
+ (let-gensyms (kif kt kf)
+ (build-cps-term
+ ($letk* ((kt (tree-il-src consequent) ($kargs () ()
+ ,(convert consequent k
subst)))
+ (kf (tree-il-src alternate) ($kargs () ()
+ ,(convert alternate k subst)))
+ (kif src ($kif kt kf)))
+ ,(match test
+ (($ <primcall> src (? branching-primitive? name) args)
+ (convert-args args
+ (lambda (args)
+ (build-cps-term ($continue kif ($primcall name args))))))
+ (_ (convert-arg test
+ (lambda (test)
+ (build-cps-term ($continue kif ($var test)))))))))))
(($ <lexical-set> src name gensym exp)
- (convert-arg
- exp
- (lambda (exp)
- (match (assq-ref subst gensym)
- ((box #t)
- (build-cps
- ($continue k ($primcall 'box-set! (box exp)))))))))
+ (convert-arg exp
+ (lambda (exp)
+ (match (assq-ref subst gensym)
+ ((box #t)
+ (build-cps-term
+ ($continue k ($primcall 'box-set! (box exp)))))))))
(($ <seq> src head tail)
- (build-cps* (ktrunc kseq)
- ($letk* ((kseq (tree-il-src tail) ($kargs () ()
- ,(convert tail k subst)))
- (ktrunc src ($ktrunc '() #f kseq)))
- ,(convert head ktrunc subst))))
+ (let-gensyms (ktrunc kseq)
+ (build-cps-term
+ ($letk* ((kseq (tree-il-src tail) ($kargs () ()
+ ,(convert tail k subst)))
+ (ktrunc src ($ktrunc '() #f kseq)))
+ ,(convert head ktrunc subst)))))
(($ <let> src names syms vals body)
(let lp ((names names) (syms syms) (vals vals))
(match (list names syms vals)
((() () ()) (convert body k subst))
(((name . names) (sym . syms) (val . vals))
- (build-cps* (klet)
- ($letk ((klet src ($kargs (name) (sym)
- ,(box-bound-var name sym
- (lp names syms vals)))))
- ,(convert val klet subst)))))))
+ (let-gensyms (klet)
+ (build-cps-term
+ ($letk ((klet src ($kargs (name) (sym)
+ ,(box-bound-var name sym
+ (lp names syms vals)))))
+ ,(convert val klet subst))))))))
(($ <fix> src names gensyms funs body)
;; Some letrecs can be contified; that happens later.
(if (current-topbox-scope)
- (build-cps* (self)
- ($letrec names
- gensyms
- (map (lambda (fun)
- (match (convert fun k subst)
- (($ $continue _ (and fun ($ $fun)))
- fun)))
- funs)
- ,(convert body k subst)))
- (build-cps* (scope kscope)
- ($letk ((kscope src ($kargs () ()
- ,(parameterize ((current-topbox-scope scope))
- (convert exp k subst)))))
- ,(capture-toplevel-scope src scope kscope)))))
+ (let-gensyms (self)
+ (build-cps-term
+ ($letrec names
+ gensyms
+ (map (lambda (fun)
+ (match (convert fun k subst)
+ (($ $continue _ (and fun ($ $fun)))
+ fun)))
+ funs)
+ ,(convert body k subst))))
+ (let-gensyms (scope kscope)
+ (build-cps-term
+ ($letk ((kscope src ($kargs () ()
+ ,(parameterize ((current-topbox-scope
scope))
+ (convert exp k subst)))))
+ ,(capture-toplevel-scope src scope kscope))))))
(($ <let-values> src exp
($ <lambda-case> lsrc req () rest #f () syms body #f))
(let ((names (append req (if rest (list rest) '()))))
- (build-cps* (ktrunc kargs)
- ($letk* ((kargs src ($kargs names syms
- ,(fold box-bound-var
- (convert body k subst)
- names syms)))
- (ktrunc src ($ktrunc req rest kargs)))
- ,(convert exp ktrunc subst)))))))
+ (let-gensyms (ktrunc kargs)
+ (build-cps-term
+ ($letk* ((kargs src ($kargs names syms
+ ,(fold box-bound-var
+ (convert body k subst)
+ names syms)))
+ (ktrunc src ($ktrunc req rest kargs)))
+ ,(convert exp ktrunc subst))))))))
(define (build-subst exp)
"Compute a mapping from lexical gensyms to substituted gensyms. The
@@ -582,12 +512,13 @@ indicates that the replacement variable is in a box."
(define (cps-convert/thunk exp)
(let ((src (tree-il-src exp)))
- (build-cps* (init kentry kinit)
- ,(build-fun
+ (let-gensyms (init kentry kinit)
+ (build-cps-call
($fun '() init '()
- (($kentry kentry src ('() '() #f '() #f)
- (kinit src ($kargs () ()
- ,(cps-convert exp))))))))))
+ ((kentry src
+ ($kentry ('() '() #f '() #f)
+ (kinit src ($kargs () ()
+ ,(cps-convert exp)))))))))))
(define *comp-module* (make-fluid))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, wip-cps-bis, updated. v2.1.0-186-g239b4dc,
Andy Wingo <=