export DYNAMIC-SPACE-SIZE from SB-EXT

[sbcl.git] / src / code / gc.lisp

diff --git a/src/code/gc.lisp b/src/code/gc.lisp
index fb4a0e1..e1ebb73 100644 (file)
--- a/src/code/gc.lisp
+++ b/src/code/gc.lisp
@@ -13,22 +13,19 @@
 \f
 ;;;; DYNAMIC-USAGE and friends
 
 \f
 ;;;; DYNAMIC-USAGE and friends
 

-(eval-when (:compile-toplevel :execute)
-  (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
 #!-sb-fluid
 (declaim (inline current-dynamic-space-start))
 #!+gencgc
 (defun current-dynamic-space-start () sb!vm:dynamic-space-start)
 #!-gencgc

-(def-c-var-fun current-dynamic-space-start "current_dynamic_space")
+(defun current-dynamic-space-start ()
+  (sb!alien:extern-alien "current_dynamic_space" sb!alien:unsigned-long))

 
 #!-sb-fluid
 (declaim (inline dynamic-usage))
 #!+gencgc
 
 #!-sb-fluid
 (declaim (inline dynamic-usage))
 #!+gencgc

-(def-c-var-fun dynamic-usage "bytes_allocated")
+(defun dynamic-usage ()
+  (sb!alien:extern-alien "bytes_allocated" os-vm-size-t))

 #!-gencgc
 (defun dynamic-usage ()
   (the (unsigned-byte 32)
 #!-gencgc
 (defun dynamic-usage ()
   (the (unsigned-byte 32)

@@ -36,11 +33,11 @@
           (current-dynamic-space-start))))
 
 (defun static-space-usage ()
           (current-dynamic-space-start))))
 
 (defun static-space-usage ()

-  (- (* sb!vm:*static-space-free-pointer* sb!vm:n-word-bytes)
+  (- (ash sb!vm:*static-space-free-pointer* sb!vm:n-fixnum-tag-bits)

      sb!vm:static-space-start))
 
 (defun read-only-space-usage ()
      sb!vm:static-space-start))
 
 (defun read-only-space-usage ()

-  (- (* sb!vm::*read-only-space-free-pointer* sb!vm:n-word-bytes)
+  (- (ash sb!vm::*read-only-space-free-pointer* sb!vm:n-fixnum-tag-bits)

      sb!vm:read-only-space-start))
 
 (defun control-stack-usage ()
      sb!vm:read-only-space-start))
 
 (defun control-stack-usage ()

@@ -179,7 +176,8 @@ NIL as the pathname."
         (native-pathname (cast val c-string)))))
   (declaim (inline dynamic-space-size))
   (defun dynamic-space-size ()
         (native-pathname (cast val c-string)))))
   (declaim (inline dynamic-space-size))
   (defun dynamic-space-size ()

-    (sb!alien:extern-alien "dynamic_space_size" sb!alien:unsigned-long)))
+    "Size of the dynamic space in bytes."
+    (sb!alien:extern-alien "dynamic_space_size" os-vm-size-t)))

 \f
 ;;;; SUB-GC
 
 \f
 ;;;; SUB-GC
 

@@ -236,39 +234,40 @@ NIL as the pathname."
            ;; Now, if GET-MUTEX did not cons, that would be enough.
            ;; Because it does, we need the :IN-PROGRESS bit above to
            ;; tell the runtime not to trigger gcs.
            ;; Now, if GET-MUTEX did not cons, that would be enough.
            ;; Because it does, we need the :IN-PROGRESS bit above to
            ;; tell the runtime not to trigger gcs.

