/[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.1 - (hide annotations) (vendor branch)
Tue Jul 30 00:39:37 1991 UTC (22 years, 8 months ago) by wlott
Changes since 1.8: +108 -263 lines
Random mods for generational GC system.
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.1 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/gc.lisp,v 1.8.1.1 1991/07/30 00:39:37 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     (format t "~&[~:[Flipping~;Tenuring~] generation ~D.")
184     (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.1 (defun default-gc-notify-after ()
192     (when (or (null *youngest-interesting-generation*)
193     (<= generation *youngest-interesting-generation*))
194     (format t " Done.]~%")
195     (when (eq *gc-verbose* :beep)
196     (system:beep *standard-output*))
197     (force-output)))
198 ram 1.1 ;;;
199     (defparameter *gc-notify-after* #'default-gc-notify-after
200 ram 1.2 "The function bound to this variable is invoked after GC'ing (unless
201     *GC-VERBOSE* is NIL) with the amount of dynamic usage (in bytes) now
202     free, the number of bytes freed by the GC, and the new GC trigger
203     threshold. The function should notify the user that the system has
204     finished GC'ing.")
205 ram 1.1
206     ;;;
207     ;;; CAREFULLY-FUNCALL -- Internal
208     ;;;
209     ;;; Used to carefully invoke hooks.
210     ;;;
211     (defmacro carefully-funcall (function &rest args)
212     `(handler-case (funcall ,function ,@args)
213     (error (cond)
214     (warn "(FUNCALL ~S~{ ~S~}) lost:~%~A" ',function ',args cond)
215     nil)))
216    
217 wlott 1.8.1.1 ;;; DO-{BEFORE,AFTER}-GC-STUFF -- Called by C code.
218 ram 1.1 ;;;
219 wlott 1.8.1.1 ;;; These two routines are called by the C code to handle any extra work
220     ;;; that must go on before or after a GC (like calling hooks, etc.).
221 ram 1.1 ;;;
222 wlott 1.8.1.1 (defun do-before-gc-stuff (generation tenuring)
223     (when *gc-verbose*
224     (carefully-funcall *gc-notify-before* generation tenuring))
225     (dolist (before-hook *before-gc-hooks*)
226     (carefully-funcall before-hook)))
227 ram 1.1 ;;;
228 wlott 1.8.1.1 (defun do-after-gc-stuff ()
229     (dolist (after-hook *after-gc-hooks*)
230     (carefully-funcall after-hook))
231     (when *gc-verbose*
232     (carefully-funcall *gc-notify-after*)))
233 ram 1.1
234 wlott 1.8.1.1
235    
236     ;;;; GC
237    
238 ram 1.1 ;;; GC -- Exported
239     ;;;
240     ;;; This is the user advertised garbage collection function.
241     ;;;
242 wlott 1.8.1.1 (defun gc (&optional (*gc-verbose* *gc-verbose*))
243 ram 1.1 "Initiates a garbage collection. The optional argument, VERBOSE-P,
244 ram 1.2 which defaults to the value of the variable *GC-VERBOSE* controls
245     whether or not GC statistics are printed."
246 wlott 1.8.1.1 (unless (internal-gc)
247     (warn "Garbage collection currently disabled.")))

  ViewVC Help
Powered by ViewVC 1.1.5