<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
- <dynwind> dynwind? make-dynwind dynwind-src dynwind-winder dynwind-pre dynwind-body dynwind-post dynwind-unwinder
+ <dynwind> dynwind? make-dynwind dynwind-src dynwind-winder dynwind-body dynwind-unwinder
<dynlet> dynlet? make-dynlet dynlet-src dynlet-fluids dynlet-vals dynlet-body
<dynref> dynref? make-dynref dynref-src dynref-fluid
<dynset> dynset? make-dynset dynset-src dynset-fluid dynset-exp
(define-type (<tree-il> #:common-slots (src) #:printer print-tree-il)
(<fix> names gensyms vals body)
(<let-values> exp body)
- (<dynwind> winder pre body post unwinder)
+ (<dynwind> winder body unwinder)
(<dynref> fluid)
(<dynset> fluid exp)
(<prompt> tag body handler)
(('let-values exp body)
(make-let-values loc (retrans exp) (retrans body)))
- (('dynwind winder pre body post unwinder)
- (make-dynwind loc (retrans winder) (retrans pre)
- (retrans body)
- (retrans post) (retrans unwinder)))
+ (('dynwind winder body unwinder)
+ (make-dynwind loc (retrans winder) (retrans body) (retrans unwinder)))
(('dynlet fluids vals body)
(make-dynlet loc (map retrans fluids) (map retrans vals) (retrans body)))
(($ <let-values> src exp body)
`(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))
- (($ <dynwind> src winder pre body post unwinder)
- `(dynwind ,(unparse-tree-il winder) ,(unparse-tree-il pre)
+ (($ <dynwind> src winder body unwinder)
+ `(dynwind ,(unparse-tree-il winder)
,(unparse-tree-il body)
- ,(unparse-tree-il post) ,(unparse-tree-il unwinder)))
+ ,(unparse-tree-il unwinder)))
(($ <dynlet> src fluids vals body)
`(dynlet ,(map unparse-tree-il fluids) ,(map unparse-tree-il vals)
(($ <let-values> src exp body)
(let*-values (((seed ...) (foldts exp seed ...)))
(foldts body seed ...)))
- (($ <dynwind> src winder pre body post unwinder)
+ (($ <dynwind> src winder body unwinder)
(let*-values (((seed ...) (foldts winder seed ...))
- ((seed ...) (foldts pre seed ...))
- ((seed ...) (foldts body seed ...))
- ((seed ...) (foldts post seed ...)))
- (foldts unwinder seed ...)))
+ ((seed ...) (foldts unwinder seed ...)))
+ (foldts body seed ...)))
(($ <dynlet> src fluids vals body)
(let*-values (((seed ...) (fold-values foldts fluids seed ...))
((seed ...) (fold-values foldts vals seed ...)))
(($ <let-values> src exp body)
(make-let-values src (lp exp) (lp body)))
- (($ <dynwind> src winder pre body post unwinder)
- (make-dynwind src
- (lp winder) (lp pre) (lp body) (lp post) (lp unwinder)))
+ (($ <dynwind> src winder body unwinder)
+ (make-dynwind src (lp winder) (lp body) (lp unwinder)))
(($ <dynlet> src fluids vals body)
(make-dynlet src (map lp fluids) (map lp vals) (lp body)))
((<let-values> exp body)
(lset-union eq? (step exp) (step body)))
- ((<dynwind> winder pre body post unwinder)
- (lset-union eq? (step winder) (step pre)
- (step body)
- (step post) (step unwinder)))
+ ((<dynwind> winder body unwinder)
+ (lset-union eq? (step winder) (step body) (step unwinder)))
((<dynlet> fluids vals body)
(apply lset-union eq? (step body) (map step (append fluids vals))))
((<let-values> exp body)
(max (recur exp) (recur body)))
- ((<dynwind> winder pre body post unwinder)
- (max (recur winder) (recur pre)
- (recur body)
- (recur post) (recur unwinder)))
+ ((<dynwind> winder body unwinder)
+ (max (recur winder) (recur body) (recur unwinder)))
((<dynlet> fluids vals body)
(apply max (recur body) (map recur (append fluids vals))))
(clear-stack-slots context gensyms)
(emit-code #f (make-glil-unbind))))))
- ;; much trickier than i thought this would be, at first, due to the need
- ;; to have body's return value(s) on the stack while the unwinder runs,
- ;; then proceed with returning or dropping or what-have-you, interacting
- ;; with RA and MVRA. What have you, I say.
- ((<dynwind> src winder pre body post unwinder)
+ ((<dynwind> src winder body unwinder)
(define (thunk? x)
(and (lambda? x)
(null? (lambda-case-gensyms (lambda-body x)))))
(make-void #f)
(make-wrong-type-arg x))))
- ;; We know at this point that `winder' and `unwinder' are
- ;; constant expressions and can be duplicated.
+ ;; The `winder' and `unwinder' of a dynwind are constant
+ ;; expressions and can be duplicated.
(if (not (thunk? winder))
(emit-thunk-check winder))
(comp-push winder)
(if (not (thunk? unwinder))
(emit-thunk-check unwinder))
(comp-push unwinder)
- (comp-drop pre)
(emit-code #f (make-glil-call 'wind 2))
(case context
((tail)
(let ((MV (make-label)))
(comp-vals body MV)
- ;; one value: unwind...
+ ;; One value. Unwind and return the value.
(emit-code #f (make-glil-call 'unwind 0))
- (comp-drop post)
- ;; ...and return the val
(emit-code #f (make-glil-call 'return 1))
(emit-label MV)
- ;; multiple values: unwind...
+ ;; Multiple values. Unwind and return the values.
(emit-code #f (make-glil-call 'unwind 0))
- (comp-drop post)
- ;; and return the values.
(emit-code #f (make-glil-call 'return/nvalues 1))))
((push)
- ;; we only want one value. so ask for one value
+ ;; We only want one value, so ask for one value and then
+ ;; unwind, leaving the value on the stack.
(comp-push body)
- ;; and unwind, leaving the val on the stack
- (emit-code #f (make-glil-call 'unwind 0))
- (comp-drop post))
+ (emit-code #f (make-glil-call 'unwind 0)))
((vals)
(let ((MV (make-label)))
(comp-vals body MV)
- ;; one value: push 1 and fall through to MV case
+ ;; Transform a singly-valued return to a multiple-value
+ ;; return and fall through to MV case.
(emit-code #f (make-glil-const 1))
(emit-label MV)
- ;; multiple values: unwind...
+ ;; Multiple values: unwind and go to the MVRA.
(emit-code #f (make-glil-call 'unwind 0))
- (comp-drop post)
- ;; and goto the MVRA.
(emit-branch #f 'br MVRA)))
((drop)
- ;; compile body, discarding values. then unwind...
+ ;; Compile body, discarding values. Then unwind and fall
+ ;; through, or goto RA if there is one.
(comp-drop body)
(emit-code #f (make-glil-call 'unwind 0))
- (comp-drop post)
- ;; and fall through, or goto RA if there is one.
(if RA
(emit-branch #f 'br RA)))))
((consumer db**) (visit consumer (concat db* db) env ctx)))
(return (make-let-values src producer consumer)
(concat db** db*))))
- (($ <dynwind> src winder pre body post unwinder)
+ (($ <dynwind> src winder body unwinder)
(let*-values (((winder db*) (visit winder db env 'value))
((db**) db*)
((unwinder db*) (visit unwinder db env 'value))
((db**) (concat db* db**))
- ((pre db*) (visit pre (concat db** db) env 'effect))
- ((db**) (concat db* db**))
((body db*) (visit body (concat db** db) env ctx))
- ((db**) (concat db* db**))
- ((post db*) (visit post (concat db** db) env 'effect))
((db**) (concat db* db**)))
- (return (make-dynwind src winder pre body post unwinder)
+ (return (make-dynwind src winder body unwinder)
db**)))
(($ <dynlet> src fluids vals body)
(let*-values (((fluids db*) (parallel-visit fluids db env 'value))
(for-each (cut visit <> env) fluids)
(for-each (cut visit <> env) vals)
(visit body env))))
- (($ <dynwind> src winder pre body post unwinder)
+ (($ <dynwind> src winder body unwinder)
(visit winder env)
- (visit pre env)
(visit body env)
- (visit post env)
(visit unwinder env))
(($ <dynref> src fluid)
(visit fluid env))
(logior (compute-effects producer)
(compute-effects consumer)
(cause &type-check)))
- (($ <dynwind> _ winder pre body post unwinder)
+ (($ <dynwind> _ winder body unwinder)
(logior (compute-effects winder)
- (compute-effects pre)
(compute-effects body)
- (compute-effects post)
(compute-effects unwinder)))
(($ <dynlet> _ fluids vals body)
(logior (accumulate-effects fluids)
(($ <conditional> _ test consequent alternate)
(and (singly-valued-expression? consequent)
(singly-valued-expression? alternate)))
+ (($ <dynwind> _ winder body unwinder)
+ (singly-valued-expression? body))
(else #f)))
(define (truncate-values x)
(else #f))))
(_ #f))
(make-let-values lv-src producer (for-tail consumer)))))
- (($ <dynwind> src winder pre body post unwinder)
- (make-dynwind src (for-value winder) (for-effect pre)
+ (($ <dynwind> src winder body unwinder)
+ (make-dynwind src
+ (for-value winder)
(for-tail body)
- (for-effect post) (for-value unwinder)))
+ (for-value unwinder)))
(($ <dynlet> src fluids vals body)
(make-dynlet src (map for-value fluids) (map for-value vals)
(for-tail body)))
(for-tail (make-let-values src (make-call src producer '())
consumer)))
(($ <primcall> src 'dynamic-wind (w thunk u))
+ (define (with-temporaries exps refcount k)
+ (let* ((pairs (map (match-lambda
+ ((and exp (? constant-expression?))
+ (cons #f exp))
+ (exp
+ (let ((sym (gensym "tmp ")))
+ (record-new-temporary! 'tmp sym refcount)
+ (cons sym exp))))
+ exps))
+ (tmps (filter car pairs)))
+ (match tmps
+ (() (k exps))
+ (tmps
+ (make-let src
+ (make-list (length tmps) 'tmp)
+ (map car tmps)
+ (map cdr tmps)
+ (k (map (match-lambda
+ ((#f . val) val)
+ ((sym . _)
+ (make-lexical-ref #f 'tmp sym)))
+ pairs)))))))
+ (define (make-begin0 src first second)
+ (make-let-values
+ src
+ first
+ (let ((vals (gensym "vals ")))
+ (record-new-temporary! 'vals vals 1)
+ (make-lambda-case
+ #f
+ '() #f 'vals #f '() (list vals)
+ (make-seq
+ src
+ second
+ (make-primcall #f 'apply
+ (list
+ (make-primitive-ref #f 'values)
+ (make-lexical-ref #f 'vals vals))))
+ #f))))
(for-tail
- (cond
- ((not (constant-expression? w))
- (cond
- ((not (constant-expression? u))
- (let ((w-sym (gensym "w ")) (u-sym (gensym "u ")))
- (record-new-temporary! 'w w-sym 2)
- (record-new-temporary! 'u u-sym 2)
- (make-let src '(w u) (list w-sym u-sym) (list w u)
- (make-dynwind
- src
- (make-lexical-ref #f 'w w-sym)
- (make-call #f (make-lexical-ref #f 'w w-sym) '())
- (make-call #f thunk '())
- (make-call #f (make-lexical-ref #f 'u u-sym) '())
- (make-lexical-ref #f 'u u-sym)))))
- (else
- (let ((w-sym (gensym "w ")))
- (record-new-temporary! 'w w-sym 2)
- (make-let src '(w) (list w-sym) (list w)
- (make-dynwind
- src
- (make-lexical-ref #f 'w w-sym)
- (make-call #f (make-lexical-ref #f 'w w-sym) '())
- (make-call #f thunk '())
- (make-call #f u '())
- u))))))
- ((not (constant-expression? u))
- (let ((u-sym (gensym "u ")))
- (record-new-temporary! 'u u-sym 2)
- (make-let src '(u) (list u-sym) (list u)
- (make-dynwind
- src
- w
- (make-call #f w '())
- (make-call #f thunk '())
- (make-call #f (make-lexical-ref #f 'u u-sym) '())
- (make-lexical-ref #f 'u u-sym)))))
- (else
- (make-dynwind src w (make-call #f w '()) (make-call #f thunk '())
- (make-call #f u '()) u)))))
+ (with-temporaries
+ (list w u) 2
+ (match-lambda
+ ((w u)
+ (make-seq src
+ (make-call src w '())
+ (make-begin0 src
+ (make-dynwind src w
+ (make-call src thunk '())
+ u)
+ (make-call src u '()))))))))
(($ <primcall> src 'values exps)
(cond
'@dynamic-wind
(case-lambda
((src pre expr post)
- (let ((PRE (gensym "pre-"))
- (POST (gensym "post-")))
- (make-let
- src
- '(pre post)
- (list PRE POST)
- (list pre post)
- (make-dynwind
- src
- (make-lexical-ref #f 'pre PRE)
- (make-call #f (make-lexical-ref #f 'pre PRE) '())
- expr
- (make-call #f (make-lexical-ref #f 'post POST) '())
- (make-lexical-ref #f 'post POST)))))))
+ (let* ((PRE (gensym "pre-"))
+ (POST (gensym "post-"))
+ (winder (make-lexical-ref #f 'winder PRE))
+ (unwinder (make-lexical-ref #f 'unwinder POST)))
+ (define (make-begin0 src first second)
+ (make-let-values
+ src
+ first
+ (let ((vals (gensym "vals ")))
+ (make-lambda-case
+ #f
+ '() #f 'vals #f '() (list vals)
+ (make-seq
+ src
+ second
+ (make-primcall #f 'apply
+ (list
+ (make-primitive-ref #f 'values)
+ (make-lexical-ref #f 'vals vals))))
+ #f))))
+ (make-let src '(pre post) (list PRE POST) (list pre post)
+ (make-seq src
+ (make-call src winder '())
+ (make-begin0
+ src
+ (make-dynwind src winder expr unwinder)
+ (make-call src unwinder '()))))))))
(hashq-set! *primitive-expand-table*
'fluid-ref
(seq (call (toplevel random)) (const #t)))
(pass-if-peval
- ;; Non-constant guards get lexical bindings.
+ ;; Non-constant guards get lexical bindings, invocation of winder and
+ ;; unwinder lifted out. Unfortunately both have the generic variable
+ ;; name "tmp", so we can't distinguish them in this test, and they
+ ;; also collide in generic names with the single-value result from
+ ;; the dynwind; alack.
(dynamic-wind foo (lambda () bar) baz)
- (let (w u) (_ _) ((toplevel foo) (toplevel baz))
- (dynwind (lexical w _)
- (call (lexical w _))
- (toplevel bar)
- (call (lexical u _))
- (lexical u _))))
+ (let (tmp tmp) (_ _) ((toplevel foo) (toplevel baz))
+ (seq (call (lexical tmp _))
+ (let (tmp) (_) ((dynwind (lexical tmp _)
+ (toplevel bar)
+ (lexical tmp _)))
+ (seq (call (lexical tmp _))
+ (lexical tmp _))))))
(pass-if-peval
;; Constant guards don't need lexical bindings.
(dynamic-wind (lambda () foo) (lambda () bar) (lambda () baz))
- (dynwind
- (lambda ()
- (lambda-case
- ((() #f #f #f () ()) (toplevel foo))))
- (toplevel foo)
- (toplevel bar)
- (toplevel baz)
- (lambda ()
- (lambda-case
- ((() #f #f #f () ()) (toplevel baz))))))
+ (seq (toplevel foo)
+ (let (tmp) (_) ((dynwind (lambda ()
+ (lambda-case
+ ((() #f #f #f () ()) (toplevel foo))))
+ (toplevel bar)
+ (lambda ()
+ (lambda-case
+ ((() #f #f #f () ()) (toplevel baz))))))
+ (seq (toplevel baz)
+ (lexical tmp _)))))
+
+ (pass-if-peval
+ ;; Dynwind bodies that return an unknown number of values need a
+ ;; let-values.
+ (dynamic-wind (lambda () foo) (lambda () (bar)) (lambda () baz))
+ (seq (toplevel foo)
+ (let-values (dynwind (lambda ()
+ (lambda-case
+ ((() #f #f #f () ()) (toplevel foo))))
+ (call (toplevel bar))
+ (lambda ()
+ (lambda-case
+ ((() #f #f #f () ()) (toplevel baz)))))
+ (lambda-case
+ ((() #f vals #f () (_))
+ (seq (toplevel baz)
+ (primcall @apply (primitive values) (lexical vals _))))))))
(pass-if-peval
;; Prompt is removed if tag is unreferenced
HCoop / bpt / guile.git / commitdiff