mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-11 06: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.  Fix construction of rest bindings
  as well.
* 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 e0e47cb527
commit 4632f3d998
2 changed files with 38 additions and 14 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -275,7 +275,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)
@ -286,7 +286,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
@ -787,16 +787,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)
@ -913,7 +913,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)
@ -933,9 +933,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))
@ -943,7 +941,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
@ -1397,8 +1395,8 @@ top-level bindings from ENV and return the resulting expression."
(list (make-primcall
#f 'list
(drop orig-args (+ nreq nopt)))))
(rest (list (make-const #f '())))
(else '()))))
((null? rest) '())
(else (list (make-const #f '()))))))
(if (>= nargs (+ nreq nopt))
(make-let src
(append req opt rest)

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

@ -1372,9 +1372,35 @@
(if (pair? arg)
(set! l arg))
(apply f l))
(let (l) (_) ((const ()))
(let (l) (_) ((const ()))
(seq
(if (primcall pair? (toplevel arg))
(set! (lexical l _) (toplevel arg))
(void))
(primcall apply (toplevel f) (lexical l _))))))
(primcall apply (toplevel f) (lexical l _)))))
(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*)
(_)
((call (lexical f _) (lexical x _)))
(if (primcall
eq?
(lexical x _)
(lexical x* _))
(lexical x* _)
(call (lexical lp _)
(lexical x* _))))))))
(call (lexical lp _)
(lexical x _))))))))