mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 11:50:28 +02:00
Code Activity

<prompt> body and handler are lambdas; add escape-only? field

Browse source 
* 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 2013-07-06 20:06:02 +09:00
parent 98eaef1b50
commit 178a40928a
11 changed files with 166 additions and 112 deletions
Download patch file Download diff file Expand all files Collapse all files

3
module/language/scheme/decompile-tree-il.scm
View file

@ -435,7 +435,7 @@
((<prompt> tag body handler) ((<prompt> tag body handler)
`(call-with-prompt `(call-with-prompt
,(recurse tag) ,(recurse tag)
(lambda () ,@(recurse-body body)) ,(recurse body)
,(recurse handler))) ,(recurse handler)))
@ -746,7 +746,6 @@
((<prompt> tag body handler) ((<prompt> tag body handler)
(primitive 'call-with-prompt) (primitive 'call-with-prompt)
(primitive 'lambda)
(recurse tag) (recurse body) (recurse handler)) (recurse tag) (recurse body) (recurse handler))
((<abort> tag args tail) ((<abort> tag args tail)

21
module/language/tree-il.scm
View file

@ -39,6 +39,7 @@
<seq> seq? make-seq seq-src seq-head seq-tail <seq> seq? make-seq seq-src seq-head seq-tail
<lambda> lambda? make-lambda lambda-src lambda-meta lambda-body <lambda> lambda? make-lambda lambda-src lambda-meta lambda-body
<lambda-case> lambda-case? make-lambda-case lambda-case-src <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-req lambda-case-opt lambda-case-rest lambda-case-kw
lambda-case-inits lambda-case-gensyms lambda-case-inits lambda-case-gensyms
lambda-case-body lambda-case-alternate 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 <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 <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 <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 <abort> abort? make-abort abort-src abort-tag abort-args abort-tail
list->seq list->seq
@ -131,7 +132,7 @@
(define-type (<tree-il> #:common-slots (src) #:printer print-tree-il) (define-type (<tree-il> #:common-slots (src) #:printer print-tree-il)
(<fix> names gensyms vals body) (<fix> names gensyms vals body)
(<let-values> exp body) (<let-values> exp body)
(<prompt> tag body handler) (<prompt> escape-only? tag body handler)
(<abort> tag args tail)) (<abort> tag args tail))
@ -241,8 +242,9 @@
(('let-values exp body) (('let-values exp body)
(make-let-values loc (retrans exp) (retrans body))) (make-let-values loc (retrans exp) (retrans body)))
(('prompt tag body handler) (('prompt escape-only? tag body handler)
(make-prompt loc (retrans tag) (retrans body) (retrans handler))) (make-prompt loc escape-only?
(retrans tag) (retrans body) (retrans handler)))
(('abort tag args tail) (('abort tag args tail)
(make-abort loc (retrans tag) (map retrans args) (retrans tail))) (make-abort loc (retrans tag) (map retrans args) (retrans tail)))
@ -319,8 +321,9 @@
(($ <let-values> src exp body) (($ <let-values> src exp body)
`(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body))) `(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))
(($ <prompt> src tag body handler) (($ <prompt> src escape-only? tag body handler)
`(prompt ,(unparse-tree-il tag) `(prompt ,escape-only?
,(unparse-tree-il tag)
,(unparse-tree-il body) ,(unparse-tree-il body)
,(unparse-tree-il handler))) ,(unparse-tree-il handler)))
@ -389,7 +392,7 @@
(($ <let-values> src exp body) (($ <let-values> src exp body)
(let*-values (((seed ...) (foldts exp seed ...))) (let*-values (((seed ...) (foldts exp seed ...)))
(foldts body seed ...))) (foldts body seed ...)))
(($ <prompt> src tag body handler) (($ <prompt> src escape-only? tag body handler)
(let*-values (((seed ...) (foldts tag seed ...)) (let*-values (((seed ...) (foldts tag seed ...))
((seed ...) (foldts body seed ...))) ((seed ...) (foldts body seed ...)))
(foldts handler 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) (($ <let-values> src exp body)
(make-let-values src (lp exp) (lp body))) (make-let-values src (lp exp) (lp body)))
(($ <prompt> src tag body handler) (($ <prompt> src escape-only? tag body handler)
(make-prompt src (lp tag) (lp body) (lp handler))) (make-prompt src escape-only? (lp tag) (lp body) (lp handler)))
(($ <abort> src tag args tail) (($ <abort> src tag args tail)
(make-abort src (lp tag) (map lp args) (lp tail))))))) (make-abort src (lp tag) (map lp args) (lp tail)))))))

