From: Christophe Rhodes <csr21@cam.ac.uk>
Date: Thu, 15 Apr 2004 13:30:07 +0000 (+0000)
Subject: 0.8.9.46:
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=6a9bbe6f36179cee92001a1f9ed5ff38be512644;p=sbcl.git

0.8.9.46:
	deKLUDGE the solution for PACK-BEFORE-GC-HOOK
	... well, not completely.  PACK remains non-reentrant and
		non-threadsafe, but at least now global data structures
		don't grow without bounds;
	... mostly whitespace changes, but clear the PACK structures
		after every call, not once per GC cycle.  Marginally
		less efficient, I fear :-(
	... while we're at it, fix analogously VOP-TN-REFS, and while
		we're at it, document that a special is a bit of an
		odd way to implement a (non-reentrant non-threadsafe)
		closure.
	... only one BEFORE-GC-HOOK left.
---

diff --git a/make-target-2.sh b/make-target-2.sh
index a5ee9fa..fb1c8c1 100644
--- a/make-target-2.sh
+++ b/make-target-2.sh
@@ -65,7 +65,6 @@ echo //doing warm init
 	;; (GC :FULL T gets us down to about 38 Mbytes, but PURIFY
 	;; gets us down to about 19 Mbytes.)
 	(sb-int:/show "done with warm.lisp, about to GC :FULL T")
-	(sb-c::pack-before-gc-hook) ; KLUDGE
 	(gc :full t)
 
         ;; resetting compilation policy to neutral values in
diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp
index 67ac123..1af1fbd 100644
--- a/src/compiler/main.lisp
+++ b/src/compiler/main.lisp
@@ -612,13 +612,7 @@
     (setq *tn-id* 0)
     (clrhash *label-ids*)
     (clrhash *id-labels*)
-    (setq *label-id* 0)
-
-    ;; Clear some PACK data structures (for GC purposes only).
-    (aver (not *in-pack*))
-    (dolist (sb *backend-sb-list*)
-      (when (finite-sb-p sb)
-	(fill (finite-sb-live-tns sb) nil))))
+    (setq *label-id* 0))
 
   ;; (Note: The CMU CL code used to set CL::*GENSYM-COUNTER* to zero here.
   ;; Superficially, this seemed harmful -- the user could reasonably be
diff --git a/src/compiler/pack.lisp b/src/compiler/pack.lisp
index 5057a72..a03d156 100644
--- a/src/compiler/pack.lisp
+++ b/src/compiler/pack.lisp
@@ -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 (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))
-
-(pushnew 'pack-before-gc-hook sb!ext:*before-gc-hooks*)
 
 ;;;; internal errors
 
@@ -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)))
diff --git a/src/compiler/vmdef.lisp b/src/compiler/vmdef.lisp
index 3b6fb42..5464a85 100644
--- a/src/compiler/vmdef.lisp
+++ b/src/compiler/vmdef.lisp
@@ -104,14 +104,13 @@
   ;; See also the description of VOP-INFO-TARGETS. -- APD, 2002-01-30
   (def!constant max-vop-tn-refs 256))
 
