* 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.
((<prompt> tag body handler)
`(call-with-prompt
,(recurse tag)
- (lambda () ,@(recurse-body body))
+ ,(recurse body)
,(recurse handler)))
((<prompt> tag body handler)
(primitive 'call-with-prompt)
- (primitive 'lambda)
(recurse tag) (recurse body) (recurse handler))
((<abort> tag args tail)
<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
<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
(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))
\f
(('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)))
(($ <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)))
(($ <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 ...)))
(($ <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)))))))
((<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)))
((<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)))
(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))
#: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)
;; 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?))
;; 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)
(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))
(($ <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))
(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)))
(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?))))
(_ #f)))
(let ((tag (for-value tag))
- (body (for-tail body)))
+ (body (for-value body)))
(cond
((find-definition tag 1)
(lambda (val op)
;; 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))))))
'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*
(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
HCoop / bpt / guile.git / commitdiff