mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 14:50:19 +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> (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)
@ -286,7 +286,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
@ -787,16 +787,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)
@ -913,7 +913,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)
@ -933,9 +933,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))
@ -943,7 +941,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
@ -1397,8 +1395,8 @@ top-level bindings from ENV and return the resulting expression."
(list (make-primcall (list (make-primcall
#f 'list #f 'list
(drop orig-args (+ nreq nopt))))) (drop orig-args (+ nreq nopt)))))
(rest (list (make-const #f '()))) ((null? rest) '())
(else '())))) (else (list (make-const #f '()))))))
(if (>= nargs (+ nreq nopt)) (if (>= nargs (+ nreq nopt))
(make-let src (make-let src
(append req opt rest) (append req opt rest)

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

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