CMUCL commit: src (code/array.lisp lisp/gencgc.c)

Raymond Toy rtoy at common-lisp.net
Sat Dec 5 04:20:37 CET 2009


    Date: Friday, December 4, 2009 @ 22:20:37
  Author: rtoy
    Path: /project/cmucl/cvsroot/src

Modified: code/array.lisp lisp/gencgc.c

First cut at GCing static vectors, including static simple-arrays.
This is done by a simple mark-and-sweep GC of the static vectors.
When scavenging the spaces, we mark any static vectors by setting the
MSB of the header word.  After GC is done, an *after-gc-hooks*
function finds all of the static vectors that are not marked and frees
them.  For marked static vectors, we clear the mark bit.

code/array.lisp:
o Add *STATIC-VECTORS* to keep track of all static vectors that have
  been allocated.
o Update MAKE-ARRAY 
  - to allow generation of static simple unboxed arrays (1D arrays
    without an array header). 
  - Push a weak pointer to the static vector onto *STATIC-VECTORS*
o Add function FREE-STATIC-VECTOR
o Add function FINALIZE-STATIC-VECTORS to free static vectors when
  they are no longer referenced.

lisp/gencgc.c:
o Update scavenge to check for static vectors.  If we find a static
  vector, mark the static vector by setting the MSB of the header
  word.


-----------------+
 code/array.lisp |   90 ++++++++++++++++++++++++++++++---------
 lisp/gencgc.c   |  123 ++++++++++++++++++++++++++++++++++++++++++++++++++++--
 2 files changed, 188 insertions(+), 25 deletions(-)


Index: src/code/array.lisp
diff -u src/code/array.lisp:1.48 src/code/array.lisp:1.49
--- src/code/array.lisp:1.48	Tue Dec  1 09:14:59 2009
+++ src/code/array.lisp	Fri Dec  4 22:20:36 2009
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /project/cmucl/cvsroot/src/code/array.lisp,v 1.48 2009-12-01 14:14:59 rtoy Exp $")
+  "$Header: /project/cmucl/cvsroot/src/code/array.lisp,v 1.49 2009-12-05 03:20:36 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -158,6 +158,9 @@
     (bit #.vm:complex-bit-vector-type)
     (t #.vm:complex-vector-type)))
 
+(defvar *static-vectors* nil
+  "List of weak-pointers to static vectors.  Needed for GCing static vectors")
+
 (defun make-array (dimensions &key
 			      (element-type t)
 			      (initial-element nil initial-element-p)
@@ -194,8 +197,7 @@
 	 (static-array-p (eq allocation :malloc))
 	 (simple (and (null fill-pointer)
 		      (not adjustable)
-		      (null displaced-to)
-		      (not static-array-p))))
+		      (null displaced-to))))
     (declare (fixnum array-rank))
     (when (and displaced-index-offset (null displaced-to))
       (error "Can't specify :displaced-index-offset without :displaced-to"))
@@ -210,14 +212,19 @@
 	  (declare (type (unsigned-byte 8) type)
 		   (type (integer 1 256) bits))
 	  (let* ((length (car dimensions))
-		 (array (allocate-vector
-			 type
-			 length
-			 (ceiling (* (if (= type vm:simple-string-type)
-					 (1+ length)
-					 length)
-				     bits)
-				  vm:word-bits))))
+		 (array (if static-array-p
+			    (let ((v (make-static-vector length element-type)))
+			      (system::without-gcing
+			       (push (make-weak-pointer v) *static-vectors*))
+			      v)
+			    (allocate-vector
+			     type
+			     length
+			     (ceiling (* (if (= type vm:simple-string-type)
+					     (1+ length)
+					     length)
+					 bits)
+				      vm:word-bits)))))
 	    (declare (type index length))
 	    (when initial-element-p
 	      (fill array initial-element))
