diff --git a/compiler/copyprop.lisp b/compiler/copyprop.lisp
index cc75699e9599aa8d4029db4ed3166df725202ffc..19d9b2ca6f1acdef6530e74e8ad6e819ca75cb25 100644
--- a/compiler/copyprop.lisp
+++ b/compiler/copyprop.lisp
@@ -61,14 +61,16 @@
 ;;; 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 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 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.
+;;; The SCs of the TN's primitive types is a subset of the SCs of the copied
+;;; TN.  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 subset of the SCs instead of the same primitive type is
+;;; that this test lets T be substituted for LIST, POSITIVE-FIXNUM for FIXNUM,
+;;; etc.  Note that more SCs implies fewer possible values, or a subtype
+;;; relationship, since more SCs implies more possible representations.
 ;;;
 (defun tn-is-copy-of (tn)
-  (declare (type tn tn) (inline member))
+  (declare (type tn tn) (inline subsetp))
   (let ((writes (tn-writes tn)))
     (and (eq (tn-kind tn) :normal)
 	 (not (tn-sc tn))		; Not wired or restricted. 
@@ -78,14 +80,10 @@
 		(let ((arg-tn (tn-ref-tn (vop-args vop))))
 		  (and (or (not (tn-sc arg-tn))
 			   (eq (tn-kind arg-tn) :constant))
-		       (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))))
+		       (subsetp (primitive-type-scs
+				 (tn-primitive-type tn))
+				(primitive-type-scs
+				 (tn-primitive-type arg-tn)))
 		       (let ((leaf (tn-leaf tn)))
 			 (or (not leaf)
 			     (not (symbol-package (leaf-name leaf)))