source: trunk/persistent-clos.lisp @ 3

Revision 3, 33.4 KB checked in by gz, 9 years ago (diff)

Recovered version 0.961 from Sheldon Ball <s.ball@…>

  • Property svn:eol-style set to native
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.