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

Contents of /src/code/gc.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5