diff options
author | Andy Wingo <wingo@pobox.com> | 2011-09-27 13:39:29 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2011-09-28 00:13:55 +0200 |
commit | ea726a53b2180ee4548723f81d9b1be7732ef5d8 (patch) | |
tree | 1f6655ced2146e89898a12958dbc284e8f8be3c7 /module/language/tree-il/optimize.scm | |
parent | fbc9387f68be677663e6756c35afa973a9dc0a1a (diff) | |
download | guile-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.
Diffstat (limited to 'module/language/tree-il/optimize.scm')
-rw-r--r-- | module/language/tree-il/optimize.scm | 67 |
1 files changed, 65 insertions, 2 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. |