[Sbcl-commits] CVS: sbcl/src/code final.lisp, 1.13, 1.14 gc.lisp, 1.87, 1.88 time.lisp, 1.41, 1.42

[Nikodemus S. <de...@us...>]

Update of /cvsroot/sbcl/sbcl/src/code
In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv9826/src/code

Modified Files:
	final.lisp gc.lisp time.lisp 
Log Message:
1.0.32.33: GENCGC tuning parameters

 * Define +HIGHEST-NORMAL-GENERATION+ and +PSEUDO-STATIC-GENERATION+
   in lisp, and let genesis tell C about them. 

 * Make various generations[gen].foo tweakable from lisp, give them
   nice interface functions and document the same.

 * Bits of manual prettification in related parts.


Index: final.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/final.lisp,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -d -r1.13 -r1.14
--- final.lisp	16 Sep 2009 11:46:40 -0000	1.13
+++ final.lisp	19 Nov 2009 16:08:37 -0000	1.14
@@ -41,19 +41,21 @@
 
 Examples:
 
-  ;;; good (assumes RELEASE-HANDLE is re-entrant)
+  ;;; GOOD, assuming RELEASE-HANDLE is re-entrant.
   (let* ((handle (get-handle))
          (object (make-object handle)))
    (finalize object (lambda () (release-handle handle)))
    object)
 
-  ;;; bad, finalizer refers to object being finalized, causing
-  ;;; it to be retained indefinitely
+  ;;; BAD, finalizer refers to object being finalized, causing
+  ;;; it to be retained indefinitely!
   (let* ((handle (get-handle))
          (object (make-object handle)))
-    (finalize object (lambda () (release-handle (object-handle object)))))
+    (finalize object
+              (lambda ()
+                (release-handle (object-handle object)))))
 
-  ;;; bad, not re-entrant
+  ;;; BAD, not re-entrant!
   (defvar *rec* nil)
 
   (defun oops ()
@@ -64,7 +66,7 @@
 
   (progn
     (finalize \"oops\" #'oops)
-    (oops)) ; causes GC and re-entry to #'oops due to the finalizer
+    (oops)) ; GC causes re-entry to #'oops due to the finalizer
             ; -> ERROR, caught, WARNING signalled"
   (unless object
     (error "Cannot finalize NIL."))

Index: gc.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/gc.lisp,v
retrieving revision 1.87
retrieving revision 1.88
diff -u -d -r1.87 -r1.88
--- gc.lisp	22 Jun 2009 12:58:23 -0000	1.87
+++ gc.lisp	19 Nov 2009 16:08:37 -0000	1.88
@@ -304,8 +304,8 @@
 
 (defun bytes-consed-between-gcs ()
   #!+sb-doc
-  "Return the amount of memory that will be allocated before the next garbage
-   collection is initiated. This can be set with SETF."
+  "The amount of memory that will be allocated before the next garbage
+collection is initiated. This can be set with SETF."
   (sb!alien:extern-alien "bytes_consed_between_gcs"
                          (sb!alien:unsigned 32)))
 
@@ -321,3 +321,106 @@
              (or #!+sb-thread *stop-for-gc-pending*
                  *gc-pending*))
     (sb!unix::receive-pending-interrupt)))
