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

Contents of /src/code/gengc.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (show annotations)
Fri Mar 19 15:18:59 2010 UTC (4 years ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, post-merge-intl-branch, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.5: +3 -1 lines
Merge intl-branch 2010-03-18 to HEAD.  To build, you need to use
boot-2010-02-1 as the bootstrap file.  You should probably also use
the new -P option for build.sh to generate and update the po files
while building.
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/gengc.lisp,v 1.6 2010/03/19 15:18:59 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Lisp level interface to the Generational Garbage Collector.
13 ;;;
14 ;;; Written by William Lott.
15 ;;;
16
17 (in-package "EXTENSIONS")
18 (intl:textdomain "cmucl")
19
20 (export '(*before-gc-hooks* *after-gc-hooks* gc purify
21 *gc-verbose* *gc-notify-before* *gc-notify-after*))
22
23 (in-package "LISP")
24
25
26
27 ;;;; GC Hooks.
28
29 ;;;
30 ;;; *BEFORE-GC-HOOKS*
31 ;;; *AFTER-GC-HOOKS*
32 ;;;
33 ;;; These variables are a list of functions which are run before and
34 ;;; after garbage collection occurs.
35 ;;;
36 (defvar *before-gc-hooks* nil
37 "A list of functions that are called before garbage collection occurs.
38 The functions should take no arguments.")
39 ;;;
40 (defvar *after-gc-hooks* nil
41 "A list of functions that are called after garbage collection occurs.
42 The functions should take no arguments.")
43
44
45 ;;; *GC-VERBOSE* -- interface
46 ;;;
47 (defvar *gc-verbose* t
48 "When non-NIL, causes the functions bound to *GC-NOTIFY-BEFORE* and
49 *GC-NOTIFY-AFTER* to be called before and after a garbage collection
50 occurs respectively. If :BEEP, causes the default notify functions to beep
51 annoyingly.")
52
53
54 (defun default-gc-notify-before (bytes-in-use)
55 (when (eq *gc-verbose* :beep)
56 (system:beep *standard-output*))
57 (format t "~&[GC threshold exceeded with ~:D bytes in use. ~
58 Commencing GC.]~%" bytes-in-use)
59 (finish-output))
60 ;;;
61 (defparameter *gc-notify-before* #'default-gc-notify-before
62 "This function bound to this variable is invoked before GC'ing (unless
63 *GC-VERBOSE* is NIL) with the current amount of dynamic usage (in
64 bytes). It should notify the user that the system is going to GC.")
65
66 (defun default-gc-notify-after (bytes-retained bytes-freed new-trigger)
67 (format t "[GC completed with ~:D bytes retained and ~:D bytes freed.]~%"
68 bytes-retained bytes-freed)
69 (format t "[GC will next occur when at least ~:D bytes are in use.]~%"
70 new-trigger)
71 (when (eq *gc-verbose* :beep)
72 (system:beep *standard-output*))
73 (finish-output))
74 ;;;
75 (defparameter *gc-notify-after* #'default-gc-notify-after
76 "The function bound to this variable is invoked after GC'ing (unless
77 *GC-VERBOSE* is NIL) with the amount of dynamic usage (in bytes) now
78 free, the number of bytes freed by the GC, and the new GC trigger
79 threshold. The function should notify the user that the system has
80 finished GC'ing.")
81
82
83 ;;; CAREFULLY-FUNCALL -- Internal
84 ;;;
85 ;;; Used to carefully invoke hooks.
86 ;;;
87 (defmacro carefully-funcall (function &rest args)
88 `(handler-case (funcall ,function ,@args)
89 (error (cond)
90 (warn "(FUNCALL ~S~{ ~S~}) lost:~%~A" ',function ',args cond)
91 nil)))
92
93
94 ;;; DO-BEFORE-GC-STUFF -- interface.
95 ;;;
96 ;;; Called by the C code just before doing a GC.
97 ;;;
98 (defun do-before-gc-stuff ()
99 (when *gc-verbose*
100 (carefully-funcall *gc-notify-before* 0))
101 (dolist (hook *before-gc-hooks*)
102 (carefully-funcall hook))
103 nil)
104
105 ;;; DO-AFTER-GC-STUFF -- interface.
106 ;;;
107 ;;; Called by the C code just after doing a GC.
108 ;;;
109 (defun do-after-gc-stuff ()
110 (dolist (hook *after-gc-hooks*)
111 (carefully-funcall hook))
112 (when *gc-verbose*
113 (carefully-funcall *gc-notify-after* 0 0 0))
114 nil)
115
116
117
118 ;;;; Interface to GC routines
119
120 (alien:def-alien-routine ("collect_garbage" gc) c-call:void
121 "Force a garbage collection.")
122
123
124 (defun purify (&key root-structures constants)
125 (declare (ignore root-structures constants))
126 (gc))
127
128
129 (defun gc-init ()
130 ;; Nothing to do.
131 (undefined-value))

  ViewVC Help
Powered by ViewVC 1.1.5