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

Contents of /src/code/gc.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (hide annotations)
Sun Apr 21 22:12:05 1991 UTC (23 years ago) by ram
Branch: MAIN
Changes since 1.6: +38 -35 lines
Fixed up the logic in SUB-GC somewhat so that it will always reset the GC
trigger page protections whenever it changes the lisp *GC-TRIGGER*.  This
should prevent problems with GC never happening when the reclaim goal is
increased.  Also, merged Bill's fix from the old system whereby we only frob
*GC-INHIBIT* related to the inhibit hook when the hook returns T.

And I changed the default before&after hooks to not beep unless *GC-VERBOSE* is
:BEEP, which is *not* the default.
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.7 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/gc.lisp,v 1.7 1991/04/21 22:12:05 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     *gc-notify-before* *gc-notify-after* get-bytes-consed))
24 ram 1.1
25     (in-package "LISP")
26 ram 1.2 (export '(room))
27 ram 1.1
28    
29 wlott 1.4 ;;;; DYNAMIC-USAGE and friends.
30 ram 1.1
31 wlott 1.4 (proclaim '(special *read-only-space-free-pointer*
32     *static-space-free-pointer*))
33 ram 1.1
34 wlott 1.4 (macrolet ((frob (lisp-fun c-var-name)
35     `(progn
36     (def-c-variable ,c-var-name (unsigned-byte 32))
37     (defun ,lisp-fun ()
38     (system:alien-access ,(intern (string-upcase c-var-name)))))))
39     (frob read-only-space-start "read_only_space")
40     (frob static-space-start "static_space")
41     (frob dynamic-0-space-start "dynamic_0_space")
42     (frob dynamic-1-space-start "dynamic_1_space")
43     (frob control-stack-start "control_stack")
44     (frob binding-stack-start "binding_stack")
45     (frob current-dynamic-space-start "current_dynamic_space"))
46 ram 1.1
47 wlott 1.4 (defun dynamic-usage ()
48     (- (system:sap-int (c::dynamic-space-free-pointer))
49     (current-dynamic-space-start)))
50 ram 1.1
51 wlott 1.4 (defun static-space-usage ()
52     (- (* lisp::*static-space-free-pointer* vm:word-bytes)
53     (static-space-start)))
54 ram 1.1
55 wlott 1.4 (defun read-only-space-usage ()
56     (- (* lisp::*read-only-space-free-pointer* vm:word-bytes)
57     (read-only-space-start)))
58 ram 1.1
59 wlott 1.4 (defun control-stack-usage ()
60     (- (system:sap-int (c::control-stack-pointer-sap)) (control-stack-start)))
61 ram 1.1
62 wlott 1.4 (defun binding-stack-usage ()
63     (- (system:sap-int (c::binding-stack-pointer-sap)) (binding-stack-start)))
64 ram 1.1
65    
66 wlott 1.4 (defun current-dynamic-space ()
67     (let ((start (current-dynamic-space-start)))
68     (cond ((= start (dynamic-0-space-start))
69     0)
70     ((= start (dynamic-1-space-start))
71     1)
72     (t
73     (error "Oh no. The current dynamic space is missing!")))))
74    
75 ram 1.1
76 wlott 1.4 ;;;; Room.
77 ram 1.1
78 wlott 1.4 (defun room-maximal-info ()
79     (format t "The current dynamic space is ~D.~%" (current-dynamic-space))
80     (format t "Dynamic Space Usage: ~10:D bytes.~%" (dynamic-usage))
81     (format t "Read-Only Space Usage: ~10:D bytes.~%" (read-only-space-usage))
82     (format t "Static Space Usage: ~10:D bytes.~%" (static-space-usage))
83     (format t "Control Stack Usage: ~10:D bytes.~%" (control-stack-usage))
84     (format t "Binding Stack Usage: ~10:D bytes.~%" (binding-stack-usage)))
85 ram 1.1
86 wlott 1.4 (defun room-minimal-info ()
87     (format t "Dynamic Space Usage: ~10:D bytes.~%" (dynamic-usage)))
88    
89     (defun room-intermediate-info ()
90     (format t "Dynamic Space Usage: ~10:D bytes.~%" (dynamic-usage))
91     (format t "Read-Only Space Usage: ~10:D bytes.~%" (read-only-space-usage))
92     (format t "Static Space Usage: ~10:D bytes.~%" (static-space-usage)))
93    
94     (defun room (&optional (verbosity :default))
95     "Prints to *STANDARD-OUTPUT* information about the state of internal
96     storage and its management. The optional argument controls the
97     verbosity of ROOM. If it is T, ROOM prints out a maximal amount of
98     information. If it is NIL, ROOM prints out a minimal amount of
99     information. If it is :DEFAULT or it is not supplied, ROOM prints out
100     an intermediate amount of information."
101     (fresh-line)
102     (case verbosity
103     ((t)
104     (room-maximal-info))
105     ((nil)
106     (room-minimal-info))
107     (:default
108     (room-intermediate-info))
109     (t
110     (error "No way man! The optional argument to ROOM must be T, NIL, ~
111     or :DEFAULT.~%What do you think you are doing?"))))
112    
113 ram 1.1
114 ram 1.2 ;;;; GET-BYTES-CONSED.
115 ram 1.1
116     ;;;
117     ;;; Internal State
118     ;;;
119     (defvar *last-bytes-in-use* nil)
120     (defvar *total-bytes-consed* 0)
121    
122     ;;;
123     ;;; GET-BYTES-CONSED -- Exported
124     ;;;
125     (defun get-bytes-consed ()
126     "Returns the number of bytes consed since the first time this function
127     was called. The first time it is called, it returns zero."
128     (cond ((null *last-bytes-in-use*)
129     (setq *last-bytes-in-use* (dynamic-usage))
130     (setq *total-bytes-consed* 0))
131     (t
132     (let ((bytes (dynamic-usage)))
133     (incf *total-bytes-consed* (- bytes *last-bytes-in-use*))
134     (setq *last-bytes-in-use* bytes))))
135     *total-bytes-consed*)
136 wlott 1.4
137 ram 1.1
138 ram 1.2 ;;;; Variables and Constants.
139 ram 1.1
140     ;;; The default value of *BYTES-CONSED-BETWEEN-GCS* and *GC-TRIGGER*.
141     ;;;
142     (defconstant default-bytes-consed-between-gcs 2000000)
143    
144     ;;; This variable is the user-settable variable that specifices the
145     ;;; minimum amount of dynamic space which must be consed before a GC
146     ;;; will be triggered.
147     ;;;
148     (defvar *bytes-consed-between-gcs* default-bytes-consed-between-gcs
149     "This number specifies the minimum number of bytes of dynamic space
150     that must be consed before the next gc will occur.")
151    
152     ;;; Internal trigger. When the dynamic usage increases beyond this
153     ;;; amount, the system notes that a garbage collection needs to occur by
154 wlott 1.5 ;;; setting *NEED-TO-COLLECT-GARBAGE* to T. It starts out as NIL meaning
155     ;;; nobody has figured out what it should be yet.
156 ram 1.1 ;;;
157 wlott 1.5 (defvar *gc-trigger* nil)
158 ram 1.1
159    
160     ;;;
161     ;;; The following specials are used to control when garbage collection
162     ;;; occurs.
163     ;;;
164    
165     ;;;
166     ;;; *GC-INHIBIT*
167     ;;;
168 ram 1.2 ;;; When non-NIL, inhibits garbage collection.
169 ram 1.1 ;;;
170     (defvar *gc-inhibit* nil)
171    
172     ;;;
173     ;;; *ALREADY-MAYBE-GCING*
174     ;;;
175     ;;; This flag is used to prevent recursive entry into the garbage
176     ;;; collector.
177     ;;;
178     (defvar *already-maybe-gcing* nil)
179    
180     ;;; When T, indicates that the dynamic usage has exceeded the value
181     ;;; *GC-TRIGGER*.
182     ;;;
183     (defvar *need-to-collect-garbage* nil)
184    
185    
186 ram 1.2 ;;;; GC Hooks.
187 ram 1.1
188     ;;;
189     ;;; *BEFORE-GC-HOOKS*
190     ;;; *AFTER-GC-HOOKS*
191     ;;;
192     ;;; These variables are a list of functions which are run before and
193     ;;; after garbage collection occurs.
194     ;;;
195     (defvar *before-gc-hooks* nil
196     "A list of functions that are called before garbage collection occurs.
197     The functions should take no arguments.")
198     ;;;
199     (defvar *after-gc-hooks* nil
200     "A list of functions that are called after garbage collection occurs.
201     The functions should take no arguments.")
202    
203     ;;;
204     ;;; *GC-INHIBIT-HOOK*
205     ;;;
206     ;;; This hook is invoked whenever SUB-GC intends to GC (unless the GC
207     ;;; was explicitly forced by calling EXT:GC). If the hook function
208     ;;; returns NIL then the GC procedes; otherwise, the GC is inhibited and
209     ;;; *GC-INHIBIT* and *NEED-TO-COLLECT-GARBAGE* are left bound to T.
210     ;;; Presumably someone will call GC-ON later to collect the garbage.
211     ;;;
212     (defvar *gc-inhibit-hook* nil
213     "Should be bound to a function or NIL. If it is a function, this
214     function should take one argument, the current amount of dynamic
215     usage. The function should return NIL if garbage collection should
216     continue and non-NIL if it should be inhibited. Use with caution.")
217    
218    
219    
220 ram 1.2 ;;;
221     ;;; *GC-VERBOSE*
222     ;;;
223     (defvar *gc-verbose* t
224     "When non-NIL, causes the functions bound to *GC-NOTIFY-BEFORE* and
225     *GC-NOTIFY-AFTER* to be called before and after a garbage collection
226 ram 1.7 occurs respectively. If :BEEP, causes the default notify functions to beep
227     annoyingly.")
228 ram 1.2
229    
230 ram 1.1 (defun default-gc-notify-before (bytes-in-use)
231 ram 1.7 (when (eq *gc-verbose* :beep)
232     (system:beep *standard-output*))
233 ram 1.1 (format t "~&[GC threshold exceeded with ~:D bytes in use. ~
234 ram 1.7 Commencing GC.]~%" bytes-in-use)
235 ram 1.1 (finish-output))
236     ;;;
237     (defparameter *gc-notify-before* #'default-gc-notify-before
238 ram 1.2 "This function bound to this variable is invoked before GC'ing (unless
239     *GC-VERBOSE* is NIL) with the current amount of dynamic usage (in
240     bytes). It should notify the user that the system is going to GC.")
241 ram 1.1
242     (defun default-gc-notify-after (bytes-retained bytes-freed new-trigger)
243     (format t "[GC completed with ~:D bytes retained and ~:D bytes freed.]~%"
244     bytes-retained bytes-freed)
245     (format t "[GC will next occur when at least ~:D bytes are in use.]~%"
246     new-trigger)
247 ram 1.7 (when (eq *gc-verbose* :beep)
248     (system:beep *standard-output*))
249 ram 1.1 (finish-output))
250     ;;;
251     (defparameter *gc-notify-after* #'default-gc-notify-after
252 ram 1.2 "The function bound to this variable is invoked after GC'ing (unless
253     *GC-VERBOSE* is NIL) with the amount of dynamic usage (in bytes) now
254     free, the number of bytes freed by the GC, and the new GC trigger
255     threshold. The function should notify the user that the system has
256     finished GC'ing.")
257 ram 1.1
258    
259 wlott 1.4 ;;;; Internal GC
260 ram 1.1
261 wlott 1.4 (def-c-routine ("collect_garbage" collect-garbage) (int))
262 ram 1.1
263 wlott 1.5 (def-c-routine ("set_auto_gc_trigger" set-auto-gc-trigger)
264     (void)
265     (dynamic-usage unsigned-long))
266    
267     (def-c-routine ("clear_auto_gc_trigger" clear-auto-gc-trigger)
268     (void))
269    
270    
271 ram 1.1 (defun %gc ()
272 wlott 1.4 (let ((old-usage (dynamic-usage)))
273     (collect-garbage)
274     (let ((new-bytes (dynamic-usage)))
275 ram 1.1 (when *last-bytes-in-use*
276 wlott 1.4 (incf *total-bytes-consed* (- old-usage *last-bytes-in-use*))
277     (setq *last-bytes-in-use* new-bytes)))))
278 ram 1.1
279 wlott 1.4
280 ram 1.1 ;;;
281     ;;; *INTERNAL-GC*
282     ;;;
283     ;;; This variables contains the function that does the real GC. This is
284     ;;; for low-level GC experimentation. Do not touch it if you do not
285     ;;; know what you are doing.
286     ;;;
287     (defvar *internal-gc* #'%gc)
288    
289    
290     ;;;; SUB-GC
291    
292     ;;;
293     ;;; CAREFULLY-FUNCALL -- Internal
294     ;;;
295     ;;; Used to carefully invoke hooks.
296     ;;;
297     (defmacro carefully-funcall (function &rest args)
298     `(handler-case (funcall ,function ,@args)
299     (error (cond)
300     (warn "(FUNCALL ~S~{ ~S~}) lost:~%~A" ',function ',args cond)
301     nil)))
302    
303     ;;;
304     ;;; SUB-GC -- Internal
305     ;;;
306     ;;; SUB-GC decides when and if to do a garbage collection. The
307     ;;; VERBOSE-P flag controls whether or not the notify functions are
308     ;;; called. The FORCE-P flags controls if a GC should occur even if the
309     ;;; dynamic usage is not greater than *GC-TRIGGER*.
310     ;;;
311     (defun sub-gc (verbose-p force-p)
312     (unless *already-maybe-gcing*
313     (let* ((*already-maybe-gcing* t)
314     (pre-gc-dyn-usage (dynamic-usage)))
315     (unless (integerp *bytes-consed-between-gcs*)
316     (warn "The value of *BYTES-CONSED-BETWEEN-GCS*, ~S, is not an ~
317 ram 1.7 integer. Reseting it to ~D." *bytes-consed-between-gcs*
318     default-bytes-consed-between-gcs)
319 ram 1.1 (setf *bytes-consed-between-gcs* default-bytes-consed-between-gcs))
320 ram 1.7 (when (or (not *gc-trigger*)
321     (> *bytes-consed-between-gcs* *gc-trigger*))
322     (when *gc-trigger* (clear-auto-gc-trigger))
323     (setf *gc-trigger* *bytes-consed-between-gcs*)
324     (set-auto-gc-trigger *gc-trigger*))
325     (when (> pre-gc-dyn-usage *gc-trigger*)
326     (setf *need-to-collect-garbage* t))
327 ram 1.1 (when (or force-p
328     (and *need-to-collect-garbage* (not *gc-inhibit*)))
329     (when (and (not force-p)
330     *gc-inhibit-hook*
331     (carefully-funcall *gc-inhibit-hook* pre-gc-dyn-usage))
332 ram 1.7 (setf *gc-inhibit* t)
333 ram 1.1 (return-from sub-gc nil))
334 wlott 1.6 (without-interrupts
335 ram 1.7 (let ((*standard-output* *terminal-io*))
336     (when verbose-p
337     (carefully-funcall *gc-notify-before* pre-gc-dyn-usage))
338     (dolist (hook *before-gc-hooks*)
339     (carefully-funcall hook))
340     (when *gc-trigger*
341     (clear-auto-gc-trigger))
342     (funcall *internal-gc*)
343     (let* ((post-gc-dyn-usage (dynamic-usage))
344     (bytes-freed (- pre-gc-dyn-usage post-gc-dyn-usage)))
345     (setf *need-to-collect-garbage* nil)
346     (setf *gc-trigger*
347     (+ post-gc-dyn-usage *bytes-consed-between-gcs*))
348     (set-auto-gc-trigger *gc-trigger*)
349     (dolist (hook *after-gc-hooks*)
350     (carefully-funcall hook))
351     (when verbose-p
352     (carefully-funcall *gc-notify-after*
353     post-gc-dyn-usage bytes-freed
354     *gc-trigger*))))))))
355 ram 1.1 nil)
356    
357     ;;;
358     ;;; MAYBE-GC -- Internal
359     ;;;
360     ;;; This routine is called by the allocation miscops to decide if a GC
361     ;;; should occur. The argument, object, is the newly allocated object
362     ;;; which must be returned to the caller.
363     ;;;
364 wlott 1.4 (defun maybe-gc (&optional object)
365 ram 1.2 (sub-gc *gc-verbose* nil)
366 ram 1.1 object)
367    
368     ;;;
369     ;;; GC -- Exported
370     ;;;
371     ;;; This is the user advertised garbage collection function.
372     ;;;
373 ram 1.2 (defun gc (&optional (verbose-p *gc-verbose*))
374 ram 1.1 "Initiates a garbage collection. The optional argument, VERBOSE-P,
375 ram 1.2 which defaults to the value of the variable *GC-VERBOSE* controls
376     whether or not GC statistics are printed."
377     (sub-gc verbose-p t))
378 ram 1.1
379    
380 ram 1.2 ;;;; Auxiliary Functions.
381 ram 1.1
382 wlott 1.5
383 ram 1.1 (defun gc-on ()
384     "Enables the garbage collector."
385     (setq *gc-inhibit* nil)
386 wlott 1.5 (unless *gc-trigger*
387     (setf *gc-trigger* *bytes-consed-between-gcs*)
388     (set-auto-gc-trigger *gc-trigger*))
389 ram 1.1 (when *need-to-collect-garbage*
390 ram 1.2 (sub-gc *gc-verbose* nil))
391 ram 1.1 nil)
392    
393     (defun gc-off ()
394     "Disables the garbage collector."
395     (setq *gc-inhibit* t)
396     nil)

  ViewVC Help
Powered by ViewVC 1.1.5