1.0.18.5: ADJOIN with constant NIL as second argument

[sbcl.git] / src / compiler / life.lisp

diff --git a/src/compiler/life.lisp b/src/compiler/life.lisp
index 6502bc2..6a89ee3 100644 (file)
--- 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)))
 \f
 ;;;; pre-pass
 
@@ -415,7 +429,7 @@
     (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))
@@ -514,10 +528,10 @@
                   (setf (svref (ir2-block-local-tns block1)
                                (global-conflicts-number current))
                         nil)
-                  (setf (global-conflicts-number current) nil)
-                  (setf (tn-current-conflict tn) current))
+                  (setf (global-conflicts-number current) nil))
                  (t
                   (setf (sbit live-in (global-conflicts-number current)) 1)))
+               (setf (tn-current-conflict tn) current)
                (return)))))
         (:write)))
     did-something))
@@ -614,7 +628,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 +700,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 +948,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))))))))
+
 \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)