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