@@ -268,16 +275,9 @@
 	  (setf (%array-available-elements array) total-size)
 	  (setf (%array-data-vector array) data)
 	  (when static-array-p
-	    ;; Add finalizer to the static array to GC it when the array header is GCed.
-	    (finalize array #'(lambda ()
-				(let ((addr (logandc1 vm:lowtag-mask (kernel:get-lisp-obj-address data))))
-				  (format t "~&Freeing foreign vector at #x~X~%"
-					  addr)
-				  (alien:alien-funcall
-				   (alien:extern-alien "free"
-						       (function c-call:void
-								 sys:system-area-pointer))
-				   (sys:int-sap addr))))))
+	    ;; Add weak-pointer to static vector for GC support.
+	    (system:without-gcing
+	     (push (make-weak-pointer data) *static-vectors*)))
 	  (cond (displaced-to
 		 (when (or initial-element-p initial-contents-p)
 		   (error "Neither :initial-element nor :initial-contents ~
@@ -360,6 +360,54 @@
 				       (- (* 2 vm:word-bytes)))))
 	   (logbitp vm:type-bits header)))))
 
+(defun free-static-vector (vector)
+  (let ((addr (logandc1 vm:lowtag-mask (kernel:get-lisp-obj-address vector))))
+    (format t "~&Freeing foreign vector at #x~X~%"
+	    addr)
+    (alien:alien-funcall
+     (alien:extern-alien "free"
+			 (function c-call:void
+				   sys:system-area-pointer))
+     (sys:int-sap addr))))
+
+(defun finalize-static-vectors ()
+  ;; Run down the list of weak-pointers to static vectors.  Look at
+  ;; the static vector and see if vector is marked.  If so, clear the
+  ;; mark, and do nothing.  If the mark is not set, then the vector is
+  ;; free, so free it, and remove this weak-pointer from the list.
+  ;; The mark bit the MSB of the header word.  Look at scavenge in
+  ;; gencgc.c.
+  (when *static-vectors*
+    (let ((*print-array* nil))
+      (format t "Finalizing static vectors ~S~%" *static-vectors*))
+    (setf *static-vectors*
+	  (delete-if
+	   #'(lambda (wp)
+	       (let ((vector (weak-pointer-value wp)))
+		 (when vector
+		   (let* ((sap (sys:vector-sap vector))
+			  (header (sys:sap-ref-32 sap (* -2 vm:word-bytes))))
+		     (format t "static vector ~A.  header = ~X~%"
+			     vector header)
+		     (cond ((logbitp 31 header)
+			    ;; Clear mark
+			    (setf (sys:sap-ref-32 sap (* -2 vm:word-bytes))
+				  (logand header #x7fffffff))
+			    (let ((*print-array* nil))
+			      (format t "static vector ~A in use~%" vector))
+			    nil)
+			   (t
+			    ;; Mark was clear so free the vector
+			    (setf (weak-pointer-value wp) nil)
+			    (let ((*print-array* nil))
+			      (format t "Free static vector ~A~%" vector))
+			    (free-static-vector vector)
+			    t))))))
+	   *static-vectors*))))
+
+(pushnew 'finalize-static-vectors *after-gc-hooks*)
+
+
 ;;; DATA-VECTOR-FROM-INITS returns a simple vector that has the specified array
 ;;; characteristics.  Dimensions is only used to pass to FILL-DATA-VECTOR
 ;;; for error checking on the structure of initial-contents.
Index: src/lisp/gencgc.c
diff -u src/lisp/gencgc.c:1.101 src/lisp/gencgc.c:1.102
--- src/lisp/gencgc.c:1.101	Mon Nov  2 10:05:07 2009
+++ src/lisp/gencgc.c	Fri Dec  4 22:20:37 2009
@@ -7,7 +7,7 @@
  *
  * Douglas Crosher, 1996, 1997, 1998, 1999.
  *
- * $Header: /project/cmucl/cvsroot/src/lisp/gencgc.c,v 1.101 2009-11-02 15:05:07 rtoy Exp $
+ * $Header: /project/cmucl/cvsroot/src/lisp/gencgc.c,v 1.102 2009-12-05 03:20:37 rtoy Exp $
  *
  */
 
@@ -1950,6 +1950,58 @@
 	    (unsigned int) page_index / PAGE_SIZE) < dynamic_space_pages
 	&& PAGE_GENERATION(page_index) == new_space;
 }
