/[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.7 - (show annotations) (vendor branch)
Sun Oct 6 21:20:45 1991 UTC (22 years, 6 months ago) by wlott
Changes since 1.8.1.6: +6 -6 lines
Fixed some format calls.
1 ;;; -*- Mode: Lisp; Package: LISP; Log: code.log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; 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 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/gc.lisp,v 1.8.1.7 1991/10/06 21:20:45 wlott Exp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; Garbage collection and allocation related code.
15 ;;;
16 ;;; Written by Christopher Hoover, Rob MacLachlan, Dave McDonald, et al.
17 ;;; New code for MIPS port by Christopher Hoover.
18 ;;;
19
20 (in-package "EXTENSIONS")
21 (export '(*before-gc-hooks* *after-gc-hooks* gc gc-on gc-off *gc-verbose*
22 *gc-notify-before* *gc-notify-after* get-bytes-consed))
23
24 (in-package "LISP")
25 (export '(room))
26
27
28 ;;;; def-c-routines for GC interface.
29
30 (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
35 (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
61
62 ;;;; Room.
63
64 (defun room-minimal-info ()
65 (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
72 (defun room-intermediate-info ()
73 (without-gcing
74 (let ((num-generations (num-generations))
75 (total 0))
76 (format t "~D generations:~%" num-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.~%" gen bytes)
82 (incf total bytes)))
83 (format t "Total memory usage: ~10:D bytes.~%" total))))
84
85 (defun room-maximal-info ()
86 (without-gcing
87 (let ((num-generations (num-generations))
88 (total 0))
89 (format t "~D generations:~%" num-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:D bytes.~%" total))))
100
101 (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 an intermediate amount of information. See also VM:MEMORY-USAGE and
108 VM:STRUCTURE-USAGE for finer report control."
109 (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
122 ;;;; GET-BYTES-CONSED.
123
124 #|
125 ;;; 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 (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 (incf *total-bytes-consed* (- bytes *last-bytes-in-use*))
145 (setq *last-bytes-in-use* bytes))))
146 *total-bytes-consed*)
147 |#
148
149
150
151 ;;;; GC Hooks.
152
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 ;;; *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 occurs respectively. If :BEEP, causes the default notify functions to beep
174 annoyingly.")
175
176 (defvar *youngest-interesting-generation* nil)
177
178 (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 (format t "~&[~:[Flipping~;Tenuring~] generation ~D." tenuring generation)
184 (force-output)))
185 ;;;
186 (defparameter *gc-notify-before* #'default-gc-notify-before
187 "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
191 (defun default-gc-notify-after (generation words-scavenged words-transported)
192 (when (or (null *youngest-interesting-generation*)
193 (<= generation *youngest-interesting-generation*))
194 (format t " Done. ~:D words scavenged, and ~:D words transported.]~%"
195 words-scavenged words-transported)
196 (when (eq *gc-verbose* :beep)
197 (system:beep *standard-output*))
198 (force-output)))
199 ;;;
200 (defparameter *gc-notify-after* #'default-gc-notify-after
201 "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
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 ;;; DO-{BEFORE,AFTER}-GC-STUFF -- Called by C code.
219 ;;;
220 ;;; 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 ;;;
223 (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 ;;;
229 (defun do-after-gc-stuff (generation words-scavenged words-transported)
230 (dolist (after-hook *after-gc-hooks*)
231 (carefully-funcall after-hook))
232 (when *gc-verbose*
233 (carefully-funcall *gc-notify-after* generation words-scavenged
234 words-transported)))
235
236
237
238 ;;;; GC
239
240 ;;; GC -- Exported
241 ;;;
242 ;;; This is the user advertised garbage collection function.
243 ;;;
244 (defun gc (&optional (*gc-verbose* *gc-verbose*))
245 "Initiates a garbage collection. The optional argument, VERBOSE-P,
246 which defaults to the value of the variable *GC-VERBOSE* controls
247 whether or not GC statistics are printed."
248 (unless (internal-gc)
249 (warn "Garbage collection currently disabled.")))

  ViewVC Help
Powered by ViewVC 1.1.5