X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fpack.lisp;h=a03d156fb42eb85478f6ebd04ba9c9ed34ba51b1;hb=cf4cb9554515c59eddbde38d1cf236339c37f55f;hp=e45542530d81d5ff17ff681f0e268386b590ac90;hpb=34dd23563d2f5cf05c72b971da0d0b065a09bf2a;p=sbcl.git

diff --git a/src/compiler/pack.lisp b/src/compiler/pack.lisp
index e455425..a03d156 100644
--- a/src/compiler/pack.lisp
+++ b/src/compiler/pack.lisp
@@ -26,12 +26,12 @@
 
 ;;; Return true if the element at the specified offset in SB has a
 ;;; conflict with TN:
-;;; -- If a component-live TN (:component kind), then iterate over
-;;;    all the blocks. If the element at Offset is used anywhere in
+;;; -- If a component-live TN (:COMPONENT kind), then iterate over
+;;;    all the blocks. If the element at OFFSET is used anywhere in
 ;;;    any of the component's blocks (always-live /= 0), then there
 ;;;    is a conflict.
 ;;; -- If TN is global (Confs true), then iterate over the blocks TN
-;;;    is live in (using TN-Global-Conflicts). If the TN is live
+;;;    is live in (using TN-GLOBAL-CONFLICTS). If the TN is live
 ;;;    everywhere in the block (:LIVE), then there is a conflict
 ;;;    if the element at offset is used anywhere in the block
 ;;;    (Always-Live /= 0). Otherwise, we use the local TN number for
