diff options
Diffstat (limited to 'module/language')
-rw-r--r-- | module/language/elisp/compile-tree-il.scm | 21 | ||||
-rw-r--r-- | module/language/scheme/decompile-tree-il.scm | 12 | ||||
-rw-r--r-- | module/language/tree-il.scm | 16 | ||||
-rw-r--r-- | module/language/tree-il/analyze.scm | 6 | ||||
-rw-r--r-- | module/language/tree-il/canonicalize.scm | 2 | ||||
-rw-r--r-- | module/language/tree-il/compile-glil.scm | 48 | ||||
-rw-r--r-- | module/language/tree-il/cse.scm | 7 | ||||
-rw-r--r-- | module/language/tree-il/debug.scm | 12 | ||||
-rw-r--r-- | module/language/tree-il/effects.scm | 15 | ||||
-rw-r--r-- | module/language/tree-il/peval.scm | 101 | ||||
-rw-r--r-- | module/language/tree-il/primitives.scm | 2 |
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 |