+
+static inline boolean
+dynamic_space_p(lispobj obj)
+{
+    lispobj end = DYNAMIC_0_SPACE_START + DYNAMIC_SPACE_SIZE;
+
+    return (obj >= DYNAMIC_0_SPACE_START) && (obj < end);
+}
+
+static inline boolean
+static_space_p(lispobj obj)
+{
+    lispobj end = SymbolValue(STATIC_SPACE_FREE_POINTER);
+
+    return (obj >= STATIC_SPACE_START) && (obj < end);
+}
+
+static inline boolean
+read_only_space_p(lispobj obj)
+{
+    lispobj end = SymbolValue(READ_ONLY_SPACE_FREE_POINTER);
+
+    return (obj >= READ_ONLY_SPACE_START) && (obj < end);
+}
+
+static inline boolean
+control_stack_space_p(lispobj obj)
+{
+    lispobj end = CONTROL_STACK_START + CONTROL_STACK_SIZE;
+
+    return (obj >= CONTROL_STACK_START) && (obj < end);
+}
+
+static inline boolean
+binding_stack_space_p(lispobj obj)
+{
+    lispobj end = BINDING_STACK_START + BINDING_STACK_SIZE;
+
+    return (obj >= BINDING_STACK_START) && (obj < end);
+}
+    
+static inline boolean
+signal_space_p(lispobj obj)
+{
+#ifdef SIGNAL_STACK_START
+    lispobj end = SIGNAL_STACK_START + SIGSTKSZ;
+
+    return (obj >= SIGNAL_STACK_START) && (obj < end);
+#else
+    return FALSE;
+#endif    
+}
 
 
 /* Copying Objects */
@@ -2357,10 +2409,73 @@
 		if (first_word == 0x01) {
 		    *start = ptr[1];
 		    words_scavenged = 1;
-		} else
+		} else {
 		    words_scavenged = scavtab[TypeOf(object)] (start, object);
-	    } else
-		words_scavenged = 1;
+                }
+            } else if (dynamic_space_p(object) || new_space_p(object) || static_space_p(object)
+                       || read_only_space_p(object) || control_stack_space_p(object)
+                       || binding_stack_space_p(object) || signal_space_p(object)) {
+                words_scavenged = 1;
+            } else {
+                lispobj *ptr = (lispobj *) PTR(object);
+                words_scavenged = 1;
+                    fprintf(stderr, "Not in Lisp spaces:  object = %p, ptr = %p\n", (void*)object, ptr);
+                if (object < 0xf0000000) {
+                    lispobj header = *ptr;
+                    fprintf(stderr, "  Header value = 0x%x\n", header);
+                    switch (TypeOf(header)) {
+                        /*
+                         * This needs to be coordinated to the set of allowed
+                         * static vectors in make-array.
+                         */
+                      case type_SimpleString:
+                      case type_SimpleArrayUnsignedByte8:
+                      case type_SimpleArrayUnsignedByte16:
+                      case type_SimpleArrayUnsignedByte32:
+#ifdef type_SimpleArraySignedByte8
+                      case type_SimpleArraySignedByte8:
+#endif
+#ifdef type_SimpleArraySignedByte16
+                      case type_SimpleArraySignedByte16:
+#endif
+#ifdef type_SimpleArraySignedByte32
+                      case type_SimpleArraySignedByte32:
+#endif
+                      case type_SimpleArraySingleFloat:
+                      case type_SimpleArrayDoubleFloat:
+#ifdef type_SimpleArrayLongFloat
+                      case type_SimpleArrayLongFloat:
+#endif
+#ifdef type_SimpleArrayComplexSingleFloat
+                      case type_SimpleArrayComplexSingleFloat:
+#endif
+#ifdef type_SimpleArrayComplexDoubleFloat
+                      case type_SimpleArrayComplexDoubleFloat:
+#endif
+#ifdef type_SimpleArrayComplexLongFloat
+                      case type_SimpleArrayComplexLongFloat:
+#endif
+                      {
+                          int static_p;
+
+                          fprintf(stderr, "Possible static vector at %p.  header = 0x%x\n",
+                                  ptr, header);
+                      
+                          static_p = (HeaderValue(header) & 1) == 1;
+                          if (static_p) {
+                              /*
+                               * We have a static vector.  Mark it as
+                               * reachable by setting the MSB of the header.
+                               */
+                              *ptr = header | 0x80000000;
+                              fprintf(stderr, "Scavenged static vector @%p, header = 0x%x\n",
+                                      ptr, header);
+                      
+                          }
+                      }
+                    }
+                }
+            }
 	} else if ((object & 3) == 0)
 	    words_scavenged = 1;
 	else



More information about the cmucl-commit mailing list