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

Contents of /src/code/gc.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Mon Apr 23 13:37:24 1990 UTC (23 years, 11 months ago) by ram
Branch: MAIN
Changes since 1.2: +1 -1 lines
current-cont -> current-fp.
1 ;;; -*- Mode: Lisp; Package: LISP; Log: code.log -*-
2 ;;;
3 ;;; **********************************************************************
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 ;;; Garbage collection and allocation related code.
12 ;;;
13 ;;; Written by Christopher Hoover, Rob MacLachlan, Dave McDonald, et al.
14 ;;;
15
16 (in-package "EXTENSIONS")
17 (export '(*before-gc-hooks* *after-gc-hooks* gc gc-on gc-off
18 *bytes-consed-between-gcs* *gc-verbose* *gc-inhibit-hook*
19 *gc-notify-before* *gc-notify-after* get-bytes-consed))
20
21 (in-package "LISP")
22 (export '(room))
23
24
25
26 ;;;; Room.
27
28 (defvar alloctable-address (int-sap %fixnum-alloctable-address)
29 "A system area pointer that addresses the the alloctable.")
30
31 (defun alloc-ref (index)
32 (logior (%primitive 16bit-system-ref alloctable-address (1+ index))
33 (ash (logand %type-space-mask
34 (%primitive 16bit-system-ref alloctable-address index))
35 16)))
36
37 (defun space-usage (type)
38 (let ((base (ash type %alloc-ref-type-shift)))
39 (values (alloc-ref base)
40 (alloc-ref (+ base 8))
41 (alloc-ref (+ base 12)))))
42
43 (defconstant type-space-names
44 '#("Bignum" "Ratio" "Complex" "Short-Float" "Short-Float" "Long-Float"
45 "String" "Bit-Vector" "Integer-Vector" "Code-Vector" "General-Vector"
46 "Array" "Function" "Symbol" "List"))
47
48 (defun room-header ()
49 (fresh-line)
50 (princ " Type | Dynamic | Static | Read-Only | Total")
51 (terpri)
52 (princ "-------------------|-----------|-----------|-----------|-----------")
53 (terpri))
54
55 (defun room-summary (dynamic static read-only)
56 (princ "-------------------|-----------|-----------|-----------|-----------")
57 (format t "~% Totals: |~10:D |~10:D |~10:D =~10:D~%"
58 dynamic static read-only (+ static dynamic read-only)))
59
60 (defun describe-one-type (type dynamic static read-only)
61 (declare (fixnum type dynamic static read-only))
62 (format t "~18A |~10:D |~10:D |~10:D |~10:D~%"
63 (elt (the simple-vector type-space-names)
64 (the fixnum (- type (the fixnum %first-pointer-type))))
65 dynamic static read-only (the fixnum (+ static dynamic read-only))))
66
67 (defun room (&optional (x t) (object nil argp))
68 "Displays information about storage allocation.
69 If X is true then information is displayed broken down by types.
70 If Object is supplied then just display information for objects of
71 that type."
72 (when x
73 (let ((type (%primitive get-type object)))
74 (when (or (> type %last-pointer-type)
75 (< type %first-pointer-type))
76 (error "Objects of type ~S have no allocated storage."
77 (type-of object)))
78 (room-header)
79 (cond
80 (argp
81 (multiple-value-bind (dyn stat ro)
82 (space-usage type)
83 (describe-one-type type dyn stat ro)))
84 (t
85 (let ((cum-dyn 0)
86 (cum-stat 0)
87 (cum-ro 0))
88 (do ((type %first-pointer-type (1+ type)))
89 ((= type (1+ %last-pointer-type)))
90 (if (not (or (eq type %short-+-float-type)
91 (eq type %short---float-type)))
92 (multiple-value-bind (dyn stat ro)
93 (space-usage type)
94 (describe-one-type type dyn stat ro)
95 (incf cum-dyn dyn) (incf cum-stat stat) (incf cum-ro ro))))
96 (room-summary cum-dyn cum-stat cum-ro)))))))
97
98
99 ;;;; DYNAMIC-USAGE.
100
101 ;;;
102 ;;; DYNAMIC-USAGE -- Interface
103 ;;;
104 ;;; Return the number of bytes of dynamic storage allocated.
105 ;;;
106 (defun dynamic-usage ()
107 "Returns the number of bytes of dynamic storage currently allocated."
108 (system:%primitive dynamic-space-in-use))
109
110
111 ;;;; GET-BYTES-CONSED.
112
113 ;;;
114 ;;; Internal State
115 ;;;
116 (defvar *last-bytes-in-use* nil)
117 (defvar *total-bytes-consed* 0)
118
119 ;;;
120 ;;; GET-BYTES-CONSED -- Exported
121 ;;;
122 (defun get-bytes-consed ()
123 "Returns the number of bytes consed since the first time this function
124 was called. The first time it is called, it returns zero."
125 (cond ((null *last-bytes-in-use*)
126 (setq *last-bytes-in-use* (dynamic-usage))
127 (setq *total-bytes-consed* 0))
128 (t
129 (let ((bytes (dynamic-usage)))
130 (incf *total-bytes-consed* (- bytes *last-bytes-in-use*))
131 (setq *last-bytes-in-use* bytes))))
132 *total-bytes-consed*)
133
134
135 ;;;; Variables and Constants.
136
137 ;;; The default value of *BYTES-CONSED-BETWEEN-GCS* and *GC-TRIGGER*.
138 ;;;
139 (defconstant default-bytes-consed-between-gcs 2000000)
140
141 ;;; This variable is the user-settable variable that specifices the
142 ;;; minimum amount of dynamic space which must be consed before a GC
143 ;;; will be triggered.
144 ;;;
145 (defvar *bytes-consed-between-gcs* default-bytes-consed-between-gcs
146 "This number specifies the minimum number of bytes of dynamic space
147 that must be consed before the next gc will occur.")
148
149 ;;; Internal trigger. When the dynamic usage increases beyond this
150 ;;; amount, the system notes that a garbage collection needs to occur by
151 ;;; setting *NEED-TO-COLLECT-GARBAGE* to T.
152 ;;;
153 (defvar *gc-trigger* default-bytes-consed-between-gcs)
154
155
156
157 ;;;
158 ;;; The following specials are used to control when garbage collection
159 ;;; occurs.
160 ;;;
161
162 ;;;
163 ;;; *GC-INHIBIT*
164 ;;;
165 ;;; When non-NIL, inhibits garbage collection.
166 ;;;
167 (defvar *gc-inhibit* nil)
168
169 ;;;
170 ;;; *ALREADY-MAYBE-GCING*
171 ;;;
172 ;;; This flag is used to prevent recursive entry into the garbage
173 ;;; collector.
174 ;;;
175 (defvar *already-maybe-gcing* nil)
176
177 ;;; When T, indicates that the dynamic usage has exceeded the value
178 ;;; *GC-TRIGGER*.
179 ;;;
180 (defvar *need-to-collect-garbage* nil)
181
182
183 ;;;; GC Hooks.
184
185 ;;;
186 ;;; *BEFORE-GC-HOOKS*
187 ;;; *AFTER-GC-HOOKS*
188 ;;;
189 ;;; These variables are a list of functions which are run before and
190 ;;; after garbage collection occurs.
191 ;;;
192 (defvar *before-gc-hooks* nil
193 "A list of functions that are called before garbage collection occurs.
194 The functions should take no arguments.")
195 ;;;
196 (defvar *after-gc-hooks* nil
197 "A list of functions that are called after garbage collection occurs.
198 The functions should take no arguments.")
199
200 ;;;
201 ;;; *GC-INHIBIT-HOOK*
202 ;;;
203 ;;; This hook is invoked whenever SUB-GC intends to GC (unless the GC
204 ;;; was explicitly forced by calling EXT:GC). If the hook function
205 ;;; returns NIL then the GC procedes; otherwise, the GC is inhibited and
206 ;;; *GC-INHIBIT* and *NEED-TO-COLLECT-GARBAGE* are left bound to T.
207 ;;; Presumably someone will call GC-ON later to collect the garbage.
208 ;;;
209 (defvar *gc-inhibit-hook* nil
210 "Should be bound to a function or NIL. If it is a function, this
211 function should take one argument, the current amount of dynamic
212 usage. The function should return NIL if garbage collection should
213 continue and non-NIL if it should be inhibited. Use with caution.")
214
215
216
217 ;;;
218 ;;; *GC-VERBOSE*
219 ;;;
220 (defvar *gc-verbose* t
221 "When non-NIL, causes the functions bound to *GC-NOTIFY-BEFORE* and
222 *GC-NOTIFY-AFTER* to be called before and after a garbage collection
223 occurs respectively.")
224
225
226 (defun default-gc-notify-before (bytes-in-use)
227 (system:beep *standard-output*)
228 (format t "~&[GC threshold exceeded with ~:D bytes in use. ~
229 Commencing GC.]~%" bytes-in-use)
230 (finish-output))
231 ;;;
232 (defparameter *gc-notify-before* #'default-gc-notify-before
233 "This function bound to this variable is invoked before GC'ing (unless
234 *GC-VERBOSE* is NIL) with the current amount of dynamic usage (in
235 bytes). It should notify the user that the system is going to GC.")
236
237 (defun default-gc-notify-after (bytes-retained bytes-freed new-trigger)
238 (format t "[GC completed with ~:D bytes retained and ~:D bytes freed.]~%"
239 bytes-retained bytes-freed)
240 (format t "[GC will next occur when at least ~:D bytes are in use.]~%"
241 new-trigger)
242 (system:beep *standard-output*)
243 (finish-output))
244 ;;;
245 (defparameter *gc-notify-after* #'default-gc-notify-after
246 "The function bound to this variable is invoked after GC'ing (unless
247 *GC-VERBOSE* is NIL) with the amount of dynamic usage (in bytes) now
248 free, the number of bytes freed by the GC, and the new GC trigger
249 threshold. The function should notify the user that the system has
250 finished GC'ing.")
251
252
253 ;;;; Stack grovelling:
254
255 ;;; VECTOR-ALLOC-END -- Internal
256 ;;;
257 ;;; Return a pointer to past the end of the memory allocated for a
258 ;;; vector-like object.
259 ;;;
260 (defun vector-alloc-end (vec)
261 (%primitive pointer+
262 vec
263 (* (%primitive vector-word-length vec) %word-size)))
264
265
266 (defvar *gc-debug* nil)
267
268 ;;; PRINT-RAW-ADDR -- Interface
269 ;;;
270 ;;; Print the full address of an arbitary object.
271 ;;;
272 (defun print-raw-addr (x &optional (stream *standard-output*))
273 (let ((fix (%primitive make-fixnum x)))
274 (format stream "~4,'0X~4,'0X "
275 (logior (ash (%primitive get-type x) 11)
276 (ash (%primitive get-space x) 9)
277 (ash fix -16))
278 (logand fix #xFFFF))))
279
280
281 ;;; GC-GROVEL-STACK -- Internal
282 ;;;
283 ;;; Locate all raw pointers on stack stack, and clobber them with something
284 ;;; that won't cause GC to gag. We return a list of lists of the form:
285 ;;; (object offset stack-location*),
286 ;;;
287 ;;; where Object is some valid vector-like object pointer and Offset is an
288 ;;; offset to be added to Object. The result of this addition should be stored
289 ;;; into each Stack-Location after GC completes. We clobber the stack
290 ;;; locations with Offset for no particular reason (might aid debugging.)
291 ;;;
292 ;;; There are three major steps in the algorithm:
293 ;;;
294 ;;; 1] Find all the distinct vector-like pointers on the stack, building a
295 ;;; list of all the locations that each pointer is stored in. We do this
296 ;;; using two hash-tables: the one for code pointers is separate, since
297 ;;; they must be special-cased.
298 ;;;
299 ;;; Note that we do our scan downward from the current CONT, and thus don't
300 ;;; scan our own frame. We don't want to modify the frame for the running
301 ;;; function, as this is apt to cause problems. It isn't necessary to
302 ;;; grovel the current frame because we return before GC happens.
303 ;;;
304 ;;; 2] Sort all of the vector-like pointers (other than code vectors), and
305 ;;; scan through this list finding raw pointers based on the assumption
306 ;;; that we will always see the true pointer to the vector header before
307 ;;; any raw pointers into that vector. This exploits our GC invariant that
308 ;;; when an indexing temp is in use, the true object pointer must be live
309 ;;; on the stack or in a register. [By now, any register indexing temp
310 ;;; will have been saved on the stack.]
311 ;;;
312 ;;; During this scan, we also note any true vector pointers that point to a
313 ;;; function object.
314 ;;;
315 ;;; Whenever we locate a raw vector pointer, we create a fixup for the
316 ;;; locations holding that pointer and then clobber the locations.
317 ;;;
318 ;;; 3] Iterate over all code pointers, clobbering the locations and
319 ;;; making fixups for those pointers that point inside some function object
320 ;;; that appears on the stack. This exploits our GC invariant that a
321 ;;; *valid* code pointer only appears on the stack when some containing
322 ;;; function object also appears on the stack. Note that *invalid* code
323 ;;; pointers may appear in the stack garbage unaccompanied by any function
324 ;;; object. Such isolated code pointers are set to 0. (Code pointers in
325 ;;; the heap must always point to the code vector header, and are always
326 ;;; considered valid.)
327 ;;;
328 ;;; This different invariant for code pointers allows us to throw around
329 ;;; raw code pointers without clearing them when they are no longer needed.
330 ;;;
331 (defun gc-grovel-stack ()
332 (let ((vec-table (make-hash-table :test #'eq))
333 (code-table (make-hash-table :test #'eq))
334 (base (%primitive make-immediate-type 0 %control-stack-type))
335 (fixups ()))
336 ;;
337 ;; Find all vector-like objects on the stack, putting code vectors in a
338 ;; separate table. (step 1)
339 (do ((sp (%primitive pointer+ (%primitive current-fp)
340 (- %stack-increment))
341 (%primitive pointer+ sp (- %stack-increment))))
342 ((%primitive pointer< sp base))
343 (let* ((el (%primitive read-control-stack sp))
344 (el-type (%primitive get-type el)))
345
346 (when (and *gc-debug* (simple-vector-p el))
347 (let ((hdr (%primitive read-control-stack el)))
348 (unless (and (fixnump hdr) (> hdr 0)
349 (<= (length el) #xFFFF)
350 (<= (%primitive get-vector-subtype el)
351 3))
352 (format t "Suspicious G-vector ")
353 (print-raw-addr el)
354 (format t "at ")
355 (print-raw-addr sp)
356 (terpri))))
357
358 (when (and (< (%primitive get-space el) %static-space)
359 (<= %string-type el-type %function-type))
360 (push sp (gethash el
361 (if (eq el-type %code-type)
362 code-table
363 vec-table))))))
364
365 (let ((vecs ())
366 (functions ()))
367 (maphash #'(lambda (k v)
368 (declare (ignore v))
369 (push k vecs))
370 vec-table)
371
372 (setq vecs
373 (sort vecs
374 #'(lambda (x y)
375 (%primitive pointer< x y))))
376
377 ;;
378 ;; Iterate over non-code vector-like pointers in order (step 2.)
379 (loop
380 (unless vecs (return))
381 (let* ((base (pop vecs))
382 (end (vector-alloc-end base)))
383
384 (when (and (= (%primitive get-type base) %function-type)
385 (<= %function-entry-subtype
386 (%primitive get-vector-subtype base)
387 %function-constants-subtype))
388 (push base functions))
389
390 (loop
391 (unless vecs (return))
392 (let ((next (first vecs)))
393 (unless (%primitive pointer< next end) (return))
394 (pop vecs)
395
396 (let ((offset (%primitive pointer- next base))
397 (sps (gethash next vec-table)))
398 (dolist (sp sps)
399 (%primitive write-control-stack sp offset))
400 (push (list* base offset sps) fixups))))))
401
402 ;;
403 ;; Iterate over all code pointers (step 3.)
404 (maphash #'(lambda (code-ptr sps)
405 (dolist (fun functions
406 (dolist (sp sps)
407 (%primitive write-control-stack sp 0)))
408 (let* ((base (%primitive header-ref fun
409 %function-code-slot))
410 (end (vector-alloc-end base)))
411 (when (and (not (%primitive pointer< code-ptr base))
412 (%primitive pointer< code-ptr end))
413 (let ((offset (%primitive pointer- code-ptr base)))
414 (dolist (sp sps)
415 (%primitive write-control-stack sp offset))
416 (push (list* base offset sps) fixups))
417 (return)))))
418 code-table)
419
420 (when *gc-debug*
421 (dolist (f fixups)
422 (terpri)
423 (print-raw-addr (first f))
424 (format t "~X " (second f))
425 (dolist (sp (cddr f))
426 (print-raw-addr sp)))
427 (terpri))
428
429 fixups)))
430
431
432 ;;; GC-FIXUP-STACK -- Internal
433 ;;;
434 ;;; Given a list of GC fixups as returned by GC-GROVEL-STACK, fix up all the
435 ;;; raw pointers on the stack.
436 ;;;
437 (defun gc-fixup-stack (fixups)
438 (dolist (fixup fixups)
439 (let ((new (%primitive pointer+ (first fixup) (second fixup))))
440 (dolist (sp (cddr fixup))
441 (%primitive write-control-stack sp new)))))
442
443
444 ;;;; Internal GC
445
446 ;;; %GC -- Internal
447 ;;;
448 ;;; %GC is the real garbage collector. What we do:
449 ;;; -- Call GC-GROVEL-STACK to locate any raw pointers on the stack.
450 ;;; -- Invoke the COLLECT-GARBAGE miscop, adding the amount of garbage
451 ;;; collected to *total-bytes-consed*.
452 ;;; -- Invalidate & revalidate the old spaces to free up their memory.
453 ;;; -- Call GC-FIXUP-STACK to restore raw pointers on the stack.
454 ;;;
455 ;;; *** Warning: the stack *including the current frame* is in a somewhat
456 ;;; altered state until after GC-FIXUP-STACK is called. Don't change a single
457 ;;; character from the start of this function until after call to
458 ;;; GC-FIXUP-STACK unless you really know what you are doing.
459 ;;;
460 ;;; It is important that we not do anything that creates raw pointers between
461 ;;; the time we call GC-GROVEL-STACK and the time we invoke COLLECT-GARBAGE.
462 ;;; In particular, this means no function calls. All raw pointers on the stack
463 ;;; have been trashed, so we cannot use any raw pointers until they have been
464 ;;; regenerated. In particular, we cannot return from this function, since the
465 ;;; return PC is a raw pointer.
466 ;;;
467 ;;; We also can't expect the value of any variables allocated between the
468 ;;; grovel and fixup to persist after the fixup, since the value that variable
469 ;;; held at grovel time may have been a pointer that needed to be fixed.
470 ;;;
471 (defun %gc ()
472 (let* ((oldspace-base (ash (%primitive newspace-bit) 25))
473 (old-bytes (system:%primitive dynamic-space-in-use))
474 (result nil)
475 (fixups (gc-grovel-stack)))
476 (%primitive clear-registers)
477 (setq result (%primitive collect-garbage))
478 (let ((new-bytes (system:%primitive dynamic-space-in-use)))
479 (when *last-bytes-in-use*
480 (incf *total-bytes-consed* (- old-bytes *last-bytes-in-use*))
481 (setq *last-bytes-in-use* new-bytes)))
482 (gc-fixup-stack fixups)
483 (do* ((i %first-pointer-type (1+ i))
484 (this-space (logior oldspace-base (ash i 27))
485 (logior oldspace-base (ash i 27)))
486 (losing-gr nil))
487 ((= i (1+ %last-pointer-type))
488 (when losing-gr
489 (system:gr-error "While reclaiming VM" losing-gr)))
490 (let ((gr (mach:vm_deallocate *task-self* this-space
491 (- #x2000000 8192))))
492 (unless (eql gr mach:kern-success) (setq losing-gr gr)))
493 (let ((gr (mach:vm_allocate *task-self* this-space
494 (- #x2000000 8192) nil)))
495 (unless (eql gr mach:kern-success) (setq losing-gr gr))))
496 result))
497
498 ;;;
499 ;;; *INTERNAL-GC*
500 ;;;
501 ;;; This variables contains the function that does the real GC. This is
502 ;;; for low-level GC experimentation. Do not touch it if you do not
503 ;;; know what you are doing.
504 ;;;
505 (defvar *internal-gc* #'%gc)
506
507
508 ;;;; SUB-GC
509
510 ;;;
511 ;;; CAREFULLY-FUNCALL -- Internal
512 ;;;
513 ;;; Used to carefully invoke hooks.
514 ;;;
515 (defmacro carefully-funcall (function &rest args)
516 `(handler-case (funcall ,function ,@args)
517 (error (cond)
518 (warn "(FUNCALL ~S~{ ~S~}) lost:~%~A" ',function ',args cond)
519 nil)))
520
521 ;;;
522 ;;; SUB-GC -- Internal
523 ;;;
524 ;;; SUB-GC decides when and if to do a garbage collection. The
525 ;;; VERBOSE-P flag controls whether or not the notify functions are
526 ;;; called. The FORCE-P flags controls if a GC should occur even if the
527 ;;; dynamic usage is not greater than *GC-TRIGGER*.
528 ;;;
529 (defun sub-gc (verbose-p force-p)
530 (unless *already-maybe-gcing*
531 (let* ((*already-maybe-gcing* t)
532 (pre-gc-dyn-usage (dynamic-usage)))
533 (unless (integerp *bytes-consed-between-gcs*)
534 (warn "The value of *BYTES-CONSED-BETWEEN-GCS*, ~S, is not an ~
535 integer. Reseting it to 2000000" *bytes-consed-between-gcs*)
536 (setf *bytes-consed-between-gcs* default-bytes-consed-between-gcs))
537 (when (> *bytes-consed-between-gcs* *gc-trigger*)
538 (setf *gc-trigger* *bytes-consed-between-gcs*))
539 (when (> pre-gc-dyn-usage *gc-trigger*)
540 (setf *need-to-collect-garbage* t))
541 (when (or force-p
542 (and *need-to-collect-garbage* (not *gc-inhibit*)))
543 (setf *gc-inhibit* t) ; Set *GC-INHIBIT* to T before calling the hook
544 (when (and (not force-p)
545 *gc-inhibit-hook*
546 (carefully-funcall *gc-inhibit-hook* pre-gc-dyn-usage))
547 (return-from sub-gc nil))
548 (setf *gc-inhibit* nil) ; Reset *GC-INHIBIT*
549 (multiple-value-bind
550 (winp old-mask)
551 (mach:unix-sigsetmask lockout-interrupts)
552 (unwind-protect
553 (progn
554 (unless winp (warn "Could not set sigmask!"))
555 (let ((*standard-output* *terminal-io*))
556 (when verbose-p
557 (carefully-funcall *gc-notify-before* pre-gc-dyn-usage))
558 (dolist (hook *before-gc-hooks*)
559 (carefully-funcall hook))
560 (funcall *internal-gc*)
561 (let* ((post-gc-dyn-usage (dynamic-usage))
562 (bytes-freed (- pre-gc-dyn-usage post-gc-dyn-usage)))
563 (setf *need-to-collect-garbage* nil)
564 (setf *gc-trigger*
565 (+ post-gc-dyn-usage *bytes-consed-between-gcs*))
566 (dolist (hook *after-gc-hooks*)
567 (carefully-funcall hook))
568 (when verbose-p
569 (carefully-funcall *gc-notify-after*
570 post-gc-dyn-usage bytes-freed
571 *gc-trigger*)))))
572 (when winp
573 (unless (values (mach:unix-sigsetmask old-mask))
574 (warn "Could not restore sigmask!"))))))))
575 nil)
576
577 ;;;
578 ;;; MAYBE-GC -- Internal
579 ;;;
580 ;;; This routine is called by the allocation miscops to decide if a GC
581 ;;; should occur. The argument, object, is the newly allocated object
582 ;;; which must be returned to the caller.
583 ;;;
584 (defun maybe-gc (object)
585 (sub-gc *gc-verbose* nil)
586 object)
587
588 ;;;
589 ;;; GC -- Exported
590 ;;;
591 ;;; This is the user advertised garbage collection function.
592 ;;;
593 (defun gc (&optional (verbose-p *gc-verbose*))
594 "Initiates a garbage collection. The optional argument, VERBOSE-P,
595 which defaults to the value of the variable *GC-VERBOSE* controls
596 whether or not GC statistics are printed."
597 (sub-gc verbose-p t))
598
599
600 ;;;; Auxiliary Functions.
601
602 (defun gc-on ()
603 "Enables the garbage collector."
604 (setq *gc-inhibit* nil)
605 (when *need-to-collect-garbage*
606 (sub-gc *gc-verbose* nil))
607 nil)
608
609 (defun gc-off ()
610 "Disables the garbage collector."
611 (setq *gc-inhibit* t)
612 nil)

  ViewVC Help
Powered by ViewVC 1.1.5