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

Contents of /src/code/gc.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5