31
module/language/tree-il/analyze.scm
View file

@ -337,8 +337,17 @@
((<let-values> exp body) ((<let-values> exp body)
(lset-union eq? (step exp) (step body))) (lset-union eq? (step exp) (step body)))
((<prompt> tag body handler) ((<prompt> escape-only? tag body handler)
(lset-union eq? (step tag) (step body) (step-tail 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) ((<abort> tag args tail)
(apply lset-union eq? (step tag) (step tail) (map step args))) (apply lset-union eq? (step tag) (step tail) (map step args)))
@ -499,13 +508,17 @@
((<let-values> exp body) ((<let-values> exp body)
(max (recur exp) (recur body))) (max (recur exp) (recur body)))
((<prompt> tag body handler) ((<prompt> escape-only? tag body handler)
(let ((cont-var (and (lambda-case? handler) (match x
(pair? (lambda-case-gensyms handler)) ;; Escape-only: the body is inlined.
(car (lambda-case-gensyms handler))))) (($ <prompt> _ #t tag
(hashq-set! allocation x ($ <lambda> _ _
(and cont-var (zero? (hashq-ref refcounts cont-var 0)))) ($ <lambda-case> _ () #f #f #f () () body #f))
(max (recur tag) (recur body) (recur handler)))) ($ <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) ((<abort> tag args tail)
(apply max (recur tag) (recur tail) (map recur args))) (apply max (recur tag) (recur tail) (map recur args)))

71
module/language/tree-il/canonicalize.scm
View file

@ -55,33 +55,48 @@
(make-const #f '()) (make-const #f '())
(make-const #f #f))) (make-const #f #f)))
#f))) #f)))
(($ <prompt> src tag body handler) (($ <prompt> src)
(define (escape-only? handler) (define (ensure-lambda-body prompt)
(match handler ;; If the prompt is escape-only, the body should be a thunk.
(($ <lambda-case> _ (_ . _) _ _ _ _ (cont . _) body #f) (match prompt
(not (tree-il-any (lambda (x) (($ <prompt> _ escape-only? tag body handler)
(and (lexical-ref? x) (match body
(eq? (lexical-ref-gensym x) cont))) ((or ($ <lambda> _ _ ($ <lambda-case> _ () #f #f #f))
body))) (? (lambda _ (not escape-only?))))
(else #f))) prompt)
(define (thunk-application? x) (else
(match x (make-prompt
(($ <call> _ src escape-only? tag
($ <lambda> _ _ ($ <lambda-case> _ () #f #f #f)) (make-lambda #f '()
()) #t) (make-lambda-case #f '() #f #f #f '() '()
(_ #f))) (make-call #f body '())
(define (make-thunk-application body) #f))
(define thunk handler))))))
(make-lambda #f '() (define (ensure-lambda-handler prompt)
(make-lambda-case #f '() #f #f #f '() '() body #f))) (match prompt
(make-call #f thunk '())) (($ <prompt> _ escape-only? tag body handler)
;; The prompt handler should be a simple lambda, so that we
;; This code has a nasty job to do: to ensure that either the ;; can inline it.
;; handler is escape-only, or the body is the application of a (match handler
;; thunk. Sad but true. (($ <lambda> _ _
(if (or (escape-only? handler) ($ <lambda-case> _ req #f rest #f () syms body #f))
(thunk-application? body)) prompt)
x (else
(make-prompt src tag (make-thunk-application body) handler))) (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)))
x)) x))

29
module/language/tree-il/compile-glil.scm
View file

@ -23,6 +23,7 @@
#:use-module (system base pmatch) #:use-module (system base pmatch)
#:use-module (system base message) #:use-module (system base message)
#:use-module (ice-9 receive) #:use-module (ice-9 receive)
#:use-module (ice-9 match)
#:use-module (language glil) #:use-module (language glil)
#:use-module (system vm instruction) #:use-module (system vm instruction)
#:use-module (language tree-il) #:use-module (language tree-il)
@ -954,10 +955,16 @@
;; if the continuation isn't referenced, we don't reify it. This makes it ;; if the continuation isn't referenced, we don't reify it. This makes it
;; possible to implement catch and throw with delimited continuations, ;; possible to implement catch and throw with delimited continuations,
;; without any overhead. ;; without any overhead.
((<prompt> src tag body handler) ((<prompt> src escape-only? tag body handler)
(let ((H (make-label)) (let ((H (make-label))
(POST (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. ;; First, set up the prompt.
(comp-push tag) (comp-push tag)
(emit-code src (make-glil-prompt H escape-only?)) (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 ;; Now the handler. The stack is now made up of the continuation, and
;; then the args to the continuation (pushed separately), and then the ;; then the args to the continuation (pushed separately), and then the
;; number of args, including the continuation. ;; number of args, including the continuation.
(record-case handler (match handler
((<lambda-case> req opt kw rest gensyms body alternate) (($ <lambda> src meta
(if (or opt kw alternate) ($ <lambda-case> lsrc req #f rest #f () gensyms body #f))
(error "unexpected lambda-case in prompt" x)) (emit-code (or lsrc src)
(emit-code src (make-glil-mv-bind (make-glil-mv-bind
(vars->bind-list (vars->bind-list
(append req (if rest (list rest) '())) (append req (if rest (list rest) '()))
gensyms allocation self) gensyms allocation self)
(and rest #t))) (and rest #t)))
(for-each (lambda (v) (for-each (lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) self) (pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #f . ,n) ((#t #f . ,n)

4
module/language/tree-il/cse.scm
View file

@ -531,11 +531,11 @@
(let*-values (((tail db**) (visit tail (concat db* db) env ctx))) (let*-values (((tail db**) (visit tail (concat db* db) env ctx)))
(values (make-seq src head tail) (values (make-seq src head tail)
(concat db** db*))))))) (concat db** db*)))))))
(($ <prompt> src tag body handler) (($ <prompt> src escape-only? tag body handler)
(let*-values (((tag db*) (visit tag db env 'value)) (let*-values (((tag db*) (visit tag db env 'value))
((body _) (visit body (concat db* db) env ctx)) ((body _) (visit body (concat db* db) env ctx))
((handler _) (visit handler (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*))) db*)))
(($ <abort> src tag args tail) (($ <abort> src tag args tail)
(let*-values (((tag db*) (visit tag db env 'value)) (let*-values (((tag db*) (visit tag db env 'value))

4
module/language/tree-il/debug.scm
View file

@ -226,7 +226,9 @@
(($ <seq> src head tail) (($ <seq> src head tail)
(visit head env) (visit head env)
(visit tail 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 tag env)
(visit body env) (visit body env)
(visit handler env)) (visit handler env))

2
module/language/tree-il/effects.scm
View file

@ -361,7 +361,7 @@ of an expression."
(cause &zero-values)) (cause &zero-values))
(compute-effects tail))) (compute-effects tail)))
(($ <prompt> _ tag body handler) (($ <prompt> _ escape-only? tag body handler)
(logior (compute-effects tag) (logior (compute-effects tag)
(compute-effects body) (compute-effects body)
(compute-effects handler))) (compute-effects handler)))

59
module/language/tree-il/peval.scm
View file

@ -1514,7 +1514,7 @@ top-level bindings from ENV and return the resulting expression."
(seq-head head) (seq-head head)
head) head)
tail)))) tail))))
(($ <prompt> src tag body handler) (($ <prompt> src escape-only? tag body handler)
(define (make-prompt-tag? x) (define (make-prompt-tag? x)
(match x (match x
(($ <primcall> _ 'make-prompt-tag (or () ((? constant-expression?)))) (($ <primcall> _ 'make-prompt-tag (or () ((? constant-expression?))))
@ -1522,7 +1522,7 @@ top-level bindings from ENV and return the resulting expression."
(_ #f))) (_ #f)))
(let ((tag (for-value tag)) (let ((tag (for-value tag))
(body (for-tail body))) (body (for-value body)))
(cond (cond
((find-definition tag 1) ((find-definition tag 1)
(lambda (val op) (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> ;; for this <prompt>, so we can elide the <prompt>
;; entirely. ;; entirely.
(unrecord-operand-uses op 1) (unrecord-operand-uses op 1)
body)) (for-tail (make-call src body '()))))
((find-definition tag 2) ((find-definition tag 2)
(lambda (val op) (lambda (val op)
(and (make-prompt-tag? val) (and (make-prompt-tag? val)
(abort? body) (match body
(tree-il=? (abort-tag body) tag))) (($ <lambda> _ _
($ <lambda-case> _ () #f #f #f () ()
($ <abort> _ (? (cut tree-il=? <> tag)))))
#t)
(else #f))))
=> (lambda (val op) => (lambda (val op)
;; (let ((t (make-prompt-tag))) ;; (let ((t (make-prompt-tag)))
;; (call-with-prompt t ;; (call-with-prompt t
;; (lambda () (abort-to-prompt t val ...)) ;; (lambda () (abort-to-prompt t val ...))
;; (lambda (k arg ...) e ...))) ;; (lambda (k arg ...) e ...)))
;; => (let-values (((k arg ...) (values values val ...))) ;; => (call-with-values (lambda () (values values val ...))
;; e ...) ;; (lambda (k arg ...) e ...))
(unrecord-operand-uses op 2) (unrecord-operand-uses op 2)
(for-tail (match body
(make-let-values (($ <lambda> _ _
src ($ <lambda-case> _ () #f #f #f () ()
(make-primcall #f 'apply ($ <abort> _ _ args tail)))
`(,(make-primitive-ref #f 'values) (for-tail
,(make-primitive-ref #f 'values) (make-primcall
,@(abort-args body) src 'call-with-values
,(abort-tail body))) (list (make-lambda
(for-value handler))))) #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 (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) (($ <abort> src tag args tail)
(make-abort src (for-value tag) (map for-value args) (make-abort src (for-value tag) (map for-value args)
(for-value tail)))))) (for-value tail))))))

16
module/language/tree-il/primitives.scm
View file

@ -538,21 +538,7 @@
'call-with-prompt 'call-with-prompt
(case-lambda (case-lambda
((src tag thunk handler) ((src tag thunk handler)
(let ((handler-sym (gensym)) (make-prompt src #f tag thunk handler))
(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)))))
(else #f))) (else #f)))
(hashq-set! *primitive-expand-table* (hashq-set! *primitive-expand-table*

36
test-suite/tests/peval.test
View file

@ -1135,25 +1135,29 @@
(call-with-prompt tag (call-with-prompt tag
(lambda () 1) (lambda () 1)
(lambda (k x) x)) (lambda (k x) x))
(prompt (toplevel tag) (prompt #t
(const 1) (toplevel tag)
(lambda-case (lambda _
(((k x) #f #f #f () (_ _)) (lambda-case
(lexical x _))))) ((() #f #f #f () ())
(const 1))))
(lambda _
(lambda-case
(((k x) #f #f #f () (_ _))
(lexical x _))))))
;; Handler toplevel not inlined ;; Handler toplevel not inlined
(pass-if-peval (pass-if-peval
(call-with-prompt tag (call-with-prompt tag
(lambda () 1) (lambda () 1)
handler) handler)
(let (handler) (_) ((toplevel handler)) (prompt #f
(prompt (toplevel tag) (toplevel tag)
(const 1) (lambda _
(lambda-case (lambda-case
((() #f args #f () (_)) ((() #f #f #f () ())
(primcall apply (const 1))))
(lexical handler _) (toplevel handler)))
(lexical args _)))))))
(pass-if-peval (pass-if-peval
;; `while' without `break' or `continue' has no prompts and gets its ;; `while' without `break' or `continue' has no prompts and gets its