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

peval: Use the right scope when replacing a lambda by a lexical-ref.

Browse source 
* module/language/tree-il/optimize.scm (peval)[maybe-unlambda]: New
  procedures.
  Use it to de-duplicate named lambdas.  This fixes the scoping bug
  described at <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>.

* test-suite/tests/tree-il.test ("partial evaluation"): Add tests to
  reproduce the bug.
This commit is contained in:
Ludovic Courtès 2011-09-13 18:25:09 +02:00
parent 1e8ace33d1
commit 61237fa4b9
2 changed files with 47 additions and 16 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -174,6 +174,22 @@ it should be called before `fix-letrec'."
(or (make-value-construction src value) orig)))
(_ new)))
(define (maybe-unlambda orig new env)
;; If NEW is a named lambda and ORIG is what it looked like before
;; partial evaluation, then attempt to replace NEW with a lexical
;; ref, to avoid code duplication.
(match new
(($ <lambda> src (= (cut assq-ref <> 'name) (? symbol? name))
($ <lambda-case> _ req opt rest kw inits gensyms body))
;; Look for NEW in the current environment, starting from the
;; outermost frame.
(or (any (lambda (x)
(and (equal? (cdr x) new)
(make-lexical-ref src name (car x))))
(vlist-fold cons '() env)) ; todo: optimize
new))
(_ new)))
(catch 'match-error
(lambda ()
(let loop ((exp exp)
@ -245,12 +261,15 @@ it should be called before `fix-letrec'."
(make-conditional src condition
(loop subsequent env calls)
(loop alternate env calls)))))
(($ <application> src proc* orig-args)
(($ <application> src orig-proc orig-args)
;; todo: augment the global env with specialized functions
(let* ((proc (loop proc* env calls))
(let* ((proc (loop orig-proc env calls))
(proc* (maybe-unlambda orig-proc proc env))
(args (map (cut loop <> env calls) orig-args))
(args* (map maybe-unconst orig-args args))
(app (make-application src proc args*)))
(args* (map (cut maybe-unlambda <> <> env)
orig-args
(map maybe-unconst orig-args args)))
(app (make-application src proc* args*)))
;; If at least one of ARGS is static (to avoid infinite
;; inlining) and this call hasn't already been expanded
;; before (to avoid infinite recursion), then expand it
@ -294,17 +313,7 @@ it should be called before `fix-letrec'."
(($ <toplevel-ref>)
app))
;; There are no constant arguments, so don't substitute
;; lambdas---i.e., prefer (lexical f) over an inline
;; copy of `f'.
(let ((proc (if (lambda? proc) proc* proc))
(args (map (lambda (raw evaled)
(if (lambda? evaled)
raw
evaled))
orig-args
args)))
(make-application src proc args)))))
app)))
(($ <lambda> src meta body)
(make-lambda src meta (loop body env calls)))
(($ <lambda-case> src req opt rest kw inits gensyms body alt)

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

@ -799,6 +799,28 @@
35)
(const 42))
(pass-if-peval
;; Higher order.
((lambda (f) (f x)) (lambda (x) x))
(apply (lambda ()
(lambda-case
(((x) #f #f #f () (_))
(lexical x _))))
(toplevel x)))
(pass-if-peval
;; Bug reported at
;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>.
(let ((fold (lambda (f g) (f (g top)))))
(fold 1+ (lambda (x) x)))
(let (fold) (_) (_)
(apply (primitive 1+)
(apply (lambda ()
(lambda-case
(((x) #f #f #f () (_))
(lexical x _))))
(toplevel top)))))
(pass-if-peval
;; Higher order, mutually recursive procedures.
(letrec ((even? (lambda (x)
@ -874,7 +896,7 @@
(apply (primitive list) (const 1) (const 2) (const 3))))
(pass-if-peval
;; Procedure only called with non-constant args is not inlined.
;; Procedure only called with dynamic args is not inlined.
(let* ((g (lambda (x y) (+ x y)))
(f (lambda (g x) (g x x))))
(+ (f g foo) (f g bar)))