mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-11 14:21:10 +02:00
Code Activity

peval: various bugfixes

Browse source 
* module/language/tree-il/optimize.scm (alpha-rename): Rename the
  init
  expressions of a <lambda-case>.
  (peval): Coalesce the <let-values> clauses.
  Fix pure-expression? matching of <lambda> clauses.
  Loop over and maybe-unconst the inits of a <lambda-case>.
This commit is contained in:
Andy Wingo 2011-09-24 17:15:32 +02:00
parent 9e8a5b6637
commit 250991010f
1 changed files with 21 additions and 18 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -77,7 +77,8 @@ references to the new symbols."
name name
(take-right new (length old))))) (take-right new (length old)))))
(_ #f)) (_ #f))
inits new (map (cut loop <> mapping) inits)
new
(loop body mapping) (loop body mapping)
(and alt (loop alt mapping))))) (and alt (loop alt mapping)))))
(($ <lexical-ref> src name gensym) (($ <lexical-ref> src name gensym)
@ -339,7 +340,7 @@ it does not handle <fix> and <let-values>, it should be called before
(and (effect-free-primitive? name) (and (effect-free-primitive? name)
(not (constructor-primitive? name)) (not (constructor-primitive? name))
(every loop args))) (every loop args)))
(($ <application> _ ($ <lambda> _ body) args) (($ <application> _ ($ <lambda> _ _ body) args)
(and (loop body) (every loop args))) (and (loop body) (every loop args)))
(($ <sequence> _ exps) (($ <sequence> _ exps)
(every loop exps)) (every loop exps))
@ -477,21 +478,20 @@ it does not handle <fix> and <let-values>, it should be called before
(if (const? body*) (if (const? body*)
body body
(make-fix src names gensyms vals body)))) (make-fix src names gensyms vals body))))
(($ <let-values> lv-src producer (($ <let-values> lv-src producer consumer)
($ <lambda-case> src req #f #f #f () gensyms body #f)) ;; Peval the producer, then try to inline the consumer into
;; Peval both producer and consumer, then try to inline. If ;; the producer. If that succeeds, peval again. Otherwise
;; that succeeds, peval again. ;; reconstruct the let-values, pevaling the consumer.
(let* ((producer (maybe-unconst producer (loop producer env calls))) (let ((producer (maybe-unconst producer (loop producer env calls))))
(body (maybe-unconst body (loop body env calls)))) (or (match consumer
(cond (($ <lambda-case> src req #f #f #f () gensyms body #f)
((inline-values producer src req gensyms body) (cond
=> (lambda (exp) (loop exp env calls))) ((inline-values producer src req gensyms body)
(else => (cut loop <> env calls))
(make-let-values lv-src producer (else #f)))
(make-lambda-case src req #f #f #f '() (_ #f))
gensyms body #f)))))) (make-let-values lv-src producer
(($ <let-values>) (loop consumer env calls)))))
exp)
(($ <dynwind> src winder body unwinder) (($ <dynwind> src winder body unwinder)
(make-dynwind src (loop winder env calls) (make-dynwind src (loop winder env calls)
(loop body env calls) (loop body env calls)
@ -616,7 +616,10 @@ it does not handle <fix> and <let-values>, it should be called before
(($ <lambda> src meta body) (($ <lambda> src meta body)
(make-lambda src meta (loop body env calls))) (make-lambda src meta (loop body env calls)))
(($ <lambda-case> src req opt rest kw inits gensyms body alt) (($ <lambda-case> src req opt rest kw inits gensyms body alt)
(make-lambda-case src req opt rest kw inits gensyms (make-lambda-case src req opt rest kw
(map maybe-unconst inits
(map (cut loop <> env calls) inits))
gensyms
(maybe-unconst body (loop body env calls)) (maybe-unconst body (loop body env calls))
alt)) alt))
(($ <sequence> src exps) (($ <sequence> src exps)