1.0.16.19: cleanups motivated by clisp host-2
[sbcl.git] / src / code / gc.lisp
index 39d59a6..e6abbb1 100644 (file)
 ;;;; DYNAMIC-USAGE and friends
 
 (declaim (special sb!vm:*read-only-space-free-pointer*
-                 sb!vm:*static-space-free-pointer*))
+                  sb!vm:*static-space-free-pointer*))
 
 (eval-when (:compile-toplevel :execute)
-  (sb!xc:defmacro def-c-var-frob (lisp-fun c-var-name)
-    `(progn
-       #!-sb-fluid (declaim (inline ,lisp-fun))
-       (defun ,lisp-fun ()
-        (sb!alien:extern-alien ,c-var-name (sb!alien:unsigned 32))))))
+  (sb!xc:defmacro def-c-var-fun (lisp-fun c-var-name)
+    `(defun ,lisp-fun ()
+       (sb!alien:extern-alien ,c-var-name (sb!alien:unsigned 32)))))
 
+#!-sb-fluid
+(declaim (inline current-dynamic-space-start))
+#!+gencgc
+(defun current-dynamic-space-start () sb!vm:dynamic-space-start)
 #!-gencgc
-(progn
-  ;; This is called once per PROFILEd function call, so it's worth a
-  ;; little possible space cost to reduce its time cost.
-  #!-sb-fluid
-  (declaim (inline current-dynamic-space-start))
-  (def-c-var-frob current-dynamic-space-start "current_dynamic_space"))
+(def-c-var-fun current-dynamic-space-start "current_dynamic_space")
 
 #!-sb-fluid
-(declaim (inline dynamic-usage)) ; to reduce PROFILEd call overhead
+(declaim (inline dynamic-usage))
 #!+gencgc
-(def-c-var-frob dynamic-usage "bytes_allocated")
+(def-c-var-fun dynamic-usage "bytes_allocated")
 #!-gencgc
 (defun dynamic-usage ()
   (the (unsigned-byte 32)
 (defun control-stack-usage ()
   #!-stack-grows-downward-not-upward
   (- (sb!sys:sap-int (sb!c::control-stack-pointer-sap))
-     (sb!vm:fixnumize sb!vm::*control-stack-start*))
+     (sb!sys:sap-int (sb!di::descriptor-sap sb!vm:*control-stack-start*)))
   #!+stack-grows-downward-not-upward
-  (- (sb!vm:fixnumize sb!vm::*control-stack-end*)
+  (- (sb!sys:sap-int (sb!di::descriptor-sap sb!vm:*control-stack-end*))
      (sb!sys:sap-int (sb!c::control-stack-pointer-sap))))
 
 (defun binding-stack-usage ()
   (- (sb!sys:sap-int (sb!c::binding-stack-pointer-sap))
-     (sb!vm:fixnumize sb!vm::*binding-stack-start*)))
+     (sb!sys:sap-int (sb!di::descriptor-sap sb!vm:*binding-stack-start*))))
 \f
 ;;;; ROOM
 
   (format t "Control stack usage is:   ~10:D bytes.~%" (control-stack-usage))
   (format t "Binding stack usage is:   ~10:D bytes.~%" (binding-stack-usage))
   #!+sb-thread
