[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-58-g178a409
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-58-g178a409 |
|
Date: |
Mon, 08 Jul 2013 08:17:44 +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=178a40928ab5221f6ce57c5af1067abe30a342b3
The branch, master has been updated
via 178a40928ab5221f6ce57c5af1067abe30a342b3 (commit)
from 98eaef1b50db626c672646da58645c62407d0c1a (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 178a40928ab5221f6ce57c5af1067abe30a342b3
Author: Andy Wingo <address@hidden>
Date: Sat Jul 6 20:06:02 2013 +0900
<prompt> body and handler are lambdas; add escape-only? field
* module/language/tree-il.scm (<prompt>): Change to have the body and
handler be lambdas, and add an "escape-only?" field. This will make
generic prompts work better in CPS or ANF with the RTL VM, as it
doesn't make sense in that context to capture only part of a frame.
Escape-only prompts can still be fully inlined.
(parse-tree-il, unparse-tree-il): Add escape-only? to the
serialization.
(make-tree-il-folder, pre-post-order): Deal with escape-only?.
* module/language/tree-il/analyze.scm (analyze-lexicals): Handle
escape-only?, and the new expectations for the body and handler.
* module/language/tree-il/canonicalize.scm (canonicalize): Ensure that
the body of an escape-only continuation is a thunk, and that the
handler is always a lambda.
* module/language/tree-il/debug.scm (verify-tree-il): Assert that
escape-only? is a boolean.
* module/language/tree-il/cse.scm (cse):
* module/language/tree-il/effects.scm (make-effects-analyzer):
* module/language/tree-il/peval.scm (peval):
* module/language/tree-il/primitives.scm (*primitive-expand-table*):
* test-suite/tests/peval.test ("partial evaluation"):
* module/language/tree-il/compile-glil.scm (flatten-lambda-case): Adapt
to <prompt> change.
-----------------------------------------------------------------------
Summary of changes:
module/language/scheme/decompile-tree-il.scm | 3 +-
module/language/tree-il.scm | 21 ++++---
module/language/tree-il/analyze.scm | 33 ++++++++----
module/language/tree-il/canonicalize.scm | 71 ++++++++++++++++----------
module/language/tree-il/compile-glil.scm | 29 +++++++----
module/language/tree-il/cse.scm | 4 +-
module/language/tree-il/debug.scm | 4 +-
module/language/tree-il/effects.scm | 2 +-
module/language/tree-il/peval.scm | 59 +++++++++++++++------
module/language/tree-il/primitives.scm | 16 +------
test-suite/tests/peval.test | 36 +++++++------
11 files changed, 166 insertions(+), 112 deletions(-)
diff --git a/module/language/scheme/decompile-tree-il.scm
b/module/language/scheme/decompile-tree-il.scm
index dca969f..74778b4 100644
--- a/module/language/scheme/decompile-tree-il.scm
+++ b/module/language/scheme/decompile-tree-il.scm
@@ -435,7 +435,7 @@
((<prompt> tag body handler)
`(call-with-prompt
,(recurse tag)
- (lambda () ,@(recurse-body body))
+ ,(recurse body)
,(recurse handler)))
@@ -746,7 +746,6 @@
((<prompt> tag body handler)
(primitive 'call-with-prompt)
- (primitive 'lambda)
(recurse tag) (recurse body) (recurse handler))
((<abort> tag args tail)
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 16fdb96..4ae1484 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -39,6 +39,7 @@
<seq> seq? make-seq seq-src seq-head seq-tail
<lambda> lambda? make-lambda lambda-src lambda-meta lambda-body
<lambda-case> lambda-case? make-lambda-case lambda-case-src
+ ;; idea: arity
lambda-case-req lambda-case-opt lambda-case-rest
lambda-case-kw
lambda-case-inits lambda-case-gensyms
lambda-case-body lambda-case-alternate
@@ -46,7 +47,7 @@
<letrec> letrec? make-letrec letrec-src letrec-in-order?
letrec-names letrec-gensyms letrec-vals letrec-body
<fix> fix? make-fix fix-src fix-names fix-gensyms fix-vals fix-body
<let-values> let-values? make-let-values let-values-src
let-values-exp let-values-body
- <prompt> prompt? make-prompt prompt-src prompt-tag prompt-body
prompt-handler
+ <prompt> prompt? make-prompt prompt-src prompt-escape-only?
prompt-tag prompt-body prompt-handler
<abort> abort? make-abort abort-src abort-tag abort-args abort-tail
list->seq
@@ -131,7 +132,7 @@
(define-type (<tree-il> #:common-slots (src) #:printer print-tree-il)
(<fix> names gensyms vals body)
(<let-values> exp body)
- (<prompt> tag body handler)
+ (<prompt> escape-only? tag body handler)
(<abort> tag args tail))
@@ -241,8 +242,9 @@
(('let-values exp body)
(make-let-values loc (retrans exp) (retrans body)))
- (('prompt tag body handler)
- (make-prompt loc (retrans tag) (retrans body) (retrans handler)))
+ (('prompt escape-only? tag body handler)
+ (make-prompt loc escape-only?
+ (retrans tag) (retrans body) (retrans handler)))
(('abort tag args tail)
(make-abort loc (retrans tag) (map retrans args) (retrans tail)))
@@ -319,8 +321,9 @@
(($ <let-values> src exp body)
`(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))
- (($ <prompt> src tag body handler)
- `(prompt ,(unparse-tree-il tag)
+ (($ <prompt> src escape-only? tag body handler)
+ `(prompt ,escape-only?
+ ,(unparse-tree-il tag)
,(unparse-tree-il body)
,(unparse-tree-il handler)))
@@ -389,7 +392,7 @@
(($ <let-values> src exp body)
(let*-values (((seed ...) (foldts exp seed ...)))
(foldts body seed ...)))
- (($ <prompt> src tag body handler)
+ (($ <prompt> src escape-only? tag body handler)
(let*-values (((seed ...) (foldts tag seed ...))
((seed ...) (foldts body seed ...)))
(foldts handler seed ...)))
@@ -479,8 +482,8 @@ This is an implementation of `foldts' as described by Andy
Wingo in
(($ <let-values> src exp body)
(make-let-values src (lp exp) (lp body)))
- (($ <prompt> src tag body handler)
- (make-prompt src (lp tag) (lp body) (lp handler)))
+ (($ <prompt> src escape-only? tag body handler)
+ (make-prompt src escape-only? (lp tag) (lp body) (lp handler)))
(($ <abort> src tag args tail)
(make-abort src (lp tag) (map lp args) (lp tail)))))))
diff --git a/module/language/tree-il/analyze.scm
b/module/language/tree-il/analyze.scm
index ca7cb80..6b6df18 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -337,8 +337,17 @@
((<let-values> exp body)
(lset-union eq? (step exp) (step body)))
- ((<prompt> tag body handler)
- (lset-union eq? (step tag) (step body) (step-tail handler)))
+ ((<prompt> escape-only? tag body handler)
+ (match x
+ ;; Escape-only: the body is inlined.
+ (($ <prompt> _ #t tag
+ ($ <lambda> _ _
+ ($ <lambda-case> _ () #f #f #f () () body #f))
+ ($ <lambda> _ _ handler))
+ (lset-union eq? (step tag) (step body) (step-tail handler)))
+ ;; Full: we make a closure.
+ (($ <prompt> _ #f tag body ($ <lambda> _ _ handler))
+ (lset-union eq? (step tag) (step body) (step-tail handler)))))
((<abort> tag args tail)
(apply lset-union eq? (step tag) (step tail) (map step args)))
@@ -499,14 +508,18 @@
((<let-values> exp body)
(max (recur exp) (recur body)))
- ((<prompt> tag body handler)
- (let ((cont-var (and (lambda-case? handler)
- (pair? (lambda-case-gensyms handler))
- (car (lambda-case-gensyms handler)))))
- (hashq-set! allocation x
- (and cont-var (zero? (hashq-ref refcounts cont-var 0))))
- (max (recur tag) (recur body) (recur handler))))
-
+ ((<prompt> escape-only? tag body handler)
+ (match x
+ ;; Escape-only: the body is inlined.
+ (($ <prompt> _ #t tag
+ ($ <lambda> _ _
+ ($ <lambda-case> _ () #f #f #f () () body #f))
+ ($ <lambda> _ _ handler))
+ (max (recur tag) (recur body) (recur handler)))
+ ;; Full: we make a closure.
+ (($ <prompt> _ #f tag body ($ <lambda> _ _ handler))
+ (max (recur tag) (recur body) (recur handler)))))
+
((<abort> tag args tail)
(apply max (recur tag) (recur tail) (map recur args)))
diff --git a/module/language/tree-il/canonicalize.scm
b/module/language/tree-il/canonicalize.scm
index 9b0c0c8..47c1db7 100644
--- a/module/language/tree-il/canonicalize.scm
+++ b/module/language/tree-il/canonicalize.scm
@@ -55,33 +55,48 @@
(make-const #f '())
(make-const #f #f)))
#f)))
- (($ <prompt> src tag body handler)
- (define (escape-only? handler)
- (match handler
- (($ <lambda-case> _ (_ . _) _ _ _ _ (cont . _) body #f)
- (not (tree-il-any (lambda (x)
- (and (lexical-ref? x)
- (eq? (lexical-ref-gensym x) cont)))
- body)))
- (else #f)))
- (define (thunk-application? x)
- (match x
- (($ <call> _
- ($ <lambda> _ _ ($ <lambda-case> _ () #f #f #f))
- ()) #t)
- (_ #f)))
- (define (make-thunk-application body)
- (define thunk
- (make-lambda #f '()
- (make-lambda-case #f '() #f #f #f '() '() body #f)))
- (make-call #f thunk '()))
-
- ;; This code has a nasty job to do: to ensure that either the
- ;; handler is escape-only, or the body is the application of a
- ;; thunk. Sad but true.
- (if (or (escape-only? handler)
- (thunk-application? body))
- x
- (make-prompt src tag (make-thunk-application body) handler)))
+ (($ <prompt> src)
+ (define (ensure-lambda-body prompt)
+ ;; If the prompt is escape-only, the body should be a thunk.
+ (match prompt
+ (($ <prompt> _ escape-only? tag body handler)
+ (match body
+ ((or ($ <lambda> _ _ ($ <lambda-case> _ () #f #f #f))
+ (? (lambda _ (not escape-only?))))
+ prompt)
+ (else
+ (make-prompt
+ src escape-only? tag
+ (make-lambda #f '()
+ (make-lambda-case #f '() #f #f #f '() '()
+ (make-call #f body '())
+ #f))
+ handler))))))
+ (define (ensure-lambda-handler prompt)
+ (match prompt
+ (($ <prompt> _ escape-only? tag body handler)
+ ;; The prompt handler should be a simple lambda, so that we
+ ;; can inline it.
+ (match handler
+ (($ <lambda> _ _
+ ($ <lambda-case> _ req #f rest #f () syms body #f))
+ prompt)
+ (else
+ (let ((handler-sym (gensym))
+ (args-sym (gensym)))
+ (make-let
+ #f (list 'handler) (list handler-sym) (list handler)
+ (make-prompt
+ src escape-only? tag body
+ (make-lambda
+ #f '()
+ (make-lambda-case
+ #f '() #f 'args #f '() (list args-sym)
+ (make-primcall
+ #f 'apply
+ (list (make-lexical-ref #f 'handler handler-sym)
+ (make-lexical-ref #f 'args args-sym)))
+ #f))))))))))
+ (ensure-lambda-handler (ensure-lambda-body x)))
(_ x)))
x))
diff --git a/module/language/tree-il/compile-glil.scm
b/module/language/tree-il/compile-glil.scm
index 96a06ab..fd67471 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -23,6 +23,7 @@
#:use-module (system base pmatch)
#:use-module (system base message)
#:use-module (ice-9 receive)
+ #:use-module (ice-9 match)
#:use-module (language glil)
#:use-module (system vm instruction)
#:use-module (language tree-il)
@@ -954,10 +955,16 @@
;; if the continuation isn't referenced, we don't reify it. This makes it
;; possible to implement catch and throw with delimited continuations,
;; without any overhead.
- ((<prompt> src tag body handler)
+ ((<prompt> src escape-only? tag body handler)
(let ((H (make-label))
(POST (make-label))
- (escape-only? (hashq-ref allocation x)))
+ (body (if escape-only?
+ (match body
+ (($ <lambda> _ _
+ ($ <lambda-case> _ () #f #f #f () () body #f))
+ body))
+ (make-call #f body '()))))
+
;; First, set up the prompt.
(comp-push tag)
(emit-code src (make-glil-prompt H escape-only?))
@@ -1003,15 +1010,15 @@
;; Now the handler. The stack is now made up of the continuation, and
;; then the args to the continuation (pushed separately), and then the
;; number of args, including the continuation.
- (record-case handler
- ((<lambda-case> req opt kw rest gensyms body alternate)
- (if (or opt kw alternate)
- (error "unexpected lambda-case in prompt" x))
- (emit-code src (make-glil-mv-bind
- (vars->bind-list
- (append req (if rest (list rest) '()))
- gensyms allocation self)
- (and rest #t)))
+ (match handler
+ (($ <lambda> src meta
+ ($ <lambda-case> lsrc req #f rest #f () gensyms body #f))
+ (emit-code (or lsrc src)
+ (make-glil-mv-bind
+ (vars->bind-list
+ (append req (if rest (list rest) '()))
+ gensyms allocation self)
+ (and rest #t)))
(for-each (lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #f . ,n)
diff --git a/module/language/tree-il/cse.scm b/module/language/tree-il/cse.scm
index 656dd72..9e5157c 100644
--- a/module/language/tree-il/cse.scm
+++ b/module/language/tree-il/cse.scm
@@ -531,11 +531,11 @@
(let*-values (((tail db**) (visit tail (concat db* db) env ctx)))
(values (make-seq src head tail)
(concat db** db*)))))))
- (($ <prompt> src tag body handler)
+ (($ <prompt> src escape-only? tag body handler)
(let*-values (((tag db*) (visit tag db env 'value))
((body _) (visit body (concat db* db) env ctx))
((handler _) (visit handler (concat db* db) env ctx)))
- (return (make-prompt src tag body handler)
+ (return (make-prompt src escape-only? tag body handler)
db*)))
(($ <abort> src tag args tail)
(let*-values (((tag db*) (visit tag db env 'value))
diff --git a/module/language/tree-il/debug.scm
b/module/language/tree-il/debug.scm
index 8ec573a..613dc2e 100644
--- a/module/language/tree-il/debug.scm
+++ b/module/language/tree-il/debug.scm
@@ -226,7 +226,9 @@
(($ <seq> src head tail)
(visit head env)
(visit tail env))
- (($ <prompt> src tag body handler)
+ (($ <prompt> src escape-only? tag body handler)
+ (unless (boolean? escape-only?)
+ (error "escape-only? should be a bool" escape-only?))
(visit tag env)
(visit body env)
(visit handler env))
diff --git a/module/language/tree-il/effects.scm
b/module/language/tree-il/effects.scm
index 467e436..6302662 100644
--- a/module/language/tree-il/effects.scm
+++ b/module/language/tree-il/effects.scm
@@ -361,7 +361,7 @@ of an expression."
(cause &zero-values))
(compute-effects tail)))
- (($ <prompt> _ tag body handler)
+ (($ <prompt> _ escape-only? tag body handler)
(logior (compute-effects tag)
(compute-effects body)
(compute-effects handler)))
diff --git a/module/language/tree-il/peval.scm
b/module/language/tree-il/peval.scm
index 5b9852b..af00e99 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -1514,7 +1514,7 @@ top-level bindings from ENV and return the resulting
expression."
(seq-head head)
head)
tail))))
- (($ <prompt> src tag body handler)
+ (($ <prompt> src escape-only? tag body handler)
(define (make-prompt-tag? x)
(match x
(($ <primcall> _ 'make-prompt-tag (or () ((?
constant-expression?))))
@@ -1522,7 +1522,7 @@ top-level bindings from ENV and return the resulting
expression."
(_ #f)))
(let ((tag (for-value tag))
- (body (for-tail body)))
+ (body (for-value body)))
(cond
((find-definition tag 1)
(lambda (val op)
@@ -1532,31 +1532,56 @@ top-level bindings from ENV and return the resulting
expression."
;; for this <prompt>, so we can elide the <prompt>
;; entirely.
(unrecord-operand-uses op 1)
- body))
+ (for-tail (make-call src body '()))))
((find-definition tag 2)
(lambda (val op)
(and (make-prompt-tag? val)
- (abort? body)
- (tree-il=? (abort-tag body) tag)))
+ (match body
+ (($ <lambda> _ _
+ ($ <lambda-case> _ () #f #f #f () ()
+ ($ <abort> _ (? (cut tree-il=? <> tag)))))
+ #t)
+ (else #f))))
=> (lambda (val op)
;; (let ((t (make-prompt-tag)))
;; (call-with-prompt t
;; (lambda () (abort-to-prompt t val ...))
;; (lambda (k arg ...) e ...)))
- ;; => (let-values (((k arg ...) (values values val ...)))
- ;; e ...)
+ ;; => (call-with-values (lambda () (values values val ...))
+ ;; (lambda (k arg ...) e ...))
(unrecord-operand-uses op 2)
- (for-tail
- (make-let-values
- src
- (make-primcall #f 'apply
- `(,(make-primitive-ref #f 'values)
- ,(make-primitive-ref #f 'values)
- ,@(abort-args body)
- ,(abort-tail body)))
- (for-value handler)))))
+ (match body
+ (($ <lambda> _ _
+ ($ <lambda-case> _ () #f #f #f () ()
+ ($ <abort> _ _ args tail)))
+ (for-tail
+ (make-primcall
+ src 'call-with-values
+ (list (make-lambda
+ #f '()
+ (make-lambda-case
+ #f '() #f #f #f '() '()
+ (make-primcall #f 'apply
+ `(,(make-primitive-ref #f 'values)
+ ,(make-primitive-ref #f 'values)
+ ,@args
+ ,tail))
+ #f))
+ handler)))))))
(else
- (make-prompt src tag body (for-value handler))))))
+ (let ((handler (for-value handler)))
+ (define (escape-only-handler? handler)
+ (match handler
+ (($ <lambda> _ _
+ ($ <lambda-case> _ (_ . _) _ _ _ _ (k . _) body #f))
+ (not (tree-il-any
+ (match-lambda
+ (($ <lexical-ref> _ _ (? (cut eq? <> k))) #t)
+ (_ #f))
+ body)))
+ (else #f)))
+ (make-prompt src (or escape-only? (escape-only-handler? handler))
+ tag body (for-value handler)))))))
(($ <abort> src tag args tail)
(make-abort src (for-value tag) (map for-value args)
(for-value tail))))))
diff --git a/module/language/tree-il/primitives.scm
b/module/language/tree-il/primitives.scm
index 8cb090a..f738b74 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -538,21 +538,7 @@
'call-with-prompt
(case-lambda
((src tag thunk handler)
- (let ((handler-sym (gensym))
- (args-sym (gensym)))
- (make-let
- src '(handler) (list handler-sym) (list handler)
- (make-prompt
- src tag (make-call #f thunk '())
- ;; If handler itself is a lambda, the inliner can do some
- ;; trickery here.
- (make-lambda-case
- (tree-il-src handler) '() #f 'args #f '() (list args-sym)
- (make-primcall
- #f 'apply
- (list (make-lexical-ref #f 'handler handler-sym)
- (make-lexical-ref #f 'args args-sym)))
- #f)))))
+ (make-prompt src #f tag thunk handler))
(else #f)))
(hashq-set! *primitive-expand-table*
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index b8d7533..cb01b4b 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -1135,25 +1135,29 @@
(call-with-prompt tag
(lambda () 1)
(lambda (k x) x))
- (prompt (toplevel tag)
- (const 1)
- (lambda-case
- (((k x) #f #f #f () (_ _))
- (lexical x _)))))
+ (prompt #t
+ (toplevel tag)
+ (lambda _
+ (lambda-case
+ ((() #f #f #f () ())
+ (const 1))))
+ (lambda _
+ (lambda-case
+ (((k x) #f #f #f () (_ _))
+ (lexical x _))))))
;; Handler toplevel not inlined
(pass-if-peval
- (call-with-prompt tag
- (lambda () 1)
- handler)
- (let (handler) (_) ((toplevel handler))
- (prompt (toplevel tag)
- (const 1)
- (lambda-case
- ((() #f args #f () (_))
- (primcall apply
- (lexical handler _)
- (lexical args _)))))))
+ (call-with-prompt tag
+ (lambda () 1)
+ handler)
+ (prompt #f
+ (toplevel tag)
+ (lambda _
+ (lambda-case
+ ((() #f #f #f () ())
+ (const 1))))
+ (toplevel handler)))
(pass-if-peval
;; `while' without `break' or `continue' has no prompts and gets its
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-58-g178a409,
Andy Wingo <=