source: tags/vers-0.961/persistent-clos.lisp@ 38

Last change on this file since 38 was 3, checked in by Gail Zacharias, 17 years ago

Recovered version 0.961 from Sheldon Ball <s.ball@…>
  • Property svn:eol-style set to native
File size: 33.4 KB
Line 
1;;;-*- Mode: Lisp; Package: (WOOD) -*-
2
3;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4;;
5;; persistent-clos.lisp
6;; Support for saving/restoring CLOS instances to/from Wood persistent heaps.
7;;
8;; Copyright © 1996 Digitool, Inc.
9;; Copyright © 1992-1995 Apple Computer, Inc.
10;; All rights reserved.
11;; Permission is given to use, copy, and modify this software provided
12;; that Digitool is given credit in all derivative works.
13;; This software is provided "as is". Digitool makes no warranty or
14;; representation, either express or implied, with respect to this software,
15;; its quality, accuracy, merchantability, or fitness for a particular
16;; purpose.
17;;
18
19;;;;;;;;;;;;;;;;;;;;;;;;;;
20;;
21;; Modification History
22;;
23;; 08/28/98 akh add dc-shared-initialize - fixes case of change class in memory, then write a slot-value to pheap
24;; left us with the class updated on disk but not the instance-slots with initforms
25;; ------------- 0.96
26;; ------------- 0.95
27;; ------------- 0.94
28;; ------------- 0.93
29;; ------------- 0.9
30;; 11/02/94 bill (method %p-store-object (t standard-object t)) no longer
31;; handles p-make-load-function-using-pheap. It has moved
32;; into %p-store-internal now.
33;; 10/28/94 Moon Change without-interrupts to with-databases-locked
34;; 10/25/94 bill p-load-instance calls wood-disk-resident-slot-names,
35;; a new GF that users can specialize.
36;; define-disk-resident-slot-names macro to aid generation
37;; of wood-disk-resident-slot-names methods and accessor
38;; methods that will swap disk resident slots in when
39;; necessary.
40;; 09/21/94 bill without-interrupts as necessary for interlocking
41;; -------------- 0.8
42;; 10/25/93 bill initialize-persistent-instance
43;; -------------- 0.6
44;; 02/16/93 bill p-load-instance now calls shared-initialize to initialize
45;; any new slots (slots that have been added since the instance
46;; was saved to the pheap file).
47;; 11/16/92 bill pheap-class-hash, p-class-instance-slot-names
48;; 11/09/92 bill Make it work correctly to create two instances, p-store them,
49;; redefine the class adding a slot, p-store the first instance,
50;; close and reopen the pheap, then p-load the second instance.
51;; chung@ils.nwu.edu found that this used to result in an instance all
52;; of whose slots were unbound.
53;; 08/27/92 bill in %p-store-object: call p-make-load-function
54;; 08/13/92 bill (setf p-slot-value) now does the right thing if instance
55;; is not a PPTR.
56;; -------------- 0.5
57;; 06/23/92 bill New file
58;;
59
60(in-package :wood)
61
62(defun pheap-class-hash (pheap)
63 (let ((hash (dc-class-hash (pheap-disk-cache pheap))))
64 (when hash
65 (pptr pheap hash))))
66
67(defun dc-class-hash (disk-cache &optional create?)
68 (with-databases-locked
69 (let ((res (dc-%svref disk-cache $root-vector $pheap.class-hash)))
70 (if (eql res $pheap-nil)
71 (if create?
72 (setf (dc-%svref disk-cache $root-vector $pheap.class-hash)
73 (dc-make-hash-table disk-cache)))
74 res))))
75
76(defun p-find-class (pheap name &optional (errorp t))
77 (multiple-value-bind (pointer imm?) (%p-store-hash-key pheap name)
78 (when pointer
79 (let ((res (dc-find-class (pheap-disk-cache pheap) pointer imm? errorp)))
80 (when res (pptr pheap res))))))
81
82(defun dc-find-class (disk-cache pointer immediate? &optional (errorp t))
83 (let ((hash (dc-class-hash disk-cache)))
84 (or (and hash
85 (dc-gethash disk-cache pointer immediate? hash))
86 (when errorp
87 (error "Class named ~s not found."
88 (dc-pointer-load disk-cache pointer immediate?))))))
89
90; Will overwrite an existing class
91(defun p-make-class (pheap name slots)
92 (unless (and (vectorp slots) (every 'symbolp slots))
93 (error "~s is not a vector of slot names"))
94 (multiple-value-bind (pointer imm?) (%p-store pheap name)
95 (pptr pheap
96 (dc-make-class (pheap-disk-cache pheap)
97 pointer
98 (%p-store pheap slots)
99 imm?
100 slots
101 pheap))))
102
103(defun dc-make-class (disk-cache name slots &optional name-imm? slots-object pheap)
104 (let* ((class (dc-make-uvector disk-cache $class-size $v_class))
105 (hash (dc-class-hash disk-cache t))
106 (wrapper (dc-make-class-wrapper disk-cache class slots slots-object pheap)))
107 (dc-%svfill disk-cache class
108 ($class.name name-imm?) name
109 $class.own-wrapper wrapper)
110 (dc-puthash disk-cache name name-imm? hash class)))
111
112(defun dc-make-class-wrapper (disk-cache class slots &optional slots-object pheap)
113 (let ((wrapper (dc-make-vector disk-cache $wrapper-size)))
114 (dc-%svfill disk-cache wrapper
115 $wrapper.class class
116 $wrapper.slots slots)
117 (when slots-object
118 (setf (gethash slots-object
119 (wrapper-hash (or pheap (disk-cache-pheap disk-cache))))
120 wrapper))
121 wrapper))
122
123; Access a (disk) class'es wrapper. Update it to agree with the
124; class in memory, if there is one.
125; Returns 2 value:
126; 1) the (possibly new) wrapper
127; 2) the in-memory class, or NIL if there isn't one.
128; 3) the vector of slot names for the in-memory class, or NIL
129; 4) true if the class'es was obsolete.
130(defun dc-update-class-wrapper (disk-cache class &optional pheap memory-class dont-update)
131 (unless pheap (setq pheap (disk-cache-pheap disk-cache)))
132 (if (eq memory-class :none)
133 (setq memory-class nil)
134 (let* ((name (pointer-load pheap (dc-%svref disk-cache class $class.name) :default disk-cache)))
135 (setq memory-class (find-class name nil))))
136 (with-databases-locked
137 (let ((wrapper (dc-%svref disk-cache class $class.own-wrapper))
138 (obsolete? nil)
139 slot-names)
140 (when memory-class
141 (let ((wrapper-hash (wrapper-hash pheap)))
142 (setq slot-names (wood-slot-names-vector (class-prototype memory-class)))
143 (unless (eql wrapper (gethash slot-names wrapper-hash))
144 (let ((old-slot-names (pointer-load pheap (dc-%svref disk-cache wrapper $wrapper.slots)
145 :default disk-cache)))
146 (if (equalp old-slot-names slot-names)
147 (setf (gethash slot-names wrapper-hash) wrapper)
148 (progn
149 (setq obsolete? t)
150 (unless dont-update
151 (setf wrapper (dc-make-class-wrapper
152 disk-cache class
153 (%p-store pheap slot-names) slot-names pheap)
154 (dc-%svref disk-cache class $class.own-wrapper) wrapper))))))))
155 (values wrapper memory-class slot-names obsolete?))))
156
157
158; This knows internals of MCL's CLOS implementation
159(defun class-slots-vector (class)
160 (ccl::%wrapper-instance-slots
161 (or (ccl::%class-own-wrapper class)
162 (ccl::initialize-class-and-wrapper class))))
163
164(defun dc-make-class-slots-vector (disk-cache class &optional
165 (pheap (disk-cache-pheap disk-cache)))
166 (%p-store pheap (wood-slot-names-vector (class-prototype class))))
167
168(def-predicate ccl::classp (p disk-cache pointer)
169 (dc-vector-subtype-p disk-cache pointer $v_class))
170
171(def-accessor class-name (p) (disk-cache pointer)
172 (require-satisfies dc-classp disk-cache pointer)
173 (dc-%svref disk-cache pointer $class.name))
174
175(defun (setf dc-class-name) (value disk-cache class &optional value-imm?)
176 (require-satisfies dc-classp disk-cache class)
177 (setf (dc-%svref disk-cache class $class.name value-imm?) value)
178 (values value value-imm?))
179
180(def-accessor class-own-wrapper (p) (disk-cache pointer)
181 (require-satisfies dc-classp disk-cache pointer)
182 (dc-%svref disk-cache pointer $class.own-wrapper))
183
184(defun (setf dc-class-own-wrapper) (value disk-cache class &optional value-imm?)
185 (require-satisfies dc-classp disk-cache class)
186 (setf (dc-%svref disk-cache class $class.own-wrapper value-imm?) value)
187 (values value value-imm?))
188
189(defmacro dc-wrapper-class (disk-cache wrapper)
190 `(dc-uvref ,disk-cache ,wrapper $wrapper.class))
191
192(defmacro dc-wrapper-slots (disk-cache wrapper)
193 `(dc-uvref ,disk-cache ,wrapper $wrapper.slots))
194
195(def-accessor class-instance-slot-names (p) (disk-cache pointer)
196 (require-satisfies dc-classp disk-cache pointer)
197 (dc-wrapper-slots disk-cache (dc-class-own-wrapper disk-cache pointer)))
198
199(defun class-instance-slot-names (class)
200 (let ((wrapper (class-own-wrapper class)))
201 (unless wrapper
202 (class-prototype class)
203 (setq wrapper (class-own-wrapper class))
204 (unless wrapper (error "Can't find class-own-wrapper for ~s" class)))
205 (ccl::%wrapper-instance-slots wrapper)))
206
207(defun p-instance-class (instance)
208 (if (pptr-p instance)
209 (let* ((pheap (pptr-pheap instance))
210 (disk-cache (pheap-disk-cache pheap))
211 (pointer (pptr-pointer instance)))
212 (pointer-load
213 pheap
214 (dc-wrapper-class disk-cache (dc-instance-class-wrapper disk-cache pointer))))
215 (class-of instance)))
216
217(defmethod %p-store-object (pheap (object standard-class) descend)
218 (let* ((disk-cache (pheap-disk-cache pheap))
219 (descend (eq descend t))
220 name imm?
221 (address (maybe-cached-address pheap object
222 (multiple-value-setq (name imm?)
223 (%p-store pheap (class-name object)))
224 (or (dc-find-class disk-cache name imm? nil)
225 (progn
226 (setq descend nil)
227 (dc-make-class disk-cache
228 name
229 (dc-make-class-slots-vector
230 disk-cache object pheap)
231 imm?))))))
232 (when descend
233 (unless name
234 (multiple-value-setq (name imm?) (%p-store pheap (class-name object))))
235 (setf (dc-class-name disk-cache address imm?) name)
236 (setf (dc-wrapper-slots disk-cache (dc-class-own-wrapper disk-cache address))
237 (dc-make-class-slots-vector disk-cache object pheap)))
238 address))
239
240(defun p-load-class (pheap disk-cache pointer depth subtype)
241 (declare (ignore depth subtype))
242 (maybe-cached-value pheap pointer
243 (multiple-value-bind (name-pointer imm?) (dc-class-name disk-cache pointer)
244 (let ((name (dc-pointer-load disk-cache name-pointer imm? pheap)))
245 (or (find-class name nil)
246 (let ((slots (pointer-load pheap
247 (dc-wrapper-slots
248 disk-cache
249 (dc-class-own-wrapper disk-cache pointer))
250 :default
251 disk-cache)))
252 ;; this is wrong - lose initargs, initforms
253 (eval `(defclass ,name () ,(coerce slots 'list)))))))))
254
255(defmethod p-allocate-instance (pheap (class symbol))
256 (p-allocate-instance pheap (or (p-find-class pheap class nil)
257 (p-store pheap (find-class class)))))
258
259(defmethod p-allocate-instance (pheap (class standard-class))
260 (p-%allocate-instance pheap (p-store pheap class) class))
261
262(defmethod p-allocate-instance (pheap (class pptr))
263 (require-satisfies p-classp class)
264 (p-%allocate-instance pheap class nil))
265
266(defun p-%allocate-instance (pheap class memory-class)
267 (pptr pheap (dc-%allocate-instance (pheap-disk-cache pheap) (pptr-pointer class) memory-class)))
268
269(defun dc-%allocate-instance (disk-cache class &optional memory-class)
270 (let* ((wrapper (dc-update-class-wrapper disk-cache class nil memory-class))
271 (slots (dc-make-vector
272 disk-cache
273 (dc-length disk-cache (dc-wrapper-slots disk-cache wrapper))
274 nil (%unbound-marker) t))
275 (res (dc-make-uvector disk-cache $instance-size $v_instance)))
276 (dc-%svfill disk-cache res
277 $instance.wrapper wrapper
278 $instance.slots slots)
279 res))
280
281(def-predicate ccl::standard-instance-p (p disk-cache pointer)
282 (dc-vector-subtype-p disk-cache pointer $v_instance))
283
284(def-accessor ccl::instance-class-wrapper (p) (disk-cache pointer)
285 (require-satisfies dc-standard-instance-p disk-cache pointer)
286 (dc-%svref disk-cache pointer $instance.wrapper))
287
288; This is the wrong name. Check the MOP
289(def-accessor instance-access (p index) (disk-cache pointer)
290 (require-satisfies dc-standard-instance-p disk-cache pointer)
291 (dc-uvref disk-cache (dc-%svref disk-cache pointer $instance.slots) index))
292
293(defun (setf p-instance-access) (value p index)
294 (setq index (require-type index 'fixnum))
295 (if (pptr-p p)
296 (let ((pheap (pptr-pheap p)))
297 (multiple-value-bind (v imm?) (%p-store pheap value)
298 (setf (dc-instance-access
299 (pheap-disk-cache pheap) (pptr-pointer p) index imm?)
300 v)
301 (if imm? v (pptr pheap v))))
302 (error "~s is defined only for Wood instances" '(setf p-instance-access))))
303
304(defun (setf dc-instance-access) (value disk-cache pointer index value-imm?)
305 (require-satisfies dc-standard-instance-p disk-cache pointer)
306 (setf (dc-uvref disk-cache (dc-%svref disk-cache pointer $instance.slots)
307 index value-imm?)
308 value))
309
310(defun instance-access (thing index)
311 (declare (ignore thing index))
312 (error "~s is defined only for Wood instances" 'instance-access))
313
314; Instance is an on-disk address.
315; class is an in-memory class or NIL.
316; Returns three values:
317; 1) The slots vector on disk
318; 2) The slot names vector in memory.
319; 3) slot-names vector if the instance was obsolete.
320; This will be different from the second value if the
321; dont-update arg is true.
322;
323; This is hairy because it has to deal with a lot of possibilities:
324;
325; 1) Class exists in memory, but hasn't been associated with PHEAP yet.
326; 2) Class exists in memeory and has been associated with PHEAP.
327; 3) Class does not exist in memory.
328; 4) 1 or 2 and the class has been redefined since the instance was stored in the PHEAP.
329(defun dc-updated-instance-slots (disk-cache instance memory-class pheap &optional
330 dont-update)
331 (with-databases-locked
332 (let ((old-wrapper (dc-%svref disk-cache instance $instance.wrapper))
333 (instance-slots (dc-%svref disk-cache instance $instance.slots))
334 class wrapper slot-names old-slot-names obsolete?)
335 (if memory-class
336 (progn
337 (setq slot-names (wood-slot-names-vector (class-prototype memory-class)))
338 (setq wrapper (gethash slot-names (wrapper-hash pheap))))
339 (progn
340 (setq class (dc-%svref disk-cache old-wrapper $wrapper.class))
341 (multiple-value-setq (wrapper memory-class slot-names obsolete?)
342 (dc-update-class-wrapper disk-cache class pheap nil dont-update))
343 (unless slot-names
344 (setq slot-names (pointer-load pheap (dc-%svref disk-cache old-wrapper $wrapper.slots)
345 :default disk-cache)
346 wrapper old-wrapper))))
347 (if (if (and wrapper (not obsolete?))
348 (eql wrapper old-wrapper)
349 (when (equalp slot-names
350 (setq old-slot-names
351 (pointer-load pheap (dc-%svref disk-cache old-wrapper $wrapper.slots)
352 :default disk-cache)))
353 (setq wrapper (setf (gethash slot-names (wrapper-hash pheap)) old-wrapper))))
354 ; Wrapper is current
355 (values instance-slots slot-names)
356 ; Wrapper needs updating.
357 (progn
358 (unless old-slot-names
359 (setq old-slot-names (pointer-load
360 pheap
361 (dc-%svref disk-cache old-wrapper $wrapper.slots)
362 :default disk-cache)))
363 (if dont-update
364 (values instance-slots old-slot-names slot-names)
365 (let* ((slot-count (length slot-names))
366 (slot-values (make-array slot-count))
367 (slot-imms (make-array slot-count)))
368 (declare (fixnum slot-count))
369 ;(dynamic-extent slot-values slot-imms))
370 (unless wrapper
371 (let ((class (dc-%svref disk-cache old-wrapper $wrapper.class)))
372 (setq wrapper (dc-update-class-wrapper disk-cache class pheap memory-class dont-update))))
373 (dotimes (i slot-count)
374 (let ((index (position (svref slot-names i) old-slot-names :test 'eq)))
375 (if index
376 (multiple-value-bind (value imm?) (dc-uvref disk-cache instance-slots index)
377 (setf (svref slot-values i) value
378 (svref slot-imms i) imm?))
379 (setf (svref slot-values i) (%unbound-marker)
380 (svref slot-imms i) t))))
381 (let* ((old-instance-length (dc-length disk-cache instance-slots))
382 (new-instance-slots (if (>= old-instance-length slot-count)
383 (let ((index slot-count))
384 (dotimes (i (- old-instance-length slot-count))
385 (setf (dc-uvref disk-cache instance-slots index t)
386 (%unbound-marker)))
387 instance-slots)
388 (dc-make-vector
389 disk-cache slot-count
390 (dc-area disk-cache instance-slots)
391 (%unbound-marker) t))))
392 (dotimes (i slot-count)
393 (let ((value (svref slot-values i))
394 (imm? (svref slot-imms i)))
395 (unless (and imm? (eq value (%unbound-marker)))
396 (setf (dc-%svref disk-cache new-instance-slots i imm?) value))))
397 (dc-shared-initialize disk-cache pheap slot-values new-instance-slots memory-class)
398 (setf (dc-%svref disk-cache instance $instance.wrapper) wrapper
399 (dc-%svref disk-cache instance $instance.slots) new-instance-slots)
400 (values new-instance-slots slot-names)))))))))
401
402
403(defun dc-shared-initialize (disk-cache pheap slot-values new-instance-slots class &optional (slot-names t))
404 ;; I don't know how to find all this stuff in the disk version - I don't think it's there.
405 ;; copied from %shared-initialize
406 (when class
407 (dotimes (i (uvsize (ccl::%class-instance-slotds class)))
408 (declare (fixnum i))
409 (let* ((slotd (svref (ccl::%class-instance-slotds class) i))
410 (index i)
411 (initform (ccl::%slotd-initform slotd)))
412 (when (and initform
413 (eq (svref slot-values index) (%unbound-marker))
414 (or (eq slot-names t) (memq (ccl::%slotd-name slotd) slot-names)))
415 (let ((value
416 (if (listp initform) ;(value)
417 (car initform)
418 (funcall initform))))
419 (multiple-value-bind (v imm?) (%p-store pheap value)
420 (setf (dc-%svref disk-cache new-instance-slots index imm?) v))))))))
421
422
423
424(def-predicate ccl::standard-instance-p (p disk-cache pointer)
425 (and (dc-uvectorp disk-cache pointer)
426 (eq (dc-%vector-subtype disk-cache pointer) $v_instance)))
427
428(def-accessor slot-value (p slot-name) (disk-cache pointer)
429 (require-satisfies dc-standard-instance-p disk-cache pointer)
430 (multiple-value-bind (value imm?)
431 (dc-%slot-value disk-cache pointer slot-name)
432 (if (and imm? (eq value (%unbound-marker)))
433 (dc-slot-unbound disk-cache pointer slot-name)
434 (values value imm?))))
435
436(defun dc-%slot-value (disk-cache pointer slot-name)
437 (multiple-value-bind (slots index)
438 (dc-%slot-vector-and-index disk-cache pointer slot-name t)
439 (if slots
440 (if (eq slots (%unbound-marker))
441 (values slots t)
442 (dc-%svref disk-cache slots index))
443 (dc-slot-missing disk-cache pointer slot-name 'slot-value))))
444
445(defun dc-slot-missing (disk-cache pointer slot-name operation &optional new-value)
446 (declare (ignore operation new-value))
447 (error "~s has no slot named ~s"
448 (pptr (disk-cache-pheap disk-cache) pointer) slot-name))
449
450(defun dc-slot-unbound (disk-cache pointer slot-name)
451 (error "Slot ~s is unbound in ~s"
452 slot-name (pptr (disk-cache-pheap disk-cache) pointer)))
453
454; Returns two values:
455; 1) disk-cache vector of slots
456; 2) index in the vector
457;
458; If the slot doesn't exist, returns NIL.
459; If the slot exists, but only after the instance is updated and dont-update
460; is true, returns (%unbound-marker).
461(defun dc-%slot-vector-and-index (disk-cache pointer slot-name &optional dont-update)
462 (let* ((pheap (disk-cache-pheap disk-cache))
463 (wrapper (dc-%svref disk-cache pointer $instance.wrapper))
464 (memory-class (pointer-load
465 pheap
466 (dc-%svref disk-cache
467 (dc-%svref disk-cache wrapper $wrapper.class)
468 $class.name)
469 :default disk-cache)))
470 (multiple-value-bind (slots slot-names real-slot-names)
471 (dc-updated-instance-slots
472 disk-cache pointer
473 (find-class
474 memory-class
475 nil)
476 pheap
477 dont-update)
478 (let ((index (position slot-name slot-names :test 'eq))
479 (real-index (and dont-update
480 real-slot-names
481 (position slot-name real-slot-names))))
482 (if (and index (or (not dont-update) (not real-slot-names) real-index))
483 (values slots index)
484 (if real-index
485 (%unbound-marker)
486 nil))))))
487
488(defun (setf p-slot-value) (value p slot-name)
489 (if (pptr-p p)
490 (let* ((pheap (pptr-pheap p))
491 (disk-cache (pheap-disk-cache pheap))
492 (pointer (pptr-pointer p)))
493 (multiple-value-bind (slots index)
494 (dc-%slot-vector-and-index disk-cache pointer slot-name)
495 (unless slots
496 (dc-slot-missing disk-cache pointer slot-name '(setf p-slot-value)))
497 (multiple-value-bind (v imm?) (%p-store pheap value)
498 (setf (dc-%svref disk-cache slots index imm?) v)
499 (if imm?
500 v
501 (pptr pheap v)))))
502 (setf (slot-value p slot-name) value)))
503
504(def-accessor slot-boundp (p slot-name) (disk-cache pointer)
505 (values (not (eq (dc-%slot-value disk-cache pointer slot-name)
506 (%unbound-marker)))
507 t))
508
509(def-accessor slot-makunbound (p slot-name) (disk-cache pointer)
510 (multiple-value-bind (slots index)
511 (dc-%slot-vector-and-index disk-cache pointer slot-name t)
512 (unless slots
513 (dc-slot-missing disk-cache pointer slot-name 'p-slot-makunbound))
514 (unless (eq slots (%unbound-marker))
515 (setf (dc-%svref disk-cache slots index t) (%unbound-marker)))
516 pointer))
517
518(defmethod %p-store-object (pheap (object ccl::funcallable-standard-object) descend)
519 (declare (ignore pheap descend))
520 (error "Can't save generic functions yet. Maybe never."))
521
522; this will do the wrong thing if anyone redefines the class
523; of the object while it is running.
524(defmethod %p-store-object (pheap (object standard-object) descend)
525 (let* ((class (class-of object))
526 (consed? nil))
527 (%p-store-object-body (pheap object descend disk-cache address)
528 (progn
529 (setq consed? t)
530 (dc-%allocate-instance disk-cache (%p-store pheap class)))
531 (progn
532 (unless consed?
533 ; Ensure that p-make-load-function-using-pheap method didn't change too much to handle
534 (require-satisfies dc-vector-subtype-p disk-cache address $v_instance))
535 (multiple-value-bind (slots slot-names)
536 (dc-updated-instance-slots disk-cache address class pheap)
537 (dotimes (i (length slot-names))
538 (let ((slot-name (svref slot-names i)))
539 (multiple-value-bind (value imm?)
540 (if (slot-boundp object slot-name)
541 (%p-store pheap (wood-slot-value object slot-name) descend)
542 (values (%unbound-marker) t))
543 (setf (dc-uvref disk-cache slots i imm?) value)))))))))
544
545; New functions
546; Allows a p-make-load-function-using-pheap method to save slots for an object
547; and do something else as well.
548
549(defmacro sd-slots (sd)
550 `(ccl::%svref ,sd 1))
551
552(defmethod instance-slot-names ((instance structure-object))
553 (let ((sd (gethash (car (ccl::%svref instance 0)) ccl::%defstructs%))
554 (res nil))
555 (dolist (slot (sd-slots sd))
556 (let ((name (car slot)))
557 (when (symbolp name)
558 (push name res))))
559 (nreverse res)))
560
561(defmethod instance-slot-names ((instance standard-object))
562 (mapcar 'slot-definition-name (class-instance-slots (class-of instance))))
563
564(defmethod p-make-load-function-saving-slots ((object standard-object) &optional (slots nil slots-p))
565 (%p-make-load-function-saving-slots object slots slots-p))
566
567(defmethod p-make-load-function-saving-slots ((object structure-object) &optional (slots nil slots-p))
568 (%p-make-load-function-saving-slots object slots slots-p))
569
570(defun %p-make-load-function-saving-slots (object slots slots-p)
571 (let* ((slot-names (if slots-p slots (instance-slot-names object)))
572 (mapper #'(lambda (slot)
573 (if (slot-boundp object slot)
574 (slot-value object slot)
575 (ccl::%unbound-marker-8))))
576 (slot-values (mapcar mapper slot-names)))
577 (declare (dynamic-extent mapper))
578 (values `(allocate-instance-of-class ,(class-name (class-of object)))
579 (when slot-names
580 `(ccl::%set-slot-values ,slot-names ,slot-values)))))
581
582(defun allocate-instance-of-class (class-name)
583 (allocate-instance (find-class class-name)))
584
585(defun progn-load-functions (&rest load-functions)
586 (declare (dynamic-extent load-functions))
587 (when load-functions
588 (do* ((this load-functions next)
589 (next (cdr this) (cdr this)))
590 ((null next) (apply 'funcall (car this)))
591 (apply 'funcall (car this)))))
592
593(defun progn-init-functions (object &rest init-functions)
594 (declare (dynamic-extent init-functions))
595 (dolist (f.args init-functions)
596 (apply (car f.args) object (cdr f.args))))
597
598(defun p-load-instance (pheap disk-cache pointer depth subtype)
599 (declare (ignore subtype))
600 (let* ((cached? t)
601 class
602 (instance (maybe-cached-value pheap pointer
603 (setq cached? nil)
604 (if (null depth)
605 (return-from p-load-instance (pptr pheap pointer)))
606 (setq class (pointer-load pheap
607 (dc-%svref disk-cache
608 (dc-instance-class-wrapper
609 disk-cache pointer)
610 $wrapper.class)
611 :default
612 disk-cache))
613 (allocate-instance class))))
614 (when (or (not cached?)
615 (and (eq depth t)
616 (let ((p-load-hash (p-load-hash pheap)))
617 (unless (gethash instance p-load-hash)
618 (setf (gethash instance p-load-hash) instance)))))
619 (let ((next-level-depth (cond ((or (eq depth :single) (fixnump depth)) nil)
620 (t depth)))
621 (disk-resident-slots (wood-disk-resident-slot-names instance)))
622 (multiple-value-bind (slot-vector slot-names real-slot-names)
623 (dc-updated-instance-slots
624 disk-cache pointer class pheap t)
625 (dotimes (i (length slot-names))
626 (let ((slot-name (svref slot-names i)))
627 (when (or (null real-slot-names) (position slot-name real-slot-names))
628 (multiple-value-bind (pointer immediate?)
629 (dc-%svref disk-cache slot-vector i)
630 (if immediate?
631 (if (eq pointer (%unbound-marker))
632 (slot-makunbound instance slot-name)
633 (setf (wood-slot-value instance slot-name) pointer))
634 (setf (wood-slot-value instance slot-name)
635 (if (member slot-name disk-resident-slots :test #'eq)
636 (pptr pheap pointer)
637 (pointer-load pheap pointer next-level-depth disk-cache))))))))
638 (when real-slot-names
639 (let (new-slot-names)
640 (dotimes (i (length real-slot-names))
641 (let ((slot-name (svref real-slot-names i)))
642 (unless (position slot-name slot-names)
643 (push slot-name new-slot-names))))
644 (when new-slot-names
645 (shared-initialize instance new-slot-names))))))
646 (unless cached?
647 (initialize-persistent-instance instance)))
648 instance))
649
650; These methods allow users to specialize the way that CLOS instances are saved.
651
652; Return a vector of the names of the slots to be saved for an instance.
653; The instance saving code assumes that multiple calls to this
654; method will return the same (EQ) vector unless the class has been redefined.
655; May be called with a CLASS-PROTOTYPE, so don't expect any of the slots
656; to contain useful information.
657(defmethod wood-slot-names-vector ((object standard-object))
658 (class-slots-vector (class-of object)))
659
660; These allow specialization of slot-value.
661; Some slots may want to be saved in a different format,
662; or interned on the way back in.
663(defmethod wood-slot-value ((object standard-object) slot-name)
664 (slot-value object slot-name))
665
666(defmethod (setf wood-slot-value) (value (object standard-object) slot-name)
667 (setf (slot-value object slot-name) value))
668
669
670; This generic function is called on a newly loaded CLOS instance
671(defmethod initialize-persistent-instance (instance)
672 (declare (ignore instance))
673 nil)
674
675
676; This generic function is called when an instance is p-load'ed to
677; determine which slots should remain disk resident and have pptr's
678; put in the instance.
679(defgeneric wood-disk-resident-slot-names (instance)
680 (:method ((instance t))
681 nil))
682
683(declaim (inline default-slot-value-processor))
684
685(defun default-slot-value-processor (instance slot-name value sticky p-loader pass-instance-to-p-loader)
686 (if (pptr-p value)
687 (let ((loaded-value
688 (if pass-instance-to-p-loader
689 (funcall p-loader instance value)
690 (funcall p-loader value))))
691 (when sticky
692 (setf (slot-value instance slot-name) loaded-value))
693 loaded-value)
694 value))
695
696; An easy way to define a wood-disk-resident-slot-names method
697; and some :around methods on slot accessors to swap the slots
698; in on demand.
699(defmacro define-disk-resident-slots ((class-name &key
700 sticky
701 (p-loader ''p-load)
702 pass-instance-to-p-loader
703 (slot-value-processor '#'default-slot-value-processor))
704 &body slots-and-accessors)
705 (let* ((sticky-p #'(lambda (slot-and-accessor)
706 (let ((cell (and (listp slot-and-accessor) (cddr slot-and-accessor))))
707 (if cell (car cell) sticky))))
708 (slots (mapcar #'(lambda (x) (if (listp x) (first x) x)) slots-and-accessors))
709 (accessors (mapcar #'(lambda (x) (if (listp x) (second x) x)) slots-and-accessors))
710 (stickies (mapcar sticky-p slots-and-accessors))
711 (class (find-class class-name nil))
712 (instance (make-symbol (symbol-name class-name))))
713 (declare (dynamic-extent sticky-p))
714 (flet ((require-symbol (x) (require-type x 'symbol)))
715 (mapc #'require-symbol slots)
716 (mapc #'require-symbol accessors))
717 (when class
718 (let* ((class-slots (mapcar 'slot-definition-name (ccl:class-instance-slots class))))
719 (flet ((require-slot (slot)
720 (unless (member slot class-slots :test 'eq)
721 (warn "~s is not an instance slot of ~s" slot class))))
722 (declare (dynamic-extent #'require-slot))
723 (mapc #'require-slot slots))))
724 `(progn
725 ,@(loop for slot in slots
726 for accessor in accessors
727 for sticky in stickies
728 collect
729 `(defmethod ,accessor :around ((,instance ,class-name))
730 (funcall ,slot-value-processor
731 ,instance
732 ',slot
733 (call-next-method)
734 ,(not (null sticky))
735 ,p-loader
736 ,(not (null pass-instance-to-p-loader)))))
737 (defmethod wood-disk-resident-slot-names ((,class-name ,class-name))
738 ',slots)
739 (record-source-file ',class-name :disk-resident-slots)
740 ',class-name)))
741
742
743
744;;; 1 3/10/94 bill 1.8d247
745;;; 2 7/26/94 Derek 1.9d027
746;;; 3 10/04/94 bill 1.9d071
747;;; 4 11/01/94 Derek 1.9d085 Bill's Saving Library Task
748;;; 5 11/03/94 Moon 1.9d086
749;;; 6 11/05/94 kab 1.9d087
750;;; 2 3/23/95 bill 1.11d010
Note: See TracBrowser for help on using the repository browser.