mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 19:50:24 +02:00
Code Activity

peval works on all expressions

Browse source 
* module/language/tree-il/optimize.scm (alpha-rename, peval): Add
  <dynset> cases.  Allow any kind of <application>.  Remove the `catch'
  wrapper as now peval handles all kinds of expressions.
This commit is contained in:
Andy Wingo 2011-09-27 15:08:17 +02:00
parent 6c4ffe2b25
commit 1cc1c2d7e3
1 changed files with 458 additions and 495 deletions
Download patch file Download diff file Expand all files Collapse all files

57
module/language/tree-il/optimize.scm
View file

@ -145,6 +145,8 @@ references to the new symbols."
(loop unwinder mapping))) (loop unwinder mapping)))
(($ <dynref> src fluid) (($ <dynref> src fluid)
(make-dynref src (loop fluid mapping))) (make-dynref src (loop fluid mapping)))
(($ <dynset> src fluid exp)
(make-dynset src (loop fluid mapping) (loop exp mapping)))
(($ <conditional> src condition subsequent alternate) (($ <conditional> src condition subsequent alternate)
(make-conditional src (make-conditional src
(loop condition mapping) (loop condition mapping)
@ -385,7 +387,8 @@ it does not handle <fix> and <let-values>, it should be called before
($ <lexical-set>) ; FIXME: these set! expressions ($ <lexical-set>) ; FIXME: these set! expressions
($ <toplevel-set>) ; could return zero values in ($ <toplevel-set>) ; could return zero values in
($ <toplevel-define>) ; the future ($ <toplevel-define>) ; the future
($ <module-set>)) ; ($ <module-set>) ;
($ <dynset>)) ;
(and (= (length names) 1) (and (= (length names) 1)
(make-let src names gensyms (list exp) body))) (make-let src names gensyms (list exp) body)))
(($ <application> src (($ <application> src
@ -500,35 +503,6 @@ it does not handle <fix> and <let-values>, it should be called before
0 x) 0 x)
#t)) #t))
(define (make-value-construction src exp)
;; Return an expression that builds a fresh copy of EXP at run-time,
;; or #f.
(let loop ((exp exp))
(match exp
((_ _ ...) ; non-empty proper list
(let ((args (map loop exp)))
(and (every struct? args)
(make-application src (make-primitive-ref src 'list)
args))))
((h . (? (negate pair?) t)) ; simple pair
(let ((h (loop h))
(t (loop t)))
(and h t
(make-application src (make-primitive-ref src 'cons)
(list h t)))))
((? vector?) ; vector
(let ((args (map loop (vector->list exp))))
(and (every struct? args)
(make-application src (make-primitive-ref src 'vector)
args))))
((? number?) (make-const src exp))
((? string?) (make-const src exp))
((? symbol?) (make-const src exp))
;((? bytevector?) (make-const src exp))
(_ #f))))
(catch 'match-error
(lambda ()
(let loop ((exp exp) (let loop ((exp exp)
(env vlist-null) ; static environment (env vlist-null) ; static environment
(counter #f) ; inlined call stack (counter #f) ; inlined call stack
@ -722,6 +696,8 @@ it does not handle <fix> and <let-values>, it should be called before
(for-tail body))) (for-tail body)))
(($ <dynref> src fluid) (($ <dynref> src fluid)
(make-dynref src (for-value fluid))) (make-dynref src (for-value fluid)))
(($ <dynset> src fluid exp)
(make-dynset src (for-value fluid) (for-value exp)))
(($ <toplevel-ref> src (? effect-free-primitive? name)) (($ <toplevel-ref> src (? effect-free-primitive? name))
(if (local-toplevel? name) (if (local-toplevel? name)
exp exp
@ -807,7 +783,6 @@ it does not handle <fix> and <let-values>, it should be called before
(for-tail (make-sequence src (list tail head)))) (for-tail (make-sequence src (list tail head))))
(('cdr ($ <application> src ($ <primitive-ref> _ 'cons) (head tail))) (('cdr ($ <application> src ($ <primitive-ref> _ 'cons) (head tail)))
(for-tail (make-sequence src (list head tail)))) (for-tail (make-sequence src (list head tail))))
(('car ($ <application> src ($ <primitive-ref> _ 'list) (head . tail))) (('car ($ <application> src ($ <primitive-ref> _ 'list) (head . tail)))
(for-tail (make-sequence src (append tail (list head))))) (for-tail (make-sequence src (append tail (list head)))))
(('cdr ($ <application> src ($ <primitive-ref> _ 'list) (head . tail))) (('cdr ($ <application> src ($ <primitive-ref> _ 'list) (head . tail)))
@ -908,18 +883,9 @@ it does not handle <fix> and <let-values>, it should be called before
(transfer! new-counter counter)) (transfer! new-counter counter))
result))))) result)))))
((or ($ <primitive-ref>) (_
($ <lambda>)
($ <toplevel-ref>)
($ <lexical-ref>))
(make-application src proc (make-application src proc
(map for-value orig-args))) (map for-value orig-args))))))
;; In practice, this is the clause that stops peval:
;; module-ref applications (produced by macros,
;; typically) don't match, and so this throws,
;; aborting peval for an entire expression.
)))
(($ <lambda> src meta body) (($ <lambda> src meta body)
(case ctx (case ctx
((effect) (make-void #f)) ((effect) (make-void #f))
@ -966,7 +932,8 @@ it does not handle <fix> and <let-values>, it should be called before
(tree-il-any (lambda (x) (tree-il-any (lambda (x)
(and (lexical-ref? x) (and (lexical-ref? x)
(eq? (lexical-ref-gensym x) cont))) (eq? (lexical-ref-gensym x) cont)))
body)))) body))
(else #f)))
(define (thunk-application? x) (define (thunk-application? x)
(match x (match x
(($ <application> _ (($ <application> _
@ -1002,7 +969,3 @@ it does not handle <fix> and <let-values>, it should be called before
(($ <abort> src tag args tail) (($ <abort> src tag args tail)
(make-abort src (for-value tag) (map for-value args) (make-abort src (for-value tag) (map for-value args)
(for-value tail)))))) (for-value tail))))))
(lambda _
;; We encountered something we don't handle, like <abort> or
;; <prompt>, so bail out.
exp)))