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

Contents of /src/code/gc.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.28 - (hide annotations)
Tue Nov 5 22:45:40 2002 UTC (11 years, 5 months ago) by cracauer
Branch: MAIN
Changes since 1.27: +75 -17 lines
Make (time ...) and the profiler do precise measuring of space
allocation.  It will also not overflow or bomb out when consing
amounts cross most-positive fixnum.

The new profiler also has an interface to plug in your own print
function (also dictates sorting or results).

This is written on gencgc/x86 but tests indicated the fallsbacks for
other platforms work.

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

  ViewVC Help
Powered by ViewVC 1.1.5