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

Contents of /src/code/gc.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5