[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, wip-cps-bis, updated. v2.1.0-199-g5b8e
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, wip-cps-bis, updated. v2.1.0-199-g5b8e969 |
|
Date: |
Fri, 16 Aug 2013 14:09:47 +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=5b8e9697631af078ab217a2098522e09126321b7
The branch, wip-cps-bis has been updated
via 5b8e9697631af078ab217a2098522e09126321b7 (commit)
from 45c931686dd96ccf2de08f299bbba256a9774e3b (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 5b8e9697631af078ab217a2098522e09126321b7
Author: Andy Wingo <address@hidden>
Date: Fri Aug 16 16:13:35 2013 +0200
$kentry binds a $ktail
* module/language/cps.scm ($ktail): New continuation kind.
($kentry): Bind a $ktail. This results in each entry having a
labelled return continuation.
(build-cont-body, parse-cps, unparse-cps)
(fold-conts, fold-local-conts): Add $ktail support.
* module/language/tree-il/compile-cps.scm (convert, cps-convert/thunk):
Add $ktail to the created $kentry forms.
* module/language/cps/dfg.scm (build-cont-table)
(build-local-cont-table): New public interfaces.
(lookup-cont, dfg-local-cont-table): Change to have lookup-cont take a
cont table instead of a DFG, and add an accessor to get the DFG's cont
table.
(compute-dfg): Fix the ktail hacks by properly handling $ktail.
* module/language/cps/slot-allocation.scm (allocate-slots): Adapt to
ktail change, and match tail continuations by type $ktail.
* module/language/cps/closure-conversion.scm (convert-to-indices, cc):
* module/language/cps/verify.scm (verify-cps): Update for ktail.
* module/language/cps/reify-primitives.scm (reify-primitives):
* module/language/cps/arities.scm (fix-entry-arities):
* module/language/cps/compile-rtl.scm (emit-rtl-sequence)
(compile-fun): Update for ktail. Use the DFG's cont table.
-----------------------------------------------------------------------
Summary of changes:
module/language/cps.scm | 52 +++++++-----
module/language/cps/arities.scm | 116 +++++++++++++---------------
module/language/cps/closure-conversion.scm | 8 +-
module/language/cps/compile-rtl.scm | 36 ++++-----
module/language/cps/dfg.scm | 64 +++++++++-------
module/language/cps/reify-primitives.scm | 21 +----
module/language/cps/slot-allocation.scm | 82 ++++++++++----------
module/language/cps/verify.scm | 7 +-
module/language/tree-il/compile-cps.scm | 50 ++++++------
9 files changed, 219 insertions(+), 217 deletions(-)
diff --git a/module/language/cps.scm b/module/language/cps.scm
index d8c30a3..f0cf058 100644
--- a/module/language/cps.scm
+++ b/module/language/cps.scm
@@ -51,7 +51,7 @@
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
#:export (;; Continuations.
- $letk $cont $kif $ktrunc $kargs $kentry
+ $letk $cont $kif $ktrunc $kargs $kentry $ktail
;; Calls.
$continue
@@ -61,7 +61,7 @@
;; Constructors.
make-$letk make-$cont
- make-$kif make-$ktrunc make-$kargs make-$kentry
+ make-$kif make-$ktrunc make-$kargs make-$kentry make-$ktail
make-$fun make-$arity make-$letrec
@@ -120,7 +120,8 @@
(define-cps-type $kif kt kf)
(define-cps-type $ktrunc arity k)
(define-cps-type $kargs names syms body)
-(define-cps-type $kentry arity cont)
+(define-cps-type $kentry arity tail cont)
+(define-cps-type $ktail)
;; Calls.
(define-cps-type $continue k exp)
@@ -147,6 +148,7 @@
;; (put '$letconst 'scheme-indent-function 1)
;; (put '$continue 'scheme-indent-function 1)
;; (put '$kargs 'scheme-indent-function 2)
+;; (put '$kentry 'scheme-indent-function 1)
(define-syntax let-gensyms
(syntax-rules ()
@@ -161,7 +163,7 @@
(make-$arity req opt rest kw allow-other-keys?))))
(define-syntax build-cont-body
- (syntax-rules (unquote $kif $ktrunc $kargs $kentry)
+ (syntax-rules (unquote $kif $ktrunc $kargs $kentry $ktail)
((_ (unquote exp))
exp)
((_ ($kif kt kf))
@@ -172,8 +174,11 @@
(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)))))
+ ((_ ($kentry arity tail cont))
+ (make-$kentry (build-arity arity) (build-cps-cont tail)
+ (build-cps-cont cont)))
+ ((_ ($ktail))
+ (make-$ktail))))
(define-syntax build-cps-cont
(syntax-rules (unquote)
@@ -261,9 +266,10 @@
(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)
+ (('kentry (req opt rest kw allow-other-keys?) tail body)
(build-cont-body
- ($kentry (req opt rest kw allow-other-keys?) ,(parse-cps body))))
+ ($kentry (req opt rest kw allow-other-keys?)
+ ,(parse-cps tail) ,(parse-cps body))))
(('kseq body)
(build-cont-body ($kargs () () ,(parse-cps body))))
@@ -312,9 +318,11 @@
`(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 ($ $arity req opt rest kw allow-other-keys?) tail body)
`(kentry (,req ,opt ,rest ,kw ,allow-other-keys?)
- ,(unparse-cps body)))
+ ,(unparse-cps tail) ,(unparse-cps body)))
+ (($ $ktail)
+ `(ktail))
;; Calls.
(($ $continue k exp)
@@ -348,14 +356,14 @@
(define (fold-conts proc seed fun)
(define (cont-folder cont seed)
(match cont
- (($ $cont k src ($ $kargs names syms body))
- (term-folder body (proc cont seed)))
+ (($ $cont k src (and cont ($ $kargs names syms body)))
+ (term-folder body (proc k src cont seed)))
- (($ $cont k src ($ $kentry arity body))
- (cont-folder body (proc cont seed)))
+ (($ $cont k src (and cont ($ $kentry arity tail body)))
+ (cont-folder body (cont-folder tail (proc k src cont seed))))
- (($ $cont)
- (proc cont seed))))
+ (($ $cont k src cont)
+ (proc k src cont seed))))
(define (fun-folder fun seed)
(match fun
@@ -380,14 +388,14 @@
(define (fold-local-conts proc seed cont)
(define (cont-folder cont seed)
(match cont
- (($ $cont k src ($ $kargs names syms body))
- (term-folder body (proc cont seed)))
+ (($ $cont k src (and cont ($ $kargs names syms body)))
+ (term-folder body (proc k src cont seed)))
- (($ $cont k src ($ $kentry arity body))
- (cont-folder body (proc cont seed)))
+ (($ $cont k src (and cont ($ $kentry arity tail body)))
+ (cont-folder body (cont-folder tail (proc k src cont seed))))
- (($ $cont)
- (proc cont seed))))
+ (($ $cont k src cont)
+ (proc k src cont seed))))
(define (term-folder term seed)
(match term
diff --git a/module/language/cps/arities.scm b/module/language/cps/arities.scm
index b89eef6..85dcff1 100644
--- a/module/language/cps/arities.scm
+++ b/module/language/cps/arities.scm
@@ -26,20 +26,15 @@
#:use-module ((srfi srfi-1) #:select (fold))
#:use-module (srfi srfi-26)
#:use-module (language cps)
+ #:use-module (language cps dfg)
#:use-module (language cps primitives)
#:export (fix-arities))
-(define (lookup-cont conts k)
- (and (not (eq? k 'ktail))
- (let lp ((conts conts))
- (match conts
- ((cont . conts)
- (match cont
- (($ $cont (? (cut eq? <> k))) cont)
- (else (lp conts))))))))
-
(define (fix-entry-arities entry)
- (let ((conts (fold-local-conts cons '() entry)))
+ (let ((conts (build-local-cont-table entry))
+ (ktail (match entry
+ (($ $cont _ _ ($ $kentry _ ($ $cont ktail _ ($ $ktail))))
+ ktail))))
(define (visit-term term)
(rewrite-cps-term term
(($ $letk conts body)
@@ -50,54 +45,53 @@
,(visit-call k exp))))
(define (adapt-call nvals k exp)
- (let ((cont (lookup-cont conts k)))
- (match nvals
- (0
- (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))
- ($continue kseq ,exp))
- (($ $cont _ _ ($ $kargs () () _))
- ($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-gensyms (k* drop)
- (build-cps-term
- ($letk ((k* src ($kargs ('drop) (drop)
- ($continue kseq ($values ())))))
- ($continue k* ,exp)))))))
- (rewrite-cps-term cont
- (#f
- ,(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)
- ($continue k ,exp))))))))
+ (match nvals
+ (0
+ (rewrite-cps-term (lookup-cont k conts)
+ (($ $ktail)
+ ,(let-gensyms (kvoid kunspec unspec)
+ (build-cps-term
+ ($letk* ((kunspec #f ($kargs (unspec) (unspec)
+ ($continue k
+ ($primcall 'return (unspec)))))
+ (kvoid #f ($kargs () ()
+ ($continue kunspec ($values ())))))
+ ($continue kvoid ,exp)))))
+ (($ $ktrunc ($ $arity () () #f () #f) kseq)
+ ($continue kseq ,exp))
+ (($ $kargs () () _)
+ ($continue k ,exp))
+ (_
+ ,(let-gensyms (k*)
+ (build-cps-term
+ ($letk ((k* #f ($kargs () () ($continue k ($void)))))
+ ($continue k* ,exp)))))))
+ (1
+ (let ((drop-result
+ (lambda (kseq)
+ (let-gensyms (k* drop)
+ (build-cps-term
+ ($letk ((k* #f ($kargs ('drop) (drop)
+ ($continue kseq ($values ())))))
+ ($continue k* ,exp)))))))
+ (rewrite-cps-term (lookup-cont k conts)
+ (($ $ktail)
+ ,(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)))))))
+ (($ $ktrunc ($ $arity () () #f () #f) kseq)
+ ,(drop-result kseq))
+ (($ $kargs () () _)
+ ,(drop-result k))
+ (_
+ ($continue k ,exp)))))))
(define (visit-call k exp)
(rewrite-cps-term exp
@@ -116,7 +110,7 @@
($continue k ,exp))
(($ $primcall 'return (arg))
;; Primcalls to return are in tail position.
- ($continue 'ktail ,exp))
+ ($continue ktail ,exp))
(($ $primcall (? (lambda (name)
(and (not (prim-rtl-instruction name))
(not (branching-primitive? name))))))
@@ -146,8 +140,8 @@
,cont)))
(rewrite-cps-cont entry
- (($ $cont sym src ($ $kentry arity body))
- (sym src ($kentry ,arity ,(visit-cont body)))))))
+ (($ $cont sym src ($ $kentry arity tail body))
+ (sym src ($kentry ,arity ,tail ,(visit-cont body)))))))
(define (fix-arities fun)
(rewrite-cps-call fun
diff --git a/module/language/cps/closure-conversion.scm
b/module/language/cps/closure-conversion.scm
index 5a49b08..ddf6e9f 100644
--- a/module/language/cps/closure-conversion.scm
+++ b/module/language/cps/closure-conversion.scm
@@ -123,9 +123,9 @@ convert functions to flat closures."
(values (build-cps-cont (sym src ($kargs names syms ,body)))
free)))
- (($ $cont sym src ($ $kentry arity body))
+ (($ $cont sym src ($ $kentry arity tail body))
(receive (body free) (cc body self bound)
- (values (build-cps-cont (sym src ($kentry ,arity ,body)))
+ (values (build-cps-cont (sym src ($kentry ,arity ,tail ,body)))
free)))
(($ $cont)
@@ -244,8 +244,8 @@ convert functions to flat closures."
(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 sym src ($ $kentry arity tail body))
+ (sym src ($kentry ,arity ,tail ,(visit-cont body))))
;; Other kinds of continuations don't bind values and don't have
;; bodies.
(($ $cont)
diff --git a/module/language/cps/compile-rtl.scm
b/module/language/cps/compile-rtl.scm
index 901aaea..3d1a6d8 100644
--- a/module/language/cps/compile-rtl.scm
+++ b/module/language/cps/compile-rtl.scm
@@ -27,6 +27,7 @@
#:use-module (language cps)
#:use-module (language cps arities)
#:use-module (language cps closure-conversion)
+ #:use-module (language cps dfg)
#:use-module (language cps primitives)
#:use-module (language cps reify-primitives)
#:use-module (language cps slot-allocation)
@@ -82,20 +83,13 @@
(($ $cont sym src ($ $kargs names syms body))
(visit-funs proc body))
- (($ $cont sym src ($ $kentry arity body))
+ (($ $cont sym src ($ $kentry arity tail body))
(visit-funs proc body))
(_ (values))))
-(define (emit-rtl-sequence exp moves slots nlocals)
- (define (intern-cont! cont table)
- (match cont
- (($ $cont k src cont)
- (hashq-set! table k cont)
- table)))
-
- (let* ((cont-table (fold-local-conts intern-cont! (make-hash-table) exp))
- (rtl '()))
+(define (emit-rtl-sequence exp moves slots nlocals cont-table)
+ (let ((rtl '()))
(define (slot sym)
(lookup-slot sym slots))
@@ -286,8 +280,8 @@
(lp (1+ n) args)))))))
(maybe-jump k))
- (match (hashq-ref cont-table k)
- (#f (emit-tail))
+ (match (lookup-cont k cont-table)
+ (($ $ktail) (emit-tail))
(($ $kargs (name) (sym)) (emit-val sym))
(($ $kargs () ()) (emit-seq))
(($ $kargs names syms) (emit-vals syms))
@@ -296,7 +290,7 @@
(($ $ktrunc ($ $arity req () rest () #f) k)
(emit-trunc (length req) (and rest #t) k))))
- (define (collect-exps cont tail)
+ (define (collect-exps k src cont tail)
(define (find-exp k src term)
(match term
(($ $continue exp-k exp)
@@ -304,7 +298,7 @@
(($ $letk conts body)
(find-exp k src body))))
(match cont
- (($ $cont k src ($ $kargs names syms body))
+ (($ $kargs names syms body)
(find-exp k src body))
(_ tail)))
@@ -324,12 +318,14 @@
(define (emit asm)
(set! rtl (cons asm rtl)))
- (define (emit-fun-entry self body alternate)
- (call-with-values (lambda () (allocate-slots self body))
+ (define (emit-fun-entry self entry alternate)
+ (call-with-values (lambda () (allocate-slots self entry))
(lambda (moves slots nlocals)
- (match body
+ (match entry
(($ $cont k src
- ($ $kentry ($ $arity req opt rest kw allow-other-keys?) body))
+ ($ $kentry ($ $arity req opt rest kw allow-other-keys?)
+ tail
+ body))
(let ((kw-indices (map (match-lambda
((key name sym)
(cons key (lookup-slot sym slots))))
@@ -339,7 +335,9 @@
,kw-indices ,allow-other-keys?
,nlocals
,alternate))
- (for-each emit (emit-rtl-sequence body moves slots nlocals))
+ (for-each emit
+ (emit-rtl-sequence body moves slots nlocals
+ (build-local-cont-table entry)))
(emit `(end-arity))))))))
(define (emit-fun-entries self entries)
diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm
index 84f6f09..4c15b8e 100644
--- a/module/language/cps/dfg.scm
+++ b/module/language/cps/dfg.scm
@@ -27,9 +27,12 @@
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-26)
#:use-module (language cps)
- #:export (compute-dfg
-
+ #:export (build-cont-table
+ build-local-cont-table
lookup-cont
+
+ compute-dfg
+ dfg-local-cont-table
find-constant-value
constant-needs-allocation?
dead-after-def?
@@ -39,12 +42,32 @@
dead-after-branch?
lookup-bound-syms))
+(define (build-cont-table fun)
+ (fold-conts (lambda (k src cont table)
+ (hashq-set! table k cont)
+ table)
+ (make-hash-table)
+ fun))
+
+(define (build-local-cont-table cont)
+ (fold-local-conts (lambda (k src cont table)
+ (hashq-set! table k cont)
+ table)
+ (make-hash-table)
+ cont))
+
+(define (lookup-cont sym conts)
+ (let ((res (hashq-ref conts sym)))
+ (unless res
+ (error "Unknown continuation!" sym (hash-fold acons '() conts)))
+ res))
+
;; Data-flow graph for CPS: both for values and continuations.
(define-record-type $dfg
(make-dfg conts use-maps uplinks)
dfg?
;; hash table of sym -> $cont
- (conts dfg-conts)
+ (conts dfg-local-cont-table)
;; hash table of sym -> $use-map
(use-maps dfg-use-maps)
;; hash table of sym -> $parent-link
@@ -95,16 +118,14 @@
(for-each recur conts)
(recur body))
- ;; Treat the entry continuation as its own parent, and as a hack
- ;; declare "ktail" as being a child of the entry.
- (($ $cont k src ($ $kentry arity body))
+ ;; Treat the entry continuation as its own parent.
+ (($ $cont k src ($ $kentry arity tail body))
(when exp-k
(error "$kentry not at top level?"))
(add-def! k k)
(add-def! self k)
(hashq-set! uplinks k (make-uplink #f 0))
- (add-def! 'ktail k)
- (link-parent! 'ktail k)
+ (visit tail k)
(visit body k))
(($ $cont k src cont)
@@ -124,6 +145,9 @@
(($ $ktrunc arity k)
(use! k))
+ (($ $ktail)
+ #f)
+
(($ $continue k exp)
(use! k)
(match exp
@@ -160,20 +184,6 @@
(error "Unknown lexical!" sym (hash-fold acons '() use-maps)))
res))
-(define (lookup-cont* sym conts)
- (let ((res (hashq-ref conts sym)))
- (unless res
- (error "Unknown continuation!" sym (hash-fold acons '() conts)))
- res))
-
-(define (lookup-cont sym dfg)
- (match dfg
- (($ $dfg conts use-maps uplinks)
- (let ((res (hashq-ref conts sym)))
- (unless res
- (error "Unknown continuation!" sym (hash-fold acons '() conts)))
- res))))
-
(define (find-defining-term sym dfg)
(match dfg
(($ $dfg conts use-maps uplinks)
@@ -181,7 +191,7 @@
(($ $use-map sym def uses)
(match (lookup-use-map def use-maps)
(($ $use-map _ _ (def-exp-k))
- (lookup-cont* def-exp-k conts))
+ (lookup-cont def-exp-k conts))
(else #f)))))))
(define (find-constant-value sym dfg)
@@ -210,7 +220,7 @@
(($ $use-map _ def uses)
(or-map
(lambda (use)
- (match (find-exp (lookup-cont* use conts))
+ (match (find-exp (lookup-cont use conts))
(($ $continue _ ($ $call)) #f)
(($ $continue _ ($ $values)) #f)
(($ $continue _ ($ $primcall 'free-ref (closure slot)))
@@ -274,7 +284,7 @@
(($ $use-map sym def uses)
(and (not (null? uses))
(and-map (lambda (k)
- (match (lookup-cont* k conts)
+ (match (lookup-cont k conts)
(($ $kif) #t)
(_ #f)))
uses)))))))
@@ -285,7 +295,7 @@
(match (lookup-use-map k use-maps)
(($ $use-map sym def (uses ..1))
(map (lambda (kif)
- (match (lookup-cont* kif conts)
+ (match (lookup-cont kif conts)
(($ $kif (? (cut eq? <> k)) kf)
kf)
(($ $kif kt (? (cut eq? <> k)))
@@ -312,6 +322,6 @@
(define (lookup-bound-syms k dfg)
(match dfg
(($ $dfg conts use-maps uplinks)
- (match (lookup-cont* k conts)
+ (match (lookup-cont k conts)
(($ $kargs names syms body)
syms)))))
diff --git a/module/language/cps/reify-primitives.scm
b/module/language/cps/reify-primitives.scm
index fe63b44..f3fdea7 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -29,6 +29,7 @@
#:use-module (ice-9 vlist)
#:use-module ((srfi srfi-1) #:select (fold))
#:use-module (language cps)
+ #:use-module (language cps dfg)
#:use-module (language cps primitives)
#:use-module (language rtl)
#:export (reify-primitives))
@@ -36,19 +37,6 @@
;; FIXME: Some of these common utilities should be factored elsewhere,
;; perhaps (language cps).
-(define (lookup-cont table k)
- (cond
- ((vhash-assq k table) => cdr)
- (else (error "unknown cont" k))))
-
-(define (build-cont-table term)
- (fold-conts (lambda (cont table)
- (match cont
- (($ $cont k src cont)
- (vhash-consq k cont table))))
- vlist-null
- term))
-
(define (module-box src module name public? bound? val-proc)
(let-gensyms (module-sym name-sym public?-sym bound?-sym kbox box)
(build-cps-term
@@ -67,6 +55,7 @@
(build-cps-term
($continue k ($primcall 'box-ref (box)))))))
+;; FIXME: Operate on one function at a time, for efficiency.
(define (reify-primitives fun)
(let ((conts (build-cont-table fun)))
(define (visit-fun term)
@@ -77,8 +66,8 @@
(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 sym src ($ $kentry arity tail body))
+ (sym src ($kentry ,arity ,tail ,(visit-cont body))))
(($ $cont)
,cont)))
(define (visit-term term)
@@ -88,7 +77,7 @@
(($ $continue k exp)
,(match exp
(($ $prim name)
- (match (lookup-cont conts k)
+ (match (lookup-cont k conts)
(($ $kargs (_)) (primitive-ref name k))
(_ (build-cps-term ($continue k ($void))))))
(($ $fun)
diff --git a/module/language/cps/slot-allocation.scm
b/module/language/cps/slot-allocation.scm
index 0aaa2c1..d071bd2 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -212,7 +212,7 @@ are comparable with eqv?. A tmp slot may be used."
(nlocals 0)
(nargs (match exp
(($ $cont _ _
- ($ $kentry _ ($ $cont _ _ ($ $kargs names syms))))
+ ($ $kentry _ _ ($ $cont _ _ ($ $kargs names syms))))
(length syms))))
(visited (make-hash-table))
(allocation (make-hash-table))
@@ -298,7 +298,7 @@ are comparable with eqv?. A tmp slot may be used."
(hashq-set! visited k #t)
(visit cont k live-set))
- (($ $kentry arity body)
+ (($ $kentry arity tail body)
(visit body exp-k (allocate! self exp-k 0 live-set)))
(($ $kargs names syms body)
@@ -312,36 +312,34 @@ are comparable with eqv?. A tmp slot may be used."
(use sym live-set))
(($ $continue k ($ $call proc args))
- (cond
- ((eq? k 'ktail)
- (let ((tail-nlocals (1+ (length args))))
- (set! nlocals (max nlocals tail-nlocals))
- (parallel-move! exp-k
- (map (cut lookup-slot <> allocation)
- (cons proc args))
- live-set (fold use live-set (cons proc args))
- (iota tail-nlocals))))
- (else
- (let ((live-set
- (fold use
- (use proc (allocate-frame! exp-k (length args)
live-set))
- args)))
- (match (lookup-cont k dfg)
- (($ $ktrunc arity kargs)
- (let* ((proc-slot (lookup-call-proc-slot exp-k allocation))
- (dst-syms (lookup-bound-syms kargs dfg))
- (nvals (length dst-syms))
- (src-slots (map (cut + proc-slot 1 <>) (iota nvals)))
- (live-set* (fold (cut allocate! <> kargs <> <>)
- live-set dst-syms src-slots))
- (dst-slots (map (cut lookup-slot <> allocation)
- dst-syms)))
- (parallel-move! exp-k
- src-slots
- live-set live-set*
- dst-slots)))
- (else
- live-set))))))
+ (match (lookup-cont k (dfg-local-cont-table dfg))
+ (($ $ktail)
+ (let ((tail-nlocals (1+ (length args))))
+ (set! nlocals (max nlocals tail-nlocals))
+ (parallel-move! exp-k
+ (map (cut lookup-slot <> allocation)
+ (cons proc args))
+ live-set (fold use live-set (cons proc args))
+ (iota tail-nlocals))))
+ (($ $ktrunc arity kargs)
+ (let* ((live-set
+ (fold use
+ (use proc
+ (allocate-frame! exp-k (length args) live-set))
+ args))
+ (proc-slot (lookup-call-proc-slot exp-k allocation))
+ (dst-syms (lookup-bound-syms kargs dfg))
+ (nvals (length dst-syms))
+ (src-slots (map (cut + proc-slot 1 <>) (iota nvals)))
+ (live-set* (fold (cut allocate! <> kargs <> <>)
+ live-set dst-syms src-slots))
+ (dst-slots (map (cut lookup-slot <> allocation)
+ dst-syms)))
+ (parallel-move! exp-k src-slots live-set live-set* dst-slots)))
+ (else
+ (fold use
+ (use proc (allocate-frame! exp-k (length args) live-set))
+ args))))
(($ $continue k ($ $primcall name args))
(fold use live-set args))
@@ -349,15 +347,17 @@ are comparable with eqv?. A tmp slot may be used."
(($ $continue k ($ $values args))
(let ((live-set* (fold use live-set args)))
(define (compute-dst-slots)
- (if (eq? k 'ktail)
- (let ((tail-nlocals (1+ (length args))))
- (set! nlocals (max nlocals tail-nlocals))
- (cdr (iota tail-nlocals)))
- (let* ((src-slots (map (cut lookup-slot <> allocation) args))
- (dst-syms (lookup-bound-syms k dfg))
- (dst-live-set (fold (cut allocate! <> k <> <>)
- live-set* dst-syms src-slots)))
- (map (cut lookup-slot <> allocation) dst-syms))))
+ (match (lookup-cont k (dfg-local-cont-table dfg))
+ (($ $ktail)
+ (let ((tail-nlocals (1+ (length args))))
+ (set! nlocals (max nlocals tail-nlocals))
+ (cdr (iota tail-nlocals))))
+ (_
+ (let* ((src-slots (map (cut lookup-slot <> allocation) args))
+ (dst-syms (lookup-bound-syms k dfg))
+ (dst-live-set (fold (cut allocate! <> k <> <>)
+ live-set* dst-syms src-slots)))
+ (map (cut lookup-slot <> allocation) dst-syms)))))
(parallel-move! exp-k
(map (cut lookup-slot <> allocation) args)
diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm
index 8b64917..8460dcc 100644
--- a/module/language/cps/verify.scm
+++ b/module/language/cps/verify.scm
@@ -75,7 +75,8 @@
(unless (list? syms)
(error "syms should be list" names))
(visit body k-env (add-env syms v-env)))
- ;; $kentry is only ever seen in $fun.
+ ;; $kentry is only ever seen in $fun. $ktail is only
+ ;; seen in $kentry.
)
cont)
(visit body k-env v-env)))
@@ -104,7 +105,9 @@
(for-each
(match-lambda
(($ $cont k* src*
- ($ $kentry arity ($ $cont k src ($ $kargs names syms body))))
+ ($ $kentry arity
+ ($ $cont ktail _ ($ $ktail))
+ ($ $cont k src ($ $kargs names syms body))))
(check-src src*)
(check-src src)
(match arity
diff --git a/module/language/tree-il/compile-cps.scm
b/module/language/tree-il/compile-cps.scm
index e0b72bc..180473c 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -233,8 +233,8 @@
(($ <primitive-ref> src name)
(build-cps-term ($continue k ($prim name))))
- (($ <lambda> src meta body)
- ;; FIXME: add src field to fun, add tail field also
+ (($ <lambda> fun-src meta body)
+ ;; FIXME: add src field to fun
(let ()
(define (convert-entries body)
(match body
@@ -246,22 +246,22 @@
'()
arity gensyms inits)))
(cons
- (let-gensyms (kentry kargs)
+ (let-gensyms (kentry ktail 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)))))))
+ ($kentry ,arity
+ (ktail fun-src ($ktail))
+ (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)
(let-gensyms (self)
@@ -270,10 +270,11 @@
($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)))))))
+ ($letk ((kscope fun-src
+ ($kargs () ()
+ ,(parameterize ((current-topbox-scope scope))
+ (convert exp k subst)))))
+ ,(capture-toplevel-scope fun-src scope kscope)))))))
(($ <module-ref> src mod name public?)
(module-box
@@ -518,18 +519,17 @@ indicates that the replacement variable is in a box."
(_ subst)))
(tree-il-fold box-set-vars default-args '() exp))
-(define (cps-convert exp)
- (convert exp 'ktail (build-subst exp)))
-
(define (cps-convert/thunk exp)
(let ((src (tree-il-src exp)))
- (let-gensyms (init kentry kinit)
+ (let-gensyms (init kentry kinit ktail)
(build-cps-call
($fun '() init '()
((kentry src
($kentry ('() '() #f '() #f)
- (kinit src ($kargs () ()
- ,(cps-convert exp)))))))))))
+ (ktail src ($ktail))
+ (kinit src ($kargs () ()
+ ,(convert exp ktail
+ (build-subst 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-199-g5b8e969,
Andy Wingo <=