+
+;;;; GENCGC specifics
+;;;;
+;;;; For documentation convenience, these have stubs on non-GENCGC platforms
+;;;; as well.
+#!+gencgc
+(deftype generation-index ()
+  '(integer 0 #.sb!vm:+pseudo-static-generation+))
+
+;;; FIXME: GENERATION (and PAGE, as seen in room.lisp) should probably be
+;;; defined in Lisp, and written to header files by genesis, instead of this
+;;; OAOOMiness -- this duplicates the struct definition in gencgc.c.
+#!+gencgc
+(define-alien-type generation
+    (struct generation
+            (alloc-start-page page-index-t)
+            (alloc-unboxed-start-page page-index-t)
+            (alloc-large-start-page page-index-t)
+            (alloc-large-unboxed-start-page page-index-t)
+            (bytes-allocated unsigned-long)
+            (gc-trigger unsigned-long)
+            (bytes-consed-between-gcs unsigned-long)
+            (number-of-gcs int)
+            (number-of-gcs-before-promotion int)
+            (cum-sum-bytes-allocated unsigned-long)
+            (minimum-age-before-gc double)))
+
+#!+gencgc
+(define-alien-variable generations
+    (array generation #.(1+ sb!vm:+pseudo-static-generation+)))
+
+(macrolet ((def (slot doc &optional setfp)
+             (declare (ignorable doc))
+             `(progn
+                (defun ,(symbolicate "GENERATION-" slot) (generation)
+                  #!+sb-doc
+                  ,doc
+                  (declare (generation-index generation))
+                  #!-gencgc
+                  (declare (ignore generation))
+                  #!-gencgc
+                  (error "~S is a GENCGC only function and unavailable in this build"
+                         ',name)
+                  #!+gencgc
+                  (slot (deref generations generation) ',slot))
+                ,@(when setfp
+                        `((defun (setf ,(symbolicate "GENERATION-" slot)) (value generation)
+                            (declare (generation-index generation))
+                            #!-gencgc
+                            (declare (ignore value generation))
+                            #!-gencgc
+                            (error "(SETF ~S) is a GENCGC only function and unavailable in this build"
+                                   ',name)
+                            #!+gencgc
+                            (setf (slot (deref generations generation) ',slot) value)))))))
+  (def bytes-consed-between-gcs
+      "Number of bytes that can be allocated to GENERATION before that
+generation is considered for garbage collection. This value is meaningless for
+generation 0 (the nursery): see BYTES-CONSED-BETWEEN-GCS instead. Default is
+20Mb. Can be assigned to using SETF. Available on GENCGC platforms only.
+
+Experimental: interface subject to change."
+    t)
+  (def minimum-age-before-gc
+      "Minimum average age of objects allocated to GENERATION before that
+generation is may be garbage collected. Default is 0.75. See also
+GENERATION-AVERAGE-AGE. Can be assigned to using SETF. Available on GENCGC
+platforms only.
+
+Experimental: interface subject to change."
+    t)
+  (def number-of-gcs-before-promotion
+      "Number of times garbage collection is done on GENERATION before
+automatic promotion to the next generation is triggered. Can be assigned to
+using SETF. Available on GENCGC platforms only.
+
+Experimental: interface subject to change."
+    t)
+  (def bytes-allocated
+      "Number of bytes allocated to GENERATION currently. Available on GENCGC
+platforms only.
+
+Experimental: interface subject to change.")
+  (def number-of-gcs
+      "Number of times garbage collection has been done on GENERATION without
+promotion. Available on GENCGC platforms only.
+
+Experimental: interface subject to change."))
+  (defun generation-average-age (generation)
+    "Average age of memory allocated to GENERATION: average number of times
+objects allocated to the generation have seen younger objects promoted to it.
+Available on GENCGC platforms only.
+
+Experimental: interface subject to change."
+    (declare (generation-index generation))
+    #!-gencgc (declare (ignore generation))
+    #!-gencgc
+    (error "~S is a GENCGC only function and unavailable in this build."
+           'generation-average-age)
+    #!+gencgc
+    (alien-funcall (extern-alien "generation_average_age"
+                                 (function double generation-index-t))
+                   generation))

Index: time.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/time.lisp,v
retrieving revision 1.41
retrieving revision 1.42
diff -u -d -r1.41 -r1.42
--- time.lisp	21 May 2009 15:27:37 -0000	1.41
+++ time.lisp	19 Nov 2009 16:08:37 -0000	1.42
@@ -257,8 +257,10 @@
 
 (defvar *gc-run-time* 0
   #!+sb-doc
-  "the total CPU time spent doing garbage collection (as reported by
-   GET-INTERNAL-RUN-TIME)")
+  "Total CPU time spent doing garbage collection (as reported by
+GET-INTERNAL-RUN-TIME.) Initialized to zero on startup. It is safe to bind
+this to zero in order to measure GC time inside a certain section of code, but
+doing so may interfere with results reported by eg. TIME.")
 (declaim (type index *gc-run-time*))
 
 (defun print-time (&key real-time-ms user-run-time-us system-run-time-us