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

Contents of /src/code/gc.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.35 - (hide annotations)
Thu May 29 12:35:05 2003 UTC (10 years, 10 months ago) by gerd
Branch: MAIN
Changes since 1.34: +10 -8 lines
	Building with cgc.

	* src/lisp/Config.FreeBSD (NM): Use linux-nm.

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

  ViewVC Help
Powered by ViewVC 1.1.5