summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2013-07-06 20:06:02 +0900
committerAndy Wingo <wingo@pobox.com>2013-07-06 20:27:21 +0900
commit178a40928ab5221f6ce57c5af1067abe30a342b3 (patch)
tree6d8b62eff02e8e4fc383cb2e76b0a326d88ad44d
parent98eaef1b50db626c672646da58645c62407d0c1a (diff)
downloadguile-178a40928ab5221f6ce57c5af1067abe30a342b3.tar.gz
<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.
-rw-r--r--module/language/scheme/decompile-tree-il.scm3
-rw-r--r--module/language/tree-il.scm21
-rw-r--r--module/language/tree-il/analyze.scm33
-rw-r--r--module/language/tree-il/canonicalize.scm71
-rw-r--r--module/language/tree-il/compile-glil.scm29
-rw-r--r--module/language/tree-il/cse.scm4
-rw-r--r--module/language/tree-il/debug.scm4
-rw-r--r--module/language/tree-il/effects.scm2
-rw-r--r--module/language/tree-il/peval.scm59
-rw-r--r--module/language/tree-il/primitives.scm16
-rw-r--r--test-suite/tests/peval.test36
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 dca969f92..74778b4ca 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 16fdb96e5..4ae1484cb 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 ca7cb80a4..6b6df18c3 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 9b0c0c8cd..47c1db7ac 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 96a06ab71..fd67471f2 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 656dd72c6..9e5157c73 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 8ec573a73..613dc2ea6 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 467e4366a..6302662a8 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 5b9852b01..af00e9904 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 8cb090a24..f738b7459 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 b8d753378..cb01b4b68 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