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

Contents of /src/code/gc.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.18 - (hide annotations)
Mon Feb 14 11:51:10 1994 UTC (20 years, 2 months ago) by ram
Branch: MAIN
Changes since 1.17: +14 -11 lines
Don't try to do verbose room if it isn't loaded.
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 ram 1.18 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/gc.lisp,v 1.18 1994/02/14 11:51:10 ram 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 wlott 1.14 *gc-run-time* bytes-consed-between-gcs))
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 ram 1.16 (vm:instance-usage :dynamic :top-n 10)
105     (vm:instance-usage :static :top-n 10))
106 ram 1.8
107 ram 1.18
108 wlott 1.4 (defun room (&optional (verbosity :default))
109     "Prints to *STANDARD-OUTPUT* information about the state of internal
110     storage and its management. The optional argument controls the
111     verbosity of ROOM. If it is T, ROOM prints out a maximal amount of
112     information. If it is NIL, ROOM prints out a minimal amount of
113     information. If it is :DEFAULT or it is not supplied, ROOM prints out
114 ram 1.8 an intermediate amount of information. See also VM:MEMORY-USAGE and
115 ram 1.16 VM:INSTANCE-USAGE for finer report control."
116 wlott 1.4 (fresh-line)
117 ram 1.18 (if (fboundp 'vm:memory-usage)
118     (case verbosity
119     ((t)
120     (room-maximal-info))
121     ((nil)
122     (room-minimal-info))
123     (:default
124     (room-intermediate-info))
125     (t
126     (error "No way man! The optional argument to ROOM must be T, NIL, ~
127     or :DEFAULT.~%What do you think you are doing?")))
128     (room-minimal-info))
129 wlott 1.12 (values))
130 wlott 1.4
131 ram 1.1
132 ram 1.2 ;;;; GET-BYTES-CONSED.
133 ram 1.1
134     ;;;
135     ;;; Internal State
136     ;;;
137     (defvar *last-bytes-in-use* nil)
138     (defvar *total-bytes-consed* 0)
139    
140 ram 1.11 (declaim (type (or index null) *last-bytes-in-use*))
141 wlott 1.15 (declaim (type integer *total-bytes-consed*))
142 ram 1.11
143 ram 1.1 ;;; GET-BYTES-CONSED -- Exported
144     ;;;
145     (defun get-bytes-consed ()
146     "Returns the number of bytes consed since the first time this function
147     was called. The first time it is called, it returns zero."
148 ram 1.11 (declare (optimize (speed 3) (safety 0)))
149 ram 1.1 (cond ((null *last-bytes-in-use*)
150     (setq *last-bytes-in-use* (dynamic-usage))
151     (setq *total-bytes-consed* 0))
152     (t
153     (let ((bytes (dynamic-usage)))
154 ram 1.11 (incf *total-bytes-consed*
155     (the index (- bytes *last-bytes-in-use*)))
156 ram 1.1 (setq *last-bytes-in-use* bytes))))
157     *total-bytes-consed*)
158 wlott 1.4
159 ram 1.1
160 ram 1.2 ;;;; Variables and Constants.
161 ram 1.1
162     ;;; The default value of *BYTES-CONSED-BETWEEN-GCS* and *GC-TRIGGER*.
163     ;;;
164     (defconstant default-bytes-consed-between-gcs 2000000)
165    
166     ;;; This variable is the user-settable variable that specifices the
167     ;;; minimum amount of dynamic space which must be consed before a GC
168     ;;; will be triggered.
169     ;;;
170     (defvar *bytes-consed-between-gcs* default-bytes-consed-between-gcs
171     "This number specifies the minimum number of bytes of dynamic space
172 wlott 1.12 that must be consed before the next gc will occur.")
173 wlott 1.14 ;;;
174 wlott 1.12 (declaim (type index *bytes-consed-between-gcs*))
175    
176 ram 1.11 ;;; Public
177     (defvar *gc-run-time* 0
178     "The total CPU time spend doing garbage collection (as reported by
179     GET-INTERNAL-RUN-TIME.)")
180    
181 wlott 1.12 (declaim (type index *gc-run-time*))
182 ram 1.11
183 ram 1.1 ;;; Internal trigger. When the dynamic usage increases beyond this
184     ;;; amount, the system notes that a garbage collection needs to occur by
185 wlott 1.5 ;;; setting *NEED-TO-COLLECT-GARBAGE* to T. It starts out as NIL meaning
186     ;;; nobody has figured out what it should be yet.
187 ram 1.1 ;;;
188 wlott 1.5 (defvar *gc-trigger* nil)
189 ram 1.1
190 ram 1.11 (declaim (type (or index null) *gc-trigger*))
191    
192 wlott 1.9 ;;; On the RT, we store the GC trigger in a ``static'' symbol instead of
193     ;;; letting magic C code handle it. It gets initialized by the startup
194     ;;; code.
195     #+ibmrt
196     (defvar rt::*internal-gc-trigger*)
197 ram 1.1
198     ;;;
199     ;;; The following specials are used to control when garbage collection
200     ;;; occurs.
201     ;;;
202    
203     ;;;
204     ;;; *GC-INHIBIT*
205     ;;;
206 ram 1.2 ;;; When non-NIL, inhibits garbage collection.
207 ram 1.1 ;;;
208     (defvar *gc-inhibit* nil)
209    
210     ;;;
211     ;;; *ALREADY-MAYBE-GCING*
212     ;;;
213     ;;; This flag is used to prevent recursive entry into the garbage
214     ;;; collector.
215     ;;;
216     (defvar *already-maybe-gcing* nil)
217    
218     ;;; When T, indicates that the dynamic usage has exceeded the value
219     ;;; *GC-TRIGGER*.
220     ;;;
221     (defvar *need-to-collect-garbage* nil)
222    
223    
224 ram 1.2 ;;;; GC Hooks.
225 ram 1.1
226     ;;;
227     ;;; *BEFORE-GC-HOOKS*
228     ;;; *AFTER-GC-HOOKS*
229     ;;;
230     ;;; These variables are a list of functions which are run before and
231     ;;; after garbage collection occurs.
232     ;;;
233     (defvar *before-gc-hooks* nil
234     "A list of functions that are called before garbage collection occurs.
235     The functions should take no arguments.")
236     ;;;
237     (defvar *after-gc-hooks* nil
238     "A list of functions that are called after garbage collection occurs.
239     The functions should take no arguments.")
240    
241     ;;;
242     ;;; *GC-INHIBIT-HOOK*
243     ;;;
244     ;;; This hook is invoked whenever SUB-GC intends to GC (unless the GC
245     ;;; was explicitly forced by calling EXT:GC). If the hook function
246     ;;; returns NIL then the GC procedes; otherwise, the GC is inhibited and
247     ;;; *GC-INHIBIT* and *NEED-TO-COLLECT-GARBAGE* are left bound to T.
248     ;;; Presumably someone will call GC-ON later to collect the garbage.
249     ;;;
250     (defvar *gc-inhibit-hook* nil
251     "Should be bound to a function or NIL. If it is a function, this
252     function should take one argument, the current amount of dynamic
253     usage. The function should return NIL if garbage collection should
254     continue and non-NIL if it should be inhibited. Use with caution.")
255    
256    
257    
258 ram 1.2 ;;;
259     ;;; *GC-VERBOSE*
260     ;;;
261     (defvar *gc-verbose* t
262     "When non-NIL, causes the functions bound to *GC-NOTIFY-BEFORE* and
263     *GC-NOTIFY-AFTER* to be called before and after a garbage collection
264 ram 1.7 occurs respectively. If :BEEP, causes the default notify functions to beep
265     annoyingly.")
266 ram 1.2
267    
268 ram 1.1 (defun default-gc-notify-before (bytes-in-use)
269 ram 1.7 (when (eq *gc-verbose* :beep)
270     (system:beep *standard-output*))
271 ram 1.1 (format t "~&[GC threshold exceeded with ~:D bytes in use. ~
272 ram 1.7 Commencing GC.]~%" bytes-in-use)
273 ram 1.1 (finish-output))
274     ;;;
275     (defparameter *gc-notify-before* #'default-gc-notify-before
276 ram 1.2 "This function bound to this variable is invoked before GC'ing (unless
277     *GC-VERBOSE* is NIL) with the current amount of dynamic usage (in
278     bytes). It should notify the user that the system is going to GC.")
279 ram 1.1
280     (defun default-gc-notify-after (bytes-retained bytes-freed new-trigger)
281     (format t "[GC completed with ~:D bytes retained and ~:D bytes freed.]~%"
282     bytes-retained bytes-freed)
283     (format t "[GC will next occur when at least ~:D bytes are in use.]~%"
284     new-trigger)
285 ram 1.7 (when (eq *gc-verbose* :beep)
286     (system:beep *standard-output*))
287 ram 1.1 (finish-output))
288     ;;;
289     (defparameter *gc-notify-after* #'default-gc-notify-after
290 ram 1.2 "The function bound to this variable is invoked after GC'ing (unless
291     *GC-VERBOSE* is NIL) with the amount of dynamic usage (in bytes) now
292     free, the number of bytes freed by the GC, and the new GC trigger
293     threshold. The function should notify the user that the system has
294     finished GC'ing.")
295 ram 1.1
296    
297 wlott 1.4 ;;;; Internal GC
298 ram 1.1
299 wlott 1.10 (alien:def-alien-routine collect-garbage c-call:int)
300 ram 1.1
301 wlott 1.9 #-ibmrt
302 wlott 1.10 (alien:def-alien-routine set-auto-gc-trigger c-call:void
303     (dynamic-usage c-call:unsigned-long))
304 wlott 1.5
305 wlott 1.9 #+ibmrt
306     (defun set-auto-gc-trigger (bytes)
307     (let ((words (ash (+ (current-dynamic-space-start) bytes) -2)))
308     (unless (and (fixnump words) (plusp words))
309     (clear-auto-gc-trigger)
310     (warn "Attempt to set GC trigger to something bogus: ~S" bytes))
311     (setf rt::*internal-gc-trigger* words)))
312    
313     #-ibmrt
314 wlott 1.10 (alien:def-alien-routine clear-auto-gc-trigger c-call:void)
315 wlott 1.9
316     #+ibmrt
317     (defun clear-auto-gc-trigger ()
318     (setf rt::*internal-gc-trigger* -1))
319 wlott 1.5
320 ram 1.1 ;;;
321     ;;; *INTERNAL-GC*
322     ;;;
323     ;;; This variables contains the function that does the real GC. This is
324     ;;; for low-level GC experimentation. Do not touch it if you do not
325     ;;; know what you are doing.
326     ;;;
327 wlott 1.12 (defvar *internal-gc* #'collect-garbage)
328 ram 1.1
329    
330     ;;;; SUB-GC
331    
332     ;;;
333     ;;; CAREFULLY-FUNCALL -- Internal
334     ;;;
335     ;;; Used to carefully invoke hooks.
336     ;;;
337     (defmacro carefully-funcall (function &rest args)
338     `(handler-case (funcall ,function ,@args)
339     (error (cond)
340     (warn "(FUNCALL ~S~{ ~S~}) lost:~%~A" ',function ',args cond)
341     nil)))
342    
343     ;;;
344     ;;; SUB-GC -- Internal
345     ;;;
346     ;;; SUB-GC decides when and if to do a garbage collection. The
347     ;;; VERBOSE-P flag controls whether or not the notify functions are
348     ;;; called. The FORCE-P flags controls if a GC should occur even if the
349     ;;; dynamic usage is not greater than *GC-TRIGGER*.
350     ;;;
351 wlott 1.12 (defun sub-gc (&key (verbose-p *gc-verbose*) force-p)
352 ram 1.1 (unless *already-maybe-gcing*
353     (let* ((*already-maybe-gcing* t)
354 ram 1.11 (start-time (get-internal-run-time))
355 ram 1.1 (pre-gc-dyn-usage (dynamic-usage)))
356 ram 1.11 (unless (integerp (symbol-value '*bytes-consed-between-gcs*))
357 wlott 1.12 ;; The noise w/ symbol-value above is to keep the compiler from
358     ;; optimizing the test away because of the type declaim for
359     ;; *bytes-consed-between-gcs*.
360 ram 1.1 (warn "The value of *BYTES-CONSED-BETWEEN-GCS*, ~S, is not an ~
361 ram 1.7 integer. Reseting it to ~D." *bytes-consed-between-gcs*
362     default-bytes-consed-between-gcs)
363 ram 1.1 (setf *bytes-consed-between-gcs* default-bytes-consed-between-gcs))
364 wlott 1.12 (when (and *gc-trigger* (> pre-gc-dyn-usage *gc-trigger*))
365 ram 1.7 (setf *need-to-collect-garbage* t))
366 ram 1.1 (when (or force-p
367     (and *need-to-collect-garbage* (not *gc-inhibit*)))
368     (when (and (not force-p)
369     *gc-inhibit-hook*
370     (carefully-funcall *gc-inhibit-hook* pre-gc-dyn-usage))
371 ram 1.7 (setf *gc-inhibit* t)
372 ram 1.1 (return-from sub-gc nil))
373 wlott 1.6 (without-interrupts
374 ram 1.7 (let ((*standard-output* *terminal-io*))
375     (when verbose-p
376     (carefully-funcall *gc-notify-before* pre-gc-dyn-usage))
377     (dolist (hook *before-gc-hooks*)
378     (carefully-funcall hook))
379     (when *gc-trigger*
380     (clear-auto-gc-trigger))
381     (funcall *internal-gc*)
382     (let* ((post-gc-dyn-usage (dynamic-usage))
383     (bytes-freed (- pre-gc-dyn-usage post-gc-dyn-usage)))
384 wlott 1.12 (when *last-bytes-in-use*
385     (incf *total-bytes-consed*
386     (- pre-gc-dyn-usage *last-bytes-in-use*))
387     (setq *last-bytes-in-use* post-gc-dyn-usage))
388 ram 1.7 (setf *need-to-collect-garbage* nil)
389     (setf *gc-trigger*
390     (+ post-gc-dyn-usage *bytes-consed-between-gcs*))
391     (set-auto-gc-trigger *gc-trigger*)
392     (dolist (hook *after-gc-hooks*)
393     (carefully-funcall hook))
394     (when verbose-p
395     (carefully-funcall *gc-notify-after*
396     post-gc-dyn-usage bytes-freed
397 ram 1.11 *gc-trigger*))))))
398     (incf *gc-run-time* (- (get-internal-run-time) start-time))))
399 ram 1.1 nil)
400    
401     ;;;
402     ;;; MAYBE-GC -- Internal
403     ;;;
404     ;;; This routine is called by the allocation miscops to decide if a GC
405     ;;; should occur. The argument, object, is the newly allocated object
406     ;;; which must be returned to the caller.
407     ;;;
408 wlott 1.4 (defun maybe-gc (&optional object)
409 wlott 1.12 (sub-gc)
410 ram 1.1 object)
411    
412     ;;;
413     ;;; GC -- Exported
414     ;;;
415     ;;; This is the user advertised garbage collection function.
416     ;;;
417 ram 1.2 (defun gc (&optional (verbose-p *gc-verbose*))
418 ram 1.1 "Initiates a garbage collection. The optional argument, VERBOSE-P,
419 ram 1.2 which defaults to the value of the variable *GC-VERBOSE* controls
420     whether or not GC statistics are printed."
421 wlott 1.12 (sub-gc :verbose-p verbose-p :force-p t))
422 ram 1.1
423    
424 ram 1.2 ;;;; Auxiliary Functions.
425 wlott 1.14
426     (defun bytes-consed-between-gcs ()
427     "Return the amount of memory that will be allocated before the next garbage
428     collection is initiated. This can be set with SETF."
429     *bytes-consed-between-gcs*)
430     ;;;
431     (defun %set-bytes-consed-between-gcs (val)
432     (declare (type index val))
433     (let ((old *bytes-consed-between-gcs*))
434     (setf *bytes-consed-between-gcs* val)
435     (when *gc-trigger*
436     (setf *gc-trigger* (+ *gc-trigger* (- val old)))
437     (cond ((<= (dynamic-usage) *gc-trigger*)
438     (clear-auto-gc-trigger)
439     (set-auto-gc-trigger *gc-trigger*))
440     (t
441 ram 1.17 (system:scrub-control-stack)
442 wlott 1.14 (sub-gc)))))
443     val)
444     ;;;
445     (defsetf bytes-consed-between-gcs %set-bytes-consed-between-gcs)
446 ram 1.1
447 wlott 1.5
448 ram 1.1 (defun gc-on ()
449     "Enables the garbage collector."
450     (setq *gc-inhibit* nil)
451     (when *need-to-collect-garbage*
452 wlott 1.12 (sub-gc))
453 ram 1.1 nil)
454    
455     (defun gc-off ()
456     "Disables the garbage collector."
457     (setq *gc-inhibit* t)
458     nil)
459 wlott 1.12
460    
461    
462     ;;;; Initialization stuff.
463    
464     (defun gc-init ()
465     (when *gc-trigger*
466     (if (< *gc-trigger* (dynamic-usage))
467     (sub-gc)
468     (set-auto-gc-trigger *gc-trigger*))))

  ViewVC Help
Powered by ViewVC 1.1.5