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

Fix bug compiling fixpoint combinator

Browse source 
* module/language/tree-il/peval.scm (<operand>): Rename "alias-value"
  field to "alias", which is now an operand and not an expression.
  This allows the operand to capture its environment; before, the
  alias was being visited in its use environment instead of its
  definition environment.
  (peval): Adapt to operand change.
* test-suite/tests/peval.test ("partial evaluation"): New test.
This commit is contained in:
Andy Wingo 2015-05-20 17:20:25 +02:00
parent 2d6e224003
commit c691c0e15a
2 changed files with 31 additions and 11 deletions
Download patch file Download diff file Expand all files Collapse all files

18
module/language/tree-il/peval.scm
View file

@ -281,7 +281,7 @@
;;
(define-record-type <operand>
(%make-operand var sym visit source visit-count use-count
copyable? residual-value constant-value alias-value)
copyable? residual-value constant-value alias)
operand?
(var operand-var)
(sym operand-sym)
@ -292,7 +292,7 @@
(copyable? operand-copyable? set-operand-copyable?!)
(residual-value operand-residual-value %set-operand-residual-value!)
(constant-value operand-constant-value set-operand-constant-value!)
(alias-value operand-alias-value set-operand-alias-value!))
(alias operand-alias set-operand-alias!))
(define* (make-operand var sym #:optional source visit alias)
;; Bind SYM to VAR, with value SOURCE. Unassigned bound operands are
@ -780,16 +780,16 @@ top-level bindings from ENV and return the resulting expression."
(else exp)))
(($ <lexical-ref> _ _ gensym)
(log 'begin-copy gensym)
(let ((op (lookup gensym)))
(let lp ((op (lookup gensym)))
(cond
((eq? ctx 'effect)
(log 'lexical-for-effect gensym)
(make-void #f))
((operand-alias-value op)
((operand-alias op)
;; This is an unassigned operand that simply aliases some
;; other operand. Recurse to avoid residualizing the leaf
;; binding.
=> for-tail)
=> lp)
((eq? ctx 'call)
;; Don't propagate copies if we are residualizing a call.
(log 'residualize-lexical-call gensym op)
@ -907,7 +907,7 @@ top-level bindings from ENV and return the resulting expression."
(map (cut make-lexical-ref #f <> <>)
tmps tmp-syms)))))))
(($ <let> src names gensyms vals body)
(define (compute-alias exp)
(define (lookup-alias exp)
;; It's very common for macros to introduce something like:
;;
;; ((lambda (x y) ...) x-exp y-exp)
@ -927,9 +927,7 @@ top-level bindings from ENV and return the resulting expression."
(match exp
(($ <lexical-ref> _ _ sym)
(let ((op (lookup sym)))
(and (not (var-set? (operand-var op)))
(or (operand-alias-value op)
exp))))
(and (not (var-set? (operand-var op))) op)))
(_ #f)))
(let* ((vars (map lookup-var gensyms))
@ -937,7 +935,7 @@ top-level bindings from ENV and return the resulting expression."
(ops (make-bound-operands vars new vals
(lambda (exp counter ctx)
(loop exp env counter ctx))
(map compute-alias vals)))
(map lookup-alias vals)))
(env (fold extend-env env gensyms ops))
(body (loop body env counter ctx)))
(cond

24
test-suite/tests/peval.test
View file

@ -1329,4 +1329,26 @@
(pass-if-peval
(eqv? '(a b) '(a b))
(const #t)))
(const #t))
(pass-if-peval
(lambda (f x)
(let lp ((x x))
(let ((x* (f x)))
(if (eq? x x*) x* (lp x*)))))
(lambda ()
(lambda-case
(((f x) #f #f #f () (_ _))
(letrec (lp)
(_)
((lambda ((name . lp))
(lambda-case
(((x) #f #f #f () (_))
(let (x*)
(_)
((apply (lexical f _) (lexical x _)))
(if (apply (primitive eq?) (lexical x _) (lexical x* _))
(lexical x* _)
(apply (lexical lp _) (lexical x* _))))))))
(apply (lexical lp _)
(lexical x _))))))))