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

Contents of /src/code/gc.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5