diff --git a/compiler/copyprop.lisp b/compiler/copyprop.lisp index a4d0abd7eeb0e22f12e78422abee02a2ddc9ddff..124a40604f9c8cc65941d97a1030ad56062e3cd2 100644 --- a/compiler/copyprop.lisp +++ b/compiler/copyprop.lisp @@ -61,14 +61,14 @@ ;;; A TN is also inelegible if it has interned name, policy is such that we ;;; would dump it in the debug vars, and speed is not 3. ;;; -;;; The SCs of the TNs primitive types must be the same. Moves between TNs of +;;; The SCs of the TNs primitive types intersect. Moves between TNs of ;;; different primitive type SCs may need to be changed into coercions, so we -;;; can't squeeze them out. The reason for testing for the same SCs instead of -;;; the same primitive type is that this test lets T be substituted for LIST, -;;; etc. +;;; can't squeeze them out. The reason for testing for intersection of the SCs +;;; instead of the same primitive type is that this test lets T be substituted +;;; for LIST, POSITIVE-FIXNUM for FIXNUM, etc. ;;; (defun tn-is-copy-of (tn) - (declare (type tn tn)) + (declare (type tn tn) (inline member)) (let ((writes (tn-writes tn))) (and (eq (tn-kind tn) :normal) (not (tn-sc tn)) ; Not wired or restricted. @@ -78,8 +78,14 @@ (let ((arg-tn (tn-ref-tn (vop-args vop)))) (and (or (not (tn-sc arg-tn)) (eq (tn-kind arg-tn) :constant)) - (equal (primitive-type-scs (tn-primitive-type arg-tn)) - (primitive-type-scs (tn-primitive-type tn))) + (let ((arg-scs (primitive-type-scs + (tn-primitive-type arg-tn)))) + (dolist (tn-sc (primitive-type-scs + (tn-primitive-type tn)) + nil) + (declare (type sc-number tn-sc)) + (when (member tn-sc arg-scs) + (return t)))) (let ((leaf (tn-leaf tn))) (or (not leaf) (not (symbol-package (leaf-name leaf)))