diff options
author | Andy Wingo <wingo@pobox.com> | 2013-06-27 18:49:21 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2013-06-27 22:02:43 +0200 |
commit | bb97e4abd49e8094e9eb8bf767c696bf7ee1ba7e (patch) | |
tree | 4a266c032b794c87f7ebd8f8101339b21f51607d /module | |
parent | 0fcc39a0a962e44d509dbb659529165c7ce5b91d (diff) | |
download | guile-bb97e4abd49e8094e9eb8bf767c696bf7ee1ba7e.tar.gz |
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.
Diffstat (limited to 'module')
-rw-r--r-- | module/ice-9/boot-9.scm | 11 | ||||
-rw-r--r-- | module/ice-9/eval.scm | 6 | ||||
-rw-r--r-- | module/language/scheme/decompile-tree-il.scm | 9 | ||||
-rw-r--r-- | module/language/tree-il.scm | 17 | ||||
-rw-r--r-- | module/language/tree-il/analyze.scm | 6 | ||||
-rw-r--r-- | module/language/tree-il/compile-glil.scm | 71 | ||||
-rw-r--r-- | module/language/tree-il/cse.scm | 9 | ||||
-rw-r--r-- | module/language/tree-il/debug.scm | 4 | ||||
-rw-r--r-- | module/language/tree-il/effects.scm | 4 | ||||
-rw-r--r-- | module/language/tree-il/peval.scm | 50 | ||||
-rw-r--r-- | module/language/tree-il/primitives.scm | 37 |
11 files changed, 48 insertions, 176 deletions
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index c99ca40cb..d6c4cfd92 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -266,7 +266,16 @@ x a-cont @result{} special-binding @end lisp" - (@dynamic-wind in (thunk) out)) + (if (thunk? out) + (in) + (scm-error 'wrong-type-arg "dynamic-wind" "Not a thunk: ~S" + (list out) #f)) + ((@@ primitive wind) in out) + (call-with-values thunk + (lambda vals + ((@@ primitive unwind)) + (out) + (apply values vals)))) diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm index 3b5964b68..0e6aeac05 100644 --- a/module/ice-9/eval.scm +++ b/module/ice-9/eval.scm @@ -203,7 +203,6 @@ ;;; module-ref: 14468 ;;; define: 1259 ;;; toplevel-set: 328 -;;; dynwind: 162 ;;; with-fluids: 0 ;;; call/cc: 0 ;;; module-set: 0 @@ -463,11 +462,6 @@ env)))) (eval x env))) - (('dynwind (in exp . out)) - (dynamic-wind (eval in env) - (lambda () (eval exp env)) - (eval out env))) - (('with-fluids (fluids vals . exp)) (let* ((fluids (map (lambda (x) (eval x env)) fluids)) (vals (map (lambda (x) (eval x env)) vals))) diff --git a/module/language/scheme/decompile-tree-il.scm b/module/language/scheme/decompile-tree-il.scm index c065474b5..b265b936c 100644 --- a/module/language/scheme/decompile-tree-il.scm +++ b/module/language/scheme/decompile-tree-il.scm @@ -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) diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm index b8009128b..633bb6dcd 100644 --- a/module/language/tree-il.scm +++ b/module/language/tree-il.scm @@ -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))) diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index 84a044ce2..1fbeb2c65 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -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)))) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index 2aad6a1f2..85b87b067 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -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) diff --git a/module/language/tree-il/cse.scm b/module/language/tree-il/cse.scm index 4c50114fe..31947dd0d 100644 --- a/module/language/tree-il/cse.scm +++ b/module/language/tree-il/cse.scm @@ -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)) diff --git a/module/language/tree-il/debug.scm b/module/language/tree-il/debug.scm index 6a3b3dc52..fbc56c6ba 100644 --- a/module/language/tree-il/debug.scm +++ b/module/language/tree-il/debug.scm @@ -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) diff --git a/module/language/tree-il/effects.scm b/module/language/tree-il/effects.scm index b9b34a11c..170c89669 100644 --- a/module/language/tree-il/effects.scm +++ b/module/language/tree-il/effects.scm @@ -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) diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index 662adb493..afa92f6de 100644 --- a/module/language/tree-il/peval.scm +++ b/module/language/tree-il/peval.scm @@ -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 diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index 4036b7ede..7112680fe 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -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)) @@ -534,38 +535,6 @@ (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 ((src fluid) (make-dynref src fluid)) |