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

Contents of /src/code/gc.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.42.38.2 - (show annotations)
Mon Feb 8 20:21:44 2010 UTC (4 years, 2 months ago) by rtoy
Branch: intl-branch
Changes since 1.42.38.1: +34 -34 lines
Mark translatable strings.
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 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/gc.lisp,v 1.42.38.2 2010/02/08 20:21:44 rtoy Exp $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Garbage collection and allocation related code.
13 ;;;
14 ;;; Written by Christopher Hoover, Rob MacLachlan, Dave McDonald, et al.
15 ;;; New code for MIPS port by Christopher Hoover.
16 ;;;
17
18 (in-package "EXTENSIONS")
19 (intl:textdomain "cmucl")
20
21 (export '(*before-gc-hooks* *after-gc-hooks* gc gc-on gc-off
22 *bytes-consed-between-gcs* *gc-verbose* *gc-inhibit-hook*
23 *gc-notify-before* *gc-notify-after* get-bytes-consed
24 *gc-run-time* bytes-consed-between-gcs
25 get-bytes-consed-dfixnum))
26
27 (in-package "LISP")
28 (export '(room))
29
30 #+gencgc
31 (sys:register-lisp-runtime-feature :gencgc)
32
33
34 ;;;; DYNAMIC-USAGE and friends.
35
36 (declaim (special *read-only-space-free-pointer*
37 *static-space-free-pointer*))
38
39 (eval-when (compile eval)
40 (defmacro c-var-frob (lisp-fun c-var-name)
41 `(progn
42 (declaim (inline ,lisp-fun))
43 (defun ,lisp-fun ()
44 (alien:extern-alien ,c-var-name (alien:unsigned 32))))))
45
46 (c-var-frob read-only-space-start "read_only_space")
47 (c-var-frob static-space-start "static_space")
48 (c-var-frob dynamic-0-space-start "dynamic_0_space")
49 (c-var-frob dynamic-1-space-start "dynamic_1_space")
50 (c-var-frob control-stack-start "control_stack")
51 #+x86 (c-var-frob control-stack-end "control_stack_end")
52 (c-var-frob binding-stack-start "binding_stack")
53 (c-var-frob current-dynamic-space-start "current_dynamic_space")
54
55 (c-var-frob read-only-space-size "read_only_space_size")
56 (c-var-frob binding-stack-size "binding_stack_size")
57 (c-var-frob static-space-size "static_space_size")
58 (c-var-frob control-stack-size "control_stack_size")
59 (c-var-frob dynamic-space-size "dynamic_space_size")
60 (declaim (inline dynamic-usage))
61
62 #-(or cgc gencgc)
63 (defun dynamic-usage ()
64 (the (unsigned-byte 32)
65 (- (system:sap-int (c::dynamic-space-free-pointer))
66 (current-dynamic-space-start))))
67
68 ;; #+(or cgc gencgc)
69 ;; (c-var-frob dynamic-usage "bytes_allocated")
70
71 #+gencgc
72 (progn
73 (alien:def-alien-routine get_bytes_allocated_lower c-call:int)
74 (alien:def-alien-routine get_bytes_allocated_upper c-call:int)
75
76 (defun dynamic-usage ()
77 (dfixnum:dfixnum-pair-integer
78 (get_bytes_allocated_upper) (get_bytes_allocated_lower))))
79
80 #+cgc
81 (c-var-frob dynamic-usage "bytes_allocated")
82
83 (defun static-space-usage ()
84 (- (* lisp::*static-space-free-pointer* #-amd64 vm:word-bytes
85 #+amd64 4) ; won't be necessary when amd64 uses 4-bit lowtag
86 (static-space-start)))
87
88 (defun read-only-space-usage ()
89 (- (* lisp::*read-only-space-free-pointer* #-amd64 vm:word-bytes
90 #+amd64 4) ; won't be necessary when amd64 uses 4-bit lowtag
91 (read-only-space-start)))
92
93 (defun control-stack-usage ()
94 #-(or x86 amd64) (- (system:sap-int (c::control-stack-pointer-sap)) (control-stack-start))
95 #+(or x86 amd64) (- (control-stack-end) (system:sap-int (c::control-stack-pointer-sap))) )
96
97 (defun binding-stack-usage ()
98 (- (system:sap-int (c::binding-stack-pointer-sap)) (binding-stack-start)))
99
100
101 (defun current-dynamic-space ()
102 (let ((start (current-dynamic-space-start)))
103 (cond ((= start (dynamic-0-space-start))
104 0)
105 ((= start (dynamic-1-space-start))
106 1)
107 (t
108 (error _"Oh no. The current dynamic space is missing!")))))
109
110
111 ;;;; Room.
112
113 (defun room-minimal-info ()
114 (flet ((megabytes (bytes)
115 ;; Convert bytes to nearest megabyte
116 (ceiling bytes (* 1024 1024))))
117 (format t _"Dynamic Space Usage: ~13:D bytes (out of ~4:D MB).~%"
118 (dynamic-usage) (megabytes (dynamic-space-size)))
119 (format t _"Read-Only Space Usage: ~13:D bytes (out of ~4:D MB).~%"
120 (read-only-space-usage) (megabytes (read-only-space-size)))
121 (format t _"Static Space Usage: ~13:D bytes (out of ~4:D MB).~%"
122 (static-space-usage) (megabytes (static-space-size)))
123 (format t _"Control Stack Usage: ~13:D bytes (out of ~4:D MB).~%"
124 (control-stack-usage) (megabytes (control-stack-size)))
125 (format t _"Binding Stack Usage: ~13:D bytes (out of ~4:D MB).~%"
126 (binding-stack-usage) (megabytes (binding-stack-size)))
127 (format t _"The current dynamic space is ~D.~%" (current-dynamic-space))
128 (format t _"Garbage collection is currently ~:[enabled~;DISABLED~].~%"
129 *gc-inhibit*)))
130
131 (defun room-intermediate-info ()
132 (room-minimal-info)
133 (vm:memory-usage :count-spaces '(:dynamic)
134 :print-spaces t
135 :cutoff 0.05s0
136 :print-summary nil))
137
138 (defun room-maximal-info ()
139 (room-minimal-info)
140 (vm:memory-usage :count-spaces '(:static :dynamic))
141 (vm:instance-usage :dynamic :top-n 10)
142 (vm:instance-usage :static :top-n 10))
143
144
145 (defun room (&optional (verbosity :default))
146 _N"Prints to *STANDARD-OUTPUT* information about the state of internal
147 storage and its management. The optional argument controls the
148 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
150 information. If it is :DEFAULT or it is not supplied, ROOM prints out
151 an intermediate amount of information. See also VM:MEMORY-USAGE and
152 VM:INSTANCE-USAGE for finer report control."
153 (fresh-line)
154 (if (fboundp 'vm:memory-usage)
155 (case verbosity
156 ((t)
157 (room-maximal-info))
158 ((nil)
159 (room-minimal-info))
160 (:default
161 (room-intermediate-info))
162 (t
163 (error _"No way man! The optional argument to ROOM must be T, NIL, ~
164 or :DEFAULT.~%What do you think you are doing?")))
165 (room-minimal-info))
166 (values))
167
168
169 ;;;; GET-BYTES-CONSED.
170
171 ;;;
172 ;;; Internal State
173 ;;;
174 (defvar *last-bytes-in-use* nil)
175 (defvar *total-bytes-consed* (dfixnum:make-dfixnum))
176
177 (declaim (type (or (unsigned-byte 32) null) *last-bytes-in-use*))
178 (declaim (type dfixnum:dfixnum *total-bytes-consed*))
179
180 ;;; GET-BYTES-CONSED -- Exported
181 ;;;
182 #+(or cgc gencgc)
183 (defun get-bytes-consed-dfixnum ()
184 ;(declare (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
185 (cond ((null *last-bytes-in-use*)
186 (pushnew
187 #'(lambda ()
188 (print _"resetting GC counters")
189 (force-output)
190 (setf *last-bytes-in-use* nil)
191 (setf *total-bytes-consed* (dfixnum:make-dfixnum)))
192 ext:*before-save-initializations*)
193 (setf *last-bytes-in-use* (dynamic-usage))
194 (dfixnum:dfixnum-set-from-number *total-bytes-consed* 0))
195 (t
196 (let* ((bytes (dynamic-usage))
197 (incbytes (- bytes *last-bytes-in-use*)))
198 (if (< incbytes dfixnum::dfmax)
199 (dfixnum:dfixnum-inc-hf *total-bytes-consed* incbytes)
200 (dfixnum:dfixnum-inc-df
201 *total-bytes-consed*
202 ;; Kinda fixme - we cons, but it doesn't matter if we consed
203 ;; more than 250 Megabyte *within* this measuring period anyway.
204 (let ((df (dfixnum:make-dfixnum)))
205 (dfixnum:dfixnum-set-from-number df incbytes)
206 df)))
207 (setq *last-bytes-in-use* bytes))))
208 *total-bytes-consed*)
209
210 #-(or cgc gencgc)
211 (defun get-bytes-consed-dfixnum ()
212 _N"Returns the number of bytes consed since the first time this function
213 was called. The first time it is called, it returns zero."
214 (declare (optimize (speed 3) (safety 0)(inhibit-warnings 3)))
215 (cond ((null *last-bytes-in-use*)
216 (setq *last-bytes-in-use* (dynamic-usage))
217 (setq *total-bytes-consed* (dfixnum:make-dfixnum)))
218 (t
219 (let ((bytes (dynamic-usage)))
220 (dfixnum:dfixnum-inc-hf *total-bytes-consed*
221 (the index (- bytes *last-bytes-in-use*)))
222 (setq *last-bytes-in-use* bytes))))
223 *total-bytes-consed*)
224
225 (defun get-bytes-consed ()
226 _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."
228 (dfixnum:dfixnum-integer (get-bytes-consed-dfixnum)))
229
230
231 ;;;; Variables and Constants.
232
233 ;;; The default value of *BYTES-CONSED-BETWEEN-GCS* and *GC-TRIGGER*.
234 ;;;
235 (defconstant default-bytes-consed-between-gcs 12000000)
236
237 ;;; This variable is the user-settable variable that specifices the
238 ;;; minimum amount of dynamic space which must be consed before a GC
239 ;;; will be triggered.
240 ;;;
241 (defparameter *bytes-consed-between-gcs* default-bytes-consed-between-gcs
242 _N"This number specifies the minimum number of bytes of dynamic space
243 that must be consed before the next gc will occur.")
244 ;;;
245 (declaim (type index *bytes-consed-between-gcs*))
246
247 ;;; Public
248 (defvar *gc-run-time* 0
249 _N"The total CPU time spend doing garbage collection (as reported by
250 GET-INTERNAL-RUN-TIME.)")
251
252 (declaim (type index *gc-run-time*))
253
254 ;;; Internal trigger. When the dynamic usage increases beyond this
255 ;;; amount, the system notes that a garbage collection needs to occur by
256 ;;; setting *NEED-TO-COLLECT-GARBAGE* to T. It starts out as NIL meaning
257 ;;; nobody has figured out what it should be yet.
258 ;;;
259 (defvar *gc-trigger* nil)
260
261 (declaim (type (or (unsigned-byte 32) null) *gc-trigger*))
262
263 ;;; On the RT, we store the GC trigger in a ``static'' symbol instead of
264 ;;; letting magic C code handle it. It gets initialized by the startup
265 ;;; code. The X86 port defines this here because it uses the `ibmrt'
266 ;;; feature in the C code for allocation and binding stack access and
267 ;;; a lot of stuff wants this INTERNAL_GC_TRIGGER available as well.
268 #+(or ibmrt x86)
269 (defvar vm::*internal-gc-trigger*)
270
271 ;;;
272 ;;; The following specials are used to control when garbage collection
273 ;;; occurs.
274 ;;;
275
276 ;;;
277 ;;; *GC-INHIBIT*
278 ;;;
279 ;;; When non-NIL, inhibits garbage collection.
280 ;;;
281 (defvar *gc-inhibit* nil)
282
283 ;;;
284 ;;; *ALREADY-MAYBE-GCING*
285 ;;;
286 ;;; This flag is used to prevent recursive entry into the garbage
287 ;;; collector.
288 ;;;
289 (defvar *already-maybe-gcing* nil)
290
291 ;;; When T, indicates that the dynamic usage has exceeded the value
292 ;;; *GC-TRIGGER*.
293 ;;;
294 (defvar *need-to-collect-garbage* nil)
295
296
297 ;;;; GC Hooks.
298
299 ;;;
300 ;;; *BEFORE-GC-HOOKS*
301 ;;; *AFTER-GC-HOOKS*
302 ;;;
303 ;;; These variables are a list of functions which are run before and
304 ;;; after garbage collection occurs.
305 ;;;
306 (defvar *before-gc-hooks* nil
307 _N"A list of functions that are called before garbage collection occurs.
308 The functions should take no arguments.")
309 ;;;
310 (defvar *after-gc-hooks* nil
311 _N"A list of functions that are called after garbage collection occurs.
312 The functions should take no arguments.")
313
314 ;;;
315 ;;; *GC-INHIBIT-HOOK*
316 ;;;
317 ;;; This hook is invoked whenever SUB-GC intends to GC (unless the GC
318 ;;; was explicitly forced by calling EXT:GC). If the hook function
319 ;;; returns NIL then the GC procedes; otherwise, the GC is inhibited and
320 ;;; *GC-INHIBIT* and *NEED-TO-COLLECT-GARBAGE* are left bound to T.
321 ;;; Presumably someone will call GC-ON later to collect the garbage.
322 ;;;
323 (defvar *gc-inhibit-hook* nil
324 _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
326 usage. The function should return NIL if garbage collection should
327 continue and non-NIL if it should be inhibited. Use with caution.")
328
329
330
331 ;;;
332 ;;; *GC-VERBOSE*
333 ;;;
334 (defvar *gc-verbose* t
335 _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
337 occurs respectively. If :BEEP, causes the default notify functions to beep
338 annoyingly.")
339
340
341 (defun default-gc-notify-before (bytes-in-use)
342 (when (eq *gc-verbose* :beep)
343 (system:beep *standard-output*))
344 (format t _"~&; [GC threshold exceeded with ~:D bytes in use. ~
345 Commencing GC.]~%" bytes-in-use)
346 (finish-output))
347 ;;;
348 (defparameter *gc-notify-before* #'default-gc-notify-before
349 _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
351 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)
354 (format t _"~&; [GC completed with ~:D bytes retained and ~:D bytes freed.]~%"
355 bytes-retained bytes-freed)
356 (format t _"~&; [GC will next occur when at least ~:D bytes are in use.]~%"
357 new-trigger)
358 (when (eq *gc-verbose* :beep)
359 (system:beep *standard-output*))
360 (finish-output))
361 ;;;
362 (defparameter *gc-notify-after* #'default-gc-notify-after
363 _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
365 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
367 finished GC'ing.")
368
369
370 ;;;; Internal GC
371
372 (alien:def-alien-routine collect-garbage c-call:int
373 #+gencgc (last-gen c-call:int))
374
375 #-ibmrt
376 (alien:def-alien-routine set-auto-gc-trigger c-call:void
377 (dynamic-usage c-call:unsigned-long))
378
379 #+ibmrt
380 (defun set-auto-gc-trigger (bytes)
381 (let ((words (ash (+ (current-dynamic-space-start) bytes) -2)))
382 (unless (and (fixnump words) (plusp words))
383 (clear-auto-gc-trigger)
384 (warn _"Attempt to set GC trigger to something bogus: ~S" bytes))
385 (setf rt::*internal-gc-trigger* words)))
386
387 #-ibmrt
388 (alien:def-alien-routine clear-auto-gc-trigger c-call:void)
389
390 #+ibmrt
391 (defun clear-auto-gc-trigger ()
392 (setf rt::*internal-gc-trigger* -1))
393
394 ;;;
395 ;;; *INTERNAL-GC*
396 ;;;
397 ;;; This variables contains the function that does the real GC. This is
398 ;;; for low-level GC experimentation. Do not touch it if you do not
399 ;;; know what you are doing.
400 ;;;
401 (defvar *internal-gc* #'collect-garbage)
402
403
404 ;;;; SUB-GC
405
406 ;;;
407 ;;; CAREFULLY-FUNCALL -- Internal
408 ;;;
409 ;;; Used to carefully invoke hooks.
410 ;;;
411 (defmacro carefully-funcall (function &rest args)
412 `(handler-case (funcall ,function ,@args)
413 (error (cond)
414 (warn _"(FUNCALL ~S~{ ~S~}) lost:~%~A" ',function ',args cond)
415 nil)))
416
417 ;;;
418 ;;; SUB-GC -- Internal
419 ;;;
420 ;;; SUB-GC decides when and if to do a garbage collection. The
421 ;;; VERBOSE-P flag controls whether or not the notify functions are
422 ;;; called. The FORCE-P flags controls if a GC should occur even if the
423 ;;; dynamic usage is not greater than *GC-TRIGGER*.
424 ;;;
425 ;;; For GENCGC all generations < GEN will be GC'ed.
426 ;;;
427 (defun sub-gc (&key (verbose-p *gc-verbose*) force-p #+gencgc (gen 0))
428 (unless *already-maybe-gcing*
429 (let* ((*already-maybe-gcing* t)
430 (start-time (get-internal-run-time))
431 (pre-gc-dyn-usage (dynamic-usage)))
432 (unless (integerp (symbol-value '*bytes-consed-between-gcs*))
433 ;; The noise w/ symbol-value above is to keep the compiler from
434 ;; optimizing the test away because of the type declaim for
435 ;; *bytes-consed-between-gcs*.
436 (warn _"The value of *BYTES-CONSED-BETWEEN-GCS*, ~S, is not an ~
437 integer. Resetting it to ~D." *bytes-consed-between-gcs*
438 default-bytes-consed-between-gcs)
439 (setf *bytes-consed-between-gcs* default-bytes-consed-between-gcs))
440 (when (and *gc-trigger* (>= pre-gc-dyn-usage *gc-trigger*))
441 (setf *need-to-collect-garbage* t))
442 (when (or force-p
443 (and *need-to-collect-garbage* (not *gc-inhibit*)))
444 (when (and (not force-p)
445 *gc-inhibit-hook*
446 (carefully-funcall *gc-inhibit-hook* pre-gc-dyn-usage))
447 (setf *gc-inhibit* t)
448 (return-from sub-gc nil))
449 (without-interrupts
450 (let ((*standard-output* *terminal-io*))
451 (when verbose-p
452 (carefully-funcall *gc-notify-before* pre-gc-dyn-usage))
453 (dolist (hook *before-gc-hooks*)
454 (carefully-funcall hook))
455 (when *gc-trigger*
456 (clear-auto-gc-trigger))
457 #-gencgc (funcall *internal-gc*)
458 #+gencgc (if (eq *internal-gc* #'collect-garbage)
459 (funcall *internal-gc* gen)
460 (funcall *internal-gc*))
461 (let* ((post-gc-dyn-usage (dynamic-usage))
462 (bytes-freed (- pre-gc-dyn-usage post-gc-dyn-usage)))
463 (when *last-bytes-in-use*
464 #+nil
465 (when verbose-p
466 (format
467 t "~&Adjusting *last-bytes-in-use* from ~:D to ~:D, gen ~d, pre ~:D ~%"
468 *last-bytes-in-use*
469 post-gc-dyn-usage
470 gen
471 pre-gc-dyn-usage)
472 (force-output))
473 (let ((correction (- pre-gc-dyn-usage *last-bytes-in-use*)))
474 (if (<= correction dfixnum::dfmax)
475 (dfixnum:dfixnum-inc-hf *total-bytes-consed* correction)
476 ;; give up on not consing
477 (dfixnum:dfixnum-inc-integer *total-bytes-consed*
478 correction)))
479 (setq *last-bytes-in-use* post-gc-dyn-usage))
480 (setf *need-to-collect-garbage* nil)
481 (setf *gc-trigger*
482 (+ post-gc-dyn-usage *bytes-consed-between-gcs*))
483 (set-auto-gc-trigger *gc-trigger*)
484 (dolist (hook *after-gc-hooks*)
485 (carefully-funcall hook))
486 (when verbose-p
487 (carefully-funcall *gc-notify-after*
488 post-gc-dyn-usage bytes-freed
489 *gc-trigger*))))
490 (scrub-control-stack)))
491 (incf *gc-run-time* (- (get-internal-run-time) start-time))))
492 nil)
493
494 ;;;
495 ;;; MAYBE-GC -- Internal
496 ;;;
497 ;;; This routine is called by the allocation miscops to decide if a GC
498 ;;; should occur. The argument, object, is the newly allocated object
499 ;;; which must be returned to the caller.
500 ;;;
501 (defun maybe-gc (&optional object)
502 (sub-gc)
503 object)
504
505 ;;;
506 ;;; GC -- Exported
507 ;;;
508 ;;; This is the user advertised garbage collection function.
509 ;;;
510 #-gencgc
511 (defun gc (&optional (verbose-p *gc-verbose*))
512 _N"Initiates a garbage collection. The optional argument, VERBOSE-P,
513 which defaults to the value of the variable *GC-VERBOSE* controls
514 whether or not GC statistics are printed."
515 (sub-gc :verbose-p verbose-p :force-p t))
516 ;;;
517 #+gencgc
518 (defun gc (&key (verbose *gc-verbose*) (gen 0) (full nil))
519 _N"Initiates a garbage collection. The keyword :VERBOSE, which
520 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
522 controls the number of generations to garbage collect."
523 (sub-gc :verbose-p verbose :force-p t :gen (if full 6 gen)))
524
525
526 ;;;; Auxiliary Functions.
527
528 (defun bytes-consed-between-gcs ()
529 _N"Return the amount of memory that will be allocated before the next garbage
530 collection is initiated. This can be set with SETF."
531 *bytes-consed-between-gcs*)
532 ;;;
533 (defun %set-bytes-consed-between-gcs (val)
534 (declare (type index val))
535 (let ((old *bytes-consed-between-gcs*))
536 (setf *bytes-consed-between-gcs* val)
537 (when *gc-trigger*
538 (setf *gc-trigger* (+ *gc-trigger* (- val old)))
539 (cond ((<= (dynamic-usage) *gc-trigger*)
540 (clear-auto-gc-trigger)
541 (set-auto-gc-trigger *gc-trigger*))
542 (t
543 (system:scrub-control-stack)
544 (sub-gc)))))
545 val)
546 ;;;
547 (defsetf bytes-consed-between-gcs %set-bytes-consed-between-gcs)
548
549
550 (defun gc-on ()
551 _N"Enables the garbage collector."
552 (setq *gc-inhibit* nil)
553 (when *need-to-collect-garbage*
554 (sub-gc))
555 nil)
556
557 (defun gc-off ()
558 _N"Disables the garbage collector."
559 (setq *gc-inhibit* t)
560 nil)
561
562
563
564 ;;;; Initialization stuff.
565
566 (defun gc-init ()
567 (when *gc-trigger*
568 (if (< *gc-trigger* (dynamic-usage))
569 (sub-gc)
570 (set-auto-gc-trigger *gc-trigger*))))
571
572 ;;; setters and accessors for gencgc parameters
573
574 #+gencgc
575 (eval-when (load eval)
576 (alien:def-alien-type nil
577 (alien:struct generation-stats
578 (bytes-allocated c-call:int)
579 (gc-trigger c-call:int)
580 (bytes-consed-between-gc c-call:int)
581 (num-gc c-call:int)
582 (trigger-age c-call:int)
583 (cum-sum-bytes-allocated c-call:int)
584 (min-av-mem-age c-call:double)))
585
586 (defun gencgc-stats (generation)
587 _N"Return some GC statistics for the specified GENERATION. The
588 statistics are the number of bytes allocated in this generation; the
589 gc-trigger; the number of bytes consed between GCs; the number of
590 GCs that have occurred; the trigger age; the cumulative number of
591 bytes allocated in this generation; and the average age of this
592 generation. See the gencgc source code for more info."
593 (alien:with-alien ((stats (alien:struct generation-stats)))
594 (alien:alien-funcall (alien:extern-alien "get_generation_stats"
595 (function c-call:void
596 c-call:int
597 (* (alien:struct
598 generation-stats))))
599 generation
600 (alien:addr stats))
601 (values (alien:slot stats 'bytes-allocated)
602 (alien:slot stats 'gc-trigger)
603 (alien:slot stats 'bytes-consed-between-gc)
604 (alien:slot stats 'num-gc)
605 (alien:slot stats 'trigger-age)
606 (alien:slot stats 'cum-sum-bytes-allocated)
607 (alien:slot stats 'min-av-mem-age))))
608
609 (alien:def-alien-routine set-gc-trigger c-call:void
610 (gen c-call:int) (trigger c-call:int))
611 (alien:def-alien-routine set-trigger-age c-call:void
612 (gen c-call:int) (trigger-age c-call:int))
613 (alien:def-alien-routine set-min-mem-age c-call:void
614 (gen c-call:int) (min-mem-age c-call:double))
615 )

  ViewVC Help
Powered by ViewVC 1.1.5