+;;; FIXME: This is a remarkably eccentric way of implementing what
+;;; would appear to be by nature a closure.  A closure isn't any more
+;;; threadsafe than this special variable implementation, but at least
+;;; it's more idiomatic, and one could imagine closing over an
+;;; extensible pool to make a thread-safe implementation.
+(declaim (type (simple-vector #.max-vop-tn-refs) *vop-tn-refs*))
 (defvar *vop-tn-refs* (make-array max-vop-tn-refs :initial-element nil))
-(defvar *using-vop-tn-refs* nil)
-
-(defun flush-vop-tn-refs ()
-  (unless *using-vop-tn-refs*
-    (fill *vop-tn-refs* nil)))
-
-(pushnew 'flush-vop-tn-refs *before-gc-hooks*)
 
 (def!constant sc-bits (integer-length (1- sc-number-limit)))
 
@@ -131,61 +130,64 @@
 		   num-args num-results num-operands)
 	     (type (integer -1 #.(1- max-vop-tn-refs)) last-arg last-result))
     (setf (vop-codegen-info vop) info)
-    (let ((refs *vop-tn-refs*)
-	  (*using-vop-tn-refs* t))
-      (declare (type (simple-vector #.max-vop-tn-refs) refs))
-      (do ((index 0 (1+ index))
-	   (ref args (and ref (tn-ref-across ref))))
-	  ((= index num-args))
-	(setf (svref refs index) ref))
-      (do ((index num-args (1+ index))
-	   (ref results (and ref (tn-ref-across ref))))
-	  ((= index num-operands))
-	(setf (svref refs index) ref))
-      (let ((temps (vop-info-temps template)))
-	(when temps
-	  (let ((index num-operands)
-		(prev nil))
-	    (dotimes (i (length temps))
-	      (let* ((temp (aref temps i))
-		     (tn (if (logbitp 0 temp)
-			     (make-wired-tn nil
-					    (ldb (byte sc-bits 1) temp)
-					    (ash temp (- (1+ sc-bits))))
-			     (make-restricted-tn nil (ash temp -1))))
-		     (write-ref (reference-tn tn t)))
-                ;; KLUDGE: These formulas must be consistent with those in
-                ;; COMPUTE-REF-ORDERING, and this is currently
-		;; maintained by hand. -- WHN 2002-01-30, paraphrasing APD
-		(setf (aref refs index) (reference-tn tn nil))
-		(setf (aref refs (1+ index)) write-ref)
-		(if prev
-		    (setf (tn-ref-across prev) write-ref)
-		    (setf (vop-temps vop) write-ref))
-		(setf prev write-ref)
-		(incf index 2))))))
-      (let ((prev nil))
-	(flet ((add-ref (ref)
-		 (setf (tn-ref-vop ref) vop)
-		 (setf (tn-ref-next-ref ref) prev)
-		 (setf prev ref)))
-	  (declare (inline add-ref))
-	  (dotimes (i (length ref-ordering))
-	    (let* ((index (aref ref-ordering i))
-		   (ref (aref refs index)))
-	      (if (or (= index last-arg) (= index last-result))
-		  (do ((ref ref (tn-ref-across ref)))
-		      ((null ref))
-		    (add-ref ref))
-		  (add-ref ref)))))
-	(setf (vop-refs vop) prev))
-      (let ((targets (vop-info-targets template)))
-	(when targets
-	  (dotimes (i (length targets))
-	    (let ((target (aref targets i)))
-	      (target-if-desirable (aref refs (ldb (byte 8 8) target))
-				   (aref refs (ldb (byte 8 0) target))))))))
-    (values vop vop)))
+    (unwind-protect
+	 (let ((refs *vop-tn-refs*))
+	   (declare (type (simple-vector #.max-vop-tn-refs) refs))
+	   (do ((index 0 (1+ index))
+		(ref args (and ref (tn-ref-across ref))))
+	       ((= index num-args))
+	     (setf (svref refs index) ref))
+	   (do ((index num-args (1+ index))
+		(ref results (and ref (tn-ref-across ref))))
+	       ((= index num-operands))
+	     (setf (svref refs index) ref))
+	   (let ((temps (vop-info-temps template)))
+	     (when temps
+	       (let ((index num-operands)
+		     (prev nil))
+		 (dotimes (i (length temps))
+		   (let* ((temp (aref temps i))
+			  (tn (if (logbitp 0 temp)
+				  (make-wired-tn nil
+						 (ldb (byte sc-bits 1) temp)
+						 (ash temp (- (1+ sc-bits))))
+				  (make-restricted-tn nil (ash temp -1))))
+			  (write-ref (reference-tn tn t)))
+		     ;; KLUDGE: These formulas must be consistent with
+		     ;; those in COMPUTE-REF-ORDERING, and this is
+		     ;; currently maintained by hand. -- WHN
+		     ;; 2002-01-30, paraphrasing APD
+		     (setf (aref refs index) (reference-tn tn nil))
+		     (setf (aref refs (1+ index)) write-ref)
+		     (if prev
+			 (setf (tn-ref-across prev) write-ref)
+			 (setf (vop-temps vop) write-ref))
+		     (setf prev write-ref)
+		     (incf index 2))))))
+	   (let ((prev nil))
+	     (flet ((add-ref (ref)
+		      (setf (tn-ref-vop ref) vop)
+		      (setf (tn-ref-next-ref ref) prev)
+		      (setf prev ref)))
+	       (declare (inline add-ref))
+	       (dotimes (i (length ref-ordering))
+		 (let* ((index (aref ref-ordering i))
+			(ref (aref refs index)))
+		   (if (or (= index last-arg) (= index last-result))
+		       (do ((ref ref (tn-ref-across ref)))
+			   ((null ref))
+			 (add-ref ref))
+		       (add-ref ref)))))
+	     (setf (vop-refs vop) prev))
+	   (let ((targets (vop-info-targets template)))
+	     (when targets
+	       (dotimes (i (length targets))
+		 (let ((target (aref targets i)))
+		   (target-if-desirable
+		    (aref refs (ldb (byte 8 8) target))
+		    (aref refs (ldb (byte 8 0) target)))))))
+	   (values vop vop))
+      (fill *vop-tn-refs* nil))))
 
 ;;;; function translation stuff
 
diff --git a/version.lisp-expr b/version.lisp-expr
index 0210465..365812f 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.9.45"
+"0.8.9.46"