summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2011-09-27 13:39:29 +0200
committerAndy Wingo <wingo@pobox.com>2011-09-28 00:13:55 +0200
commitea726a53b2180ee4548723f81d9b1be7732ef5d8 (patch)
tree1f6655ced2146e89898a12958dbc284e8f8be3c7
parentfbc9387f68be677663e6756c35afa973a9dc0a1a (diff)
downloadguile-ea726a53b2180ee4548723f81d9b1be7732ef5d8.tar.gz
peval: add support for <prompt> and <abort>
* module/language/tree-il/optimize.scm (alpha-rename, peval): Handle <prompt> and <abort>. Attempt to remove the prompt if the tag is otherwise unreferenced. * module/language/tree-il/primitives.scm (*primitive-constructors*): Add make-prompt-tag as a constructor. * test-suite/tests/tree-il.test ("partial evaluation"): Add a test that an prompt whose tag is unreferenced is removed.
-rw-r--r--module/language/tree-il/optimize.scm67
-rw-r--r--module/language/tree-il/primitives.scm2
-rw-r--r--test-suite/tests/tree-il.test11
3 files changed, 77 insertions, 3 deletions
diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm
index bff6ed101..6c55d64eb 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -154,7 +154,13 @@ references to the new symbols."
(make-application src (loop proc mapping)
(map (cut loop <> mapping) args)))
(($ <sequence> src exps)
- (make-sequence src (map (cut loop <> mapping) exps))))))
+ (make-sequence src (map (cut loop <> mapping) exps)))
+ (($ <prompt> src tag body handler)
+ (make-prompt src (loop tag mapping) (loop body mapping)
+ (loop handler mapping)))
+ (($ <abort> src tag args tail)
+ (make-abort src (loop tag mapping) (map (cut loop <> mapping) args)
+ (loop tail mapping))))))
(define-syntax-rule (let/ec k e e* ...)
(let ((tag (make-prompt-tag)))
@@ -398,6 +404,10 @@ it does not handle <fix> and <let-values>, it should be called before
;; Bail on other applications.
(($ <application>) #f)
+ ;; Bail on prompt and abort.
+ (($ <prompt>) #f)
+ (($ <abort>) #f)
+
;; Propagate to tail positions.
(($ <let> src names gensyms vals body)
(let ((body (loop body)))
@@ -472,6 +482,8 @@ it does not handle <fix> and <let-values>, it should be called before
(and (every loop vals) (loop body)))
(($ <let-values> _ exp body)
(and (loop exp) (loop body)))
+ (($ <prompt> _ tag body handler)
+ (and (loop tag) (loop body) (loop handler)))
(_ #f))))
(define (small-expression? x limit)
@@ -934,7 +946,58 @@ it does not handle <fix> and <let-values>, it should be called before
((void? head)
(lp rest effects))
(else
- (lp rest (cons head effects))))))))))))
+ (lp rest (cons head effects)))))))))
+ (($ <prompt> src tag body handler)
+ (define (singly-used-definition x)
+ (cond
+ ((and (lexical-ref? x)
+ ;; Only fetch definitions with single uses.
+ (= (lexical-refcount (lexical-ref-gensym x)) 1)
+ (lookup (lexical-ref-gensym x)))
+ => singly-used-definition)
+ (else x)))
+ (define (escape-only? handler)
+ (match handler
+ (($ <lambda-case> _ (_ . _) _ _ _ _ (cont . _) body #f)
+ (tree-il-any (lambda (x)
+ (and (lexical-ref? x)
+ (eq? (lexical-ref-gensym x) cont)))
+ body))))
+ (define (thunk-application? x)
+ (match x
+ (($ <application> _
+ ($ <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-application #f thunk '()))
+
+ (match (singly-used-definition tag)
+ (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag)
+ (or () ((? constant-expression?))))
+ ;; There is no way that an <abort> could know the tag
+ ;; for this <prompt>, so we can elide the <prompt>
+ ;; entirely.
+ (for-tail body))
+ (_
+ ;; It's a nasty, but this code has another job to do: to
+ ;; ensure that either the handler is escape-only, or the
+ ;; body is the application of a thunk. Sad but true.
+ (let ((tag (for-value tag))
+ (body (for-value body))
+ (handler (for-value handler)))
+ (make-prompt src tag
+ (if (or (escape-only? handler)
+ (thunk-application? body))
+ body
+ (make-thunk-application body))
+ handler)))))
+ (($ <abort> src tag args tail)
+ (make-abort src (for-value tag) (map for-value args)
+ (for-value tail))))))
(lambda _
;; We encountered something we don't handle, like <abort> or
;; <prompt>, so bail out.
diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index 67c12d2d3..c850cba9b 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -110,7 +110,7 @@
(define *primitive-constructors*
;; Primitives that return a fresh object.
'(acons cons cons* list vector make-struct make-struct/no-tail
- car cdr vector-ref struct-ref))
+ car cdr vector-ref struct-ref make-prompt-tag))
(define *effect-free-primitives*
`(values
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 290a48377..9bb45eede 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -1275,6 +1275,17 @@
(cdr (list (bar) 0))
(begin (apply (toplevel bar)) (apply (primitive list) (const 0))))
+ (pass-if-peval
+ resolve-primitives
+ ;; Prompt is removed if tag is unreferenced
+ (let ((tag (make-prompt-tag)))
+ (call-with-prompt tag
+ (lambda () 1)
+ (lambda args args)))
+ ;; FIXME: elide the (make-prompt-tag) call
+ (begin
+ (apply (primitive make-prompt-tag))
+ (const 1)))
)