[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, wip-cps-bis, updated. v2.1.0-197-g77ee
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, wip-cps-bis, updated. v2.1.0-197-g77ee8b9 |
|
Date: |
Fri, 16 Aug 2013 10:43:21 +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=77ee8b90cb8d3f51c85c2e0961b2dc46990515b7
The branch, wip-cps-bis has been updated
via 77ee8b90cb8d3f51c85c2e0961b2dc46990515b7 (commit)
via 120e28cccf56d7e8fbe8273c17c61ef2f480a774 (commit)
via d8ca22b56ec5b33d952abadcc9f7fbaa71eae5f2 (commit)
via 0313c87ce8282d34f18967c70d1e39e44a50646f (commit)
via c19881a97a2c56bc57de4c469bad1175f41e8c54 (commit)
from 561c9db260a7e5d0dc86c471316526a8c89ccf65 (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 77ee8b90cb8d3f51c85c2e0961b2dc46990515b7
Author: Andy Wingo <address@hidden>
Date: Fri Aug 16 12:35:21 2013 +0200
reorder $cont's k and src fields
* module/language/cps.scm ($cont): Reorder the "k" and "src" fields.
(build-cps-cont): Adapt. Happily this is the one make-$cont use site.
* module/language/cps.scm:
* module/language/cps/arities.scm:
* module/language/cps/closure-conversion.scm:
* module/language/cps/compile-rtl.scm:
* module/language/cps/dfg.scm:
* module/language/cps/reify-primitives.scm:
* module/language/cps/slot-allocation.scm:
* module/language/cps/verify.scm: Adapt pattern matchers.
commit 120e28cccf56d7e8fbe8273c17c61ef2f480a774
Author: Andy Wingo <address@hidden>
Date: Fri Aug 16 12:22:40 2013 +0200
parse-cps uses build-cps
* module/language/cps.scm (parse-cps): Convert to use the build-cps
facilities.
commit d8ca22b56ec5b33d952abadcc9f7fbaa71eae5f2
Author: Andy Wingo <address@hidden>
Date: Fri Aug 16 12:10:15 2013 +0200
closure conversion refactor
* module/language/cps/closure-conversion.scm (convert-closures):
(convert-to-indices): Some more build-cps-term rewriting, and tighten
up the convert-to-indices loop.
commit 0313c87ce8282d34f18967c70d1e39e44a50646f
Author: Andy Wingo <address@hidden>
Date: Fri Aug 16 11:53:58 2013 +0200
reify-primitives using cps builders
* module/language/cps.scm (rewrite-cps-term, rewrite-cps-cont):
(rewrite-cps-call): Move here, from arities.scm.
* module/language/cps/arities.scm: Adapt.
* module/language/cps/reify-primitives.scm: Rewrite to use the CPS
builders.
commit c19881a97a2c56bc57de4c469bad1175f41e8c54
Author: Andy Wingo <address@hidden>
Date: Fri Aug 16 11:44:58 2013 +0200
(language cps arities) uses build-cps-term
* module/language/cps.scm (build-cps-term): Add a ($letk ,conts body)
case.
* module/language/cps/arities.scm: Adapt to use build-cps-term and
friends.
-----------------------------------------------------------------------
Summary of changes:
module/language/cps.scm | 236 +++++++++++++++-------------
module/language/cps/arities.scm | 219 +++++++++++++-------------
module/language/cps/closure-conversion.scm | 58 ++++---
module/language/cps/compile-rtl.scm | 8 +-
module/language/cps/dfg.scm | 4 +-
module/language/cps/reify-primitives.scm | 117 ++++++---------
module/language/cps/slot-allocation.scm | 2 +-
module/language/cps/verify.scm | 6 +-
8 files changed, 324 insertions(+), 326 deletions(-)
diff --git a/module/language/cps.scm b/module/language/cps.scm
index 35cf43d..562d070 100644
--- a/module/language/cps.scm
+++ b/module/language/cps.scm
@@ -76,7 +76,10 @@
let-gensyms
build-cps-term
build-cps-call
- build-cps-cont))
+ build-cps-cont
+ rewrite-cps-term
+ rewrite-cps-call
+ rewrite-cps-cont))
;; FIXME: Use SRFI-99, when Guile adds it.
(define-syntax define-record-type*
@@ -110,7 +113,7 @@
;; Continuations.
(define-cps-type $letk conts body)
-(define-cps-type $cont src k cont)
+(define-cps-type $cont k src cont)
(define-cps-type $kif kt kf)
(define-cps-type $ktrunc arity k)
(define-cps-type $kargs names syms body)
@@ -129,110 +132,6 @@
(define-cps-type $values args)
(define-cps-type $prompt escape? tag handler)
-(define (parse-cps exp)
- (define (src exp)
- (let ((props (source-properties exp)))
- (and (pair? props) props)))
- (match exp
- ;; Continuations.
- (('let k (name sym val) body)
- (make-$letk (list (make-$cont (src exp) k
- (make-$kargs (list name) (list sym)
- (parse-cps body))))
- (parse-cps val)))
- (('letk (cont ...) body)
- (make-$letk (map parse-cps cont) (parse-cps body)))
- (('k sym body)
- (make-$cont (src exp) sym (parse-cps body)))
- (('kif kt kf)
- (make-$kif kt kf))
- (('ktrunc req rest k)
- (make-$ktrunc (make-$arity req '() rest '() #f) k))
- (('kargs names syms body)
- (make-$kargs names syms (parse-cps body)))
- (('kentry (req opt rest kw allow-other-keys?) body)
- (make-$kentry (make-$arity req opt rest kw allow-other-keys?)
- (parse-cps body)))
- (('kseq body)
- (make-$kargs '() '() (parse-cps body)))
-
- ;; Calls.
- (('continue k exp)
- (make-$continue k (parse-cps exp)))
- (('var sym)
- (make-$var sym))
- (('void)
- (make-$void))
- (('const exp)
- (make-$const exp))
- (('prim name)
- (make-$prim name))
- (('fun meta self free entries)
- (make-$fun meta self free (map parse-cps entries)))
- (('letrec ((name sym fun) ...) body)
- (make-$letrec name sym (map parse-cps fun) (parse-cps body)))
- (('call proc arg ...)
- (make-$call proc arg))
- (('primcall name arg ...)
- (make-$primcall name arg))
- (('values arg ...)
- (make-$values arg))
- (('prompt escape? tag handler)
- (make-$prompt escape? tag handler))
- (_
- (error "unexpected cps" exp))))
-
-(define (unparse-cps exp)
- (match exp
- ;; Continuations.
- (($ $letk (($ $cont src k ($ $kargs (name) (sym) body))) val)
- `(let ,k (,name ,sym ,(unparse-cps val))
- ,(unparse-cps body)))
- (($ $letk conts body)
- `(letk ,(map unparse-cps conts) ,(unparse-cps body)))
- (($ $cont src sym body)
- `(k ,sym ,(unparse-cps body)))
- (($ $kif kt kf)
- `(kif ,kt ,kf))
- (($ $ktrunc ($ $arity req () rest '() #f) k)
- `(ktrunc ,req ,rest ,k))
- (($ $kargs () () body)
- `(kseq ,(unparse-cps body)))
- (($ $kargs names syms body)
- `(kargs ,names ,syms ,(unparse-cps body)))
- (($ $kentry ($ $arity req opt rest kw allow-other-keys?) body)
- `(kentry (,req ,opt ,rest ,kw ,allow-other-keys?)
- ,(unparse-cps body)))
-
- ;; Calls.
- (($ $continue k exp)
- `(continue ,k ,(unparse-cps exp)))
- (($ $var sym)
- `(var ,sym))
- (($ $void)
- `(void))
- (($ $const val)
- `(const ,val))
- (($ $prim name)
- `(prim ,name))
- (($ $fun meta self free entries)
- `(fun ,meta ,self ,free ,(map unparse-cps entries)))
- (($ $letrec names syms funs body)
- `(letrec ,(map (lambda (name sym fun)
- (list name sym (unparse-cps fun)))
- names syms funs)
- ,(unparse-cps body)))
- (($ $call proc args)
- `(call ,proc ,@args))
- (($ $primcall name args)
- `(primcall ,name ,@args))
- (($ $values args)
- `(values ,@args))
- (($ $prompt escape? tag handler)
- `(prompt ,escape? ,tag ,handler))
- (_
- (error "unexpected cps" exp))))
-
;; FIXME: Figure out how to evaluate this automatically when Emacs
;; visits this buffer.
;;
@@ -276,7 +175,7 @@
(define-syntax build-cps-cont
(syntax-rules (unquote)
((_ (unquote exp)) exp)
- ((_ (k src cont)) (make-$cont src k (build-cont-body cont)))))
+ ((_ (k src cont)) (make-$cont k src (build-cont-body cont)))))
(define-syntax build-cps-call
(syntax-rules (unquote
@@ -302,6 +201,8 @@
(syntax-rules (unquote $letk $letk* $letconst $letrec $continue)
((_ (unquote exp))
exp)
+ ((_ ($letk (unquote conts) body))
+ (make-$letk conts (build-cps-term body)))
((_ ($letk (cont ...) body))
(make-$letk (list (build-cps-cont cont) ...)
(build-cps-term body)))
@@ -320,3 +221,124 @@
(make-$letrec names gensyms funs (build-cps-term body)))
((_ ($continue k exp))
(make-$continue k (build-cps-call exp)))))
+
+;; (put 'rewrite-cps-term 'scheme-indent-function 1)
+;; (put 'rewrite-cps-cont 'scheme-indent-function 1)
+;; (put 'rewrite-cps-call 'scheme-indent-function 1)
+(define-syntax-rule (rewrite-cps-term x (pat body) ...)
+ (match x
+ (pat (build-cps-term body)) ...))
+(define-syntax-rule (rewrite-cps-cont x (pat body) ...)
+ (match x
+ (pat (build-cps-cont body)) ...))
+(define-syntax-rule (rewrite-cps-call x (pat body) ...)
+ (match x
+ (pat (build-cps-call body)) ...))
+
+(define (parse-cps exp)
+ (define (src exp)
+ (let ((props (source-properties exp)))
+ (and (pair? props) props)))
+ (match exp
+ ;; Continuations.
+ (('let k (name sym val) body)
+ (build-cps-term
+ ($letk ((k (src exp) ($kargs (name) (sym)
+ ,(parse-cps body))))
+ ,(parse-cps val))))
+ (('letk (cont ...) body)
+ (build-cps-term
+ ($letk ,(map parse-cps cont) ,(parse-cps body))))
+ (('k sym body)
+ (build-cps-cont
+ (sym (src exp) ,(parse-cps body))))
+ (('kif kt kf)
+ (build-cont-body ($kif kt kf)))
+ (('ktrunc req rest k)
+ (build-cont-body ($ktrunc req rest k)))
+ (('kargs names syms body)
+ (build-cont-body ($kargs names syms ,(parse-cps body))))
+ (('kentry (req opt rest kw allow-other-keys?) body)
+ (build-cont-body
+ ($kentry (req opt rest kw allow-other-keys?) ,(parse-cps body))))
+ (('kseq body)
+ (build-cont-body ($kargs () () ,(parse-cps body))))
+
+ ;; Calls.
+ (('continue k exp)
+ (build-cps-term ($continue k ,(parse-cps exp))))
+ (('var sym)
+ (build-cps-call ($var sym)))
+ (('void)
+ (build-cps-call ($void)))
+ (('const exp)
+ (build-cps-call ($const exp)))
+ (('prim name)
+ (build-cps-call ($prim name)))
+ (('fun meta self free entries)
+ (build-cps-call ($fun meta self free ,(map parse-cps entries))))
+ (('letrec ((name sym fun) ...) body)
+ (build-cps-term
+ ($letrec name sym (map parse-cps fun) ,(parse-cps body))))
+ (('call proc arg ...)
+ (build-cps-call ($call proc arg)))
+ (('primcall name arg ...)
+ (build-cps-call ($primcall name arg)))
+ (('values arg ...)
+ (build-cps-call ($values arg)))
+ (('prompt escape? tag handler)
+ (build-cps-call ($prompt escape? tag handler)))
+ (_
+ (error "unexpected cps" exp))))
+
+(define (unparse-cps exp)
+ (match exp
+ ;; Continuations.
+ (($ $letk (($ $cont k src ($ $kargs (name) (sym) body))) val)
+ `(let ,k (,name ,sym ,(unparse-cps val))
+ ,(unparse-cps body)))
+ (($ $letk conts body)
+ `(letk ,(map unparse-cps conts) ,(unparse-cps body)))
+ (($ $cont sym src body)
+ `(k ,sym ,(unparse-cps body)))
+ (($ $kif kt kf)
+ `(kif ,kt ,kf))
+ (($ $ktrunc ($ $arity req () rest '() #f) k)
+ `(ktrunc ,req ,rest ,k))
+ (($ $kargs () () body)
+ `(kseq ,(unparse-cps body)))
+ (($ $kargs names syms body)
+ `(kargs ,names ,syms ,(unparse-cps body)))
+ (($ $kentry ($ $arity req opt rest kw allow-other-keys?) body)
+ `(kentry (,req ,opt ,rest ,kw ,allow-other-keys?)
+ ,(unparse-cps body)))
+
+ ;; Calls.
+ (($ $continue k exp)
+ `(continue ,k ,(unparse-cps exp)))
+ (($ $var sym)
+ `(var ,sym))
+ (($ $void)
+ `(void))
+ (($ $const val)
+ `(const ,val))
+ (($ $prim name)
+ `(prim ,name))
+ (($ $fun meta self free entries)
+ `(fun ,meta ,self ,free ,(map unparse-cps entries)))
+ (($ $letrec names syms funs body)
+ `(letrec ,(map (lambda (name sym fun)
+ (list name sym (unparse-cps fun)))
+ names syms funs)
+ ,(unparse-cps body)))
+ (($ $call proc args)
+ `(call ,proc ,@args))
+ (($ $primcall name args)
+ `(primcall ,name ,@args))
+ (($ $values args)
+ `(values ,@args))
+ (($ $prompt escape? tag handler)
+ `(prompt ,escape? ,tag ,handler))
+ (_
+ (error "unexpected cps" exp))))
+
diff --git a/module/language/cps/arities.scm b/module/language/cps/arities.scm
index a28ed65..bfae9b5 100644
--- a/module/language/cps/arities.scm
+++ b/module/language/cps/arities.scm
@@ -29,13 +29,6 @@
#:use-module (language cps primitives)
#:export (fix-arities))
-(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 (fold-conts proc seed term)
(match term
(($ $fun meta self free entries)
@@ -60,10 +53,10 @@
conts)
body))
- (($ $cont src sym ($ $kargs names syms body))
+ (($ $cont sym src ($ $kargs names syms body))
(fold-conts proc (proc term seed) body))
- (($ $cont src sym ($ $kentry arity body))
+ (($ $cont sym src ($ $kentry arity body))
(fold-conts proc (proc term seed) body))
(($ $cont)
@@ -80,121 +73,121 @@
(match conts
((cont . conts)
(match cont
- (($ $cont _ (? (cut eq? <> k))) cont)
+ (($ $cont (? (cut eq? <> k))) cont)
(else (lp conts))))))))
-(define (fix-arities term)
- (let ((conts (fold-conts cons '() term)))
- (define (adapt nvals k proc)
+(define (fix-arities fun)
+ (let ((conts (fold-conts cons '() fun)))
+ (define (visit-term term)
+ (rewrite-cps-term term
+ (($ $letk conts body)
+ ($letk ,(map visit-cont conts) ,(visit-term body)))
+ (($ $letrec names syms funs body)
+ ($letrec names syms (map visit-fun funs) ,(visit-term body)))
+ (($ $continue k exp)
+ ,(visit-call k exp))))
+
+ (define (adapt-call nvals k exp)
(let ((cont (lookup-cont conts k)))
(match nvals
(0
- (match cont
- (#f ;(proc k)
- ;; XXX I'm not sure if this is desirable, but it's
- ;; needed to handle things like 'define!' and 'box-set!'
- ;; in tail position.
- (let ((kvoid (gensym "kvoid"))
- (kunspec (gensym "kunspec"))
- (unspec (gensym "unspec")))
- (make-$let1v
- #f kunspec unspec unspec
- (make-$continue k (make-$primcall 'return (list unspec)))
- (make-$let1k
- (make-$cont #f kvoid
- (make-$kargs '() '()
- (make-$continue kunspec
(make-$void))))
- (proc kvoid)))))
+ (rewrite-cps-term cont
+ (#f
+ ,(let-gensyms (kvoid kunspec unspec)
+ (build-cps-term
+ ($letk* ((kunspec #f ($kargs (unspec) (unspec)
+ ($continue k
+ ($primcall 'return (unspec)))))
+ (kvoid #f ($kargs () ()
+ ($continue kunspec ($values ())))))
+ ($continue kvoid ,exp)))))
(($ $cont _ _ ($ $ktrunc ($ $arity () () #f () #f) kseq))
- (proc kseq))
+ ($continue kseq ,exp))
(($ $cont _ _ ($ $kargs () () _))
- (proc k))
- (($ $cont src k)
- (let ((k* (gensym "kvoid")))
- (make-$letk
- (list (make-$cont src k*
- (make-$kargs '() '()
- (make-$continue k (make-$void)))))
- (proc k*))))))
+ ($continue k ,exp))
+ (($ $cont k src)
+ ,(let-gensyms (k*)
+ (build-cps-term
+ ($letk ((k* src ($kargs () () ($continue k ($void)))))
+ ($continue k* ,exp)))))))
(1
(let ((drop-result
(lambda (src kseq)
- (let ((k* (gensym "kdrop")))
- (make-$let1v src k* 'drop (gensym "vdrop")
- (make-$continue kseq (make-$values '()))
- (proc k*))))))
- (match cont
+ (let-gensyms (k* drop)
+ (build-cps-term
+ ($letk ((k* src ($kargs ('drop) (drop)
+ ($continue kseq ($values ())))))
+ ($continue k* ,exp)))))))
+ (rewrite-cps-term cont
(#f
- (let ((k* (gensym "ktail"))
- (v (gensym "v")))
- (make-$let1v #f k* v v
- (make-$continue k (make-$primcall 'return (list
v)))
- (proc k*))))
- (($ $cont src _ ($ $ktrunc ($ $arity () () #f () #f) kseq))
- (drop-result src kseq))
- (($ $cont src kseq ($ $kargs () () _))
- (drop-result src kseq))
+ ,(rewrite-cps-term exp
+ (($var sym)
+ ($continue 'ktail ($primcall 'return (sym))))
+ (_
+ ,(let-gensyms (k* v)
+ (build-cps-term
+ ($letk ((k* #f ($kargs (v) (v)
+ ($continue k
+ ($primcall 'return (v))))))
+ ($continue k* ,exp)))))))
+ (($ $cont _ src ($ $ktrunc ($ $arity () () #f () #f) kseq))
+ ,(drop-result src kseq))
+ (($ $cont kseq src ($ $kargs () () _))
+ ,(drop-result src kseq))
(($ $cont)
- (proc k))))))))
+ ($continue k ,exp))))))))
- (let lp ((term term))
- (match term
- (($ $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))))
- (($ $cont src sym ($ $kentry arity body))
- (make-$cont src sym (make-$kentry arity (lp body))))
- (($ $cont)
- term)
+ (define (visit-call k exp)
+ (rewrite-cps-term exp
+ ((or ($ $void)
+ ($ $const)
+ ($ $prim)
+ ($ $var))
+ ,(adapt-call 1 k exp))
+ (($ $fun)
+ ,(adapt-call 1 k (visit-fun exp)))
+ (($ $call)
+ ;; In general, calls have unknown return arity. For that
+ ;; reason every non-tail call has an implicit adaptor
+ ;; continuation to adapt the return to the target
+ ;; continuation, and we don't need to do any adapting here.
+ ($continue k ,exp))
+ (($ $primcall 'return (arg))
+ ;; Primcalls to return are in tail position.
+ ($continue 'ktail ,exp))
+ (($ $primcall (? (lambda (name)
+ (and (not (prim-rtl-instruction name))
+ (not (branching-primitive? name))))))
+ ($continue k ,exp))
+ (($ $primcall name args)
+ ,(match (prim-arity name)
+ ((out . in)
+ (if (= in (length args))
+ (adapt-call out k exp)
+ (let-gensyms (k* p*)
+ (build-cps-term
+ ($letk ((k* #f ($kargs ('prim) (p*)
+ ($continue k ($call p* args)))))
+ ($continue k* ($prim name)))))))))
+ (($ $values)
+ ;; Values nodes are inserted by CPS optimization passes, so
+ ;; we assume they are correct.
+ ($continue k ,exp))
+ (($ $prompt)
+ ($continue k ,exp))))
+
+ (define (visit-fun fun)
+ (rewrite-cps-call fun
(($ $fun meta self free entries)
- (make-$fun meta self free (map lp entries)))
- (($ $letrec names syms funs body)
- (make-$letrec names syms (map lp funs) (lp body)))
- (($ $continue k exp)
- (match exp
- (($ $var sym)
- (if (eq? k 'ktail)
- (make-$continue k (make-$primcall 'return (list sym)))
- (adapt 1 k (lambda (k) (make-$continue k exp)))))
- ((or ($ $void)
- ($ $const)
- ($ $prim))
- (adapt 1 k (lambda (k) (make-$continue k exp))))
- (($ $fun)
- (adapt 1 k (lambda (k) (make-$continue k (lp exp)))))
- (($ $call)
- ;; In general, calls have unknown return arity. For that
- ;; reason every non-tail call has an implicit adaptor
- ;; continuation to adapt the return to the target
- ;; continuation, and we don't need to do any adapting here.
- term)
- (($ $primcall 'return (arg))
- ;; Primcalls to return are in tail position.
- (make-$continue 'ktail exp))
- (($ $primcall name args)
- (if (or (prim-rtl-instruction name)
- (branching-primitive? name))
- (match (prim-arity name)
- ((out . in)
- (adapt
- out
- k
- (if (= in (length args))
- (cut make-$continue <> exp)
- (lambda (k)
- (let ((k* (gensym "kprim"))
- (p* (gensym (symbol->string name))))
- (make-$let1v #f k* 'prim p*
- (make-$continue k (make-$call p*
args))
- (make-$continue k* (make-$prim
name)))))))))
- ;; If it's not implemented in the VM, it will be
- ;; converted into a normal procedure call, so we don't
- ;; need to adapt.
- term))
- (($ $values)
- ;; Values nodes are inserted by CPS optimization passes, so
- ;; we assume they are correct.
- term)
- (($ $prompt)
- term)))))))
+ ($fun meta self free ,(map visit-cont entries)))))
+
+ (define (visit-cont cont)
+ (rewrite-cps-cont cont
+ (($ $cont sym src ($ $kargs names syms body))
+ (sym src ($kargs names syms ,(visit-term body))))
+ (($ $cont sym src ($ $kentry arity body))
+ (sym src ($kentry ,arity ,(visit-cont body))))
+ (($ $cont)
+ ,cont)))
+
+ (visit-fun fun)))
diff --git a/module/language/cps/closure-conversion.scm
b/module/language/cps/closure-conversion.scm
index d62714f..5a49b08 100644
--- a/module/language/cps/closure-conversion.scm
+++ b/module/language/cps/closure-conversion.scm
@@ -115,15 +115,15 @@ convert functions to flat closures."
(($ $letk conts body)
(receive (conts free) (cc* conts self bound)
(receive (body free*) (cc body self bound)
- (values (make-$letk conts body)
+ (values (build-cps-term ($letk ,conts ,body))
(union free free*)))))
- (($ $cont src sym ($ $kargs names syms body))
+ (($ $cont sym src ($ $kargs names syms body))
(receive (body free) (cc body self (append syms bound))
(values (build-cps-cont (sym src ($kargs names syms ,body)))
free)))
- (($ $cont src sym ($ $kentry arity body))
+ (($ $cont sym src ($ $kentry arity body))
(receive (body free) (cc body self bound)
(values (build-cps-cont (sym src ($kentry ,arity ,body)))
free)))
@@ -221,30 +221,37 @@ convert functions to flat closures."
;; Convert the slot arguments of 'free-ref' primcalls from symbols to
;; indices.
(define (convert-to-indices exp)
- (let lpfree ((exp exp) (free '()))
- (let lp ((exp exp))
- (match exp
+ (define (visit-fun-entry entry free)
+ (define (free-index sym)
+ (or (list-index (cut eq? <> sym) free)
+ (error "free variable not found!" sym free)))
+ (define (visit-term term)
+ (rewrite-cps-term term
(($ $letk conts body)
- (make-$letk (map lp conts) (lp body)))
- (($ $cont src sym ($ $kargs names syms body))
- (build-cps-cont (sym src ($kargs names syms ,(lp body)))))
- (($ $cont src sym ($ $kentry arity 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)
+ ($letk ,(map visit-cont conts) ,(visit-term body)))
(($ $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))))))))
+ ,(let-gensyms (idx)
+ (build-cps-term
+ ($letconst (('idx idx (free-index sym)))
+ ($continue k ($primcall 'free-ref (closure idx)))))))
(($ $continue k ($ $fun meta self free entries))
- (build-cps-term
- ($continue k ($fun meta self free
- ,(map (cut lpfree <> free) entries)))))
- (($ $continue) exp)))))
+ ($continue k
+ ($fun meta self free
+ ,(map (cut visit-fun-entry <> free) entries))))
+ (($ $continue)
+ ,term)))
+ (define (visit-cont cont)
+ (rewrite-cps-cont cont
+ (($ $cont sym src ($ $kargs names syms body))
+ (sym src ($kargs names syms ,(visit-term body))))
+ (($ $cont sym src ($ $kentry arity body))
+ (sym src ($kentry ,arity ,(visit-cont body))))
+ ;; Other kinds of continuations don't bind values and don't have
+ ;; bodies.
+ (($ $cont)
+ ,cont)))
+ (visit-cont entry))
+ (visit-fun-entry exp '()))
(define (convert-closures exp)
"Convert free reference in @var{exp} to primcalls to @code{free-ref},
@@ -254,4 +261,5 @@ and allocate and initialize flat closures."
(receive (entries free) (cc* entries #f '())
(unless (null? free)
(error "Expected no free vars in toplevel thunk" exp entries free))
- (make-$fun meta self '() (map convert-to-indices entries))))))
+ (build-cps-call
+ ($fun meta self '() ,(map convert-to-indices entries)))))))
diff --git a/module/language/cps/compile-rtl.scm
b/module/language/cps/compile-rtl.scm
index 5a4dfef..c0fc9b8 100644
--- a/module/language/cps/compile-rtl.scm
+++ b/module/language/cps/compile-rtl.scm
@@ -79,10 +79,10 @@
(visit-funs proc body)
(for-each (lambda (cont) (visit-funs proc cont)) conts))
- (($ $cont src sym ($ $kargs names syms body))
+ (($ $cont sym src ($ $kargs names syms body))
(visit-funs proc body))
- (($ $cont src sym ($ $kentry arity body))
+ (($ $cont sym src ($ $kentry arity body))
(visit-funs proc body))
(_ (values))))
@@ -95,7 +95,7 @@
(fold-conts proc seed body)
conts))
- (($ $cont src k cont)
+ (($ $cont k src cont)
(fold-conts proc (proc k src cont seed) cont))
(($ $kargs names syms body)
@@ -342,7 +342,7 @@
(call-with-values (lambda () (allocate-slots self body))
(lambda (moves slots nlocals)
(match body
- (($ $cont src k
+ (($ $cont k src
($ $kentry ($ $arity req opt rest kw allow-other-keys?) body))
(let ((kw-indices (map (match-lambda
((key name sym)
diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm
index 4c51aba..84f6f09 100644
--- a/module/language/cps/dfg.scm
+++ b/module/language/cps/dfg.scm
@@ -97,7 +97,7 @@
;; Treat the entry continuation as its own parent, and as a hack
;; declare "ktail" as being a child of the entry.
- (($ $cont src k ($ $kentry arity body))
+ (($ $cont k src ($ $kentry arity body))
(when exp-k
(error "$kentry not at top level?"))
(add-def! k k)
@@ -107,7 +107,7 @@
(link-parent! 'ktail k)
(visit body k))
- (($ $cont src k cont)
+ (($ $cont k src cont)
(def! k)
(hashq-set! conts k cont)
(link-parent! k exp-k)
diff --git a/module/language/cps/reify-primitives.scm
b/module/language/cps/reify-primitives.scm
index 378cb89..a923391 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -36,21 +36,6 @@
;; FIXME: Some of these common utilities should be factored elsewhere,
;; perhaps (language cps).
-(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-let src val-proc body-proc)
- (let ((k (gensym "k")) (sym (gensym "v")))
- (make-$let1v src k 'tmp sym (body-proc sym) (val-proc k))))
-
-(define (make-$let1c src name sym val cont-body)
- (let ((k (gensym "kconst")))
- (make-$let1v src k name sym cont-body (make-$continue k (make-$const
val)))))
-
(define (fold-conts proc seed term)
(match term
(($ $fun meta self free entries)
@@ -75,10 +60,10 @@
conts)
body))
- (($ $cont src sym ($ $kargs names syms body))
+ (($ $cont sym src ($ $kargs names syms body))
(fold-conts proc (proc term seed) body))
- (($ $cont src sym ($ $kentry arity body))
+ (($ $cont sym src ($ $kentry arity body))
(fold-conts proc (proc term seed) body))
(($ $cont)
@@ -97,76 +82,66 @@
(define (build-cont-table term)
(fold-conts (lambda (cont table)
(match cont
- (($ $cont src k cont)
+ (($ $cont k src cont)
(vhash-consq k cont table))))
vlist-null
term))
(define (module-box src module name public? bound? val-proc)
- (let ((module-sym (gensym "module"))
- (name-sym (gensym "name"))
- (public?-sym (gensym "public?"))
- (bound?-sym (gensym "bound?")))
- (make-$let1c
- src 'module module-sym module
- (make-$let1c
- src 'name name-sym name
- (make-$let1c
- src 'public? public?-sym public?
- (make-$let1c
- src 'bound? bound?-sym bound?
- (make-let
- src
- (lambda (k)
- (make-$continue k (make-$primcall
- 'cached-module-box
- (list module-sym name-sym public?-sym
bound?-sym))))
- val-proc)))))))
+ (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 (primitive-ref name k)
(module-box #f '(guile) name #f #t
(lambda (box)
- (make-$continue k (make-$primcall 'box-ref (list box))))))
+ (build-cps-term
+ ($continue k ($primcall 'box-ref (box)))))))
(define (reify-primitives fun)
(let ((conts (build-cont-table fun)))
(define (visit-fun term)
- (match term
+ (rewrite-cps-call term
(($ $fun meta self free entries)
- (make-$fun meta self free (map visit-entry entries)))))
- (define (visit-entry term)
- (match term
- (($ $cont src sym ($ $kentry arity body))
- (make-$cont src sym
- (make-$kentry arity (visit-cont body))))))
- (define (visit-cont term)
- (match term
- (($ $cont src sym ($ $kargs names syms body))
- (make-$cont src sym (make-$kargs names syms (visit-term body))))
- (_ term)))
+ ($fun meta self free ,(map visit-cont entries)))))
+ (define (visit-cont cont)
+ (rewrite-cps-cont cont
+ (($ $cont sym src ($ $kargs names syms body))
+ (sym src ($kargs names syms ,(visit-term body))))
+ (($ $cont sym src ($ $kentry arity body))
+ (sym src ($kentry ,arity ,(visit-cont body))))
+ (($ $cont)
+ ,cont)))
(define (visit-term term)
- (match term
+ (rewrite-cps-term term
(($ $letk conts body)
- (make-$letk (map visit-cont conts) (visit-term body)))
+ ($letk ,(map visit-cont conts) ,(visit-term body)))
(($ $continue k exp)
- (match exp
- (($ $prim name)
- (match (lookup-cont conts k)
- (($ $kargs (_)) (primitive-ref name k))
- (_ (make-$continue k (make-$void)))))
- (($ $fun)
- (make-$continue k (visit-fun exp)))
- (($ $primcall name args)
- (cond
- ((or (prim-rtl-instruction name) (branching-primitive? name))
- ;; Assume arities are correct.
- term)
- (else
- (make-let #f
- (lambda (k)
- (primitive-ref name k))
- (lambda (v)
- (make-$continue k (make-$call v args)))))))
- (_ term)))))
+ ,(match exp
+ (($ $prim name)
+ (match (lookup-cont conts k)
+ (($ $kargs (_)) (primitive-ref name k))
+ (_ (build-cps-term ($continue k ($void))))))
+ (($ $fun)
+ (build-cps-term ($continue k ,(visit-fun exp))))
+ (($ $primcall name args)
+ (cond
+ ((or (prim-rtl-instruction name) (branching-primitive? name))
+ ;; Assume arities are correct.
+ term)
+ (else
+ (let-gensyms (k* v)
+ (build-cps-term
+ ($letk ((k* #f ($kargs (v) (v)
+ ($continue k ($call v args)))))
+ ,(primitive-ref name k*)))))))
+ (_ term)))))
(visit-fun fun)))
diff --git a/module/language/cps/slot-allocation.scm
b/module/language/cps/slot-allocation.scm
index 00180d4..0aaa2c1 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -294,7 +294,7 @@ are comparable with eqv?. A tmp slot may be used."
(for-each (cut visit <> exp-k live-set) conts))
live-set)
- (($ $cont src k cont)
+ (($ $cont k src cont)
(hashq-set! visited k #t)
(visit cont k live-set))
diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm
index eed74dd..8b64917 100644
--- a/module/language/cps/verify.scm
+++ b/module/language/cps/verify.scm
@@ -55,7 +55,7 @@
(v-env '()))
(match exp
;; Continuations.
- (($ $letk (($ $cont src k cont) ...) body)
+ (($ $letk (($ $cont k src cont) ...) body)
(let ((k-env (add-env k k-env)))
(for-each check-src src)
(for-each (match-lambda
@@ -103,8 +103,8 @@
(error "entry should be symbol" k))
(for-each
(match-lambda
- (($ $cont src* k*
- ($ $kentry arity ($ $cont src k ($ $kargs names syms body))))
+ (($ $cont k* src*
+ ($ $kentry arity ($ $cont k src ($ $kargs names syms body))))
(check-src src*)
(check-src src)
(match arity
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-197-g77ee8b9,
Andy Wingo <=