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

Initial revision

parent 0e88e42e
No related branches found
No related tags found
No related merge requests found
;;; -*- Package: C; Log: C.Log -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; This file implements the copy propagation phase of the compiler,
;;; which uses global flow analysis to eliminate unnecessary copying of
;;; variables.
;;;
;;; Written by Rob MacLachlan
;;;
(in-package 'c)
;;; In copy propagation, we manipulate sets of TNs. We only consider TNs whose
;;; sole write is by a MOVE VOP. This allows us to use a degenerate version of
;;; reaching definitions: since each such TN has only one definition, the TN
;;; can stand for the definition. We can get away with this simplification,
;;; since the TNs that would be subject to copy propagation are nearly always
;;; single-writer (mostly temps allocated to ensure evaluation order is
;;; perserved). Only TNs written by MOVEs are interesting, since all we do
;;; with this information is delete spurious MOVEs.
;;;
;;; There are additional semantic constraints on whether a TN can be considered
;;; to be a copy. See TN-IS-A-COPY-OF.
;;;
;;; If a TN is in the IN set for a block, that TN is a copy of a TN which still
;;; has the same value it had at the time the move was done. Any reference
;;; to a TN in the IN set can be replaced with a reference to the TN moved
;;; from. When we delete all reads of such a TN, we can delete the MOVE VOP.
;;; IN is computed as the intersection of OUT for all the predecessor blocks.
;;;
;;; In this flow analysis scheme, the KILL set is the set of all interesting
;;; TNs where the copied TN is modified by the block (in any way.)
;;;
;;; GEN is the set of all interesting TNs that are copied in the block (whose
;;; write appears in the block.)
;;;
;;; OUT is (union (difference IN KILL) GEN)
;;;
;;; TN-IS-COPY-OF -- Internal
;;;
;;; If TN is subject to copy propagation, then return the TN it is a copy
;;; of, otherwise NIL.
;;;
;;; We also only consider TNs where neither the TN nor the copied TN are wired
;;; or restricted. If we extended the life of a wired or restricted TN,
;;; register allocation might fail, and we can't substitute arbitrary things
;;; for references to wired or restricted TNs, since the reader may be
;;; expencting the argument to be in a particular place (as in a passing
;;; location.)
;;;
;;; The TN must be a :NORMAL TN. Other TNs might have hidden references or be
;;; otherwise bizzare.
;;;
;;; 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
;;; 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.
;;;
(defun tn-is-copy-of (tn)
(declare (type tn tn))
(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))
(equal (primitive-type-scs (tn-primitive-type arg-tn))
(primitive-type-scs (tn-primitive-type 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)))))))
;;; INIT-COPY-SETS -- Internal
;;;
;;; Init the sets in Block for copy propagation. To find Gen, we just look
;;; for MOVE vops, and then see if the result is a eligible copy TN. To find
;;; Kill, we must look at all VOP results, seeing if any of the reads of the
;;; written TN are copies for eligible TNs.
;;;
(defun init-copy-sets (block)
(declare (type cblock block))
(let ((kill (make-sset))
(gen (make-sset)))
(do ((vop (ir2-block-start-vop (block-info block)) (vop-next 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))))))))))
(setf (block-out block) (copy-sset gen))
(setf (block-kill block) kill)
(setf (block-gen block) gen))
(undefined-value))
;;; COPY-FLOW-ANALYSIS -- Internal
;;;
;;; Do the flow analysis step for copy propagation on Block. We rely on OUT
;;; being initilized to GEN, and use SSET-UNION-OF-DIFFERENCE to incrementally
;;; build the union in OUT, rather than replacing OUT each time.
;;;
(defun copy-flow-analysis (block)
(declare (type cblock block))
(let* ((pred (block-pred block))
(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 block))))
(defevent copy-deleted-move "Copy propagation deleted a move.")
;;; PROPAGATE-COPIES -- Internal
;;;
;;; Make use of the result of flow analysis to eliminate copies. We scan
;;; the VOPs in block, propagating copies and keeping our IN set in sync.
;;;
;;; Original-Copy-Of is an EQ hash table that we use to keep track of
;;; renamings when there are copy chains, i.e. copies of copies. When we see
;;; copy of a copy, we enter the first copy in the table with the second copy
;;; as a key. When we see a reference to a TN in a copy chain, we can only
;;; substitute the first copied TN for the reference when all intervening
;;; copies in the copy chain are also avaliable. Otherwise, we just leave the
;;; reference alone. It is possible that we might have been able to reference
;;; one of the intermediate copies instead, but that copy might have already
;;; been deleted, since we delete the move immediately when the references go
;;; to zero.
;;;
;;; To understand why we always can to the substitution when the copy chain
;;; recorded in the Original-Copy-Of table hits NIL, note that we make an entry
;;; in the table iff we change the arg of a copy. If an entry is not in the
;;; table, it must be that we hit a move which *originally* referenced our
;;; Copy-Of TN. If all the intervening copies reach our reference, then
;;; Copy-Of must reach the reference.
;;;
;;; Note that due to our restricting copies to single-writer TNs, it will
;;; always be the case that when the first copy in a chain reaches the
;;; reference, all intervening copies reach also reach the reference. We
;;; don't exploit this, since we have to work backward from the last copy.
;;;
;;; In this discussion, we are really only playing with the tail of the true
;;; copy chain for which all of the copies have already had PROPAGATE-COPIES
;;; done on them. But, because we do this pass in DFO, it is virtually always
;;; the case that we will process earlier copies before later ones. In
;;; perverse cases (non-reducible flow graphs), we just miss some optimization
;;; opportinities.
;;;
(defun propagate-copies (block original-copy-of)
(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))
(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 (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))))
(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-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)))))
(undefined-value))
;;; COPY-PROPAGATE -- Interface
;;;
;;; Do copy propgation on Component by initilizing the flow analysis sets,
;;; doing flow analysis, and then propagating copies using the results.
;;;
(defun copy-propagate (component)
(setf (block-out (component-head component)) (make-sset))
(do-blocks (block component)
(init-copy-sets block))
(loop
(let ((did-something nil))
(do-blocks (block component)
(when (copy-flow-analysis block)
(setq did-something t)))
(unless did-something (return))))
(let ((original-copies (make-hash-table :test #'eq)))
(do-blocks (block component)
(propagate-copies block original-copies)))
(undefined-value))
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