mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
<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.
This commit is contained in:
Andy Wingo
parent
98eaef1b50
commit
178a40928a
11 changed files with 166 additions and 112 deletions
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)))))))
|
||||
|
|
|
|||
|
|
@ -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,13 +508,17 @@
|
|||
((<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)))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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))))))
|
||||
|
|
|
|||
|
|
@ -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*
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue