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

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

@ -1329,4 +1329,26 @@
(pass-if-peval (pass-if-peval
(eqv? '(a b) '(a b)) (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 _))))))))