@@ -52,7 +52,7 @@
      (confs
       (let ((loc-confs (svref (finite-sb-conflicts sb) offset))
 	    (loc-live (svref (finite-sb-always-live sb) offset)))
-	(do ((conf confs (global-conflicts-tn-next conf)))
+	(do ((conf confs (global-conflicts-next-tnwise conf)))
 	    ((null conf)
 	     nil)
 	  (let* ((block (global-conflicts-block conf))
@@ -104,12 +104,12 @@
 	     (loc-live (svref (finite-sb-always-live sb) this-offset)))
 	(cond
 	 ((eq kind :component)
-	  (dotimes (num (ir2-block-count *component-being-compiled*) nil)
+	  (dotimes (num (ir2-block-count *component-being-compiled*))
 	    (declare (type index num))
 	    (setf (sbit loc-live num) 1)
 	    (set-bit-vector (svref loc-confs num))))
 	 (confs
-	  (do ((conf confs (global-conflicts-tn-next conf)))
+	  (do ((conf confs (global-conflicts-next-tnwise conf)))
 	      ((null conf))
 	    (let* ((block (global-conflicts-block conf))
 		   (num (ir2-block-number block))
@@ -241,40 +241,6 @@
     (setf (finite-sb-current-size sb) new-size))
   (values))
 
-;;; This variable is true whenever we are in pack (and thus the per-SB
-;;; conflicts information is in use.)
-(defvar *in-pack* nil)
-
-;;; In order to prevent the conflict data structures from growing
-;;; arbitrarily large, we clear them whenever a GC happens and we
-;;; aren't currently in pack. We revert to the initial number of
-;;; locations and 0 blocks.
-(defun pack-before-gc-hook ()
-  (unless *in-pack*
-    (dolist (sb *backend-sb-list*)
-      (unless (eq (sb-kind sb) :non-packed)
-	(let ((size (sb-size sb)))
-	  (fill nil (finite-sb-always-live sb))
-	  (setf (finite-sb-always-live sb)
-		(make-array size
-			    :initial-element
-			    #-sb-xc #*
-			    ;; The cross-compiler isn't very good at
-			    ;; dumping specialized arrays, so we delay
-			    ;; construction of this SIMPLE-BIT-VECTOR
-			    ;; until runtime.
-			    #+sb-xc (make-array 0 :element-type 'bit)))
-
-	  (fill nil (finite-sb-conflicts sb))
-	  (setf (finite-sb-conflicts sb)
-		(make-array size :initial-element '#()))
-
-	  (fill nil (finite-sb-live-tns sb))
-	  (setf (finite-sb-live-tns sb)
-		(make-array size :initial-element nil))))))
-  (values))
-
-(pushnew 'pack-before-gc-hook sb!ext:*before-gc-hooks*)
 
 ;;;; internal errors
 
@@ -590,8 +556,8 @@
 ;;;; optimized saving
 
 ;;; Save TN if it isn't a single-writer TN that has already been
-;;; saved. If multi-write, we insert the save Before the specified
-;;; VOP. Context is a VOP used to tell which node/block to use for the
+;;; saved. If multi-write, we insert the save BEFORE the specified
+;;; VOP. CONTEXT is a VOP used to tell which node/block to use for the
 ;;; new VOP.
 (defun save-if-necessary (tn before context)
   (declare (type tn tn) (type (or vop null) before) (type vop context))
@@ -606,7 +572,7 @@
   (values))
 
 ;;; Load the TN from its save location, allocating one if necessary.
-;;; The load is inserted Before the specifier VOP. Context is a VOP
+;;; The load is inserted BEFORE the specifier VOP. CONTEXT is a VOP
 ;;; used to tell which node/block to use for the new VOP.
 (defun restore-tn (tn before context)
   (declare (type tn tn) (type (or vop null) before) (type vop context))
@@ -805,7 +771,7 @@
 (defvar *repack-blocks*)
 (declaim (type (or hash-table null) *repack-blocks*))
 
-;;; Set the Live-TNs vectors in all :FINITE SBs to represent the TNs
+;;; Set the LIVE-TNS vectors in all :FINITE SBs to represent the TNs
 ;;; live at the end of BLOCK.
 (defun init-live-tns (block)
   (dolist (sb *backend-sb-list*)
@@ -1448,85 +1414,124 @@
 
 (defevent repack-block "Repacked a block due to TN unpacking.")
 
-(defun pack (component)
-  (aver (not *in-pack*))
-  (let ((*in-pack* t)
-	(optimize (policy *lexenv*
-			  (or (>= speed compilation-speed)
-			      (>= space compilation-speed))))
-	(2comp (component-info component)))
-    (init-sb-vectors component)
-
-    ;; Call the target functions.
-    (do-ir2-blocks (block component)
-      (do ((vop (ir2-block-start-vop block) (vop-next vop)))
-	  ((null vop))
-	(let ((target-fun (vop-info-target-fun (vop-info vop))))
-	  (when target-fun
-	    (funcall target-fun vop)))))
-
-
-    ;; Pack wired TNs first.
-    (do ((tn (ir2-component-wired-tns 2comp) (tn-next tn)))
-	((null tn))
-      (pack-wired-tn tn))
-
-    ;; Pack restricted component TNs.
-    (do ((tn (ir2-component-restricted-tns 2comp) (tn-next tn)))
-	((null tn))
-      (when (eq (tn-kind tn) :component)
-	(pack-tn tn t)))
-
-    ;; Pack other restricted TNs.
-    (do ((tn (ir2-component-restricted-tns 2comp) (tn-next tn)))
-	((null tn))
-      (unless (tn-offset tn)
-	(pack-tn tn t)))
-
-    ;; Assign costs to normal TNs so we know which ones should always
-    ;; be packed on the stack.
-    (when (and optimize *pack-assign-costs*)
-      (assign-tn-costs component))
-
-    ;; Pack normal TNs in the order that they appear in the code. This
-    ;; should have some tendency to pack important TNs first, since
-    ;; control analysis favors the drop-through. This should also help
-    ;; targeting, since we will pack the target TN soon after we
-    ;; determine the location of the targeting TN.
-    (do-ir2-blocks (block component)
-      (let ((ltns (ir2-block-local-tns block)))
-	(do ((i (1- (ir2-block-local-tn-count block)) (1- i)))
-	    ((minusp i))
-	  (declare (fixnum i))
-	  (let ((tn (svref ltns i)))
-	    (unless (or (null tn) (eq tn :more) (tn-offset tn))
-	      (pack-tn tn nil))))))
-
-    ;; Pack any leftover normal TNs. This is to deal with :MORE TNs,
-    ;; which could possibly not appear in any local TN map.
-    (do ((tn (ir2-component-normal-tns 2comp) (tn-next tn)))
-	((null tn))
-      (unless (tn-offset tn)
-	(pack-tn tn nil)))
-
-    ;; Do load TN packing and emit saves.
-    (let ((*repack-blocks* nil))
-      (cond ((and optimize *pack-optimize-saves*)
-	     (optimized-emit-saves component)
-	     (do-ir2-blocks (block component)
-	       (pack-load-tns block)))
-	    (t
-	     (do-ir2-blocks (block component)
-	       (emit-saves block)
-	       (pack-load-tns block))))
-      (when *repack-blocks*
-	(loop
-	  (when (zerop (hash-table-count *repack-blocks*)) (return))
-	  (maphash (lambda (block v)
-		     (declare (ignore v))
-		     (remhash block *repack-blocks*)
-		     (event repack-block)
-		     (pack-load-tns block))
-		   *repack-blocks*)))))
+;;; KLUDGE: Prior to SBCL version 0.8.9.xx, this function was known as
+;;; PACK-BEFORE-GC-HOOK, but was non-functional since approximately
+;;; version 0.8.3.xx since the removal of GC hooks from the system.
+;;; This currently (as of 2004-04-12) runs now after every call to
+;;; PACK, rather than -- as was originally intended -- once per GC
+;;; cycle; this is probably non-optimal, and might require tuning,
+;;; maybe to be called when the data structures exceed a certain size,
+;;; or maybe once every N times.  The KLUDGE is that this rewrite has
+;;; done nothing to improve the reentrance or threadsafety of the
+;;; compiler; it still fails to be callable from several threads at
+;;; the same time.
+;;;
+;;; Brief experiments indicate that during a compilation cycle this
+;;; causes about 10% more consing, and takes about 1%-2% more time.
+;;;
+;;; -- CSR, 2004-04-12
+(defun clean-up-pack-structures ()
+  (dolist (sb *backend-sb-list*)
+    (unless (eq (sb-kind sb) :non-packed)
+      (let ((size (sb-size sb)))
+	(fill (finite-sb-always-live sb) nil)
+	(setf (finite-sb-always-live sb)
+	      (make-array size
+			  :initial-element
+			  #-sb-xc #*
+			  ;; The cross-compiler isn't very good at
+			  ;; dumping specialized arrays, so we delay
+			  ;; construction of this SIMPLE-BIT-VECTOR
+			  ;; until runtime.
+			  #+sb-xc (make-array 0 :element-type 'bit)))
+	
+	(fill (finite-sb-conflicts sb) nil)
+	(setf (finite-sb-conflicts sb)
+	      (make-array size :initial-element '#()))
+	
+	(fill (finite-sb-live-tns sb) nil)
+	(setf (finite-sb-live-tns sb)
+	      (make-array size :initial-element nil))))))
 
-  (values))
+(defun pack (component)
+  (unwind-protect
+       (let ((optimize (policy *lexenv*
+			       (or (>= speed compilation-speed)
+				   (>= space compilation-speed))))
+	     (2comp (component-info component)))
+	 (init-sb-vectors component)
+	 
+	 ;; Call the target functions.
+	 (do-ir2-blocks (block component)
+	   (do ((vop (ir2-block-start-vop block) (vop-next vop)))
+	       ((null vop))
+	     (let ((target-fun (vop-info-target-fun (vop-info vop))))
+	       (when target-fun
+		 (funcall target-fun vop)))))
+	 
+	 
+	 ;; Pack wired TNs first.
+	 (do ((tn (ir2-component-wired-tns 2comp) (tn-next tn)))
+	     ((null tn))
+	   (pack-wired-tn tn))
+	 
+	 ;; Pack restricted component TNs.
+	 (do ((tn (ir2-component-restricted-tns 2comp) (tn-next tn)))
+	     ((null tn))
+	   (when (eq (tn-kind tn) :component)
+	     (pack-tn tn t)))
+	 
+	 ;; Pack other restricted TNs.
+	 (do ((tn (ir2-component-restricted-tns 2comp) (tn-next tn)))
+	     ((null tn))
+	   (unless (tn-offset tn)
+	     (pack-tn tn t)))
+	 
+	 ;; Assign costs to normal TNs so we know which ones should always
+	 ;; be packed on the stack.
+	 (when (and optimize *pack-assign-costs*)
+	   (assign-tn-costs component))
+	 
+	 ;; Pack normal TNs in the order that they appear in the code. This
+	 ;; should have some tendency to pack important TNs first, since
+	 ;; control analysis favors the drop-through. This should also help
+	 ;; targeting, since we will pack the target TN soon after we
+	 ;; determine the location of the targeting TN.
+	 (do-ir2-blocks (block component)
+	   (let ((ltns (ir2-block-local-tns block)))
+	     (do ((i (1- (ir2-block-local-tn-count block)) (1- i)))
+		 ((minusp i))
+	       (declare (fixnum i))
+	       (let ((tn (svref ltns i)))
+		 (unless (or (null tn) (eq tn :more) (tn-offset tn))
+		   (pack-tn tn nil))))))
+	 
+	 ;; Pack any leftover normal TNs. This is to deal with :MORE TNs,
+	 ;; which could possibly not appear in any local TN map.
+	 (do ((tn (ir2-component-normal-tns 2comp) (tn-next tn)))
+	     ((null tn))
+	   (unless (tn-offset tn)
+	     (pack-tn tn nil)))
+	 
+	 ;; Do load TN packing and emit saves.
+	 (let ((*repack-blocks* nil))
+	   (cond ((and optimize *pack-optimize-saves*)
+		  (optimized-emit-saves component)
+		  (do-ir2-blocks (block component)
+		    (pack-load-tns block)))
+		 (t
+		  (do-ir2-blocks (block component)
+		    (emit-saves block)
+		    (pack-load-tns block))))
+	   (when *repack-blocks*
+	     (loop
+	      (when (zerop (hash-table-count *repack-blocks*)) (return))
+	      (maphash (lambda (block v)
+			 (declare (ignore v))
+			 (remhash block *repack-blocks*)
+			 (event repack-block)
+			 (pack-load-tns block))
+		       *repack-blocks*))))
+	 
+	 (values))
+    (clean-up-pack-structures)))