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

Contents of /src/code/gengc.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show annotations)
Mon Oct 31 04:11:27 1994 UTC (19 years, 5 months ago) by ram
Branch: MAIN
CVS Tags: double-double-array-base, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, unicode-string-buffer-base, RELEASE_18d, sse2-packed-base, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, LINKAGE_TABLE, release-19c-base, label-2009-03-16, release-19f-base, PRE_LINKAGE_TABLE, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, RELEASE_18a, RELEASE_18b, RELEASE_18c, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2007-06, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, UNICODE-BASE, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, double-double-init-x86, sse2-checkpoint-2008-10-01, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, RELENG_18, unicode-string-buffer-branch, dynamic-extent, UNICODE-BRANCH, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.4: +1 -3 lines
Fix headed boilerplate.
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.5 1994/10/31 04:11:27 ram 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 (export '(*before-gc-hooks* *after-gc-hooks* gc purify
19 *gc-verbose* *gc-notify-before* *gc-notify-after*))
20
21 (in-package "LISP")
22
23
24
25 ;;;; GC Hooks.
26
27 ;;;
28 ;;; *BEFORE-GC-HOOKS*
29 ;;; *AFTER-GC-HOOKS*
30 ;;;
31 ;;; These variables are a list of functions which are run before and
32 ;;; after garbage collection occurs.
33 ;;;
34 (defvar *before-gc-hooks* nil
35 "A list of functions that are called before garbage collection occurs.
36 The functions should take no arguments.")
37 ;;;
38 (defvar *after-gc-hooks* nil
39 "A list of functions that are called after garbage collection occurs.
40 The functions should take no arguments.")
41
42
43 ;;; *GC-VERBOSE* -- interface
44 ;;;
45 (defvar *gc-verbose* t
46 "When non-NIL, causes the functions bound to *GC-NOTIFY-BEFORE* and
47 *GC-NOTIFY-AFTER* to be called before and after a garbage collection
48 occurs respectively. If :BEEP, causes the default notify functions to beep
49 annoyingly.")
50
51
52 (defun default-gc-notify-before (bytes-in-use)
53 (when (eq *gc-verbose* :beep)
54 (system:beep *standard-output*))
55 (format t "~&[GC threshold exceeded with ~:D bytes in use. ~
56 Commencing GC.]~%" bytes-in-use)
57 (finish-output))
58 ;;;
59 (defparameter *gc-notify-before* #'default-gc-notify-before
60 "This function bound to this variable is invoked before GC'ing (unless
61 *GC-VERBOSE* is NIL) with the current amount of dynamic usage (in
62 bytes). It should notify the user that the system is going to GC.")
63
64 (defun default-gc-notify-after (bytes-retained bytes-freed new-trigger)
65 (format t "[GC completed with ~:D bytes retained and ~:D bytes freed.]~%"
66 bytes-retained bytes-freed)
67 (format t "[GC will next occur when at least ~:D bytes are in use.]~%"
68 new-trigger)
69 (when (eq *gc-verbose* :beep)
70 (system:beep *standard-output*))
71 (finish-output))
72 ;;;
73 (defparameter *gc-notify-after* #'default-gc-notify-after
74 "The function bound to this variable is invoked after GC'ing (unless
75 *GC-VERBOSE* is NIL) with the amount of dynamic usage (in bytes) now
76 free, the number of bytes freed by the GC, and the new GC trigger
77 threshold. The function should notify the user that the system has
78 finished GC'ing.")
79
80
81 ;;; CAREFULLY-FUNCALL -- Internal
82 ;;;
83 ;;; Used to carefully invoke hooks.
84 ;;;
85 (defmacro carefully-funcall (function &rest args)
86 `(handler-case (funcall ,function ,@args)
87 (error (cond)
88 (warn "(FUNCALL ~S~{ ~S~}) lost:~%~A" ',function ',args cond)
89 nil)))
90
91
92 ;;; DO-BEFORE-GC-STUFF -- interface.
93 ;;;
94 ;;; Called by the C code just before doing a GC.
95 ;;;
96 (defun do-before-gc-stuff ()
97 (when *gc-verbose*
98 (carefully-funcall *gc-notify-before* 0))
99 (dolist (hook *before-gc-hooks*)
100 (carefully-funcall hook))
101 nil)
102
103 ;;; DO-AFTER-GC-STUFF -- interface.
104 ;;;
105 ;;; Called by the C code just after doing a GC.
106 ;;;
107 (defun do-after-gc-stuff ()
108 (dolist (hook *after-gc-hooks*)
109 (carefully-funcall hook))
110 (when *gc-verbose*
111 (carefully-funcall *gc-notify-after* 0 0 0))
112 nil)
113
114
115
116 ;;;; Interface to GC routines
117
118 (alien:def-alien-routine ("collect_garbage" gc) c-call:void
119 "Force a garbage collection.")
120
121
122 (defun purify (&key root-structures constants)
123 (declare (ignore root-structures constants))
124 (gc))
125
126
127 (defun gc-init ()
128 ;; Nothing to do.
129 (undefined-value))

  ViewVC Help
Powered by ViewVC 1.1.5