Merge branch 'stable-2.0'

[bpt/guile.git] / module / language / tree-il / peval.scm

diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm
index 676ac89..8a60d7b 100644 (file)
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -731,24 +731,26 @@ top-level bindings from ENV and return the resulting expression."
         (cond
          ((lookup (lexical-ref-gensym x))
           => (lambda (op)
-               (let ((y (or (operand-residual-value op)
-                            (visit-operand op counter 'value 10 10)
-                            (operand-source op))))
-                 (cond
-                  ((and (lexical-ref? y)
-                        (= (lexical-refcount (lexical-ref-gensym x)) 1))
-                   ;; X is a simple alias for Y.  Recurse, regardless of
-                   ;; the number of aliases we were expecting.
-                   (find-definition y n-aliases))
-                  ((= (lexical-refcount (lexical-ref-gensym x)) n-aliases)
-                   ;; We found a definition that is aliased the right
-                   ;; number of times.  We still recurse in case it is a
-                   ;; lexical.
-                   (values (find-definition y 1)
-                           op))
-                  (else
-                   ;; We can't account for our aliases.
-                   (values #f #f))))))
+               (if (var-set? (operand-var op))
+                   (values #f #f)
+                   (let ((y (or (operand-residual-value op)
+                                (visit-operand op counter 'value 10 10)
+                                (operand-source op))))
+                     (cond
+                      ((and (lexical-ref? y)
+                            (= (lexical-refcount (lexical-ref-gensym x)) 1))
+                       ;; X is a simple alias for Y.  Recurse, regardless of
+                       ;; the number of aliases we were expecting.
+                       (find-definition y n-aliases))
+                      ((= (lexical-refcount (lexical-ref-gensym x)) n-aliases)
+                       ;; We found a definition that is aliased the right
+                       ;; number of times.  We still recurse in case it is a
+                       ;; lexical.
+                       (values (find-definition y 1)
+                               op))
+                      (else
+                       ;; We can't account for our aliases.
+                       (values #f #f)))))))
          (else
           ;; A formal parameter.  Can't say anything about that.
           (values #f #f))))
@@ -1265,7 +1267,7 @@ top-level bindings from ENV and return the resulting expression."
                (_
                 (make-primcall src 'thunk? (list proc)))))))))
 
-      (($ <primcall> src (? accessor-primitive? name) args)
+      (($ <primcall> src name args)
        (match (cons name (map for-value args))
          ;; FIXME: these for-tail recursions could take place outside
          ;; an effort counter.
@@ -1324,25 +1326,15 @@ top-level bindings from ENV and return the resulting expression."
                (for-tail (make-seq src k (make-const #f #f))))
               (else
                (make-primcall src name (list k (make-const #f elts))))))))
-         ((name . args)
-          (fold-constants src name args ctx))))
-
-      (($ <primcall> src (? equality-primitive? name) (a b))
-       (let ((val-a (for-value a))
-             (val-b (for-value b)))
-         (log 'equality-primitive name val-a val-b)
-         (cond ((and (lexical-ref? val-a) (lexical-ref? val-b)
-                     (eq? (lexical-ref-gensym val-a)
-                          (lexical-ref-gensym val-b)))
-                (for-tail (make-const #f #t)))
-               (else
-                (fold-constants src name (list val-a val-b) ctx)))))
-      
-      (($ <primcall> src (? effect-free-primitive? name) args)
-       (fold-constants src name (map for-value args) ctx))
+         (((? equality-primitive?)
+           ($ <lexical-ref> _ _ sym) ($ <lexical-ref> _ _ sym))
+          (for-tail (make-const #f #t)))
 
-      (($ <primcall> src name args)
-       (make-primcall src name (map for-value args)))
+         (((? effect-free-primitive?) . args)
+          (fold-constants src name args ctx))
+
+         ((name . args)
+          (make-primcall src name args))))
 
       (($ <call> src orig-proc orig-args)
        ;; todo: augment the global env with specialized functions