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

Contents of /src/code/gc.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.29 - (hide annotations)
Thu Nov 7 16:07:23 2002 UTC (11 years, 5 months ago) by toy
Branch: MAIN
Changes since 1.28: +4 -1 lines
Fix typo on the dfixnum profile changes so this works on non-x86
platforms.
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.29 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/gc.lisp,v 1.29 2002/11/07 16:07:23 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     (defun get-bytes-consed ()
190     "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     (dfixnum:dfixnum-integer (get-bytes-consed-dfixnum)))
193    
194     #-(or cgc gencgc)
195 ram 1.1 (defun get-bytes-consed ()
196     "Returns the number of bytes consed since the first time this function
197     was called. The first time it is called, it returns zero."
198 pw 1.26 (declare (optimize (speed 3) (safety 0)(inhibit-warnings 3)))
199 ram 1.1 (cond ((null *last-bytes-in-use*)
200 cracauer 1.28 (setq *last-bytes-in-use* (dynamic-usage))
201     (setq *total-bytes-consed* 0))
202     (t
203     (let ((bytes (dynamic-usage)))
204     (incf *total-bytes-consed*
205     (the index (- bytes *last-bytes-in-use*)))
206     (setq *last-bytes-in-use* bytes))))
207 ram 1.1 *total-bytes-consed*)
208 wlott 1.4
209 cracauer 1.28 #-(or cgc gencgc)
210     (defun get-bytes-consed-dfixnum ()
211     ;; A plug until a direct implementation is available.
212     (dfixnum:dfixnum-make-from-number (get-bytes-consed)))
213    
214 ram 1.1
215 ram 1.2 ;;;; Variables and Constants.
216 ram 1.1
217     ;;; The default value of *BYTES-CONSED-BETWEEN-GCS* and *GC-TRIGGER*.
218     ;;;
219     (defconstant default-bytes-consed-between-gcs 2000000)
220    
221     ;;; This variable is the user-settable variable that specifices the
222     ;;; minimum amount of dynamic space which must be consed before a GC
223     ;;; will be triggered.
224     ;;;
225     (defvar *bytes-consed-between-gcs* default-bytes-consed-between-gcs
226     "This number specifies the minimum number of bytes of dynamic space
227 wlott 1.12 that must be consed before the next gc will occur.")
228 wlott 1.14 ;;;
229 wlott 1.12 (declaim (type index *bytes-consed-between-gcs*))
230    
231 ram 1.11 ;;; Public
232     (defvar *gc-run-time* 0
233     "The total CPU time spend doing garbage collection (as reported by
234     GET-INTERNAL-RUN-TIME.)")
235    
236 wlott 1.12 (declaim (type index *gc-run-time*))
237 ram 1.11
238 ram 1.1 ;;; Internal trigger. When the dynamic usage increases beyond this
239     ;;; amount, the system notes that a garbage collection needs to occur by
240 wlott 1.5 ;;; setting *NEED-TO-COLLECT-GARBAGE* to T. It starts out as NIL meaning
241     ;;; nobody has figured out what it should be yet.
242 ram 1.1 ;;;
243 wlott 1.5 (defvar *gc-trigger* nil)
244 ram 1.1
245 ram 1.11 (declaim (type (or index null) *gc-trigger*))
246    
247 wlott 1.9 ;;; On the RT, we store the GC trigger in a ``static'' symbol instead of
248     ;;; letting magic C code handle it. It gets initialized by the startup
249 ram 1.20 ;;; code. The X86 port defines this here because it uses the `ibmrt'
250     ;;; feature in the C code for allocation and binding stack access and
251     ;;; a lot of stuff wants this INTERNAL_GC_TRIGGER available as well.
252     #+(or ibmrt x86)
253     (defvar vm::*internal-gc-trigger*)
254 ram 1.1
255     ;;;
256     ;;; The following specials are used to control when garbage collection
257     ;;; occurs.
258     ;;;
259    
260     ;;;
261     ;;; *GC-INHIBIT*
262     ;;;
263 ram 1.2 ;;; When non-NIL, inhibits garbage collection.
264 ram 1.1 ;;;
265     (defvar *gc-inhibit* nil)
266    
267     ;;;
268     ;;; *ALREADY-MAYBE-GCING*
269     ;;;
270     ;;; This flag is used to prevent recursive entry into the garbage
271     ;;; collector.
272     ;;;
273     (defvar *already-maybe-gcing* nil)
274    
275     ;;; When T, indicates that the dynamic usage has exceeded the value
276     ;;; *GC-TRIGGER*.
277     ;;;
278     (defvar *need-to-collect-garbage* nil)
279    
280    
281 ram 1.2 ;;;; GC Hooks.
282 ram 1.1
283     ;;;
284     ;;; *BEFORE-GC-HOOKS*
285     ;;; *AFTER-GC-HOOKS*
286     ;;;
287     ;;; These variables are a list of functions which are run before and
288     ;;; after garbage collection occurs.
289     ;;;
290     (defvar *before-gc-hooks* nil
291     "A list of functions that are called before garbage collection occurs.
292     The functions should take no arguments.")
293     ;;;
294     (defvar *after-gc-hooks* nil
295     "A list of functions that are called after garbage collection occurs.
296     The functions should take no arguments.")
297    
298     ;;;
299     ;;; *GC-INHIBIT-HOOK*
300     ;;;
301     ;;; This hook is invoked whenever SUB-GC intends to GC (unless the GC
302     ;;; was explicitly forced by calling EXT:GC). If the hook function
303     ;;; returns NIL then the GC procedes; otherwise, the GC is inhibited and
304     ;;; *GC-INHIBIT* and *NEED-TO-COLLECT-GARBAGE* are left bound to T.
305     ;;; Presumably someone will call GC-ON later to collect the garbage.
306     ;;;
307     (defvar *gc-inhibit-hook* nil
308     "Should be bound to a function or NIL. If it is a function, this
309     function should take one argument, the current amount of dynamic
310     usage. The function should return NIL if garbage collection should
311     continue and non-NIL if it should be inhibited. Use with caution.")
312    
313    
314    
315 ram 1.2 ;;;
316     ;;; *GC-VERBOSE*
317     ;;;
318     (defvar *gc-verbose* t
319     "When non-NIL, causes the functions bound to *GC-NOTIFY-BEFORE* and
320     *GC-NOTIFY-AFTER* to be called before and after a garbage collection
321 ram 1.7 occurs respectively. If :BEEP, causes the default notify functions to beep
322     annoyingly.")
323 ram 1.2
324    
325 ram 1.1 (defun default-gc-notify-before (bytes-in-use)
326 ram 1.7 (when (eq *gc-verbose* :beep)
327     (system:beep *standard-output*))
328 ram 1.1 (format t "~&[GC threshold exceeded with ~:D bytes in use. ~
329 ram 1.7 Commencing GC.]~%" bytes-in-use)
330 ram 1.1 (finish-output))
331     ;;;
332     (defparameter *gc-notify-before* #'default-gc-notify-before
333 ram 1.2 "This function bound to this variable is invoked before GC'ing (unless
334     *GC-VERBOSE* is NIL) with the current amount of dynamic usage (in
335     bytes). It should notify the user that the system is going to GC.")
336 ram 1.1
337     (defun default-gc-notify-after (bytes-retained bytes-freed new-trigger)
338     (format t "[GC completed with ~:D bytes retained and ~:D bytes freed.]~%"
339     bytes-retained bytes-freed)
340     (format t "[GC will next occur when at least ~:D bytes are in use.]~%"
341     new-trigger)
342 ram 1.7 (when (eq *gc-verbose* :beep)
343     (system:beep *standard-output*))
344 ram 1.1 (finish-output))
345     ;;;
346     (defparameter *gc-notify-after* #'default-gc-notify-after
347 ram 1.2 "The function bound to this variable is invoked after GC'ing (unless
348     *GC-VERBOSE* is NIL) with the amount of dynamic usage (in bytes) now
349     free, the number of bytes freed by the GC, and the new GC trigger
350     threshold. The function should notify the user that the system has
351     finished GC'ing.")
352 ram 1.1
353    
354 wlott 1.4 ;;;; Internal GC
355 ram 1.1
356 dtc 1.23 (alien:def-alien-routine collect-garbage c-call:int
357     #+gencgc (last-gen c-call:int))
358 ram 1.1
359 wlott 1.9 #-ibmrt
360 wlott 1.10 (alien:def-alien-routine set-auto-gc-trigger c-call:void
361     (dynamic-usage c-call:unsigned-long))
362 wlott 1.5
363 wlott 1.9 #+ibmrt
364     (defun set-auto-gc-trigger (bytes)
365     (let ((words (ash (+ (current-dynamic-space-start) bytes) -2)))
366     (unless (and (fixnump words) (plusp words))
367     (clear-auto-gc-trigger)
368     (warn "Attempt to set GC trigger to something bogus: ~S" bytes))
369     (setf rt::*internal-gc-trigger* words)))
370    
371     #-ibmrt
372 wlott 1.10 (alien:def-alien-routine clear-auto-gc-trigger c-call:void)
373 wlott 1.9
374     #+ibmrt
375     (defun clear-auto-gc-trigger ()
376     (setf rt::*internal-gc-trigger* -1))
377 wlott 1.5
378 ram 1.1 ;;;
379     ;;; *INTERNAL-GC*
380     ;;;
381     ;;; This variables contains the function that does the real GC. This is
382     ;;; for low-level GC experimentation. Do not touch it if you do not
383     ;;; know what you are doing.
384     ;;;
385 wlott 1.12 (defvar *internal-gc* #'collect-garbage)
386 ram 1.1
387    
388     ;;;; SUB-GC
389    
390     ;;;
391     ;;; CAREFULLY-FUNCALL -- Internal
392     ;;;
393     ;;; Used to carefully invoke hooks.
394     ;;;
395     (defmacro carefully-funcall (function &rest args)
396     `(handler-case (funcall ,function ,@args)
397     (error (cond)
398     (warn "(FUNCALL ~S~{ ~S~}) lost:~%~A" ',function ',args cond)
399     nil)))
400    
401     ;;;
402     ;;; SUB-GC -- Internal
403     ;;;
404     ;;; SUB-GC decides when and if to do a garbage collection. The
405     ;;; VERBOSE-P flag controls whether or not the notify functions are
406     ;;; called. The FORCE-P flags controls if a GC should occur even if the
407     ;;; dynamic usage is not greater than *GC-TRIGGER*.
408     ;;;
409 dtc 1.23 ;;; For GENCGC all generations < GEN will be GC'ed.
410     ;;;
411     (defun sub-gc (&key (verbose-p *gc-verbose*) force-p #+gencgc (gen 0))
412 ram 1.1 (unless *already-maybe-gcing*
413     (let* ((*already-maybe-gcing* t)
414 ram 1.11 (start-time (get-internal-run-time))
415 ram 1.1 (pre-gc-dyn-usage (dynamic-usage)))
416 ram 1.11 (unless (integerp (symbol-value '*bytes-consed-between-gcs*))
417 wlott 1.12 ;; The noise w/ symbol-value above is to keep the compiler from
418     ;; optimizing the test away because of the type declaim for
419     ;; *bytes-consed-between-gcs*.
420 ram 1.1 (warn "The value of *BYTES-CONSED-BETWEEN-GCS*, ~S, is not an ~
421 ram 1.7 integer. Reseting it to ~D." *bytes-consed-between-gcs*
422     default-bytes-consed-between-gcs)
423 ram 1.1 (setf *bytes-consed-between-gcs* default-bytes-consed-between-gcs))
424 wlott 1.12 (when (and *gc-trigger* (> pre-gc-dyn-usage *gc-trigger*))
425 ram 1.7 (setf *need-to-collect-garbage* t))
426 ram 1.1 (when (or force-p
427     (and *need-to-collect-garbage* (not *gc-inhibit*)))
428     (when (and (not force-p)
429     *gc-inhibit-hook*
430     (carefully-funcall *gc-inhibit-hook* pre-gc-dyn-usage))
431 ram 1.7 (setf *gc-inhibit* t)
432 ram 1.1 (return-from sub-gc nil))
433 wlott 1.6 (without-interrupts
434 ram 1.7 (let ((*standard-output* *terminal-io*))
435     (when verbose-p
436     (carefully-funcall *gc-notify-before* pre-gc-dyn-usage))
437     (dolist (hook *before-gc-hooks*)
438     (carefully-funcall hook))
439     (when *gc-trigger*
440     (clear-auto-gc-trigger))
441 dtc 1.23 #-gencgc (funcall *internal-gc*)
442     #+gencgc (if (eq *internal-gc* #'collect-garbage)
443     (funcall *internal-gc* gen)
444 cracauer 1.28 (funcall *internal-gc*))
445 ram 1.7 (let* ((post-gc-dyn-usage (dynamic-usage))
446     (bytes-freed (- pre-gc-dyn-usage post-gc-dyn-usage)))
447 wlott 1.12 (when *last-bytes-in-use*
448 cracauer 1.28 #+nil(when verbose-p
449     (format
450     t "~&Adjusting *last-bytes-in-use* from ~:D to ~:D, gen ~d, pre ~:D ~%"
451     *last-bytes-in-use*
452     post-gc-dyn-usage
453     gen
454     pre-gc-dyn-usage)
455     (force-output))
456     (dfixnum:dfixnum-inc-hf
457     *total-bytes-consed*
458     (- pre-gc-dyn-usage *last-bytes-in-use*))
459 wlott 1.12 (setq *last-bytes-in-use* post-gc-dyn-usage))
460 ram 1.7 (setf *need-to-collect-garbage* nil)
461     (setf *gc-trigger*
462     (+ post-gc-dyn-usage *bytes-consed-between-gcs*))
463     (set-auto-gc-trigger *gc-trigger*)
464     (dolist (hook *after-gc-hooks*)
465     (carefully-funcall hook))
466     (when verbose-p
467     (carefully-funcall *gc-notify-after*
468     post-gc-dyn-usage bytes-freed
469 ram 1.20 *gc-trigger*))))
470     (scrub-control-stack)))
471 ram 1.11 (incf *gc-run-time* (- (get-internal-run-time) start-time))))
472 ram 1.1 nil)
473    
474     ;;;
475     ;;; MAYBE-GC -- Internal
476     ;;;
477     ;;; This routine is called by the allocation miscops to decide if a GC
478     ;;; should occur. The argument, object, is the newly allocated object
479     ;;; which must be returned to the caller.
480     ;;;
481 wlott 1.4 (defun maybe-gc (&optional object)
482 wlott 1.12 (sub-gc)
483 ram 1.1 object)
484    
485     ;;;
486     ;;; GC -- Exported
487     ;;;
488     ;;; This is the user advertised garbage collection function.
489     ;;;
490 dtc 1.23 #-gencgc
491 ram 1.2 (defun gc (&optional (verbose-p *gc-verbose*))
492 ram 1.1 "Initiates a garbage collection. The optional argument, VERBOSE-P,
493 ram 1.2 which defaults to the value of the variable *GC-VERBOSE* controls
494     whether or not GC statistics are printed."
495 wlott 1.12 (sub-gc :verbose-p verbose-p :force-p t))
496 dtc 1.23 ;;;
497     #+gencgc
498     (defun gc (&key (verbose *gc-verbose*) (gen 0) (full nil))
499     "Initiates a garbage collection. The keyword :VERBOSE, which
500     defaults to the value of the variable *GC-VERBOSE* controls whether or
501 dtc 1.24 not GC statistics are printed. The keyword :GEN defaults to 0, and
502 dtc 1.23 controls the number of generations to garbage collect."
503     (sub-gc :verbose-p verbose :force-p t :gen (if full 6 gen)))
504 ram 1.1
505    
506 ram 1.2 ;;;; Auxiliary Functions.
507 wlott 1.14
508     (defun bytes-consed-between-gcs ()
509     "Return the amount of memory that will be allocated before the next garbage
510     collection is initiated. This can be set with SETF."
511     *bytes-consed-between-gcs*)
512     ;;;
513     (defun %set-bytes-consed-between-gcs (val)
514     (declare (type index val))
515     (let ((old *bytes-consed-between-gcs*))
516     (setf *bytes-consed-between-gcs* val)
517     (when *gc-trigger*
518     (setf *gc-trigger* (+ *gc-trigger* (- val old)))
519     (cond ((<= (dynamic-usage) *gc-trigger*)
520     (clear-auto-gc-trigger)
521     (set-auto-gc-trigger *gc-trigger*))
522     (t
523 ram 1.17 (system:scrub-control-stack)
524 wlott 1.14 (sub-gc)))))
525     val)
526     ;;;
527     (defsetf bytes-consed-between-gcs %set-bytes-consed-between-gcs)
528 ram 1.1
529 wlott 1.5
530 ram 1.1 (defun gc-on ()
531     "Enables the garbage collector."
532     (setq *gc-inhibit* nil)
533     (when *need-to-collect-garbage*
534 wlott 1.12 (sub-gc))
535 ram 1.1 nil)
536    
537     (defun gc-off ()
538     "Disables the garbage collector."
539     (setq *gc-inhibit* t)
540     nil)
541 wlott 1.12
542    
543    
544     ;;;; Initialization stuff.
545    
546     (defun gc-init ()
547     (when *gc-trigger*
548     (if (< *gc-trigger* (dynamic-usage))
549     (sub-gc)
550     (set-auto-gc-trigger *gc-trigger*))))
551 moore 1.27
552     ;;; setters and accessors for gencgc parameters
553    
554     #+gencgc(eval-when (load eval)
555     (alien:def-alien-type nil
556     (alien:struct generation-stats
557     (bytes-allocated c-call:int)
558     (gc-trigger c-call:int)
559     (bytes-consed-between-gc c-call:int)
560     (num-gc c-call:int)
561     (trigger-age c-call:int)
562     (cum-sum-bytes-allocated c-call:int)
563     (min-av-mem-age c-call:double)))
564    
565     (defun gencgc-stats (generation)
566     (alien:with-alien ((stats (alien:struct generation-stats)))
567     (alien:alien-funcall (alien:extern-alien "get_generation_stats"
568     (function c-call:void
569     c-call:int
570     (* (alien:struct
571     generation-stats))))
572     generation
573     (alien:addr stats))
574     (values (alien:slot stats 'bytes-allocated)
575     (alien:slot stats 'gc-trigger)
576     (alien:slot stats 'bytes-consed-between-gc)
577     (alien:slot stats 'num-gc)
578     (alien:slot stats 'trigger-age)
579     (alien:slot stats 'cum-sum-bytes-allocated)
580     (alien:slot stats 'min-av-mem-age))))
581    
582     (alien:def-alien-routine set-gc-trigger c-call:void
583     (gen c-call:int) (trigger c-call:int))
584     (alien:def-alien-routine set-trigger-age c-call:void
585     (gen c-call:int) (trigger-age c-call:int))
586     (alien:def-alien-routine set-min-mem-age c-call:void
587     (gen c-call:int) (min-mem-age c-call:double))
588     )

  ViewVC Help
Powered by ViewVC 1.1.5