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

Contents of /src/code/gc.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5