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

In the lifetime post-pass, added stuff to ensure that all results are

marked as live before we start the ref-scan for the VOP.  This is necessary
to ensure the correct conflicts with dead results, especially in the
presence of results with :FROM specs.
parent 90bdefd5
No related branches found
No related tags found
No related merge requests found
...@@ -650,6 +650,41 @@ ...@@ -650,6 +650,41 @@
(when (find-in #'tn-ref-across tn (vop-args vop) :key #'tn-ref-tn) (when (find-in #'tn-ref-across tn (vop-args vop) :key #'tn-ref-tn)
(return nil)))) (return nil))))
;;; MAKE-DEBUG-ENVIRONMENT-TNS-LIVE -- Internal
;;;
;;; If the block has no successors, or its successor is the component tail,
;;; then all :DEBUG-ENVIRONMENT TNs are always added, regardless of whether
;;; they appeared to be live. This ensures that these TNs are considered to be
;;; live throughout blocks that read them, but don't have any interesting
;;; successors (such as a return or tail call.) In this case, we set the
;;; corresponding bit in LIVE-IN as well.
;;;
(defun make-debug-environment-tns-live (block live-bits live-list)
(let* ((1block (ir2-block-block block))
(live-in (ir2-block-live-in block))
(succ (block-succ 1block))
(next (ir2-block-next block)))
(when (and next
(not (eq (ir2-block-block next) 1block))
(or (null succ)
(eq (first succ)
(component-tail (block-component 1block)))))
(do ((conf (ir2-block-global-tns block)
(global-conflicts-next conf)))
((null conf))
(let* ((tn (global-conflicts-tn conf))
(num (global-conflicts-number conf)))
(when (and num (zerop (sbit live-bits num))
(eq (tn-kind tn) :debug-environment)
(eq (tn-environment tn) (block-environment 1block))
(saved-after-read tn block))
(note-conflicts live-bits live-list tn num)
(setf (sbit live-bits num) 1)
(push-in tn-next* tn live-list)
(setf (sbit live-in num) 1))))))
(values live-bits live-list))
;;; Compute-Initial-Conflicts -- Internal ;;; Compute-Initial-Conflicts -- Internal
;;; ;;;
...@@ -660,12 +695,11 @@ ...@@ -660,12 +695,11 @@
;;; end, setting up the TN-Local-Conflicts and TN-Local-Number, and adding the ;;; end, setting up the TN-Local-Conflicts and TN-Local-Number, and adding the
;;; TN to the live list. ;;; TN to the live list.
;;; ;;;
;;; If the block has no successors, or its successor is the component tail, ;;; If a :MORE result is not live, we effectively fake a read to it. This is
;;; then all :DEBUG-ENVIRONMENT TNs are always added, regardless of whether ;;; part of the action described in ENSURE-RESULTS-LIVE.
;;; they appeared to be live. This ensures that these TNs are considered to be ;;;
;;; live throughout blocks that read them, but don't have any interesting ;;; At the end, we call MAKE-DEBUG-ENVIRONEMNT-TNS-LIVE to make debug
;;; successors (such as a return or tail call.) In this case, we set the ;;; environment TNs appear live when appropriate, even when they aren't.
;;; corresponding bit in LIVE-IN as well.
;;; ;;;
;;; ### Note: we alias the global-conflicts-conflicts here as the ;;; ### Note: we alias the global-conflicts-conflicts here as the
;;; tn-local-conflicts. ;;; tn-local-conflicts.
...@@ -673,6 +707,7 @@ ...@@ -673,6 +707,7 @@
(defun compute-initial-conflicts (block) (defun compute-initial-conflicts (block)
(declare (type ir2-block block)) (declare (type ir2-block block))
(let* ((live-in (ir2-block-live-in block)) (let* ((live-in (ir2-block-live-in block))
(ltns (ir2-block-local-tns block))
(live-bits (bit-vector-copy live-in)) (live-bits (bit-vector-copy live-in))
(live-list nil)) (live-list nil))
...@@ -681,50 +716,58 @@ ...@@ -681,50 +716,58 @@
((null conf)) ((null conf))
(let ((bits (global-conflicts-conflicts conf)) (let ((bits (global-conflicts-conflicts conf))
(tn (global-conflicts-tn conf)) (tn (global-conflicts-tn conf))
(num (global-conflicts-number conf))) (num (global-conflicts-number conf))
(kind (global-conflicts-kind conf)))
(setf (tn-local-number tn) num) (setf (tn-local-number tn) num)
(unless (eq (global-conflicts-kind conf) :live) (unless (eq kind :live)
(unless (zerop (sbit live-bits num)) (cond ((not (zerop (sbit live-bits num)))
(bit-vector-replace bits live-bits) (bit-vector-replace bits live-bits)
(setf (sbit bits num) 0) (setf (sbit bits num) 0)
(push-in tn-next* tn live-list)) (push-in tn-next* tn live-list))
((and (eq (svref ltns num) :more)
(eq kind :write))
(note-conflicts live-bits live-list tn num)
(setf (sbit live-bits num) 1)
(push-in tn-next* tn live-list)
(setf (sbit live-in num) 1)))
(setf (tn-local-conflicts tn) bits)))) (setf (tn-local-conflicts tn) bits))))
(let* ((1block (ir2-block-block block)) (make-debug-environment-tns-live block live-bits live-list)))
(succ (block-succ 1block))
(next (ir2-block-next block)))
(when (and next ;;; DO-SAVE-P-STUFF -- Internal
(not (eq (ir2-block-block next) 1block)) ;;;
(or (null succ) ;;; A function called in Conflict-Analyze-1-Block when we have a VOP with
(eq (first succ) ;;; SAVE-P true. We compute the save-set, and if :FORCE-TO-STACK, force all
(component-tail (block-component 1block))))) ;;; the live TNs to be stack environment TNs.
(do ((conf (ir2-block-global-tns block) ;;;
(global-conflicts-next conf))) (defun do-save-p-stuff (vop block live-bits)
((null conf)) (declare (type vop vop) (type ir2-block block)
(let* ((tn (global-conflicts-tn conf)) (type local-tn-bit-vector live-bits))
(num (global-conflicts-number conf))) (let ((ss (compute-save-set vop live-bits)))
(when (and num (zerop (sbit live-bits num)) (setf (vop-save-set vop) ss)
(eq (tn-kind tn) :debug-environment) (when (eq (vop-info-save-p (vop-info vop)) :force-to-stack)
(eq (tn-environment tn) (block-environment 1block)) (do-live-tns (tn ss block)
(saved-after-read tn block)) (unless (eq (tn-kind tn) :component)
(note-conflicts live-bits live-list tn num) (force-tn-to-stack tn)
(setf (sbit live-bits num) 1) (unless (eq (tn-kind tn) :environment)
(push-in tn-next* tn live-list) (convert-to-environment-tn
(setf (sbit live-in num) 1)))))) tn
(block-environment (ir2-block-block block))))))))
(values live-bits live-list))) (undefined-value))
(eval-when (compile eval) (eval-when (compile eval)
;;; Frob-More-TNs -- Internal ;;; Frob-More-TNs -- Internal
;;; ;;;
;;; Used in the guts of Conflict-Analyze-1-Block to simultaneously do ;;; Used in SCAN-VOP-REFS to simultaneously do something to all of the TNs
;;; something to all of the TNs referenced by a big more arg. We have to treat ;;; referenced by a big more arg. We have to treat these TNs specially, since
;;; these TNs specially, since when we set or clear the bit in the live TNs, ;;; when we set or clear the bit in the live TNs, the represents a change in
;;; the represents a change in the liveness of all the more TNs. If we ;;; the liveness of all the more TNs. If we iterated as normal, the next more
;;; iterated as normal, the next more ref would be thought to be not live when ;;; ref would be thought to be not live when it was, etc. We return true if
;;; it was, etc. We return true if there where more TNs. ;;; there where more TNs.
;;; ;;;
(defmacro frob-more-tns (action) (defmacro frob-more-tns (action)
`(when (eq (svref ltns num) :more) `(when (eq (svref ltns num) :more)
...@@ -736,6 +779,53 @@ ...@@ -736,6 +779,53 @@
,action)) ,action))
t)) t))
;;; SCAN-VOP-REFS -- Internal
;;;
;;; Handle the part of CONFLICT-ANALYZE-1-BLOCK that scans the REFs for the
;;; current VOP. This macro shamelessly references free variables in C-A-1-B.
;;;
(defmacro scan-vop-refs ()
'(do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
((null ref))
(let* ((tn (tn-ref-tn ref))
(num (tn-local-number tn)))
(cond
((not num))
((not (zerop (sbit live-bits num)))
(when (tn-ref-write-p ref)
(setf (sbit live-bits num) 0)
(deletef-in tn-next* live-list tn)
(when (frob-more-tns (deletef-in tn-next* live-list mtn))
(return))))
(t
(assert (not (tn-ref-write-p ref)))
(note-conflicts live-bits live-list tn num)
(frob-more-tns (note-conflicts live-bits live-list mtn num))
(setf (sbit live-bits num) 1)
(push-in tn-next* tn live-list)
(when (frob-more-tns (push-in tn-next* mtn live-list))
(return)))))))
;;; ENSURE-RESULTS-LIVE -- Internal
;;;
;;; This macro is called by CONFLICT-ANALYZE-1-BLOCK to scan the current
;;; VOP's results, and make any dead ones live. This is necessary, since even
;;; though a result is dead after the VOP, it may be in use for an extended
;;; period within the VOP (especially if it has :FROM specified.) During this
;;; interval, temporaries must be noted to conflict with the result. More
;;; results are finessed in COMPUTE-INITIAL-CONFLICTS, so we ignore them here.
;;;
(defmacro ensure-results-live ()
'(do ((res (vop-results vop) (tn-ref-across res)))
((null res))
(let* ((tn (tn-ref-tn res))
(num (tn-local-number tn)))
(when (and num (zerop (sbit live-bits num)))
(unless (eq (svref ltns num) :more)
(note-conflicts live-bits live-list tn num)
(setf (sbit live-bits num) 1)
(push-in tn-next* tn live-list))))))
); Eval-When (Compile Eval) ); Eval-When (Compile Eval)
...@@ -751,46 +841,13 @@ ...@@ -751,46 +841,13 @@
(live-bits live-list) (live-bits live-list)
(compute-initial-conflicts block) (compute-initial-conflicts block)
(let ((ltns (ir2-block-local-tns block))) (let ((ltns (ir2-block-local-tns block)))
(do ((vop (ir2-block-last-vop block) (do ((vop (ir2-block-last-vop block)
(vop-prev vop))) (vop-prev vop)))
((null vop)) ((null vop))
(when (vop-info-save-p (vop-info vop))
(let ((save-p (vop-info-save-p (vop-info vop)))) (do-save-p-stuff vop block live-bits))
(when save-p (ensure-results-live)
(let ((ss (compute-save-set vop live-bits))) (scan-vop-refs)))))
(setf (vop-save-set vop) ss)
(when (eq save-p :force-to-stack)
(do-live-tns (tn ss block)
(unless (eq (tn-kind tn) :component)
(force-tn-to-stack tn)
(unless (eq (tn-kind tn) :environment)
(convert-to-environment-tn
tn
(block-environment (ir2-block-block block))))))))))
(do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
((null ref))
(let* ((tn (tn-ref-tn ref))
(num (tn-local-number tn)))
(cond
((not num))
((not (zerop (sbit live-bits num)))
(when (tn-ref-write-p ref)
(setf (sbit live-bits num) 0)
(deletef-in tn-next* live-list tn)
(when (frob-more-tns (deletef-in tn-next* live-list mtn))
(return))))
((tn-ref-write-p ref)
(note-conflicts live-bits live-list tn num))
(t
(note-conflicts live-bits live-list tn num)
(frob-more-tns (note-conflicts live-bits live-list mtn num))
(setf (sbit live-bits num) 1)
(push-in tn-next* tn live-list)
(when (frob-more-tns (push-in tn-next* mtn live-list))
(return))))))))))
;;; Lifetime-Post-Pass -- Internal ;;; Lifetime-Post-Pass -- Internal
......
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