/[mcclim]/mcclim/defresource.lisp
ViewVC logotype

Contents of /mcclim/defresource.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (show annotations)
Fri Mar 21 21:36:58 2003 UTC (11 years ago) by mikemac
Branch: MAIN
CVS Tags: McCLIM-0-9, mcclim-0-9-4, McCLIM-0-9-5, McCLIM-0-9-4, McCLIM-0-9-6, McCLIM-0-9-1, McCLIM-0-9-3, McCLIM-0-9-2, HEAD
Changes since 1.5: +1 -1 lines
make all of the package names passed to in-package be lowercase keywords for ACL's java mode
1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-INTERNALS; -*-
2 ;;; ---------------------------------------------------------------------------
3 ;;; Title: CLIM-2 Chapter 32.1 Resources
4 ;;; Created: 2001-05-21
5 ;;; Author: Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
6 ;;; License: LGPL (See file COPYING for details).
7 ;;; ---------------------------------------------------------------------------
8 ;;; (c) copyright 2001 by Gilbert Baumann
9
10 ;;; This library is free software; you can redistribute it and/or
11 ;;; modify it under the terms of the GNU Library General Public
12 ;;; License as published by the Free Software Foundation; either
13 ;;; version 2 of the License, or (at your option) any later version.
14 ;;;
15 ;;; This library is distributed in the hope that it will be useful,
16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 ;;; Library General Public License for more details.
19 ;;;
20 ;;; You should have received a copy of the GNU Library General Public
21 ;;; License along with this library; if not, write to the
22 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;;; Boston, MA 02111-1307 USA.
24
25 ;;;; Changes
26
27 ;;; When Who What
28 ;;; --------------------------------------------------------------------------------------
29 ;;; 2002-02-10 GB named allocator function
30 ;;; 2001-05-21 GB created
31
32 (in-package :clim-internals)
33
34 ;;;; 32.1 Resources
35
36 ;;; TODO
37 ;; - provide a "real" using-resource expansion
38 ;; - under CMU ATOMIC-INCF is a performance blocker, what to do?
39 ;; - use per process free-lists?
40 ;; - use two lists? One for free objects, one for allocated?
41
42 ;;; NOTES
43
44 ;; It seems wasteful not to shuffle objects. When there are already a
45 ;; couple of objects in use and these are in front of
46 ;; RESOURCE-OBJECTS, we revisit them each time while finding. On the
47 ;; other hand, when we would like to shuffle the list of objects, we
48 ;; would need to acquire another lock, which seems equally wasteful.
49
50 ;; Further: This somewhat assumes a feasible implementation of
51 ;; ATOMIC-INCF and ATOMIC-DECF. If plain vanilla locks or
52 ;; WITHOUT-SCHEDULING is faster, we would be better off using that.
53
54 ;; USING-RESOURCE should not cause unnecessary consing. To test this I
55 ;; appended a test case below. There is an UNWIND-PROTECT in the
56 ;; definition of USING-RESOURCE, which might cause consing. (E.g. CMU
57 ;; does so, when the clean-up form writes to variables defined outside
58 ;; of it).
59
60 ;; Also I tried to define all this in a way, that the no assumptions
61 ;; about random user code is made. Specifically: no locks are held,
62 ;; scheduling is _not_ disabled, any of the resource API can be
63 ;; called.
64
65 ;; ) unlike under Genera it seems.
66
67 (defvar *resource-table*
68 (make-hash-table :test #'eq)
69 "Hash table of all defined resource types.")
70
71 (defstruct resource
72 ;; One defined resource
73 name ;its name just for the sake of it
74 objects ;a list of RESOURCE-OBJECTs
75 lock ;A regular process lock to protect the OBJECTS slot.
76 allocator ;function to allocate an object
77 ; takes the resource and the parameters.
78 ; Returns two values: the object and its
79 ; descriptor (a RESOURCE-OBJECT)
80 ; [cf. Genera's definition allocate-resource]
81 deallocator) ;function to deallocate an object
82 ; takes three arguments: the resource, the
83 ; object and the descriptor.
84
85
86 (defstruct resource-object
87 ;; One resourced object
88 object ;the object itself
89 lock ;homebrew lock
90 ; is >= 1, if resource is allocated or investigated
91 ; is 0, if resource is free
92 parameters) ;list of parameters supplied, while allocating this
93 ; object. Needed for a possible deinitializer
94 ; or default matcher. NIL if not needed at all.
95
96 (defun find-resource (name &optional barfp)
97 (or (gethash name *resource-table*)
98 (if barfp
99 (progn
100 (cerror "Try again to find resource ~S (after you defined it)"
101 "There is no such resource: ~S." name)
102 (find-resource name))
103 nil)))
104
105 (defun (setf find-resource) (value name)
106 (setf (gethash name *resource-table*) value))
107
108 (defun allocate-resource (name &rest parameters)
109 "Allocates an object from the resource."
110 (let ((resource (find-resource name)))
111 (values (apply (the function (resource-allocator resource))
112 resource parameters))) )
113
114 (defun deallocate-resource (name object)
115 "Returns the object to the resource."
116 (let ((resource (find-resource name)))
117 (funcall (the function (resource-deallocator resource))
118 resource object)) )
119
120 (defmacro using-resource ((variable name &rest parameters) &body body)
121 "The forms in 'body' are evaluated with 'variable' bound to an object
122 allocated from the resource named 'name', using the parameters given
123 by 'parameters'."
124 (let ((r. (gensym "R."))
125 (ro. (gensym "RO."))
126 (evil-cell (gensym "EVIL-CELL.")))
127 `(let* ((,evil-cell (load-time-value (list nil)))
128 (,r. (or (car (the cons ,evil-cell))
129 (setf (car (the cons ,evil-cell))
130 (find-resource ',name)))))
131 ;; Q: Why this EVIL-CELL hack? And not
132 ;; (load-time-value (find-resource ..))?
133 ;; A: Since the time of actual evaluation of the LOAD-TIME-VALUE is
134 ;; unspecified with regard to other [top level] forms in a file[,
135 ;; when loaded]. But I want the DEFRESOURCE to evaluate before this
136 ;; LOAD-TIME-VALUE.
137 (multiple-value-bind (,variable ,ro.)
138 (funcall (resource-allocator ,r.) ,r. ,@parameters)
139 (unwind-protect
140 (locally ,@body)
141 (when ,variable
142 (funcall (resource-deallocator ,r.) ,r. ,variable ,ro.)))))))
143
144 (defun clear-resource (name)
145 "Removes all of the resourced object from the resource."
146 (let ((resource (find-resource name)))
147 (setf (resource-objects resource) nil)))
148
149 (defun map-resource (function name)
150 "Calls function once on each object in the resource."
151 (let ((resource (find-resource name)))
152 (dolist (resource-object (resource-objects resource))
153 (funcall function
154 (resource-object-object resource-object)
155 (not (zerop (car (resource-object-lock resource-object))))
156 name))))
157
158 (defmacro defresource (name parameters
159 &key (constructor (error "~S argument is required" :constructor))
160 initializer
161 deinitializer
162 matcher
163 initial-copies)
164 ;; First do some type checks
165 (check-type name symbol)
166 ;; Safety first: Check a possible definition lock.
167 (let ((pack (symbol-package name)))
168 (when (or (eq pack (find-package :keyword))
169 (eq pack (find-package :common-lisp))
170 #+excl (excl:package-definition-lock pack)
171 )
172 (cerror "Define resource ~S anyway"
173 "Resource ~S cannot be defined, since its home package, ~S, is locked."
174 name (package-name pack))))
175 ;; Collect parameter variables
176 (let ((pvars nil))
177 (dolist (parameter parameters)
178 (cond ((member parameter lambda-list-keywords)
179 nil)
180 ((symbolp parameter)
181 (pushnew parameter pvars))
182 ((consp parameter)
183 (if (consp (first parameter))
184 (pushnew (second (first parameter)) pvars)
185 (pushnew (first parameter) pvars))
186 (when (third parameter)
187 (pushnew (third parameter) pvars)))))
188 (setf pvars (reverse pvars))
189
190 (let ((parameters-needed-p
191 (or (null matcher)
192 (not (null deinitializer)))))
193 (labels ((allocate-fresh-expr (r.)
194 ;; Allocate a fresh object
195 (let ((ro. (gensym "RO.")))
196 `(let ((,ro.
197 (make-resource-object
198 :object ,constructor
199 :lock (list 1)
200 :parameters ,(if parameters-needed-p
201 `(make-list ,(length pvars))
202 'nil))))
203 (with-lock-held ((resource-lock ,r.))
204 (push ,ro. (resource-objects ,r.)))
205 ,ro.)) )
206
207 (match-expr (ro.)
208 ;; Compilation of the matcher
209 (let ((q. (gensym "Q.")))
210 (if matcher
211 `(let ((,name (resource-object-object ,ro.)))
212 (declare (ignorable ,name))
213 ,matcher)
214 `(let ((,q. (resource-object-parameters ,ro.)))
215 (declare (ignorable ,q.))
216 (and
217 ,@(loop for p in pvars collect
218 `(equal (pop ,q.) ,p)))))))
219
220 (find-expr (r.)
221 ;; Find an object, which matches or allocate a fresh one.
222 ;;
223 ;; To improve granularity of locking, each allocated resource
224 ;; carries its own lock. Furthermore, when a lock is not
225 ;; available, we do not care to wait, but simply choose to
226 ;; carry on. Furthermore we consider resources in use as
227 ;; locked. This saves us another test while finding at the
228 ;; expense that MAP-RESOURCE might once in a while report a
229 ;; resource as used, while somebody else is just peeking.
230 ;;
231 (let ((ro. (gensym "$RO."))
232 (lock. (gensym "$LOCK.")))
233 `(dolist (,ro. (resource-objects ,r.)
234 ;; fall back: allocate a fresh object
235 ,(allocate-fresh-expr r.))
236 (declare (type resource-object ,ro.))
237 (let ((,lock. (resource-object-lock ,ro.)))
238 (declare (type cons ,lock.))
239 (when (= 0 (the fixnum (car ,lock.)))
240 (atomic-incf (the fixnum (car ,lock.)))
241 (cond ((and (= 1 (the fixnum
242 (locally
243 #+excl (declare (optimize (safety 3))) ;EXCL bug
244 (car ,lock.))))
245 ,(match-expr ro.))
246 (return ,ro.))
247 (t
248 (atomic-decf (the fixnum (car ,lock.)))) ))))))
249
250 (allocator ()
251 ;; Function for ALLOCATE-RESOURCE
252 (let ((r. (gensym "R."))
253 (ro. (gensym "RO."))
254 (fn. (make-symbol
255 (with-standard-io-syntax
256 (let ((*package* (find-package :keyword)))
257 (format nil "ALLOCATOR for ~S" name))))))
258 `(labels ((,fn. (,r. ,@parameters)
259 (let ((,ro. ,(find-expr r.)))
260 (declare (type resource-object ,ro.))
261 ;; install parameters in resource-object and eval initializer
262 ,(install-parameters-expr ro.)
263 (let ((,name (resource-object-object ,ro.)))
264 (declare (ignorable ,name))
265 ,initializer)
266 ;; done
267 (values (resource-object-object ,ro.)
268 ,ro.))))
269 #',fn.)))
270
271 (install-parameters-expr (ro.)
272 (and parameters-needed-p
273 (let ((q. (gensym "Q.")))
274 `(let ((,q. (resource-object-parameters ,ro.)))
275 (declare (ignorable ,q.))
276 ,@(loop for p in pvars collect
277 `(setf (car ,q.) ,p ,q. (cdr ,q.)))))))
278
279 (deallocator ()
280 ;; Function for deallocate-resource
281 (let ((r. (gensym "R."))
282 (ro. (gensym "RO."))
283 (obj. (gensym "OBJ"))
284 (q. (gensym "Q"))
285 (lock. (gensym "LOCK")))
286 `(lambda (,r. ,obj. &optional ,ro.)
287 (unless ,ro.
288 (do ((q (resource-objects (the resource ,r.)) (cdr (the cons q))))
289 ((null q)
290 (error "Something corrupted."))
291 (let ((ro (car (the cons q))))
292 (declare (type resource-object ro))
293 (when (eq ,obj. (resource-object-object ro))
294 (setf ,ro. ro)
295 (return)))))
296 (locally
297 (declare (type resource-object ,ro.))
298 (let ((,name ,obj.))
299 (declare (ignorable ,name))
300 ,(when deinitializer
301 `(destructuring-bind (,@pvars) (resource-object-parameters ,ro.)
302 (declare (ignorable ,@pvars))
303 ,deinitializer)))
304 ,(if (and matcher (not (null deinitializer)))
305 `(let ((,q. (resource-object-parameters ,ro.)))
306 ,@(loop repeat (length pvars) collect
307 `(setf (car ,q.) nil ,q. (cdr ,q.))))
308 nil)
309 (let ((,lock. (resource-object-lock ,ro.)))
310 (atomic-decf (the fixnum (car ,lock.)))))))) )
311 ;;
312 (let* ((r. (gensym "R."))
313 (q. (gensym "Q."))
314 (allocator. (gensym "ALLOCATOR."))
315 (deallocator. (gensym "DEALLOCATOR.")) )
316 `(progn
317 #+excl (excl:record-source-file ',name :type :resource-definition)
318 (let* ((,allocator. ,(allocator))
319 (,deallocator. ,(deallocator))
320 (,r.
321 (or ;; (find-resource ',name)
322 (make-resource
323 :name ',name
324 :objects nil
325 :lock (make-lock (let ((*package* (find-package :keyword)))
326 (format nil "Resource ~S" ',name)))))))
327 (setf (resource-allocator ,r.) ,allocator.
328 (resource-deallocator ,r.) ,deallocator.)
329 ;; Care for initial copies
330 ,(when initial-copies
331 `(progn
332 (dotimes (,q. ,initial-copies)
333 (funcall ,allocator. ,r.))
334 (dolist (,q. (resource-objects ,r.))
335 (funcall ,deallocator. ,r. (resource-object-object ,q.) ,q.))))
336 ;; Finally install the resource
337 (setf (find-resource ',name) ,r.)
338 ;; Out of habit we return the name, although nobody uses a
339 ;; printing LOAD these days.
340 ',name) ))))))
341
342 ;;; --------------------
343 ;;; Proposal
344
345 ;; PERMANENTLY-DEALLOCATE-RESOURCE name object [Function]
346
347 ;; Deallocate 'object' and indicate, that it is no longer useful to retain it.
348
349 ;; EXAMPLE
350
351 ;; One might consider connections to FTP servers as a resource. But those
352 ;; connection can become dead on "itself", because the FTP server might have
353 ;; chosen to kick us out due to inactivity. With
354 ;; PERMANENTLY-DEALLOCATE-RESOURCE it is now possible to selectively clean
355 ;; up the those objects. Or do it on demand, while matching.
356
357 ;; (defresource ftp-connection (host &optional (port +ftp-port+))
358 ;; :constructor (make-ftp-connection host port)
359 ;; :matcher (cond ((connection-dead-p ftp-connection)
360 ;; (permanently-deallocate-resource
361 ;; 'ftp-connection ftp-connection)
362 ;; nil)
363 ;; ((and (equal (ftp-connection-host host) host)
364 ;; (equal (ftp-connection-port port) port))))
365 ;; :destructor (close-ftp-connection ftp-connection))
366
367 ;; IMPLICATIONS
368
369 ;; We now also need a :DESTRUCTOR option to indicate actions needed, when we
370 ;; throw away an object. These should also be invoked, when one does a
371 ;; CLEAR-RESOURCE.
372
373 ;;; --------------------
374
375 ;;; Test cases
376
377 #||
378
379 ;; First a minimal speed test
380
381 (defresource seventeen ()
382 :constructor 17)
383
384 (defun test-seventeen ()
385 ;; should not cons at all
386 (dotimes (i 1000000)
387 (using-resource (x seventeen))))
388
389 ;; Now a more sophisticated test:
390
391 (defstruct foo x y)
392
393 (defresource foo (&optional (x 10) (y 20))
394 :constructor (make-foo)
395 :initializer (setf (foo-x foo) x
396 (foo-y foo) y)
397 :initial-copies 3)
398
399 (defun test-foo ()
400 (dotimes (i 1000000)
401 (using-resource (x foo 8 9))))
402
403 ||#

  ViewVC Help
Powered by ViewVC 1.1.5