-           (let ((sb!impl::*in-without-gcing* t)
-                 (sb!impl::*deadline* nil)
-                 (sb!impl::*deadline-seconds* nil))
-             (sb!thread:with-mutex (*already-in-gc*)
-               (let ((*gc-inhibit* t))
-                 (let ((old-usage (dynamic-usage))
-                       (new-usage 0))
-                   (unsafe-clear-roots gen)
-                   (gc-stop-the-world)
-                   (let ((start-time (get-internal-run-time)))
-                     (collect-garbage gen)
-                     (setf *gc-epoch* (cons nil nil))
-                     (let ((run-time (- (get-internal-run-time) start-time)))
-                       ;; KLUDGE: Sometimes we see the second getrusage() call
-                       ;; return a smaller value than the first, which can
-                       ;; lead to *GC-RUN-TIME* to going negative, which in
-                       ;; turn is a type-error.
-                       (when (plusp run-time)
-                         (incf *gc-run-time* run-time))))
-                   (setf *gc-pending* nil
-                         new-usage (dynamic-usage))
-                   #!+sb-thread
-                   (assert (not *stop-for-gc-pending*))
-                   (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)))))))
+           (sb!thread::without-thread-waiting-for (:already-without-interrupts t)
+             (let* ((sb!impl::*in-without-gcing* t)
+                    (sb!impl::*deadline* nil)
+                    (sb!impl::*deadline-seconds* nil))
+               (sb!thread:with-mutex (*already-in-gc*)
+                 (let ((*gc-inhibit* t))
+                   (let ((old-usage (dynamic-usage))
+                         (new-usage 0))
+                     (unsafe-clear-roots gen)
+                     (gc-stop-the-world)
+                     (let ((start-time (get-internal-run-time)))
+                       (collect-garbage gen)
+                       (setf *gc-epoch* (cons nil nil))
+                       (let ((run-time (- (get-internal-run-time) start-time)))
+                         ;; KLUDGE: Sometimes we see the second getrusage() call
+                         ;; return a smaller value than the first, which can
+                         ;; lead to *GC-RUN-TIME* to going negative, which in
+                         ;; turn is a type-error.
+                         (when (plusp run-time)
+                           (incf *gc-run-time* run-time))))
+                     (setf *gc-pending* nil
+                           new-usage (dynamic-usage))
+                     #!+sb-thread
+                     (assert (not *stop-for-gc-pending*))
+                     (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))))))))

            ;; While holding the mutex we were protected from
            ;; SIG_STOP_FOR_GC and recursive GCs. Now, in order to
            ;; preserve the invariant (*GC-PENDING* ->
            ;; While holding the mutex we were protected from
            ;; SIG_STOP_FOR_GC and recursive GCs. Now, in order to
            ;; preserve the invariant (*GC-PENDING* ->

@@ -299,9 +298,10 @@ NIL as the pathname."
   ;; finalizers and after-gc hooks.
   (when (sb!thread:thread-alive-p sb!thread:*current-thread*)
     (when *allow-with-interrupts*
   ;; finalizers and after-gc hooks.
   (when (sb!thread:thread-alive-p sb!thread:*current-thread*)
     (when *allow-with-interrupts*

-      (with-interrupts
-        (run-pending-finalizers)
-        (call-hooks "after-GC" *after-gc-hooks* :on-error :warn)))))
+      (sb!thread::without-thread-waiting-for ()
+        (with-interrupts
+          (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)
 
 ;;; This is the user-advertised garbage collection function.
 (defun gc (&key (gen 0) (full nil) &allow-other-keys)

@@ -317,6 +317,7 @@ NIL as the pathname."
 (define-alien-routine scrub-control-stack sb!alien:void)
 
 (defun unsafe-clear-roots (gen)
 (define-alien-routine scrub-control-stack sb!alien:void)
 
 (defun unsafe-clear-roots (gen)

+  #!-gencgc (declare (ignore gen))

   ;; 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.
   ;; 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.

@@ -339,14 +340,17 @@ NIL as the pathname."
 (defun bytes-consed-between-gcs ()
   #!+sb-doc
   "The amount of memory that will be allocated before the next garbage
 (defun bytes-consed-between-gcs ()
   #!+sb-doc
   "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)))
+collection is initiated. This can be set with SETF.
+
+On GENCGC platforms this is the nursery size, and defaults to 5% of dynamic
+space size.
+
+Note: currently changes to this value are lost when saving core."
+  (sb!alien:extern-alien "bytes_consed_between_gcs" os-vm-size-t))

 
 (defun (setf bytes-consed-between-gcs) (val)
   (declare (type index val))
 
 (defun (setf bytes-consed-between-gcs) (val)
   (declare (type index val))

-  (setf (sb!alien:extern-alien "bytes_consed_between_gcs"
-                               (sb!alien:unsigned 32))
+  (setf (sb!alien:extern-alien "bytes_consed_between_gcs" os-vm-size-t)

         val))
 
 (declaim (inline maybe-handle-pending-gc))
         val))
 
 (declaim (inline maybe-handle-pending-gc))

@@ -374,15 +378,13 @@ collection is initiated. This can be set with SETF."
             (alloc-unboxed-start-page page-index-t)
             (alloc-large-start-page page-index-t)
             (alloc-large-unboxed-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)
+            (bytes-allocated os-vm-size-t)
+            (gc-trigger os-vm-size-t)
+            (bytes-consed-between-gcs os-vm-size-t)

             (number-of-gcs int)
             (number-of-gcs-before-promotion int)
             (number-of-gcs int)
             (number-of-gcs-before-promotion int)

-            (cum-sum-bytes-allocated unsigned-long)
-            (minimum-age-before-gc double)
-            ;; `struct lutex *' or `void *', depending.
-            (lutexes (* char))))
+            (cum-sum-bytes-allocated os-vm-size-t)
+            (minimum-age-before-gc double)))

 
 #!+gencgc
 (define-alien-variable generations
 
 #!+gencgc
 (define-alien-variable generations

@@ -418,7 +420,8 @@ collection is initiated. This can be set with SETF."
       "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
       "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.
+5% of the dynamic space size. Can be assigned to using SETF. Available on
+GENCGC platforms only.

 
 Experimental: interface subject to change."
     t)
 
 Experimental: interface subject to change."
     t)