X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fcopyprop.lisp;h=10a17684bbbcaed898fb8cc8009a2c7ebf94e532;hb=9304704f68a18894fa8eb985b387465e5d25e1d5;hp=f7062cadf4d39fd22ecba8bf96844b929914e90a;hpb=416152f084604094445a758ff399871132dff2bd;p=sbcl.git diff --git a/src/compiler/copyprop.lisp b/src/compiler/copyprop.lisp index f7062ca..10a1768 100644 --- a/src/compiler/copyprop.lisp +++ b/src/compiler/copyprop.lisp @@ -55,8 +55,8 @@ ;;; 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 @@ -71,23 +71,31 @@ (declare (inline subsetp)) (let ((writes (tn-writes tn))) (and (eq (tn-kind tn) :normal) - (not (tn-sc tn)) ; Not wired or restricted. - (and writes (null (tn-ref-next writes))) - (let ((vop (tn-ref-vop writes))) - (and (eq (vop-info-name (vop-info vop)) 'move) - (let ((arg-tn (tn-ref-tn (vop-args vop)))) - (and (or (not (tn-sc arg-tn)) - (eq (tn-kind arg-tn) :constant)) - (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))) - (policy (vop-node vop) - (or (= speed 3) (< debug 2))))) - arg-tn))))))) + (not (tn-sc tn)) ; Not wired or restricted. + (and writes (null (tn-ref-next writes))) + (let ((vop (tn-ref-vop writes))) + (and (eq (vop-info-name (vop-info vop)) 'move) + (let ((arg-tn (tn-ref-tn (vop-args vop)))) + (and (or (not (tn-sc arg-tn)) + (eq (tn-kind arg-tn) :constant)) + (subsetp (primitive-type-scs + (tn-primitive-type tn)) + (primitive-type-scs + (tn-primitive-type arg-tn))) + (let ((leaf (tn-leaf tn))) + (or (not leaf) + (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 ;;; look for MOVE vops, and then see whether the result is a eligible @@ -97,28 +105,28 @@ (defun init-copy-sets (block) (declare (type cblock block)) (let ((kill (make-sset)) - (gen (make-sset))) + (gen (make-sset))) (do ((vop (ir2-block-start-vop (block-info block)) (vop-next vop))) - ((null vop)) + ((null vop)) (unless (and (eq (vop-info-name (vop-info vop)) 'move) - (let ((y (tn-ref-tn (vop-results vop)))) - (when (tn-is-copy-of y) - (sset-adjoin y gen) - t))) - (do ((res (vop-results vop) (tn-ref-across res))) - ((null res)) - (let ((res-tn (tn-ref-tn res))) - (do ((read (tn-reads res-tn) (tn-ref-next read))) - ((null read)) - (let ((read-vop (tn-ref-vop read))) - (when (eq (vop-info-name (vop-info read-vop)) 'move) - (let ((y (tn-ref-tn (vop-results read-vop)))) - (when (tn-is-copy-of y) - (sset-delete y gen) - (sset-adjoin y kill)))))))))) - + (let ((y (tn-ref-tn (vop-results vop)))) + (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))) + ((not res)) + (let ((res-tn (tn-ref-tn res))) + (do ((read (tn-reads res-tn) (tn-ref-next read))) + ((null read)) + (let ((read-vop (tn-ref-vop read))) + (when (eq (vop-info-name (vop-info read-vop)) 'move) + (let ((y (tn-ref-tn (vop-results read-vop)))) + (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)) @@ -129,13 +137,13 @@ (defun copy-flow-analysis (block) (declare (type cblock block)) (let* ((pred (block-pred block)) - (in (copy-sset (block-out (first pred))))) + (in (copy-sset (block-out (first pred))))) (dolist (pred-block (rest pred)) (sset-intersection in (block-out pred-block))) (setf (block-in block) in) (sset-union-of-difference (block-out block) - in - (block-kill-sset block)))) + in + (block-kill block)))) (defevent copy-deleted-move "Copy propagation deleted a move.") @@ -146,19 +154,19 @@ ;;; to preserve parallel assignment semantics. (defun ok-copy-ref (vop arg in original-copy-of) (declare (type vop vop) (type tn arg) (type sset in) - (type hash-table original-copy-of)) + (type hash-table original-copy-of)) (and (sset-member arg in) (do ((original (gethash arg original-copy-of) - (gethash original original-copy-of))) - ((not original) t) - (unless (sset-member original in) - (return nil))) + (gethash original original-copy-of))) + ((not original) t) + (unless (sset-member original in) + (return nil))) (let ((info (vop-info vop))) - (not (and (eq (vop-info-move-args info) :local-call) - (>= (or (position-in #'tn-ref-across arg (vop-args vop) - :key #'tn-ref-tn) - (error "Couldn't find REF?")) - (length (template-arg-types info)))))))) + (not (or (eq (vop-info-move-args info) :local-call) + (>= (or (position-in #'tn-ref-across arg (vop-args vop) + :key #'tn-ref-tn) + (error "Couldn't find REF?")) + (length (template-arg-types info)))))))) ;;; Make use of the result of flow analysis to eliminate copies. We ;;; scan the VOPs in block, propagating copies and keeping our IN set @@ -199,31 +207,31 @@ (declare (type cblock block) (type hash-table original-copy-of)) (let ((in (block-in block))) (do ((vop (ir2-block-start-vop (block-info block)) (vop-next vop))) - ((null vop)) + ((null vop)) (let ((this-copy (and (eq (vop-info-name (vop-info vop)) 'move) - (let ((y (tn-ref-tn (vop-results vop)))) - (when (tn-is-copy-of y) y))))) - ;; Substitute copied TN for copy when we find a reference to a copy. - ;; If the copy is left with no reads, delete the move to the copy. - (do ((arg-ref (vop-args vop) (tn-ref-across arg-ref))) - ((null arg-ref)) - (let* ((arg (tn-ref-tn arg-ref)) - (copy-of (tn-is-copy-of arg))) - (when (and copy-of (ok-copy-ref vop arg in original-copy-of)) - (when this-copy - (setf (gethash this-copy original-copy-of) arg)) - (change-tn-ref-tn arg-ref copy-of) - (when (null (tn-reads arg)) - (event copy-deleted-move) - (delete-vop (tn-ref-vop (tn-writes arg))))))) - ;; Kill any elements in IN that are copies of a TN we are clobbering. - (do ((res-ref (vop-results vop) (tn-ref-across res-ref))) - ((null res-ref)) - (do-sset-elements (tn in) - (when (eq (tn-is-copy-of tn) (tn-ref-tn res-ref)) - (sset-delete tn in)))) - ;; If this VOP is a copy, add the copy TN to IN. - (when this-copy (sset-adjoin this-copy in))))) + (let ((y (tn-ref-tn (vop-results vop)))) + (when (tn-is-copy-of y) y))))) + ;; Substitute copied TN for copy when we find a reference to a copy. + ;; If the copy is left with no reads, delete the move to the copy. + (do ((arg-ref (vop-args vop) (tn-ref-across arg-ref))) + ((null arg-ref)) + (let* ((arg (tn-ref-tn arg-ref)) + (copy-of (tn-is-copy-of arg))) + (when (and copy-of (ok-copy-ref vop arg in original-copy-of)) + (when this-copy + (setf (gethash this-copy original-copy-of) arg)) + (change-tn-ref-tn arg-ref copy-of) + (when (null (tn-reads arg)) + (event copy-deleted-move) + (delete-vop (tn-ref-vop (tn-writes arg))))))) + ;; Kill any elements in IN that are copies of a TN we are clobbering. + (do ((res-ref (vop-results vop) (tn-ref-across res-ref))) + ((null res-ref)) + (do-sset-elements (tn in) + (when (eq (tn-is-copy-of tn) (tn-ref-tn res-ref)) + (sset-delete tn in)))) + ;; If this VOP is a copy, add the copy TN to IN. + (when this-copy (sset-adjoin this-copy in))))) (values)) @@ -238,8 +246,8 @@ (loop (let ((did-something nil)) (do-blocks (block component) - (when (copy-flow-analysis block) - (setq did-something t))) + (when (copy-flow-analysis block) + (setq did-something t))) (unless did-something (return)))) (let ((original-copies (make-hash-table :test 'eq)))