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

Contents of /src/code/gc.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.37 - (hide annotations)
Thu Sep 25 02:40:12 2003 UTC (10 years, 6 months ago) by toy
Branch: MAIN
CVS Tags: snapshot-2003-10
Changes since 1.36: +4 -1 lines
Implmement Pierre Mai's idea of adding 2 macros for setting *FEATURES*
and *RUNTIME-FEATURES* and setting them appropriately as files are
loaded so that recompiling CMUCL produces a result with the same set
of features.  *RUNTIME-FEATURES* is a subset of *FEATURES* that is
written out to internals.h so the C code can be compiled
appropriately.

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

  ViewVC Help
Powered by ViewVC 1.1.5