source: branches/qres/ccl/library/macptr-termination.lisp @ 15278

Last change on this file since 15278 was 13070, checked in by gz, 10 years ago

r13066, r13067 from trunk: copyrights etc

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 17.3 KB
Line 
1; -*- Mode: Lisp; Package: CCL; -*-
2;;;
3;;;   Copyright (C) 2009 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18;;; macptr-termination.lisp
19;;;
20;;; Allows you to associate a termination function with a macptr.
21;;; The termination function will be called with the macptr as
22;;; its single arg when the macptr is no longer accessible in the
23;;; mac heap (i.e. when the garbage collector decides that its
24;;; storage can be recycled).
25;;;
26;;; This file is provided primarily for backward compatibility.
27;;; You can use terminate-when-unreachable for new code.
28
29;; Modification History
30;;
31;; 11/26/96 bill Remove cons-terminable-macptr from the PPC version of the code.
32;;               It referenced undefined $macptr-size and it was not used.
33;; ------------- 4.0
34;; 09/12/96 bill *slave-macptrs-table* is for non-terminable slaves.
35;;               *terminable-slaves-table* is for terminable slaves.
36;;               *terminable-slaves-table* is not weak, *slave-macptrs-table* still is.
37;;               *terminable-slaves-table* is an EQL hash table which maps a copy of the
38;;               slave to the master.
39;;               When a slave is terminated, its entry is explicitly removed from *terminable-slaves-table*.
40;;               This means that a master will be removed on the next GC after all of
41;;               its slaves are terminated. Not optimal, but it guarantees that all the slaves are
42;;               disposed before the master.
43;; 08/23/96 bill A *save-exit-function* to clear-terminable-macptrs
44;; 08/21/96 bill add the SK8 register-slave-macptr & teminable-macptr-p functions
45;;               and the :deactivate-only keyword to deactivate-macptr
46;; ------------- 4.0b1
47;; 02/28/96 bill Make it work in PPC MCL
48;;
49
50;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
51;;;
52;;; Documentation
53;;;
54
55#|
56
57SET-POST-EGC-HOOK-ENABLED-P value
58  This package works by setting MCL's undocumented ccl::*post-gc-hook*.
59The hook is normally called only after a full GC. If you want it to
60be called after each ephemeral GC as well, call this with a true value.
61
62POST-EGC-HOOK-ENABLED-P
63  Returns true if the post gc hook will be called after EGC as well as
64after full GC.¬
65
66ADD-PRE-GC-HOOK hook
67DELETE-PRE-GC-HOOK hook
68ADD-POST-GC-HOOK hook
69DELETE-POST-GC-HOOK hook
70  MCL's ccl::*pre-gc-hook* and ccl::*post-gc-hook* can each contain
71either a function or NIL. These four functions extend that functionality
72by maintaining a list of functions for each of the two hooks. Hooks are
73compared with EQ, so it is best to pass a symbol that has a global
74definition (see the last form in this file).
75
76MAKE-TERMINABLE-MACPTR macptr termination-function &key master
77  Creates and returns a terminable macptr. It will point at the same Mac
78Heap address as the macptr arg. When the return value becomes scavengeable
79(e.g. no longer accessible in the Lisp heap), will call the
80termination-function with a single arg, the returned macptr. If the
81termination-function's return value is non-NIL, will free the macptr.
82Otherwise, will assume that you decided not to terminate it, and will
83call the termination-function again the next time the GC runs and
84it is scavengeable.  If master is supplied, then
85initialize the new terminable macptr as a slave to the given master.
86All slave terminable macptrs are terminated before their master is terminated.
87Raise an error if macptr is not a macptr or the supplied master
88is not a terminable macptr.
89
90REGISTER-SLAVE-MACPTR slave-macptr master-macptr
91  Registers a macptr as the slave of a terminable macptr.
92A master terminable macptr is not terminated until all of its slaves
93have been GC'ed (and terminated if appropriate).
94Raise an error if master-macptr is not a terminable macptr.
95
96TERMINABLE-MACPTR-P thing
97returns t if thing is an active terminable or gcable macptr;
98otherwise returns  nil.
99
100DEACTIVATE-MACPTR macptr &key deactivate-only
101  If macptr has an associated termination action,
102cancel that action. If deactivate-only is nil, call the
103termination action before canceling it, and change
104the macptr to a dead macptr.  Raise an error if macptr
105is not a macptr.  Return nil if not a terminable macptr
106or if deactivate-only is nil and disposal function returns
107nil;  otherwise return true.
108
109|#
110
111(in-package "CCL")
112
113(provide "MACPTR-TERMINATION")
114
115(export '(set-post-egc-hook-enabled-p post-egc-hook-enabled-p
116          add-pre-gc-hook delete-pre-gc-hook add-post-gc-hook delete-post-gc-hook
117          make-terminable-macptr register-slave-macptr terminable-macptr-p deactivate-macptr))
118
119; Map slave-macptr to master-macptr
120; This holds on to the master until the slave is GC'd
121(defvar *slave-macptrs-table*
122  (make-hash-table :test 'eq :weak :key))
123
124; Map a copy of a terminable slave to its master
125; This holds on to the master until the slave is terminated
126(defvar *terminable-slaves-table*
127  (make-hash-table :test 'eql))
128
129(defun register-slave-macptr (slave-macptr master-macptr)
130  (unless (terminable-macptr-p master-macptr)
131    (error "~s is not a terminable macptr" master-macptr))
132  (unless (macptrp slave-macptr)
133    (setq slave-macptr (require-type slave-macptr 'macptr)))
134  (if (terminable-macptr-p slave-macptr)
135    (setf (gethash (%inc-ptr slave-macptr 0) *terminable-slaves-table*) master-macptr)
136    (setf (gethash slave-macptr *slave-macptrs-table*) master-macptr)))
137
138(defun dispose-gcable-macptr (macptr)
139  (let ((flags (macptr-flags macptr)))
140    ; we set to $flags_normal before calling the dispose function.
141    ; (client code can and does depend on this).
142    ; hence, if it aborts a memory leak results.
143    ; if we were to wait until after the user function returns
144    ; to put in the $flags_normal, then it will get called again
145    ; and might try to free something twice: crash!
146    (setf (macptr.flags macptr) #.$flags_normal)
147    (case flags
148      (#.$flags_normal nil)
149      (#.$flags_DisposHandle (#_DisposeHandle macptr) t)
150      (#.$flags_DisposPtr    (#_DisposePtr    macptr) t)
151      (#.$flags_DisposWindow (#_DisposeWindow macptr) t)
152      (#.$flags_DisposGWorld (#_DisposeGWorld macptr) t)
153      (otherwise (error "Macptr has bogus flags")))))
154
155;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
156;;;
157;;; The PPC version uses the new general termination support
158;;;
159
160#+ppc-target
161(progn
162
163(eval-when (:compile-toplevel :execute)
164  (require "LISPEQU"))
165
166(defvar *macptr-termination-population*
167  (%cons-terminatable-alist))
168
169(defun make-terminable-macptr (macptr termination-function &key master)
170  (let* ((p (%inc-ptr macptr 0))
171         (cell (list (cons p termination-function)))
172         (population *macptr-termination-population*))
173    (without-interrupts
174     (setf (cdr cell) (population-data population)
175           (population-data population) cell))
176    (when master
177      (register-slave-macptr p master))
178    p))
179
180(defun terminable-macptr-p (thing)
181  (or (not (eql $flags_normal (macptr-flags thing)))
182      (member thing (population-data *macptr-termination-population*)
183              :key 'car)))
184
185(defun deactivate-macptr (macptr &key (deactivate-only t))
186  (unless (macptrp macptr)
187    (setq macptr (require-type macptr 'macptr)))
188  (let ((termination-function nil)
189        (population *macptr-termination-population*))
190    (flet ((test (macptr cell) (and (eq macptr (car cell)) (setq termination-function (cdr cell)))))
191      (declare (dynamic-extent #'test))
192      (without-interrupts
193       (setf (population-data population)
194             (delete macptr (population-data population)
195                     :test #'test
196                     :count 1))))
197    (when termination-function
198      (remhash macptr *terminable-slaves-table*))
199    (if deactivate-only
200      termination-function
201      (prog1
202        (if termination-function
203          (funcall termination-function macptr)
204          (progn
205            (dispose-gcable-macptr macptr)
206            (remhash macptr *slave-macptrs-table*)))
207        (macptr->dead-macptr macptr)))))
208
209; The post GC hook
210(defun terminate-macptrs ()
211  (let ((population *macptr-termination-population*)
212        list cell)
213    (loop
214      (without-interrupts
215       (setq list (population-termination-list population))
216       (unless list (return))
217       (setf cell (car list)
218             (population-termination-list population) (cdr list)
219             (cdr list) nil))
220      (let ((macptr (car cell)))
221        (if (funcall (cdr cell) macptr)
222          (remhash macptr *terminable-slaves-table*)
223          (without-interrupts
224           (setf (cdr list) (population-data population)
225                 (population-data population) list)))))))
226
227(defun macptr->dead-macptr (macptr)
228  (if (macptrp macptr)
229    (%macptr->dead-macptr macptr)
230    (macptr->dead-macptr (require-type macptr 'macptr))))
231
232
233
234; Call this before save-application.
235; It makes no sense to keep terminable macptrs around after that.
236; They'll be dead-macptr's then causing lots of grief.
237(defun clear-terminable-macptrs ()
238  (let ((population *macptr-termination-population*))
239    (setf (population-data population) nil
240          (population-termination-list population) nil)
241    (clrhash *slave-macptrs-table*)))
242
243)  ; end of #+ppc-target progn
244
245
246;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
247;;;
248;;; The 68K version needs to work harder.
249;;; It also requires a kernel patch.
250;;; It won't work in a vanilla MCL 3.0 (or 2.0).
251;;;
252
253#-ppc-target
254(progn
255
256(eval-when (:compile-toplevel :execute)
257  (require "LAPMACROS")
258
259  (defconstant $flags_terminable 5)
260  (defconstant $flags_terminate_when_ready 6)
261 
262  (defconstant $gc-finalize-macptrs-bit (- 26 $fixnumshift))
263  (defconstant $gc-post-egc-hook-p (- 25 $fixnumshift))
264 
265  (def-accessors () %svref
266    nil                                   ; macptr.ptr
267    nil                                   ; macptr.flags
268    macptr.link
269    macptr.id
270    macptr-size)
271 
272  ; This is not exported from the kernel. In future MCL versions, it
273  ; will be and this definition will not be necessary.
274  ; This value came from the lisp-8.map file for the new kernel
275  (defconstant $gcable_ptrs (- #xD84 #x1000))
276  )
277
278(defun gcable-ptrs-head ()
279  (lap-inline ()
280    (move.l (a5 $gcable_ptrs) acc)))
281
282(defun (setf macptr-flags) (value p)
283  (setq p (require-type p 'macptr))
284  (setq value (require-type value 'fixnum))
285  (lap-inline (value p)
286    (move.l arg_z atemp0)
287    (getint arg_y)
288    (move.l arg_y (atemp0 $macptr.flags)))
289  value)
290
291;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
292;;;
293;;; cons-terminable-macptr & map-over-terminated-macptrs
294;;; are the low-level interface to this package.
295;;;
296
297; Create a terminable macptr from another macptr
298(defun cons-terminable-macptr (macptr &optional (id 0))
299  (setq macptr (require-type macptr 'macptr))
300  (setq id (require-type id 'fixnum))
301  (let ((p (make-uvector macptr-size $v_macptr :initial-element 0)))
302    (%setf-macptr p macptr)
303    (setf (macptr-flags p) $flags_terminable
304          (macptr.id p) id)
305    (lap-inline (p)
306      (move.l arg_z atemp0)
307      (move.l (a5 $gcable_ptrs) (svref atemp0 macptr.link))
308      (move.l atemp0 (a5 $gcable_ptrs)))
309    p))
310
311; Calls function with each terminated macptr.
312; If function returns NIL, will not reap the macptr;
313; it will reappear in the list of terminated macptrs after the next GC
314; (assuming FUNCTION didn't store it somewhere).
315(defun map-over-terminated-macptrs (function)
316  (declare (fixnum *gc-event-status-bits*))
317  (when (logbitp $gc-finalize-macptrs-bit *gc-event-status-bits*)
318    (let ((done? nil))
319      (unwind-protect
320        (let ((p (gcable-ptrs-head)))
321          (setq *gc-event-status-bits*
322                (the fixnum 
323                     (bitclr $gc-finalize-macptrs-bit *gc-event-status-bits*)))
324          (loop
325            (when (eql 0 p)
326              (return))
327            (when (eql $flags_terminate_when_ready (macptr-flags p))
328              ; We set to $flags_normal BEFORE calling the user function.
329              ; Hence, if it aborts a memory leak results.
330              ; If we were to wait until after the user function returns
331              ; to put in the $flags_normal, then it will get called again
332              ; and might try to free something twice: CRASH!
333              (setf (macptr-flags p) $flags_normal)
334              (unless (funcall function p)
335                (setf (macptr-flags p) $flags_terminable)))
336            (setq p (macptr.link p)))
337          (setq done? t))
338        (unless done?
339          (setq *gc-event-status-bits*
340                (the fixnum
341                     (bitset $gc-finalize-macptrs-bit *gc-event-status-bits*))))))))
342
343;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
344;;;
345;;; make-terminable-macptr is the user entry point.
346;;;
347
348; This table cannot be weak on key since hash tables are reaped before gcable-macptrs.
349(defvar *termination-functions-table* (make-hash-table :test 'eql))
350
351(defvar *terminable-macptr-max-id* most-negative-fixnum)
352(defvar *free-terminable-macptr-ids* nil)
353
354(defun make-terminable-macptr (macptr termination-function &key master)
355  (let* ((id (or (pop *free-terminable-macptr-ids*)
356                 (incf *terminable-macptr-max-id*)))
357         (p (cons-terminable-macptr macptr id)))
358    (setf (gethash id *termination-functions-table*) termination-function
359          (gethash nil *termination-functions-table*) nil)       ; clear cache
360    (when master
361      (register-slave-macptr p master))
362    p))
363
364(defun terminable-macptr-p (thing)
365  (not (eql $flags_normal (macptr-flags thing))))
366
367(defun terminate-macptrs ()
368  (map-over-terminated-macptrs
369   #'(lambda (p)
370       (let* ((id (macptr.id p))
371              (termination-function (gethash id *termination-functions-table*)))
372         (if termination-function
373           (when (funcall termination-function p)
374             (remhash id *termination-functions-table*)
375             (remhash p *terminable-slaves-table*)
376             (push id *free-terminable-macptr-ids*)
377             t)
378           (progn
379             (cerror "Continue." "Can't find ~s in ~s"
380                     p '*termination-functions-table*)
381             t))))))
382
383(defun deactivate-macptr (macptr &key (deactivate-only t))
384  (setq macptr (require-type macptr 'macptr))
385  (let ((flags (macptr-flags macptr))
386        (termination-function nil))
387    (unless (eql $flags_normal flags)
388      (when (or (eql flags $flags_terminable)
389                (eql flags $flags_terminate_when_ready))
390        (setf (macptr-flags macptr) $flags_normal)
391        (let ((id (macptr.id macptr)))
392          (setq termination-function
393                (if deactivate-only
394                  t
395                  (gethash id *termination-functions-table*)))
396          (remhash id *termination-functions-table*)
397          (push id *free-terminable-macptr-ids*)
398          (remhash macptr *terminable-slaves-table*)))
399      (if deactivate-only
400        termination-function
401        (prog1
402          (if termination-function
403            (funcall termination-function macptr)
404            (progn
405              (dispose-gcable-macptr macptr)
406              (remhash macptr *slave-macptrs-table*)))
407          (macptr->dead-macptr macptr))))))
408
409#+ccl-3
410(defun macptr->dead-macptr (macptrObject)
411  (require-type macptrObject 'macptr)
412  (lap-inline ()
413    (:variable macptrobject)
414    (move.l (varg macptrObject) atemp0)
415    (set_vsubtype ($ $v_badptr) atemp0 da))
416  macptrObject)
417 
418#-ccl-3
419(defun macptr->dead-macptr (macptrObject)
420  (require-type macptrObject 'macptr)
421  (lap
422    (move.l (varg macptrObject) atemp0)
423    (move.b ($ $v_badptr) (atemp0 $v_subtype)))
424  macptrObject)
425
426; Call this before save-application.
427; It makes no sense to keep terminable macptrs around after that.
428; They'll be dead-macptr's then causing lots of grief.
429(defun clear-terminable-macptrs ()
430  (clrhash *termination-functions-table*)
431  (clrhash *slave-macptrs-table*))
432
433)  ; End of #-ppc-target progn
434
435(pushnew 'clear-terminable-macptrs *save-exit-functions*)
436
437;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
438;;;
439;;; Backward compatibility for the gc-hook maintenance functions.
440;;;
441
442(defun add-pre-gc-hook (hook)
443  (add-gc-hook hook :pre-gc))
444
445(defun delete-pre-gc-hook (hook)
446  (remove-gc-hook hook :pre-gc))
447
448(defun add-post-gc-hook (hook)
449  (add-gc-hook hook :post-gc))
450
451(defun delete-post-gc-hook (hook)
452  (remove-gc-hook hook :post-gc))
453
454;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
455;;;
456;;; Enabling the ccl::*post-gc-hook* after EGC
457;;;
458
459#|  ; These are built in now
460
461(defun post-egc-hook-enabled-p ()
462  (declare (fixnum *gc-event-status-bits*))
463  (logbitp $gc-post-egc-hook-p *gc-event-status-bits*))
464
465(defun set-post-egc-hook-enabled-p (value)
466  (declare (fixnum *gc-event-status-bits*))
467  (setq *gc-event-status-bits*
468        (if (setq value (not (null value)))
469          (the fixnum (bitset $gc-post-egc-hook-p *gc-event-status-bits*))
470          (the fixnum (bitclr $gc-post-egc-hook-p *gc-event-status-bits*))))
471  value)
472
473|#
474 
475;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
476;;;
477;;; Install the hook
478;;;
479
480(add-post-gc-hook 'terminate-macptrs)
Note: See TracBrowser for help on using the repository browser.