X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Flife.lisp;h=9d28fbdfc5b92a30eb97e24f27bb8d37a35f022b;hb=8e4ec430504f0f563280be26034af590dff50d34;hp=8d81428ce7e195a85f9e32b0aef86c706c1c0147;hpb=631ecfcd29ecabd40c3bc5579496e635b30a142e;p=sbcl.git diff --git a/src/compiler/life.lisp b/src/compiler/life.lisp index 8d81428..9d28fbd 100644 --- a/src/compiler/life.lisp +++ b/src/compiler/life.lisp @@ -58,6 +58,20 @@ (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))) ;;;; pre-pass @@ -404,18 +418,38 @@ (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)) @@ -423,7 +457,15 @@ 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 @@ -485,7 +527,14 @@ ;;; 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)) @@ -514,10 +563,13 @@ (setf (svref (ir2-block-local-tns block1) (global-conflicts-number current)) nil) - (setf (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))) - (setf (tn-current-conflict tn) current) + (when fastp + (setf (tn-current-conflict tn) current)) (return))))) (:write))) did-something)) @@ -525,7 +577,14 @@ ;;; 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) @@ -537,13 +596,13 @@ (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)))) @@ -614,7 +673,7 @@ (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) @@ -686,7 +745,7 @@ (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. @@ -934,9 +993,23 @@ (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)))))))) + (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)