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

Diff of /src/code/gc.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.42 by rtoy, Mon Jan 31 18:02:58 2005 UTC revision 1.42.38.3 by rtoy, Tue Feb 9 02:44:32 2010 UTC
# Line 16  Line 16 
16  ;;;  ;;;
17    
18  (in-package "EXTENSIONS")  (in-package "EXTENSIONS")
19    (intl:textdomain "cmucl")
20    
21  (export '(*before-gc-hooks* *after-gc-hooks* gc gc-on gc-off  (export '(*before-gc-hooks* *after-gc-hooks* gc gc-on gc-off
22            *bytes-consed-between-gcs* *gc-verbose* *gc-inhibit-hook*            *bytes-consed-between-gcs* *gc-verbose* *gc-inhibit-hook*
23            *gc-notify-before* *gc-notify-after* get-bytes-consed            *gc-notify-before* *gc-notify-after* get-bytes-consed
# Line 103  Line 105 
105            ((= start (dynamic-1-space-start))            ((= start (dynamic-1-space-start))
106             1)             1)
107            (t            (t
108             (error "Oh no.  The current dynamic space is missing!")))))             (error _"Oh no.  The current dynamic space is missing!")))))
109    
110    
111  ;;;; Room.  ;;;; Room.
# Line 112  Line 114 
114    (flet ((megabytes (bytes)    (flet ((megabytes (bytes)
115             ;; Convert bytes to nearest megabyte             ;; Convert bytes to nearest megabyte
116             (ceiling bytes (* 1024 1024))))             (ceiling bytes (* 1024 1024))))
117      (format t "Dynamic Space Usage:    ~13:D bytes (out of ~4:D MB).~%"      (format t _"Dynamic Space Usage:    ~13:D bytes (out of ~4:D MB).~%"
118              (dynamic-usage) (megabytes (dynamic-space-size)))              (dynamic-usage) (megabytes (dynamic-space-size)))
119      (format t "Read-Only Space Usage:  ~13:D bytes (out of ~4:D MB).~%"      (format t _"Read-Only Space Usage:  ~13:D bytes (out of ~4:D MB).~%"
120              (read-only-space-usage) (megabytes (read-only-space-size)))              (read-only-space-usage) (megabytes (read-only-space-size)))
121      (format t "Static Space Usage:     ~13:D bytes (out of ~4:D MB).~%"      (format t _"Static Space Usage:     ~13:D bytes (out of ~4:D MB).~%"
122              (static-space-usage) (megabytes (static-space-size)))              (static-space-usage) (megabytes (static-space-size)))
123      (format t "Control Stack Usage:    ~13:D bytes (out of ~4:D MB).~%"      (format t _"Control Stack Usage:    ~13:D bytes (out of ~4:D MB).~%"
124              (control-stack-usage) (megabytes (control-stack-size)))              (control-stack-usage) (megabytes (control-stack-size)))
125      (format t "Binding Stack Usage:    ~13:D bytes (out of ~4:D MB).~%"      (format t _"Binding Stack Usage:    ~13:D bytes (out of ~4:D MB).~%"
126              (binding-stack-usage) (megabytes (binding-stack-size)))              (binding-stack-usage) (megabytes (binding-stack-size)))
127      (format t "The current dynamic space is ~D.~%" (current-dynamic-space))      (format t _"The current dynamic space is ~D.~%" (current-dynamic-space))
128      (format t "Garbage collection is currently ~:[enabled~;DISABLED~].~%"      (format t _"Garbage collection is currently ~:[enabled~;DISABLED~].~%"
129              *gc-inhibit*)))              *gc-inhibit*)))
130    
131  (defun room-intermediate-info ()  (defun room-intermediate-info ()
# Line 141  Line 143 
143    
144    
145  (defun room (&optional (verbosity :default))  (defun room (&optional (verbosity :default))
146    "Prints to *STANDARD-OUTPUT* information about the state of internal    _N"Prints to *STANDARD-OUTPUT* information about the state of internal
147    storage and its management.  The optional argument controls the    storage and its management.  The optional argument controls the
148    verbosity of ROOM.  If it is T, ROOM prints out a maximal amount of    verbosity of ROOM.  If it is T, ROOM prints out a maximal amount of
149    information.  If it is NIL, ROOM prints out a minimal amount of    information.  If it is NIL, ROOM prints out a minimal amount of
# Line 158  Line 160 
160          (:default          (:default
161           (room-intermediate-info))           (room-intermediate-info))
162          (t          (t
163           (error "No way man!  The optional argument to ROOM must be T, NIL, ~           (error _"No way man!  The optional argument to ROOM must be T, NIL, ~
164                   or :DEFAULT.~%What do you think you are doing?")))                   or :DEFAULT.~%What do you think you are doing?")))
165        (room-minimal-info))        (room-minimal-info))
166    (values))    (values))
# Line 183  Line 185 
185    (cond ((null *last-bytes-in-use*)    (cond ((null *last-bytes-in-use*)
186           (pushnew           (pushnew
187            #'(lambda ()            #'(lambda ()
188                (print "resetting GC counters")                (print _"resetting GC counters")
189                (force-output)                (force-output)
190                (setf *last-bytes-in-use* nil)                (setf *last-bytes-in-use* nil)
191                (setf *total-bytes-consed* (dfixnum:make-dfixnum)))                (setf *total-bytes-consed* (dfixnum:make-dfixnum)))
# Line 221  Line 223 
223    *total-bytes-consed*)    *total-bytes-consed*)
224    
225  (defun get-bytes-consed ()  (defun get-bytes-consed ()
226    "Returns the number of bytes consed since the first time this function    _N"Returns the number of bytes consed since the first time this function
227    was called.  The first time it is called, it returns zero."    was called.  The first time it is called, it returns zero."
228    (dfixnum:dfixnum-integer (get-bytes-consed-dfixnum)))    (dfixnum:dfixnum-integer (get-bytes-consed-dfixnum)))
229    
# Line 237  Line 239 
239  ;;; will be triggered.  ;;; will be triggered.
240  ;;;  ;;;
241  (defparameter *bytes-consed-between-gcs* default-bytes-consed-between-gcs  (defparameter *bytes-consed-between-gcs* default-bytes-consed-between-gcs
242    "This number specifies the minimum number of bytes of dynamic space    _N"This number specifies the minimum number of bytes of dynamic space
243     that must be consed before the next gc will occur.")     that must be consed before the next gc will occur.")
244  ;;;  ;;;
245  (declaim (type index *bytes-consed-between-gcs*))  (declaim (type index *bytes-consed-between-gcs*))
246    
247  ;;; Public  ;;; Public
248  (defvar *gc-run-time* 0  (defvar *gc-run-time* 0
249    "The total CPU time spend doing garbage collection (as reported by    _N"The total CPU time spend doing garbage collection (as reported by
250     GET-INTERNAL-RUN-TIME.)")     GET-INTERNAL-RUN-TIME.)")
251    
252  (declaim (type index *gc-run-time*))  (declaim (type index *gc-run-time*))
# Line 302  Line 304 
304  ;;; after garbage collection occurs.  ;;; after garbage collection occurs.
305  ;;;  ;;;
306  (defvar *before-gc-hooks* nil  (defvar *before-gc-hooks* nil
307    "A list of functions that are called before garbage collection occurs.    _N"A list of functions that are called before garbage collection occurs.
308    The functions should take no arguments.")    The functions should take no arguments.")
309  ;;;  ;;;
310  (defvar *after-gc-hooks* nil  (defvar *after-gc-hooks* nil
311    "A list of functions that are called after garbage collection occurs.    _N"A list of functions that are called after garbage collection occurs.
312    The functions should take no arguments.")    The functions should take no arguments.")
313    
314  ;;;  ;;;
# Line 319  Line 321 
321  ;;; Presumably someone will call GC-ON later to collect the garbage.  ;;; Presumably someone will call GC-ON later to collect the garbage.
322  ;;;  ;;;
323  (defvar *gc-inhibit-hook* nil  (defvar *gc-inhibit-hook* nil
324    "Should be bound to a function or NIL.  If it is a function, this    _N"Should be bound to a function or NIL.  If it is a function, this
325    function should take one argument, the current amount of dynamic    function should take one argument, the current amount of dynamic
326    usage.  The function should return NIL if garbage collection should    usage.  The function should return NIL if garbage collection should
327    continue and non-NIL if it should be inhibited.  Use with caution.")    continue and non-NIL if it should be inhibited.  Use with caution.")
# Line 330  Line 332 
332  ;;; *GC-VERBOSE*  ;;; *GC-VERBOSE*
333  ;;;  ;;;
334  (defvar *gc-verbose* t  (defvar *gc-verbose* t
335    "When non-NIL, causes the functions bound to *GC-NOTIFY-BEFORE* and    _N"When non-NIL, causes the functions bound to *GC-NOTIFY-BEFORE* and
336    *GC-NOTIFY-AFTER* to be called before and after a garbage collection    *GC-NOTIFY-AFTER* to be called before and after a garbage collection
337    occurs respectively.  If :BEEP, causes the default notify functions to beep    occurs respectively.  If :BEEP, causes the default notify functions to beep
338    annoyingly.")    annoyingly.")
# Line 339  Line 341 
341  (defun default-gc-notify-before (bytes-in-use)  (defun default-gc-notify-before (bytes-in-use)
342    (when (eq *gc-verbose* :beep)    (when (eq *gc-verbose* :beep)
343      (system:beep *standard-output*))      (system:beep *standard-output*))
344    (format t "~&; [GC threshold exceeded with ~:D bytes in use.  ~    (format t _"~&; [GC threshold exceeded with ~:D bytes in use.  ~
345               Commencing GC.]~%" bytes-in-use)               Commencing GC.]~%" bytes-in-use)
346    (finish-output))    (finish-output))
347  ;;;  ;;;
348  (defparameter *gc-notify-before* #'default-gc-notify-before  (defparameter *gc-notify-before* #'default-gc-notify-before
349    "This function bound to this variable is invoked before GC'ing (unless    _N"This function bound to this variable is invoked before GC'ing (unless
350    *GC-VERBOSE* is NIL) with the current amount of dynamic usage (in    *GC-VERBOSE* is NIL) with the current amount of dynamic usage (in
351    bytes).  It should notify the user that the system is going to GC.")    bytes).  It should notify the user that the system is going to GC.")
352    
353  (defun default-gc-notify-after (bytes-retained bytes-freed new-trigger)  (defun default-gc-notify-after (bytes-retained bytes-freed new-trigger)
354    (format t "~&; [GC completed with ~:D bytes retained and ~:D bytes freed.]~%"    (format t _"~&; [GC completed with ~:D bytes retained and ~:D bytes freed.]~%"
355            bytes-retained bytes-freed)            bytes-retained bytes-freed)
356    (format t "~&; [GC will next occur when at least ~:D bytes are in use.]~%"    (format t _"~&; [GC will next occur when at least ~:D bytes are in use.]~%"
357            new-trigger)            new-trigger)
358    (when (eq *gc-verbose* :beep)    (when (eq *gc-verbose* :beep)
359      (system:beep *standard-output*))      (system:beep *standard-output*))
360    (finish-output))    (finish-output))
361  ;;;  ;;;
362  (defparameter *gc-notify-after* #'default-gc-notify-after  (defparameter *gc-notify-after* #'default-gc-notify-after
363    "The function bound to this variable is invoked after GC'ing (unless    _N"The function bound to this variable is invoked after GC'ing (unless
364    *GC-VERBOSE* is NIL) with the amount of dynamic usage (in bytes) now    *GC-VERBOSE* is NIL) with the amount of dynamic usage (in bytes) now
365    free, the number of bytes freed by the GC, and the new GC trigger    free, the number of bytes freed by the GC, and the new GC trigger
366    threshold.  The function should notify the user that the system has    threshold.  The function should notify the user that the system has
# Line 379  Line 381 
381    (let ((words (ash (+ (current-dynamic-space-start) bytes) -2)))    (let ((words (ash (+ (current-dynamic-space-start) bytes) -2)))
382      (unless (and (fixnump words) (plusp words))      (unless (and (fixnump words) (plusp words))
383        (clear-auto-gc-trigger)        (clear-auto-gc-trigger)
384        (warn "Attempt to set GC trigger to something bogus: ~S" bytes))        (warn _"Attempt to set GC trigger to something bogus: ~S" bytes))
385      (setf rt::*internal-gc-trigger* words)))      (setf rt::*internal-gc-trigger* words)))
386    
387  #-ibmrt  #-ibmrt
# Line 409  Line 411 
411  (defmacro carefully-funcall (function &rest args)  (defmacro carefully-funcall (function &rest args)
412    `(handler-case (funcall ,function ,@args)    `(handler-case (funcall ,function ,@args)
413       (error (cond)       (error (cond)
414         (warn "(FUNCALL ~S~{ ~S~}) lost:~%~A" ',function ',args cond)         (warn _"(FUNCALL ~S~{ ~S~}) lost:~%~A" ',function ',args cond)
415         nil)))         nil)))
416    
417  ;;;  ;;;
# Line 431  Line 433 
433          ;; The noise w/ symbol-value above is to keep the compiler from          ;; The noise w/ symbol-value above is to keep the compiler from
434          ;; optimizing the test away because of the type declaim for          ;; optimizing the test away because of the type declaim for
435          ;; *bytes-consed-between-gcs*.          ;; *bytes-consed-between-gcs*.
436          (warn "The value of *BYTES-CONSED-BETWEEN-GCS*, ~S, is not an ~          (warn _"The value of *BYTES-CONSED-BETWEEN-GCS*, ~S, is not an ~
437                 integer.  Resetting it to ~D." *bytes-consed-between-gcs*                 integer.  Resetting it to ~D." *bytes-consed-between-gcs*
438                 default-bytes-consed-between-gcs)                 default-bytes-consed-between-gcs)
439          (setf *bytes-consed-between-gcs* default-bytes-consed-between-gcs))          (setf *bytes-consed-between-gcs* default-bytes-consed-between-gcs))
# Line 514  Line 516 
516  ;;;  ;;;
517  #+gencgc  #+gencgc
518  (defun gc (&key (verbose *gc-verbose*) (gen 0) (full nil))  (defun gc (&key (verbose *gc-verbose*) (gen 0) (full nil))
519    "Initiates a garbage collection.  The keyword :VERBOSE, which    _N"Initiates a garbage collection.  The keyword :VERBOSE, which
520     defaults to the value of the variable *GC-VERBOSE* controls whether or     defaults to the value of the variable *GC-VERBOSE* controls whether or
521     not GC statistics are printed. The keyword :GEN defaults to 0, and     not GC statistics are printed. The keyword :GEN defaults to 0, and
522     controls the number of generations to garbage collect."     controls the number of generations to garbage collect."
# Line 524  Line 526 
526  ;;;; Auxiliary Functions.  ;;;; Auxiliary Functions.
527    
528  (defun bytes-consed-between-gcs ()  (defun bytes-consed-between-gcs ()
529    "Return the amount of memory that will be allocated before the next garbage    _N"Return the amount of memory that will be allocated before the next garbage
530     collection is initiated.  This can be set with SETF."     collection is initiated.  This can be set with SETF."
531    *bytes-consed-between-gcs*)    *bytes-consed-between-gcs*)
532  ;;;  ;;;
# Line 546  Line 548 
548    
549    
550  (defun gc-on ()  (defun gc-on ()
551    "Enables the garbage collector."    _N"Enables the garbage collector."
552    (setq *gc-inhibit* nil)    (setq *gc-inhibit* nil)
553    (when *need-to-collect-garbage*    (when *need-to-collect-garbage*
554      (sub-gc))      (sub-gc))
555    nil)    nil)
556    
557  (defun gc-off ()  (defun gc-off ()
558    "Disables the garbage collector."    _N"Disables the garbage collector."
559    (setq *gc-inhibit* t)    (setq *gc-inhibit* t)
560    nil)    nil)
561    
# Line 582  Line 584 
584      (min-av-mem-age c-call:double)))      (min-av-mem-age c-call:double)))
585    
586  (defun gencgc-stats (generation)  (defun gencgc-stats (generation)
587    "Return some GC statistics for the specified GENERATION.  The    _N"Return some GC statistics for the specified GENERATION.  The
588    statistics are the number of bytes allocated in this generation; the    statistics are the number of bytes allocated in this generation; the
589    gc-trigger; the number of bytes consed between GCs; the number of    gc-trigger; the number of bytes consed between GCs; the number of
590    GCs that have occurred; the trigger age; the cumulative number of    GCs that have occurred; the trigger age; the cumulative number of

Legend:
Removed from v.1.42  
changed lines
  Added in v.1.42.38.3

  ViewVC Help
Powered by ViewVC 1.1.5