summaryrefslogtreecommitdiff
path: root/module/language
diff options
context:
space:
mode:
Diffstat (limited to 'module/language')
-rw-r--r--module/language/elisp/compile-tree-il.scm21
-rw-r--r--module/language/scheme/decompile-tree-il.scm12
-rw-r--r--module/language/tree-il.scm16
-rw-r--r--module/language/tree-il/analyze.scm6
-rw-r--r--module/language/tree-il/canonicalize.scm2
-rw-r--r--module/language/tree-il/compile-glil.scm48
-rw-r--r--module/language/tree-il/cse.scm7
-rw-r--r--module/language/tree-il/debug.scm12
-rw-r--r--module/language/tree-il/effects.scm15
-rw-r--r--module/language/tree-il/peval.scm101
-rw-r--r--module/language/tree-il/primitives.scm2
11 files changed, 86 insertions, 156 deletions
diff --git a/module/language/elisp/compile-tree-il.scm b/module/language/elisp/compile-tree-il.scm
index 1a4d00faa..c0b5f8815 100644
--- a/module/language/elisp/compile-tree-il.scm
+++ b/module/language/elisp/compile-tree-il.scm
@@ -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)
diff --git a/module/language/scheme/decompile-tree-il.scm b/module/language/scheme/decompile-tree-il.scm
index 7dc55bfcb..dca969f92 100644
--- a/module/language/scheme/decompile-tree-il.scm
+++ b/module/language/scheme/decompile-tree-il.scm
@@ -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)
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 1580142cd..16fdb96e5 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
- <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)))
diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm
index 673f68b2d..ca7cb80a4 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)))
- ((<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))
diff --git a/module/language/tree-il/canonicalize.scm b/module/language/tree-il/canonicalize.scm
index b291eaab9..9b0c0c8cd 100644
--- a/module/language/tree-il/canonicalize.scm
+++ b/module/language/tree-il/canonicalize.scm
@@ -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
diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index c2dba522f..96a06ab71 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -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
diff --git a/module/language/tree-il/cse.scm b/module/language/tree-il/cse.scm
index ffddc1934..656dd72c6 100644
--- a/module/language/tree-il/cse.scm
+++ b/module/language/tree-il/cse.scm
@@ -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>)
diff --git a/module/language/tree-il/debug.scm b/module/language/tree-il/debug.scm
index d5dab80c5..8ec573a73 100644
--- a/module/language/tree-il/debug.scm
+++ b/module/language/tree-il/debug.scm
@@ -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)
diff --git a/module/language/tree-il/effects.scm b/module/language/tree-il/effects.scm
index 374ab2c8c..467e4366a 100644
--- a/module/language/tree-il/effects.scm
+++ b/module/language/tree-il/effects.scm
@@ -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.
diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm
index bfd338da9..5b9852b01 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -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)
diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index cd950848b..8cb090a24 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -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