trivial-garbage.lisp - clic - Clic is an command line interactive client for go… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
trivial-garbage.lisp (15981B) | |
--- | |
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- | |
2 ;;; | |
3 ;;; trivial-garbage.lisp --- Trivial Garbage! | |
4 ;;; | |
5 ;;; This software is placed in the public domain by Luis Oliveira | |
6 ;;; <[email protected]> and is provided with absolutely no | |
7 ;;; warranty. | |
8 | |
9 #+xcvb (module ()) | |
10 | |
11 (defpackage #:trivial-garbage | |
12 (:use #:cl) | |
13 (:shadow #:make-hash-table) | |
14 (:nicknames #:tg) | |
15 (:export #:gc | |
16 #:make-weak-pointer | |
17 #:weak-pointer-value | |
18 #:weak-pointer-p | |
19 #:make-weak-hash-table | |
20 #:hash-table-weakness | |
21 #:finalize | |
22 #:cancel-finalization) | |
23 (:documentation | |
24 "@a[http://common-lisp.net/project/trivial-garbage]{trivial-garbage} | |
25 provides a portable API to finalizers, weak hash-tables and weak | |
26 pointers on all major implementations of the Common Lisp | |
27 programming language. For a good introduction to these | |
28 data-structures, have a look at | |
29 @a[http://www.haible.de/bruno/papers/cs/weak/WeakDatastructures-writ… | |
30 References: Data Types and Implementation} by Bruno Haible. | |
31 | |
32 Source code is available at | |
33 @a[https://github.com/trivial-garbage/trivial-garbage]{github}, | |
34 which you are welcome to use for submitting patches and/or | |
35 @a[https://github.com/trivial-garbage/trivial-garbage/issues]{bug | |
36 reports}. Discussion takes place on | |
37 @a[http://lists.common-lisp.net/cgi-bin/mailman/listinfo/trivial-gar… | |
38 at common-lisp.net}. | |
39 | |
40 @a[http://common-lisp.net/project/trivial-garbage/releases/]{Tarball | |
41 releases} are available, but the easiest way to install this | |
42 library is via @a[http://www.quicklisp.org/]{Quicklisp}: | |
43 @code{(ql:quickload :trivial-garbage)}. | |
44 | |
45 @begin[Weak Pointers]{section} | |
46 A @em{weak pointer} holds an object in a way that does not prevent | |
47 it from being reclaimed by the garbage collector. An object | |
48 referenced only by weak pointers is considered unreachable (or | |
49 \"weakly reachable\") and so may be collected at any time. When | |
50 that happens, the weak pointer's value becomes @code{nil}. | |
51 | |
52 @aboutfun{make-weak-pointer} | |
53 @aboutfun{weak-pointer-value} | |
54 @aboutfun{weak-pointer-p} | |
55 @end{section} | |
56 | |
57 @begin[Weak Hash-Tables]{section} | |
58 A @em{weak hash-table} is one that weakly references its keys | |
59 and/or values. When both key and value are unreachable (or weakly | |
60 reachable) that pair is reclaimed by the garbage collector. | |
61 | |
62 @aboutfun{make-weak-hash-table} | |
63 @aboutfun{hash-table-weakness} | |
64 @end{section} | |
65 | |
66 @begin[Finalizers]{section} | |
67 A @em{finalizer} is a hook that is executed after a given object | |
68 has been reclaimed by the garbage collector. | |
69 | |
70 @aboutfun{finalize} | |
71 @aboutfun{cancel-finalization} | |
72 @end{section}")) | |
73 | |
74 (in-package #:trivial-garbage) | |
75 | |
76 ;;;; GC | |
77 | |
78 (defun gc (&key full verbose) | |
79 "Initiates a garbage collection. @code{full} forces the collection | |
80 of all generations, when applicable. When @code{verbose} is | |
81 @em{true}, diagnostic information about the collection is printed | |
82 if possible." | |
83 (declare (ignorable verbose full)) | |
84 #+(or cmu scl) (ext:gc :verbose verbose :full full) | |
85 #+sbcl (sb-ext:gc :full full) | |
86 #+allegro (excl:gc (not (null full))) | |
87 #+(or abcl clisp) (ext:gc) | |
88 #+ecl (si:gc t) | |
89 #+openmcl (ccl:gc) | |
90 #+corman (ccl:gc (if full 3 0)) | |
91 #+lispworks (hcl:gc-generation (if full t 0)) | |
92 #+clasp (gctools:garbage-collect)) | |
93 | |
94 ;;;; Weak Pointers | |
95 | |
96 #+openmcl | |
97 (defvar *weak-pointers* (cl:make-hash-table :test 'eq :weak :value) | |
98 "Weak value hash-table mapping between pseudo weak pointers and its va… | |
99 | |
100 #+(or allegro openmcl lispworks) | |
101 (defstruct (weak-pointer (:constructor %make-weak-pointer)) | |
102 #-openmcl pointer) | |
103 | |
104 (defun make-weak-pointer (object) | |
105 "Creates a new weak pointer which points to @code{object}. For | |
106 portability reasons, @code{object} must not be @code{nil}." | |
107 (assert (not (null object))) | |
108 #+sbcl (sb-ext:make-weak-pointer object) | |
109 #+(or cmu scl) (ext:make-weak-pointer object) | |
110 #+clisp (ext:make-weak-pointer object) | |
111 #+abcl (ext:make-weak-reference object) | |
112 #+ecl (ext:make-weak-pointer object) | |
113 #+allegro | |
114 (let ((wv (excl:weak-vector 1))) | |
115 (setf (svref wv 0) object) | |
116 (%make-weak-pointer :pointer wv)) | |
117 #+openmcl | |
118 (let ((wp (%make-weak-pointer))) | |
119 (setf (gethash wp *weak-pointers*) object) | |
120 wp) | |
121 #+corman (ccl:make-weak-pointer object) | |
122 #+lispworks | |
123 (let ((array (make-array 1 :weak t))) | |
124 (setf (svref array 0) object) | |
125 (%make-weak-pointer :pointer array)) | |
126 #+clasp (core:make-weak-pointer object)) | |
127 | |
128 #-(or allegro openmcl lispworks) | |
129 (defun weak-pointer-p (object) | |
130 "Returns @em{true} if @code{object} is a weak pointer and @code{nil} | |
131 otherwise." | |
132 #+sbcl (sb-ext:weak-pointer-p object) | |
133 #+(or cmu scl) (ext:weak-pointer-p object) | |
134 #+clisp (ext:weak-pointer-p object) | |
135 #+abcl (typep object 'ext:weak-reference) | |
136 #+ecl (typep object 'ext:weak-pointer) | |
137 #+corman (ccl:weak-pointer-p object) | |
138 #+clasp (core:weak-pointer-valid object)) | |
139 | |
140 (defun weak-pointer-value (weak-pointer) | |
141 "If @code{weak-pointer} is valid, returns its value. Otherwise, | |
142 returns @code{nil}." | |
143 #+sbcl (values (sb-ext:weak-pointer-value weak-pointer)) | |
144 #+(or cmu scl) (values (ext:weak-pointer-value weak-pointer)) | |
145 #+clisp (values (ext:weak-pointer-value weak-pointer)) | |
146 #+abcl (values (ext:weak-reference-value weak-pointer)) | |
147 #+ecl (values (ext:weak-pointer-value weak-pointer)) | |
148 #+allegro (svref (weak-pointer-pointer weak-pointer) 0) | |
149 #+openmcl (values (gethash weak-pointer *weak-pointers*)) | |
150 #+corman (ccl:weak-pointer-obj weak-pointer) | |
151 #+lispworks (svref (weak-pointer-pointer weak-pointer) 0) | |
152 #+clasp (core:weak-pointer-value weak-pointer)) | |
153 | |
154 ;;;; Weak Hash-tables | |
155 | |
156 ;;; Allegro can apparently create weak hash-tables with both weak keys | |
157 ;;; and weak values but it's not obvious whether it's an OR or an AND | |
158 ;;; relation. TODO: figure that out. | |
159 | |
160 (defun weakness-keyword-arg (weakness) | |
161 (declare (ignorable weakness)) | |
162 #+(or sbcl abcl clasp ecl-weak-hash) :weakness | |
163 #+(or clisp openmcl) :weak | |
164 #+lispworks :weak-kind | |
165 #+allegro (case weakness (:key :weak-keys) (:value :values)) | |
166 #+cmu :weak-p) | |
167 | |
168 (defvar *weakness-warnings* '() | |
169 "List of weaknesses that have already been warned about this | |
170 session. Used by `weakness-missing'.") | |
171 | |
172 (defun weakness-missing (weakness errorp) | |
173 "Signal an error or warning, depending on ERRORP, about lack of Lisp | |
174 support for WEAKNESS." | |
175 (cond (errorp | |
176 (error "Your Lisp does not support weak ~(~A~) hash-tables." | |
177 weakness)) | |
178 ((member weakness *weakness-warnings*) nil) | |
179 (t (push weakness *weakness-warnings*) | |
180 (warn "Your Lisp does not support weak ~(~A~) hash-tables." | |
181 weakness)))) | |
182 | |
183 (defun weakness-keyword-opt (weakness errorp) | |
184 (declare (ignorable errorp)) | |
185 (ecase weakness | |
186 (:key | |
187 #+(or lispworks sbcl abcl clasp clisp openmcl ecl-weak-hash) :key | |
188 #+(or allegro cmu) t | |
189 #-(or lispworks sbcl abcl clisp openmcl allegro cmu ecl-weak-hash c… | |
190 (weakness-missing weakness errorp)) | |
191 (:value | |
192 #+allegro :weak | |
193 #+(or clisp openmcl sbcl abcl lispworks cmu ecl-weak-hash) :value | |
194 #-(or allegro clisp openmcl sbcl abcl lispworks cmu ecl-weak-hash) | |
195 (weakness-missing weakness errorp)) | |
196 (:key-or-value | |
197 #+(or clisp sbcl abcl cmu) :key-or-value | |
198 #+lispworks :either | |
199 #-(or clisp sbcl abcl lispworks cmu) | |
200 (weakness-missing weakness errorp)) | |
201 (:key-and-value | |
202 #+(or clisp abcl sbcl cmu ecl-weak-hash) :key-and-value | |
203 #+lispworks :both | |
204 #-(or clisp sbcl abcl lispworks cmu ecl-weak-hash) | |
205 (weakness-missing weakness errorp)))) | |
206 | |
207 (defun make-weak-hash-table (&rest args &key weakness (weakness-matters … | |
208 #+openmcl (test #'eql) | |
209 &allow-other-keys) | |
210 "Returns a new weak hash table. In addition to the standard | |
211 arguments accepted by @code{cl:make-hash-table}, this function adds | |
212 extra keywords: @code{:weakness} being the kind of weak table it | |
213 should create, and @code{:weakness-matters} being whether an error | |
214 should be signalled when that weakness isn't available (the default | |
215 is to signal an error). @code{weakness} can be one of @code{:key}, | |
216 @code{:value}, @code{:key-or-value}, @code{:key-and-value}. | |
217 | |
218 If @code{weakness} is @code{:key} or @code{:value}, an entry is | |
219 kept as long as its key or value is reachable, respectively. If | |
220 @code{weakness} is @code{:key-or-value} or @code{:key-and-value}, | |
221 an entry is kept if either or both of its key and value are | |
222 reachable, respectively. | |
223 | |
224 @code{tg::make-hash-table} is available as an alias for this | |
225 function should you wish to import it into your package and shadow | |
226 @code{cl:make-hash-table}." | |
227 (remf args :weakness) | |
228 (remf args :weakness-matters) | |
229 (if weakness | |
230 (let ((arg (weakness-keyword-arg weakness)) | |
231 (opt (weakness-keyword-opt weakness weakness-matters))) | |
232 (apply #'cl:make-hash-table | |
233 #+openmcl :test #+openmcl (if (eq opt :key) #'eq test) | |
234 #+clasp :test #+clasp #'eq | |
235 (if arg | |
236 (list* arg opt args) | |
237 args))) | |
238 (apply #'cl:make-hash-table args))) | |
239 | |
240 ;;; If you want to use this function to override CL:MAKE-HASH-TABLE, | |
241 ;;; it's necessary to shadow-import it. For example: | |
242 ;;; | |
243 ;;; (defpackage #:foo | |
244 ;;; (:use #:common-lisp #:trivial-garbage) | |
245 ;;; (:shadowing-import-from #:trivial-garbage #:make-hash-table)) | |
246 ;;; | |
247 (defun make-hash-table (&rest args) | |
248 (apply #'make-weak-hash-table args)) | |
249 | |
250 (defun hash-table-weakness (ht) | |
251 "Returns one of @code{nil}, @code{:key}, @code{:value}, | |
252 @code{:key-or-value} or @code{:key-and-value}." | |
253 #-(or allegro sbcl abcl clisp cmu openmcl lispworks | |
254 ecl-weak-hash clasp) | |
255 (declare (ignore ht)) | |
256 ;; keep this first if any of the other lisps bugously insert a NIL | |
257 ;; for the returned (values) even when *read-suppress* is NIL (e.g. cl… | |
258 #.(if (find :sbcl *features*) | |
259 (if (find-symbol "HASH-TABLE-WEAKNESS" "SB-EXT") | |
260 (read-from-string "(sb-ext:hash-table-weakness ht)") | |
261 nil) | |
262 (values)) | |
263 #+abcl (sys:hash-table-weakness ht) | |
264 #+ecl-weak-hash (ext:hash-table-weakness ht) | |
265 #+allegro (cond ((excl:hash-table-weak-keys ht) :key) | |
266 ((eq (excl:hash-table-values ht) :weak) :value)) | |
267 #+clisp (ext:hash-table-weak-p ht) | |
268 #+cmu (let ((weakness (lisp::hash-table-weak-p ht))) | |
269 (if (eq t weakness) :key weakness)) | |
270 #+openmcl (ccl::hash-table-weak-p ht) | |
271 #+lispworks (system::hash-table-weak-kind ht) | |
272 #+clasp (core:hash-table-weakness ht)) | |
273 | |
274 ;;;; Finalizers | |
275 | |
276 ;;; Note: Lispworks can't finalize gensyms. | |
277 | |
278 #+(or allegro clisp lispworks openmcl) | |
279 (defvar *finalizers* | |
280 (cl:make-hash-table :test 'eq | |
281 #+allegro :weak-keys #+:allegro t | |
282 #+(or clisp openmcl) :weak | |
283 #+lispworks :weak-kind | |
284 #+(or clisp openmcl lispworks) :key | |
285 #+clasp :weakness #+clasp :key) | |
286 "Weak hashtable that holds registered finalizers.") | |
287 | |
288 #+corman | |
289 (progn | |
290 (defvar *finalizers* '() | |
291 "Weak alist that holds registered finalizers.") | |
292 | |
293 (defvar *finalizers-cs* (threads:allocate-critical-section))) | |
294 | |
295 #+lispworks | |
296 (progn | |
297 (hcl:add-special-free-action 'free-action) | |
298 (defun free-action (object) | |
299 (let ((finalizers (gethash object *finalizers*))) | |
300 (unless (null finalizers) | |
301 (mapc #'funcall finalizers))))) | |
302 | |
303 ;;; Note: ECL bytecmp does not perform escape analysis and unused | |
304 ;;; variables are not optimized away from its lexenv. That leads to | |
305 ;;; closing over whole definition lexenv. That's why we define | |
306 ;;; EXTEND-FINALIZER-FN which defines lambda outside the lexical scope | |
307 ;;; of FINALIZE (which inludes object) - to prevent closing over | |
308 ;;; finalized object. This problem does not apply to C compiler. | |
309 | |
310 #+ecl | |
311 (defun extend-finalizer-fn (old-fn new-fn) | |
312 (if (null old-fn) | |
313 (lambda (obj) | |
314 (declare (ignore obj)) | |
315 (funcall new-fn)) | |
316 (lambda (obj) | |
317 (declare (ignore obj)) | |
318 (funcall new-fn) | |
319 (funcall old-fn nil)))) | |
320 | |
321 (defun finalize (object function) | |
322 "Pushes a new @code{function} to the @code{object}'s list of | |
323 finalizers. @code{function} should take no arguments. Returns | |
324 @code{object}. | |
325 | |
326 @b{Note:} @code{function} should not attempt to look at | |
327 @code{object} by closing over it because that will prevent it from | |
328 being garbage collected." | |
329 #+(or cmu scl) (ext:finalize object function) | |
330 #+sbcl (sb-ext:finalize object function) | |
331 #+abcl (ext:finalize object function) | |
332 #+ecl (let* ((old-fn (ext:get-finalizer object)) | |
333 (new-fn (extend-finalizer-fn old-fn function))) | |
334 (ext:set-finalizer object new-fn) | |
335 object) | |
336 #+allegro | |
337 (progn | |
338 (push (excl:schedule-finalization | |
339 object (lambda (obj) (declare (ignore obj)) (funcall function… | |
340 (gethash object *finalizers*)) | |
341 object) | |
342 #+clasp (gctools:finalize object (lambda (obj) (declare (ignore obj)) … | |
343 #+clisp | |
344 ;; The CLISP code used to be a bit simpler but we had to workaround | |
345 ;; a bug regarding the interaction between GC and weak hashtables. | |
346 ;; See <http://article.gmane.org/gmane.lisp.clisp.general/11028> | |
347 ;; and <http://article.gmane.org/gmane.lisp.cffi.devel/994>. | |
348 (multiple-value-bind (finalizers presentp) | |
349 (gethash object *finalizers* (cons 'finalizers nil)) | |
350 (unless presentp | |
351 (setf (gethash object *finalizers*) finalizers) | |
352 (ext:finalize object (lambda (obj) | |
353 (declare (ignore obj)) | |
354 (mapc #'funcall (cdr finalizers))))) | |
355 (push function (cdr finalizers)) | |
356 object) | |
357 #+openmcl | |
358 (progn | |
359 (ccl:terminate-when-unreachable | |
360 object (lambda (obj) (declare (ignore obj)) (funcall function))) | |
361 ;; store number of finalizers | |
362 (incf (gethash object *finalizers* 0)) | |
363 object) | |
364 #+corman | |
365 (flet ((get-finalizers (obj) | |
366 (assoc obj *finalizers* :test #'eq :key #'ccl:weak-pointer-ob… | |
367 (threads:with-synchronization *finalizers-cs* | |
368 (let ((pair (get-finalizers object))) | |
369 (if (null pair) | |
370 (push (list (ccl:make-weak-pointer object) function) *finali… | |
371 (push function (cdr pair))))) | |
372 (ccl:register-finalization | |
373 object (lambda (obj) | |
374 (threads:with-synchronization *finalizers-cs* | |
375 (mapc #'funcall (cdr (get-finalizers obj))) | |
376 (setq *finalizers* | |
377 (delete obj *finalizers* | |
378 :test #'eq :key #'ccl:weak-pointer-obj))))) | |
379 object) | |
380 #+lispworks | |
381 (progn | |
382 (let ((finalizers (gethash object *finalizers*))) | |
383 (unless finalizers | |
384 (hcl:flag-special-free-action object)) | |
385 (setf (gethash object *finalizers*) | |
386 (cons function finalizers))) | |
387 object)) | |
388 | |
389 (defun cancel-finalization (object) | |
390 "Cancels all of @code{object}'s finalizers, if any." | |
391 #+cmu (ext:cancel-finalization object) | |
392 #+scl (ext:cancel-finalization object nil) | |
393 #+sbcl (sb-ext:cancel-finalization object) | |
394 #+abcl (ext:cancel-finalization object) | |
395 #+ecl (ext:set-finalizer object nil) | |
396 #+allegro | |
397 (progn | |
398 (mapc #'excl:unschedule-finalization | |
399 (gethash object *finalizers*)) | |
400 (remhash object *finalizers*)) | |
401 #+clasp (gctools:definalize object) | |
402 #+clisp | |
403 (multiple-value-bind (finalizers present-p) | |
404 (gethash object *finalizers*) | |
405 (when present-p | |
406 (setf (cdr finalizers) nil)) | |
407 (remhash object *finalizers*)) | |
408 #+openmcl | |
409 (let ((count (gethash object *finalizers*))) | |
410 (unless (null count) | |
411 (dotimes (i count) | |
412 (ccl:cancel-terminate-when-unreachable object)))) | |
413 #+corman | |
414 (threads:with-synchronization *finalizers-cs* | |
415 (setq *finalizers* | |
416 (delete object *finalizers* :test #'eq :key #'ccl:weak-pointer… | |
417 #+lispworks | |
418 (progn | |
419 (remhash object *finalizers*) | |
420 (hcl:flag-not-special-free-action object))) |