/[cmucl]/src/code/gc.lisp
ViewVC logotype

Diff of /src/code/gc.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.9.1.1 by wlott, Wed Nov 20 16:02:03 1991 UTC revision 1.45 by rtoy, Tue Apr 20 17:57:44 2010 UTC
# Line 3  Line 3 
3  ;;; **********************************************************************  ;;; **********************************************************************
4  ;;; This code was written as part of the CMU Common Lisp project at  ;;; This code was written as part of the CMU Common Lisp project at
5  ;;; Carnegie Mellon University, and has been placed in the public domain.  ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;; If you want to use this code or any part of CMU Common Lisp, please contact  
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.  
6  ;;;  ;;;
7  (ext:file-comment  (ext:file-comment
8    "$Header$")    "$Header$")
# Line 18  Line 16 
16  ;;;  ;;;
17    
18  (in-package "EXTENSIONS")  (in-package "EXTENSIONS")
19  (export '(*before-gc-hooks* *after-gc-hooks* gc gc-on gc-off *gc-verbose*  (intl:textdomain "cmucl")
20            *gc-notify-before* *gc-notify-after* get-bytes-consed))  
21    (export '(*before-gc-hooks* *after-gc-hooks* gc gc-on gc-off
22              *bytes-consed-between-gcs* *gc-verbose* *gc-inhibit-hook*
23              *gc-notify-before* *gc-notify-after* get-bytes-consed
24              *gc-run-time* bytes-consed-between-gcs
25              get-bytes-consed-dfixnum))
26    
27  (in-package "LISP")  (in-package "LISP")
28  (export '(room))  (export '(room))
29    
30    #+gencgc
31    (sys:register-lisp-runtime-feature :gencgc)
32    
33    
34  ;;;; def-c-routines for GC interface.  ;;;; DYNAMIC-USAGE and friends.
35    
36  (proclaim '(inline gc-on gc-off num-generations set-num-generations  (declaim (special *read-only-space-free-pointer*
37                     bytes-in-use bytes-allocated-between-flips                    *static-space-free-pointer*))
38                     set-bytes-allocated-between-flips flip-threshold  
39                     tenure-threshold set-tenure-threshold internal-gc))  (eval-when (compile eval)
40      (defmacro c-var-frob (lisp-fun c-var-name)
41  (def-c-routine ("gengc_On" gc-on) (void))      `(progn
42  (def-c-routine ("gengc_Off" gc-off) (void))         (declaim (inline ,lisp-fun))
43  (def-c-routine ("gengc_Generations" num-generations) (int))         (defun ,lisp-fun ()
44  (def-c-routine ("gengc_SetGenerations" set-num-generations) (int)           (alien:extern-alien ,c-var-name (alien:unsigned 32))))))
45    (count int))  
46  (def-c-routine ("gengc_BytesInUse" bytes-in-use) (unsigned-long)  (c-var-frob read-only-space-start "read_only_space")
47    (generation int)  (c-var-frob static-space-start "static_space")
48    (space int))  (c-var-frob dynamic-0-space-start "dynamic_0_space")
49  (def-c-routine ("gengc_BytesAllocatedBetweenFlips"  (c-var-frob dynamic-1-space-start "dynamic_1_space")
50                  bytes-allocated-between-flips)  (c-var-frob control-stack-start "control_stack")
51                 (unsigned-long)  #+x86 (c-var-frob control-stack-end "control_stack_end")
52    (generation int))  (c-var-frob binding-stack-start "binding_stack")
53  (def-c-routine ("gengc_SetBytesAllocatedBetweenFlips"  (c-var-frob current-dynamic-space-start "current_dynamic_space")
54                  set-bytes-allocated-between-flips)  
55                 (void)  (c-var-frob read-only-space-size "read_only_space_size")
56    (generation int)  (c-var-frob binding-stack-size "binding_stack_size")
57    (bytes unsigned-long))  (c-var-frob static-space-size "static_space_size")
58  (def-c-routine ("gengc_FlipThreshold" flip-threshold) (unsigned-long)  (c-var-frob control-stack-size "control_stack_size")
59    (generation int))  (c-var-frob dynamic-space-size "dynamic_space_size")
60  (def-c-routine ("gengc_TenureThreshold" tenure-threshold) (unsigned-long)  (declaim (inline dynamic-usage))
61    (generation int))  
62  (def-c-routine ("gengc_SetTenureThreshold" set-tenure-threshold) (void)  #-(or cgc gencgc)
63    (generation int)  (defun dynamic-usage ()
64    (bytes unsigned-long))    (the (unsigned-byte 32)
65  (def-c-routine ("gengc_InitiateGC" internal-gc) (boolean))         (- (system:sap-int (c::dynamic-space-free-pointer))
66              (current-dynamic-space-start))))
67    
68    ;; #+(or cgc gencgc)
69    ;; (c-var-frob dynamic-usage "bytes_allocated")
70    
71    #+gencgc
72    (progn
73      (alien:def-alien-routine get_bytes_allocated_lower c-call:int)
74      (alien:def-alien-routine get_bytes_allocated_upper c-call:int)
75    
76      (defun dynamic-usage ()
77        (dfixnum:dfixnum-pair-integer
78         (get_bytes_allocated_upper) (get_bytes_allocated_lower))))
79    
80    #+cgc
81    (c-var-frob dynamic-usage "bytes_allocated")
82    
83    (defun static-space-usage ()
84      (- (* lisp::*static-space-free-pointer* #-amd64 vm:word-bytes
85            #+amd64 4) ; won't be necessary when amd64 uses 4-bit lowtag
86         (static-space-start)))
87    
88    (defun read-only-space-usage ()
89      (- (* lisp::*read-only-space-free-pointer* #-amd64 vm:word-bytes
90            #+amd64 4) ; won't be necessary when amd64 uses 4-bit lowtag
91         (read-only-space-start)))
92    
93    (defun control-stack-usage ()
94    #-(or x86 amd64) (- (system:sap-int (c::control-stack-pointer-sap)) (control-stack-start))
95    #+(or x86 amd64) (- (control-stack-end) (system:sap-int (c::control-stack-pointer-sap))) )
96    
97    (defun binding-stack-usage ()
98      (- (system:sap-int (c::binding-stack-pointer-sap)) (binding-stack-start)))
99    
100    
101    (defun current-dynamic-space ()
102      (let ((start (current-dynamic-space-start)))
103        (cond ((= start (dynamic-0-space-start))
104               0)
105              ((= start (dynamic-1-space-start))
106               1)
107              (t
108               (error (intl:gettext "Oh no.  The current dynamic space is missing!"))))))
109    
110    
111  ;;;; Room.  ;;;; Room.
112    
113  (defun room-minimal-info ()  (defun room-minimal-info ()
114    (without-gcing    (flet ((megabytes (bytes)
115     (let ((result 0))             ;; Convert bytes to nearest megabyte
116       (dotimes (gen (num-generations))             (ceiling bytes (* 1024 1024))))
117         (dotimes (space 3)      (format t (intl:gettext "Dynamic Space Usage:    ~13:D bytes (out of ~4:D MB).~%")
118           (incf result (bytes-in-use gen space))))              (dynamic-usage) (megabytes (dynamic-space-size)))
119       (format t "Total memory usage: ~10:D bytes.~%" result))))      (format t (intl:gettext "Read-Only Space Usage:  ~13:D bytes (out of ~4:D MB).~%")
120                (read-only-space-usage) (megabytes (read-only-space-size)))
121        (format t (intl:gettext "Static Space Usage:     ~13:D bytes (out of ~4:D MB).~%")
122                (static-space-usage) (megabytes (static-space-size)))
123        (format t (intl:gettext "Control Stack Usage:    ~13:D bytes (out of ~4:D MB).~%")
124                (control-stack-usage) (megabytes (control-stack-size)))
125        (format t (intl:gettext "Binding Stack Usage:    ~13:D bytes (out of ~4:D MB).~%")
126                (binding-stack-usage) (megabytes (binding-stack-size)))
127        (format t (intl:gettext "The current dynamic space is ~D.~%") (current-dynamic-space))
128        (format t (intl:gettext "Garbage collection is currently ~:[enabled~;DISABLED~].~%")
129                *gc-inhibit*)))
130    
131  (defun room-intermediate-info ()  (defun room-intermediate-info ()
132    (without-gcing    (room-minimal-info)
133     (let ((num-generations (num-generations))    (vm:memory-usage :count-spaces '(:dynamic)
134           (total 0))                     :print-spaces t
135       (format t "~D generations:~%" num-generations)                     :cutoff 0.05s0
136       (dotimes (gen num-generations)                     :print-summary nil))
        (let ((bytes 0))  
          (dotimes (space 3)  
            (incf bytes (bytes-in-use gen space)))  
          (format t "  Generation ~2D: ~10:D bytes.~%" gen bytes)  
          (incf total bytes)))  
      (format t "Total memory usage: ~10:D bytes.~%" total))))  
137    
138  (defun room-maximal-info ()  (defun room-maximal-info ()
139    (without-gcing    (room-minimal-info)
140     (let ((num-generations (num-generations))    (vm:memory-usage :count-spaces '(:static :dynamic))
141           (total 0))    (vm:instance-usage :dynamic :top-n 10)
142       (format t "~D generations:~%" num-generations)    (vm:instance-usage :static :top-n 10))
143       (format t "  Generation  Scavenged  Unscavenged     Code       Total~%")  
      (dotimes (gen num-generations)  
        (let* ((scav (bytes-in-use gen 0))  
               (unscav (bytes-in-use gen 1))  
               (code (bytes-in-use gen 2))  
               (bytes (+ scav unscav code)))  
          (format t "  ~10@:<~D~> ~11:D ~11:D ~11:D ~11:D~%"  
                  gen scav unscav code bytes)  
          (incf total bytes)))  
      (format t "Total memory usage: ~10:D bytes.~%" total))))  
144    
145  (defun room (&optional (verbosity :default))  (defun room (&optional (verbosity :default))
146    "Prints to *STANDARD-OUTPUT* information about the state of internal    "Prints to *STANDARD-OUTPUT* information about the state of internal
# Line 105  Line 149 
149    information.  If it is NIL, ROOM prints out a minimal amount of    information.  If it is NIL, ROOM prints out a minimal amount of
150    information.  If it is :DEFAULT or it is not supplied, ROOM prints out    information.  If it is :DEFAULT or it is not supplied, ROOM prints out
151    an intermediate amount of information.  See also VM:MEMORY-USAGE and    an intermediate amount of information.  See also VM:MEMORY-USAGE and
152    VM:STRUCTURE-USAGE for finer report control."    VM:INSTANCE-USAGE for finer report control."
153    (fresh-line)    (fresh-line)
154    (case verbosity    (if (fboundp 'vm:memory-usage)
155      ((t)        (case verbosity
156       (room-maximal-info))          ((t)
157      ((nil)           (room-maximal-info))
158       (room-minimal-info))          ((nil)
159      (:default           (room-minimal-info))
160       (room-intermediate-info))          (:default
161      (t           (room-intermediate-info))
162       (error "No way man!  The optional argument to ROOM must be T, NIL, ~          (t
163       or :DEFAULT.~%What do you think you are doing?"))))           (error (intl:gettext "No way man!  The optional argument to ROOM must be T, NIL, ~
164                     or :DEFAULT.~%What do you think you are doing?"))))
165          (room-minimal-info))
166      (values))
167    
168    
169  ;;;; GET-BYTES-CONSED.  ;;;; GET-BYTES-CONSED.
170    
171  #|  ;;;
172  ;;; Internal State  ;;; Internal State
173  ;;;  ;;;
174  (defvar *last-bytes-in-use* nil)  (defvar *last-bytes-in-use* nil)
175  (defvar *total-bytes-consed* 0)  (defvar *total-bytes-consed* (dfixnum:make-dfixnum))
176    
177    (declaim (type (or (unsigned-byte 32) null) *last-bytes-in-use*))
178    (declaim (type dfixnum:dfixnum *total-bytes-consed*))
179    
 ;;;  
180  ;;; GET-BYTES-CONSED -- Exported  ;;; GET-BYTES-CONSED -- Exported
181  ;;;  ;;;
182    #+(or cgc gencgc)
183    (defun get-bytes-consed-dfixnum ()
184      ;(declare (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
185      (cond ((null *last-bytes-in-use*)
186             (pushnew
187              #'(lambda ()
188                  (print (intl:gettext "resetting GC counters"))
189                  (force-output)
190                  (setf *last-bytes-in-use* nil)
191                  (setf *total-bytes-consed* (dfixnum:make-dfixnum)))
192              ext:*before-save-initializations*)
193             (setf *last-bytes-in-use* (dynamic-usage))
194             (dfixnum:dfixnum-set-from-number *total-bytes-consed* 0))
195            (t
196             (let* ((bytes (dynamic-usage))
197                    (incbytes (- bytes *last-bytes-in-use*)))
198               (if (< incbytes dfixnum::dfmax)
199                   (dfixnum:dfixnum-inc-hf *total-bytes-consed* incbytes)
200                 (dfixnum:dfixnum-inc-df
201                  *total-bytes-consed*
202                  ;; Kinda fixme - we cons, but it doesn't matter if we consed
203                  ;; more than 250 Megabyte *within* this measuring period anyway.
204                  (let ((df (dfixnum:make-dfixnum)))
205                    (dfixnum:dfixnum-set-from-number df incbytes)
206                    df)))
207               (setq *last-bytes-in-use* bytes))))
208      *total-bytes-consed*)
209    
210    #-(or cgc gencgc)
211    (defun get-bytes-consed-dfixnum ()
212      _N"Returns the number of bytes consed since the first time this function
213      was called.  The first time it is called, it returns zero."
214      (declare (optimize (speed 3) (safety 0)(inhibit-warnings 3)))
215      (cond ((null *last-bytes-in-use*)
216             (setq *last-bytes-in-use* (dynamic-usage))
217             (setq *total-bytes-consed* (dfixnum:make-dfixnum)))
218            (t
219             (let ((bytes (dynamic-usage)))
220               (dfixnum:dfixnum-inc-hf *total-bytes-consed*
221                                (the index (- bytes *last-bytes-in-use*)))
222               (setq *last-bytes-in-use* bytes))))
223      *total-bytes-consed*)
224    
225  (defun get-bytes-consed ()  (defun get-bytes-consed ()
226    "Returns the number of bytes consed since the first time this function    "Returns the number of bytes consed since the first time this function
227    was called.  The first time it is called, it returns zero."    was called.  The first time it is called, it returns zero."
228    (let ((bytes 0))    (dfixnum:dfixnum-integer (get-bytes-consed-dfixnum)))
229      (dotimes (gen (num-generations))  
230        (dotimes (space 3)  
231          (incf bytes (bytes-in-use gen space))))  ;;;; Variables and Constants.
     (cond ((null *last-bytes-in-use*)  
            (setq *last-bytes-in-use* bytes)  
            (setq *total-bytes-consed* 0))  
           (t  
            (incf *total-bytes-consed* (- bytes *last-bytes-in-use*))  
            (setq *last-bytes-in-use* bytes))))  
   *total-bytes-consed*)  
 |#  
232    
233    ;;; The default value of *BYTES-CONSED-BETWEEN-GCS* and *GC-TRIGGER*.
234    ;;;
235    (defconstant default-bytes-consed-between-gcs 12000000)
236    
237    ;;; This variable is the user-settable variable that specifices the
238    ;;; minimum amount of dynamic space which must be consed before a GC
239    ;;; will be triggered.
240    ;;;
241    (defparameter *bytes-consed-between-gcs* default-bytes-consed-between-gcs
242      "This number specifies the minimum number of bytes of dynamic space
243       that must be consed before the next gc will occur.")
244    ;;;
245    (declaim (type index *bytes-consed-between-gcs*))
246    
247    ;;; Public
248    (defvar *gc-run-time* 0
249      "The total CPU time spend doing garbage collection (as reported by
250       GET-INTERNAL-RUN-TIME.)")
251    
252    (declaim (type index *gc-run-time*))
253    
254    ;;; Internal trigger.  When the dynamic usage increases beyond this
255    ;;; amount, the system notes that a garbage collection needs to occur by
256    ;;; setting *NEED-TO-COLLECT-GARBAGE* to T.  It starts out as NIL meaning
257    ;;; nobody has figured out what it should be yet.
258    ;;;
259    (defvar *gc-trigger* nil)
260    
261    (declaim (type (or (unsigned-byte 32) null) *gc-trigger*))
262    
263    ;;; On the RT, we store the GC trigger in a ``static'' symbol instead of
264    ;;; letting magic C code handle it.  It gets initialized by the startup
265    ;;; code. The X86 port defines this here because it uses the `ibmrt'
266    ;;; feature in the C code for allocation and binding stack access and
267    ;;; a lot of stuff wants this INTERNAL_GC_TRIGGER available as well.
268    #+(or ibmrt x86)
269    (defvar vm::*internal-gc-trigger*)
270    
271    ;;;
272    ;;; The following specials are used to control when garbage collection
273    ;;; occurs.
274    ;;;
275    
276    ;;;
277    ;;; *GC-INHIBIT*
278    ;;;
279    ;;; When non-NIL, inhibits garbage collection.
280    ;;;
281    (defvar *gc-inhibit* nil)
282    
283    ;;;
284    ;;; *ALREADY-MAYBE-GCING*
285    ;;;
286    ;;; This flag is used to prevent recursive entry into the garbage
287    ;;; collector.
288    ;;;
289    (defvar *already-maybe-gcing* nil)
290    
291    ;;; When T, indicates that the dynamic usage has exceeded the value
292    ;;; *GC-TRIGGER*.
293    ;;;
294    (defvar *need-to-collect-garbage* nil)
295    
296    
297  ;;;; GC Hooks.  ;;;; GC Hooks.
# Line 165  Line 311 
311    "A list of functions that are called after garbage collection occurs.    "A list of functions that are called after garbage collection occurs.
312    The functions should take no arguments.")    The functions should take no arguments.")
313    
314    ;;;
315    ;;; *GC-INHIBIT-HOOK*
316    ;;;
317    ;;; This hook is invoked whenever SUB-GC intends to GC (unless the GC
318    ;;; was explicitly forced by calling EXT:GC).  If the hook function
319    ;;; returns NIL then the GC procedes; otherwise, the GC is inhibited and
320    ;;; *GC-INHIBIT* and *NEED-TO-COLLECT-GARBAGE* are left bound to T.
321    ;;; Presumably someone will call GC-ON later to collect the garbage.
322    ;;;
323    (defvar *gc-inhibit-hook* nil
324      "Should be bound to a function or NIL.  If it is a function, this
325      function should take one argument, the current amount of dynamic
326      usage.  The function should return NIL if garbage collection should
327      continue and non-NIL if it should be inhibited.  Use with caution.")
328    
329    
330    
331    ;;;
332  ;;; *GC-VERBOSE*  ;;; *GC-VERBOSE*
333  ;;;  ;;;
334  (defvar *gc-verbose* t  (defvar *gc-verbose* t
# Line 173  Line 337 
337    occurs respectively.  If :BEEP, causes the default notify functions to beep    occurs respectively.  If :BEEP, causes the default notify functions to beep
338    annoyingly.")    annoyingly.")
339    
 (defvar *youngest-interesting-generation* nil)  
340    
341  (defun default-gc-notify-before (generation tenuring)  (defun default-gc-notify-before (bytes-in-use)
342    (when (or (null *youngest-interesting-generation*)    (when (eq *gc-verbose* :beep)
343              (<= generation *youngest-interesting-generation*))      (system:beep *standard-output*))
344      (when (eq *gc-verbose* :beep)    (format t (intl:gettext "~&; [GC threshold exceeded with ~:D bytes in use.  ~
345        (system:beep *standard-output*))               Commencing GC.]~%") bytes-in-use)
346      (format t "~&[~:[Flipping~;Tenuring~] generation ~D." tenuring generation)    (finish-output))
     (force-output)))  
347  ;;;  ;;;
348  (defparameter *gc-notify-before* #'default-gc-notify-before  (defparameter *gc-notify-before* #'default-gc-notify-before
349    "This function bound to this variable is invoked before GC'ing (unless    "This function bound to this variable is invoked before GC'ing (unless
350    *GC-VERBOSE* is NIL) with the current amount of dynamic usage (in    *GC-VERBOSE* is NIL) with the current amount of dynamic usage (in
351    bytes).  It should notify the user that the system is going to GC.")    bytes).  It should notify the user that the system is going to GC.")
352    
353  (defun default-gc-notify-after (generation words-scavenged words-transported)  (defun default-gc-notify-after (bytes-retained bytes-freed new-trigger)
354    (when (or (null *youngest-interesting-generation*)    (format t (intl:gettext "~&; [GC completed with ~:D bytes retained and ~:D bytes freed.]~%")
355              (<= generation *youngest-interesting-generation*))            bytes-retained bytes-freed)
356      (format t "  Done.  ~:D words scavenged, and ~:D words transported.]~%"    (format t (intl:gettext "~&; [GC will next occur when at least ~:D bytes are in use.]~%")
357              words-scavenged words-transported)            new-trigger)
358      (when (eq *gc-verbose* :beep)    (when (eq *gc-verbose* :beep)
359        (system:beep *standard-output*))      (system:beep *standard-output*))
360      (force-output)))    (finish-output))
361  ;;;  ;;;
362  (defparameter *gc-notify-after* #'default-gc-notify-after  (defparameter *gc-notify-after* #'default-gc-notify-after
363    "The function bound to this variable is invoked after GC'ing (unless    "The function bound to this variable is invoked after GC'ing (unless
# Line 204  Line 366 
366    threshold.  The function should notify the user that the system has    threshold.  The function should notify the user that the system has
367    finished GC'ing.")    finished GC'ing.")
368    
369    
370    ;;;; Internal GC
371    
372    (alien:def-alien-routine collect-garbage c-call:int
373      #+gencgc (last-gen c-call:int))
374    
375    #-ibmrt
376    (alien:def-alien-routine set-auto-gc-trigger c-call:void
377      (dynamic-usage c-call:unsigned-long))
378    
379    #+ibmrt
380    (defun set-auto-gc-trigger (bytes)
381      (let ((words (ash (+ (current-dynamic-space-start) bytes) -2)))
382        (unless (and (fixnump words) (plusp words))
383          (clear-auto-gc-trigger)
384          (warn (intl:gettext "Attempt to set GC trigger to something bogus: ~S") bytes))
385        (setf rt::*internal-gc-trigger* words)))
386    
387    #-ibmrt
388    (alien:def-alien-routine clear-auto-gc-trigger c-call:void)
389    
390    #+ibmrt
391    (defun clear-auto-gc-trigger ()
392      (setf rt::*internal-gc-trigger* -1))
393    
394    ;;;
395    ;;; *INTERNAL-GC*
396    ;;;
397    ;;; This variables contains the function that does the real GC.  This is
398    ;;; for low-level GC experimentation.  Do not touch it if you do not
399    ;;; know what you are doing.
400    ;;;
401    (defvar *internal-gc* #'collect-garbage)
402    
403    
404    ;;;; SUB-GC
405    
406  ;;;  ;;;
407  ;;; CAREFULLY-FUNCALL -- Internal  ;;; CAREFULLY-FUNCALL -- Internal
408  ;;;  ;;;
# Line 212  Line 411 
411  (defmacro carefully-funcall (function &rest args)  (defmacro carefully-funcall (function &rest args)
412    `(handler-case (funcall ,function ,@args)    `(handler-case (funcall ,function ,@args)
413       (error (cond)       (error (cond)
414         (warn "(FUNCALL ~S~{ ~S~}) lost:~%~A" ',function ',args cond)         (warn (intl:gettext "(FUNCALL ~S~{ ~S~}) lost:~%~A") ',function ',args cond)
415         nil)))         nil)))
416    
 ;;; DO-{BEFORE,AFTER}-GC-STUFF -- Called by C code.  
417  ;;;  ;;;
418  ;;; These two routines are called by the C code to handle any extra work  ;;; SUB-GC -- Internal
419  ;;; that must go on before or after a GC (like calling hooks, etc.).  ;;;
420    ;;; SUB-GC decides when and if to do a garbage collection.  The
421    ;;; VERBOSE-P flag controls whether or not the notify functions are
422    ;;; called.  The FORCE-P flags controls if a GC should occur even if the
423    ;;; dynamic usage is not greater than *GC-TRIGGER*.
424  ;;;  ;;;
425  (defun do-before-gc-stuff (generation tenuring)  ;;; For GENCGC all generations < GEN will be GC'ed.
   (when *gc-verbose*  
     (carefully-funcall *gc-notify-before* generation tenuring))  
   (dolist (before-hook *before-gc-hooks*)  
     (carefully-funcall before-hook)))  
426  ;;;  ;;;
427  (defun do-after-gc-stuff (generation words-scavenged words-transported)  (defun sub-gc (&key (verbose-p *gc-verbose*) force-p #+gencgc (gen 0))
428    (dolist (after-hook *after-gc-hooks*)    (unless *already-maybe-gcing*
429      (carefully-funcall after-hook))      (let* ((*already-maybe-gcing* t)
430    (when *gc-verbose*             (start-time (get-internal-run-time))
431      (carefully-funcall *gc-notify-after* generation words-scavenged             (pre-gc-dyn-usage (dynamic-usage)))
432                         words-transported)))        (unless (integerp (symbol-value '*bytes-consed-between-gcs*))
433            ;; The noise w/ symbol-value above is to keep the compiler from
434            ;; optimizing the test away because of the type declaim for
435            ;; *bytes-consed-between-gcs*.
436            (warn (intl:gettext "The value of *BYTES-CONSED-BETWEEN-GCS*, ~S, is not an ~
437                   integer.  Resetting it to ~D.") *bytes-consed-between-gcs*
438                   default-bytes-consed-between-gcs)
439            (setf *bytes-consed-between-gcs* default-bytes-consed-between-gcs))
440          (when (and *gc-trigger* (>= pre-gc-dyn-usage *gc-trigger*))
441            (setf *need-to-collect-garbage* t))
442          (when (or force-p
443                    (and *need-to-collect-garbage* (not *gc-inhibit*)))
444            (when (and (not force-p)
445                       *gc-inhibit-hook*
446                       (carefully-funcall *gc-inhibit-hook* pre-gc-dyn-usage))
447              (setf *gc-inhibit* t)
448              (return-from sub-gc nil))
449            (without-interrupts
450              (let ((*standard-output* *terminal-io*))
451                (when verbose-p
452                  (carefully-funcall *gc-notify-before* pre-gc-dyn-usage))
453                (dolist (hook *before-gc-hooks*)
454                  (carefully-funcall hook))
455                (when *gc-trigger*
456                  (clear-auto-gc-trigger))
457                #-gencgc (funcall *internal-gc*)
458                #+gencgc (if (eq *internal-gc* #'collect-garbage)
459                             (funcall *internal-gc* gen)
460                             (funcall *internal-gc*))
461                (let* ((post-gc-dyn-usage (dynamic-usage))
462                       (bytes-freed (- pre-gc-dyn-usage post-gc-dyn-usage)))
463                  (when *last-bytes-in-use*
464                    #+nil
465                    (when verbose-p
466                      (format
467                       t (intl:gettext "~&Adjusting *last-bytes-in-use* from ~:D to ~:D, gen ~d, pre ~:D ~%")
468                       *last-bytes-in-use*
469                       post-gc-dyn-usage
470                       gen
471                       pre-gc-dyn-usage)
472                      (force-output))
473                    (let ((correction (- pre-gc-dyn-usage *last-bytes-in-use*)))
474                      (if (<= correction dfixnum::dfmax)
475                          (dfixnum:dfixnum-inc-hf *total-bytes-consed* correction)
476                          ;; give up on not consing
477                          (dfixnum:dfixnum-inc-integer *total-bytes-consed*
478                                                       correction)))
479                    (setq *last-bytes-in-use* post-gc-dyn-usage))
480                  (setf *need-to-collect-garbage* nil)
481                  (setf *gc-trigger*
482                        (+ post-gc-dyn-usage *bytes-consed-between-gcs*))
483                  (set-auto-gc-trigger *gc-trigger*)
484                  (dolist (hook *after-gc-hooks*)
485                    (carefully-funcall hook))
486                  (when verbose-p
487                    (carefully-funcall *gc-notify-after*
488                                       post-gc-dyn-usage bytes-freed
489                                       *gc-trigger*))))
490              (scrub-control-stack)))
491          (incf *gc-run-time* (- (get-internal-run-time) start-time))))
492      nil)
493    
494    ;;;
495    ;;; MAYBE-GC -- Internal
496    ;;;
497    ;;; This routine is called by the allocation miscops to decide if a GC
498    ;;; should occur.  The argument, object, is the newly allocated object
499    ;;; which must be returned to the caller.
500    ;;;
501    (defun maybe-gc (&optional object)
502      (sub-gc)
503      object)
504    
505    ;;;
 ;;;; GC  
   
506  ;;; GC -- Exported  ;;; GC -- Exported
507  ;;;  ;;;
508  ;;; This is the user advertised garbage collection function.  ;;; This is the user advertised garbage collection function.
509  ;;;  ;;;
510  (defun gc (&optional (*gc-verbose* *gc-verbose*))  #-gencgc
511    "Initiates a garbage collection.  The optional argument, VERBOSE-P,  (defun gc (&optional (verbose-p *gc-verbose*))
512      _N"Initiates a garbage collection.  The optional argument, VERBOSE-P,
513    which defaults to the value of the variable *GC-VERBOSE* controls    which defaults to the value of the variable *GC-VERBOSE* controls
514    whether or not GC statistics are printed."    whether or not GC statistics are printed."
515    (unless (internal-gc)    (sub-gc :verbose-p verbose-p :force-p t))
516      (warn "Garbage collection currently disabled.")))  ;;;
517    #+gencgc
518    (defun gc (&key (verbose *gc-verbose*) (gen 0) (full nil))
519      _N"Initiates a garbage collection.  The keyword :VERBOSE, which
520       defaults to the value of the variable *GC-VERBOSE* controls whether or
521       not GC statistics are printed. The keyword :GEN defaults to 0, and
522       controls the number of generations to garbage collect."
523      (sub-gc :verbose-p verbose :force-p t :gen (if full 6 gen)))
524    
525    
526    ;;;; Auxiliary Functions.
527    
528    (defun bytes-consed-between-gcs ()
529      "Return the amount of memory that will be allocated before the next garbage
530       collection is initiated.  This can be set with SETF."
531      *bytes-consed-between-gcs*)
532    ;;;
533    (defun %set-bytes-consed-between-gcs (val)
534      (declare (type index val))
535      (let ((old *bytes-consed-between-gcs*))
536        (setf *bytes-consed-between-gcs* val)
537        (when *gc-trigger*
538          (setf *gc-trigger* (+ *gc-trigger* (- val old)))
539          (cond ((<= (dynamic-usage) *gc-trigger*)
540                 (clear-auto-gc-trigger)
541                 (set-auto-gc-trigger *gc-trigger*))
542                (t
543                 (system:scrub-control-stack)
544                 (sub-gc)))))
545      val)
546    ;;;
547    (defsetf bytes-consed-between-gcs %set-bytes-consed-between-gcs)
548    
549    
550    (defun gc-on ()
551      "Enables the garbage collector."
552      (setq *gc-inhibit* nil)
553      (when *need-to-collect-garbage*
554        (sub-gc))
555      nil)
556    
557    (defun gc-off ()
558      "Disables the garbage collector."
559      (setq *gc-inhibit* t)
560      nil)
561    
562    
563    
564    ;;;; Initialization stuff.
565    
566    (defun gc-init ()
567      (when *gc-trigger*
568        (if (< *gc-trigger* (dynamic-usage))
569            (sub-gc)
570            (set-auto-gc-trigger *gc-trigger*))))
571    
572    ;;; setters and accessors for gencgc parameters
573    
574    #+gencgc
575    (eval-when (load eval)
576    (alien:def-alien-type nil
577      (alien:struct generation-stats
578        (bytes-allocated c-call:int)
579        (gc-trigger c-call:int)
580        (bytes-consed-between-gc c-call:int)
581        (num-gc c-call:int)
582        (trigger-age c-call:int)
583        (cum-sum-bytes-allocated c-call:int)
584        (min-av-mem-age c-call:double)))
585    
586    (defun gencgc-stats (generation)
587      "Return some GC statistics for the specified GENERATION.  The
588      statistics are the number of bytes allocated in this generation; the
589      gc-trigger; the number of bytes consed between GCs; the number of
590      GCs that have occurred; the trigger age; the cumulative number of
591      bytes allocated in this generation; and the average age of this
592      generation.  See the gencgc source code for more info."
593      (alien:with-alien ((stats (alien:struct generation-stats)))
594        (alien:alien-funcall (alien:extern-alien "get_generation_stats"
595                                                 (function c-call:void
596                                                           c-call:int
597                                                           (* (alien:struct
598                                                               generation-stats))))
599                             generation
600                             (alien:addr stats))
601        (values (alien:slot stats 'bytes-allocated)
602                (alien:slot stats 'gc-trigger)
603                (alien:slot stats 'bytes-consed-between-gc)
604                (alien:slot stats 'num-gc)
605                (alien:slot stats 'trigger-age)
606                (alien:slot stats 'cum-sum-bytes-allocated)
607                (alien:slot stats 'min-av-mem-age))))
608    
609    (alien:def-alien-routine set-gc-trigger c-call:void
610                             (gen c-call:int) (trigger c-call:int))
611    (alien:def-alien-routine set-trigger-age c-call:void
612                             (gen c-call:int) (trigger-age c-call:int))
613    (alien:def-alien-routine set-min-mem-age c-call:void
614                             (gen c-call:int) (min-mem-age c-call:double))
615    )

Legend:
Removed from v.1.9.1.1  
changed lines
  Added in v.1.45

  ViewVC Help
Powered by ViewVC 1.1.5