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

Contents of /src/code/gc.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5