(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
(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))
(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))
prev))))
(do ((b last (ir2-block-prev b)))
((not (eq (ir2-block-block b) block)))
- (setup-environment-tn-conflict tn b debug-p)))))
+ (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
;;; 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))
(global-conflicts-number current))
nil)
(setf (global-conflicts-number current) nil)
- (setf (tn-current-conflict tn) current))
+ (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)
(dolist (b (block-succ block))
(when (and (block-start b)
- (propagate-live-tns last (block-info 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)
+ (when (propagate-live-tns b prev (< i 10))
(setq did-something t)))))
(unless did-something (return))))
(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))
+ (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)
(unless (eq (tn-kind tn) :environment)
(convert-to-environment-tn
tn
- (block-physenv (ir2-block-block block))))))))
+ (cached-block-physenv (ir2-block-block block))))))))
(values))
;;; FIXME: The next 3 macros aren't needed in the target runtime.
(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)
(setq ,n (ir2-block-number (global-conflicts-block ,c)))))
(scan (g l lc)
`(do ()
- ((>= ,g ,l))
+ ((>= ,l ,g))
(advance ,l ,lc))))
(loop
projects / sbcl.git / blobdiff