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

Contents of /src/code/gengc.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5.58.1 - (hide annotations)
Thu Feb 25 20:34:49 2010 UTC (4 years, 1 month ago) by rtoy
Branch: intl-2-branch
Changes since 1.5: +3 -1 lines
Restart internalization work.  This new branch starts with code from
the intl-branch on date 2010-02-12 18:00:00+0500.  This version works
and

LANG=en@piglatin bin/lisp

works (once the piglatin translation is added).
1 wlott 1.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 rtoy 1.5.58.1 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/gengc.lisp,v 1.5.58.1 2010/02/25 20:34:49 rtoy Exp $")
9 wlott 1.1 ;;;
10     ;;; **********************************************************************
11     ;;;
12     ;;; Lisp level interface to the Generational Garbage Collector.
13     ;;;
14     ;;; Written by William Lott.
15     ;;;
16    
17 wlott 1.2 (in-package "EXTENSIONS")
18 rtoy 1.5.58.1 (intl:textdomain "cmucl")
19    
20 wlott 1.3 (export '(*before-gc-hooks* *after-gc-hooks* gc purify
21 wlott 1.2 *gc-verbose* *gc-notify-before* *gc-notify-after*))
22    
23 wlott 1.1 (in-package "LISP")
24    
25 wlott 1.2
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 wlott 1.1 (defun do-before-gc-stuff ()
99 wlott 1.2 (when *gc-verbose*
100     (carefully-funcall *gc-notify-before* 0))
101     (dolist (hook *before-gc-hooks*)
102     (carefully-funcall hook))
103 wlott 1.1 nil)
104    
105 wlott 1.2 ;;; DO-AFTER-GC-STUFF -- interface.
106     ;;;
107     ;;; Called by the C code just after doing a GC.
108     ;;;
109 wlott 1.1 (defun do-after-gc-stuff ()
110 wlott 1.2 (dolist (hook *after-gc-hooks*)
111     (carefully-funcall hook))
112     (when *gc-verbose*
113     (carefully-funcall *gc-notify-after* 0 0 0))
114 wlott 1.1 nil)
115    
116 wlott 1.2
117    
118     ;;;; Interface to GC routines
119    
120     (alien:def-alien-routine ("collect_garbage" gc) c-call:void
121     "Force a garbage collection.")
122 wlott 1.3
123    
124     (defun purify (&key root-structures constants)
125     (declare (ignore root-structures constants))
126     (gc))
127 wlott 1.4
128    
129     (defun gc-init ()
130     ;; Nothing to do.
131     (undefined-value))

  ViewVC Help
Powered by ViewVC 1.1.5