-  (format t 
-         "Control and binding stack usage is for the current thread only.~%")
+  (format t
+          "Control and binding stack usage is for the current thread only.~%")
   (format t "Garbage collection is currently ~:[enabled~;DISABLED~].~%"
-         (> *gc-inhibit* 0)))
+          *gc-inhibit*))
 
 (defun room-intermediate-info ()
   (room-minimal-info)
   (sb!vm:memory-usage :count-spaces '(:dynamic)
-                     :print-spaces t
-                     :cutoff 0.05f0
-                     :print-summary nil))
+                      :print-spaces t
+                      :cutoff 0.05f0
+                      :print-summary nil))
 
 (defun room-maximal-info ()
-  (room-minimal-info)
-  (sb!vm:memory-usage :count-spaces '(:static :dynamic))
-  (sb!vm:instance-usage :dynamic :top-n 10)
-  (sb!vm:instance-usage :static :top-n 10))
+  ;; FIXME: SB!VM:INSTANCE-USAGE calls suppressed until bug 344 is fixed
+  (room-intermediate-info)
+  ;; old way, could be restored when bug 344 fixed:
+  ;;x (room-minimal-info)
+  ;;x (sb!vm:memory-usage :count-spaces '(:static :dynamic))
+  ;;x (sb!vm:instance-usage :dynamic :top-n 10)
+  ;;x (sb!vm:instance-usage :static :top-n 10)
+  )
 
 (defun room (&optional (verbosity :default))
   #!+sb-doc
 ;;; allocated and never freed.)
 (declaim (type unsigned-byte *n-bytes-freed-or-purified*))
 (defvar *n-bytes-freed-or-purified* 0)
-(push (lambda ()
-       (setf *n-bytes-freed-or-purified* 0))
-      ;; KLUDGE: It's probably not quite safely right either to do
-      ;; this in *BEFORE-SAVE-INITIALIZATIONS* (since consing, or even
-      ;; worse, something which depended on (GET-BYTES-CONSED), might
-      ;; happen after that) or in *AFTER-SAVE-INITIALIZATIONS*. But
-      ;; it's probably not a big problem, and there seems to be no
-      ;; other obvious time to do it. -- WHN 2001-07-30
-      *after-save-initializations*)
-
-(declaim (ftype (function () unsigned-byte) get-bytes-consed))
+(defun gc-reinit ()
+  (gc-on)
+  (gc)
+  (setf *n-bytes-freed-or-purified* 0
+        *gc-run-time* 0
+        ;; See comment in interr.lisp
+        *heap-exhausted-error-condition* (make-condition 'heap-exhausted-error)))
+
+(declaim (ftype (sfunction () unsigned-byte) get-bytes-consed))
 (defun get-bytes-consed ()
   #!+sb-doc
   "Return the number of bytes consed since the program began. Typically
@@ -138,122 +137,35 @@ and submit it as a patch."
   (+ (dynamic-usage)
      *n-bytes-freed-or-purified*))
 \f
-;;;; variables and constants
-
-;;; the minimum amount of dynamic space which must be consed before a
-;;; GC will be triggered
-;;;
-;;; Unlike CMU CL, we don't export this variable. (There's no need to,
-;;; since our BYTES-CONSED-BETWEEN-GCS function is SETFable.)
-(defvar *bytes-consed-between-gcs*
-  #!+gencgc (* 4 (expt 10 6))
-  ;; Stop-and-copy GC is really really slow when used too often. CSR
-  ;; reported that even on his old 64 Mb SPARC, 20 Mb is much faster
-  ;; than 4 Mb when rebuilding SBCL ca. 0.7.1. For modern machines
-  ;; with >> 128 Mb memory, the optimum could be significantly more
-  ;; than this, but at least 20 Mb should be better than 4 Mb.
-  #!-gencgc (* 20 (expt 10 6)))
-(declaim (type index *bytes-consed-between-gcs*))
-
 ;;;; GC hooks
 
-(defvar *before-gc-hooks* nil ; actually initialized in cold init
-  #!+sb-doc
-  "A list of functions that are called before garbage collection occurs.
-  The functions should take no arguments.")
+(defvar *after-gc-hooks* nil
+  "Called after each garbage collection, except for garbage collections
+triggered during thread exits. In a multithreaded environment these hooks may
+run in any thread.")
 
-(defvar *after-gc-hooks* nil ; actually initialized in cold init
-  #!+sb-doc
-  "A list of functions that are called after garbage collection occurs.
-  The functions should take no arguments.")
-
-(defvar *gc-notify-stream* nil ; (actually initialized in cold init)
-  #!+sb-doc
-  "When non-NIL, this must be a STREAM; and the functions bound to
-  *GC-NOTIFY-BEFORE* and *GC-NOTIFY-AFTER* are called with the
-  STREAM value before and after a garbage collection occurs
-  respectively.")
-
-(defvar *gc-run-time* 0
-  #!+sb-doc
-  "the total CPU time spent doing garbage collection (as reported by
-   GET-INTERNAL-RUN-TIME)")
-(declaim (type index *gc-run-time*))
-
-;;;; The following specials are used to control when garbage
-;;;; collection occurs.
-
-;;; When the dynamic usage increases beyond this amount, the system
-;;; notes that a garbage collection needs to occur by setting
-;;; *NEED-TO-COLLECT-GARBAGE* to T. It starts out as NIL meaning
-;;; nobody has figured out what it should be yet.
-;;;
-;;; FIXME: *GC-TRIGGER* seems to be denominated in bytes, not words.
-;;; And limiting it to INDEX is fairly reasonable in order to avoid
-;;; bignum arithmetic on every allocation, and to minimize the need
-;;; for thought about weird gotchas of the GC-control mechanism itself
-;;; consing as it operates. But as of sbcl-0.7.5, 512Mbytes of memory
-;;; costs $54.95 at Fry's in Dallas but cheap consumer 64-bit machines
-;;; are still over the horizon, so gratuitously limiting our heap size
-;;; to FIXNUM bytes seems fairly stupid. It'd be reasonable to
-;;; (1) allow arbitrary UNSIGNED-BYTE values of *GC-TRIGGER*, or
-;;; (2) redenominate this variable in words instead of bytes, postponing
-;;;     the problem to heaps which exceed 50% of the machine's address
-;;;     space, or even
-;;; (3) redemoninate this variable in CONS-sized two-word units,
-;;;     allowing it to cover the entire memory space at the price of
-;;;     possible loss of clarity.
-;;; (And whatever is done, it'd also be good to rename the variable so
-;;; that it's clear what unit it's denominated in.)
-(declaim (type (or index null) *gc-trigger*))
-(defvar *gc-trigger* nil)
-
-;;; When >0, inhibits garbage collection.
-(defvar *gc-inhibit*) ; initialized in cold init
-
-;;; When T, indicates that a GC should have happened but did not due to 
-;;; *GC-INHIBIT*. 
-(defvar *need-to-collect-garbage* nil) ; initialized in cold init
 \f
 ;;;; internal GC
 
 (sb!alien:define-alien-routine collect-garbage sb!alien:int
   (#!+gencgc last-gen #!-gencgc ignore sb!alien:int))
 
-(sb!alien:define-alien-routine set-auto-gc-trigger sb!alien:void
-  (dynamic-usage sb!alien:unsigned-long))
-
-(sb!alien:define-alien-routine clear-auto-gc-trigger sb!alien:void)
-
 #!+sb-thread
-(def-c-var-frob gc-thread-pid "gc_thread_pid")
-#!+sb-thread
-(defun other-thread-collect-garbage (gen)
-  (setf (sb!alien:extern-alien "maybe_gc_pending" (sb!alien:unsigned 32))
-       (1+ gen))
-  (sb!unix:unix-kill (gc-thread-pid) :SIGALRM))
-
-;;; This variable contains the function that does the real GC. This is
-;;; for low-level GC experimentation. Do not touch it if you do not
-;;; know what you are doing.
-(defvar *internal-gc*
-  #!+sb-thread #'other-thread-collect-garbage
-  #!-sb-thread #'collect-garbage)
-       
+(progn
+  (sb!alien:define-alien-routine gc-stop-the-world sb!alien:void)
+  (sb!alien:define-alien-routine gc-start-the-world sb!alien:void))
+#!-sb-thread
+(progn
+  (defun gc-stop-the-world ())
+  (defun gc-start-the-world ()))
+
 \f
 ;;;; SUB-GC
 
-;;; This is used to carefully invoke hooks.
-(eval-when (:compile-toplevel :execute)
-  (sb!xc:defmacro carefully-funcall (function &rest args)
-    `(handler-case (funcall ,function ,@args)
-       (error (cond)
-             (warn "(FUNCALL ~S~{ ~S~}) lost:~%~A" ',function ',args cond)
-             nil))))
-
 ;;; SUB-GC does a garbage collection.  This is called from three places:
-;;; (1) The C runtime will call here when it detects that we've consed 
-;;;     enough to exceed the gc trigger threshold
+;;; (1) The C runtime will call here when it detects that we've consed
+;;;     enough to exceed the gc trigger threshold.  This is done in
+;;;     alloc() for gencgc or interrupt_maybe_gc() for cheneygc
 ;;; (2) The user may request a collection using GC, below
 ;;; (3) At the end of a WITHOUT-GCING section, we are called if
 ;;;     *NEED-TO-COLLECT-GARBAGE* is true
@@ -265,47 +177,78 @@ and submit it as a patch."
 
 ;;; For GENCGC all generations < GEN will be GC'ed.
 
-(defvar *gc-mutex* (sb!thread:make-mutex :name "GC Mutex"))
-
-(defun sub-gc (&key (gen 0))
-  (when (sb!thread::mutex-value *gc-mutex*) (return-from sub-gc nil))
-  (sb!thread:with-mutex (*gc-mutex* :wait-p nil)
-    (let* ((start-time (get-internal-run-time)))
-      (setf *need-to-collect-garbage* t)
-      (when (zerop *gc-inhibit*)
-       (without-interrupts
-        (dolist (hook  *before-gc-hooks*)  (carefully-funcall hook))
-        (when *gc-trigger*
-          (clear-auto-gc-trigger))
-        (let* ((pre-internal-gc-dynamic-usage (dynamic-usage))
-               (ignore-me (funcall *internal-gc* gen))
-               (post-gc-dynamic-usage (dynamic-usage))
-               (n-bytes-freed (- pre-internal-gc-dynamic-usage
-                                 post-gc-dynamic-usage))
-               ;; the raw N-BYTES-FREED from GENCGC can sometimes be
-               ;; substantially negative (e.g. -5872).  This is
-               ;; probably due to fluctuating inefficiency in the way
-               ;; that the GENCGC packs things into page boundaries.
-               ;; We bump the raw result up to 0: the space is
-               ;; allocated even if unusable, so should be counted
-               ;; for deciding when we've allocated enough to GC
-               ;; next.  ("Man isn't a rational animal, he's a
-               ;; rationalizing animal.":-) -- WHN 2001-06-23)
-               (eff-n-bytes-freed (max 0 n-bytes-freed)))
-          (declare (ignore ignore-me))
-          (incf *n-bytes-freed-or-purified*  eff-n-bytes-freed)
-          (setf *need-to-collect-garbage* nil)
-          (setf *gc-trigger*  (+ post-gc-dynamic-usage
-                                 *bytes-consed-between-gcs*))
-          (set-auto-gc-trigger *gc-trigger*)
-          (dolist (hook *after-gc-hooks*)
-            (carefully-funcall hook))))
-       (scrub-control-stack))       ;XXX again?  we did this from C ...
-      (incf *gc-run-time* (- (get-internal-run-time) start-time))))
-  nil)
-
+(defvar *already-in-gc*
+  (sb!thread:make-mutex :name "GC lock") "ID of thread running SUB-GC")
 
+;;; A unique GC id. This is supplied for code that needs to detect
+;;; whether a GC has happened since some earlier point in time. For
+;;; example:
+;;;
+;;;   (let ((epoch *gc-epoch*))
+;;;      ...
+;;;      (unless (eql epoch *gc-epoch)
+;;;        ....))
+;;;
+;;; This isn't just a fixnum counter since then we'd have theoretical
+;;; problems when exactly 2^29 GCs happen between epoch
+;;; comparisons. Unlikely, but the cost of using a cons instead is too
+;;; small to measure. -- JES, 2007-09-30
+(declaim (type cons *gc-epoch*))
+(defvar *gc-epoch* (cons nil nil))
 
+(defun sub-gc (&key (gen 0))
+  (unless (eq sb!thread:*current-thread*
+              (sb!thread:mutex-value *already-in-gc*))
+    ;; With gencgc, unless *GC-PENDING* every allocation in this
+    ;; function triggers another gc, potentially exceeding maximum
+    ;; interrupt nesting. If *GC-INHIBIT* is not true, however,
+    ;; there is no guarantee that we would ever check for pending
+    ;; GC -- so in that case we must first disable interrupts, which
+    ;; needs to be done for GC anyways...
+    (cond (*gc-inhibit*
+           (setf *gc-pending* t))
+          (t
+           (without-interrupts
+             (setf *gc-pending* t)
+             (sb!thread:with-mutex (*already-in-gc*)
+               (let ((old-usage (dynamic-usage))
+                     (new-usage 0))
+                 (unsafe-clear-roots)
+
+                 (gc-stop-the-world)
+                 (let ((start-time (get-internal-run-time)))
+                   (collect-garbage gen)
+                   (setf *gc-epoch* (cons nil nil))
+                   (incf *gc-run-time*
+                         (- (get-internal-run-time) start-time)))
+                 (setf *gc-pending* nil
+                       new-usage (dynamic-usage))
+                 (gc-start-the-world)
+
+                 ;; In a multithreaded environment the other threads will
+                 ;; see *n-b-f-o-p* change a little late, but that's OK.
+                 (let ((freed (- old-usage new-usage)))
+                   ;; GENCGC occasionally reports negative here, but the
+                   ;; current belief is that it is part of the normal order
+                   ;; of things and not a bug.
+                   (when (plusp freed)
+                     (incf *n-bytes-freed-or-purified* freed))))))
+
+           ;; Outside the mutex, interrupts enabled: these may cause
+           ;; another GC. FIXME: it can potentially exceed maximum
+           ;; interrupt nesting by triggering GCs.
+           ;;
+           ;; Can that be avoided by having the finalizers and hooks
+           ;; run only from the outermost SUB-GC?
+           ;;
+           ;; KLUDGE: Don't run the hooks in GC's triggered by dying
+           ;; threads, so that user-code never runs with
+           ;;   (thread-alive-p *current-thread*) => nil
+           ;; The long-term solution will be to keep a separate thread
+           ;; for finalizers and after-gc hooks.
+           (when (sb!thread:thread-alive-p sb!thread:*current-thread*)
+             (run-pending-finalizers)
+             (call-hooks "after-GC" *after-gc-hooks* :on-error :warn))))))
 
 ;;; This is the user-advertised garbage collection function.
 (defun gc (&key (gen 0) (full nil) &allow-other-keys)
@@ -315,7 +258,19 @@ and submit it as a patch."
   #!+(and sb-doc (not gencgc))
   "Initiate a garbage collection. GEN may be provided for compatibility with
   generational garbage collectors, but is ignored in this implementation."
-  (sub-gc  :gen (if full 6 gen)))
+  (sub-gc :gen (if full 6 gen)))
+
+(defun unsafe-clear-roots ()
+  ;; KLUDGE: Do things in an attempt to get rid of extra roots. Unsafe
+  ;; as having these cons more then we have space left leads to huge
+  ;; badness.
+  (scrub-control-stack)
+  ;; Power cache of the bignum printer: drops overly large bignums and
+  ;; removes duplicate entries.
+  (scrub-power-cache)
+  ;; FIXME: CTYPE-OF-CACHE-CLEAR isn't thread-safe.
+  #!-sb-thread
+  (ctype-of-cache-clear))
 
 \f
 ;;;; auxiliary functions
@@ -324,44 +279,33 @@ and submit it as a patch."
   #!+sb-doc
   "Return the amount of memory that will be allocated before the next garbage
    collection is initiated. This can be set with SETF."
-  *bytes-consed-between-gcs*)
+  (sb!alien:extern-alien "bytes_consed_between_gcs"
+                         (sb!alien:unsigned 32)))
+
 (defun (setf bytes-consed-between-gcs) (val)
-  ;; FIXME: Shouldn't this (and the DECLAIM for the underlying variable)
-  ;; be for a strictly positive number type, e.g.
-  ;; (AND (INTEGER 1) FIXNUM)?
   (declare (type index val))
-  (let ((old *bytes-consed-between-gcs*))
-    (setf *bytes-consed-between-gcs* val)
-    (when *gc-trigger*
-      (setf *gc-trigger* (+ *gc-trigger* (- val old)))
-      (cond ((<= (dynamic-usage) *gc-trigger*)
-            (clear-auto-gc-trigger)
-            (set-auto-gc-trigger *gc-trigger*))
-           (t
-            ;; FIXME: If SCRUB-CONTROL-STACK is required here, why
-            ;; isn't it built into SUB-GC? And *is* it required here?
-            (sb!sys:scrub-control-stack)
-            (sub-gc)))))
-  val)
-
+  (setf (sb!alien:extern-alien "bytes_consed_between_gcs"
+                               (sb!alien:unsigned 32))
+        val))
+
+(declaim (inline maybe-handle-pending-gc))
+(defun maybe-handle-pending-gc ()
+  (when (and (not *gc-inhibit*)
+             (or #!+sb-thread *stop-for-gc-pending*
+                 *gc-pending*))
+    (sb!unix::receive-pending-interrupt)))
+
+;;; These work both regardless of whether we're inside WITHOUT-GCING
+;;; or not.
 (defun gc-on ()
   #!+sb-doc
   "Enable the garbage collector."
-  (setq *gc-inhibit* 0)
-  (when *need-to-collect-garbage*
-    (sub-gc))
+  (setq *gc-inhibit* nil)
+  (maybe-handle-pending-gc)
   nil)
 
 (defun gc-off ()
   #!+sb-doc
   "Disable the garbage collector."
-  (setq *gc-inhibit* 1)
+  (setq *gc-inhibit* t)
   nil)
-\f
-;;;; initialization stuff
-
-(defun gc-reinit ()
-  (when *gc-trigger*
-    (if (< *gc-trigger* (dynamic-usage))
-       (sub-gc)
-       (set-auto-gc-trigger *gc-trigger*))))