mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-02 13:00:26 +02:00
dynamic-wind in terms of wind and unwind; remove <dynwind>, @dynamic-wind
* doc/ref/compiler.texi: Remove mention of <dynwind>.
* libguile/eval.c (eval): Remove SCM_M_DYNWIND case.
* libguile/expand.c: Remove scm_sym_at_dynamic_wind.
* libguile/memoize.c (do_wind, do_unwind): A couple of hacky subrs. If
we see a wind or unwind primcall, we expand to a call of a quoted subr
value. It works and removes a kind of memoized value from the
interpreter. For the compiler,primcalls to wind and unwind are
handled specially.
(MAKMEMO_DYNWIND): Remove.
(scm_tc16_memoizer): Remove. Yay!
(memoize): Remove speculative lookup for toplevels to see if they are
memoizers: there are no more memoizers. Memoize calls to the wind and
unwind primitives.
(m_dynamic_wind): Remove.
(unmemoize): Remove dynwind case.
(scm_init_memoize): Add wind and unwind local definitions.
* module/ice-9/boot-9.scm (dynamic-wind): Reimplement in terms of "wind"
and "unwind" primitives. These primitives are not exposed to other
modules.
* module/ice-9/eval.scm (primitive-eval): Remove dynwind case.
* module/language/scheme/decompile-tree-il.scm (do-decompile):
(choose-output-names): Remove dynwind cases.
* module/language/tree-il.scm: Remove <dynwind>. Yaaay!
* module/language/tree-il/analyze.scm (analyze-lexicals): Remove dynwind
cases.
* module/language/tree-il/compile-glil.scm (*primcall-ops*): Add wind
and unwind.
(flatten-lambda-case): Remove dynwind case. Yay!
* module/language/tree-il/cse.scm (cse):
* module/language/tree-il/debug.scm (verify-tree-il):
* module/language/tree-il/effects.scm (make-effects-analyzer):
* module/language/tree-il/peval.scm (singly-valued-expression?, peval):
Remove <dywind> cases. Inline primcalls to dynamic-wind. Add
constant folding for thunk?.
* module/language/tree-il/primitives.scm (*interesting-primitive-names*):
Remove @dynamic-wind, and add procedure? and thunk?.
(*effect+exception-free-primitives*): Add procedure? and thunk?.
(*multiply-valued-primitives*): Remove @dynamic-wind.
Remove @dynamic-wind expander.
* test-suite/tests/peval.test ("partial evaluation"): Update tests for
dynwind desugaring.
This commit is contained in:
Andy Wingo
parent
0fcc39a0a9
commit
bb97e4abd4
17 changed files with 108 additions and 280 deletions
|
|
@ -432,11 +432,6 @@
|
|||
`(call-with-values (lambda () ,@(recurse-body exp))
|
||||
,(recurse (make-lambda #f '() body))))
|
||||
|
||||
((<dynwind> body winder unwinder)
|
||||
`(dynamic-wind ,(recurse winder)
|
||||
(lambda () ,@(recurse-body body))
|
||||
,(recurse unwinder)))
|
||||
|
||||
((<dynlet> fluids vals body)
|
||||
`(with-fluids ,(map list
|
||||
(map recurse fluids)
|
||||
|
|
@ -761,10 +756,6 @@
|
|||
(primitive 'call-with-values)
|
||||
(recurse exp) (recurse body))
|
||||
|
||||
((<dynwind> winder body unwinder)
|
||||
(primitive 'dynamic-wind)
|
||||
(recurse winder) (recurse body) (recurse unwinder))
|
||||
|
||||
((<dynlet> fluids vals body)
|
||||
(primitive 'with-fluids)
|
||||
(for-each recurse fluids)
|
||||
|
|
|
|||
|
|
@ -46,7 +46,6 @@
|
|||
<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-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
|
||||
|
|
@ -136,7 +135,6 @@
|
|||
(define-type (<tree-il> #:common-slots (src) #:printer print-tree-il)
|
||||
(<fix> names gensyms vals body)
|
||||
(<let-values> exp body)
|
||||
(<dynwind> winder body unwinder)
|
||||
(<dynref> fluid)
|
||||
(<dynset> fluid exp)
|
||||
(<prompt> tag body handler)
|
||||
|
|
@ -249,9 +247,6 @@
|
|||
(('let-values exp body)
|
||||
(make-let-values loc (retrans exp) (retrans body)))
|
||||
|
||||
(('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)))
|
||||
|
||||
|
|
@ -339,11 +334,6 @@
|
|||
(($ <let-values> src exp body)
|
||||
`(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))
|
||||
|
||||
(($ <dynwind> src winder body unwinder)
|
||||
`(dynwind ,(unparse-tree-il winder)
|
||||
,(unparse-tree-il body)
|
||||
,(unparse-tree-il unwinder)))
|
||||
|
||||
(($ <dynlet> src fluids vals body)
|
||||
`(dynlet ,(map unparse-tree-il fluids) ,(map unparse-tree-il vals)
|
||||
,(unparse-tree-il body)))
|
||||
|
|
@ -424,10 +414,6 @@
|
|||
(($ <let-values> src exp body)
|
||||
(let*-values (((seed ...) (foldts exp seed ...)))
|
||||
(foldts body seed ...)))
|
||||
(($ <dynwind> src winder body unwinder)
|
||||
(let*-values (((seed ...) (foldts winder 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 ...)))
|
||||
|
|
@ -527,9 +513,6 @@ 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)))
|
||||
|
||||
(($ <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)))
|
||||
|
||||
|
|
|
|||
|
|
@ -337,9 +337,6 @@
|
|||
((<let-values> exp body)
|
||||
(lset-union eq? (step exp) (step body)))
|
||||
|
||||
((<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))))
|
||||
|
||||
|
|
@ -511,9 +508,6 @@
|
|||
((<let-values> exp body)
|
||||
(max (recur exp) (recur body)))
|
||||
|
||||
((<dynwind> winder body unwinder)
|
||||
(max (recur winder) (recur body) (recur unwinder)))
|
||||
|
||||
((<dynlet> fluids vals body)
|
||||
(apply max (recur body) (map recur (append fluids vals))))
|
||||
|
||||
|
|
|
|||
|
|
@ -135,6 +135,9 @@
|
|||
;; hack for lua
|
||||
(return/values . return/values)
|
||||
|
||||
((wind . 2) . wind)
|
||||
((unwind . 0) . unwind)
|
||||
|
||||
((bytevector-u8-ref . 2) . bv-u8-ref)
|
||||
((bytevector-u8-set! . 3) . bv-u8-set)
|
||||
((bytevector-s8-ref . 2) . bv-s8-ref)
|
||||
|
|
@ -940,74 +943,6 @@
|
|||
(clear-stack-slots context gensyms)
|
||||
(emit-code #f (make-glil-unbind))))))
|
||||
|
||||
((<dynwind> src winder body unwinder)
|
||||
(define (thunk? x)
|
||||
(and (lambda? x)
|
||||
(null? (lambda-case-gensyms (lambda-body x)))))
|
||||
(define (make-wrong-type-arg x)
|
||||
(make-primcall src 'scm-error
|
||||
(list
|
||||
(make-const #f 'wrong-type-arg)
|
||||
(make-const #f "dynamic-wind")
|
||||
(make-const #f "Wrong type (expecting thunk): ~S")
|
||||
(make-primcall #f 'list (list x))
|
||||
(make-primcall #f 'list (list x)))))
|
||||
(define (emit-thunk-check x)
|
||||
(comp-drop (make-conditional
|
||||
src
|
||||
(make-primcall src 'thunk? (list x))
|
||||
(make-void #f)
|
||||
(make-wrong-type-arg x))))
|
||||
|
||||
;; 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)
|
||||
(emit-code #f (make-glil-call 'wind 2))
|
||||
|
||||
(case context
|
||||
((tail)
|
||||
(let ((MV (make-label)))
|
||||
(comp-vals body MV)
|
||||
;; One value. Unwind and return the value.
|
||||
(emit-code #f (make-glil-call 'unwind 0))
|
||||
(emit-code #f (make-glil-call 'return 1))
|
||||
|
||||
(emit-label MV)
|
||||
;; Multiple values. Unwind and return the values.
|
||||
(emit-code #f (make-glil-call 'unwind 0))
|
||||
(emit-code #f (make-glil-call 'return/nvalues 1))))
|
||||
|
||||
((push)
|
||||
;; We only want one value, so ask for one value and then
|
||||
;; unwind, leaving the value on the stack.
|
||||
(comp-push body)
|
||||
(emit-code #f (make-glil-call 'unwind 0)))
|
||||
|
||||
((vals)
|
||||
(let ((MV (make-label)))
|
||||
(comp-vals body MV)
|
||||
;; 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 and go to the MVRA.
|
||||
(emit-code #f (make-glil-call 'unwind 0))
|
||||
(emit-branch #f 'br MVRA)))
|
||||
|
||||
((drop)
|
||||
;; 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))
|
||||
(if RA
|
||||
(emit-branch #f 'br RA)))))
|
||||
|
||||
((<dynlet> src fluids vals body)
|
||||
(for-each comp-push fluids)
|
||||
(for-each comp-push vals)
|
||||
|
|
|
|||
|
|
@ -442,15 +442,6 @@
|
|||
((consumer db**) (visit consumer (concat db* db) env ctx)))
|
||||
(return (make-let-values src producer consumer)
|
||||
(concat db** db*))))
|
||||
(($ <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**))
|
||||
((body db*) (visit body (concat db** db) env ctx))
|
||||
((db**) (concat db* db**)))
|
||||
(return (make-dynwind src winder body unwinder)
|
||||
db**)))
|
||||
(($ <dynlet> src fluids vals body)
|
||||
(let*-values (((fluids db*) (parallel-visit fluids db env 'value))
|
||||
((vals db**) (parallel-visit vals db env 'value))
|
||||
|
|
|
|||
|
|
@ -216,10 +216,6 @@
|
|||
(for-each (cut visit <> env) fluids)
|
||||
(for-each (cut visit <> env) vals)
|
||||
(visit body env))))
|
||||
(($ <dynwind> src winder body unwinder)
|
||||
(visit winder env)
|
||||
(visit body env)
|
||||
(visit unwinder env))
|
||||
(($ <dynref> src fluid)
|
||||
(visit fluid env))
|
||||
(($ <dynset> src fluid exp)
|
||||
|
|
|
|||
|
|
@ -211,10 +211,6 @@ of an expression."
|
|||
(logior (compute-effects producer)
|
||||
(compute-effects consumer)
|
||||
(cause &type-check)))
|
||||
(($ <dynwind> _ winder body unwinder)
|
||||
(logior (compute-effects winder)
|
||||
(compute-effects body)
|
||||
(compute-effects unwinder)))
|
||||
(($ <dynlet> _ fluids vals body)
|
||||
(logior (accumulate-effects fluids)
|
||||
(accumulate-effects vals)
|
||||
|
|
|
|||
|
|
@ -104,8 +104,6 @@
|
|||
(($ <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)
|
||||
|
|
@ -543,10 +541,6 @@ top-level bindings from ENV and return the resulting expression."
|
|||
(($ <prompt>) #f)
|
||||
(($ <abort>) #f)
|
||||
|
||||
;; Bail on dynwinds, as that would cause the consumer to run in
|
||||
;; the wrong dynamic context.
|
||||
(($ <dynwind>) #f)
|
||||
|
||||
;; Propagate to tail positions.
|
||||
(($ <let> src names gensyms vals body)
|
||||
(let ((body (loop body)))
|
||||
|
|
@ -1002,11 +996,6 @@ top-level bindings from ENV and return the resulting expression."
|
|||
(else #f))))
|
||||
(_ #f))
|
||||
(make-let-values lv-src producer (for-tail consumer)))))
|
||||
(($ <dynwind> src winder body unwinder)
|
||||
(make-dynwind src
|
||||
(for-value winder)
|
||||
(for-tail body)
|
||||
(for-value unwinder)))
|
||||
(($ <dynlet> src fluids vals body)
|
||||
(make-dynlet src (map for-value fluids) (map for-value vals)
|
||||
(for-tail body)))
|
||||
|
|
@ -1169,13 +1158,29 @@ top-level bindings from ENV and return the resulting expression."
|
|||
(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 '()))))))))
|
||||
(make-seq
|
||||
src
|
||||
(make-seq
|
||||
src
|
||||
(make-conditional
|
||||
src
|
||||
;; fixme: introduce logic to fold thunk?
|
||||
(make-primcall src 'thunk? (list u))
|
||||
(make-call src w '())
|
||||
(make-primcall
|
||||
src 'scm-error
|
||||
(list
|
||||
(make-const #f 'wrong-type-arg)
|
||||
(make-const #f "dynamic-wind")
|
||||
(make-const #f "Wrong type (expecting thunk): ~S")
|
||||
(make-primcall #f 'list (list u))
|
||||
(make-primcall #f 'list (list u)))))
|
||||
(make-primcall src 'wind (list w u)))
|
||||
(make-begin0 src
|
||||
(make-call src thunk '())
|
||||
(make-seq src
|
||||
(make-primcall src 'unwind '())
|
||||
(make-call src u '())))))))))
|
||||
|
||||
(($ <primcall> src 'values exps)
|
||||
(cond
|
||||
|
|
@ -1244,6 +1249,15 @@ top-level bindings from ENV and return the resulting expression."
|
|||
((name . args)
|
||||
(make-primcall src name args))))))
|
||||
|
||||
(($ <primcall> src 'thunk? (proc))
|
||||
(match (for-value proc)
|
||||
(($ <lambda> _ _ ($ <lambda-case> _ req))
|
||||
(for-tail (make-const src (null? req))))
|
||||
(proc
|
||||
(case ctx
|
||||
((effect) (make-void src))
|
||||
(else (make-primcall src 'thunk? (list proc)))))))
|
||||
|
||||
(($ <primcall> src (? accessor-primitive? name) args)
|
||||
(match (cons name (map for-value args))
|
||||
;; FIXME: these for-tail recursions could take place outside
|
||||
|
|
|
|||
|
|
@ -41,7 +41,6 @@
|
|||
call-with-current-continuation
|
||||
call/cc
|
||||
dynamic-wind
|
||||
@dynamic-wind
|
||||
values
|
||||
eq? eqv? equal?
|
||||
memq memv
|
||||
|
|
@ -51,6 +50,8 @@
|
|||
not
|
||||
pair? null? list? symbol? vector? string? struct? number? char? nil?
|
||||
|
||||
procedure? thunk?
|
||||
|
||||
complex? real? rational? inf? nan? integer? exact? inexact? even? odd?
|
||||
|
||||
char<? char<=? char>=? char>?
|
||||
|
|
@ -176,6 +177,7 @@
|
|||
eq? eqv? equal?
|
||||
not
|
||||
pair? null? list? symbol? vector? struct? string? number? char?
|
||||
procedure? thunk?
|
||||
acons cons cons* list vector))
|
||||
|
||||
;; Primitives that don't always return one value.
|
||||
|
|
@ -185,7 +187,6 @@
|
|||
call-with-current-continuation
|
||||
call/cc
|
||||
dynamic-wind
|
||||
@dynamic-wind
|
||||
values
|
||||
call-with-prompt
|
||||
@abort abort-to-prompt))
|
||||
|
|
@ -533,38 +534,6 @@
|
|||
(hashq-set! *primitive-expand-table* 'eqv? maybe-simplify-to-eq)
|
||||
(hashq-set! *primitive-expand-table* 'equal? maybe-simplify-to-eq)
|
||||
|
||||
(hashq-set! *primitive-expand-table*
|
||||
'@dynamic-wind
|
||||
(case-lambda
|
||||
((src pre expr 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
|
||||
(case-lambda
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue