Skip to content
Snippets Groups Projects
Commit 4929bd41 authored by ram's avatar ram
Browse files

In TN-IS-COPY-OF, allow copy propagation whenever there is an intersection

between the TNs SCs, rather than only when the SC list are EQUAL.  This
allows POSITIVE-FIXNUM to be subsituted for FIXNUM, etc.
parent 4d1b0a90
No related branches found
No related tags found
No related merge requests found
...@@ -61,14 +61,14 @@ ...@@ -61,14 +61,14 @@
;;; A TN is also inelegible if it has interned name, policy is such that we ;;; 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. ;;; 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 ;;; 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 ;;; can't squeeze them out. The reason for testing for intersection of the SCs
;;; the same primitive type is that this test lets T be substituted for LIST, ;;; instead of the same primitive type is that this test lets T be substituted
;;; etc. ;;; for LIST, POSITIVE-FIXNUM for FIXNUM, etc.
;;; ;;;
(defun tn-is-copy-of (tn) (defun tn-is-copy-of (tn)
(declare (type tn tn)) (declare (type tn tn) (inline member))
(let ((writes (tn-writes tn))) (let ((writes (tn-writes tn)))
(and (eq (tn-kind tn) :normal) (and (eq (tn-kind tn) :normal)
(not (tn-sc tn)) ; Not wired or restricted. (not (tn-sc tn)) ; Not wired or restricted.
...@@ -78,8 +78,14 @@ ...@@ -78,8 +78,14 @@
(let ((arg-tn (tn-ref-tn (vop-args vop)))) (let ((arg-tn (tn-ref-tn (vop-args vop))))
(and (or (not (tn-sc arg-tn)) (and (or (not (tn-sc arg-tn))
(eq (tn-kind arg-tn) :constant)) (eq (tn-kind arg-tn) :constant))
(equal (primitive-type-scs (tn-primitive-type arg-tn)) (let ((arg-scs (primitive-type-scs
(primitive-type-scs (tn-primitive-type tn))) (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))) (let ((leaf (tn-leaf tn)))
(or (not leaf) (or (not leaf)
(not (symbol-package (leaf-name leaf))) (not (symbol-package (leaf-name leaf)))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment