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

Contents of /src/code/gc.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5