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

peval: Alpha-rename anonymous lambdas that are duplicated.

Browse source 
* module/language/tree-il/optimize.scm (alpha-rename): New procedure.
  (peval)[maybe-unlambda]: Use it.

* test-suite/tests/tree-il.test ("partial evaluation"): Add two test
  cases for <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>.
This commit is contained in:
Ludovic Courtès 2011-09-17 16:49:41 +02:00
parent 3f2d6efc7b
commit 2ae0775e40
2 changed files with 129 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -41,6 +41,70 @@
(peval (expand-primitives! (resolve-primitives! x env))
env)))))
;;;
;;; Partial evaluation.
;;;
(define (alpha-rename exp)
"Alpha-rename EXP. For any lambda in EXP, generate new symbols and
replace all lexical references to the former symbols with lexical
references to the new symbols."
;; XXX: This should be factorized somehow.
(let loop ((exp exp)
(mapping vlist-null)) ; maps old to new gensyms
(match exp
(($ <lambda-case> src req opt rest kw inits gensyms body alt)
;; Create new symbols to replace GENSYMS and propagate them down
;; in BODY and ALT.
(let* ((new (map (compose gensym symbol->string) gensyms))
(mapping (fold vhash-consq mapping gensyms new)))
(make-lambda-case src req opt rest kw inits new
(loop body mapping)
(and alt (loop alt mapping)))))
(($ <lexical-ref> src name gensym)
;; Possibly replace GENSYM by the new gensym defined in MAPPING.
(let ((val (vhash-assq gensym mapping)))
(if val
(make-lexical-ref src name (cdr val))
exp)))
(($ <lambda> src meta body)
(make-lambda src meta (loop body mapping)))
(($ <let> src names gensyms vals body)
;; As for `lambda-case' rename GENSYMS to avoid any collision.
(let* ((new (map (compose gensym symbol->string) gensyms))
(mapping (fold vhash-consq mapping gensyms new))
(vals (map (cut loop <> mapping) vals))
(body (loop body mapping)))
(make-let src names new vals body)))
(($ <letrec> src in-order? names gensyms vals body)
;; Likewise.
(let* ((new (map (compose gensym symbol->string) gensyms))
(mapping (fold vhash-consq mapping gensyms new))
(vals (map (cut loop <> mapping) vals))
(body (loop body mapping)))
(make-letrec src in-order? names new vals body)))
(($ <const>)
exp)
(($ <void>)
exp)
(($ <toplevel-ref>)
exp)
(($ <module-ref>)
exp)
(($ <primitive-ref>)
exp)
(($ <conditional> src condition subsequent alternate)
(make-conditional src
(loop condition mapping)
(loop subsequent mapping)
(loop alternate mapping)))
(($ <application> src proc args)
(make-application src (loop proc mapping)
(map (cut loop <> mapping) args)))
(($ <sequence> src exps)
(make-sequence src (map (cut loop <> mapping) exps))))))
(define* (peval exp #:optional (cenv (current-module)) (env vlist-null))
"Partially evaluate EXP in compilation environment CENV, with
top-level bindings from ENV and return the resulting expression. Since
@ -189,6 +253,13 @@ it does not handle <fix> and <let-values>, it should be called before
(make-lexical-ref src name (car x))))
(vlist-fold cons '() env)) ; todo: optimize
new))
(($ <lambda> src ()
(and lc ($ <lambda-case>)))
;; This is an anonymous lambda that we're going to inline. The
;; variable allocation process assumes globally unique gensyms to
;; alpha-rename the lambda to avoid any collision with other
;; copies of it.
(make-lambda src '() (alpha-rename lc)))
(_ new)))
(catch 'match-error

58
test-suite/tests/tree-il.test
View file

@ -828,6 +828,64 @@
(lexical x _))))
(toplevel top)))))
(pass-if-peval
;; In this example, the two anonymous lambdas are inlined more than
;; once; thus, they should use different gensyms for their
;; arguments, because the variable allocation process assumes
;; globally unique gensyms. This test in itself doesn't check that;
;; we rely on the next one to catch any error.
;;
;; Bug reported at
;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html> and
;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00029.html>.
(letrec ((fold (lambda (f x3 b null? car cdr)
(if (null? x3)
b
(f (car x3) (fold f (cdr x3) b null? car cdr))))))
(fold * x 1 zero? (lambda (x1) x1) (lambda (x2) (- x2 1))))
(letrec (fold) (_) (_)
(if (apply (primitive zero?) (toplevel x))
(const 1)
(apply (primitive *) ; f
(apply (lambda () ; car
(lambda-case
(((x1) #f #f #f () (_))
(lexical x1 _))))
(toplevel x))
(apply (lexical fold _) ; fold
(primitive *)
(apply (lambda () ; cdr
(lambda-case
(((x2) #f #f #f () (_))
(apply (primitive -)
(lexical x2 _) (const 1)))))
(toplevel x))
(const 1)
(primitive zero?)
(lambda () ; car
(lambda-case
(((x1) #f #f #f () (_))
(lexical x1 _))))
(lambda () ; cdr
(lambda-case
(((x2) #f #f #f () (_))
(apply (primitive -)
(lexical x2 _) (const 1))))))))))
(pass-if "inlined lambdas are alpha-renamed"
;; This one should compile without errors; see above for an
;; explanation.
(and (compile
'(letrec ((fold (lambda (f x3 b null? car cdr)
(if (null? x3)
b
(f (car x3)
(fold f (cdr x3) b null? car cdr))))))
(fold * x 1 zero? (lambda (x1) x1) (lambda (x2) (- x2 1))))
#:opts '(#:partial-eval? #t)
#:to 'glil)
#t))
(pass-if-peval
;; Higher order, mutually recursive procedures.
(letrec ((even? (lambda (x)