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

Contents of /src/code/gc.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3.1.2 - (hide annotations) (vendor branch)
Mon Jun 25 20:56:00 1990 UTC (23 years, 10 months ago) by wlott
Changes since 1.3.1.1: +9 -7 lines
Fixed a few random bugs:  *static-space-free-pointer* and
*read-only-space-free-pointer* are in words, not bytes.  Made function
name usages consistent.  In a case, NIL must be in a list.  And added
a ~% at a useful place in a format string.
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.3.1.2 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/code/gc.lisp,v 1.3.1.2 1990/06/25 20:56:00 wlott Exp $
12 wlott 1.3.1.1 ;;;
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.3.1.1 ;;; 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.3.1.1 ;;;; DYNAMIC-USAGE and friends.
29 ram 1.1
30 wlott 1.3.1.1 (proclaim '(special *read-only-space-free-pointer*
31     *static-space-free-pointer*))
32 ram 1.1
33 wlott 1.3.1.1 (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.3.1.1 (defun dynamic-usage ()
47     (- (system:sap-int (c::dynamic-space-free-pointer))
48     (current-dynamic-space-start)))
49 ram 1.1
50 wlott 1.3.1.1 (defun static-space-usage ()
51 wlott 1.3.1.2 (- (* lisp::*static-space-free-pointer* vm:word-bytes)
52     (static-space-start)))
53 ram 1.1
54 wlott 1.3.1.1 (defun read-only-space-usage ()
55 wlott 1.3.1.2 (- (* lisp::*read-only-space-free-pointer* vm:word-bytes)
56     (read-only-space-start)))
57 ram 1.1
58 wlott 1.3.1.1 (defun control-stack-usage ()
59     (- (system:sap-int (c::control-stack-pointer-sap)) (control-stack-start)))
60 ram 1.1
61 wlott 1.3.1.1 (defun binding-stack-usage ()
62     (- (system:sap-int (c::binding-stack-pointer-sap)) (binding-stack-start)))
63 ram 1.1
64    
65 wlott 1.3.1.1 (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.3.1.1 ;;;; Room.
76 ram 1.1
77 wlott 1.3.1.1 (defun room-maximal-info ()
78 wlott 1.3.1.2 (format t "The current dynamic space is ~D.~%" (current-dynamic-space))
79     (format t "Dynamic Space Usage: ~10:D bytes.~%" (dynamic-usage))
80 wlott 1.3.1.1 (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.3.1.1 (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 wlott 1.3.1.2 ((nil)
105 wlott 1.3.1.1 (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 wlott 1.3.1.2 or :DEFAULT.~%What do you think you are doing?"))))
111 wlott 1.3.1.1
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.3.1.1
136 ram 1.1
137 ram 1.2 ;;;; Variables and Constants.
138 ram 1.1
139 wlott 1.3.1.1 #|
140    
141 ram 1.1 ;;; The default value of *BYTES-CONSED-BETWEEN-GCS* and *GC-TRIGGER*.
142     ;;;
143     (defconstant default-bytes-consed-between-gcs 2000000)
144    
145     ;;; This variable is the user-settable variable that specifices the
146     ;;; minimum amount of dynamic space which must be consed before a GC
147     ;;; will be triggered.
148     ;;;
149     (defvar *bytes-consed-between-gcs* default-bytes-consed-between-gcs
150     "This number specifies the minimum number of bytes of dynamic space
151     that must be consed before the next gc will occur.")
152    
153     ;;; Internal trigger. When the dynamic usage increases beyond this
154     ;;; amount, the system notes that a garbage collection needs to occur by
155     ;;; setting *NEED-TO-COLLECT-GARBAGE* to T.
156     ;;;
157     (defvar *gc-trigger* default-bytes-consed-between-gcs)
158    
159 wlott 1.3.1.1 |#
160 ram 1.1
161     ;;;
162     ;;; The following specials are used to control when garbage collection
163     ;;; occurs.
164     ;;;
165    
166     ;;;
167     ;;; *GC-INHIBIT*
168     ;;;
169 ram 1.2 ;;; When non-NIL, inhibits garbage collection.
170 ram 1.1 ;;;
171     (defvar *gc-inhibit* nil)
172    
173     ;;;
174     ;;; *ALREADY-MAYBE-GCING*
175     ;;;
176     ;;; This flag is used to prevent recursive entry into the garbage
177     ;;; collector.
178     ;;;
179     (defvar *already-maybe-gcing* nil)
180    
181     ;;; When T, indicates that the dynamic usage has exceeded the value
182     ;;; *GC-TRIGGER*.
183     ;;;
184     (defvar *need-to-collect-garbage* nil)
185    
186    
187 ram 1.2 ;;;; GC Hooks.
188 ram 1.1
189     ;;;
190     ;;; *BEFORE-GC-HOOKS*
191     ;;; *AFTER-GC-HOOKS*
192     ;;;
193     ;;; These variables are a list of functions which are run before and
194     ;;; after garbage collection occurs.
195     ;;;
196     (defvar *before-gc-hooks* nil
197     "A list of functions that are called before garbage collection occurs.
198     The functions should take no arguments.")
199     ;;;
200     (defvar *after-gc-hooks* nil
201     "A list of functions that are called after garbage collection occurs.
202     The functions should take no arguments.")
203    
204     ;;;
205     ;;; *GC-INHIBIT-HOOK*
206     ;;;
207     ;;; This hook is invoked whenever SUB-GC intends to GC (unless the GC
208     ;;; was explicitly forced by calling EXT:GC). If the hook function
209     ;;; returns NIL then the GC procedes; otherwise, the GC is inhibited and
210     ;;; *GC-INHIBIT* and *NEED-TO-COLLECT-GARBAGE* are left bound to T.
211     ;;; Presumably someone will call GC-ON later to collect the garbage.
212     ;;;
213     (defvar *gc-inhibit-hook* nil
214     "Should be bound to a function or NIL. If it is a function, this
215     function should take one argument, the current amount of dynamic
216     usage. The function should return NIL if garbage collection should
217     continue and non-NIL if it should be inhibited. Use with caution.")
218    
219    
220    
221 ram 1.2 ;;;
222     ;;; *GC-VERBOSE*
223     ;;;
224     (defvar *gc-verbose* t
225     "When non-NIL, causes the functions bound to *GC-NOTIFY-BEFORE* and
226     *GC-NOTIFY-AFTER* to be called before and after a garbage collection
227     occurs respectively.")
228    
229    
230 ram 1.1 (defun default-gc-notify-before (bytes-in-use)
231     (system:beep *standard-output*)
232     (format t "~&[GC threshold exceeded with ~:D bytes in use. ~
233     Commencing GC.]~%" bytes-in-use)
234     (finish-output))
235     ;;;
236     (defparameter *gc-notify-before* #'default-gc-notify-before
237 ram 1.2 "This function bound to this variable is invoked before GC'ing (unless
238     *GC-VERBOSE* is NIL) with the current amount of dynamic usage (in
239     bytes). It should notify the user that the system is going to GC.")
240 ram 1.1
241     (defun default-gc-notify-after (bytes-retained bytes-freed new-trigger)
242     (format t "[GC completed with ~:D bytes retained and ~:D bytes freed.]~%"
243     bytes-retained bytes-freed)
244     (format t "[GC will next occur when at least ~:D bytes are in use.]~%"
245     new-trigger)
246     (system:beep *standard-output*)
247     (finish-output))
248     ;;;
249     (defparameter *gc-notify-after* #'default-gc-notify-after
250 ram 1.2 "The function bound to this variable is invoked after GC'ing (unless
251     *GC-VERBOSE* is NIL) with the amount of dynamic usage (in bytes) now
252     free, the number of bytes freed by the GC, and the new GC trigger
253     threshold. The function should notify the user that the system has
254     finished GC'ing.")
255 ram 1.1
256    
257     ;;;; Internal GC
258    
259 wlott 1.3.1.1 (def-c-routine ("collect_garbage" collect-garbage) (int))
260    
261 ram 1.1 (defun %gc ()
262 wlott 1.3.1.1 (let ((old-usage (dynamic-usage)))
263     (collect-garbage)
264     (let ((new-bytes (dynamic-usage)))
265 ram 1.1 (when *last-bytes-in-use*
266 wlott 1.3.1.1 (incf *total-bytes-consed* (- old-usage *last-bytes-in-use*))
267     (setq *last-bytes-in-use* new-bytes)))))
268 ram 1.1
269 wlott 1.3.1.1
270 ram 1.1 ;;;
271     ;;; *INTERNAL-GC*
272     ;;;
273     ;;; This variables contains the function that does the real GC. This is
274     ;;; for low-level GC experimentation. Do not touch it if you do not
275     ;;; know what you are doing.
276     ;;;
277     (defvar *internal-gc* #'%gc)
278    
279    
280     ;;;; SUB-GC
281    
282     ;;;
283     ;;; CAREFULLY-FUNCALL -- Internal
284     ;;;
285     ;;; Used to carefully invoke hooks.
286     ;;;
287     (defmacro carefully-funcall (function &rest args)
288     `(handler-case (funcall ,function ,@args)
289     (error (cond)
290     (warn "(FUNCALL ~S~{ ~S~}) lost:~%~A" ',function ',args cond)
291     nil)))
292    
293 wlott 1.3.1.1 #|
294    
295 ram 1.1 ;;;
296     ;;; SUB-GC -- Internal
297     ;;;
298     ;;; SUB-GC decides when and if to do a garbage collection. The
299     ;;; VERBOSE-P flag controls whether or not the notify functions are
300     ;;; called. The FORCE-P flags controls if a GC should occur even if the
301     ;;; dynamic usage is not greater than *GC-TRIGGER*.
302     ;;;
303     (defun sub-gc (verbose-p force-p)
304     (unless *already-maybe-gcing*
305     (let* ((*already-maybe-gcing* t)
306     (pre-gc-dyn-usage (dynamic-usage)))
307     (unless (integerp *bytes-consed-between-gcs*)
308     (warn "The value of *BYTES-CONSED-BETWEEN-GCS*, ~S, is not an ~
309     integer. Reseting it to 2000000" *bytes-consed-between-gcs*)
310     (setf *bytes-consed-between-gcs* default-bytes-consed-between-gcs))
311     (when (> *bytes-consed-between-gcs* *gc-trigger*)
312     (setf *gc-trigger* *bytes-consed-between-gcs*))
313     (when (> pre-gc-dyn-usage *gc-trigger*)
314     (setf *need-to-collect-garbage* t))
315     (when (or force-p
316     (and *need-to-collect-garbage* (not *gc-inhibit*)))
317     (setf *gc-inhibit* t) ; Set *GC-INHIBIT* to T before calling the hook
318     (when (and (not force-p)
319     *gc-inhibit-hook*
320     (carefully-funcall *gc-inhibit-hook* pre-gc-dyn-usage))
321     (return-from sub-gc nil))
322     (setf *gc-inhibit* nil) ; Reset *GC-INHIBIT*
323     (multiple-value-bind
324     (winp old-mask)
325     (mach:unix-sigsetmask lockout-interrupts)
326     (unwind-protect
327     (progn
328     (unless winp (warn "Could not set sigmask!"))
329     (let ((*standard-output* *terminal-io*))
330     (when verbose-p
331     (carefully-funcall *gc-notify-before* pre-gc-dyn-usage))
332     (dolist (hook *before-gc-hooks*)
333     (carefully-funcall hook))
334     (funcall *internal-gc*)
335     (let* ((post-gc-dyn-usage (dynamic-usage))
336     (bytes-freed (- pre-gc-dyn-usage post-gc-dyn-usage)))
337     (setf *need-to-collect-garbage* nil)
338     (setf *gc-trigger*
339     (+ post-gc-dyn-usage *bytes-consed-between-gcs*))
340     (dolist (hook *after-gc-hooks*)
341     (carefully-funcall hook))
342     (when verbose-p
343     (carefully-funcall *gc-notify-after*
344     post-gc-dyn-usage bytes-freed
345     *gc-trigger*)))))
346     (when winp
347     (unless (values (mach:unix-sigsetmask old-mask))
348     (warn "Could not restore sigmask!"))))))))
349     nil)
350 wlott 1.3.1.1
351     |#
352    
353     (defun sub-gc (verbose-p force-p)
354     (unless *already-maybe-gcing*
355     (let* ((*already-maybe-gcing* t)
356     (pre-gc-dyn-usage (dynamic-usage)))
357     (setf *need-to-collect-garbage* t)
358     (when (or force-p
359     (and *need-to-collect-garbage* (not *gc-inhibit*)))
360     (setf *gc-inhibit* t) ; Set *GC-INHIBIT* to T before calling the hook
361     (when (and (not force-p)
362     *gc-inhibit-hook*
363     (carefully-funcall *gc-inhibit-hook* pre-gc-dyn-usage))
364     (return-from sub-gc nil))
365     (setf *gc-inhibit* nil) ; Reset *GC-INHIBIT*
366     (let ((*standard-output* *terminal-io*))
367     (when verbose-p
368     (carefully-funcall *gc-notify-before* pre-gc-dyn-usage))
369     (dolist (hook *before-gc-hooks*)
370     (carefully-funcall hook))
371     (funcall *internal-gc*)
372     (let* ((post-gc-dyn-usage (dynamic-usage))
373     (bytes-freed (- pre-gc-dyn-usage post-gc-dyn-usage)))
374     (setf *need-to-collect-garbage* nil)
375     (dolist (hook *after-gc-hooks*)
376     (carefully-funcall hook))
377     (when verbose-p
378     (carefully-funcall *gc-notify-after*
379     post-gc-dyn-usage bytes-freed 0)))))))
380     nil)
381    
382 ram 1.1
383     ;;;
384     ;;; MAYBE-GC -- Internal
385     ;;;
386     ;;; This routine is called by the allocation miscops to decide if a GC
387     ;;; should occur. The argument, object, is the newly allocated object
388     ;;; which must be returned to the caller.
389     ;;;
390     (defun maybe-gc (object)
391 ram 1.2 (sub-gc *gc-verbose* nil)
392 ram 1.1 object)
393    
394     ;;;
395     ;;; GC -- Exported
396     ;;;
397     ;;; This is the user advertised garbage collection function.
398     ;;;
399 ram 1.2 (defun gc (&optional (verbose-p *gc-verbose*))
400 ram 1.1 "Initiates a garbage collection. The optional argument, VERBOSE-P,
401 ram 1.2 which defaults to the value of the variable *GC-VERBOSE* controls
402     whether or not GC statistics are printed."
403     (sub-gc verbose-p t))
404 ram 1.1
405    
406 ram 1.2 ;;;; Auxiliary Functions.
407 ram 1.1
408     (defun gc-on ()
409     "Enables the garbage collector."
410     (setq *gc-inhibit* nil)
411     (when *need-to-collect-garbage*
412 ram 1.2 (sub-gc *gc-verbose* nil))
413 ram 1.1 nil)
414    
415     (defun gc-off ()
416     "Disables the garbage collector."
417     (setq *gc-inhibit* t)
418     nil)

  ViewVC Help
Powered by ViewVC 1.1.5