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

Contents of /src/code/gc.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.33 - (hide annotations)
Wed Feb 12 18:35:29 2003 UTC (11 years, 2 months ago) by cracauer
Branch: MAIN
CVS Tags: release-18e-base, release-18e-pre2, cold-pcl-base, release-18e-pre1
Branch point for: release-18e-branch, cold-pcl
Changes since 1.32: +9 -5 lines
Fix a problem with the consing-free allocation counter.  If you
allocate more than most-positive-fixnum bytes between two GCs, do a
normal, possibly consing addition instead of the fast dfixnum
increment.

Also clean up the exports of the dfixnum package and define a new
operator to increment a dfixnum by any integer.

Tested: full ITA testsuite, tried the profiler, tried various
allocation patterns which failed before this fix.
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.33 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/gc.lisp,v 1.33 2003/02/12 18:35:29 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 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 toy 1.29 #+(or cgc gencgc)
61     (progn
62 cracauer 1.28 (alien:def-alien-routine get_bytes_allocated_lower c-call:int)
63     (alien:def-alien-routine get_bytes_allocated_upper c-call:int)
64    
65     (defun dynamic-usage ()
66     (dfixnum:dfixnum-pair-integer
67     (get_bytes_allocated_upper) (get_bytes_allocated_lower)))
68 toy 1.29 )
69 ram 1.20
70 wlott 1.4 (defun static-space-usage ()
71     (- (* lisp::*static-space-free-pointer* vm:word-bytes)
72     (static-space-start)))
73 ram 1.1
74 wlott 1.4 (defun read-only-space-usage ()
75     (- (* lisp::*read-only-space-free-pointer* vm:word-bytes)
76     (read-only-space-start)))
77 ram 1.1
78 wlott 1.4 (defun control-stack-usage ()
79 dtc 1.21 #-x86 (- (system:sap-int (c::control-stack-pointer-sap)) (control-stack-start))
80 ram 1.20 #+x86 (- (control-stack-end) (system:sap-int (c::control-stack-pointer-sap))) )
81 ram 1.1
82 wlott 1.4 (defun binding-stack-usage ()
83     (- (system:sap-int (c::binding-stack-pointer-sap)) (binding-stack-start)))
84 ram 1.1
85    
86 wlott 1.4 (defun current-dynamic-space ()
87     (let ((start (current-dynamic-space-start)))
88     (cond ((= start (dynamic-0-space-start))
89     0)
90     ((= start (dynamic-1-space-start))
91     1)
92     (t
93     (error "Oh no. The current dynamic space is missing!")))))
94    
95 ram 1.1
96 wlott 1.4 ;;;; Room.
97 ram 1.1
98 ram 1.8 (defun room-minimal-info ()
99 wlott 1.4 (format t "Dynamic Space Usage: ~10:D bytes.~%" (dynamic-usage))
100     (format t "Read-Only Space Usage: ~10:D bytes.~%" (read-only-space-usage))
101 wlott 1.12 (format t "Static Space Usage: ~10:D bytes.~%" (static-space-usage))
102     (format t "Control Stack Usage: ~10:D bytes.~%" (control-stack-usage))
103     (format t "Binding Stack Usage: ~10:D bytes.~%" (binding-stack-usage))
104     (format t "The current dynamic space is ~D.~%" (current-dynamic-space))
105 wlott 1.13 (format t "Garbage collection is currently ~:[enabled~;DISABLED~].~%"
106     *gc-inhibit*))
107 ram 1.1
108 wlott 1.4 (defun room-intermediate-info ()
109 ram 1.8 (room-minimal-info)
110     (vm:memory-usage :count-spaces '(:dynamic)
111     :print-spaces t
112 ram 1.20 :cutoff 0.05s0
113 ram 1.8 :print-summary nil))
114 wlott 1.4
115 ram 1.8 (defun room-maximal-info ()
116     (room-minimal-info)
117     (vm:memory-usage :count-spaces '(:static :dynamic))
118 ram 1.16 (vm:instance-usage :dynamic :top-n 10)
119     (vm:instance-usage :static :top-n 10))
120 ram 1.8
121 ram 1.18
122 wlott 1.4 (defun room (&optional (verbosity :default))
123     "Prints to *STANDARD-OUTPUT* information about the state of internal
124     storage and its management. The optional argument controls the
125     verbosity of ROOM. If it is T, ROOM prints out a maximal amount of
126     information. If it is NIL, ROOM prints out a minimal amount of
127     information. If it is :DEFAULT or it is not supplied, ROOM prints out
128 ram 1.8 an intermediate amount of information. See also VM:MEMORY-USAGE and
129 ram 1.16 VM:INSTANCE-USAGE for finer report control."
130 wlott 1.4 (fresh-line)
131 ram 1.18 (if (fboundp 'vm:memory-usage)
132     (case verbosity
133     ((t)
134     (room-maximal-info))
135     ((nil)
136     (room-minimal-info))
137     (:default
138     (room-intermediate-info))
139     (t
140     (error "No way man! The optional argument to ROOM must be T, NIL, ~
141     or :DEFAULT.~%What do you think you are doing?")))
142     (room-minimal-info))
143 wlott 1.12 (values))
144 wlott 1.4
145 ram 1.1
146 ram 1.2 ;;;; GET-BYTES-CONSED.
147 ram 1.1
148     ;;;
149     ;;; Internal State
150     ;;;
151     (defvar *last-bytes-in-use* nil)
152 cracauer 1.28 (defvar *total-bytes-consed* (dfixnum:make-dfixnum))
153 ram 1.1
154 cracauer 1.28 (declaim (type (or fixnum null) *last-bytes-in-use*))
155     (declaim (type dfixnum:dfixnum *total-bytes-consed*))
156 ram 1.11
157 ram 1.1 ;;; GET-BYTES-CONSED -- Exported
158     ;;;
159 cracauer 1.28 #+(or cgc gencgc)
160     (defun get-bytes-consed-dfixnum ()
161     ;(declare (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
162     (cond ((null *last-bytes-in-use*)
163     (pushnew
164     #'(lambda ()
165     (print "resetting GC counters")
166     (force-output)
167     (setf *last-bytes-in-use* nil)
168     (setf *total-bytes-consed* (dfixnum:make-dfixnum)))
169     ext:*before-save-initializations*)
170     (setf *last-bytes-in-use* (dynamic-usage))
171     (dfixnum:dfixnum-set-from-number *total-bytes-consed* 0))
172     (t
173     (let* ((bytes (dynamic-usage))
174     (incbytes (- bytes *last-bytes-in-use*)))
175     (if (< incbytes dfixnum::dfmax)
176     (dfixnum:dfixnum-inc-hf *total-bytes-consed* incbytes)
177     (dfixnum:dfixnum-inc-df
178     *total-bytes-consed*
179     ;; Kinda fixme - we cons, but it doesn't matter if we consed
180     ;; more than 250 Megabyte *within* this measuring period anyway.
181     (let ((df (dfixnum:make-dfixnum)))
182     (dfixnum:dfixnum-set-from-number df incbytes)
183     df)))
184     (setq *last-bytes-in-use* bytes))))
185     *total-bytes-consed*)
186    
187     #-(or cgc gencgc)
188 toy 1.30 (defun get-bytes-consed-dfixnum ()
189 ram 1.1 "Returns the number of bytes consed since the first time this function
190     was called. The first time it is called, it returns zero."
191 pw 1.26 (declare (optimize (speed 3) (safety 0)(inhibit-warnings 3)))
192 ram 1.1 (cond ((null *last-bytes-in-use*)
193 cracauer 1.28 (setq *last-bytes-in-use* (dynamic-usage))
194 toy 1.30 (setq *total-bytes-consed* (dfixnum:make-dfixnum)))
195 cracauer 1.28 (t
196     (let ((bytes (dynamic-usage)))
197 toy 1.30 (dfixnum:dfixnum-inc-hf *total-bytes-consed*
198     (the index (- bytes *last-bytes-in-use*)))
199 cracauer 1.28 (setq *last-bytes-in-use* bytes))))
200 ram 1.1 *total-bytes-consed*)
201 wlott 1.4
202 toy 1.30 (defun get-bytes-consed ()
203     "Returns the number of bytes consed since the first time this function
204     was called. The first time it is called, it returns zero."
205     (dfixnum:dfixnum-integer (get-bytes-consed-dfixnum)))
206 cracauer 1.28
207 ram 1.1
208 ram 1.2 ;;;; Variables and Constants.
209 ram 1.1
210     ;;; The default value of *BYTES-CONSED-BETWEEN-GCS* and *GC-TRIGGER*.
211     ;;;
212     (defconstant default-bytes-consed-between-gcs 2000000)
213    
214     ;;; This variable is the user-settable variable that specifices the
215     ;;; minimum amount of dynamic space which must be consed before a GC
216     ;;; will be triggered.
217     ;;;
218     (defvar *bytes-consed-between-gcs* default-bytes-consed-between-gcs
219     "This number specifies the minimum number of bytes of dynamic space
220 wlott 1.12 that must be consed before the next gc will occur.")
221 wlott 1.14 ;;;
222 wlott 1.12 (declaim (type index *bytes-consed-between-gcs*))
223    
224 ram 1.11 ;;; Public
225     (defvar *gc-run-time* 0
226     "The total CPU time spend doing garbage collection (as reported by
227     GET-INTERNAL-RUN-TIME.)")
228    
229 wlott 1.12 (declaim (type index *gc-run-time*))
230 ram 1.11
231 ram 1.1 ;;; Internal trigger. When the dynamic usage increases beyond this
232     ;;; amount, the system notes that a garbage collection needs to occur by
233 wlott 1.5 ;;; setting *NEED-TO-COLLECT-GARBAGE* to T. It starts out as NIL meaning
234     ;;; nobody has figured out what it should be yet.
235 ram 1.1 ;;;
236 wlott 1.5 (defvar *gc-trigger* nil)
237 ram 1.1
238 ram 1.11 (declaim (type (or index null) *gc-trigger*))
239    
240 wlott 1.9 ;;; On the RT, we store the GC trigger in a ``static'' symbol instead of
241     ;;; letting magic C code handle it. It gets initialized by the startup
242 ram 1.20 ;;; code. The X86 port defines this here because it uses the `ibmrt'
243     ;;; feature in the C code for allocation and binding stack access and
244     ;;; a lot of stuff wants this INTERNAL_GC_TRIGGER available as well.
245     #+(or ibmrt x86)
246     (defvar vm::*internal-gc-trigger*)
247 ram 1.1
248     ;;;
249     ;;; The following specials are used to control when garbage collection
250     ;;; occurs.
251     ;;;
252    
253     ;;;
254     ;;; *GC-INHIBIT*
255     ;;;
256 ram 1.2 ;;; When non-NIL, inhibits garbage collection.
257 ram 1.1 ;;;
258     (defvar *gc-inhibit* nil)
259    
260     ;;;
261     ;;; *ALREADY-MAYBE-GCING*
262     ;;;
263     ;;; This flag is used to prevent recursive entry into the garbage
264     ;;; collector.
265     ;;;
266     (defvar *already-maybe-gcing* nil)
267    
268     ;;; When T, indicates that the dynamic usage has exceeded the value
269     ;;; *GC-TRIGGER*.
270     ;;;
271     (defvar *need-to-collect-garbage* nil)
272    
273    
274 ram 1.2 ;;;; GC Hooks.
275 ram 1.1
276     ;;;
277     ;;; *BEFORE-GC-HOOKS*
278     ;;; *AFTER-GC-HOOKS*
279     ;;;
280     ;;; These variables are a list of functions which are run before and
281     ;;; after garbage collection occurs.
282     ;;;
283     (defvar *before-gc-hooks* nil
284     "A list of functions that are called before garbage collection occurs.
285     The functions should take no arguments.")
286     ;;;
287     (defvar *after-gc-hooks* nil
288     "A list of functions that are called after garbage collection occurs.
289     The functions should take no arguments.")
290    
291     ;;;
292     ;;; *GC-INHIBIT-HOOK*
293     ;;;
294     ;;; This hook is invoked whenever SUB-GC intends to GC (unless the GC
295     ;;; was explicitly forced by calling EXT:GC). If the hook function
296     ;;; returns NIL then the GC procedes; otherwise, the GC is inhibited and
297     ;;; *GC-INHIBIT* and *NEED-TO-COLLECT-GARBAGE* are left bound to T.
298     ;;; Presumably someone will call GC-ON later to collect the garbage.
299     ;;;
300     (defvar *gc-inhibit-hook* nil
301     "Should be bound to a function or NIL. If it is a function, this
302     function should take one argument, the current amount of dynamic
303     usage. The function should return NIL if garbage collection should
304     continue and non-NIL if it should be inhibited. Use with caution.")
305    
306    
307    
308 ram 1.2 ;;;
309     ;;; *GC-VERBOSE*
310     ;;;
311     (defvar *gc-verbose* t
312     "When non-NIL, causes the functions bound to *GC-NOTIFY-BEFORE* and
313     *GC-NOTIFY-AFTER* to be called before and after a garbage collection
314 ram 1.7 occurs respectively. If :BEEP, causes the default notify functions to beep
315     annoyingly.")
316 ram 1.2
317    
318 ram 1.1 (defun default-gc-notify-before (bytes-in-use)
319 ram 1.7 (when (eq *gc-verbose* :beep)
320     (system:beep *standard-output*))
321 toy 1.31 (format t "~&; [GC threshold exceeded with ~:D bytes in use. ~
322 ram 1.7 Commencing GC.]~%" bytes-in-use)
323 ram 1.1 (finish-output))
324     ;;;
325     (defparameter *gc-notify-before* #'default-gc-notify-before
326 ram 1.2 "This function bound to this variable is invoked before GC'ing (unless
327     *GC-VERBOSE* is NIL) with the current amount of dynamic usage (in
328     bytes). It should notify the user that the system is going to GC.")
329 ram 1.1
330     (defun default-gc-notify-after (bytes-retained bytes-freed new-trigger)
331 toy 1.31 (format t "~&; [GC completed with ~:D bytes retained and ~:D bytes freed.]~%"
332 ram 1.1 bytes-retained bytes-freed)
333 toy 1.31 (format t "~&; [GC will next occur when at least ~:D bytes are in use.]~%"
334 ram 1.1 new-trigger)
335 ram 1.7 (when (eq *gc-verbose* :beep)
336     (system:beep *standard-output*))
337 ram 1.1 (finish-output))
338     ;;;
339     (defparameter *gc-notify-after* #'default-gc-notify-after
340 ram 1.2 "The function bound to this variable is invoked after GC'ing (unless
341     *GC-VERBOSE* is NIL) with the amount of dynamic usage (in bytes) now
342     free, the number of bytes freed by the GC, and the new GC trigger
343     threshold. The function should notify the user that the system has
344     finished GC'ing.")
345 ram 1.1
346    
347 wlott 1.4 ;;;; Internal GC
348 ram 1.1
349 dtc 1.23 (alien:def-alien-routine collect-garbage c-call:int
350     #+gencgc (last-gen c-call:int))
351 ram 1.1
352 wlott 1.9 #-ibmrt
353 wlott 1.10 (alien:def-alien-routine set-auto-gc-trigger c-call:void
354     (dynamic-usage c-call:unsigned-long))
355 wlott 1.5
356 wlott 1.9 #+ibmrt
357     (defun set-auto-gc-trigger (bytes)
358     (let ((words (ash (+ (current-dynamic-space-start) bytes) -2)))
359     (unless (and (fixnump words) (plusp words))
360     (clear-auto-gc-trigger)
361     (warn "Attempt to set GC trigger to something bogus: ~S" bytes))
362     (setf rt::*internal-gc-trigger* words)))
363    
364     #-ibmrt
365 wlott 1.10 (alien:def-alien-routine clear-auto-gc-trigger c-call:void)
366 wlott 1.9
367     #+ibmrt
368     (defun clear-auto-gc-trigger ()
369     (setf rt::*internal-gc-trigger* -1))
370 wlott 1.5
371 ram 1.1 ;;;
372     ;;; *INTERNAL-GC*
373     ;;;
374     ;;; This variables contains the function that does the real GC. This is
375     ;;; for low-level GC experimentation. Do not touch it if you do not
376     ;;; know what you are doing.
377     ;;;
378 wlott 1.12 (defvar *internal-gc* #'collect-garbage)
379 ram 1.1
380    
381     ;;;; SUB-GC
382    
383     ;;;
384     ;;; CAREFULLY-FUNCALL -- Internal
385     ;;;
386     ;;; Used to carefully invoke hooks.
387     ;;;
388     (defmacro carefully-funcall (function &rest args)
389     `(handler-case (funcall ,function ,@args)
390     (error (cond)
391     (warn "(FUNCALL ~S~{ ~S~}) lost:~%~A" ',function ',args cond)
392     nil)))
393    
394     ;;;
395     ;;; SUB-GC -- Internal
396     ;;;
397     ;;; SUB-GC decides when and if to do a garbage collection. The
398     ;;; VERBOSE-P flag controls whether or not the notify functions are
399     ;;; called. The FORCE-P flags controls if a GC should occur even if the
400     ;;; dynamic usage is not greater than *GC-TRIGGER*.
401     ;;;
402 dtc 1.23 ;;; For GENCGC all generations < GEN will be GC'ed.
403     ;;;
404     (defun sub-gc (&key (verbose-p *gc-verbose*) force-p #+gencgc (gen 0))
405 ram 1.1 (unless *already-maybe-gcing*
406     (let* ((*already-maybe-gcing* t)
407 ram 1.11 (start-time (get-internal-run-time))
408 ram 1.1 (pre-gc-dyn-usage (dynamic-usage)))
409 ram 1.11 (unless (integerp (symbol-value '*bytes-consed-between-gcs*))
410 wlott 1.12 ;; The noise w/ symbol-value above is to keep the compiler from
411     ;; optimizing the test away because of the type declaim for
412     ;; *bytes-consed-between-gcs*.
413 ram 1.1 (warn "The value of *BYTES-CONSED-BETWEEN-GCS*, ~S, is not an ~
414 ram 1.7 integer. Reseting it to ~D." *bytes-consed-between-gcs*
415     default-bytes-consed-between-gcs)
416 ram 1.1 (setf *bytes-consed-between-gcs* default-bytes-consed-between-gcs))
417 wlott 1.12 (when (and *gc-trigger* (> pre-gc-dyn-usage *gc-trigger*))
418 ram 1.7 (setf *need-to-collect-garbage* t))
419 ram 1.1 (when (or force-p
420     (and *need-to-collect-garbage* (not *gc-inhibit*)))
421     (when (and (not force-p)
422     *gc-inhibit-hook*
423     (carefully-funcall *gc-inhibit-hook* pre-gc-dyn-usage))
424 ram 1.7 (setf *gc-inhibit* t)
425 ram 1.1 (return-from sub-gc nil))
426 wlott 1.6 (without-interrupts
427 ram 1.7 (let ((*standard-output* *terminal-io*))
428     (when verbose-p
429     (carefully-funcall *gc-notify-before* pre-gc-dyn-usage))
430     (dolist (hook *before-gc-hooks*)
431     (carefully-funcall hook))
432     (when *gc-trigger*
433     (clear-auto-gc-trigger))
434 dtc 1.23 #-gencgc (funcall *internal-gc*)
435     #+gencgc (if (eq *internal-gc* #'collect-garbage)
436     (funcall *internal-gc* gen)
437 cracauer 1.28 (funcall *internal-gc*))
438 ram 1.7 (let* ((post-gc-dyn-usage (dynamic-usage))
439     (bytes-freed (- pre-gc-dyn-usage post-gc-dyn-usage)))
440 wlott 1.12 (when *last-bytes-in-use*
441 cracauer 1.33 #+nil
442     (when verbose-p
443 cracauer 1.28 (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 cracauer 1.33 (let ((correction (- pre-gc-dyn-usage *last-bytes-in-use*)))
451     (if (<= correction dfixnum::dfmax)
452     (dfixnum:dfixnum-inc-hf *total-bytes-consed* correction)
453     ;; give up on not consing
454     (dfixnum:dfixnum-inc-integer *total-bytes-consed*
455     correction)))
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