diff --git a/compiler/life.lisp b/compiler/life.lisp index 7c60f059ddfa01ddebab120e0fc0f427f5358594..ff3413990f00836f736e2d07e91781c375a9571f 100644 --- a/compiler/life.lisp +++ b/compiler/life.lisp @@ -40,16 +40,26 @@ new))) (setf (tn-current-conflict tn) new) - (let ((global-num (tn-number tn))) - (do ((prev nil conf) - (conf (ir2-block-global-tns block) - (global-conflicts-next conf))) - ((or (null conf) - (> (tn-number (global-conflicts-tn conf)) global-num)) - (if prev - (setf (global-conflicts-next prev) new) - (setf (ir2-block-global-tns block) new)) - (setf (global-conflicts-next new) conf))))) + (insert-block-global-conflict new block)) + (undefined-value)) + + +;;; INSERT-BLOCK-GLOBAL-CONFLICT -- Internal +;;; +;;; Do the actual insertion of the conflict New into Block's global +;;; conflicts. +;;; +(defun insert-block-global-conflict (new block) + (let ((global-num (tn-number (global-conflicts-tn new)))) + (do ((prev nil conf) + (conf (ir2-block-global-tns block) + (global-conflicts-next conf))) + ((or (null conf) + (> (tn-number (global-conflicts-tn conf)) global-num)) + (if prev + (setf (global-conflicts-next prev) new) + (setf (ir2-block-global-tns block) new)) + (setf (global-conflicts-next new) conf)))) (undefined-value)) @@ -123,7 +133,7 @@ (let* ((tn (tn-ref-tn ref)) (local (tn-local tn)) (kind (tn-kind tn))) - (when (eq kind :normal) + (unless (member kind '(:component :environment :constant)) (unless (eq local block) (when (= ltn-num local-tn-limit) (return-from find-local-references vop)) @@ -394,6 +404,105 @@ (undefined-value)) + +;;;; Environment TN stuff: + + +;;; SETUP-ENVIRONMENT-TN-CONFLICT -- Internal +;;; +;;; Add a :LIVE global conflict for TN in 2block if there is none present. +;;; If Debug-P is false (a :ENVIRONMENT TN), then modify any existing conflict +;;; to be :LIVE. +;;; +(defun setup-environment-tn-conflict (tn 2block debug-p) + (declare (type tn tn) (type ir2-block 2block)) + (let ((block-num (ir2-block-number 2block))) + (do ((conf (tn-current-conflict tn) (global-conflicts-tn-next conf)) + (prev nil conf)) + ((or (null conf) + (> (ir2-block-number (global-conflicts-block conf)) block-num)) + (setf (tn-current-conflict tn) prev) + (add-global-conflict :live tn 2block nil)) + (when (eq (global-conflicts-block conf) 2block) + (unless (or debug-p + (eq (global-conflicts-kind conf) :live)) + (setf (global-conflicts-kind conf) :live) + (setf (svref (ir2-block-local-tns 2block) + (global-conflicts-number conf)) + nil) + (setf (global-conflicts-number conf) nil)) + (setf (tn-current-conflict tn) conf) + (return)))) + (undefined-value)) + + +;;; SETUP-ENVIRONMENT-TN-CONFLICTS -- Internal +;;; +;;; Iterate over all the blocks in Env, setting up :LIVE conflicts for TN. +;;; We make the TN global if it isn't already. The TN must have at least one +;;; reference. +;;; +(defun setup-environment-tn-conflicts (component tn env debug-p) + (declare (type component component) (type tn tn) (type environment env)) + (when (and debug-p (not (tn-global-conflicts tn))) + (convert-to-global tn)) + (setf (tn-current-conflict tn) (tn-global-conflicts tn)) + (do-blocks-backwards (block component) + (when (eq (block-environment block) env) + (let* ((2block (block-info block)) + (last (do ((b (ir2-block-next 2block) (ir2-block-next b)) + (prev 2block b)) + ((not (eq (ir2-block-block b) block)) + prev)))) + (do ((b last (ir2-block-prev b))) + ((not (eq (ir2-block-block b) block))) + (setup-environment-tn-conflict tn b debug-p))))) + (undefined-value)) + + +;;; SETUP-ENVIRONMENT-[DEBUG-]LIVE-CONFLICTS -- Internal +;;; +;;; Iterate over all the environment TNs, adding always-live conflicts as +;;; appropriate. +;;; +(defun setup-environment-live-conflicts (component) + (declare (type component component)) + (dolist (fun (component-lambdas component)) + (let ((env (lambda-environment fun))) + (dolist (tn (ir2-environment-live-tns (environment-info env))) + (setup-environment-tn-conflicts component tn env nil)))) + (undefined-value)) +;;; +(defun setup-environment-debug-live-conflicts (component) + (declare (type component component)) + (dolist (fun (component-lambdas component)) + (let ((env (lambda-environment fun))) + (dolist (tn (ir2-environment-debug-live-tns (environment-info env))) + (setup-environment-tn-conflicts component tn env t)))) + (undefined-value)) + + +;;; Convert-To-Environment-TN -- Internal +;;; +;;; Convert a :NORMAL or :DEBUG-ENVIRONMENT TN to an :ENVIRONMENT TN. This +;;; requires adding :LIVE conflicts to all blocks in TN-ENV. +;;; +(defun convert-to-environment-tn (tn tn-env) + (declare (type tn tn) (type environment tn-env)) + (assert (member (tn-kind tn) '(:normal :debug-environment))) + (when (eq (tn-kind tn) :debug-environment) + (assert (eq (tn-environment tn) tn-env)) + (let ((2env (environment-info tn-env))) + (setf (ir2-environment-debug-live-tns 2env) + (delete tn (ir2-environment-debug-live-tns 2env))))) + (setup-environment-tn-conflicts *compile-component* tn tn-env nil) + (setf (tn-local tn) nil) + (setf (tn-local-number tn) nil) + (setf (tn-kind tn) :environment) + (setf (tn-environment tn) tn-env) + (push tn (ir2-environment-live-tns (environment-info tn-env))) + (undefined-value)) + ;;;; Flow analysis: @@ -494,39 +603,6 @@ ;;;; Post-pass: -;;; Convert-To-Environment-TN -- Internal -;;; -;;; Convert a :Normal TN to an :Environment TN. This requires deleting the -;;; existing conflict info. -;;; -(defun convert-to-environment-tn (tn) - (declare (type tn tn)) - (assert (eq (tn-kind tn) :normal)) - (let ((confs (tn-global-conflicts tn))) - (if confs - (do ((conf confs (global-conflicts-tn-next conf))) - ((null conf)) - (let ((block (global-conflicts-block conf))) - (unless (eq (global-conflicts-kind conf) :live) - (let ((ltns (ir2-block-local-tns block)) - (num (global-conflicts-number conf))) - (assert (not (eq (svref ltns num) :more))) - (setf (svref ltns num) nil))) - (deletef-in global-conflicts-next (ir2-block-global-tns block) - conf))) - (setf (svref (ir2-block-local-tns (tn-local tn)) - (tn-local-number tn)) - nil)) - (setf (tn-local tn) nil) - (setf (tn-local-number tn) nil) - (setf (tn-global-conflicts tn) nil) - (setf (tn-kind tn) :environment) - (push tn (ir2-environment-live-tns - (environment-info - (tn-environment tn))))) - (undefined-value)) - - ;;; Note-Conflicts -- Internal ;;; ;;; Note that TN conflicts with all current live TNs. Num is TN's LTN @@ -550,17 +626,32 @@ ;;; Compute a bit vector of the TNs live after VOP that aren't results. ;;; (defun compute-save-set (vop live-bits) - (declare (type vop vop) (type local-tn-bit-vector live-list)) + (declare (type vop vop) (type local-tn-bit-vector live-bits)) (let ((live (bit-vector-copy live-bits))) (do ((r (vop-results vop) (tn-ref-across r))) ((null r)) (let ((tn (tn-ref-tn r))) (ecase (tn-kind tn) - (:normal (setf (sbit live (tn-local-number tn)) 0)) + ((:normal :debug-environment) + (setf (sbit live (tn-local-number tn)) 0)) (:environment :component)))) live)) +;;; SAVED-AFTER-READ -- Internal +;;; +;;; Used to determine whether a :DEBUG-ENVIRONMENT TN should be considered +;;; live at block end. We return true if a VOP with non-null SAVE-P appears +;;; before the first read of TN (hence is seen first in our backward scan.) +;;; +(defun saved-after-read (tn block) + (do ((vop (ir2-block-last-vop block) (vop-prev vop))) + ((null vop) t) + (when (vop-info-save-p (vop-info vop)) (return t)) + (when (find-in #'tn-ref-across tn (vop-args vop) :key #'tn-ref-tn) + (return nil)))) + + ;;; Compute-Initial-Conflicts -- Internal ;;; ;;; Return as values, a LTN bit-vector and a list (threaded by TN-Next*) @@ -570,13 +661,21 @@ ;;; end, setting up the TN-Local-Conflicts and TN-Local-Number, and adding the ;;; TN to the live list. ;;; +;;; 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. +;;; ;;; ### Note: we alias the global-conflicts-conflicts here as the ;;; tn-local-conflicts. ;;; (defun compute-initial-conflicts (block) (declare (type ir2-block block)) - (let ((live-bits (bit-vector-copy (ir2-block-live-in block))) - (live-list nil)) + (let* ((live-in (ir2-block-live-in block)) + (live-bits (bit-vector-copy live-in)) + (live-list nil)) (do ((conf (ir2-block-global-tns block) (global-conflicts-next conf))) @@ -592,6 +691,28 @@ (push-in tn-next* tn live-list)) (setf (tn-local-conflicts tn) bits)))) + (let* ((1block (ir2-block-block 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))) @@ -645,7 +766,9 @@ (unless (eq (tn-kind tn) :component) (force-tn-to-stack tn) (unless (eq (tn-kind tn) :environment) - (convert-to-environment-tn tn)))))))) + (convert-to-environment-tn + tn + (block-environment (ir2-block-block block)))))))))) (do ((ref (vop-refs vop) (tn-ref-next-ref ref))) ((null ref)) @@ -679,14 +802,183 @@ (do-ir2-blocks (block component) (conflict-analyze-1-block block))) + +;;;; Alias TN stuff: + +;;; MERGE-ALIAS-BLOCK-CONFLICTS -- Internal +;;; +;;; Destructively modify Oconf to include the conflict information in Conf. +;;; +(defun merge-alias-block-conflicts (conf oconf) + (declare (type global-conflicts conf oconf)) + (let* ((kind (global-conflicts-kind conf)) + (num (global-conflicts-number conf)) + (okind (global-conflicts-kind oconf)) + (onum (global-conflicts-number oconf)) + (block (global-conflicts-block oconf)) + (ltns (ir2-block-local-tns block))) + (cond + ((eq okind :live)) + ((eq kind :live) + (setf (global-conflicts-kind oconf) :live) + (setf (svref ltns onum) nil) + (setf (global-conflicts-number oconf) nil)) + (t + (unless (eq kind okind) + (setf (global-conflicts-kind oconf) :read)) + ;; + ;; Make original conflict with all the local TNs the alias conflicted + ;; with. + (bit-ior (global-conflicts-conflicts oconf) + (global-conflicts-conflicts conf) + t) + (flet ((frob (x) + (unless (zerop (sbit x num)) + (setf (sbit x onum) 1)))) + ;; + ;; Make all the local TNs that conflicted with the alias conflict + ;; with the original. + (dotimes (i (ir2-block-local-tn-count block)) + (let ((tn (svref ltns i))) + (when (and tn (not (eq tn :more)) + (null (tn-global-conflicts tn))) + (frob (tn-local-conflicts tn))))) + ;; + ;; Same for global TNs... + (do ((current (ir2-block-global-tns block) + (global-conflicts-next current))) + ((null current)) + (unless (eq (global-conflicts-kind current) :live) + (frob (global-conflicts-conflicts current)))) + ;; + ;; Make the original TN live everywhere that the alias was live. + (frob (ir2-block-written block)) + (frob (ir2-block-live-in block)) + (frob (ir2-block-live-out block)) + (do ((vop (ir2-block-start-vop block) + (vop-next vop))) + ((null vop)) + (let ((sset (vop-save-set vop))) + (when sset (frob sset))))))) + ;; + ;; Delete the alias's conflict info. + (when num + (setf (svref ltns num) nil)) + (deletef-in global-conflicts-next (ir2-block-global-tns block) conf)) + + (undefined-value)) + + +;;; CHANGE-GLOBAL-CONFLICTS-TN -- Internal +;;; +;;; Co-opt Conf to be a conflict for TN. +;;; +(defun change-global-conflicts-tn (conf new) + (declare (type global-conflicts conf) (type tn new)) + (setf (global-conflicts-tn conf) new) + (let ((ltn-num (global-conflicts-number conf)) + (block (global-conflicts-block conf))) + (deletef-in global-conflicts-next (ir2-block-global-tns block) conf) + (setf (global-conflicts-next conf) nil) + (insert-block-global-conflict conf block) + (when ltn-num + (setf (svref (ir2-block-local-tns block) ltn-num) new))) + (undefined-value)) + + +;;; ENSURE-GLOBAL-TN -- Internal +;;; +;;; Do CONVERT-TO-GLOBAL on TN if it has no global conflicts. Copy the +;;; local conflicts into the global bit vector. +;;; +(defun ensure-global-tn (tn) + (declare (type tn tn)) + (unless (tn-global-conflicts tn) + (convert-to-global tn) + (bit-ior (global-conflicts-conflicts (tn-global-conflicts tn)) + (tn-local-conflicts tn) + t)) + (undefined-value)) + + +;;; MERGE-ALIAS-CONFLICTS -- Internal +;;; +;;; For each :ALIAS TN, destructively merge the conflict info into the +;;; original TN and replace the uses of the alias. +;;; +;;; For any block that uses only the alias TN, just insert that conflict into +;;; the conflicts for the original TN, changing the LTN map to refer to the +;;; original TN. This gives a result indistinguishable from the what there +;;; would have been if the original TN had always been referenced. This leaves +;;; no sign that an alias TN was ever involved. +;;; +;;; If a block has references to both the alias and the original TN, then we +;;; call MERGE-ALIAS-BLOCK-CONFLICTS to combine the conflicts into the original +;;; conflict. +;;; +(defun merge-alias-conflicts (component) + (declare (type component component)) + (do ((tn (ir2-component-alias-tns (component-info component)) + (tn-next tn))) + ((null tn)) + (let ((original (tn-save-tn tn))) + (ensure-global-tn tn) + (ensure-global-tn original) + (let ((conf (tn-global-conflicts tn)) + (oconf (tn-global-conflicts original)) + (oprev nil)) + (loop + (let* ((block (global-conflicts-block conf)) + (num (ir2-block-number block)) + (onum (ir2-block-number (global-conflicts-block oconf)))) + + (cond ((< onum num) + (shiftf oprev oconf (global-conflicts-tn-next oconf))) + ((> onum num) + (if oprev + (setf (global-conflicts-tn-next oprev) conf) + (setf (tn-global-conflicts original) conf)) + (change-global-conflicts-tn conf original) + (shiftf conf (global-conflicts-tn-next conf) oconf)) + (t + (merge-alias-block-conflicts conf oconf) + (shiftf oprev oconf (global-conflicts-tn-next oconf)) + (setf conf (global-conflicts-tn-next conf))))) + (unless oconf + (if oprev + (setf (global-conflicts-tn-next oprev) conf) + (setf (tn-global-conflicts original) conf)) + (do ((current conf (global-conflicts-tn-next current))) + ((null current)) + (change-global-conflicts-tn conf original)) + (return)) + (unless conf (return)))) + + (flet ((frob (refs) + (let ((ref refs) + (next nil)) + (loop + (unless ref (return)) + (setq next (tn-ref-next ref)) + (change-tn-ref-tn ref original) + (setq ref next))))) + (frob (tn-reads tn)) + (frob (tn-writes tn))) + (setf (tn-global-conflicts tn) nil))) + + (undefined-value)) + ;;; Lifetime-Analyze -- Interface ;;; ;;; (defun lifetime-analyze (component) (lifetime-pre-pass component) + (setup-environment-live-conflicts component) (lifetime-flow-analysis component) - (lifetime-post-pass component)) + (setup-environment-debug-live-conflicts component) + (lifetime-post-pass component) + (merge-alias-conflicts component)) ;;;; Conflict testing: @@ -747,32 +1039,6 @@ (advance y-num y-conf))))))) -;;; TNs-Conflict-Environment-Global -- Interface -;;; -;;; Return true if any of Y's blocks are in X's environment. -;;; -(defun tns-conflict-environment-global (x y) - (declare (type tn x y)) - (let ((env (tn-environment x))) - (do ((conf (tn-global-conflicts y) (global-conflicts-tn-next conf))) - ((null conf) - nil) - (when (eq (block-environment - (ir2-block-block (global-conflicts-block conf))) - env) - (return t))))) - - -;;; TNs-Conflict-Environment-Local -- Interface -;;; -;;; Return true if Y's block is in X's environment. -;;; -(defun tns-conflict-environment-local (x y) - (declare (type tn x y)) - (eq (block-environment (ir2-block-block (tn-local y))) - (tn-environment x))) - - ;;; TNs-Conflict -- Interface ;;; ;;; Return true if X and Y are distinct and the lifetimes of X and Y overlap @@ -783,17 +1049,6 @@ (let ((x-kind (tn-kind x)) (y-kind (tn-kind y))) (cond ((eq x y) nil) - ((eq x-kind :environment) - (cond ((tn-global-conflicts y) - (tns-conflict-environment-global x y)) - ((eq (tn-kind y) :environment) - (eq (tn-environment x) (tn-environment y))) - (t - (tns-conflict-environment-local x y)))) - ((eq y-kind :environment) - (if (tn-global-conflicts x) - (tns-conflict-environment-global y x) - (tns-conflict-environment-local y x))) ((or (eq x-kind :component) (eq y-kind :component)) t) ((tn-global-conflicts x) (if (tn-global-conflicts y) @@ -805,3 +1060,4 @@ (and (eq (tn-local x) (tn-local y)) (not (zerop (sbit (tn-local-conflicts x) (tn-local-number y))))))))) +