;;; The TN must be a :NORMAL TN. Other TNs might have hidden
;;; references or be otherwise bizarre.
;;;
-;;; 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.
+;;; A TN is also inelegible if we want to preserve it to facilitate
+;;; debugging.
;;;
;;; 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
(tn-primitive-type arg-tn)))
(let ((leaf (tn-leaf tn)))
(or (not leaf)
- (not (symbol-package (leaf-name leaf)))
- (policy (vop-node vop)
- (or (= speed 3) (< debug 2)))))
+ (and
+ ;; Do we not care about preserving this this
+ ;; TN for debugging?
+ (or
+ (not (symbol-package (leaf-debug-name leaf)))
+ (policy (vop-node vop)
+ (or (= speed 3) (< debug 2))))
+ ;; arguments of local functions have hidden write
+ (not (and (lambda-var-p leaf)
+ (memq (functional-kind (lambda-var-home leaf))
+ '(nil :optional)))))))
arg-tn)))))))
;;; Init the sets in BLOCK for copy propagation. To find GEN, we just
(when (tn-is-copy-of y)
(sset-adjoin y gen)
t)))
+ ;; WANTED: explanation of UNLESS above.
(do ((res (vop-results vop) (tn-ref-across res)))
- ((null res))
+ ((not res))
(let ((res-tn (tn-ref-tn res)))
(do ((read (tn-reads res-tn) (tn-ref-next read)))
((null read))
(when (tn-is-copy-of y)
(sset-delete y gen)
(sset-adjoin y kill))))))))))
-
(setf (block-out block) (copy-sset gen))
- (setf (block-kill-sset block) kill)
+ (setf (block-kill block) kill)
(setf (block-gen block) gen))
(values))
(setf (block-in block) in)
(sset-union-of-difference (block-out block)
in
- (block-kill-sset block))))
+ (block-kill block))))
(defevent copy-deleted-move "Copy propagation deleted a move.")