From 45380dbb52002756c80d97444d746cf6f1b105a3 Mon Sep 17 00:00:00 2001 From: rtoy <rtoy> Date: Sat, 5 Dec 2009 03:20:37 +0000 Subject: [PATCH] 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(-) diff --git a/code/array.lisp b/code/array.lisp index 6854bf9c5..5700a3a1b 100644 --- a/code/array.lisp +++ b/code/array.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/array.lisp,v 1.48 2009/12/01 14:14:59 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/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. diff --git a/lisp/gencgc.c b/lisp/gencgc.c index 53e37b14f..fd8b6de63 100644 --- a/lisp/gencgc.c +++ b/lisp/gencgc.c @@ -7,7 +7,7 @@ * * Douglas Crosher, 1996, 1997, 1998, 1999. * - * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/gencgc.c,v 1.101 2009/11/02 15:05:07 rtoy Exp $ + * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/gencgc.c,v 1.102 2009/12/05 03:20:37 rtoy Exp $ * */ @@ -1950,6 +1950,58 @@ new_space_p(lispobj obj) (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 @@ scavenge(void *start_obj, long nwords) 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 -- GitLab