(unless (tn-global-conflicts tn)
(convert-to-global tn))
(add-global-conflict :read-only tn block ltn-num))
-
+
(setf (tn-local tn) block)
(setf (tn-local-number tn) ltn-num)
(setf (svref tns ltn-num) tn)
;;; local when we scan the block again.
;;;
;;; If there are conflicts, then we set LOCAL to one of the
-;;; conflicting blocks. This ensures that Local doesn't hold over
+;;; conflicting blocks. This ensures that LOCAL doesn't hold over
;;; BLOCK as its value, causing the subsequent reanalysis to think
;;; that the TN has already been seen in that block.
;;;
(defun convert-to-environment-tn (tn tn-physenv)
(declare (type tn tn) (type physenv tn-physenv))
(aver (member (tn-kind tn) '(:normal :debug-environment)))
- (when (eq (tn-kind tn) :debug-environment)
- (aver (eq (tn-physenv tn) tn-physenv))
- (let ((2env (physenv-info tn-physenv)))
- (setf (ir2-physenv-debug-live-tns 2env)
- (delete tn (ir2-physenv-debug-live-tns 2env)))))
+ (ecase (tn-kind tn)
+ (:debug-environment
+ (setq tn-physenv (tn-physenv tn))
+ (let* ((2env (physenv-info tn-physenv)))
+ (setf (ir2-physenv-debug-live-tns 2env)
+ (delete tn (ir2-physenv-debug-live-tns 2env)))))
+ (:normal
+ (setf (tn-local tn) nil)
+ (setf (tn-local-number tn) nil)))
(setup-environment-tn-conflicts *component-being-compiled* tn tn-physenv nil)
- (setf (tn-local tn) nil)
- (setf (tn-local-number tn) nil)
(setf (tn-kind tn) :environment)
(setf (tn-physenv tn) tn-physenv)
(push tn (ir2-physenv-live-tns (physenv-info tn-physenv)))
;;; We leave the CURRENT-CONFLICT pointing to the conflict for BLOCK1.
;;; The CURRENT-CONFLICT must be initialized to the head of the
;;; GLOBAL-CONFLICTS for the TN between each flow analysis iteration.
-;;;
-;;; :DEBUG-ENVIRONMENT TN might be :LIVE before being assigned, so we
-;;; must be careful to not propagate its liveness into another
-;;; environment (see bug 115).
(defun propagate-live-tns (block1 block2)
(declare (type ir2-block block1 block2))
(let ((live-in (ir2-block-live-in block1))
(did-something nil))
(do ((conf2 (ir2-block-global-tns block2)
- (global-conflicts-next-blockwise conf2)))
- ((null conf2))
- (let ((tn (global-conflicts-tn conf2)))
- (unless (and (not (eq (ir2-block-physenv block1) (ir2-block-physenv block2)))
- (member (tn-kind tn) '(:environment :debug-environment)))
- (ecase (global-conflicts-kind conf2)
- ((:live :read :read-only)
- (let* ((tn-conflicts (tn-current-conflict tn))
- (number1 (ir2-block-number block1)))
- (aver tn-conflicts)
- (do ((current tn-conflicts (global-conflicts-next-tnwise current))
- (prev nil current))
- ((or (null current)
- (> (ir2-block-number (global-conflicts-block current))
- number1))
- (setf (tn-current-conflict tn) prev)
- (add-global-conflict :live tn block1 nil)
- (setq did-something t))
- (when (eq (global-conflicts-block current) block1)
- (case (global-conflicts-kind current)
- (:live)
- (:read-only
- (setf (global-conflicts-kind current) :live)
- (setf (svref (ir2-block-local-tns block1)
- (global-conflicts-number current))
- nil)
- (setf (global-conflicts-number current) nil)
- (setf (tn-current-conflict tn) current))
- (t
- (setf (sbit live-in (global-conflicts-number current)) 1)))
- (return)))))
- (:write)))))
+ (global-conflicts-next-blockwise conf2)))
+ ((null conf2))
+ (ecase (global-conflicts-kind conf2)
+ ((:live :read :read-only)
+ (let* ((tn (global-conflicts-tn conf2))
+ (tn-conflicts (tn-current-conflict tn))
+ (number1 (ir2-block-number block1)))
+ (aver tn-conflicts)
+ (do ((current tn-conflicts (global-conflicts-next-tnwise current))
+ (prev nil current))
+ ((or (null current)
+ (> (ir2-block-number (global-conflicts-block current))
+ number1))
+ (setf (tn-current-conflict tn) prev)
+ (add-global-conflict :live tn block1 nil)
+ (setq did-something t))
+ (when (eq (global-conflicts-block current) block1)
+ (case (global-conflicts-kind current)
+ (:live)
+ (:read-only
+ (setf (global-conflicts-kind current) :live)
+ (setf (svref (ir2-block-local-tns block1)
+ (global-conflicts-number current))
+ nil)
+ (setf (global-conflicts-number current) nil)
+ (setf (tn-current-conflict tn) current))
+ (t
+ (setf (sbit live-in (global-conflicts-number current)) 1)))
+ (return)))))
+ (:write)))
did-something))
;;; Do backward global flow analysis to find all TNs live at each