;;; block in order to keep that thread sorted.
(defun add-global-conflict (kind tn block number)
(declare (type (member :read :write :read-only :live) kind)
- (type tn tn) (type ir2-block block)
- (type (or local-tn-number null) number))
+ (type tn tn) (type ir2-block block)
+ (type (or local-tn-number null) number))
(let ((new (make-global-conflicts kind tn block number)))
(let ((last (tn-current-conflict tn)))
(if last
- (shiftf (global-conflicts-next-tnwise new)
- (global-conflicts-next-tnwise last)
- new)
- (shiftf (global-conflicts-next-tnwise new)
- (tn-global-conflicts tn)
- new)))
+ (shiftf (global-conflicts-next-tnwise new)
+ (global-conflicts-next-tnwise last)
+ new)
+ (shiftf (global-conflicts-next-tnwise new)
+ (tn-global-conflicts tn)
+ new)))
(setf (tn-current-conflict tn) new)
(insert-block-global-conflict new block))
(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-blockwise conf)))
- ((or (null conf)
- (> (tn-number (global-conflicts-tn conf)) global-num))
- (if prev
- (setf (global-conflicts-next-blockwise prev) new)
- (setf (ir2-block-global-tns block) new))
- (setf (global-conflicts-next-blockwise new) conf))))
+ (conf (ir2-block-global-tns block)
+ (global-conflicts-next-blockwise conf)))
+ ((or (null conf)
+ (> (tn-number (global-conflicts-tn conf)) global-num))
+ (if prev
+ (setf (global-conflicts-next-blockwise prev) new)
+ (setf (ir2-block-global-tns block) new))
+ (setf (global-conflicts-next-blockwise new) conf))))
(values))
;;; Reset the CURRENT-CONFLICT slot in all packed TNs to point to the
(defun reset-current-conflict (component)
(do-packed-tns (tn component)
(setf (tn-current-conflict tn) (tn-global-conflicts tn))))
+
+;;; Cache the results of BLOCK-PHYSENV during lifetime analysis.
+;;;
+;;; Fetching the home-lambda of a block (needed in block-physenv) can
+;;; be an expensive operation under some circumstances, and it needs
+;;; to be done a lot during lifetime analysis when compiling with high
+;;; DEBUG (e.g. 30% of the total compilation time for CL-PPCRE with
+;;; DEBUG 3 just for that).
+(defun cached-block-physenv (block)
+ (let ((physenv (block-physenv-cache block)))
+ (if (eq physenv :none)
+ (setf (block-physenv-cache block)
+ (block-physenv block))
+ physenv)))
\f
;;;; pre-pass
(defun convert-to-global (tn)
(declare (type tn tn))
(let ((block (tn-local tn))
- (num (tn-local-number tn)))
+ (num (tn-local-number tn)))
(add-global-conflict
(if (zerop (sbit (ir2-block-written block) num))
- :read-only
- (if (zerop (sbit (ir2-block-live-out block) num))
- :write
- :read))
+ :read-only
+ (if (zerop (sbit (ir2-block-live-out block) num))
+ :write
+ :read))
tn block num))
(values))
(defun find-local-references (block)
(declare (type ir2-block block))
(let ((kill (ir2-block-written block))
- (live (ir2-block-live-out block))
- (tns (ir2-block-local-tns block)))
+ (live (ir2-block-live-out block))
+ (tns (ir2-block-local-tns block)))
(let ((ltn-num (ir2-block-local-tn-count block)))
(do ((vop (ir2-block-last-vop block)
- (vop-prev vop)))
- ((null vop))
- (do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
- ((null ref))
- (let* ((tn (tn-ref-tn ref))
- (local (tn-local tn))
- (kind (tn-kind tn)))
- (unless (member kind '(:component :environment :constant))
- (unless (eq local block)
- (when (= ltn-num local-tn-limit)
- (return-from find-local-references vop))
- (when local
- (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)
- (incf ltn-num))
-
- (let ((num (tn-local-number tn)))
- (if (tn-ref-write-p ref)
- (setf (sbit kill num) 1 (sbit live num) 0)
- (setf (sbit live num) 1)))))))
+ (vop-prev vop)))
+ ((null vop))
+ (do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
+ ((null ref))
+ (let* ((tn (tn-ref-tn ref))
+ (local (tn-local tn))
+ (kind (tn-kind tn)))
+ (unless (member kind '(:component :environment :constant))
+ (unless (eq local block)
+ (when (= ltn-num local-tn-limit)
+ (return-from find-local-references vop))
+ (when local
+ (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)
+ (incf ltn-num))
+
+ (let ((num (tn-local-number tn)))
+ (if (tn-ref-write-p ref)
+ (setf (sbit kill num) 1 (sbit live num) 0)
+ (setf (sbit live num) 1)))))))
(setf (ir2-block-local-tn-count block) ltn-num)))
nil)
(let ((live (ir2-block-live-out block)))
(let ((kill (ir2-block-written block)))
(do ((conf (ir2-block-global-tns block)
- (global-conflicts-next-blockwise conf)))
- ((null conf))
- (let ((num (global-conflicts-number conf)))
- (unless (zerop (sbit kill num))
- (setf (global-conflicts-kind conf)
- (if (zerop (sbit live num))
- :write
- :read))))))
+ (global-conflicts-next-blockwise conf)))
+ ((null conf))
+ (let ((num (global-conflicts-number conf)))
+ (unless (zerop (sbit kill num))
+ (setf (global-conflicts-kind conf)
+ (if (zerop (sbit live num))
+ :write
+ :read))))))
(let ((ltns (ir2-block-local-tns block)))
(dotimes (i (ir2-block-local-tn-count block))
- (let ((tn (svref ltns i)))
- (unless (or (eq tn :more)
- (tn-global-conflicts tn)
- (zerop (sbit live i)))
- (convert-to-global tn))))))
+ (let ((tn (svref ltns i)))
+ (unless (or (eq tn :more)
+ (tn-global-conflicts tn)
+ (zerop (sbit live i)))
+ (convert-to-global tn))))))
(values))
;;; block.
(defun split-ir2-blocks (2block lose number)
(declare (type ir2-block 2block) (type vop lose)
- (type unsigned-byte number))
+ (type unsigned-byte number))
(event split-ir2-block (vop-node lose))
(let ((new (make-ir2-block (ir2-block-block 2block)))
- (new-start (vop-next lose)))
+ (new-start (vop-next lose)))
(setf (ir2-block-number new) number)
(add-to-emit-order new 2block)
(do ((vop new-start (vop-next vop)))
- ((null vop))
+ ((null vop))
(setf (vop-block vop) new))
(setf (ir2-block-start-vop new) new-start)
(setf (ir2-block-local-tn-count block) 0)
(do ((conf (ir2-block-global-tns block)
- (global-conflicts-next-blockwise conf)))
+ (global-conflicts-next-blockwise conf)))
((null conf)
(setf (ir2-block-global-tns block) nil))
(let ((tn (global-conflicts-tn conf)))
(aver (eq (tn-current-conflict tn) conf))
(aver (null (global-conflicts-next-tnwise conf)))
(do ((current (tn-global-conflicts tn)
- (global-conflicts-next-tnwise current))
- (prev nil current))
- ((eq current conf)
- (if prev
- (setf (global-conflicts-next-tnwise prev) nil)
- (setf (tn-global-conflicts tn) nil))
- (setf (tn-current-conflict tn) prev)))))
+ (global-conflicts-next-tnwise current))
+ (prev nil current))
+ ((eq current conf)
+ (if prev
+ (setf (global-conflicts-next-tnwise prev) nil)
+ (setf (tn-global-conflicts tn) nil))
+ (setf (tn-current-conflict tn) prev)))))
(fill (ir2-block-written block) 0)
(let ((ltns (ir2-block-local-tns block)))
(dotimes (i local-tn-limit)
(let ((tn (svref ltns i)))
- (aver (not (eq tn :more)))
- (let ((conf (tn-global-conflicts tn)))
- (setf (tn-local tn)
- (if conf
- (global-conflicts-block conf)
- nil))))))
+ (aver (not (eq tn :more)))
+ (let ((conf (tn-global-conflicts tn)))
+ (setf (tn-local tn)
+ (if conf
+ (global-conflicts-block conf)
+ nil))))))
(values))
(setf (svref (ir2-block-local-tns block) num) :more)
(do ((op (do ((op ops (tn-ref-across op))
- (i 0 (1+ i)))
- ((= i (length fixed)) op)
- (declare (type index i)))
- (tn-ref-across op)))
- ((null op))
+ (i 0 (1+ i)))
+ ((= i (length fixed)) op)
+ (declare (type index i)))
+ (tn-ref-across op)))
+ ((null op))
(let ((tn (tn-ref-tn op)))
- (assert
- (flet ((frob (refs)
- (do ((ref refs (tn-ref-next ref)))
- ((null ref) t)
- (when (and (eq (vop-block (tn-ref-vop ref)) block)
- (not (eq ref op)))
- (return nil)))))
- (and (frob (tn-reads tn)) (frob (tn-writes tn))))
- () "More operand ~S used more than once in its VOP." op)
- (aver (not (find-in #'global-conflicts-next-blockwise tn
- (ir2-block-global-tns block)
- :key #'global-conflicts-tn)))
-
- (add-global-conflict :read-only tn block num)
- (setf (tn-local tn) block)
- (setf (tn-local-number tn) num))))
+ (assert
+ (flet ((frob (refs)
+ (do ((ref refs (tn-ref-next ref)))
+ ((null ref) t)
+ (when (and (eq (vop-block (tn-ref-vop ref)) block)
+ (not (eq ref op)))
+ (return nil)))))
+ (and (frob (tn-reads tn)) (frob (tn-writes tn))))
+ () "More operand ~S used more than once in its VOP." op)
+ (aver (not (find-in #'global-conflicts-next-blockwise tn
+ (ir2-block-global-tns block)
+ :key #'global-conflicts-tn)))
+
+ (add-global-conflict :read-only tn block num)
+ (setf (tn-local tn) block)
+ (setf (tn-local-number tn) num))))
(values))
(defevent coalesce-more-ltn-numbers
(declare (type fixnum counter))
(do-blocks-backwards (block component)
(let ((2block (block-info block)))
- (do ((lose (find-local-references 2block)
- (find-local-references 2block))
- (last-lose nil lose)
- (coalesced nil))
- ((not lose)
- (init-global-conflict-kind 2block)
- (setf (ir2-block-number 2block) (incf counter)))
-
- (clear-lifetime-info 2block)
-
- (cond
- ((vop-next lose)
- (aver (not (eq last-lose lose)))
- (let ((new (split-ir2-blocks 2block lose (incf counter))))
- (aver (not (find-local-references new)))
- (init-global-conflict-kind new)))
- (t
- (aver (not (eq lose coalesced)))
- (setq coalesced lose)
- (event coalesce-more-ltn-numbers (vop-node lose))
- (let ((info (vop-info lose))
- (new (if (vop-prev lose)
- (split-ir2-blocks 2block (vop-prev lose)
- (incf counter))
- 2block)))
- (coalesce-more-ltn-numbers new (vop-args lose)
- (vop-info-arg-types info))
- (coalesce-more-ltn-numbers new (vop-results lose)
- (vop-info-result-types info))
- (let ((lose (find-local-references new)))
- (aver (not lose)))
- (init-global-conflict-kind new))))))))
+ (do ((lose (find-local-references 2block)
+ (find-local-references 2block))
+ (last-lose nil lose)
+ (coalesced nil))
+ ((not lose)
+ (init-global-conflict-kind 2block)
+ (setf (ir2-block-number 2block) (incf counter)))
+
+ (clear-lifetime-info 2block)
+
+ (cond
+ ((vop-next lose)
+ (aver (not (eq last-lose lose)))
+ (let ((new (split-ir2-blocks 2block lose (incf counter))))
+ (aver (not (find-local-references new)))
+ (init-global-conflict-kind new)))
+ (t
+ (aver (not (eq lose coalesced)))
+ (setq coalesced lose)
+ (event coalesce-more-ltn-numbers (vop-node lose))
+ (let ((info (vop-info lose))
+ (new (if (vop-prev lose)
+ (split-ir2-blocks 2block (vop-prev lose)
+ (incf counter))
+ 2block)))
+ (coalesce-more-ltn-numbers new (vop-args lose)
+ (vop-info-arg-types info))
+ (coalesce-more-ltn-numbers new (vop-results lose)
+ (vop-info-result-types info))
+ (let ((lose (find-local-references new)))
+ (aver (not lose)))
+ (init-global-conflict-kind new))))))))
(values))
\f
(declare (type tn tn) (type ir2-block 2block))
(let ((block-num (ir2-block-number 2block)))
(do ((conf (tn-current-conflict tn) (global-conflicts-next-tnwise 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))
+ (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))))
+ (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))))
(values))
+;;; Return true if TN represents a closed-over variable with an
+;;; "implicit" value-cell.
+(defun implicit-value-cell-tn-p (tn)
+ (let ((leaf (tn-leaf tn)))
+ (and (lambda-var-p leaf)
+ (lambda-var-indirect leaf)
+ (not (lambda-var-explicit-value-cell leaf)))))
+
+;;; If BLOCK ends with a TAIL LOCAL COMBINATION, the function called.
+;;; Otherwise, NIL.
+(defun block-tail-local-call-fun (block)
+ (let ((node (block-last block)))
+ (when (and (combination-p node)
+ (eq :local (combination-kind node))
+ (combination-tail-p node))
+ (ref-leaf (lvar-uses (combination-fun node))))))
+
;;; 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 physenv env))
+(defun setup-environment-tn-conflicts (component tn env debug-p &optional parent-envs)
+ (declare (type component component) (type tn tn) (type physenv env) (type list parent-envs))
+ (when (member env parent-envs)
+ ;; Prevent infinite recursion due to recursive tail calls.
+ (return-from setup-environment-tn-conflicts (values)))
(when (and debug-p
- (not (tn-global-conflicts tn))
- (tn-local tn))
+ (not (tn-global-conflicts tn))
+ (tn-local tn))
(convert-to-global tn))
(setf (tn-current-conflict tn) (tn-global-conflicts tn))
(do-blocks-backwards (block component)
- (when (eq (block-physenv block) env)
+ (when (eq (cached-block-physenv 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)))))
+ (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)))
+ ;; If BLOCK ends with a TAIL LOCAL COMBINATION and TN is an
+ ;; "implicit value cell" then setup conflicts for the callee
+ ;; function as well.
+ (let ((fun (and (implicit-value-cell-tn-p tn)
+ (block-tail-local-call-fun block))))
+ (when fun
+ (setup-environment-tn-conflicts component tn (lambda-physenv fun) debug-p
+ (list* env parent-envs))))))
(values))
;;; Iterate over all the environment TNs, adding always-live conflicts
(declare (type component component))
(dolist (fun (component-lambdas component))
(let* ((env (lambda-physenv fun))
- (2env (physenv-info env)))
+ (2env (physenv-info env)))
(dolist (tn (ir2-physenv-live-tns 2env))
- (setup-environment-tn-conflicts component tn env nil))
+ (setup-environment-tn-conflicts component tn env nil))
(dolist (tn (ir2-physenv-debug-live-tns 2env))
- (setup-environment-tn-conflicts component tn env t))))
+ (setup-environment-tn-conflicts component tn env t))))
(values))
;;; Convert a :NORMAL or :DEBUG-ENVIRONMENT TN to an :ENVIRONMENT TN.
;;; 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.
-(defun propagate-live-tns (block1 block2)
+
+;;; FASTP is a KLUDGE: SBCL used to update the current-conflict only
+;;; for the read-only case, but switched at one point to always
+;;; updating it. This generally speeds up the compiler nicely, but
+;;; sometimes it causes an infinite loop in the updating machinery,
+;;; We cheat by switching of the fast path if it seems we're looping
+;;; longer then expected.
+(defun propagate-live-tns (block1 block2 fastp)
(declare (type ir2-block block1 block2))
(let ((live-in (ir2-block-live-in block1))
- (did-something nil))
+ (did-something nil))
(do ((conf2 (ir2-block-global-tns block2)
- (global-conflicts-next-blockwise conf2)))
- ((null conf2))
+ (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)))
+ ((: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)
+ (unless fastp
+ (setf (tn-current-conflict tn) current)))
+ (t
+ (setf (sbit live-in (global-conflicts-number current)) 1)))
+ (when fastp
+ (setf (tn-current-conflict tn) current))
+ (return)))))
+ (:write)))
did-something))
;;; Do backward global flow analysis to find all TNs live at each
;;; block boundary.
(defun lifetime-flow-analysis (component)
- (loop
+ ;; KLUDGE: This is the second part of the FASTP kludge in
+ ;; propagate-live-tns: we pass fastp for ten first attempts,
+ ;; and then switch to the works-for-sure version.
+ ;;
+ ;; The upstream uses the fast version always, but sometimes
+ ;; that gets stuck in a loop...
+ (loop for i = 0 then (1+ i)
+ do
(reset-current-conflict component)
(let ((did-something nil))
(do-blocks-backwards (block component)
- (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))))
-
- (dolist (b (block-succ block))
- (when (and (block-start b)
- (propagate-live-tns last (block-info b)))
- (setq did-something t)))
-
- (do ((b (ir2-block-prev last) (ir2-block-prev b))
- (prev last b))
- ((not (eq (ir2-block-block b) block)))
- (when (propagate-live-tns b prev)
- (setq did-something t)))))
+ (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))))
+
+ (dolist (b (block-succ block))
+ (when (and (block-start b)
+ (propagate-live-tns last (block-info b) (< i 10)))
+ (setq did-something t)))
+
+ (do ((b (ir2-block-prev last) (ir2-block-prev b))
+ (prev last b))
+ ((not (eq (ir2-block-block b) block)))
+ (when (propagate-live-tns b prev (< i 10))
+ (setq did-something t)))))
(unless did-something (return))))
;;; number in the conflicts of all TNs in LIVE-LIST.
(defun note-conflicts (live-bits live-list tn num)
(declare (type tn tn) (type (or tn null) live-list)
- (type local-tn-bit-vector live-bits)
- (type local-tn-number num))
+ (type local-tn-bit-vector live-bits)
+ (type local-tn-number num))
(let ((lconf (tn-local-conflicts tn)))
(bit-ior live-bits lconf lconf))
(do ((live live-list (tn-next* live)))
(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))
+ ((null r))
(let ((tn (tn-ref-tn r)))
- (ecase (tn-kind tn)
- ((:normal :debug-environment)
- (setf (sbit live (tn-local-number tn)) 0))
- (:environment :component))))
+ (ecase (tn-kind tn)
+ ((:normal :debug-environment)
+ (setf (sbit live (tn-local-number tn)) 0))
+ (:environment :component))))
live))
;;; This is used to determine whether a :DEBUG-ENVIRONMENT TN should
;;; 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)))
+ (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)))))
+ (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-blockwise 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-physenv tn) (block-physenv 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))))))
+ (global-conflicts-next-blockwise 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-physenv tn) (cached-block-physenv 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))
(defun compute-initial-conflicts (block)
(declare (type ir2-block block))
(let* ((live-in (ir2-block-live-in block))
- (ltns (ir2-block-local-tns block))
- (live-bits (bit-vector-copy live-in))
- (live-list nil))
+ (ltns (ir2-block-local-tns block))
+ (live-bits (bit-vector-copy live-in))
+ (live-list nil))
(do ((conf (ir2-block-global-tns block)
- (global-conflicts-next-blockwise conf)))
- ((null conf))
+ (global-conflicts-next-blockwise conf)))
+ ((null conf))
(let ((bits (global-conflicts-conflicts conf))
- (tn (global-conflicts-tn conf))
- (num (global-conflicts-number conf))
- (kind (global-conflicts-kind conf)))
- (setf (tn-local-number tn) num)
- (unless (eq kind :live)
- (cond ((not (zerop (sbit live-bits num)))
- (bit-vector-replace bits live-bits)
- (setf (sbit bits num) 0)
- (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))))
+ (tn (global-conflicts-tn conf))
+ (num (global-conflicts-number conf))
+ (kind (global-conflicts-kind conf)))
+ (setf (tn-local-number tn) num)
+ (unless (eq kind :live)
+ (cond ((not (zerop (sbit live-bits num)))
+ (bit-vector-replace bits live-bits)
+ (setf (sbit bits num) 0)
+ (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))))
(make-debug-environment-tns-live block live-bits live-list)))
;;; force all the live TNs to be stack environment TNs.
(defun conflictize-save-p-vop (vop block live-bits)
(declare (type vop vop) (type ir2-block block)
- (type local-tn-bit-vector live-bits))
+ (type local-tn-bit-vector live-bits))
(let ((ss (compute-save-set vop live-bits)))
(setf (vop-save-set vop) ss)
(when (eq (vop-info-save-p (vop-info vop)) :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-physenv (ir2-block-block block))))))))
+ (unless (eq (tn-kind tn) :component)
+ (force-tn-to-stack tn)
+ (unless (eq (tn-kind tn) :environment)
+ (convert-to-environment-tn
+ tn
+ (cached-block-physenv (ir2-block-block block))))))))
(values))
;;; FIXME: The next 3 macros aren't needed in the target runtime.
`(when (eq (svref ltns num) :more)
(let ((prev ref))
(do ((mref (tn-ref-next-ref ref) (tn-ref-next-ref mref)))
- ((null mref))
- (let ((mtn (tn-ref-tn mref)))
- (unless (eql (tn-local-number mtn) num)
- (return))
- ,action)
- (setq prev mref))
+ ((null mref))
+ (let ((mtn (tn-ref-tn mref)))
+ (unless (eql (tn-local-number mtn) num)
+ (return))
+ ,action)
+ (setq prev mref))
(setq ref prev))))
;;; Handle the part of CONFLICT-ANALYZE-1-BLOCK that scans the REFs
'(do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
((null ref))
(let* ((tn (tn-ref-tn ref))
- (num (tn-local-number tn)))
+ (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)
- (frob-more-tns (deletef-in tn-next* live-list mtn))))
- (t
- (aver (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)
- (frob-more-tns (push-in tn-next* mtn live-list)))))))
+ ((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)
+ (frob-more-tns (deletef-in tn-next* live-list mtn))))
+ (t
+ (aver (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)
+ (frob-more-tns (push-in tn-next* mtn live-list)))))))
;;; This macro is called by CONFLICT-ANALYZE-1-BLOCK to scan the
;;; current VOP's results, and make any dead ones live. This is
'(do ((res (vop-results vop) (tn-ref-across res)))
((null res))
(let* ((tn (tn-ref-tn res))
- (num (tn-local-number tn)))
+ (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))))))
+ (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))))))
;;; Compute the block-local conflict information for BLOCK. We iterate
;;; over all the TN-REFs in a block in reference order, maintaining
(compute-initial-conflicts block)
(let ((ltns (ir2-block-local-tns block)))
(do ((vop (ir2-block-last-vop block)
- (vop-prev vop)))
- ((null vop))
- (when (vop-info-save-p (vop-info vop))
- (conflictize-save-p-vop vop block live-bits))
- (ensure-results-live)
- (scan-vop-refs)))))
+ (vop-prev vop)))
+ ((null vop))
+ (when (vop-info-save-p (vop-info vop))
+ (conflictize-save-p-vop vop block live-bits))
+ (ensure-results-live)
+ (scan-vop-refs)))))
;;; Conflict analyze each block, and also add it.
(defun lifetime-post-pass (component)
(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)))
+ (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-number oconf) nil))
(t
(unless (eq kind okind)
- (setf (global-conflicts-kind oconf) :read))
+ (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)
+ (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-blockwise 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)))))))
+ (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-blockwise 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-blockwise
- (ir2-block-global-tns block)
- conf))
+ (ir2-block-global-tns block)
+ conf))
(values))
(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)))
+ (block (global-conflicts-block conf)))
(deletef-in global-conflicts-next-blockwise
- (ir2-block-global-tns block)
- conf)
+ (ir2-block-global-tns block)
+ conf)
(setf (global-conflicts-next-blockwise conf) nil)
(insert-block-global-conflict conf block)
(when ltn-num
(defun ensure-global-tn (tn)
(declare (type tn tn))
(cond ((tn-global-conflicts tn))
- ((tn-local tn)
- (convert-to-global tn)
- (bit-ior (global-conflicts-conflicts (tn-global-conflicts tn))
- (tn-local-conflicts tn)
- t))
- (t
- (aver (and (null (tn-reads tn)) (null (tn-writes tn))))))
+ ((tn-local tn)
+ (convert-to-global tn)
+ (bit-ior (global-conflicts-conflicts (tn-global-conflicts tn))
+ (tn-local-conflicts tn)
+ t))
+ (t
+ (aver (and (null (tn-reads tn)) (null (tn-writes tn))))))
(values))
;;; For each :ALIAS TN, destructively merge the conflict info into the
(defun merge-alias-conflicts (component)
(declare (type component component))
(do ((tn (ir2-component-alias-tns (component-info component))
- (tn-next tn)))
+ (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
- (unless oconf
- (if oprev
- (setf (global-conflicts-next-tnwise oprev) conf)
- (setf (tn-global-conflicts original) conf))
- (do ((current conf (global-conflicts-next-tnwise current)))
- ((null current))
- (change-global-conflicts-tn current original))
- (return))
- (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-next-tnwise oconf)))
- ((> onum num)
- (if oprev
- (setf (global-conflicts-next-tnwise oprev) conf)
- (setf (tn-global-conflicts original) conf))
- (change-global-conflicts-tn conf original)
- (shiftf oprev
- conf
- (global-conflicts-next-tnwise conf)
- oconf))
- (t
- (merge-alias-block-conflicts conf oconf)
- (shiftf oprev oconf (global-conflicts-next-tnwise oconf))
- (setf conf (global-conflicts-next-tnwise conf)))))
- (unless conf (return))))
+ (oconf (tn-global-conflicts original))
+ (oprev nil))
+ (loop
+ (unless oconf
+ (if oprev
+ (setf (global-conflicts-next-tnwise oprev) conf)
+ (setf (tn-global-conflicts original) conf))
+ (do ((current conf (global-conflicts-next-tnwise current)))
+ ((null current))
+ (change-global-conflicts-tn current original))
+ (return))
+ (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-next-tnwise oconf)))
+ ((> onum num)
+ (if oprev
+ (setf (global-conflicts-next-tnwise oprev) conf)
+ (setf (tn-global-conflicts original) conf))
+ (change-global-conflicts-tn conf original)
+ (shiftf oprev
+ conf
+ (global-conflicts-next-tnwise conf)
+ oconf))
+ (t
+ (merge-alias-block-conflicts conf oconf)
+ (shiftf oprev oconf (global-conflicts-next-tnwise oconf))
+ (setf conf (global-conflicts-next-tnwise conf)))))
+ (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)))
+ (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)))
(values))
+
+;;; On high debug levels, for all variables that a lambda closes over
+;;; convert the TNs to :ENVIRONMENT TNs (in the physical environment
+;;; of that lambda). This way the debugger can display the variables.
+(defun maybe-environmentalize-closure-tns (component)
+ (dolist (lambda (component-lambdas component))
+ (when (policy lambda (>= debug 2))
+ (let ((physenv (lambda-physenv lambda)))
+ (dolist (closure-var (physenv-closure physenv))
+ (let ((tn (find-in-physenv closure-var physenv)))
+ (when (member (tn-kind tn) '(:normal :debug-environment))
+ (convert-to-environment-tn tn physenv))))))))
+
\f
(defun lifetime-analyze (component)
(lifetime-pre-pass component)
+ (maybe-environmentalize-closure-tns component)
(setup-environment-live-conflicts component)
(lifetime-flow-analysis component)
(lifetime-post-pass component)
(defun tns-conflict-local-global (x y)
(let ((block (tn-local x)))
(do ((conf (ir2-block-global-tns block)
- (global-conflicts-next-blockwise conf)))
- ((null conf) nil)
+ (global-conflicts-next-blockwise conf)))
+ ((null conf) nil)
(when (eq (global-conflicts-tn conf) y)
- (let ((num (global-conflicts-number conf)))
- (return (or (not num)
- (not (zerop (sbit (tn-local-conflicts x)
- num))))))))))
+ (let ((num (global-conflicts-number conf)))
+ (return (or (not num)
+ (not (zerop (sbit (tn-local-conflicts x)
+ num))))))))))
;;; Test for conflict between two global TNs X and Y.
(defun tns-conflict-global-global (x y)
(declare (type tn x y))
(let* ((x-conf (tn-global-conflicts x))
- (x-num (ir2-block-number (global-conflicts-block x-conf)))
- (y-conf (tn-global-conflicts y))
- (y-num (ir2-block-number (global-conflicts-block y-conf))))
+ (x-num (ir2-block-number (global-conflicts-block x-conf)))
+ (y-conf (tn-global-conflicts y))
+ (y-num (ir2-block-number (global-conflicts-block y-conf))))
(macrolet ((advance (n c)
- `(progn
- (setq ,c (global-conflicts-next-tnwise ,c))
- (unless ,c (return-from tns-conflict-global-global nil))
- (setq ,n (ir2-block-number (global-conflicts-block ,c)))))
- (scan (g l lc)
- `(do ()
- ((>= ,g ,l))
- (advance ,l ,lc))))
+ `(progn
+ (setq ,c (global-conflicts-next-tnwise ,c))
+ (unless ,c (return-from tns-conflict-global-global nil))
+ (setq ,n (ir2-block-number (global-conflicts-block ,c)))))
+ (scan (g l lc)
+ `(do ()
+ ((>= ,l ,g))
+ (advance ,l ,lc))))
(loop
- ;; x-conf, y-conf true, x-num, y-num corresponding block numbers.
- (scan x-num y-num y-conf)
- (scan y-num x-num x-conf)
- (when (= x-num y-num)
- (let ((ltn-num-x (global-conflicts-number x-conf)))
- (unless (and ltn-num-x
- (global-conflicts-number y-conf)
- (zerop (sbit (global-conflicts-conflicts y-conf)
- ltn-num-x)))
- (return t))
- (advance x-num x-conf)
- (advance y-num y-conf)))))))
+ ;; x-conf, y-conf true, x-num, y-num corresponding block numbers.
+ (scan x-num y-num y-conf)
+ (scan y-num x-num x-conf)
+ (when (= x-num y-num)
+ (let ((ltn-num-x (global-conflicts-number x-conf)))
+ (unless (and ltn-num-x
+ (global-conflicts-number y-conf)
+ (zerop (sbit (global-conflicts-conflicts y-conf)
+ ltn-num-x)))
+ (return t))
+ (advance x-num x-conf)
+ (advance y-num y-conf)))))))
;;; Return true if X and Y are distinct and the lifetimes of X and Y
;;; overlap at any point.
(defun tns-conflict (x y)
(declare (type tn x y))
(let ((x-kind (tn-kind x))
- (y-kind (tn-kind y)))
+ (y-kind (tn-kind y)))
(cond ((eq x y) nil)
- ((or (eq x-kind :component) (eq y-kind :component)) t)
- ((tn-global-conflicts x)
- (if (tn-global-conflicts y)
- (tns-conflict-global-global x y)
- (tns-conflict-local-global y x)))
- ((tn-global-conflicts y)
- (tns-conflict-local-global x y))
- (t
- (and (eq (tn-local x) (tn-local y))
- (not (zerop (sbit (tn-local-conflicts x)
- (tn-local-number y)))))))))
+ ((or (eq x-kind :component) (eq y-kind :component)) t)
+ ((tn-global-conflicts x)
+ (if (tn-global-conflicts y)
+ (tns-conflict-global-global x y)
+ (tns-conflict-local-global y x)))
+ ((tn-global-conflicts y)
+ (tns-conflict-local-global x y))
+ (t
+ (and (eq (tn-local x) (tn-local y))
+ (not (zerop (sbit (tn-local-conflicts x)
+ (tn-local-number y)))))))))
projects / sbcl.git / blobdiff