summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2013-06-27 18:49:21 +0200
committerAndy Wingo <wingo@pobox.com>2013-06-27 22:02:43 +0200
commitbb97e4abd49e8094e9eb8bf767c696bf7ee1ba7e (patch)
tree4a266c032b794c87f7ebd8f8101339b21f51607d /module
parent0fcc39a0a962e44d509dbb659529165c7ce5b91d (diff)
downloadguile-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.scm11
-rw-r--r--module/ice-9/eval.scm6
-rw-r--r--module/language/scheme/decompile-tree-il.scm9
-rw-r--r--module/language/tree-il.scm17
-rw-r--r--module/language/tree-il/analyze.scm6
-rw-r--r--module/language/tree-il/compile-glil.scm71
-rw-r--r--module/language/tree-il/cse.scm9
-rw-r--r--module/language/tree-il/debug.scm4
-rw-r--r--module/language/tree-il/effects.scm4
-rw-r--r--module/language/tree-il/peval.scm50
-rw-r--r--module/language/tree-il/primitives.scm37
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))