diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index 7dd572ff4..431c07e01 100644 --- a/module/language/tree-il/peval.scm +++ b/module/language/tree-il/peval.scm @@ -281,7 +281,7 @@ ;; (define-record-type (%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))) (($ _ _ 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))))))) (($ 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 (($ _ _ 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 diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test index 74213236f..c4e4a7141 100644 --- a/test-suite/tests/peval.test +++ b/test-suite/tests/peval.test @@ -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 _))))))))