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

Contents of /src/code/gc.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8.1.6 - (hide annotations) (vendor branch)
Tue Aug 6 00:18:26 1991 UTC (22 years, 8 months ago) by wlott
Changes since 1.8.1.5: +2 -2 lines
Left out an arg to format in default-gc-notify-before.
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 wlott 1.8.1.6 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/gc.lisp,v 1.8.1.6 1991/08/06 00:18:26 wlott 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 wlott 1.8.1.1 (export '(*before-gc-hooks* *after-gc-hooks* gc gc-on gc-off *gc-verbose*
22 ram 1.2 *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.8.1.1 ;;;; def-c-routines for GC interface.
29 ram 1.1
30 wlott 1.8.1.1 (proclaim '(inline gc-on gc-off num-generations set-num-generations
31     bytes-in-use bytes-allocated-between-flips
32     set-bytes-allocated-between-flips flip-threshold
33     tenure-threshold set-tenure-threshold internal-gc))
34 ram 1.1
35 wlott 1.8.1.1 (def-c-routine ("gengc_On" gc-on) (void))
36     (def-c-routine ("gengc_Off" gc-off) (void))
37     (def-c-routine ("gengc_Generations" num-generations) (int))
38     (def-c-routine ("gengc_SetGenerations" set-num-generations) (int)
39     (count int))
40     (def-c-routine ("gengc_BytesInUse" bytes-in-use) (unsigned-long)
41     (generation int)
42     (space int))
43     (def-c-routine ("gengc_BytesAllocatedBetweenFlips"
44     bytes-allocated-between-flips)
45     (unsigned-long)
46     (generation int))
47     (def-c-routine ("gengc_SetBytesAllocatedBetweenFlips"
48     set-bytes-allocated-between-flips)
49     (void)
50     (generation int)
51     (bytes unsigned-long))
52     (def-c-routine ("gengc_FlipThreshold" flip-threshold) (unsigned-long)
53     (generation int))
54     (def-c-routine ("gengc_TenureThreshold" tenure-threshold) (unsigned-long)
55     (generation int))
56     (def-c-routine ("gengc_SetTenureThreshold" set-tenure-threshold) (void)
57     (generation int)
58     (bytes unsigned-long))
59     (def-c-routine ("gengc_InitiateGC" internal-gc) (boolean))
60 ram 1.1
61    
62 wlott 1.4 ;;;; Room.
63 ram 1.1
64 ram 1.8 (defun room-minimal-info ()
65 wlott 1.8.1.1 (without-gcing
66     (let ((result 0))
67     (dotimes (gen (num-generations))
68     (dotimes (space 3)
69     (incf result (bytes-in-use gen space))))
70     (format t "Total memory usage: ~10:D bytes.~%" result))))
71 ram 1.1
72 wlott 1.4 (defun room-intermediate-info ()
73 wlott 1.8.1.1 (without-gcing
74     (let ((num-generations (num-generations))
75     (total 0))
76     (format t "~D generations:~%")
77     (dotimes (gen num-generations)
78     (let ((bytes 0))
79     (dotimes (space 3)
80     (incf bytes (bytes-in-use gen space)))
81     (format t " Generation ~2D: ~10:D bytes.~%" bytes)
82     (incf total bytes)))
83     (format t "Total memory usage: ~10: bytes.~%" total))))
84 wlott 1.4
85 ram 1.8 (defun room-maximal-info ()
86 wlott 1.8.1.1 (without-gcing
87     (let ((num-generations (num-generations))
88     (total 0))
89     (format t "~D generations:~%")
90     (format t " Generation Scavenged Unscavenged Code Total")
91     (dotimes (gen num-generations)
92     (let* ((scav (bytes-in-use gen 0))
93     (unscav (bytes-in-use gen 1))
94     (code (bytes-in-use gen 2))
95     (bytes (+ scav unscav code)))
96     (format t " ~10@:<~D~> ~11:D ~11:D ~11:D ~11:D~%"
97     gen scav unscav code bytes)
98     (incf total bytes)))
99     (format t "Total memory usage: ~10: bytes.~%" total))))
100 ram 1.8
101 wlott 1.4 (defun room (&optional (verbosity :default))
102     "Prints to *STANDARD-OUTPUT* information about the state of internal
103     storage and its management. The optional argument controls the
104     verbosity of ROOM. If it is T, ROOM prints out a maximal amount of
105     information. If it is NIL, ROOM prints out a minimal amount of
106     information. If it is :DEFAULT or it is not supplied, ROOM prints out
107 ram 1.8 an intermediate amount of information. See also VM:MEMORY-USAGE and
108     VM:STRUCTURE-USAGE for finer report control."
109 wlott 1.4 (fresh-line)
110     (case verbosity
111     ((t)
112     (room-maximal-info))
113     ((nil)
114     (room-minimal-info))
115     (:default
116     (room-intermediate-info))
117     (t
118     (error "No way man! The optional argument to ROOM must be T, NIL, ~
119     or :DEFAULT.~%What do you think you are doing?"))))
120    
121 ram 1.1
122 ram 1.2 ;;;; GET-BYTES-CONSED.
123 ram 1.1
124 wlott 1.8.1.1 #|
125 ram 1.1 ;;; Internal State
126     ;;;
127     (defvar *last-bytes-in-use* nil)
128     (defvar *total-bytes-consed* 0)
129    
130     ;;;
131     ;;; GET-BYTES-CONSED -- Exported
132     ;;;
133     (defun get-bytes-consed ()
134     "Returns the number of bytes consed since the first time this function
135     was called. The first time it is called, it returns zero."
136 wlott 1.8.1.1 (let ((bytes 0))
137     (dotimes (gen (num-generations))
138     (dotimes (space 3)
139     (incf bytes (bytes-in-use gen space))))
140     (cond ((null *last-bytes-in-use*)
141     (setq *last-bytes-in-use* bytes)
142     (setq *total-bytes-consed* 0))
143     (t
144 ram 1.1 (incf *total-bytes-consed* (- bytes *last-bytes-in-use*))
145     (setq *last-bytes-in-use* bytes))))
146     *total-bytes-consed*)
147 wlott 1.8.1.1 |#
148 wlott 1.4
149 ram 1.1
150    
151 ram 1.2 ;;;; GC Hooks.
152 ram 1.1
153     ;;;
154     ;;; *BEFORE-GC-HOOKS*
155     ;;; *AFTER-GC-HOOKS*
156     ;;;
157     ;;; These variables are a list of functions which are run before and
158     ;;; after garbage collection occurs.
159     ;;;
160     (defvar *before-gc-hooks* nil
161     "A list of functions that are called before garbage collection occurs.
162     The functions should take no arguments.")
163     ;;;
164     (defvar *after-gc-hooks* nil
165     "A list of functions that are called after garbage collection occurs.
166     The functions should take no arguments.")
167    
168 ram 1.2 ;;; *GC-VERBOSE*
169     ;;;
170     (defvar *gc-verbose* t
171     "When non-NIL, causes the functions bound to *GC-NOTIFY-BEFORE* and
172     *GC-NOTIFY-AFTER* to be called before and after a garbage collection
173 ram 1.7 occurs respectively. If :BEEP, causes the default notify functions to beep
174     annoyingly.")
175 ram 1.2
176 wlott 1.8.1.1 (defvar *youngest-interesting-generation* nil)
177 ram 1.2
178 wlott 1.8.1.1 (defun default-gc-notify-before (generation tenuring)
179     (when (or (null *youngest-interesting-generation*)
180     (<= generation *youngest-interesting-generation*))
181     (when (eq *gc-verbose* :beep)
182     (system:beep *standard-output*))
183 wlott 1.8.1.6 (format t "~&[~:[Flipping~;Tenuring~] generation ~D." tenuring generation)
184 wlott 1.8.1.1 (force-output)))
185 ram 1.1 ;;;
186     (defparameter *gc-notify-before* #'default-gc-notify-before
187 ram 1.2 "This function bound to this variable is invoked before GC'ing (unless
188     *GC-VERBOSE* is NIL) with the current amount of dynamic usage (in
189     bytes). It should notify the user that the system is going to GC.")
190 ram 1.1
191 wlott 1.8.1.5 (defun default-gc-notify-after (generation words-scavenged words-transported)
192 wlott 1.8.1.1 (when (or (null *youngest-interesting-generation*)
193     (<= generation *youngest-interesting-generation*))
194 wlott 1.8.1.5 (format t " Done. ~:D words scavenged, and ~:D words transported.]~%"
195     words-scavenged words-transported)
196 wlott 1.8.1.1 (when (eq *gc-verbose* :beep)
197     (system:beep *standard-output*))
198     (force-output)))
199 ram 1.1 ;;;
200     (defparameter *gc-notify-after* #'default-gc-notify-after
201 ram 1.2 "The function bound to this variable is invoked after GC'ing (unless
202     *GC-VERBOSE* is NIL) with the amount of dynamic usage (in bytes) now
203     free, the number of bytes freed by the GC, and the new GC trigger
204     threshold. The function should notify the user that the system has
205     finished GC'ing.")
206 ram 1.1
207     ;;;
208     ;;; CAREFULLY-FUNCALL -- Internal
209     ;;;
210     ;;; Used to carefully invoke hooks.
211     ;;;
212     (defmacro carefully-funcall (function &rest args)
213     `(handler-case (funcall ,function ,@args)
214     (error (cond)
215     (warn "(FUNCALL ~S~{ ~S~}) lost:~%~A" ',function ',args cond)
216     nil)))
217    
218 wlott 1.8.1.1 ;;; DO-{BEFORE,AFTER}-GC-STUFF -- Called by C code.
219 ram 1.1 ;;;
220 wlott 1.8.1.1 ;;; These two routines are called by the C code to handle any extra work
221     ;;; that must go on before or after a GC (like calling hooks, etc.).
222 ram 1.1 ;;;
223 wlott 1.8.1.1 (defun do-before-gc-stuff (generation tenuring)
224     (when *gc-verbose*
225     (carefully-funcall *gc-notify-before* generation tenuring))
226     (dolist (before-hook *before-gc-hooks*)
227     (carefully-funcall before-hook)))
228 ram 1.1 ;;;
229 wlott 1.8.1.5 (defun do-after-gc-stuff (generation words-scavenged words-transported)
230 wlott 1.8.1.1 (dolist (after-hook *after-gc-hooks*)
231     (carefully-funcall after-hook))
232     (when *gc-verbose*
233 wlott 1.8.1.5 (carefully-funcall *gc-notify-after* generation words-scavenged
234     words-transported)))
235 ram 1.1
236 wlott 1.8.1.1
237    
238     ;;;; GC
239    
240 ram 1.1 ;;; GC -- Exported
241     ;;;
242     ;;; This is the user advertised garbage collection function.
243     ;;;
244 wlott 1.8.1.1 (defun gc (&optional (*gc-verbose* *gc-verbose*))
245 ram 1.1 "Initiates a garbage collection. The optional argument, VERBOSE-P,
246 ram 1.2 which defaults to the value of the variable *GC-VERBOSE* controls
247     whether or not GC statistics are printed."
248 wlott 1.8.1.1 (unless (internal-gc)
249     (warn "Garbage collection currently disabled.")))

  ViewVC Help
Powered by ViewVC 1.1.5