mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-19 02:00:26 +02:00
Remove with-fluids; replaced by with-fluid* and inlined push-fluid primops
* libguile/vm-i-system.c (push-fluid, pop-fluid): * doc/ref/vm.texi (Dynamic Environment Instructions): Rename wind-fluids to push-fluid, and unwind-fluids to pop-fluid. They now only work on one fluid binding at a time. * module/ice-9/boot-9.scm (with-fluid*): Implement in Scheme in terms of primcalls to push-fluid and pop-fluid. (custom-throw-handler, catch, with-throw-handler): Use with-fluid* instead of with-fluids, as with-fluids is no longer available before psyntax is loaded. (with-fluids): Define in Scheme in terms of with-fluid*. * libguile/fluids.c (scm_with_fluid): Rename from scm_with_fluids, and don't expose to Scheme. * libguile/eval.c (eval): Remove SCM_M_WITH_FLUIDS case. * libguile/expand.c (expand_with_fluids): Remove with-fluids syntax. (DYNLET): Remove, no longer defining dynlet in the %expanded-vtables. * libguile/expand.h: Remove dynlet definitions. * module/ice-9/eval.scm (primitive-eval): Remove with-fluids case. * libguile/memoize.c (do_push_fluid, do_pop_fluid): New primitive helpers, like wind and unwind. (memoize): Memoize wind and unwind primcalls. Don't memoize dynlet to with-fluids. (scm_init_memoize): Initialize push_fluid and pop_fluid here. * libguile/memoize.h (SCM_M_WITH_FLUIDS): Remove definition. * module/ice-9/psyntax.scm (build-dynlet): Remove; this just supported with-fluids, which is now defined in boot-9. * module/ice-9/psyntax-pp.scm: Regenerate. * doc/ref/compiler.texi (Tree-IL): * module/language/tree-il.scm: * module/language/tree-il/analyze.scm: * module/language/tree-il/canonicalize.scm: * module/language/tree-il/compile-glil.scm: * module/language/tree-il/cse.scm: * module/language/tree-il/debug.scm: * module/language/tree-il/effects.scm: Remove <dynlet>. Add cases for primcalls to push-fluid and pop-fluid in compile-glil.scm and effects.scm. * module/language/tree-il/peval.scm (peval): Factor out with-temporaries; probably a bad idea, but works for now. Factor out make-begin0 (a better idea). Inline primcalls to with-fluid*, and remove dynlet cases. * module/language/tree-il/primitives.scm (*interesting-primitive-names*): Add with-fluid*.
This commit is contained in:
Andy Wingo
parent
5e0253f19e
commit
c32b7c4cef
24 changed files with 178 additions and 351 deletions
|
|
@ -1,6 +1,6 @@
|
|||
;;; Guile Emacs Lisp
|
||||
|
||||
;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
|
|
@ -297,6 +297,25 @@
|
|||
meta
|
||||
(make-lambda-case #f req opt rest #f init vars body #f)))
|
||||
|
||||
(define (make-dynlet src fluids vals body)
|
||||
(let ((f (map (lambda (x) (gensym "fluid ")) fluids))
|
||||
(v (map (lambda (x) (gensym "valud ")) vals)))
|
||||
(make-let src (map (lambda (_) 'fluid) fluids) f fluids
|
||||
(make-let src (map (lambda (_) 'val) vals) v vals
|
||||
(let lp ((f f) (v v))
|
||||
(if (null? f)
|
||||
body
|
||||
(make-primcall
|
||||
src 'with-fluid*
|
||||
(list (make-lexical-ref #f 'fluid (car f))
|
||||
(make-lexical-ref #f 'val (car v))
|
||||
(make-lambda
|
||||
src '()
|
||||
(make-lambda-case
|
||||
src '() #f #f #f '() '()
|
||||
(lp (cdr f) (cdr v))
|
||||
#f))))))))))
|
||||
|
||||
(define (compile-lambda loc meta args body)
|
||||
(receive (valid? req-ids opt-ids rest-id)
|
||||
(parse-lambda-list args)
|
||||
|
|
|
|||
|
|
@ -432,12 +432,6 @@
|
|||
`(call-with-values (lambda () ,@(recurse-body exp))
|
||||
,(recurse (make-lambda #f '() body))))
|
||||
|
||||
((<dynlet> fluids vals body)
|
||||
`(with-fluids ,(map list
|
||||
(map recurse fluids)
|
||||
(map recurse vals))
|
||||
,@(recurse-body body)))
|
||||
|
||||
((<prompt> tag body handler)
|
||||
`(call-with-prompt
|
||||
,(recurse tag)
|
||||
|
|
@ -750,12 +744,6 @@
|
|||
(primitive 'call-with-values)
|
||||
(recurse exp) (recurse body))
|
||||
|
||||
((<dynlet> fluids vals body)
|
||||
(primitive 'with-fluids)
|
||||
(for-each recurse fluids)
|
||||
(for-each recurse vals)
|
||||
(recurse body))
|
||||
|
||||
((<prompt> tag body handler)
|
||||
(primitive 'call-with-prompt)
|
||||
(primitive 'lambda)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
<dynlet> dynlet? make-dynlet dynlet-src dynlet-fluids dynlet-vals dynlet-body
|
||||
<prompt> prompt? make-prompt prompt-src prompt-tag prompt-body prompt-handler
|
||||
<abort> abort? make-abort abort-src abort-tag abort-args abort-tail
|
||||
|
||||
|
|
@ -128,7 +127,6 @@
|
|||
;; (<lambda-case> req opt rest kw inits gensyms body alternate)
|
||||
;; (<let> names gensyms vals body)
|
||||
;; (<letrec> in-order? names gensyms vals body)
|
||||
;; (<dynlet> fluids vals body)
|
||||
|
||||
(define-type (<tree-il> #:common-slots (src) #:printer print-tree-il)
|
||||
(<fix> names gensyms vals body)
|
||||
|
|
@ -243,9 +241,6 @@
|
|||
(('let-values exp body)
|
||||
(make-let-values loc (retrans exp) (retrans body)))
|
||||
|
||||
(('dynlet fluids vals body)
|
||||
(make-dynlet loc (map retrans fluids) (map retrans vals) (retrans body)))
|
||||
|
||||
(('prompt tag body handler)
|
||||
(make-prompt loc (retrans tag) (retrans body) (retrans handler)))
|
||||
|
||||
|
|
@ -324,10 +319,6 @@
|
|||
(($ <let-values> src exp body)
|
||||
`(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))
|
||||
|
||||
(($ <dynlet> src fluids vals body)
|
||||
`(dynlet ,(map unparse-tree-il fluids) ,(map unparse-tree-il vals)
|
||||
,(unparse-tree-il body)))
|
||||
|
||||
(($ <prompt> src tag body handler)
|
||||
`(prompt ,(unparse-tree-il tag)
|
||||
,(unparse-tree-il body)
|
||||
|
|
@ -398,10 +389,6 @@
|
|||
(($ <let-values> src exp body)
|
||||
(let*-values (((seed ...) (foldts exp seed ...)))
|
||||
(foldts body seed ...)))
|
||||
(($ <dynlet> src fluids vals body)
|
||||
(let*-values (((seed ...) (fold-values foldts fluids seed ...))
|
||||
((seed ...) (fold-values foldts vals seed ...)))
|
||||
(foldts body seed ...)))
|
||||
(($ <prompt> src tag body handler)
|
||||
(let*-values (((seed ...) (foldts tag seed ...))
|
||||
((seed ...) (foldts body seed ...)))
|
||||
|
|
@ -492,9 +479,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)))
|
||||
|
||||
(($ <dynlet> src fluids vals body)
|
||||
(make-dynlet src (map lp fluids) (map lp vals) (lp body)))
|
||||
|
||||
(($ <prompt> src tag body handler)
|
||||
(make-prompt src (lp tag) (lp body) (lp handler)))
|
||||
|
||||
|
|
|
|||
|
|
@ -337,9 +337,6 @@
|
|||
((<let-values> exp body)
|
||||
(lset-union eq? (step exp) (step body)))
|
||||
|
||||
((<dynlet> fluids vals body)
|
||||
(apply lset-union eq? (step body) (map step (append fluids vals))))
|
||||
|
||||
((<prompt> tag body handler)
|
||||
(lset-union eq? (step tag) (step body) (step-tail handler)))
|
||||
|
||||
|
|
@ -502,9 +499,6 @@
|
|||
((<let-values> exp body)
|
||||
(max (recur exp) (recur body)))
|
||||
|
||||
((<dynlet> fluids vals body)
|
||||
(apply max (recur body) (map recur (append fluids vals))))
|
||||
|
||||
((<prompt> tag body handler)
|
||||
(let ((cont-var (and (lambda-case? handler)
|
||||
(pair? (lambda-case-gensyms handler))
|
||||
|
|
|
|||
|
|
@ -40,8 +40,6 @@
|
|||
body)
|
||||
(($ <fix> src () () () body)
|
||||
body)
|
||||
(($ <dynlet> src () () body)
|
||||
body)
|
||||
(($ <lambda> src meta #f)
|
||||
;; Give a body to case-lambda with no clauses.
|
||||
(make-lambda
|
||||
|
|
|
|||
|
|
@ -139,6 +139,8 @@
|
|||
|
||||
((wind . 2) . wind)
|
||||
((unwind . 0) . unwind)
|
||||
((push-fluid . 2) . push-fluid)
|
||||
((pop-fluid . 0) . pop-fluid)
|
||||
|
||||
((bytevector-u8-ref . 2) . bv-u8-ref)
|
||||
((bytevector-u8-set! . 3) . bv-u8-set)
|
||||
|
|
@ -945,52 +947,6 @@
|
|||
(clear-stack-slots context gensyms)
|
||||
(emit-code #f (make-glil-unbind))))))
|
||||
|
||||
((<dynlet> src fluids vals body)
|
||||
(for-each comp-push fluids)
|
||||
(for-each comp-push vals)
|
||||
(emit-code #f (make-glil-call 'wind-fluids (length fluids)))
|
||||
|
||||
(case context
|
||||
((tail)
|
||||
(let ((MV (make-label)))
|
||||
;; NB: in tail case, it is possible to preserve asymptotic tail
|
||||
;; recursion, via merging unwind-fluids structures -- but we'd need
|
||||
;; to compile in the body twice (once in tail context, assuming the
|
||||
;; caller unwinds, and once with this trampoline thing, unwinding
|
||||
;; ourselves).
|
||||
(comp-vals body MV)
|
||||
;; one value: unwind and return
|
||||
(emit-code #f (make-glil-call 'unwind-fluids 0))
|
||||
(emit-code #f (make-glil-call 'return 1))
|
||||
|
||||
(emit-label MV)
|
||||
;; multiple values: unwind and return values
|
||||
(emit-code #f (make-glil-call 'unwind-fluids 0))
|
||||
(emit-code #f (make-glil-call 'return/nvalues 1))))
|
||||
|
||||
((push)
|
||||
(comp-push body)
|
||||
(emit-code #f (make-glil-call 'unwind-fluids 0)))
|
||||
|
||||
((vals)
|
||||
(let ((MV (make-label)))
|
||||
(comp-vals body MV)
|
||||
;; one value: push 1 and fall through to MV case
|
||||
(emit-code #f (make-glil-const 1))
|
||||
|
||||
(emit-label MV)
|
||||
;; multiple values: unwind and goto MVRA
|
||||
(emit-code #f (make-glil-call 'unwind-fluids 0))
|
||||
(emit-branch #f 'br MVRA)))
|
||||
|
||||
((drop)
|
||||
;; compile body, discarding values. then unwind...
|
||||
(comp-drop body)
|
||||
(emit-code #f (make-glil-call 'unwind-fluids 0))
|
||||
;; and fall through, or goto RA if there is one.
|
||||
(if RA
|
||||
(emit-branch #f 'br RA)))))
|
||||
|
||||
;; What's the deal here? The deal is that we are compiling the start of a
|
||||
;; delimited continuation. We try to avoid heap allocation in the normal
|
||||
;; case; so the body is an expression, not a thunk, and we try to render
|
||||
|
|
|
|||
|
|
@ -442,13 +442,6 @@
|
|||
((consumer db**) (visit consumer (concat db* db) env ctx)))
|
||||
(return (make-let-values src producer consumer)
|
||||
(concat db** db*))))
|
||||
(($ <dynlet> src fluids vals body)
|
||||
(let*-values (((fluids db*) (parallel-visit fluids db env 'value))
|
||||
((vals db**) (parallel-visit vals db env 'value))
|
||||
((body db***) (visit body (concat db** (concat db* db))
|
||||
env ctx)))
|
||||
(return (make-dynlet src fluids vals body)
|
||||
(concat db*** (concat db** db*)))))
|
||||
(($ <toplevel-ref>)
|
||||
(return exp vlist-null))
|
||||
(($ <module-ref>)
|
||||
|
|
|
|||
|
|
@ -204,18 +204,6 @@
|
|||
(error "name should be symbol" exp))
|
||||
(else
|
||||
(visit exp env))))
|
||||
(($ <dynlet> src fluids vals body)
|
||||
(cond
|
||||
((not (list? fluids))
|
||||
(error "fluids should be list" exp))
|
||||
((not (list? vals))
|
||||
(error "vals should be list" exp))
|
||||
((not (= (length fluids) (length vals)))
|
||||
(error "mismatch in fluids/vals" exp))
|
||||
(else
|
||||
(for-each (cut visit <> env) fluids)
|
||||
(for-each (cut visit <> env) vals)
|
||||
(visit body env))))
|
||||
(($ <conditional> src condition subsequent alternate)
|
||||
(visit condition env)
|
||||
(visit subsequent env)
|
||||
|
|
|
|||
|
|
@ -211,12 +211,6 @@ of an expression."
|
|||
(logior (compute-effects producer)
|
||||
(compute-effects consumer)
|
||||
(cause &type-check)))
|
||||
(($ <dynlet> _ fluids vals body)
|
||||
(logior (accumulate-effects fluids)
|
||||
(accumulate-effects vals)
|
||||
(cause &type-check)
|
||||
(cause &fluid)
|
||||
(compute-effects body)))
|
||||
(($ <toplevel-ref>)
|
||||
(logior &toplevel
|
||||
(cause &type-check)))
|
||||
|
|
@ -284,6 +278,15 @@ of an expression."
|
|||
(cause &type-check)
|
||||
(cause &fluid)))
|
||||
|
||||
(($ <primcall> _ 'push-fluid (fluid val))
|
||||
(logior (compute-effects fluid)
|
||||
(compute-effects val)
|
||||
(cause &type-check)
|
||||
(cause &fluid)))
|
||||
|
||||
(($ <primcall> _ 'pop-fluid ())
|
||||
(logior (cause &fluid)))
|
||||
|
||||
;; Primitives that are normally effect-free, but which might
|
||||
;; cause type checks, allocate memory, or access mutable
|
||||
;; memory. FIXME: expand, to be more precise.
|
||||
|
|
|
|||
|
|
@ -433,6 +433,47 @@ top-level bindings from ENV and return the resulting expression."
|
|||
(define (lexical-refcount sym)
|
||||
(var-refcount (lookup-var sym)))
|
||||
|
||||
(define (with-temporaries src exps refcount can-copy? k)
|
||||
(let* ((pairs (map (match-lambda
|
||||
((and exp (? can-copy?))
|
||||
(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))))
|
||||
|
||||
;; ORIG has been alpha-renamed to NEW. Analyze NEW and record a link
|
||||
;; from it to ORIG.
|
||||
;;
|
||||
|
|
@ -559,10 +600,6 @@ top-level bindings from ENV and return the resulting expression."
|
|||
(make-let-values src exp
|
||||
(make-lambda-case src2 req opt rest kw
|
||||
inits gensyms body #f)))))
|
||||
(($ <dynlet> src fluids vals body)
|
||||
(let ((body (loop body)))
|
||||
(and body
|
||||
(make-dynlet src fluids vals body))))
|
||||
(($ <seq> src head tail)
|
||||
(let ((tail (loop tail)))
|
||||
(and tail (make-seq src head tail)))))))
|
||||
|
|
@ -994,9 +1031,6 @@ top-level bindings from ENV and return the resulting expression."
|
|||
(else #f))))
|
||||
(_ #f))
|
||||
(make-let-values lv-src producer (for-tail consumer)))))
|
||||
(($ <dynlet> src fluids vals body)
|
||||
(make-dynlet src (map for-value fluids) (map for-value vals)
|
||||
(for-tail body)))
|
||||
(($ <toplevel-ref> src (? effect-free-primitive? name))
|
||||
exp)
|
||||
(($ <toplevel-ref>)
|
||||
|
|
@ -1108,48 +1142,9 @@ top-level bindings from ENV and return the resulting expression."
|
|||
(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
|
||||
(with-temporaries
|
||||
(list w u) 2
|
||||
src (list w u) 2 constant-expression?
|
||||
(match-lambda
|
||||
((w u)
|
||||
(make-seq
|
||||
|
|
@ -1176,6 +1171,18 @@ top-level bindings from ENV and return the resulting expression."
|
|||
(make-primcall src 'unwind '())
|
||||
(make-call src u '())))))))))
|
||||
|
||||
(($ <primcall> src 'with-fluid* (f v thunk))
|
||||
(for-tail
|
||||
(with-temporaries
|
||||
src (list f v thunk) 1 constant-expression?
|
||||
(match-lambda
|
||||
((f v thunk)
|
||||
(make-seq src
|
||||
(make-primcall src 'push-fluid (list f v))
|
||||
(make-begin0 src
|
||||
(make-call src thunk '())
|
||||
(make-primcall src 'pop-fluid '()))))))))
|
||||
|
||||
(($ <primcall> src 'values exps)
|
||||
(cond
|
||||
((null? exps)
|
||||
|
|
|
|||
|
|
@ -76,7 +76,7 @@
|
|||
variable-ref variable-set!
|
||||
variable-bound?
|
||||
|
||||
fluid-ref fluid-set!
|
||||
fluid-ref fluid-set! with-fluid*
|
||||
|
||||
call-with-prompt
|
||||
abort-to-prompt* abort-to-prompt
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue