source: trunk/persistent-heap.lisp @ 3

Revision 3, 176.5 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-heap.lisp
6;; Code to maintain a Lisp heap in a file.
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;; 11/02/97 akh  bill's dc-aref-vector-and-index
24;; 10/28/97 akh  bill's patches for multi-dim array and always rehash
25;; -------------- 0.96
26;; 05/21/96 bill  new functions p-store-bit-vector & p-load-bit-vector.
27;;                Enter them in the $v_bitv slot of *p-store-subtype-functions*
28;;                and *p-load-subtype-functions*, respectively.
29;; -------------- 0.95
30;; 05/09/96 bill  p-load-bignum, p-store-bignum, (method %p-store-object (t fixnum t))
31;;                immediate-object-p is false for fixnums that are bigger than MCL 2.0 fixnums.
32;;                p-load-bignum still needs to be fixed to cons less.
33;; -------------- 0.94 = MCL-PPC 3.9
34;; 04/04/96 bill  Handle hash tables.
35;;                Revert p-load-header. New code renamed to p-load-arrayh.
36;; 03/29/96 bill  #+ppc-target for the new p-load-header def.
37;;                p-load-struct passes true value for the new struct-p
38;;                arg to p-load-gvector. This makes loading a struct
39;;                that references itself work again.
40;; 03/27/96 bill  :read-only-p keyword for open-pheap (from Dylan).
41;; 03/22/96 bill  Make it work on the PPC.
42;;                This mostly involved mapping the new typecodes to/from the old subtypes
43;;                and dealing with the change in complex array/vector headers.
44;;                New:
45;;                  *wood-subtype->ccl-subtag-table*, *ccl-subtag->wood-subtype-table*,
46;;                  p-store-arrayh
47;;                Changed:
48;;                  wood->ccl-subtype, ccl->wood-subtype,
49;;                  p-load-header, immediate-object-p, %p-store-object
50;; 03/21/96 bill  uvref-extended-string, uvset-extended-string and other support for 2-byte strings.
51;; 09/12/95 bill  setf method for p-stored?
52;; -------------  0.93
53;; 08/10/95 bill  p-assoc
54;; 06/30/95 bill  p-load-header passes a null depth directly to p-load-gvector.
55;;                Thanks to Sidney Markowitz.
56;; 05/31/95 bill  Shared swapping space:
57;;                Add :shared-buffer & :shared-buffer-pool to *open-pheap-keywords*
58;;                open-pheap takes new :shared-buffer & :shared-buffer-pool keywords
59;;                which it passes on to open-disk-cache.
60;; 05/31/95 bill  pheap class definition now specifies the size of the pheap->mem-hash &
61;;                mem->pheap-hash tables as *pheap<->mem-hash-table-size* = 500.
62;; 05/25/95 bill  *default-page-size* moved to disk-cache.lisp.
63;;                remove *default-max-pages*.
64;;                add :swapping-space to *open-pheap-keywords*
65;;                open-pheap takes a new :swapping-space keyword arg, the default is
66;;                *default-swapping-space*. The default value for max-pages is now computed from
67;;                the page-size and the swapping-space, and is forced to be at least 2.
68;;                dc-cons-segment calls %dc-allocate-new-memory with a nil value for its
69;;                initial-element arg. This prevents storage from being initialized twice,
70;;                once when the segment is allocated and again when an object is consed.
71;;                initialize-vector-storage calls extend-disk-cache with a true value for
72;;                its new extend-file? arg if the vector being consed is at least 16K bytes
73;;                long. This is an attempt to get contiguous disk space for large arrays.
74;; 03/22/95 bill  in %p-store-internal - in the first (conser) body subform of the %p-store-object-body
75;;                form, unconditionally set checked-load-function? to true. This prevents unnecessary
76;;                checking in the second (filler) body subform.
77;; -------------  0.91
78;; 03/20/95 bill  %p-store checks for (eq descend :store-slots-again) before calling require-type.
79;;                  This is an optimization, not a bug fix.
80;;                %fill-load-function-object takes a new descend arg.
81;;                %p-store-internal & %p-store-lfun-vector call %fill-load-function-object with the new arg.
82;;                %p-store-internal lets %p-store-object-body do all the work with p-store-hash
83;;                  and with the :store-slots-again descend value.
84;;                %p-store-internal doesn't make its first call to %p-store-object-body if
85;;                  in forced descend mode and there is no load function.
86;;                %p-store-object-body now handles the :store-slots-again descend value.
87;;                  It is also more efficient w.r.t. lookups in the p-store-hash table.
88;; -------------  0.9
89;; 02/10/95 bill  Binding of *loading-pheap* moves from p-load to pointer-load.
90;; 01/17/95 bill  poor man's transactions.
91;;                open-pheap takes an :initial-transaction-p keyword.
92;;                If nil (NOT the default), errors on any disk writes that
93;;                happen outside of a start-transaction/commit-transaction pair.
94;; 12/09/94 bill  Changes from fix-redefine-class-patch for Alpha 1
95;;                %p-store-internal gets new descend value :store-slots-again
96;; 11/16/94 bill  flush-all-open-pheaps ignores errors and ensures that they
97;;                won't happen again.
98;; 11/04/94 ows   open-pheap & create-pheap take a mac-file-creator keyword, which
99;;                they pass on to open-disk-cache.
100;;                Add :mac-file-creator to *open-pheap-keywords*.
101;; 11/02/94 bill  Handling of p-make-load-function-using-pheap moves into
102;;                %p-store-internal and out of (method %p-store-object (t structure-object t)).
103;;                %p-store-object-body-with-load-function commented out.
104;;                Remove %p-store-hash-table and its call.
105;;                Optimize handling of NIL in %p-store-internal
106;; 10/28/94 Moon  Change without-interrupts to with-databases-locked
107;;                Remove interlocking from pheap-write-hook since it is only called
108;;                from inside of get-disk-page, which is already interlocked
109;; 10/25/94 bill  p-loaded?, p-maphash type checks its hash table arg.
110;;                initialize-vector-storage had an error in its first error call.
111;;                %p-store-uvector calls %p-store-hash-table for hash tables.
112;;                %p-store-hash-table saves hash tables without dumping
113;;                a copy of #'equal, #'equalp, or internal hash table functions.
114;;                p-load-load-function handles circularity correctly.
115;;                New macro: %p-store-object-body-with-load-function and
116;;                its helper function do-%p-store-object-body-with-load-function
117;; 10/13/94 bill  New variable: *preserve-lfun-info*. Pass it as second arg to split-lfun.
118;; 10/12/94 bill  typo in error message in initialize-vector-storage.
119;;                Thanx to Chris DiGiano for finding this.
120;; 10/11/94 bill  open-pheap works again if the file does not exist and
121;;                the :if-exists keyword is present.
122;; 09/26/94 bill  GZ's simplification t do-%p-store-object-body
123;; 09/21/94 bill  without-interrupts as necessary for interlocking
124;; 09/19/94 bill  New function: p-stored?
125;;                New macro: careful-maybe-cached-address. Use it in %p-store-object-body
126;;                to handle the case of a make-load-function-using-pheap returning
127;;                the same disk object for two different memory objects.
128;; 07/18/94 bill  (via derek)
129;;                Calls p-make-load-function-using-pheap instead of p-make-load-function.
130;;                p-make-load-function-using-pheap takes the pheap as an arg, so that it
131;;                can dispatch off its type. open-pheap takes a new :pheap-class keyword
132;;                to support this. The reason for this change is to allow different
133;;                persistent heap types to have different strategies for storing objects to disk.
134;; 06/21/94 bill  flush-all-open-pheaps removes a pheap from *open-pheaps* if
135;;                its stream is no longer open.
136;; 03/10/93 bill  create-pheap & open-pheap now take an :external-format keyword
137;;                (submitted by Oliver Steele)
138;; -------------- 0.8
139;; 12/17/93 bill  increment version number. Call check-pheap-version in open-pheap
140;; 11/09/93 bill  p-load-lfun & (method %p-store-object (t function t)) updated
141;;                to work with functions whose immediates reference the function.
142;; 10/20/93 bill  p-load-struct
143;; 07/07/93 bill  %p-store-lfun-vector
144;; 06/26/93 bill  use addr+, not +, when computing $sym_xxx addresses.
145;; 03/29/93 bill  dc-%make-symbol comes out of line from dc-intern
146;; 03/27/93 bill  dc-root-object, (setf dc-root-object)
147;; 03/09/93 bill  DWIM for (setf p-car) & (setf p-cdr) was wrong.
148;; -------------- 0.6
149;; 02/17/93 bill  dc-uv-subtype-size, hence p-length & p-uvsize, now works
150;;                correctly for 0 length bit vectors.
151;; 01/19/93 bill  handle GENSYM'd symbols correctly. Add argument for
152;;                (error "There is no package named ~s")
153;; 12/09/92 bill  initialize-vector-storage works correctly for 0 length
154;; 10/21/92 bill  p-nth, p-nthcdr for Ruben
155;; 10/06/92 bill  in with-consing-area: dynamic-extend -> dynamic-extent.
156;;                Thanx to Guillaume Cartier.
157;;                Also, FLET -> LET to save a symbol in the thunk.
158;; 08/27/92 bill  add p-make-load-function & p-make-load-function-object
159;; 08/11/92 bill  remove misguided unwind-protect from do-%p-store-object-body
160;;                (method p-store-object (t cons t)) now tail-calls for the CDR
161;;                as does p-load-cons.
162;; 08/06/92 bill  pheap-stream, pheap-pathname, print-object method for pheap's.
163;; 07/30/92 bill  p-load-istruct marks hash tables as needing rehashing
164;; -------------- 0.5
165;; 07/27/92 bill  p-clrhash, p-maphash
166;; 06/23/92 bill  (open-pheap name :if-exists :supersede) now works
167;; 06/04/92 bill  save/restore functions
168;; 06/23/92 bill  save/restore CLOS instances -> persistent-clos.lisp
169;; -------------- 0.1
170;;
171
172;;;;;;;;;;;;;;;;;;;;;;;;;;
173;;
174;; To do.
175;;
176;; Hook for writing/reading macptr's
177;;
178;; Make abort in the middle of load or store clear the cache appropriately.
179;;
180;; p-maphash, p-map-btree
181;;
182;; persistent-stream
183;;
184;; Think about floats. The current implementation does not allow
185;; for distinguishing floats and conses when walking memory.
186;; 1) A float is a 16-byte vector. Free up the tag
187;; 2) Cons floats in a special area.
188;; 3) Don't worry about being able to walk memory.
189
190(defpackage :wood)
191(in-package :wood)
192
193(export '(create-pheap open-pheap close-pheap with-open-pheap
194          root-object p-load p-store
195          ))
196
197(eval-when (:compile-toplevel :execute)
198  (require :woodequ)
199  (require :lispequ))
200
201; Dispatch tables at end of file
202(declaim (special *p-load-subtype-functions*
203                  *subtype->bytes-per-element*
204                  *p-store-subtype-functions*
205                  *subtype->uvreffer*
206                  *subtype->uvsetter*
207                  *subtype-initial-element*))
208
209(defparameter *pheap<->mem-hash-table-size* 500)
210
211(defclass pheap ()
212  ((disk-cache :accessor pheap-disk-cache :initarg :disk-cache)
213   (consing-area :accessor pheap-consing-area :initarg :consing-area)
214   (pptr-hash :reader pptr-hash
215              :initform (make-hash-table :weak :value :test 'eql))
216   (wrapper-hash :reader wrapper-hash
217                 :initform (make-hash-table :weak :key :test 'eq))
218   (pheap->mem-hash :reader pheap->mem-hash
219                   :initform (make-hash-table :weak :value
220                                              :test 'eql
221                                              :size *pheap<->mem-hash-table-size*))
222   (mem->pheap-hash :reader mem->pheap-hash
223                   :initform (make-hash-table :weak :key
224                                              :test 'eq
225                                              :size *pheap<->mem-hash-table-size*))
226   (p-load-hash :reader p-load-hash
227                :initform (make-hash-table :weak :key :test 'eq))
228   (inside-p-load :accessor inside-p-load :initform nil)
229   (p-store-hash :reader p-store-hash
230                 :initform (make-hash-table :weak :key :test 'eq))
231   (inside-p-store :accessor inside-p-store :initform nil)))
232
233(defun pheap-stream (pheap)
234  (disk-cache-stream (pheap-disk-cache pheap)))
235
236(defun pheap-pathname (pheap)
237  (pathname (pheap-stream pheap)))
238
239(defmethod print-object ((pheap pheap) stream)
240  (print-unreadable-object (pheap stream)
241    (let ((pheap-stream (pheap-stream pheap)))
242      (format stream "~a ~:_~s to ~:_~s"
243              (stream-direction pheap-stream)
244              (type-of pheap)
245              (pathname pheap-stream)))))
246
247(defmethod read-only-p ((pheap pheap))
248  (disk-cache-read-only-p (pheap-disk-cache pheap)))
249   
250; A PPTR is a pointer into a PHEAP
251(defstruct (pptr (:print-function print-pptr))
252  pheap
253  pointer
254  )
255
256(defun print-pptr (pptr stream level)
257  (declare (ignore level))
258  (write-string "#.(" stream)
259  (prin1 'pptr stream)
260  (tyo #\space stream)
261  (prin1 (pptr-pheap pptr) stream)
262  (write-string " #x" stream)
263  (let ((*print-base* 16))
264    (prin1 (pptr-pointer pptr) stream))
265  (tyo #\) stream))
266
267(defun pptr (pheap pointer)
268  (if (eq pointer $pheap-nil)
269    nil
270    (let ((hash (pptr-hash pheap)))
271      (or (gethash pointer hash)
272          (setf (gethash pointer hash)
273                (make-pptr :pheap pheap :pointer pointer))))))
274
275; Turns a value into a (pointer imm?) pair
276(defun split-pptr (maybe-pptr)
277  (if (pptr-p maybe-pptr)
278    (pptr-pointer maybe-pptr)
279    (values maybe-pptr t)))
280
281(defun dc-pointer-pptr (disk-cache pointer)
282  (pptr (disk-cache-pheap disk-cache) pointer))
283
284(defun pptr-disk-cache (pptr)
285  (pheap-disk-cache (pptr-pheap pptr)))
286
287(defun clear-memory<->disk-tables (pheap)
288  (clrhash (mem->pheap-hash pheap)) 
289  (clrhash (pheap->mem-hash pheap)))
290
291(defparameter $version-number #x504802)          ; current version number "PH2"
292
293(defparameter *default-area-segment-size* 4096)
294
295;;;;;;;;;;;;;;;;;;;;;;;
296;;;
297;;; WITH-EGC macro can disable EGC while dumping or loading.
298;;; This prevents extraneous rehashing of the mem->pheap hash table
299;;;
300
301(defmacro with-egc (state &body body)
302  (let ((egc-state (gensym)))
303    `(let ((,egc-state (ccl:egc-enabled-p)))
304       (unwind-protect
305         (progn
306           (ccl:egc ,state)
307           ,@body)
308         (ccl:egc ,egc-state)))))
309;;;;;;;;;;;;;;;;;;;;;;;;;;
310;;
311;; Functions to create, open, and close pheaps
312;;
313
314(defmacro dc-%svfill (disk-cache vector &body indices-and-values)
315  (let (res)
316    (loop
317      (when (null indices-and-values) (return))
318      (let ((index (pop indices-and-values))
319            (value (pop indices-and-values))
320            immediate?)
321        (when (consp index)
322          (psetq index (car index) immediate? (cadr index)))
323        (push `(setf (dc-%svref ,disk-cache ,vector ,index ,immediate?) ,value)
324              res)))
325    `(progn ,@(nreverse res))))
326
327; Create a pheap. Close its file.
328(defun create-pheap (filename &key
329                              (if-exists :error)
330                              (area-segment-size *default-area-segment-size*)
331                              (page-size *default-page-size*)
332                              (mac-file-creator :ccl2)
333                              (external-format :WOOD))
334  (let ((min-page-size 512))
335    (setq page-size
336          (require-type (* min-page-size (floor (+ page-size min-page-size -1) min-page-size))
337                        'fixnum)))
338  (let* ((disk-cache (open-disk-cache
339                      filename
340                      :if-exists if-exists
341                      :if-does-not-exist :create
342                      :page-size page-size
343                      :mac-file-creator mac-file-creator
344                      :external-format external-format)))
345    (fill-long disk-cache 0 0 (ash (disk-cache-page-size disk-cache) -2))
346    (initialize-vector-storage
347     disk-cache (pointer-address $root-vector)
348     $pheap-header-size $v_dbheader 4 $pheap-nil)
349    (dc-%svfill disk-cache $root-vector
350      ($pheap.version t) $version-number
351      ($pheap.free-page t) 1
352      $pheap.default-consing-area (dc-make-area
353                                   disk-cache :segment-size area-segment-size)
354      ($pheap.page-size t) page-size)
355    (setf (read-string disk-cache
356                       (+ $root-vector (- $t_vector) (ash $pheap-header-size 2)))
357          #.(format nil "~%This is a persistent heap~%~
358                         created by William's Object Oriented Database~%~
359                         in Macintosh Common Lisp.~%"))
360    (close-disk-cache disk-cache)
361    filename))
362
363(defvar *open-pheaps* nil)
364
365(defparameter *open-pheap-keywords*
366  '(:read-only-p
367    :if-does-not-exist
368    :if-exists
369    :area-segment-size
370    :page-size
371    :swapping-space
372    :max-pages
373    :shared-buffer
374    :shared-buffer-pool
375    :mac-file-creator
376    :external-format
377    :pheap-class
378    :initial-transaction-p))
379
380(defun open-pheap (filename &rest rest
381                              &key
382                              (if-does-not-exist :error)
383                              (if-exists :overwrite)
384                              read-only-p
385                              (area-segment-size *default-area-segment-size*)
386                              (page-size *default-page-size*)
387                              (swapping-space *default-swapping-space*)
388                              max-pages
389                              shared-buffer
390                              shared-buffer-pool
391                              (mac-file-creator :ccl2)
392                              (external-format :WOOD)
393                              (pheap-class (load-time-value (find-class 'pheap)))
394                              (initial-transaction-p t)
395                              &allow-other-keys)
396  (declare (dynamic-extent rest))
397  (if (null max-pages)
398    (setq max-pages  (ceiling swapping-space page-size))
399    (setq swapping-space (* max-pages page-size)))
400  (when (symbolp pheap-class)
401    (setq pheap-class (find-class pheap-class)))
402  (unless (typep (class-prototype pheap-class) 'pheap)
403    (error "~s is not a subclass of ~s" pheap-class 'pheap))
404  (let* ((disk-cache (unless (eq if-exists :supersede)
405                       (open-disk-cache filename
406                                        :if-exists if-exists
407                                        :if-does-not-exist nil
408                                        :read-only-p read-only-p
409                                        :page-size page-size
410                                        :max-pages max-pages
411                                        :shared-buffer shared-buffer
412                                        :shared-buffer-pool shared-buffer-pool
413                                        :write-hook 'pheap-write-hook
414                                        :mac-file-creator mac-file-creator
415                                        :external-format external-format
416                                        :initial-transaction-p initial-transaction-p))))
417    (when (null disk-cache)
418      (if (or (eq if-exists :supersede)
419              (eq if-does-not-exist :create))
420        (progn
421          (create-pheap filename
422                        :if-exists if-exists
423                        :area-segment-size area-segment-size
424                        :page-size page-size
425                        :mac-file-creator mac-file-creator
426                        :external-format external-format)
427          (return-from open-pheap
428            (apply #'open-pheap filename :if-exists :overwrite rest)))
429        (error "File ~s does not exist" filename)))
430    (when (not (eql page-size (setq page-size (dc-%svref disk-cache $root-vector $pheap.page-size))))
431      (close-disk-cache disk-cache)
432      (return-from open-pheap
433        (apply #'open-pheap filename
434               :page-size page-size
435               :swapping-space swapping-space
436               :max-pages nil
437               rest)))
438    (let ((done? nil))
439      (unwind-protect
440        (progn
441          (lock-page-at-address disk-cache 0)   ; accessed frequently
442          (multiple-value-bind (count imm?) (dc-page-write-count disk-cache)
443            (when (or imm? (not (eql count $pheap-nil)))
444              (cerror "Hope for the best."
445                      "~s was modified but not closed properly. It may be corrupt."
446                      filename)
447              (setf (dc-page-write-count disk-cache) $pheap-nil
448                    (disk-cache-write-hook disk-cache) nil)
449              (flush-disk-cache disk-cache)
450              (setf (disk-cache-write-hook disk-cache) 'pheap-write-hook)))
451          (let ((pheap (apply 'make-instance pheap-class
452                              :disk-cache disk-cache
453                              (dolist (keyword *open-pheap-keywords* rest)
454                                (loop (unless (remf rest keyword)
455                                        (return)))))))
456            (check-pheap-version pheap)
457            (setf (pheap-consing-area pheap) (dc-default-consing-area disk-cache))
458            (with-databases-locked
459             (push pheap *open-pheaps*))
460            (setq done? t)
461            pheap))
462        (unless done?
463          (close-disk-cache disk-cache))))))
464
465(defun close-pheap (pheap)
466  (flush-pheap pheap)                   ; interruptable
467  (with-databases-locked
468   (flush-pheap pheap)                  ; make sure we're really done
469   (let ((disk-cache (pheap-disk-cache pheap)))
470     (unlock-page (nth-value 3 (get-disk-page disk-cache 0)))
471     (close-disk-cache disk-cache))
472   (setq *open-pheaps* (delq pheap *open-pheaps*)))
473  nil)
474
475(defun move-pheap-file (pheap new-filename)
476  (let* ((old-filename (probe-file (pheap-pathname pheap)))
477         (new-filename (merge-pathnames (translate-logical-pathname new-filename)
478                                        old-filename))
479         (finished? nil)
480         (disk-cache (pheap-disk-cache pheap))
481         (page-size (dc-%svref disk-cache $root-vector $pheap.page-size))
482         (shared-buffer (disk-cache-shared-buffer disk-cache))
483         (mac-file-creator (mac-file-creator old-filename))
484         (external-format (mac-file-type old-filename)))
485    (flet ((open-it (pathname)
486             (setf (pheap-disk-cache pheap)
487                   (open-disk-cache pathname
488                                    :if-does-not-exist :error
489                                    :page-size page-size
490                                    :shared-buffer shared-buffer
491                                    :write-hook 'pheap-write-hook
492                                    :mac-file-creator mac-file-creator
493                                    :external-format external-format))
494             (push pheap *open-pheaps*)))
495      (declare (dynamic-extent #'open-it))
496      (let ((new-path (probe-file new-filename)))
497        (when new-path
498          (if (equalp new-path old-filename)
499            (return-from move-pheap-file
500              (values new-path old-filename))
501            (error "File already exists: ~s" new-filename))))
502      (let* ((old-dir (pathname-directory old-filename))
503             (new-dir (pathname-directory new-filename))
504             (rename? (string-equal (second old-dir)
505                                    (second new-dir))))
506        (unless (and (eq :absolute (car old-dir))
507                     (eq :absolute (car new-dir)))
508          (error "Relative pathname detected"))
509        (unwind-protect
510          (progn
511            (close-pheap pheap)
512            (unless (and rename?
513                         (ignore-errors         ; handle wierd aliases
514                          (rename-file old-filename new-filename)))
515              (setq rename? nil)
516              (copy-file old-filename new-filename))
517            (setq new-filename (probe-file new-filename))       ; resolve aliases
518            (open-it new-filename)
519            (setq finished? t)
520            (values new-filename old-filename))
521      (if finished?
522        (unless rename?
523          (delete-file old-filename))
524        (unless rename?
525          (open-it old-filename))))))))
526
527(defmacro with-open-pheap ((pheap filename &rest options) &body body)
528  `(let ((,pheap (open-pheap ,filename ,@options)))
529     (unwind-protect
530       (progn ,@body)
531       (close-pheap ,pheap))))
532
533(defun disk-cache-pheap (disk-cache)
534  (dolist (pheap *open-pheaps*)
535    (if (eq disk-cache (pheap-disk-cache pheap))
536      (return pheap))))
537
538(defun flush-pheap (pheap &optional (uninterruptable t))
539  (if uninterruptable
540    (with-databases-locked
541      (flush-pheap pheap nil))
542    (let ((disk-cache (pheap-disk-cache pheap))
543          (*error-on-non-transaction-writes* nil))
544      (flush-disk-cache disk-cache)
545      (with-databases-locked
546        (multiple-value-bind (count imm?) (dc-page-write-count disk-cache)
547          (unless (and (not imm?) (eql count $pheap-nil))
548            (setf (dc-page-write-count disk-cache) $pheap-nil
549                  (disk-cache-write-hook disk-cache) nil)
550            (flush-disk-cache disk-cache)
551            (setf (disk-cache-write-hook disk-cache) 'pheap-write-hook)))))))
552
553; This is only called while attempting to quit.
554; Don't let errors get in the way.
555(defun flush-all-open-pheaps ()
556  (let ((bad-ones nil))
557    (unwind-protect
558      (dolist (pheap *open-pheaps*)
559        (if (eq :closed (stream-direction (pheap-stream pheap)))
560          (with-databases-locked
561            (setq *open-pheaps* (delq pheap *open-pheaps*)))
562          (handler-case
563            (flush-pheap pheap)
564            (error () (push pheap bad-ones)))))
565      (dolist (pheap bad-ones)
566        (with-databases-locked
567          (setq *open-pheaps* (delq pheap *open-pheaps*))
568          (setq *open-disk-caches*
569                (delq (pheap-disk-cache pheap) *open-disk-caches*))
570          (setq ccl::*open-file-streams*
571                (delq (pheap-stream pheap) ccl::*open-file-streams*)))))))
572
573(pushnew 'flush-all-open-pheaps *lisp-cleanup-functions*)
574
575(defmacro with-transaction ((pheap) &body body)
576  (let ((thunk (gensym)))
577    `(let ((,thunk #'(lambda () ,@body)))
578       (declare (dynamic-extent ,thunk))
579       (funcall-with-transaction ,pheap ,thunk))))
580
581(defun funcall-with-transaction (pheap thunk)
582  (let ((transaction (start-transaction pheap))
583        (done nil))
584    (unwind-protect
585      (multiple-value-prog1
586        (funcall thunk)
587        (setq done t))
588      (if done
589        (commit-transaction transaction)
590        (abort-transaction transaction)))))
591
592(defun start-transaction (pheap)
593  (start-disk-cache-transaction (pheap-disk-cache pheap))
594  pheap)
595
596(defun commit-transaction (transaction)
597  (let ((pheap transaction))
598    (with-databases-locked
599      (unwind-protect
600        (flush-pheap pheap nil)
601        (commit-disk-cache-transaction (pheap-disk-cache pheap) nil)))))
602
603(defun abort-transaction (transaction)
604  (commit-transaction transaction))
605
606
607; This marks the pheap as modifed so that the next open
608; will complain if it was not closed properly.
609; Eventually, we'll also maintain an active transactions count.
610; No with-databases-locked in pheap-write-hook since it is only called
611; from inside of get-disk-page, which is already interlocked
612(defun pheap-write-hook (disk-page)
613   (let ((disk-cache (disk-page-disk-cache disk-page))
614         flush-page-0?
615         (*error-on-non-transaction-writes* nil))
616     (multiple-value-bind (count imm?) (dc-page-write-count disk-cache)
617       (when (and (not imm?) (eql count $pheap-nil))
618         (setq count 0
619               flush-page-0? t))
620       (setf (dc-page-write-count disk-cache t)
621             (if (eql count most-positive-fixnum)
622               count
623               (1+ count)))
624       (when flush-page-0?
625         (setf (disk-cache-write-hook disk-cache) nil)
626         (flush-disk-page (nth-value 3 (get-disk-page disk-cache 0)))
627         (setf (disk-cache-write-hook disk-cache) 'pheap-write-hook)))))
628
629(defun dc-page-write-count (disk-cache)
630  (dc-%svref disk-cache $root-vector $pheap.page-write-count))
631
632(defun (setf dc-page-write-count) (value disk-cache &optional imm?)
633  (setf (dc-%svref disk-cache $root-vector $pheap.page-write-count imm?)
634        value))
635
636(defun pheap-default-consing-area (pheap)
637  (multiple-value-bind (pointer immediate?)
638                       (dc-default-consing-area (pheap-disk-cache pheap))
639    (if immediate?
640      pointer
641      (pptr pheap pointer))))
642
643(defun dc-default-consing-area (disk-cache)
644  (dc-%svref disk-cache
645             $root-vector
646             $pheap.default-consing-area))
647
648(defmacro require-satisfies (predicate &rest args)
649  `(unless (,predicate ,@args)
650     (error "Not ~s" ',predicate)))
651
652(defun (setf pheap-default-consing-area) (area pheap)
653  (let ((disk-cache (pheap-disk-cache pheap))
654        (pointer (pheap-pptr-pointer area pheap)))
655    (require-satisfies dc-vector-subtype-p disk-cache pointer $v_area)
656    (setf (dc-%svref disk-cache $root-vector $pheap.default-consing-area)
657          pointer))
658  area)
659
660
661;;;;;;;;;;;;;;;;;;;;;;;;;;
662;;
663;; Reading pheap data into the Lisp heap
664;;
665;; Readers take a DEPTH argument:
666;; :default      The default. Load the object into memory stopping at
667;;               objects that have already been loaded.
668;; nil           No conversion except lookup in the hash table.
669;; :single       load a single level. vectors, arrays, & lists will come out
670;;               one level deep. May cons lots of pptr's
671;; <fixnum>      Same as :single but will only load vectors if their length
672;;               is <= depth
673;; T             Recursive descent until closure. May modify some existing Lisp objects.
674;;               Slower than the others as it requires clearing the descent hash table.
675
676
677(defun root-object (pheap)
678  (multiple-value-bind (pointer immediate?)
679                       (dc-root-object (pheap-disk-cache pheap))
680    (if immediate?
681      pointer
682      (pptr pheap pointer))))
683
684(defun dc-root-object (disk-cache)
685  (dc-%svref disk-cache $root-vector $pheap.root))                         
686
687(defvar *loading-pheap* nil)
688
689(defun p-loading-pheap ()
690  *loading-pheap*)
691
692(defun p-load (pptr &optional (depth :default))
693  (if (pptr-p pptr)
694    (pointer-load (pptr-pheap pptr)
695                  (pptr-pointer pptr)
696                  depth)
697    pptr))
698
699; This may execute with-databases-locked for quite a while.
700; Whether it is with-databases-locked should likely be a switch.
701(defun pointer-load (pheap pointer &optional depth disk-cache)
702  (with-databases-locked
703   (unless disk-cache
704     (setq disk-cache (pheap-disk-cache pheap)))
705   (let ((*loading-pheap* pheap))
706     (if (or (neq depth t) (inside-p-load pheap))
707       (pointer-load-internal pheap pointer depth disk-cache)
708       (unwind-protect
709         (progn
710           (setf (inside-p-load pheap) t)
711           (pointer-load-internal pheap pointer depth disk-cache))
712         (clrhash (p-load-hash pheap))
713         (setf (inside-p-load pheap) nil))))))
714
715(defun pointer-load-internal (pheap pointer depth disk-cache)
716  (let ((tag (pointer-tag pointer)))
717    (declare (fixnum tag))
718    (let ((f (locally (declare (optimize (speed 3) (safety 0)))
719               (svref #(p-load-immediate        ; $t_fixnum
720                        p-load-vector   ; $t_vector
721                        p-load-symbol   ; $t_symbol
722                        p-load-dfloat   ; $t_dfloat
723                        p-load-cons     ; $t_cons
724                        p-load-immediate        ; $t_sfloat
725                        p-load-lfun     ; $t_lfun
726                        p-load-immediate)       ; $t_imm
727                      tag))))
728      (unless (or (eq depth t) (eq f 'p-load-immediate))
729        (let ((res (gethash pointer (pheap->mem-hash pheap))))
730          (when res
731            (return-from pointer-load-internal res))))
732      (funcall f pheap disk-cache pointer depth))))
733
734; For error messages
735(defun dc-pointer-load (disk-cache pointer &optional immediate? pheap)
736  (if immediate?
737    pointer
738    (pointer-load (or pheap (disk-cache-pheap disk-cache)) pointer :default disk-cache)))
739
740(defmacro maybe-cached-value (pheap pointer &body forms)
741  (setq pheap (require-type pheap 'symbol)
742        pointer (require-type pointer '(or symbol integer)))
743  (let ((pheap->mem-hash (make-symbol "PHEAP->MEM-HASH"))
744        (value (make-symbol "VALUE")))
745    `(let ((,pheap->mem-hash (pheap->mem-hash ,pheap)))
746       (or (gethash ,pointer ,pheap->mem-hash)
747           (let ((,value (progn ,@forms)))
748             (if (pptr-p ,value)    ; you should throw out in this case.
749               ,value
750               (setf (gethash ,value (mem->pheap-hash ,pheap)) ,pointer
751                     (gethash ,pointer ,pheap->mem-hash) ,value)))))))
752
753(defmacro maybe-cached-address (pheap object &body forms)
754  (setq pheap (require-type pheap 'symbol)
755        object (require-type object 'symbol))
756  (let ((mem->pheap-hash (make-symbol "MEM->PHEAP-HASH"))
757        (address (make-symbol "ADDRESS")))
758    `(let ((,mem->pheap-hash (mem->pheap-hash ,pheap)))
759       (or (gethash ,object ,mem->pheap-hash)
760           (let ((,address (progn ,@forms)))
761             (setf (gethash ,address (pheap->mem-hash ,pheap)) ,object
762                   (gethash ,object ,mem->pheap-hash) ,address))))))
763
764(defmacro careful-maybe-cached-address (pheap object &body forms)
765  (setq pheap (require-type pheap 'symbol)
766        object (require-type object 'symbol))
767  (let ((mem->pheap-hash (make-symbol "MEM->PHEAP-HASH"))
768        (pheap->mem-hash (make-symbol "PHEAP->MEM-HASH"))
769        (address (make-symbol "ADDRESS")))
770    `(let ((,mem->pheap-hash (mem->pheap-hash ,pheap)))
771       (or (gethash ,object ,mem->pheap-hash)
772           (let ((,address (progn ,@forms))
773                 (,pheap->mem-hash (pheap->mem-hash ,pheap)))
774             (unless (gethash ,address ,pheap->mem-hash)        ; two different memory objects may go to the same disk object
775               (setf (gethash ,address ,pheap->mem-hash) ,object))
776             (setf (gethash ,object ,mem->pheap-hash) ,address))))))
777
778(defun p-load-immediate (pheap disk-cache pointer depth)
779  (declare (ignore disk-cache depth))
780  (error "Immediate pointer ~s" (pptr pheap pointer)))
781
782(defun p-load-vector (pheap disk-cache pointer depth)
783  (let ((subtype (dc-%vector-subtype disk-cache pointer)))
784    (declare (fixnum subtype))
785    (let ((f (svref *p-load-subtype-functions* subtype)))
786      (if f
787        (funcall f pheap disk-cache pointer depth subtype)
788        (pptr pheap pointer)))))
789
790(defun p-load-error (pheap disk-cache pointer depth subtype)
791  (declare (ignore disk-cache depth))
792  (error "~x is of unsupported subtype: ~s" (pptr pheap pointer) subtype))
793
794(defun p-load-nop (pheap disk-cache pointer depth subtype)
795  (declare (ignore disk-cache depth subtype))
796  (pptr pheap pointer))
797
798(defmacro old-wood->ccl-subtype (wood-subtype)
799  `(* 2 ,wood-subtype))
800
801(defmacro old-ccl->wood-subtype (ccl-subtype)
802  `(ash ,ccl-subtype -1))
803
804#-ppc-target
805(progn
806
807(defmacro wood->ccl-subtype (wood-subtype)
808  `(old-wood->ccl-subtype ,wood-subtype))
809
810(defmacro ccl->wood-subtype (ccl-subtype)
811  `(old-ccl->wood-subtype ,ccl-subtype))
812
813)  ; end of #-ppc-target progn
814
815#+ppc-target
816(progn
817
818(defvar *wood-subtype->ccl-subtag-table*)
819(defvar *ccl-subtag->wood-subtype-table*)
820
821(defmacro wood->ccl-subtype (wood-subtype)
822  (let ((subtype-var (gensym)))
823    `(let ((,subtype-var ,wood-subtype))
824       (or (svref *wood-subtype->ccl-subtag-table* ,subtype-var)
825           (error "There is no CCL typecode for wood subtype ~s"
826                  ,subtype-var)))))
827
828(defmacro ccl->wood-subtype (ccl-typecode)
829  (let ((typecode-var (gensym)))
830    `(let ((,typecode-var ,ccl-typecode))
831       (or (svref *ccl-subtag->wood-subtype-table* ,typecode-var)
832         (error "There is no wood subtype for ccl typecode ~s"
833                ,typecode-var)))))
834
835)  ; end of #+ppc-target progn
836 
837
838(defstruct uninitialize-structure)
839
840(defvar *uninitialized-structure*
841  (make-uninitialize-structure))
842
843; general vector
844(defun p-load-gvector (pheap disk-cache pointer depth subtype &optional
845                             special-index-p special-index-value struct-p)
846  (let* (length
847         modified?
848         (cached? t)
849         (vector (maybe-cached-value pheap pointer
850                   (setq cached? nil
851                         length  (dc-%simple-vector-length disk-cache pointer))
852                   (if (or (null depth)
853                           (and (fixnump depth) (< depth length)))
854                     (return-from p-load-gvector (pptr pheap pointer))
855                     (let ((res (ccl::make-uvector
856                                 length (wood->ccl-subtype subtype))))
857                       (when struct-p
858                         ; Make sure it looks like a structure
859                         (setf (uvref res 0) (uvref *uninitialized-structure* 0)))
860                       res)))))
861    (when (or (not cached?)
862              (listp depth)
863              (and (eq depth t)
864                   (let ((p-load-hash (p-load-hash pheap)))
865                     (unless (gethash vector p-load-hash)
866                       (setf (gethash vector p-load-hash) vector)))))
867      (let ((next-level-depth (cond ((or (eq depth :single) (fixnump depth)) nil)
868                                     ((listp depth) (car depth))
869                                     (t depth))))
870        (setq modified? t)
871        (dotimes (i (or length (uvsize vector)))
872          (setf (uvref vector i)
873                (if (and special-index-p (funcall special-index-p i))
874                  (funcall special-index-value disk-cache pointer i)
875                  (multiple-value-bind (pointer immediate?)
876                                       (dc-%svref disk-cache pointer i)
877                    (if immediate?
878                      pointer
879                      (if (and struct-p (eql i 0))
880                        (pointer-load pheap pointer :default disk-cache)
881                        (pointer-load pheap pointer next-level-depth disk-cache)))))))))
882    (values vector modified?)))
883
884(defun p-load-header (pheap disk-cache pointer depth subtype &optional
885                            special-index-p special-index-value)
886;  (declare (type (integer 0 256) subtype))
887  (if (or (null depth) (eq depth t))
888    (p-load-gvector pheap disk-cache pointer depth subtype
889                    special-index-p special-index-value)
890    (let ((depth-list (list depth)))
891      (declare (dynamic-extent depth-list))
892      (p-load-gvector pheap disk-cache pointer depth-list subtype
893                      special-index-p special-index-value))))
894
895#-ppc-target
896(defun p-load-arrayh (pheap disk-cache pointer depth subtype)
897  (p-load-header pheap disk-cache pointer depth subtype))
898
899#+ppc-target
900(defun p-load-arrayh (pheap disk-cache pointer depth subtype)
901  (declare (ignore subtype))
902  (let* ((cached? t)
903         (subtag (wood->ccl-subtype (old-ccl->wood-subtype (dc-%arrayh-type disk-cache pointer))))
904         (rank (dc-array-rank disk-cache pointer))
905         (vector (maybe-cached-value pheap pointer
906                   (setq cached? nil)
907                   (let* ((subtype (if (eql rank 1)
908                                     ppc::subtag-vectorh
909                                     ppc::subtag-arrayh))
910                          (length (+ ppc::vectorh.element-count
911                                     (if (eql rank 1) 0 rank))))
912                     (ccl::make-uvector length subtype)))))
913    (when (or (not cached?)
914              (and (eq depth t)
915                   (let ((p-load-hash (p-load-hash pheap)))
916                     (unless (gethash vector p-load-hash)
917                       (setf (gethash vector p-load-hash) vector)))))
918      (if (eql rank 1)
919        (setf (uvref vector ppc::vectorH.logsize-cell)
920              (dc-%svref-fixnum disk-cache pointer $arh.fill '$arh.fill)
921              (uvref vector ppc::vectorH.physsize-cell)
922              (dc-%svref-fixnum disk-cache pointer $arh.vlen '$arh.vlen))
923        (let ((total-size 1))
924          (setf (uvref vector ppc::arrayH.rank-cell) rank)
925          (dotimes (i rank)
926            (let ((dim (dc-%svref-fixnum disk-cache pointer (+ $arh.fill i))))
927              (declare (fixnum dim))
928              (setq total-size (* total-size dim))
929              (setf (uvref vector (+ ppc::arrayH.dim0-cell i)) dim)))
930          (unless (fixnump total-size)
931            (error "Array total size not a fixnum"))
932          (setf (uvref vector ppc::vectorH.physsize-cell) total-size)))
933      (setf (uvref vector ppc::vectorH.displacement-cell)
934            (dc-%svref-fixnum disk-cache pointer $arh.offs '$arh.offs)
935            (uvref vector ppc::vectorH.flags-cell)
936            (dpb (dc-%arrayh-bits disk-cache pointer)
937                 ppc::arrayH.flags-cell-bits-byte
938                 (dpb subtag ppc::arrayH.flags-cell-subtag-byte 0))
939            (uvref vector ppc::vectorH.data-vector-cell)
940            (pointer-load pheap (dc-%svref disk-cache pointer $arh.vect) depth disk-cache)))
941    vector))
942
943
944(defun p-load-istruct (pheap disk-cache pointer depth subtype)
945  (when (or (eq depth :single) (fixnump depth))
946    (setq depth :default))
947  (multiple-value-bind (vector modified?)
948                       (p-load-gvector pheap disk-cache pointer depth subtype)
949    (when (and (hash-table-p vector) modified?)
950      (ccl::needs-rehashing vector))
951    vector))
952
953(defun p-load-struct (pheap disk-cache pointer depth subtype)
954  (let ((vector (p-load-gvector pheap disk-cache pointer depth subtype nil nil t)))
955    (when (ccl::uvector-subtype-p vector ccl::$v_struct)
956      (let ((struct-type (uvref vector 0)))
957        (when (typep struct-type 'pptr)
958          (setf (uvref vector 0) (p-load struct-type)))))
959    vector))
960
961; ivectors
962(defun p-load-ivector (pheap disk-cache pointer depth subtype)
963  (declare (fixnum subtype))
964  (let* ((cached? t)
965         (res (maybe-cached-value pheap pointer
966                (setq cached? nil)
967                (let ((length (dc-uvsize disk-cache pointer))
968                      (size (dc-%vector-size disk-cache pointer)))
969                  (if (and depth
970                           (or (not (fixnump depth)) (<= length depth)))
971                    (load-byte-array
972                     disk-cache (addr+ disk-cache pointer $v_data) size
973                     (ccl::make-uvector length (wood->ccl-subtype subtype))
974                     0 t)
975                    (return-from p-load-ivector (pptr pheap pointer)))))))
976    (when (and cached? (eq depth t))
977      (let* ((size (dc-%vector-size disk-cache pointer))
978             (subtype (dc-%vector-subtype disk-cache pointer)))
979        (unless (eql (uvsize res) (dc-uvsize disk-cache pointer))
980          (error "Inconsistency. Disk ivector is different size than in-memory version."))
981        (unless (eql (wood->ccl-subtype subtype)
982                     (ccl::%vect-subtype res))
983          (error "Inconsistency. Subtype mismatch."))
984        (load-byte-array disk-cache (addr+ disk-cache pointer $v_data) size res 0 t)))
985    res))
986
987#-ppc-target
988(defun p-load-bignum (pheap disk-cache pointer depth subtype)
989  (p-load-ivector pheap disk-cache pointer depth subtype))
990
991;; bignums are stored in Wood files in MCL 2.0 format.
992;; Their elements are 16-bit integers, and they are stored as sign/magnitude.
993;; The first word's MSB is the sign bit. The rest of that word and the
994;; other words are the magnitude.
995;; Some day, recode this using bignum internals so that it doesn't cons so much.
996#+ppc-target
997(defun p-load-bignum (pheap disk-cache pointer depth subtype)
998  (declare (ignore pheap depth subtype))
999  (let ((p (+ pointer $v_data)))
1000    (accessing-disk-cache (disk-cache p)
1001      (let* ((first-word (load.uw 0))
1002             (negative? (logbitp 15 first-word))
1003             (value (logand #x7fff first-word))
1004             (index 0))
1005        (declare (fixnum first-word index))
1006        (dotimes (i (1- (the fixnum (dc-uvsize disk-cache pointer))))
1007          (setq value (+ (ash value 16) (load.uw (incf index 2)))))
1008        (if negative?
1009          (- value)
1010          value)))))
1011
1012#+ppc-target
1013(defun p-load-bit-vector (pheap disk-cache pointer depth subtype)
1014  (declare (fixnum subtype))
1015  (let* ((cached? t)
1016         (res (maybe-cached-value pheap pointer
1017                (setq cached? nil)
1018                (let ((length (dc-uvsize disk-cache pointer))
1019                      (size (dc-%vector-size disk-cache pointer)))
1020                  (declare (fixnum size))
1021                  (load-byte-array
1022                   disk-cache (addr+ disk-cache pointer (1+ $v_data)) (1- size)
1023                   (ccl::make-uvector length (wood->ccl-subtype subtype))
1024                   0 t)))))
1025    (when (and cached? (eq depth t))
1026      (let* ((size (dc-%vector-size disk-cache pointer))
1027             (subtype (dc-%vector-subtype disk-cache pointer)))
1028        (declare (fixnum size))
1029        (unless (eql (uvsize res) (dc-uvsize disk-cache pointer))
1030          (error "Inconsistency. Disk ivector is different size than in-memory version."))
1031        (unless (eql (wood->ccl-subtype subtype)
1032                     (ccl::%vect-subtype res))
1033          (error "Inconsistency. Subtype mismatch."))
1034        (load-byte-array disk-cache (addr+ disk-cache pointer (1+ $v_data)) (1- size) res 0 t)))
1035    res))
1036
1037(defun p-load-lfun-vector (pheap disk-cache pointer depth subtype)
1038  (declare (ignore pheap disk-cache pointer depth subtype))
1039  (error "Inconsistency: WOOD does not tag vectors as ~s" '$t_lfunv))
1040
1041(defun p-load-pkg (pheap disk-cache pointer depth subtype)
1042  (declare (ignore depth subtype))
1043  (maybe-cached-value pheap pointer
1044    (let* ((names (pointer-load-internal pheap (dc-%svref disk-cache pointer $pkg.names)
1045                                         t disk-cache))
1046           (name (car names)))
1047      (or (find-package name)
1048          (make-package name :nicknames (cdr names) :use nil)))))
1049
1050;; End of loaders for $t_vector subtypes
1051
1052(defun p-load-symbol (pheap disk-cache pointer depth)
1053  (declare (ignore depth))
1054  (maybe-cached-value pheap pointer
1055    (let ((pname (pointer-load-internal
1056                  pheap
1057                  (read-long disk-cache (addr+ disk-cache pointer $sym_pname))
1058                  :default disk-cache))
1059          (pkg (pointer-load-internal
1060                pheap
1061                (read-long disk-cache (addr+ disk-cache pointer $sym_package))
1062                :default disk-cache)))
1063      (if pkg
1064        (intern pname pkg)
1065        (make-symbol pname)))))
1066
1067(defun p-load-dfloat (pheap disk-cache pointer depth)
1068  (maybe-cached-value pheap pointer
1069    (if (eq depth nil)
1070      (return-from p-load-dfloat (pptr pheap pointer)))
1071    (values (read-double-float disk-cache (- pointer $t_dfloat)) t)))
1072
1073(defun p-load-cons (pheap disk-cache pointer depth)
1074    (p-load-cons-internal pheap disk-cache pointer depth nil nil))
1075
1076(defvar *avoid-cons-caching* nil)
1077
1078(defun p-load-cons-internal (pheap disk-cache pointer depth set-my-cdr res)
1079  (if (eql pointer $pheap-nil)
1080    (progn
1081      (when set-my-cdr
1082        (setf (cdr set-my-cdr) nil))
1083      res)
1084    (let* ((cached? t)
1085           (cons (block avoid-cache
1086                   (maybe-cached-value pheap pointer
1087                     (setq cached? nil)
1088                     (if (or (null depth) (and (fixnump depth) (<= depth 0)))
1089                       (return-from avoid-cache (pptr pheap pointer))
1090                       (let ((res (cons nil nil)))
1091                         (if *avoid-cons-caching*
1092                           (return-from avoid-cache res)
1093                           res)))))))
1094      (when set-my-cdr
1095        (setf (cdr set-my-cdr) cons))
1096      (if (and (listp cons)
1097               (or (not cached?)
1098                   (and (eq depth t)
1099                        (let ((p-load-hash (p-load-hash pheap)))
1100                          (unless (gethash cons p-load-hash)
1101                            (setf (gethash cons p-load-hash) cons))))))
1102        (let ((next-level-depth (unless (or (eq depth :single) (fixnump depth))
1103                                  depth))
1104              (rest-depth (if (fixnump depth) (1- depth) depth)))
1105          (multiple-value-bind (car car-imm?) (read-pointer disk-cache (- pointer $t_cons))
1106            (multiple-value-bind (cdr cdr-imm?) (read-pointer disk-cache pointer)
1107              (setf (car cons)
1108                    (if car-imm?
1109                      car
1110                      (pointer-load pheap car next-level-depth disk-cache)))
1111              (if (and (not cdr-imm?) (dc-consp disk-cache cdr))
1112                ; THIS MUST BE A TAIL CALL!!
1113                (p-load-cons-internal pheap disk-cache cdr rest-depth cons (or res cons))
1114                (progn
1115                  (setf (cdr cons)
1116                        (if cdr-imm?
1117                          cdr
1118                          (pointer-load pheap cdr rest-depth disk-cache)))
1119                  (or res cons))))))
1120        (or res cons)))))
1121
1122; All this hair is to create the lfun before loading its immediates.
1123; This allows circular references.
1124(defun p-load-lfun (pheap disk-cache pointer depth)
1125  (let (imms imms-address indices
1126        (imms-length 0))
1127    (declare (fixnum imms-length))
1128    (let ((lfun (maybe-cached-value pheap pointer
1129                  (if (null depth)
1130                    (return-from p-load-lfun (pptr pheap pointer))
1131                    (let* ((vector-pointer (+ pointer (- $t_vector $t_lfun)))
1132                           (length (1- (dc-uvsize disk-cache vector-pointer)))
1133                           (vector (make-array length)))
1134                      (declare (fixnum length) (dynamic-extent vector))
1135                      (setq imms (make-array imms-length :initial-element '*$temp$*))
1136                      (dotimes (i length)
1137                        (declare (fixnum i))
1138                        (multiple-value-bind (val imm?) (dc-%svref disk-cache vector-pointer (1+ i))
1139                          (setf (ccl::%svref vector i)
1140                                (if imm? val (pointer-load-internal pheap val :default disk-cache)))))
1141                      (let (f)
1142                        (multiple-value-setq (f imms indices)
1143                          (ccl::applyv 'ccl::join-lfun-with-dummy-immediates vector))
1144                        (setq imms-address (dc-%svref disk-cache vector-pointer 0)
1145                              imms-length (dc-uvsize disk-cache imms-address))
1146                        (unless (eql (length imms) imms-length)
1147                          (error "Immediates count mismatch. Was: ~d, SB: ~d" imms imms-length))
1148                        f))))))
1149      (when imms
1150        (dotimes (i imms-length)
1151          (multiple-value-bind (val imm?) (dc-%svref disk-cache imms-address i)
1152            (setf (ccl::%svref imms i)
1153                  (if imm? val (pointer-load-internal pheap val :default disk-cache)))))
1154        (ccl::%patch-lfun-immediates lfun imms indices))
1155      lfun)))
1156
1157; Load the result of p-make-load-function-object
1158(defun p-load-load-function (pheap disk-cache pointer depth subtype)
1159  (declare (ignore subtype))
1160  (let* ((object (maybe-cached-value pheap pointer
1161                   (if (null depth)
1162                     (return-from p-load-load-function (pptr pheap pointer))
1163                     (let ((load-function.args (pointer-load
1164                                                pheap
1165                                                (dc-%svref disk-cache pointer $load-function.load-list)
1166                                                :default
1167                                                disk-cache)))
1168                       (apply (car load-function.args)
1169                              (cdr load-function.args))))))
1170         (init-function.args (pointer-load
1171                              pheap
1172                              (dc-%svref disk-cache pointer $load-function.init-list)
1173                              :default
1174                              disk-cache)))
1175      (when init-function.args
1176            (apply (car init-function.args)
1177                   object
1178                   (cdr init-function.args)))
1179      object))
1180
1181;;;;;;;;;;;;;;;;;;;;;;;;;;
1182;;;
1183;;; Writing Lisp data into the pheap
1184;;;
1185
1186;;; The descend argument can take three values:
1187;;;
1188;;; :default     The default. Don't descend if you find an address in the cache
1189;;; nil          Same as :default, but newly consed values are not cached.
1190;;;              Allows storing stack-consed objects in the persistent heap.
1191;;; t            Recursively descend and overwrite any cached values.
1192
1193(defun (setf root-object) (new-root pheap)
1194  (multiple-value-bind (pointer immediate?) (%p-store pheap new-root)
1195    (setf (dc-root-object (pheap-disk-cache pheap) immediate?) pointer)
1196    (if immediate?
1197      pointer
1198      (pptr pheap pointer))))
1199
1200(defun (setf dc-root-object) (new-root disk-cache imm?)
1201  (setf (dc-%svref disk-cache $root-vector $pheap.root imm?) new-root))
1202
1203(defun p-store (pheap object &optional (descend :default))
1204  (multiple-value-bind (pointer immediate?) (%p-store pheap object descend)
1205    (if (or immediate? (null pointer))
1206      pointer
1207      (pptr pheap pointer))))
1208
1209(defun p-loaded? (pptr)
1210  (if (pptr-p pptr)
1211    (gethash (pptr-pointer pptr) (pheap->mem-hash (pptr-pheap pptr)))
1212    pptr))
1213
1214; Again, maybe we shouldn't allow other than NIL for the object
1215;;; ----@@@@ This should be (setf p-loaded?) but that didn't work as a patch.
1216(defun set-p-loaded? (pptr object)
1217  (setq pptr (require-type pptr 'pptr))
1218  (if (pptr-p object)
1219    (require-satisfies eq object pptr)
1220    (let ((pheap (pptr-pheap pptr))
1221          (pointer (pptr-pointer pptr)))
1222      (with-databases-locked
1223        (let ((mem->pheap-hash (mem->pheap-hash pheap))
1224              (pheap->mem-hash (pheap->mem-hash pheap)))
1225          (if object
1226            (setf (gethash object mem->pheap-hash) pointer
1227                  (gethash pointer pheap->mem-hash) object)
1228            (let ((object (gethash pointer pheap->mem-hash)))
1229              (when object
1230                (remhash object mem->pheap-hash)
1231                (remhash pointer pheap->mem-hash))))))))
1232  object)
1233
1234(defun p-stored? (pheap object)
1235  (cond ((null object) nil)
1236        ((pptr-p object)
1237         (and (eq pheap (pptr-pheap object))
1238              object))
1239        (t (multiple-value-bind (pointer imm?) (%p-store-hash-key pheap object)
1240             (cond (imm? pointer)
1241                   (pointer (pptr pheap pointer))
1242                   (t nil))))))
1243
1244(defsetf p-stored? set-p-stored?)
1245
1246; Maybe we should only allow NIL for PPTR.
1247; Allowing random other PPTRs gives people rope to hang themselves.
1248;;; ----@@@@ This should be (setf p-stored?) but that didn't work as a patch.
1249(defun set-p-stored? (pheap object pptr-or-nil)
1250  (if (pptr-p object)
1251    (require-satisfies eq pptr-or-nil object)
1252    (when object
1253      (with-databases-locked
1254        (let ((mem->pheap-hash (mem->pheap-hash pheap))
1255              (pheap->mem-hash (pheap->mem-hash pheap)))
1256          (if pptr-or-nil
1257            (let ((pointer (pptr-pointer pptr-or-nil)))
1258              (require-pptr-pheap pptr-or-nil pheap)
1259              (setf (gethash object mem->pheap-hash) pointer
1260                    (gethash pointer pheap->mem-hash) object))
1261            (let ((pointer (gethash object mem->pheap-hash)))
1262              (when pointer
1263                (remhash object mem->pheap-hash)
1264                (remhash pointer pheap->mem-hash) nil)))))))
1265  pptr-or-nil)
1266
1267
1268(defun require-pptr-pheap (pptr pheap)
1269  (unless (eq (pptr-pheap pptr) pheap)
1270    (error "wrong pheap!")))
1271
1272(defun pheap-pptr-pointer (pptr pheap)
1273  (require-pptr-pheap pptr pheap)
1274  (pptr-pointer pptr))
1275
1276#+ppc-target
1277(progn
1278
1279(declaim (inline %ccl2-fixnum-p))
1280
1281(defun %ccl2-fixnum-p (ppc-fixnum)
1282  (declare (fixnum ppc-fixnum))
1283  (and (>= ppc-fixnum (- (ash 1 28))) (< ppc-fixnum (ash 1 28))))
1284
1285)
1286
1287(declaim (inline immediate-object-p))
1288
1289(defun immediate-object-p (object)
1290  #-ppc-target
1291  (ccl::dtagp object (+ (ash 1 ccl::$t_fixnum)
1292                        (ash 1 ccl::$t_sfloat)
1293                        (ash 1 ccl::$t_imm)))
1294  #+ppc-target
1295  (let ((typecode (ccl::ppc-typecode object)))
1296    (if (eql typecode ppc::tag-fixnum)
1297      (%ccl2-fixnum-p object)
1298      (eql typecode ppc::tag-imm))))
1299
1300; Same comment here as for pointer-load:
1301; this may execute with-databases-locked for a long time.
1302(defun %p-store (pheap object &optional (descend :default))
1303  (unless (or (eq descend :default)
1304              (null descend)
1305              (eq descend t)
1306              (eq descend :store-slots-again))
1307    (setq descend (require-type descend '(member :default nil t :store-slots-again))))
1308  (cond ((immediate-object-p object)
1309         (values object t))
1310        ((typep object 'pptr)
1311         (if (eq pheap (pptr-pheap object))
1312           (pptr-pointer object)
1313           (let ((pptr (or (p-store-pptr pheap object) object)))
1314             (require-pptr-pheap pptr pheap)
1315             (pptr-pointer pptr))))
1316        (t (with-databases-locked
1317            (if (or (eq descend :default) (inside-p-store pheap))
1318             (%p-store-internal pheap object descend)
1319             (unwind-protect
1320               (progn
1321                 (setf (inside-p-store pheap) t)
1322                 (%p-store-internal pheap object descend))
1323               (clrhash (p-store-hash pheap))
1324               (setf (inside-p-store pheap) nil)))))))
1325
1326(defgeneric p-store-pptr (pheap pptr)
1327  (:method ((pheap pheap) (pptr t))
1328    nil))
1329
1330; This happenned three times so I made it into a macro.
1331(defmacro %p-store-object-body ((pheap object descend disk-cache address)
1332                                    &body body
1333                                    &environment env)
1334  (multiple-value-bind (body decls) (ccl::parse-body body env)
1335    (unless (null (cddr body))
1336      (error "body must be of the form (conser filler)"))
1337    (let ((conser (car body))
1338          (filler (cadr body))
1339          (conser-var (gensym))
1340          (filler-var (gensym)))
1341      `(let ((,conser-var #'(lambda (,disk-cache ,object)
1342                              (declare (ignore-if-unused ,object))
1343                              ,@decls
1344                              ,conser))
1345             (,filler-var #'(lambda (,pheap ,disk-cache ,object ,address ,descend)
1346                              (declare (ignore-if-unused ,pheap ,descend))
1347                              ,@decls
1348                              ,filler)))
1349         (declare (dynamic-extent ,conser-var ,filler-var))
1350         (do-%p-store-object-body ,pheap ,object ,descend ,conser-var ,filler-var)))))
1351
1352(defun do-%p-store-object-body (pheap object descend conser filler)
1353  (let* ((disk-cache (pheap-disk-cache pheap))
1354         (cached? t)
1355         (address nil)
1356         (p-store-hash (and (neq descend :default) (p-store-hash pheap)))
1357         (p-store-hash? (and p-store-hash (gethash object p-store-hash)))
1358         (orig-descend descend))
1359    (when p-store-hash?
1360      (return-from do-%p-store-object-body p-store-hash?))
1361    (when (eq descend :store-slots-again)
1362      (setq orig-descend t
1363            descend :default))
1364    (block avoid-cache
1365      (setq address (careful-maybe-cached-address pheap object
1366                      #+remove (when (eq descend nil)
1367                                   (when (setq address (gethash object (p-store-hash pheap)))
1368                                     (return-from do-%p-store-object-body address)))
1369                      (setq cached? nil)
1370                      (prog1
1371                        (setq address (funcall conser disk-cache object))
1372                        (when (or (eq descend nil)
1373                                  (and (consp object) *avoid-cons-caching*))
1374                          (return-from avoid-cache))))))
1375    (when p-store-hash
1376      (setf (gethash object p-store-hash) address)
1377      (when (eq orig-descend t)
1378        (setq cached? nil)))
1379    (unless cached?
1380      (funcall filler pheap disk-cache object address descend))
1381    address))
1382
1383#| ; Not used. Keep around in case we need to reincarnate it later
1384(defmacro %p-store-object-body-with-load-function ((pheap object descend disk-cache address)
1385                                                          &body body
1386                                                          &environment env)
1387  (multiple-value-bind (body decls) (ccl::parse-body body env)
1388    (destructuring-bind (conser filler) body
1389      (let ((conser-var (gensym))
1390            (filler-var (gensym)))
1391        `(let ((,conser-var #'(lambda (,disk-cache) ,@decls ,conser))
1392               (,filler-var #'(lambda (,disk-cache ,address) ,@decls ,filler)))
1393           (declare (dynamic-extent ,conser-var ,filler-var))
1394           (do-%p-store-object-body-with-load-function ,pheap ,object ,descend ,conser-var ,filler-var))))))
1395
1396; New function
1397(defun do-%p-store-object-body-with-load-function (pheap object descend conser filler)
1398  (let* (checked-load-function? load-function.args init-function.args)
1399    (%p-store-object-body (pheap object descend disk-cache address)
1400      (progn
1401        (multiple-value-setq (load-function.args init-function.args)
1402          (p-make-load-function-using-pheap pheap object))
1403        (setq checked-load-function? t)
1404        (if load-function.args
1405            (if (pptr-p load-function.args)
1406              (pheap-pptr-pointer load-function.args pheap)
1407              (dc-make-uvector disk-cache $load-function-size $v_load-function))
1408            (funcall conser disk-cache)))
1409      (progn
1410        (unless checked-load-function?
1411          (multiple-value-setq (load-function.args init-function.args)
1412            (p-make-load-function-using-pheap pheap object)))
1413        (if load-function.args
1414          (if (pptr-p load-function.args)
1415            (unless checked-load-function?
1416              (require-satisfies eql (pheap-pptr-pointer load-function.args pheap) address))
1417            (progn
1418              (unless checked-load-function?
1419                (require-satisfies dc-vector-subtype-p disk-cache address $v_load-function))
1420              (%fill-load-function-object
1421               pheap disk-cache address load-function.args init-function.args)))
1422          (funcall filler disk-cache address))))))
1423|#
1424
1425(defun %p-store-internal (pheap object descend)
1426  (cond ((immediate-object-p object)
1427         (values object t))
1428        ((null object) $pheap-nil)
1429        (t (or (block no-load-function
1430                 (let* (checked-load-function? got-load-function? load-function.args init-function.args)
1431                   (when (or (eq descend t) (eq descend :store-slots-again))
1432                     (multiple-value-setq (load-function.args init-function.args)
1433                       (p-make-load-function-using-pheap pheap object))
1434                     (setq got-load-function? t)
1435                     (unless load-function.args
1436                       (return-from no-load-function nil)))
1437                   (%p-store-object-body (pheap object descend disk-cache address)
1438                     (progn
1439                       (unless got-load-function?
1440                         (multiple-value-setq (load-function.args init-function.args)
1441                           (p-make-load-function-using-pheap pheap object))
1442                         (setq got-load-function? t))
1443                       (setq checked-load-function? t)
1444                       (if load-function.args
1445                         (if (pptr-p load-function.args)
1446                           (pheap-pptr-pointer load-function.args pheap)
1447                           (dc-make-uvector disk-cache $load-function-size $v_load-function))
1448                         (return-from no-load-function nil)))
1449                     (progn
1450                       (unless got-load-function?
1451                         (multiple-value-setq (load-function.args init-function.args)
1452                           (p-make-load-function-using-pheap pheap object)))
1453                       (if load-function.args
1454                         (if (pptr-p load-function.args)
1455                           (unless checked-load-function?
1456                             (require-satisfies eql (pheap-pptr-pointer load-function.args pheap) address))
1457                           (progn
1458                             (unless checked-load-function?
1459                               (require-satisfies dc-vector-subtype-p disk-cache address $v_load-function))
1460                             (%fill-load-function-object
1461                              pheap disk-cache address load-function.args init-function.args descend)))
1462                         (return-from no-load-function nil))))))
1463               (%p-store-object pheap object descend)))))
1464
1465(defmethod %p-store-object (pheap (object pptr) descend)
1466  (declare (ignore descend))
1467  (require-pptr-pheap object pheap)
1468  (pptr-pointer object))
1469
1470(defmethod %p-store-object (pheap (object symbol) descend)
1471  (if (null object)
1472    $pheap-nil
1473    (maybe-cached-address pheap object
1474      (let ((address (dc-intern (pheap-disk-cache pheap)
1475                                (symbol-name object)
1476                                (symbol-package object)
1477                                t
1478                                (pheap-consing-area pheap)
1479                                pheap)))
1480        (when (eq descend nil)
1481          (return-from %p-store-object address))
1482        address))))
1483
1484(defmethod %p-store-object (pheap (object null) descend)
1485  (declare (ignore pheap descend))
1486  $pheap-nil)
1487
1488;;For general use, this should default to T, but for Hula we only save incidental lfuns in wood
1489;; heaps, so do not save debugging info for them.
1490(defvar *preserve-lfun-info* nil)
1491
1492(defmethod %p-store-object (pheap (object function) descend)
1493  (let* ((split-vec (apply #'vector (split-lfun object *preserve-lfun-info*)))
1494         (subtype (ccl->wood-subtype (ccl::%vect-subtype split-vec)))
1495         (length (length split-vec)))
1496    (%p-store-object-body (pheap object descend disk-cache address)
1497      (declare (ignore object))
1498      (+ (dc-make-uvector disk-cache length subtype) (- $t_lfun $t_vector))
1499      (p-store-gvector pheap split-vec descend disk-cache (+ address (- $t_vector $t_lfun)) length))))
1500
1501(defmethod %p-store-object (pheap (object cons) descend)
1502  (%p-store-object-body (pheap object descend disk-cache address)
1503    (dc-cons disk-cache $pheap-nil $pheap-nil)
1504    (progn
1505      (multiple-value-bind (car car-imm?) (%p-store pheap (car object) descend)
1506        (setf (dc-car disk-cache address car-imm?) car))
1507      (%p-store-cdr-of-cons pheap (cdr object) descend disk-cache address address))))
1508
1509(defun %p-store-cdr-of-cons (pheap cdr descend disk-cache outer-address result)
1510  (if (consp cdr)
1511    ; This cached? & inner-cached? stuff is to get around a compiler bug
1512    ; that causes the recursive call to %p-store-cdr-of-cons to not be tail-called.
1513    (let (cached? address)
1514      (let* ((inner-cached? t))
1515        (setq address (%p-store-object-body (pheap cdr descend disk-cache address)
1516                        (declare (ignore-if-unused cdr disk-cache address))
1517                        (dc-cons disk-cache $pheap-nil $pheap-nil)
1518                        (setq inner-cached? nil))
1519              cached? inner-cached?))             
1520      (setf (dc-cdr disk-cache outer-address) address)
1521      (unless cached?
1522        (multiple-value-bind (car car-imm?) (%p-store pheap (car cdr) descend)
1523          (setf (dc-car disk-cache address car-imm?) car))
1524        (setq cdr (cdr cdr))
1525        ; THIS MUST BE A TAIL CALL!!
1526        (%p-store-cdr-of-cons pheap cdr descend disk-cache address result)))
1527    (multiple-value-bind (cdr cdr-imm?) (%p-store pheap cdr descend)
1528      (setf (dc-cdr disk-cache outer-address cdr-imm?) cdr)
1529      result)))
1530
1531(defmethod %p-store-object (pheap (object double-float) descend)
1532  (maybe-cached-address pheap object
1533    (let ((address (dc-cons-float (pheap-disk-cache pheap)
1534                                  object
1535                                  (pheap-consing-area pheap))))
1536      (when (eq descend nil)
1537        (return-from %p-store-object address))
1538      address)))
1539
1540(defun p-cons-float (pheap float)
1541  (pptr pheap (dc-cons-float (pheap-disk-cache pheap) float)))       
1542
1543(defun dc-cons-float (disk-cache value &optional area)
1544  (setq value (require-type value 'float))
1545  (let ((address (%allocate-storage disk-cache area 8)))
1546    (setf (read-double-float disk-cache (decf address $t_cons)) value)
1547    (+ $t_dfloat address)))
1548
1549(defmethod %p-store-object (pheap (object package) descend)
1550  (maybe-cached-address pheap object
1551    (let ((address (dc-find-or-make-package (pheap-disk-cache pheap) object t)))
1552      (when (eq descend nil)
1553        (return-from %p-store-object address))
1554      address)))
1555
1556(defmethod %p-store-object (pheap (object structure-object) descend)
1557  (let* ((length (uvsize object))
1558         (consed? nil))
1559    (%p-store-object-body (pheap object descend disk-cache address)
1560      (progn
1561        (setq consed? t)
1562        (dc-make-uvector disk-cache length $v_struct))
1563      (progn
1564        (unless consed?
1565          ; Ensure that p-make-load-function-using-pheap method didn't change too much to handle
1566          (require-satisfies dc-vector-subtype-p disk-cache address $v_struct)
1567          (require-satisfies eql length (dc-uvsize disk-cache address)))
1568        (p-store-gvector pheap object descend disk-cache address length)))))
1569
1570; Called by %p-store-object for structure-object and standard-object
1571(defun %fill-load-function-object (pheap disk-cache address
1572                                              load-function.args init-function.args descend)
1573  (progn
1574    (require-satisfies p-consp load-function.args)
1575    (require-satisfies p-listp init-function.args)
1576    (dc-%svfill disk-cache address
1577      $load-function.load-list (%p-store pheap load-function.args descend)
1578      $load-function.init-list (%p-store pheap init-function.args descend))))
1579
1580
1581#-ppc-target
1582(defmethod %p-store-object (pheap (object t) descend)
1583  (if (uvectorp object)
1584    (if (ccl::%lfun-vector-p object)
1585      (%p-store-lfun-vector pheap object descend)
1586      (%p-store-uvector pheap object descend))
1587    (error "Don't know how to store ~s" object)))
1588
1589#+ppc-target
1590; No lfun vectors on the PPC
1591(defmethod %p-store-object (pheap (object t) descend)
1592  (if (uvectorp object)
1593    (%p-store-uvector pheap object descend)
1594    (error "Don't know how to store ~s" object)))
1595
1596#+ppc-target
1597; Some ppc fixnums aren't Wood fixnums
1598(defmethod %p-store-object (pheap (object fixnum) descend)
1599  (if (%ccl2-fixnum-p object)
1600    (progn
1601      ; We should only get here if %ccl2-fixnum-p is false.
1602      (cerror "Do the right thing" "Object, ~s,  doesn't satisfy ~s" object '%ccl2-fixnum-p)
1603      (values object t))
1604    (p-store-bignum pheap object descend)))
1605       
1606(defun %p-store-uvector (pheap object descend)
1607  (let* ((length (uvsize object))
1608         (subtype (ccl->wood-subtype (ccl::%vect-subtype object)))
1609         (store-function (or (svref *p-store-subtype-functions* subtype)
1610                             (error "Can't store vector of subtype ~s: ~s" subtype object))))
1611    #+ppc-target
1612    (when (eql subtype $v_arrayh)
1613      (return-from %p-store-uvector
1614        (p-store-arrayh pheap object descend)))
1615    #+ppc-target
1616    (when (eql subtype $v_bignum)
1617      (p-store-bignum pheap object descend))
1618    #+ccl-3
1619    (when (eql subtype $v_nhash)
1620      (return-from %p-store-uvector
1621        (p-store-nhash pheap object descend)))
1622    (%p-store-object-body (pheap object descend disk-cache address)
1623      (dc-make-uvector disk-cache length subtype)
1624      (funcall store-function pheap object descend disk-cache address length))))
1625
1626#+ppc-target
1627(defun p-store-bignum (pheap object descend)
1628  (let* ((negative? (< object 0))
1629         (abs (if negative? (- object) object))
1630         (bits (integer-length abs)))
1631    (multiple-value-bind (words zero-bits) (ceiling bits 16)
1632      (declare (fixnum words bits))
1633      (when (eql 0 zero-bits)
1634        (incf words))
1635      (%p-store-object-body (pheap object descend disk-cache address)
1636        (declare (ignore object))
1637        (dc-make-uvector disk-cache words $v_bignum)
1638        (let ((position 0)
1639              (index (* 2 (1- words))))
1640          (declare (fixnum index))
1641          (accessing-disk-cache (disk-cache (+ address $v_data))
1642            (dotimes (i words)
1643              (let ((word (if (> position bits) 0 (ccl::load-byte 16 position abs))))
1644                (declare (fixnum word))
1645                (when (and negative? (eql index 0))
1646                  (setq word (logior #x8000 word)))
1647                (store.w word index)
1648                (incf position 16)
1649                (decf index 2)))))))))
1650
1651#+ppc-target
1652(defun p-store-arrayh (pheap object descend)
1653  (assert (ccl::%array-is-header object))
1654  (multiple-value-bind (displaced-to offset) (displaced-array-p object)
1655    (let* ((rank (array-rank object))
1656           (dims (unless (eql rank 1) (array-dimensions object)))
1657           (total-size (array-total-size object))
1658           (fill (and (eql rank 1) (array-has-fill-pointer-p object) (fill-pointer object)))
1659           (simple (ccl::simple-array-p object))
1660           (subtype (old-wood->ccl-subtype (ccl->wood-subtype (ccl::%array-header-subtype object))))
1661           (adjustable (adjustable-array-p object))
1662           (length (if (eql rank 1)
1663                     (+ $arh.fill 1)
1664                     (+ $arh.dims rank 1)))
1665           (bits (+ (if fill (ash 1 $arh_fill_bit) 0)
1666                    (if simple (ash 1 $arh_simple_bit) 0)
1667                    (if (ccl::%array-is-header displaced-to) (ash 1 $arh_disp_bit) 0)
1668                    (if adjustable (ash 1 $arh_adjp_bit) 0)))
1669           (flags (+ (ash rank (+ 2 16 -3))
1670                     (ash subtype (+ 8 -3))
1671                     (ash bits -3))))
1672      (unless (fixnump flags)
1673        (error "Array header flags not a fixnum. Rank must be too big."))
1674      (unless displaced-to
1675        (error "~s should be displaced but isn't"))
1676      (%p-store-object-body (pheap object descend disk-cache address)
1677        (declare (ignore object))
1678        (dc-make-uvector disk-cache length $v_arrayh)
1679        (progn
1680          (dc-%svfill disk-cache address
1681            ($arh.fixnum t) flags
1682            ($arh.offs t) offset)
1683          (if (eql rank 1)
1684            (dc-%svfill disk-cache address
1685              ($arh.vlen t) total-size
1686              ($arh.fill t) (or fill total-size))
1687            (progn
1688              (setf (dc-%svref disk-cache address $arh.dims t) rank)
1689              (dotimes (i rank)
1690                (setf (dc-%svref disk-cache address (+ $arh.fill i) t)
1691                      (pop dims)))))
1692          (setf (dc-%svref disk-cache address $arh.vect)
1693                (%p-store pheap displaced-to descend)))))))
1694
1695(defun p-store-gvector (pheap object descend disk-cache address length)
1696  (dotimes (i length)
1697    (multiple-value-bind (element imm?) (%p-store pheap (uvref object i) descend)
1698      (setf (dc-%svref disk-cache address i imm?) element))))
1699
1700(defun p-store-ivector (pheap object descend disk-cache address length)
1701  (declare (ignore pheap descend length))
1702  (let* ((bytes (dc-%vector-size disk-cache address)))
1703    (store-byte-array object disk-cache (addr+ disk-cache address $v_data) bytes 0 t)))
1704
1705#+ppc-target
1706(defun p-store-bit-vector (pheap object descend disk-cache address length)
1707    (declare (ignore pheap descend length))
1708    (let* ((bytes (dc-%vector-size disk-cache address)))
1709      (declare (fixnum bytes))
1710      (store-byte-array object disk-cache (addr+ disk-cache address (1+ $v_data)) (1- bytes) 0 t)))
1711
1712#-ppc-target
1713(defun %p-store-lfun-vector (pheap object descend)
1714  (%p-store-object-body (pheap object descend disk-cache address)
1715    (dc-make-uvector disk-cache $load-function-size $v_load-function)
1716    (let* ((load-function.args
1717            `(ccl::%lfun-vector ,(ccl::%lfun-vector-lfun object))))
1718      (%fill-load-function-object
1719       pheap disk-cache address load-function.args nil descend))))
1720
1721(defmethod p-make-load-function-using-pheap ((pheap pheap) (hash hash-table))
1722  (let ((rehashF (function-name (ccl::nhash.rehashF hash)))
1723        (keytransF (ccl::nhash.keytransF hash))
1724        (compareF (ccl::nhash.compareF hash))
1725        (vector (ccl::nhash.vector hash))
1726        (count (ccl::nhash.count hash))
1727        (locked-additions (ccl::nhash.locked-additions hash)))
1728    (flet ((convert (f)
1729             (cond ((fixnump f) f)
1730                   ((symbolp f) (list f))
1731                   (t (function-name f)))))
1732      (values
1733       `(ccl::%cons-hash-table
1734         nil nil nil nil ,(ccl::nhash.grow-threshold hash) ,(ccl::nhash.rehash-ratio hash) ,(ccl::nhash.rehash-size hash))
1735       `(%initialize-hash-table ,rehashF ,(convert keytransF) ,(convert compareF)
1736                                ,vector ,count ,locked-additions)))))
1737
1738(defun %initialize-hash-table (hash rehashF keytransF compareF vector count locked-additions)
1739  (flet ((convert (f)
1740           (cond ((symbolp f) (symbol-function f))
1741                 ((listp f) (car f))
1742                 (t f))))
1743    (setf (ccl::nhash.rehashF hash) (symbol-function rehashF)
1744          (ccl::nhash.keytransF hash) (convert keytransF)
1745          (ccl::nhash.compareF hash) (convert compareF)
1746          (ccl::nhash.vector hash) vector
1747          (ccl::nhash.count hash) count
1748          (ccl::nhash.locked-additions hash) locked-additions)
1749    ; Rehash all hash tables. Everything hashes differently between 3.x and 4.x
1750    (ccl::needs-rehashing hash)
1751    (when (eq rehashF 'ccl::%no-rehash)
1752      (ccl::%maybe-rehash hash))))
1753
1754#-ccl-3
1755(defun p-load-nhash (pheap disk-cache pointer depth subtype)
1756  (p-load-header pheap disk-cache pointer depth subtype))
1757
1758; ccl-3 stores 2 more words in the header than ccl-2 did.
1759; It uses the unused header word and the other two for
1760; the the cache-index, cache-key, & cache-value
1761#+ccl-3
1762(progn
1763
1764(defconstant $old-nhash.vector-overhead 8)
1765(defconstant $old-nhash.vector-header-size 7)
1766(defconstant $new-nhash.vector-overhead 10)
1767(defconstant $nhash.vector-overhead-delta
1768  (- $new-nhash.vector-overhead $old-nhash.vector-overhead))
1769
1770(defun p-load-nhash (pheap disk-cache pointer depth subtype)
1771  (assert (eql subtype $v_nhash))
1772  (let* (length
1773         (cached? t)
1774         (vector (maybe-cached-value pheap pointer
1775                   (setq cached? nil
1776                         length (dc-%simple-vector-length disk-cache pointer))
1777                   (let* ((pairs (- length $old-nhash.vector-overhead))
1778                          (element-count (ash pairs -1))
1779                          (res (ccl::%cons-nhash-vector element-count))
1780                          (res-length (uvsize res)))
1781                     (declare (fixnum disk-length pairs element-count res-length))
1782                     (assert (eql (the fixnum (- length $old-nhash.vector-overhead))
1783                                  (the fixnum (- res-length $new-nhash.vector-overhead))))
1784                     res))))
1785    (when (or (not cached?)
1786              (and (eq depth t)
1787                   (let ((p-load-hash (p-load-hash pheap)))
1788                     (unless (gethash vector p-load-hash)
1789                       (setf (gethash vector p-load-hash) vector)))))
1790      (dotimes (i (the fixnum (or length (dc-%simple-vector-length disk-cache pointer))))
1791        (declare (fixnum i))
1792        (let ((j (if (< i $old-nhash.vector-header-size)
1793                   i
1794                   (the fixnum
1795                     (+ i $nhash.vector-overhead-delta)))))
1796          (unless (eql i $old-nhash.vector-header-size)
1797            (setf (uvref vector j)
1798                  (multiple-value-bind (pointer immediate?)
1799                                       (dc-%svref disk-cache pointer i)
1800                    (if immediate?
1801                      pointer
1802                      (pointer-load pheap pointer depth disk-cache))))))))
1803    vector))
1804
1805(defun p-store-nhash (pheap object descend)
1806  (let* ((length (uvsize object))
1807         (old-length (- length $nhash.vector-overhead-delta)))
1808    (declare (fixnum length old-length))
1809    (%p-store-object-body (pheap object descend disk-cache address)
1810      (dc-make-uvector disk-cache old-length $v_nhash)
1811      (progn
1812        (setf (dc-%svref disk-cache address $old-nhash.vector-header-size) $pheap-nil)
1813        (dotimes (i length)
1814          (declare (fixnum i))
1815          (let ((j i))
1816            (declare (fixnum j))
1817            (unless (and (>= i $old-nhash.vector-header-size)
1818                         (progn (decf j $nhash.vector-overhead-delta)
1819                                (< i $new-nhash.vector-overhead)))
1820              (multiple-value-bind (element imm?) (%p-store pheap (uvref object i) descend)
1821                (setf (dc-%svref disk-cache address j imm?) element)))))))))
1822
1823)  ; end of progn
1824
1825;;;;;;;;;;;;;;;;;;;;;;;;;;
1826;;
1827;; Useful macros for predicates and accessors
1828;;
1829
1830(defmacro p-dispatch (p if-pptr otherwise &optional make-pptr? apply?)
1831  (let ((p (if (listp p) (car p) p))
1832        (args (if (listp p) (cdr p))))
1833    (flet ((add-apply (form)
1834             (if apply?
1835               `(apply #',(car form) ,@(cdr form))
1836               form)))
1837      `(if (typep ,p 'pptr)
1838         (locally (declare (type pptr ,p) (optimize (speed 3) (safety 0)))
1839           ,(if make-pptr?
1840              (let ((pheap (make-symbol "PHEAP"))
1841                    (disk-cache (make-symbol "DISK-CACHE"))
1842                    (pointer (make-symbol "POINTER"))
1843                    (immediate? (make-symbol "IMMEDIATE?")))
1844                `(let* ((,pheap (pptr-pheap ,p))
1845                        (,disk-cache (pheap-disk-cache ,pheap)))
1846                   (multiple-value-bind (,pointer ,immediate?)
1847                                        ,(add-apply
1848                                          `(,if-pptr ,disk-cache (pptr-pointer ,p) ,@args))
1849                     (if ,immediate?
1850                       ,pointer
1851                       (pptr ,pheap ,pointer)))))
1852              (add-apply `(,if-pptr (pptr-disk-cache ,p)
1853                                    (pptr-pointer ,p)
1854                                    ,@args))))
1855         ,(add-apply `(,otherwise ,p ,@args))))))
1856
1857(eval-when (:compile-toplevel :load-toplevel :execute)
1858  (defun symbol-append (&rest syms)
1859    (let ((res (string (pop syms))))
1860      (loop
1861        (when (null syms) (return))
1862        (setq res (concatenate 'string res "-" (string (pop syms)))))
1863      (intern res))))
1864     
1865(defmacro def-predicate (lisp-predicate (p disk-cache pointer) &body body)
1866  (let ((p-name (symbol-append 'p lisp-predicate))
1867        (dc-name (symbol-append 'dc lisp-predicate)))
1868    `(progn
1869       (defun ,p-name (,p)
1870         (p-dispatch ,p ,dc-name ,lisp-predicate))
1871       (defun ,dc-name (,disk-cache ,pointer)
1872         ,@body))))
1873
1874(defmacro def-accessor (lisp-accessor (p . args) (disk-cache pointer)
1875                                      &body body)
1876  (let ((p-name (symbol-append 'p lisp-accessor))
1877        (dc-name (symbol-append 'dc lisp-accessor))
1878        (args-sans-keywords (remove lambda-list-keywords args
1879                                    :test #'(lambda (ll arg) (memq arg ll))))
1880        (rest-arg? (let ((l (cdr (memq '&rest args))))
1881                     (when l
1882                       (when (cdr l) (error "rest arg must be last"))
1883                       (car l)))))
1884    `(progn
1885       (defun ,p-name (,p ,@args)
1886         ,@(if rest-arg? `((declare (dynamic-extent ,rest-arg?))))
1887         (p-dispatch (,p ,@args-sans-keywords)
1888                     ,dc-name ,lisp-accessor t ,rest-arg?))
1889       (defun ,dc-name (,disk-cache ,pointer ,@args)
1890         ,@body))))
1891
1892;;;;;;;;;;;;;;;;;;;;;;;;;;
1893;;;
1894;;; Predicates
1895;;;
1896
1897; p-simple-string-p & dc-simple-string-p
1898(def-predicate simple-string-p (p disk-cache pointer)
1899  (dc-vector-subtype-p disk-cache pointer $v_sstr))
1900
1901; p-simple-vector-p & dc-simple-vector-p
1902(def-predicate simple-vector-p (p disk-cache pointer)
1903  (dc-vector-subtype-p disk-cache pointer $v_genv))
1904
1905(defun dc-vector-subtype-p (disk-cache pointer subtype)
1906  (declare (fixnum subtype))
1907  (and (pointer-tagp pointer $t_vector)
1908       (eql (read-8-bits disk-cache (+ pointer $v_subtype)) subtype)))
1909
1910(def-predicate consp (p disk-cache pointer)
1911  (declare (ignore disk-cache))
1912  (and (not (eql pointer $pheap-nil))
1913       (pointer-tagp pointer $t_cons)))
1914
1915(def-predicate listp (p disk-cache pointer)
1916  (declare (ignore disk-cache))
1917  (or (eql pointer $pheap-nil)
1918      (pointer-tagp pointer $t_cons)))
1919
1920(defun p-atom (p)
1921  (not (p-consp p)))
1922
1923(defun dc-atom (disk-cache pointer)
1924  (not (dc-consp disk-cache pointer)))
1925
1926(def-predicate uvectorp (p disk-cache pointer)
1927  (declare (ignore disk-cache))
1928  (eq $t_vector (pointer-tag pointer)))
1929
1930(def-predicate packagep (p disk-cache pointer)
1931  (dc-vector-subtype-p disk-cache pointer $v_pkg))
1932
1933(def-predicate symbolp (p disk-cache pointer)
1934  (declare (ignore disk-cache))
1935  (pointer-tagp pointer $t_symbol))
1936
1937(def-predicate arrayp (p disk-cache pointer)
1938  (and (pointer-tagp pointer $t_vector)
1939       (let ((subtype (dc-%vector-subtype disk-cache pointer)))
1940         (declare (fixnum subtype))
1941         (and (<= $v_min_arr subtype) (<= subtype $v_arrayh)))))
1942
1943(defun dc-array-subtype-satisfies-p (disk-cache array predicate)
1944  (and (pointer-tagp array $t_vector)
1945       (let ((subtype (dc-%vector-subtype disk-cache array)))
1946         (if (eql $v_arrayh subtype)
1947           (values
1948            (funcall predicate
1949                     (old-ccl->wood-subtype (dc-%arrayh-type disk-cache array)))
1950            t)
1951           (funcall predicate subtype)))))
1952
1953(def-predicate stringp (p disk-cache pointer)
1954  (multiple-value-bind (stringp arrayhp)
1955                       (dc-array-subtype-satisfies-p
1956                        disk-cache pointer
1957                        #'(lambda (x) (eql x $v_sstr)))
1958    (and stringp
1959         (or (not arrayhp)
1960             (eql $arh_one_dim (dc-%arrayh-rank4 disk-cache pointer))))))
1961
1962(def-predicate vectorp (p disk-cache pointer)
1963  (multiple-value-bind (arrayp arrayhp)
1964                       (dc-array-subtype-satisfies-p
1965                        disk-cache pointer
1966                        #'(lambda (x)
1967                            (declare (fixnum x))
1968                            (and (<= $v_min_arr x) (< x $v_arrayh))))
1969    (and arrayp
1970         (or (not arrayhp)
1971             (eql $arh_one_dim (dc-%arrayh-rank4 disk-cache pointer))))))
1972
1973;;;;;;;;;;;;;;;;;;;;;;;;;;
1974;;
1975;; Accessors
1976
1977; Returns vector size in BYTES
1978(defun dc-%vector-size (disk-cache v-pointer)
1979  (read-low-24-bits disk-cache (+ v-pointer $v_log)))
1980
1981(def-accessor svref (v index) (disk-cache v-pointer)
1982  (require-satisfies dc-simple-vector-p disk-cache v-pointer)
1983  (let ((length (dc-%simple-vector-length disk-cache v-pointer)))
1984    (unless (< -1 index length)
1985      (error "Index ~s out of bounds in ~s"
1986             index (dc-pointer-pptr disk-cache v-pointer))))
1987  (dc-%svref disk-cache v-pointer index))
1988
1989(defun (setf p-svref) (value p index)
1990  (if (pptr-p p)
1991    (let ((pheap (pptr-pheap p)))
1992      (multiple-value-bind (v imm?) (%p-store pheap value)
1993        (setf (dc-svref (pheap-disk-cache pheap)
1994                        (pptr-pointer p)
1995                        index
1996                        imm?)
1997              v)
1998        (if imm?
1999          v
2000          (pptr pheap v))))
2001    (setf (svref p index) value)))
2002
2003(defun (setf dc-svref) (value disk-cache v-pointer index &optional immediate?)
2004  (require-satisfies dc-simple-vector-p disk-cache v-pointer)
2005  (let ((length (dc-%simple-vector-length disk-cache v-pointer)))
2006    (unless (< -1 index length)
2007      (error "Index ~s out of bounds in ~s"
2008             (dc-pointer-pptr disk-cache v-pointer))))
2009  (setf (dc-%svref disk-cache v-pointer index immediate?) value))
2010
2011; Here's where the $block-overhead is skipped
2012(defun addr+ (disk-cache address offset)
2013  (let* ((page-size (disk-cache-page-size disk-cache))
2014         (mask (disk-cache-mask disk-cache))
2015         (start-page 0)
2016         (page-offset 0)
2017         (offset (require-type offset 'fixnum)))
2018    (declare (fixnum page-size mask page-offset blocks-crossed offset))
2019    (macrolet ((doit ()
2020                 `(progn
2021                    (setq start-page (logand address mask)
2022                          page-offset (- address (incf start-page $block-overhead)))
2023                    (incf page-offset offset)
2024                    (when (>= page-offset (decf page-size $block-overhead))
2025                      (incf page-offset
2026                            (the fixnum (* $block-overhead
2027                                           (the fixnum (floor page-offset page-size))))))
2028                    (+ start-page page-offset))))
2029      ; This will usually be called with fixnum addresses.
2030      ; It gets called a lot, so the optimization is worthwhile
2031      (if (fixnump address)
2032        (locally (declare (fixnum address start-page))
2033          (doit))
2034        (doit)))))
2035
2036(def-accessor ccl::%svref (v index) (disk-cache v-pointer)
2037  (read-pointer
2038   disk-cache
2039   (addr+ disk-cache v-pointer (+ (ash index 2) $v_data))))
2040
2041(defun (setf p-%svref) (value v index &optional immediate?)
2042  (declare (ignore value v index immediate?))
2043  (error "Not implemeneted"))
2044
2045(defun (setf dc-%svref) (value disk-cache v-pointer index &optional immediate?)
2046  (setf (read-pointer
2047         disk-cache
2048         (addr+ disk-cache v-pointer (+ (ash index 2) $v_data))
2049         immediate?)
2050        value))
2051
2052(defun dc-%simple-vector-length (disk-cache pointer)
2053  (the fixnum (ash (the fixnum (read-low-24-bits
2054                                disk-cache (+ pointer $v_log)))
2055                   -2)))
2056
2057(defun dc-%vector-subtype (disk-cache pointer)
2058  (read-8-bits disk-cache (+ pointer $v_subtype)))
2059
2060(def-accessor ccl::%vect-subtype (p) (disk-cache pointer)
2061  (values (dc-%vector-subtype disk-cache pointer) t))
2062
2063(defun dc-read-fixnum (disk-cache address &optional (address-name address))
2064  (multiple-value-bind (value imm?) (read-pointer disk-cache address)
2065    (unless (and imm? (fixnump value))
2066      (error "Inconsistency: pointer at ~s was not a fixnum." address-name))
2067    value))
2068
2069(defun dc-read-cons (disk-cache address &optional (address-name address))
2070  (multiple-value-bind (value imm?) (read-pointer disk-cache address)
2071    (unless (and (not imm?) (pointer-tagp value $t_cons))
2072      (error "Inconsistency: pointer at ~s was not a cons." address-name))
2073    value))
2074
2075(defun dc-%svref-fixnum (disk-cache vector index &optional (address-name index))
2076  (multiple-value-bind (value imm?) (dc-%svref disk-cache vector index)
2077    (unless (and imm? (fixnump value))
2078      (error "Inconsistency: pointer at ~s was not a fixnum." address-name))
2079    value))
2080
2081(def-accessor car (p) (disk-cache pointer)
2082  (require-satisfies dc-listp disk-cache pointer)
2083  (if (eq pointer $pheap-nil)
2084    $pheap-nil
2085    (read-pointer disk-cache (- pointer $t_cons))))
2086
2087(def-accessor cdr (p) (disk-cache pointer)
2088  (require-satisfies dc-listp disk-cache pointer)
2089  (if (eq pointer $pheap-nil)
2090    $pheap-nil
2091    (read-pointer disk-cache pointer)))
2092
2093(def-accessor last (list) (disk-cache pointer)
2094  (require-satisfies dc-listp disk-cache pointer)
2095  (loop
2096    (let ((next (dc-cdr disk-cache pointer)))
2097      (when (dc-atom disk-cache next)
2098        (return pointer))
2099      (setq pointer next))))
2100
2101(defun (setf p-car) (value p)
2102  (if (pptr-p p)
2103    (let ((pheap (pptr-pheap p)))
2104      (multiple-value-bind (v imm?) (%p-store pheap value)
2105        (setf (dc-car (pheap-disk-cache pheap)
2106                      (pptr-pointer p)
2107                      imm?)
2108              v)
2109        (if imm?
2110          v
2111          (pptr pheap v))))
2112    (setf (car p) value)))
2113
2114(defun (setf dc-car) (value disk-cache pointer &optional immediate?)
2115  (require-satisfies dc-consp disk-cache pointer)
2116  (setf (read-pointer disk-cache (- pointer $t_cons) immediate?) value))
2117
2118(defun (setf p-cdr) (value p)
2119  (if (pptr-p p)
2120    (let ((pheap (pptr-pheap p)))
2121      (multiple-value-bind (v imm?) (%p-store pheap value)
2122        (setf (dc-cdr (pheap-disk-cache pheap)
2123                      (pptr-pointer p)
2124                      imm?)
2125              v)
2126        (if imm?
2127          v
2128          (pptr pheap v))))
2129    (setf (cdr p) value)))
2130
2131(defun (setf dc-cdr) (value disk-cache pointer &optional immediate?)
2132  (require-satisfies dc-consp disk-cache pointer)
2133  (setf (read-pointer disk-cache pointer immediate?) value))
2134
2135(eval-when (:compile-toplevel :execute)
2136
2137(defmacro def-cxrs (max-length)
2138  (let ((res nil)
2139        (prev '("A" "D"))
2140        (prev-symbols '(dc-car dc-cdr))
2141        (len 2)
2142        next next-symbols)
2143    (loop
2144      (loop for middle in prev
2145            for sym in prev-symbols
2146            do (loop for prefix in '("A" "D")
2147                     for prefix-symbol in '(dc-car dc-cdr)
2148                     for new-middle = (concatenate 'string prefix middle)
2149                     for name = (intern (concatenate 'string "C" new-middle "R")
2150                                        :wood)
2151                     for dc-name = (intern (concatenate 'string "DC-" (symbol-name name))
2152                                           :wood)
2153                     for p-name = (intern (concatenate 'string "P-" (symbol-name name))
2154                                          :wood)
2155                     for form = `(def-accessor ,name (p) (disk-cache pointer)
2156                                   (multiple-value-bind (thing imm?)
2157                                                        (,sym disk-cache pointer)
2158                                     (when imm?
2159                                       (error "Immediate returned from:~@
2160                                               (~s ~s #x~x).~@
2161                                               Expected a cons pointer."
2162                                              ',sym disk-cache pointer))
2163                                     (,prefix-symbol disk-cache thing)))
2164                     for p-setter = `(defun (setf ,p-name) (value p)
2165                                       (if (pptr-p p)
2166                                         (let ((pheap (pptr-pheap p)))
2167                                           (multiple-value-bind (v imm?) (%p-store pheap value)
2168                                             (setf (,dc-name (pheap-disk-cache pheap)
2169                                                             (pptr-pointer p)
2170                                                             imm?)
2171                                                   v)
2172                                             (if imm? v (pptr pheap v))))
2173                                         (setf (,name p) value)))
2174                     for dc-setter = `(defun (setf ,dc-name) (value disk-cache pointer &optional
2175                                                                    value-imm?)
2176                                        (multiple-value-bind (cons cons-imm?) (,sym disk-cache pointer)
2177                                          (when cons-imm?
2178                                            (error "(~s ~s ~s) is an immediate."
2179                                                   ',sym disk-cache pointer))
2180                                          (setf (,prefix-symbol disk-cache cons value-imm?) value)))
2181                                       
2182                     do
2183                     (push form res)
2184                     (push p-setter res)
2185                     (push dc-setter res)
2186                     (push new-middle next)
2187                     (push dc-name next-symbols)))
2188      (setq prev next prev-symbols next-symbols
2189            next nil next-symbols nil)
2190      (when (> (incf len) max-length) (return)))
2191    `(progn ,@(nreverse res))))
2192
2193)
2194
2195(def-cxrs 4)
2196
2197(defun p-nth (n list)
2198  (if (pptr-p list)
2199    (let ((pheap (pptr-pheap list)))
2200      (multiple-value-bind (res imm?)
2201                           (dc-nth (pheap-disk-cache pheap) n (pptr-pointer list))
2202        (if imm? res (pptr pheap res))))
2203    (nth n list)))
2204
2205(defun dc-nth (disk-cache n list)
2206  (dc-car disk-cache (dc-nthcdr disk-cache n list)))
2207
2208(defun (setf p-nth) (value n list)
2209  (if (pptr-p list)
2210    (let* ((pheap (pptr-pheap list)))
2211      (multiple-value-bind (pointer imm?) (%p-store pheap value)
2212        (setf (dc-nth (pheap-disk-cache pheap) n (pptr-pointer list) imm?) pointer)
2213        (if imm? pointer (pptr pheap pointer))))
2214    (setf (nth n list) value)))
2215
2216(defun (setf dc-nth) (value disk-cache n list &optional imm?)
2217  (setf (dc-car disk-cache (dc-nthcdr disk-cache n list) imm?) value))
2218
2219(defun p-nthcdr (n list)
2220  (if (pptr-p list)
2221    (let ((pheap (pptr-pheap list)))
2222      (multiple-value-bind (res imm?)
2223                           (dc-nthcdr
2224                            (pheap-disk-cache pheap) n (pptr-pointer list))
2225        (if imm? res (pptr pheap res))))
2226    (nthcdr n list)))
2227
2228(defun dc-nthcdr (disk-cache n list)
2229  (setq n (require-type n 'unsigned-byte))
2230  (loop
2231    (when (eql 0 n)
2232      (return list))
2233    (decf n)
2234    (setq list (dc-cdr disk-cache list))))
2235
2236(defun (setf p-nthcdr) (value n list)
2237  (if (pptr-p list)
2238    (let* ((pheap (pptr-pheap list)))
2239      (multiple-value-bind (pointer imm?) (%p-store pheap value)
2240        (setf (dc-nthcdr (pheap-disk-cache pheap) n (pptr-pointer list) imm?) pointer)
2241        (if imm? pointer (pptr pheap pointer))))
2242    (setf (nthcdr n list) value)))
2243
2244(defun (setf dc-nthcdr) (value disk-cache n list &optional imm?)
2245  (if (eql 0 n)
2246    (values value imm?)
2247    (setf (dc-cdr disk-cache (dc-nthcdr disk-cache (1- n) list) imm?) value)))
2248
2249(defmacro p-dolist ((var list &optional result) &body body)
2250  (let ((list-var (gensym)))
2251    `(let ((,list-var ,list)
2252           ,var)
2253       (loop
2254         (when (null ,list-var) (return ,result))
2255         (setq ,var (p-car ,list-var)
2256               ,list-var (p-cdr ,list-var))
2257         ,@body))))
2258
2259(defun p-assoc (indicator a-list &key (test 'eql) test-not key (p-load? t))
2260  (if test-not
2261    (flet ((test (x y)
2262             (not (funcall test-not x y))))
2263      (declare (dynamic-extent #'test))
2264      (p-assoc indicator a-list :test #'test :key key :p-load? p-load?))
2265    (p-dolist (cell a-list)
2266      (let ((key-item (p-car cell)))
2267        (when p-load?
2268          (setq key-item (p-load key-item)))
2269        (when (funcall test indicator (if key (funcall key key-item) key-item))
2270          (return cell))))))
2271
2272(def-accessor uvsize (p) (disk-cache pointer)
2273  (require-satisfies dc-uvectorp disk-cache pointer)
2274  (let ((subtype (dc-%vector-subtype disk-cache pointer)))
2275    (dc-uv-subtype-size subtype
2276                        (dc-%vector-size disk-cache pointer)
2277                        (if (eql $v_bitv subtype)
2278                          (read-8-bits disk-cache (addr+ disk-cache pointer $v_data))))))
2279
2280(defun dc-uv-subtype-size (subtype bytes &optional last-byte-bits)
2281  (let* ((bytes-per-element (svref *subtype->bytes-per-element* subtype)))
2282    (values
2283     (if bytes-per-element
2284       (/ bytes bytes-per-element)
2285       (if (eql $v_bitv subtype)
2286         (+ (* 8 (max 0 (- bytes 2))) last-byte-bits)
2287         (error "~s not supported for vectors of subtype ~s" 'dc-uvref subtype)))
2288     t)))
2289     
2290(def-accessor uvref (v index) (disk-cache v-pointer)
2291  (require-satisfies dc-uvectorp disk-cache v-pointer)
2292  (let* ((subtype (dc-%vector-subtype disk-cache v-pointer))
2293         (uvreffer (svref *subtype->uvreffer* subtype)))
2294    (unless uvreffer
2295      (error "~s not valid for vector ~s of subtype ~s"
2296             'dc-uvref (dc-pointer-pptr disk-cache v-pointer) subtype))
2297    (funcall uvreffer disk-cache v-pointer index)))
2298
2299(defun do-uvref (disk-cache pointer offset index reader)
2300  (let ((size (dc-%vector-size disk-cache pointer)))
2301    (unless (< -1 offset size)
2302      (error "Index ~s out of range for ~s"
2303             index (dc-pointer-pptr disk-cache pointer)))
2304    (funcall reader disk-cache (addr+ disk-cache pointer (+ $v_data offset)))))
2305
2306(defun uvref-signed-byte (disk-cache pointer index)
2307  (values (do-uvref disk-cache pointer index index 'read-8-bits-signed)
2308          t))
2309
2310(defun uvref-unsigned-byte (disk-cache pointer index)
2311  (values (do-uvref disk-cache pointer index index 'read-8-bits)
2312          t))
2313
2314(defun uvref-signed-word (disk-cache pointer index)
2315  (values (do-uvref disk-cache pointer (* 2 index) index 'read-word)
2316          t))
2317
2318(defun uvref-unsigned-word (disk-cache pointer index)
2319  (values (do-uvref disk-cache pointer (* 2 index) index 'read-unsigned-word)
2320          t))
2321
2322(defun uvref-signed-long (disk-cache pointer index)
2323  (values (do-uvref disk-cache pointer (* 4 index) index 'read-long)
2324          t))
2325
2326(defun uvref-unsigned-long (disk-cache pointer index)
2327  (values (do-uvref disk-cache pointer (* 4 index) index 'read-unsigned-long)
2328          t))
2329
2330(defun uvref-genv (disk-cache pointer index)
2331  (do-uvref disk-cache pointer (* 4 index) index 'read-pointer))
2332
2333(defun uvref-string (disk-cache pointer index)
2334  (values (code-char (do-uvref disk-cache pointer index index 'read-8-bits))
2335          t))
2336
2337(defun uvref-extended-string (disk-cache pointer index)
2338  (values (code-char (do-uvref disk-cache pointer index index 'read-unsigned-word))
2339          t))
2340
2341; This will get much less ugly when we can stack cons float vectors.
2342(defun uvref-dfloat (disk-cache pointer index)
2343  (let ((offset (* index 8))
2344        (size (dc-%vector-size disk-cache pointer)))
2345    (unless (< -1 offset size)
2346      (error "Index ~s out of range for ~s"
2347             index (dc-pointer-pptr disk-cache pointer)))
2348    (values (read-double-float disk-cache (addr+ disk-cache pointer (+ $v_data offset))) t)))
2349
2350(defun %bit-vector-index-address-and-bit (disk-cache pointer index)
2351  (let ((size (dc-uv-subtype-size
2352               $v_bitv
2353               (dc-%vector-size disk-cache pointer)
2354               (read-8-bits disk-cache (addr+ disk-cache pointer $v_data)))))
2355    (unless (< -1 index size)
2356      (error "Index ~s out of range for ~s" index (dc-pointer-pptr disk-cache pointer)))
2357    (values (addr+ disk-cache pointer (+ $v_data 1 (ash index -3)))
2358            (- 7 (logand index 7)))))
2359
2360(defun uvref-bit-vector (disk-cache pointer index)
2361  (multiple-value-bind (address bit)
2362                       (%bit-vector-index-address-and-bit disk-cache pointer index)
2363    (values
2364     (if (logbitp bit (read-8-bits disk-cache address))
2365       1
2366       0)
2367     t)))
2368             
2369
2370(defun (setf p-uvref) (value pptr index)
2371  (if (pptr-p pptr)
2372    (let ((pheap (pptr-pheap pptr)))
2373      (multiple-value-bind (value-pointer imm?)
2374                           (if (and (or (bignump value) (typep value 'double-float))
2375                                    (memq (svref *subtype->uvsetter* (p-%vect-subtype pptr))
2376                                          '(uvset-long uvset-dfloat)))
2377                              (values value t)
2378                              (%p-store pheap value))
2379        (setf (dc-uvref (pheap-disk-cache pheap)
2380                        (pptr-pointer pptr)
2381                        index
2382                        imm?)
2383              value-pointer)
2384        (if imm?
2385          value-pointer
2386          (pptr pheap value-pointer))))
2387    (setf (uvref pptr index) value)))
2388
2389(defun (setf dc-uvref) (value disk-cache pointer index &optional immediate?)
2390  (let* ((subtype (dc-%vector-subtype disk-cache pointer))
2391         (uvsetter (svref *subtype->uvsetter* subtype)))
2392    (unless uvsetter
2393      (error "~s not valid for vector ~s of subtype ~s"
2394             'dc-uvref (dc-pointer-pptr disk-cache pointer) subtype))
2395    (funcall uvsetter value disk-cache pointer index immediate?)))
2396
2397(defun do-uvset (value disk-cache pointer offset index writer immediate?)
2398  (let ((size (dc-%vector-size disk-cache pointer)))
2399    (unless (< -1 offset size)
2400      (error "Index ~s out of range for ~s"
2401             index (dc-pointer-pptr disk-cache pointer)))
2402    (if immediate?
2403      (values (funcall writer
2404                       value disk-cache (addr+ disk-cache pointer (+ $v_data offset)) t)
2405              t)
2406      (funcall writer value disk-cache (addr+ disk-cache pointer (+ $v_data offset))))))
2407
2408(defun uvset-byte (value disk-cache pointer index immediate?)
2409  (unless (and immediate? (fixnump value))
2410    (error "Attempt to write a non-fixnum byte"))
2411  (do-uvset value disk-cache pointer index index #'(setf read-8-bits) nil))
2412
2413(defun uvset-word (value disk-cache pointer index immediate?)
2414  (unless (and immediate? (fixnump value))
2415    (error "Attempt to write a non-fixnum word"))
2416  (do-uvset value disk-cache pointer (* 2 index) index #'(setf read-word) nil))
2417
2418(defun uvset-long (value disk-cache pointer index immediate?)
2419  (unless immediate?
2420    (setq value (require-type
2421                 (pointer-load (disk-cache-pheap disk-cache) value :default disk-cache)
2422                 'integer)))
2423  (do-uvset value disk-cache pointer (* 4 index) index #'(setf read-long) nil))
2424
2425(defun uvset-genv (value disk-cache pointer index immediate?)
2426  (do-uvset value disk-cache pointer (* 4 index) index #'(setf read-pointer) immediate?))
2427
2428(defun uvset-string (value disk-cache pointer index immediate?)
2429  (declare (ignore immediate?))
2430  (do-uvset (char-code value) disk-cache pointer index index #'(setf read-8-bits) nil))
2431
2432(defun uvset-extended-string (value disk-cache pointer index immediate?)
2433  (declare (ignore immediate?))
2434  (do-uvset (char-code value) disk-cache pointer index index #'(setf read-word) nil))
2435
2436(defun uvset-dfloat (value disk-cache pointer index immediate?)
2437  (let ((offset (* index 8))
2438        (size (dc-%vector-size disk-cache pointer)))
2439    (unless (< -1 offset size)
2440      (error "Index ~s out of range for ~s"
2441             offset (dc-pointer-pptr disk-cache pointer)))
2442    (if immediate?
2443      (setf (read-double-float disk-cache (addr+ disk-cache pointer (+ $v_data offset)))
2444            (require-type value 'double-float))
2445      (let ((buf (make-string 8 :element-type 'base-character)))
2446        (declare (dynamic-extent buf))
2447        (require-satisfies pointer-tagp value $t_dfloat)
2448        (load-byte-array disk-cache (- value $t_dfloat) 8 buf)
2449        (store-byte-array buf disk-cache (addr+ disk-cache pointer (+ $v_data offset)) 8)
2450        value))))       
2451
2452(defun uvset-bit-vector (value disk-cache pointer index immediate?)
2453  (multiple-value-bind (address bit)
2454                       (%bit-vector-index-address-and-bit disk-cache pointer index)
2455    (unless (and immediate? (or (eql value 1) (eql value 0)))
2456      (error "bit vector value must be 0 or 1"))
2457    (let* ((byte (read-8-bits disk-cache address))
2458           (set? (logbitp bit byte)))
2459      (if (eql  value 0)
2460        (when set?
2461          (setf (read-8-bits disk-cache address)
2462                (logand byte (lognot (ash 1 bit)))))
2463        (unless set?
2464          (setf (read-8-bits disk-cache address)
2465                (logior byte (ash 1 bit)))))))
2466  value)
2467
2468(defun p-array-data-and-offset (p)
2469  (if (pptr-p p)
2470    (let ((pheap (pptr-pheap p)))
2471      (multiple-value-bind (address offset)
2472                           (dc-array-data-and-offset (pheap-disk-cache pheap)
2473                                                     (pptr-pointer p))
2474        (values (pptr pheap address) offset)))
2475    (ccl::array-data-and-offset p)))
2476
2477(defun dc-array-data-and-offset (disk-cache pointer)
2478  (require-satisfies dc-arrayp disk-cache pointer)
2479  (if (not (dc-vector-subtype-p disk-cache pointer $v_arrayh))
2480    (values pointer 0)
2481    (let* ((p pointer)
2482           (offset 0))
2483      (loop
2484        (incf offset (dc-%svref-fixnum disk-cache p $arh.offs '$arh.offs))
2485        (let ((next-p (dc-%svref disk-cache p $arh.vect)))
2486          (unless (logbitp $arh_disp_bit (dc-%arrayh-bits disk-cache p))
2487            (return (values next-p offset)))
2488          (setq p next-p))))))
2489
2490(def-accessor length (p) (disk-cache pointer)
2491  (values
2492   (cond ((dc-listp disk-cache pointer)
2493          (dc-%length-of-list disk-cache pointer))
2494         ((dc-vectorp disk-cache pointer)
2495          (dc-%vector-length disk-cache pointer))
2496         (t (error "~s is neither a list nor a vector"
2497                   (dc-pointer-pptr disk-cache pointer))))
2498   t))
2499
2500(defun dc-%vector-length (disk-cache pointer)
2501  (if (eql $v_arrayh (dc-%vector-subtype disk-cache pointer))
2502    (if (logbitp $arh_fill_bit (dc-%arrayh-bits disk-cache pointer))
2503      (dc-%svref disk-cache pointer $arh.fill)
2504      (dc-%svref disk-cache pointer $arh.vlen))
2505    (dc-uvsize disk-cache pointer)))
2506
2507(defun dc-%length-of-list (disk-cache pointer)
2508  (let ((len 0))
2509    (loop
2510      (if (eql $pheap-nil pointer)
2511        (return len))
2512      (setq pointer (dc-cdr disk-cache pointer))
2513      (incf len))))
2514 
2515(def-accessor symbol-name (p) (disk-cache pointer)
2516  (require-satisfies dc-symbolp disk-cache pointer)
2517  (read-pointer disk-cache (addr+ disk-cache pointer $sym_pname)))
2518
2519(def-accessor symbol-package (p) (disk-cache pointer)
2520  (require-satisfies dc-symbolp disk-cache pointer)
2521  (read-pointer disk-cache (addr+ disk-cache pointer $sym_package)))
2522
2523(defun dc-error (string disk-cache pointer)
2524  (let ((p (dc-pointer-pptr disk-cache pointer)))
2525    (error string p (p-load p))))
2526
2527(def-accessor symbol-value (p) (disk-cache pointer)
2528  (let ((values (dc-symbol-values-list disk-cache pointer)))
2529    (let ((value (ccl::%unbound-marker-8))
2530          (value-imm? t))
2531      (when values
2532        (multiple-value-setq (value value-imm?) (dc-car disk-cache values)))
2533      (when (and value-imm? (eq value (ccl::%unbound-marker-8)))
2534        (dc-error "Unbound variable: ~s = ~s" disk-cache pointer))
2535      (values value value-imm?))))
2536
2537; Should probably take an area parameter
2538(defun dc-symbol-values-list (disk-cache pointer &optional create?)
2539  (require-satisfies dc-symbolp disk-cache pointer)
2540  (let ((addr (addr+ disk-cache pointer $sym_values)))
2541    (multiple-value-bind (values vv-imm?)
2542                         (read-pointer disk-cache addr)
2543      (when (or vv-imm? (not (dc-listp disk-cache values)))
2544        (dc-error "Bad value list for symbol: ~s = ~s" disk-cache pointer))
2545      (if (eq values $pheap-nil)
2546        (when create?
2547          (setf (read-pointer disk-cache addr)
2548                (dc-make-list disk-cache 2)))
2549        values))))
2550
2551(defun (setf p-symbol-value) (value symbol)
2552  (if (pptr-p symbol)
2553    (let ((pheap (pptr-pheap symbol)))
2554      (multiple-value-bind (v v-imm?) (%p-store pheap value)
2555        (setf (dc-symbol-value (pheap-disk-cache pheap) (pptr-pointer symbol) v-imm?)
2556              v)
2557        (if v-imm? v (pptr pheap v))))
2558    (setf (symbol-value symbol) value)))
2559
2560(defun (setf dc-symbol-value) (value disk-cache pointer &optional imm?)
2561  (let ((values (dc-symbol-values-list disk-cache pointer t)))
2562    (setf (dc-car disk-cache values imm?) value)
2563    (values value imm?)))
2564 
2565(defun dc-pkg-arg (disk-cache pkg &optional (pkg-imm? (not (integerp pkg))))
2566  (or (dc-find-package disk-cache pkg pkg-imm?)
2567      (error "There is no package named ~s"
2568             (dc-canonicalize-pkg-arg disk-cache pkg pkg-imm?))))
2569
2570(def-accessor package-name (p) (disk-cache pointer)
2571  (dc-car disk-cache
2572          (dc-%svref disk-cache (dc-pkg-arg disk-cache pointer) $pkg.names)))
2573
2574(def-accessor package-nicknames (p) (disk-cache pointer)
2575  (dc-cdr disk-cache
2576          (dc-%svref disk-cache (dc-pkg-arg disk-cache pointer) $pkg.names)))
2577
2578(def-accessor string (p) (disk-cache pointer)
2579  (if (dc-stringp disk-cache pointer)
2580    pointer
2581    (dc-symbol-name disk-cache pointer)))
2582
2583(def-accessor array-rank (p) (disk-cache pointer)
2584  (require-satisfies dc-arrayp disk-cache pointer)
2585  (values
2586   (if (dc-vectorp disk-cache pointer)
2587     1
2588     (ash (dc-%arrayh-rank4 disk-cache pointer) -2))
2589   t))
2590
2591(def-accessor array-dimension (p n) (disk-cache pointer)
2592  (let ((rank (dc-array-rank disk-cache pointer)))
2593    (if (or (not (fixnump n)) (< n 0) (>= n rank))
2594      (error "~s is non-integer, < 0, or > rank of ~s"
2595             n (dc-pointer-pptr disk-cache pointer))
2596      (values
2597       (if (dc-simple-vector-p disk-cache pointer)
2598         (dc-%vector-length disk-cache pointer)
2599         (dc-%svref-fixnum disk-cache pointer (+ $arh.fill n)))
2600       t))))
2601
2602(def-accessor array-dimensions (p) (disk-cache pointer)
2603  (let ((rank (dc-array-rank disk-cache pointer)))
2604    (declare (fixnum rank))
2605    (if (dc-simple-vector-p disk-cache pointer)
2606      (values (list (dc-%vector-length disk-cache pointer)) t)
2607      (let ((res nil)
2608            (index $arh.fill))
2609        (declare (fixnum index))
2610        (dotimes (i rank)
2611          (push (dc-%svref-fixnum disk-cache pointer index) res)
2612          (incf index))
2613        (values
2614         (nreverse res)
2615         t)))))
2616 
2617(defun p-aref (p &rest indices)
2618  (declare (dynamic-extent indices))
2619  (if (pptr-p p)
2620    (let ((pheap (pptr-pheap p)))
2621      (multiple-value-bind (res imm?) (dc-aref-internal (pheap-disk-cache pheap)
2622                                                        (pptr-pointer p)
2623                                                        indices)
2624        (if imm?
2625          res
2626          (pptr pheap res))))
2627    (apply #'aref p indices)))
2628
2629(defun dc-aref (disk-cache pointer &rest indices)
2630  (declare (dynamic-extent indices))
2631  (dc-aref-internal disk-cache pointer indices))
2632
2633; Clobbers the indices arg. It is a stack-consed rest arg in my uses of it here.
2634(defun dc-aref-internal (disk-cache pointer indices)
2635  (multiple-value-bind (vector index) (dc-aref-vector-and-index disk-cache pointer indices)
2636    (if (null vector)                   ; rank 0
2637      nil
2638      (dc-uvref disk-cache vector index))))
2639
2640(defun dc-aref-vector-and-index (disk-cache pointer indices)
2641  (let ((rank (dc-array-rank disk-cache pointer)))
2642    (declare (fixnum rank))
2643    (unless (eql rank (length indices))
2644      (error "~s cannot be accessed with ~s subscripts."
2645             (dc-pointer-pptr disk-cache pointer)
2646             (length indices)))
2647    (if (eql rank 0)
2648      nil
2649      (multiple-value-bind (vector offset) (dc-array-data-and-offset disk-cache pointer)
2650        (if (eql rank 1)
2651          (values vector (+ offset (car indices)))
2652          (let* ((arrayh-index (+ $arh.dims rank))
2653                 (index 0)
2654                 (rest-size 1))
2655            (declare (fixnum index))
2656            (setq indices (nreverse indices))
2657            (dotimes (i rank)
2658              (let ((idx (pop indices))
2659                    (dim (dc-%svref-fixnum disk-cache pointer arrayh-index)))
2660                (if (>= idx dim)
2661                  (error "Array index ~s out of bounds for ~s"
2662                         idx (dc-pointer-pptr disk-cache pointer)))
2663                (setq index (+ index (* idx rest-size)))
2664                (setq rest-size (* rest-size dim))
2665                (decf arrayh-index)))
2666            (values vector (+ offset index))))))))
2667
2668(defun (setf p-aref) (value p &rest indices)
2669  (declare (dynamic-extent indices))
2670  (if (pptr-p p)
2671    (let ((pheap (pptr-pheap p)))
2672      (multiple-value-bind (v imm?) (%p-store pheap value)
2673        (dc-setf-aref (pheap-disk-cache pheap) (pptr-pointer p) v imm? indices)
2674        (if imm?
2675          v
2676          (pptr pheap v))))
2677    (setf (apply #'aref p indices) value)))
2678                   
2679(defun dc-setf-aref (disk-cache pointer value value-imm? indices)
2680  (multiple-value-bind (vector index) (dc-aref-vector-and-index disk-cache pointer indices)
2681    (setf (dc-uvref disk-cache vector index value-imm?) value)))
2682
2683#|
2684(defun incf-index-list (indices dims)
2685  (do ((indices-tail indices (cdr indices-tail))
2686       (dims-tail dims (cdr dims-tail)))
2687      ((null indices-tail) (return nil))
2688    (if (>= (incf (car indices-tail)) (car dims-tail))
2689      (setf (car indices-tail) 0)
2690      (return indices))))
2691
2692(defun p-fill-array (array)
2693  (let* ((dims (p-array-dimensions array))
2694         (indices (make-list (length dims) :initial-element 0)))
2695    (loop
2696      (let ((value (p-store (pptr-pheap array) indices nil)))
2697        (apply #'(setf p-aref) value array indices))
2698      (unless (incf-index-list indices dims)
2699        (return array)))))
2700
2701(defun p-check-array (array)
2702  (let* ((dims (p-array-dimensions array))
2703         (indices (make-list (length dims) :initial-element 0)))
2704    (loop
2705      (let ((value (p-load (apply #'p-aref array indices) t)))
2706        (unless (equal value indices)
2707          (cerror "Continue."
2708                  "~&SB: ~s, WAS: ~s~%" indices value))
2709        (unless (incf-index-list indices dims)
2710          (return))))))
2711
2712|#
2713
2714(defun p-delq (item list &optional count key)
2715  (unless (pptr-p list)
2716    (return-from p-delq
2717      (if key
2718        (delete item list :test 'eq :key key)
2719        (delq item list count))))
2720  (require-satisfies p-listp list)
2721  (let* ((pheap (pptr-pheap list))
2722         (list-address (pptr-pointer list))
2723         (disk-cache (pheap-disk-cache pheap)))
2724    (multiple-value-bind (item-address item-imm?)
2725                         (cond ((pptr-p item) (pheap-pptr-pointer item pheap))
2726                               ((immediate-object-p item) (values item t))
2727                               (t (or (gethash item (mem->pheap-hash pheap))
2728                                      (return-from p-delq list))))
2729      (let* ((handle (cons nil list-address))
2730             (last handle)
2731             (current list-address))
2732        (declare (dynamic-extent handle))
2733        (flet ((my-cdr (x)
2734                 (if (listp x)
2735                   (cdr x)
2736                   (multiple-value-bind (cdr imm?) (dc-cdr disk-cache x)
2737                     (when (and imm? cdr)
2738                       (error "Non-nil final cdr"))
2739                     cdr)))
2740               (set-my-cdr (x value)
2741                 (if (listp x)
2742                   (setf (cdr x) value)
2743                   (setf (dc-cdr disk-cache x) value))))
2744          (declare (dynamic-extent #'my-cdr #'set-my-cdr))
2745          (loop
2746            (when (or (eql current $pheap-nil) (eql 0 count))
2747              (return (pptr pheap (cdr handle))))
2748            (multiple-value-bind (car car-imm?) (dc-car disk-cache current)
2749              (if (if key
2750                    (eq item (funcall key (if car-imm? car (pptr pheap car))))
2751                    (and (eq car item-address)
2752                       (eq (not (null car-imm?)) item-imm?)))
2753                (progn
2754                  (setq current (my-cdr current))
2755                  (set-my-cdr last current)
2756                  (when count (decf count)))
2757                (setq last current
2758                      current (my-cdr current))))))))))
2759
2760;;;;;;;;;;;;;;;;;;;;;;;;;;
2761;;
2762;; Consers
2763;;
2764
2765(defun initialize-vector-storage (disk-cache address length subtype
2766                                                  bytes-per-element initial-element
2767                                                  &optional immediate?)
2768  (let* ((ptr address)
2769         (length (require-type length 'fixnum))
2770         (size (require-type (* length bytes-per-element) 'fixnum))
2771         (double-words (ash (+ size 7) -3))
2772         (min-disk-cache-size (addr+ disk-cache
2773                                     ptr
2774                                     (+ (ash double-words 3) $vector-header-size))))
2775    (declare (fixnum length size double-words))
2776    (unless (eql 0 (logand 7 ptr))
2777      (error "Address ~s not double-word aligned" address))
2778    (unless (< size #.(expt 2 24))
2779      (error "size: ~s > 24 bits" length))
2780    ; Extend the disk cache.
2781    ; Extend the file size too if the vector is big enough that it's worthwhile
2782    ; attempting to make the file contiguous there.
2783    ; Maybe this should extend the file for any object that crosses a page boundary
2784    (let ((extend-file-p (>= size (* 1024 16))))
2785      (extend-disk-cache disk-cache min-disk-cache-size extend-file-p))
2786    (unless (or (eql bytes-per-element 8)
2787                (eql bytes-per-element 4)
2788                (eql bytes-per-element 2)
2789                (eql bytes-per-element 1))
2790      (error "~s was ~s, should be 1, 2, or 4"
2791             'bytes-per-element bytes-per-element))
2792    (setf (read-long disk-cache ptr) $vector-header
2793          (read-8-bits disk-cache (incf ptr 4)) subtype
2794          (read-low-24-bits disk-cache ptr) size)
2795    (when (and initial-element (> double-words 0))
2796      (funcall (case bytes-per-element ((4 8) 'fill-long) (2 'fill-word) (1 'fill-byte))
2797               disk-cache
2798               (addr+ disk-cache ptr 4)
2799               initial-element
2800               ; round up to the nearest double word
2801               (* (case bytes-per-element ((4 8) 2) (2 4) (1 8)) double-words)
2802               immediate?)))
2803  (+ address $t_vector))
2804
2805; All sizes are rounded up to a multiple of 8 bytes.
2806(defmacro normalize-size (x &optional (multiple 8))
2807  (let ((mask (1- multiple)))
2808    `(logand (lognot ,mask) (+ ,x ,mask))))
2809
2810(assert (eql $segment-header-entry-bytes
2811             (normalize-size $segment-header-entry-bytes)))
2812
2813; Make a new area with single segment.
2814(defun p-make-area (pheap &rest rest &key segment-size flags)
2815  (declare (ignore segment-size flags))
2816  (declare (dynamic-extent rest))
2817  (pptr pheap (apply #'dc-make-area (pheap-disk-cache pheap) rest)))
2818
2819(defun dc-make-area (disk-cache &key
2820                                (segment-size *default-area-segment-size*)
2821                                (flags 0))
2822  (setq segment-size (require-type segment-size 'fixnum)
2823        flags (require-type flags 'fixnum))
2824  (symbol-macrolet ((area-header-size (normalize-size (* 4 $area-descriptor-size))))
2825    (let* ((area (%dc-allocate-new-memory disk-cache 1 $v_area))        ; take 1 page
2826           (free-count (floor (- (dc-%vector-size disk-cache area) area-header-size)
2827                              $segment-header-entry-bytes))
2828           (free-ptr (+ area $v_data area-header-size $t_cons
2829                        (- $segment-header-entry-bytes))))
2830      (assert (typep free-count 'fixnum))
2831      (dc-%svfill disk-cache area
2832        $segment-headers.area area
2833        ; $segment-headers.link is already $pheap-nil
2834        ($area.flags t) flags
2835        ($area.segment-size t) segment-size
2836        $area.last-headers area
2837        ($area.free-count t) free-count
2838        $area.free-ptr free-ptr)
2839      (dc-cons-segment disk-cache area segment-size $pheap-nil)
2840      area)))
2841
2842(defmacro with-consing-area (area &body body)
2843  (let ((thunk (gensym)))
2844    `(let ((,thunk #'(lambda () ,@body)))
2845       (declare (dynamic-extent ,thunk))
2846       (call-with-consing-area ,thunk ,area))))
2847
2848(defun call-with-consing-area (thunk area)
2849  (setq area (require-type area 'pptr))
2850  (let ((pheap (pptr-pheap area))
2851        (pointer (pptr-pointer area)))
2852    (require-satisfies dc-vector-subtype-p (pheap-disk-cache pheap) pointer $v_area)
2853    (let ((old-area (pheap-consing-area pheap)))
2854      (unwind-protect
2855        (progn
2856          (setf (pheap-consing-area pheap) pointer)
2857          (funcall thunk))
2858        (setf (pheap-consing-area pheap) old-area)))))
2859
2860(def-accessor area (p) (disk-cache pointer)
2861  (let* ((page (logand pointer (disk-cache-mask disk-cache)))
2862         (segment (read-long disk-cache (+ page $block-segment-ptr))))
2863    (dc-%svref disk-cache segment  $segment.area)))
2864
2865(defun area (p)
2866  (declare (ignore p))
2867  (error "In-memory objects do not have an area.."))
2868
2869
2870; Cons a new segment for the given area.
2871; The size defaults to the area's segment-size
2872; The free-link parameter is here only for use by dc-make-area above,
2873; so that it doesn't have to inline this code.
2874; Returns the pointer to the segment header.
2875(defun dc-cons-segment (disk-cache area &optional segment-size free-link)
2876  (unless segment-size
2877    (setq segment-size (dc-%svref disk-cache area $area.segment-size)))
2878  (let ((segment (%dc-allocate-new-memory disk-cache segment-size $v_segment nil)))
2879    (with-databases-locked
2880     (let ((free-count (dc-%svref-fixnum disk-cache area $area.free-count '$area.free-count))
2881           free-ptr)
2882       (declare (fixnum free-count))
2883       (flet ((get-free-link (disk-cache free-ptr)
2884                (if (eql 0 (dc-read-fixnum disk-cache (+ free-ptr $segment-header_freebytes)))
2885                  (dc-read-cons disk-cache (+ free-ptr $segment-header_free-link)
2886                                '$segment-header_free-link)
2887                  free-ptr)))
2888         (if (> free-count 0)
2889           (let ((old-free-ptr (dc-%svref disk-cache area $area.free-ptr)))
2890             (setq free-ptr (+ old-free-ptr $segment-header-entry-bytes)
2891                   free-link (or free-link (get-free-link disk-cache old-free-ptr))
2892                   free-count (1- free-count)))
2893           (symbol-macrolet ((segment-header-bytes (normalize-size (* 4 $segment-header-size))))
2894             (let* ((new-headers (%dc-allocate-new-memory disk-cache 1 $v_segment-headers)))
2895               (setf free-ptr (+ new-headers $v_data segment-header-bytes $t_cons)
2896                     free-link (or free-link
2897                                   (get-free-link disk-cache
2898                                                  (dc-%svref disk-cache area $area.free-ptr)))
2899                     free-count (floor (- (dc-%vector-size disk-cache new-headers)
2900                                          segment-header-bytes)
2901                                       $segment-header-entry-bytes)
2902                     (dc-%svref disk-cache new-headers $segment-headers.area) area
2903                     ; $segment-headers.link is already $pheap-nil
2904                     (dc-%svref disk-cache
2905                                (dc-%svref disk-cache area $area.last-headers)
2906                                $segment-headers.link)
2907                     new-headers
2908                     (dc-%svref disk-cache area $area.last-headers) new-headers))))
2909         (dc-%svfill disk-cache segment
2910           $segment.area area
2911           $segment.header free-ptr)
2912         (symbol-macrolet ((segment-header-bytes (normalize-size (* 4 $segment-header-size))))
2913           (setf (read-pointer disk-cache (+ free-ptr $segment-header_free))
2914                 (+ segment $v_data segment-header-bytes $t_cons)
2915                 (read-pointer disk-cache (+ free-ptr $segment-header_freebytes) t)
2916                 (- (dc-%vector-size disk-cache segment) segment-header-bytes)
2917                 (read-pointer disk-cache (+ free-ptr $segment-header_free-link))
2918                 free-link
2919                 (read-pointer disk-cache (+ free-ptr $segment-header_segment))
2920                 segment))
2921         (dc-%svfill disk-cache area
2922           ($area.free-count t) free-count
2923           $area.free-ptr free-ptr))))))
2924
2925; This is where the disk file gets longer.
2926; We grow a segment at a time.
2927; Segments are an even multiple of the page size in length and are aligned on a page
2928; boundary.
2929; This fills in only the vector header word and the subtype & length word.
2930; All other initialization must be done by the caller.
2931(defun %dc-allocate-new-memory (disk-cache segment-size subtype
2932                                               &optional
2933                                               (initial-element $pheap-nil)
2934                                               ie-imm?)
2935  (let* ((page-size (disk-cache-page-size disk-cache))
2936         (page-count (floor (+ segment-size (1- page-size)) page-size))
2937         free-page immediate?)
2938    (setq segment-size (* page-count page-size))
2939    (with-databases-locked
2940     (multiple-value-setq (free-page immediate?)
2941       (dc-%svref disk-cache $root-vector $pheap.free-page))
2942     (unless (and immediate? (fixnump free-page))
2943       (error "Inconsistent PHEAP: free pointer not a fixnum"))
2944     (setf (dc-%svref disk-cache $root-vector $pheap.free-page t)
2945           (require-type (+ free-page page-count) 'fixnum)))
2946    (let* ((free (* free-page page-size))
2947           (data-size (- segment-size (* page-count $block-overhead)))
2948           (res (initialize-vector-storage
2949                 disk-cache (+ free $block-overhead)
2950                 (ash (- data-size $vector-header-size) -2)
2951                 subtype 4 initial-element ie-imm?)))
2952      (incf free $block-segment-ptr)
2953      (dotimes (i page-count)
2954        (setf (read-pointer disk-cache free) res)
2955        (incf free page-size))
2956      res)))
2957
2958(eval-when (:compile-toplevel :execute)
2959  (assert (< (expt 2 24) most-positive-fixnum)))
2960
2961(assert (fixnump (1- (expt 2 24))))
2962
2963; And here's where all vectors are consed.
2964(defun %cons-vector-in-area (disk-cache area length subtype &optional
2965                                        initial-element (immediate? nil))
2966  (unless initial-element
2967    (setq initial-element (svref *subtype-initial-element* subtype)))
2968  (let* ((bytes-per-element (svref *subtype->bytes-per-element* subtype))
2969         (size (* length bytes-per-element)))
2970    (unless (< size (expt 2 24))
2971      (error "Attempt to allocate a vector larger than ~s bytes long"
2972             (1- (expt 2 24))))
2973    (locally (declare (fixnum size))
2974      (let* ((address (%allocate-storage disk-cache area (+ $vector-header-size size))))
2975        (initialize-vector-storage
2976         disk-cache (- address $t_cons) length subtype bytes-per-element initial-element
2977         immediate?)))))
2978
2979; Allocate size bytes of storage from the given area.
2980; Does not write anything in the storage.
2981; If you do not fill it properly, the next GC of the pheap will die a horrible death.
2982(defun %allocate-storage (disk-cache area size)
2983  (setq area (maybe-default-disk-cache-area disk-cache area))
2984  (%allocate-storage-internal
2985   disk-cache area (dc-%svref disk-cache area $area.free-ptr) (normalize-size size)))
2986
2987; Do the work for %allocate-storage.
2988; Size must be normalized.
2989; It's possible that this function needs to be only partially
2990; uninterruptable, but I was not sure so I played it safe. -Bill
2991(defun %allocate-storage-internal (disk-cache area segment size &optional
2992                                                   last-free-segment
2993                                                   (initial-segment segment)
2994                                                   it-better-fit)
2995  (with-databases-locked
2996   (let ((freebytes (dc-read-fixnum disk-cache (+ segment $segment-header_freebytes)
2997                                    '$segment-header_freebytes)))
2998     (declare (fixnum freebytes))
2999     (if (>= freebytes size)
3000       ; The allocation fits in this segment
3001       (let* ((address (dc-read-cons disk-cache (+ segment $segment-header_free))))
3002         (setf (read-pointer disk-cache (+ segment $segment-header_freebytes) t)
3003               (decf freebytes size)
3004               (read-pointer disk-cache (+ segment $segment-header_free))
3005               (addr+ disk-cache address size))
3006         (when (and (eql 0 freebytes) last-free-segment)
3007           ; This segment is full. Splice it out of the free list.
3008           (setf (read-pointer disk-cache (+ last-free-segment $segment-header_free-link))
3009                 (dc-read-cons disk-cache (+ segment $segment-header_free-link))
3010                 (read-pointer disk-cache (+ segment $segment-header_free-link))
3011                 $pheap-nil))
3012         address)
3013       ; Does not fit in this segment, try next free segment
3014       (let (#+remove (free-link (dc-read-cons disk-cache (+ segment $segment-header_free-link))))
3015         (when it-better-fit
3016           (error "it-better-fit and it doesn't"))
3017         (if nil ; (not (eql free-link $pheap-nil))
3018           ; Try the next segment in the free list
3019           (%allocate-storage-internal
3020            disk-cache area free-link size segment initial-segment)
3021           ; Does not fit in any of the existing segments. Make a new one.
3022           (let ((new-segment (dc-cons-segment
3023                               disk-cache
3024                               area
3025                               (max
3026                                (dc-%svref disk-cache area $area.segment-size)
3027                                (addr+
3028                                 disk-cache
3029                                 (+ $block-overhead
3030                                    (normalize-size (* 4 $segment-header-size))
3031                                    $vector-header-size)
3032                                 size)))))
3033             (%allocate-storage-internal
3034              disk-cache area new-segment size segment initial-segment t))))))))
3035
3036(defun maybe-default-disk-cache-area (disk-cache area)
3037  (unless area
3038    (setq area (dc-default-consing-area disk-cache)))
3039  (require-satisfies dc-vector-subtype-p disk-cache area $v_area)
3040  area)
3041
3042(defun maybe-default-area (pheap area)
3043  (if area
3044    (pheap-pptr-pointer area pheap)
3045    (pheap-consing-area pheap)))
3046
3047(defun p-cons (pheap car cdr &optional area)
3048  (multiple-value-bind (car-p car-immediate?) (%p-store pheap car)
3049    (multiple-value-bind (cdr-p cdr-immediate?) (%p-store pheap cdr)
3050      (pptr pheap
3051            (dc-cons (pheap-disk-cache pheap)
3052                          car-p cdr-p car-immediate? cdr-immediate?
3053                          (maybe-default-area pheap area))))))
3054
3055(defun dc-cons (disk-cache car cdr &optional
3056                                car-immediate? cdr-immediate? area)
3057  (let ((address (%allocate-storage disk-cache area 8)))
3058    (setf (read-pointer disk-cache (- address 4) car-immediate?) car
3059          (read-pointer disk-cache address cdr-immediate?) cdr)
3060    address))
3061
3062(defun p-list (pheap &rest elements)
3063  (declare (dynamic-extent elements))
3064  (%p-list*-in-area pheap nil elements))
3065
3066(defun p-list-in-area (pheap area &rest elements)
3067  (declare (dynamic-extent elements))
3068  (%p-list*-in-area pheap area elements))
3069
3070(defun %p-list*-in-area (pheap area elements)
3071  (let* ((disk-cache (pheap-disk-cache pheap))
3072         (res $pheap-nil)
3073         (area-pointer (maybe-default-area pheap area)))
3074    (require-satisfies dc-vector-subtype-p disk-cache area-pointer $v_area)
3075    (setq elements (nreverse elements))
3076    (dolist (element elements)
3077      (multiple-value-bind (car car-imm?) (%p-store pheap element)
3078        (setq res (dc-cons disk-cache car res car-imm? nil area-pointer))))
3079    (pptr pheap res)))
3080
3081(defun p-make-list (pheap size &key initial-element area)
3082  (let* ((disk-cache (pheap-disk-cache pheap))
3083         (area-pointer (maybe-default-area pheap area)))
3084    (require-satisfies dc-vector-subtype-p disk-cache area-pointer $v_area)
3085    (multiple-value-bind (ie ie-imm?) (%p-store pheap initial-element)
3086      (pptr pheap (dc-make-list disk-cache size ie area ie-imm?)))))
3087
3088(defun dc-make-list (disk-cache size &optional ie area ie-imm?)
3089  (when (and (null ie) (not ie-imm?))
3090    (setq ie $pheap-nil))
3091  (let ((res $pheap-nil))
3092    (dotimes (i size)
3093      (setq res (dc-cons disk-cache ie res ie-imm? nil area)))
3094    res))
3095
3096(defun p-make-uvector (pheap length subtype &key
3097                             (initial-element nil ie?)
3098                             area)
3099  (let (ie ie-imm?)
3100    (when ie?
3101      (multiple-value-setq (ie ie-imm?) (%p-store pheap initial-element)))
3102    (pptr pheap
3103          (dc-make-uvector
3104           (pheap-disk-cache pheap)
3105           length
3106           subtype
3107           (maybe-default-area pheap area)
3108           ie ie-imm?))))
3109
3110(defun dc-make-uvector (disk-cache length &optional
3111                                        (subtype $v_genv)
3112                                        area
3113                                        initial-element
3114                                        ie-imm?)
3115  (setq area (maybe-default-disk-cache-area disk-cache area))
3116  (if (eql subtype $v_bitv)
3117    (%cons-bit-vector disk-cache area length initial-element ie-imm?)
3118    (progn
3119      (if (and (eq subtype $v_sstr) ie-imm?)
3120        (setq initial-element (char-code initial-element)))
3121      (%cons-vector-in-area disk-cache area length subtype initial-element ie-imm?))))
3122
3123(defun p-make-vector (pheap length &key
3124                            (initial-element nil ie?)
3125                            area)
3126  (let (ie ie-imm?)
3127    (when ie?
3128      (multiple-value-setq (ie ie-imm?) (%p-store pheap initial-element)))
3129    (pptr pheap
3130          (dc-make-vector
3131           (pheap-disk-cache pheap)
3132           length
3133           (maybe-default-area pheap area)
3134           ie ie-imm?))))
3135
3136(defun dc-make-vector (disk-cache length &optional
3137                                  area
3138                                  initial-element
3139                                  ie-imm?)
3140  (dc-make-uvector disk-cache length $v_genv area initial-element ie-imm?))
3141
3142(defun %cons-bit-vector (disk-cache area length &optional initial-element ie-imm?)
3143  (let* ((bytes (1+ (ceiling length 8))))
3144    (unless (< bytes (expt 2 24))
3145      (error "Attempt to allocate a vector larger than ~s bytes long"
3146             (1- (expt 2 24))))
3147    (when initial-element
3148      (unless ie-imm?
3149        (error "Attempt to create a bit-vector with a non-bit initial-element."))
3150      (ecase initial-element
3151        (0)
3152        (1 (setq initial-element #xff))))
3153    (locally (declare (fixnum bytes))
3154      (let* ((address (%allocate-storage disk-cache area (+ $vector-header-size bytes)))
3155             (res (initialize-vector-storage
3156                   disk-cache (- address $t_cons) bytes $v_bitv 1
3157                   initial-element ie-imm?)))
3158        (setf (read-8-bits disk-cache (addr+ disk-cache res $v_data)) (mod length 8))
3159        res))))
3160
3161(defun p-make-array (pheap dimensions &key
3162                           area
3163                           (element-type t)
3164                           initial-contents
3165                           initial-element
3166                           adjustable
3167                           fill-pointer
3168                           displaced-to
3169                           displaced-index-offset)
3170  (let (ie ie-imm?)
3171    (when initial-element               ; NIL is the default
3172      (multiple-value-setq (ie ie-imm?) (%p-store pheap initial-element)))
3173    (pptr pheap
3174          (dc-make-array
3175           (pheap-disk-cache pheap)
3176           (p-load dimensions)
3177           (if (pptr-p area)
3178             (pheap-pptr-pointer area pheap)
3179             (pheap-consing-area pheap))
3180           (p-load element-type)
3181           ie
3182           ie-imm?
3183           initial-contents
3184           adjustable
3185           fill-pointer
3186           displaced-to
3187           displaced-index-offset))))
3188
3189(defun dc-make-array (disk-cache dimensions &optional
3190                                 area (element-type t) initial-element ie-imm?
3191                                 initial-contents adjustable
3192                                 fill-pointer displaced-to
3193                                 displaced-index-offset)
3194  (when (or initial-contents adjustable fill-pointer
3195            displaced-to displaced-index-offset)
3196    (error "Unsupported array option. Only support :initial-element & :area"))
3197  (let ((subtype (array-element-type->subtype element-type)))
3198    (if (or (atom dimensions) (null (cdr dimensions)))
3199      ; one-dimensional array
3200      (let ((length (require-type
3201                     (if (atom dimensions) dimensions (car dimensions))
3202                     'fixnum)))
3203        (dc-make-uvector disk-cache length subtype area initial-element ie-imm?))
3204      ; multi-dimensional array
3205      (progn
3206        (dolist (dim dimensions)
3207          (unless (and (fixnump dim) (>= dim 0))
3208            (error "Array dimension not a fixnum or less than 0: ~s")))
3209        (let ((rank (length dimensions))
3210              (length (apply #'* dimensions)))
3211          (unless (fixnump length)
3212            (error "Attempt to create multidimensional of size > ~s"
3213                   most-positive-fixnum))
3214          (unless (< rank (/ (expt 2 15) 4))
3215            (error "rank ~s > (/ (expt 2 15) 4)" rank))
3216          (let ((vector (dc-make-uvector
3217                         disk-cache length subtype area initial-element ie-imm?))
3218                (arrayh (dc-make-uvector disk-cache (+ $arh.dims rank 1) $v_arrayh area 0 t)))
3219            (setf (dc-%svref disk-cache arrayh $arh.vect) vector
3220                  (dc-%arrayh-rank4 disk-cache arrayh) (* 4 rank)
3221                  (dc-%arrayh-type disk-cache arrayh) (old-wood->ccl-subtype subtype)
3222                  (dc-%arrayh-bits disk-cache arrayh) (ash 1 $arh_simple_bit))
3223            (let ((dims dimensions)
3224                  (index $arh.fill))
3225              (declare (fixnum index))
3226              (dotimes (i (the fixnum rank))
3227                (setf (dc-%svref disk-cache arrayh index t) (pop dims))
3228                (incf index)))
3229            arrayh))))))
3230           
3231
3232(defparameter *array-element-type->subtype*
3233  '((bit . #.$v_bitv)
3234    ((signed-byte 8) . #.$v_sbytev)
3235    ((unsigned-byte 8) . #.$v_ubytev)
3236    ((signed-byte 16) . #.$v_swordv)
3237    ((unsigned-byte 16) . #.$v_uwordv)
3238    ((signed-byte 32) . #.$v_slongv)
3239    ((unsigned-byte 32) . #.$v_ulongv)
3240    (double-float . #.$v_floatv)
3241    (character . #.$v_sstr)
3242    (t . #.$v_genv)))
3243
3244(defun array-element-type->subtype (element-type)
3245  (if (eq element-type t)
3246    $v_genv
3247    (dolist (pair *array-element-type->subtype*
3248                  (error "Can't find subtype. Shouldn't happen."))
3249      (if (subtypep element-type (car pair))
3250        (return (cdr pair))))))
3251
3252(defun p-vector (pheap &rest elements)
3253  (declare (dynamic-extent elements))
3254  (p-uvector* pheap $v_genv elements))
3255
3256(defun p-uvector (pheap subtype &rest elements)
3257  (declare (dynamic-extent elements))
3258  (p-uvector* pheap subtype elements))
3259
3260(defun p-uvector* (pheap subtype elements)
3261  (let* ((genv? (eql (svref *subtype->uvsetter* subtype) 'uvset-genv))
3262         (vector (p-make-uvector pheap (length elements) subtype))
3263         (disk-cache (pheap-disk-cache pheap))
3264         (vector-pointer (pptr-pointer vector))
3265         (i 0))
3266    (if genv?
3267      (dolist (element elements)
3268        (multiple-value-bind (e imm?) (%p-store pheap element)
3269          (setf (dc-%svref disk-cache vector-pointer i imm?) e)
3270          (incf i)))
3271      (dolist (element elements)
3272        (multiple-value-bind (e imm?) (%p-store pheap element)
3273          (setf (dc-uvref disk-cache vector-pointer i imm?) e)
3274          (incf i))))
3275    vector))
3276
3277(defun p-cons-population (pheap data &optional (type 0))
3278  (p-uvector pheap $v_weakh nil type data))
3279
3280(def-accessor ccl::population-data (p) (disk-cache pointer)
3281  (require-satisfies dc-vector-subtype-p disk-cache pointer $v_weakh)
3282  (dc-%svref disk-cache pointer $population.data))
3283             
3284(defun p-make-load-function-object (pheap load-function.args init-function.args
3285                                          &optional area)
3286  (require-satisfies p-consp load-function.args)
3287  (require-satisfies p-listp init-function.args)
3288  (pptr pheap
3289        (dc-make-load-function-object
3290         (pheap-disk-cache pheap)
3291         (%p-store pheap load-function.args)
3292         (%p-store pheap init-function.args)
3293         (if (pptr-p area)
3294           (pheap-pptr-pointer area pheap)
3295           (pheap-consing-area pheap)))))
3296
3297
3298(defun dc-make-load-function-object (disk-cache load-function.args init-function.args
3299                                                &optional area)
3300  (let ((vector (dc-make-uvector disk-cache $load-function-size
3301                                 $v_load-function area)))
3302    (dc-%svfill disk-cache vector
3303      $load-function.load-list load-function.args
3304      $load-function.init-list init-function.args)
3305    vector))
3306
3307(defmethod p-make-load-function ((object t))
3308  nil)
3309
3310(defmethod p-make-load-function-using-pheap ((pheap pheap) object)
3311  (p-make-load-function object))        ; backward compatibility
3312
3313;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3314;;;
3315;;; Packages and symbols
3316;;;
3317     
3318(defun p-find-package (pheap package)
3319  (if (and (pptr-p package)
3320           (p-packagep package))
3321    package
3322    (multiple-value-bind (pkg pkg-imm?) (split-pptr package)
3323      (let ((pointer (dc-find-package (pheap-disk-cache pheap) pkg pkg-imm?)))
3324        (when pointer
3325          (pptr pheap pointer))))))
3326
3327; Returns a disk-resident package, memory-resident package, or memory-resident string
3328(defun dc-canonicalize-pkg-arg (disk-cache pkg pkg-imm?)
3329  (if pkg-imm?
3330    (values
3331     (if (packagep pkg)
3332       pkg
3333       (string pkg))
3334     t)
3335    (if (dc-packagep disk-cache pkg)
3336      pkg
3337      (values (pointer-load (disk-cache-pheap disk-cache)
3338                            (dc-string disk-cache pkg)
3339                            :default
3340                            disk-cache)
3341              t))))
3342
3343(defun dc-find-package (disk-cache pkg &optional pkg-imm?)
3344  (multiple-value-bind (pkg pkg-imm?) (dc-canonicalize-pkg-arg disk-cache pkg pkg-imm?)
3345    (if (not pkg-imm?)
3346      pkg
3347      (let* ((pkg-name (if (packagep pkg)
3348                         (package-name pkg)
3349                         (string pkg)))
3350             (btree (dc-package-btree disk-cache nil)))
3351        (and btree
3352             (dc-btree-lookup disk-cache btree pkg-name))))))
3353
3354(defun p-package-btree (pheap &optional (create? t))
3355  (let ((pointer (dc-package-btree (pheap-disk-cache pheap) create?)))
3356    (and pointer (pptr pheap pointer))))
3357
3358(defun dc-package-btree (disk-cache &optional (create? t))
3359  (with-databases-locked
3360   (let ((btree (dc-%svref disk-cache $root-vector $pheap.package-btree)))
3361     (if (not (eql $pheap-nil btree))
3362       btree
3363       (when create?
3364         (setf (dc-%svref disk-cache $root-vector $pheap.package-btree)
3365               (dc-make-btree disk-cache)))))))
3366
3367(defun p-make-package (pheap package-name &key nicknames)
3368  (pptr pheap (dc-make-package (pheap-disk-cache pheap)
3369                               (p-load package-name)
3370                               (p-load nicknames))))
3371
3372(defun dc-make-package (disk-cache name &optional nicknames)
3373  (let* ((pkg-name (ensure-simple-string (string name)))
3374         (btree (dc-package-btree disk-cache)))
3375    (with-databases-locked
3376     (if (dc-btree-lookup disk-cache btree pkg-name)
3377       (error "package name ~s already in use in ~s"
3378              pkg-name (disk-cache-pheap disk-cache))
3379       (dc-btree-store
3380        disk-cache
3381        btree
3382        pkg-name
3383        (dc-cons-package disk-cache pkg-name nicknames))))))
3384
3385(defun p-cons-package (pheap pkg-name &optional nicknames)
3386  (pptr pheap
3387        (dc-cons-package (pheap-disk-cache pheap)
3388                         (p-load pkg-name)
3389                         (p-load nicknames)
3390                         pheap)))
3391
3392(defun dc-cons-package (disk-cache pkg-name &optional
3393                                   nicknames
3394                                   (pheap (disk-cache-pheap disk-cache)))
3395  (let* ((names (mapcar #'(lambda (x) (ensure-simple-string (string x)))
3396                        (cons pkg-name nicknames)))
3397         (p-names (%p-store pheap names))
3398         (package (dc-make-uvector disk-cache $pkg-length $v_pkg)))
3399    (setf (dc-uvref disk-cache package $pkg.names) p-names
3400          (dc-uvref disk-cache package $pkg.btree) (dc-make-btree disk-cache))
3401    package))
3402       
3403
3404(defun p-intern (pheap string &key
3405                       (package *package*)
3406                       (area nil area-p))
3407  (multiple-value-bind (pkg pkg-imm?) (split-pptr package)
3408    (pptr pheap (dc-intern (pheap-disk-cache pheap)
3409                           (p-load string)
3410                           pkg pkg-imm?
3411                           (if area-p
3412                             (pheap-pptr-pointer area pheap)
3413                             (pheap-consing-area pheap))
3414                           pheap))))
3415
3416(defun dc-intern (disk-cache string pkg &optional pkg-imm? area pheap)
3417  (let* ((pkg (and pkg (dc-find-or-make-package disk-cache pkg pkg-imm?)))
3418         (str (require-type string 'string))
3419         (btree (and pkg (dc-%svref disk-cache pkg $pkg.btree))))
3420    (with-databases-locked
3421     (or (and pkg (dc-btree-lookup disk-cache btree str))
3422         (dc-%make-symbol disk-cache str pkg btree area pheap)))))
3423
3424(defun dc-%make-symbol (disk-cache str pkg &optional pkg-btree area pheap str-pointer)
3425  (let ((sym (dc-cons-symbol disk-cache
3426                             (or str-pointer
3427                                 (%p-store (or pheap (disk-cache-pheap disk-cache)) str))
3428                             (or pkg $pheap-nil)
3429                             area)))
3430    (when pkg
3431      (dc-btree-store
3432       disk-cache
3433       (or pkg-btree (dc-%svref disk-cache pkg $pkg.btree))
3434       (setq str (ensure-simple-string str))
3435       sym))
3436    sym))
3437
3438(defun dc-find-or-make-package (disk-cache package &optional pkg-imm?)
3439  (multiple-value-bind (pkg pkg-imm?)
3440                       (dc-canonicalize-pkg-arg disk-cache package pkg-imm?)
3441    (with-databases-locked
3442     (or (dc-find-package disk-cache pkg pkg-imm?)
3443         (let* ((pkg (or (if (packagep package) package (find-package package))
3444                         (error "There is no package named ~s") package))
3445                (pkg-name (package-name pkg))
3446                (nicknames (package-nicknames pkg)))
3447           (dc-make-package disk-cache pkg-name nicknames))))))
3448
3449(defun dc-cons-symbol (disk-cache string-pointer package &optional area)
3450  (let ((sym (+ (- $t_symbol $t_cons)
3451                (%allocate-storage disk-cache area $symbol-size))))
3452    (setf (read-long disk-cache (+ sym $sym_header)) $symbol-header
3453          (read-long disk-cache (addr+ disk-cache sym $sym_pname)) string-pointer
3454          (read-long disk-cache (addr+ disk-cache sym $sym_package)) package
3455          (read-long disk-cache (addr+ disk-cache sym $sym_values)) $pheap-nil)
3456    sym))
3457
3458(defun p-find-symbol (pheap string &optional (package *package*))
3459  (multiple-value-bind (pkg pkg-imm?) (split-pptr package)
3460    (let ((pointer (dc-find-symbol (pheap-disk-cache pheap) string pkg pkg-imm?)))
3461      (and pointer (pptr pheap pointer)))))
3462
3463(defun dc-find-symbol (disk-cache string &optional (package *package*) pkg-imm?)
3464  (let* ((pkg (dc-find-package disk-cache package pkg-imm?))
3465         (str (require-type string 'string)))
3466    (and pkg
3467         (dc-btree-lookup disk-cache
3468                          (dc-%svref disk-cache pkg $pkg.btree)
3469                          str))))
3470
3471;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3472;;;
3473;;; Hash tables
3474;;;
3475
3476(defun p-make-hash-table (pheap &key (test 'eq) weak area)
3477  (pptr pheap (dc-make-hash-table
3478               (pheap-disk-cache pheap)
3479               :test test
3480               :weak weak
3481               :area (maybe-default-area pheap area))))
3482
3483(defun dc-make-hash-table (disk-cache &key (test 'eq) weak area)
3484  (unless (or (eq test 'eq) (eq test #'eq))
3485    (error "Only ~s hash tables supported" 'eq))
3486  (let ((type (ecase weak
3487                ((nil) $btree-type_eqhash)
3488                (:key $btree-type_eqhash-weak-key)
3489                (:value $btree-type_eqhash-weak-value))))
3490    (dc-make-btree disk-cache area type)))
3491
3492(defun p-btree-p (p)
3493  (and (pptr-p p)
3494       (dc-btree-p (pptr-disk-cache p) (pptr-pointer p))))
3495
3496(defun dc-btree-p (disk-cache pointer)
3497  (dc-vector-subtype-p disk-cache pointer $v_btree))
3498
3499(def-predicate hash-table-p (p disk-cache pointer)
3500  (and (dc-btree-p disk-cache pointer)
3501       (> (dc-uvsize disk-cache pointer) $btree.type)   ; early versions missing this slot
3502       (logbitp $btree-type_eqhash-bit
3503                (dc-%svref-fixnum disk-cache pointer $btree.type '$btree.type))))
3504
3505(def-accessor hash-table-count (p) (disk-cache pointer)
3506  (require-satisfies dc-hash-table-p disk-cache pointer)
3507  (dc-btree-count disk-cache pointer))
3508
3509(def-accessor btree-count (p) (disk-cache pointer)
3510  (require-satisfies dc-btree-p disk-cache pointer)
3511  (dc-%svref disk-cache pointer $btree.count))
3512
3513(defun btree-count (p)
3514  (declare (ignore p))
3515  (error "~s is only defined for wood btrees" 'btree-count))
3516
3517(defun p-gethash (key hash &optional default)
3518  (if (pptr-p hash)
3519    (let* ((pheap (pptr-pheap hash))
3520           (hash-pointer (pptr-pointer hash))
3521           (disk-cache (pheap-disk-cache pheap)))
3522      (require-satisfies dc-hash-table-p disk-cache hash-pointer)
3523      (multiple-value-bind (value imm?) (%p-store-hash-key pheap key)
3524        (multiple-value-bind (res res-imm? found?)
3525                             (and value
3526                                  (dc-gethash disk-cache value imm? hash-pointer))
3527          (if found?
3528            (values
3529             (if res-imm?
3530               res
3531               (pptr pheap res))
3532             t)
3533            default))))
3534    (gethash key hash default)))
3535
3536; This could be just %p-store, but I'd rather not look in the
3537; btree if I know that the key can't be EQ.
3538(defun %p-store-hash-key (pheap key)
3539  (if (pptr-p key)
3540    (pheap-pptr-pointer key pheap)
3541    (cond ((immediate-object-p key) (values key t))
3542          ((null key) $pheap-nil)
3543          (t
3544           (with-databases-locked
3545            (maybe-cached-address pheap key
3546              ; This will be slightly faster if the p-find-xxx's are changed
3547              ; to dc-find-xxx.
3548              (or (cond ((symbolp key)
3549                         (split-pptr (p-find-symbol
3550                                      pheap (symbol-name key) (symbol-package key))))
3551                        ((packagep key)
3552                         (split-pptr (p-find-package pheap key)))
3553                        ((typep key 'class)
3554                         (split-pptr (p-find-class pheap key nil))))
3555                  (return-from %p-store-hash-key nil))))))))
3556
3557(defmacro with-dc-hash-key ((key-var key key-imm?) &body body)
3558  (let ((s4 (gensym))
3559        (s3 (gensym))
3560        (s2 (gensym))
3561        (s1 (gensym)))
3562    `(let* ((,s4 (make-string 4 :element-type 'base-character))
3563            (,s3 (make-string 3 :element-type 'base-character))
3564            (,s2 (make-string 2 :element-type 'base-character))
3565            (,s1 (make-string 1 :element-type 'base-character))
3566            ,key-var)
3567       (declare (dynamic-extent ,s4 ,s3 ,s2 ,s1))
3568       (%store-pointer ,key ,s4 0 ,key-imm?)
3569       (locally (declare (optimize (speed 3) (safety 0)))
3570         (if (eql #\000 (schar ,s4 0))
3571           (if (eql #\000 (schar ,s4 1))
3572             (if (eql #\000 (schar ,s4 2))
3573               (setf (schar ,s1 0) (schar ,s4 3)
3574                     ,key-var ,s1)
3575               (setf (schar ,s2 0) (schar ,s4 2)
3576                     (schar ,s2 1) (schar ,s4 3)
3577                     ,key-var ,s2))
3578             (setf (schar ,s3 0) (schar ,s4 1)
3579                   (schar ,s3 1) (schar ,s4 2)
3580                   (schar ,s3 2) (schar ,s4 3)
3581                   ,key-var ,s3))
3582           (setq ,key-var ,s4)))
3583       ,@body)))
3584
3585(defun dc-hash-key-value (key-string)
3586  (let* ((s (make-string 4 :element-type 'base-character))
3587         (len (length key-string)))
3588    (declare (dynamic-extent s)
3589             (fixnum len))
3590    (locally (declare (optimize (speed 3) (safety 0)))
3591      (setf (schar s 0)
3592            (setf (schar s 1)
3593                  (setf (schar s 2)
3594                        (setf (schar s 3) #\000)))))
3595    (if (> len 4) (error "Bad hash-table key-string: ~s" key-string))
3596    (%copy-byte-array-portion key-string 0 len s (the fixnum (- 4 len)))
3597    (%load-pointer s 0)))
3598
3599(defun dc-gethash (disk-cache key key-imm? hash)
3600  (with-dc-hash-key (key-string key key-imm?)
3601    (dc-btree-lookup disk-cache hash key-string)))
3602 
3603(defun (setf p-gethash) (value key hash &optional default)
3604  (declare (ignore default))
3605  (if (pptr-p hash)
3606    (let* ((pheap (pptr-pheap hash))
3607           (hash-pointer (pptr-pointer hash))
3608           (disk-cache (pheap-disk-cache pheap)))
3609      (require-satisfies dc-hash-table-p disk-cache hash-pointer)
3610      (multiple-value-bind (vp vi?) (%p-store pheap value)
3611        (multiple-value-bind (kp ki?) (%p-store pheap key)
3612          (dc-puthash disk-cache kp ki? hash-pointer vp vi?)
3613          (if vi?
3614            vp
3615            (pptr pheap vp)))))
3616    (setf (gethash key hash) value)))
3617
3618(defun dc-puthash (disk-cache key key-imm? hash value &optional value-imm?)
3619  (with-dc-hash-key (key-string key key-imm?)
3620    (dc-btree-store disk-cache hash key-string value value-imm?)))
3621
3622(defun p-remhash (key hash)
3623  (if (pptr-p hash)
3624    (let ((pheap (pptr-pheap hash)))
3625      (multiple-value-bind (value imm?) (%p-store-hash-key pheap key)
3626        (dc-remhash (pheap-disk-cache pheap) value imm? (pptr-pointer hash))))
3627    (remhash key hash)))
3628
3629(defun dc-remhash (disk-cache key key-imm? hash)
3630  (with-dc-hash-key (key-string key key-imm?)
3631    (dc-btree-delete disk-cache hash key-string)))
3632
3633(defun p-clrhash (hash)
3634  (if (pptr-p hash)
3635    (progn
3636      (dc-clrhash (pptr-disk-cache hash) (pptr-pointer hash))
3637      hash)
3638    (clrhash hash)))
3639
3640(defun dc-clrhash (disk-cache hash)
3641  (dc-clear-btree disk-cache hash))
3642
3643(defun p-maphash (function hash)
3644  (if (pptr-p hash)
3645    (let* ((pheap (pptr-pheap hash))
3646           (disk-cache (pheap-disk-cache pheap))
3647           (pointer (pptr-pointer hash)))
3648      (require-satisfies dc-hash-table-p disk-cache pointer)
3649      (let ((f #'(lambda (disk-cache key value value-imm?)
3650                   (declare (ignore disk-cache))
3651                   (multiple-value-bind (key-value key-imm?) (dc-hash-key-value key)
3652                     (funcall function
3653                              (if key-imm? key-value (pptr pheap key-value))
3654                              (if value-imm? value (pptr pheap value)))))))
3655        (declare (dynamic-extent f))
3656        (dc-map-btree disk-cache pointer f)))
3657    (maphash function hash)))
3658
3659;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3660;;;
3661;;; load barriars
3662;;;
3663
3664(defun p-make-pload-barrier (pheap object)
3665  (multiple-value-bind (addr addr-imm?) (%p-store pheap object)
3666    (if addr-imm?
3667      object
3668      (pptr pheap
3669            (dc-make-pload-barrier (pheap-disk-cache pheap) addr)))))
3670
3671; New function
3672(defun dc-make-pload-barrier (disk-cache address)
3673  (dc-make-uvector disk-cache $pload-barrier-size $v_pload-barrier nil address))
3674
3675(defun p-load-pload-barrier (pheap disk-cache pointer depth subtype)
3676  (declare (ignore subtype depth))
3677  (pptr pheap (dc-%svref disk-cache pointer $pload-barrier.object)))
3678
3679(defun p-load-through-barrier (object &optional (depth :default))
3680  (if (pptr-p object)
3681    (let* ((pheap (pptr-pheap object))
3682           (pointer (pptr-pointer object))
3683           (disk-cache (pheap-disk-cache pheap)))
3684      (if (dc-vector-subtype-p disk-cache pointer $v_pload-barrier)
3685        (pointer-load pheap (dc-%svref disk-cache pointer $pload-barrier.object)
3686                      depth disk-cache)
3687        (p-load object depth)))
3688    (p-load object depth)))
3689
3690(defun p-uvector-subtype-p (p subtype)
3691  (if (pptr-p p)
3692    (dc-vector-subtype-p (pptr-disk-cache p) (pptr-pointer p) subtype)
3693    (ccl::uvector-subtype-p p subtype)))
3694
3695(defun pload-barrier-p (object)
3696  (p-uvector-subtype-p object $v_pload-barrier))
3697
3698
3699;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3700;;;
3701;;; Dispatch tables
3702;;;
3703
3704(defparameter *p-load-subtype-functions*
3705  #(p-load-error                        ;($v_packed_sstr 0)
3706    p-load-bignum                       ;($v_bignum 1)
3707    p-load-error                        ;($v_macptr 2) - not supported
3708    p-load-ivector                      ;($v_badptr 3)
3709    p-load-lfun-vector                  ;($v_nlfunv 4)
3710    p-load-error                        ;subtype 5 unused
3711    p-load-ivector                      ;($v_xstr 6)      ;extended string
3712    p-load-ivector                      ;($v_ubytev 7)    ;unsigned byte vector
3713    p-load-ivector                      ;($v_uwordv 8)    ;unsigned word vector
3714    p-load-ivector                      ;($v_floatv 9)    ;float vector
3715    p-load-ivector                      ;($v_slongv 10)   ;Signed long vector
3716    p-load-ivector                      ;($v_ulongv 11)   ;Unsigned long vector
3717    #-ppc-target p-load-ivector         ;($v_bitv 12)     ;Bit vector
3718    #+ppc-target p-load-bit-vector
3719    p-load-ivector                      ;($v_sbytev 13)   ;Signed byte vector
3720    p-load-ivector                      ;($v_swordv 14)   ;Signed word vector
3721    p-load-ivector                      ;($v_sstr 15)     ;simple string
3722    p-load-gvector                      ;($v_genv 16)     ;simple general vector
3723    p-load-arrayh                       ;($v_arrayh 17)   ;complex array header
3724    p-load-struct                       ;($v_struct 18)   ;structure
3725    p-load-error                        ;($v_mark 19)     ;buffer mark
3726    p-load-pkg                          ;($v_pkg 20)
3727    p-load-error                        ;subtype 21 unused
3728    p-load-istruct                      ;($v_istruct 22)
3729    p-load-ivector                      ;($v_ratio 23)
3730    p-load-ivector                      ;($v_complex 24)
3731    p-load-instance                     ;($v_instance 25) ;clos instance
3732    p-load-error                        ;subtype 26 unused
3733    p-load-error                        ;subtype 27 unused
3734    p-load-error                        ;subtype 28 unused
3735    p-load-header                       ;($v_weakh 29)
3736    p-load-header                       ;($v_poolfreelist 30)
3737    p-load-nhash                        ;($v_nhash 31)
3738    ; internal subtypes
3739    p-load-nop                          ;($v_area 32)
3740    p-load-nop                          ;($v_segment 33)
3741    p-load-nop                          ;($v_random-bits 34)
3742    p-load-nop                          ;($v_dbheader 35)
3743    p-load-nop                          ;($v_segment-headers 36)
3744    p-load-nop                          ;($v_btree 37)
3745    p-load-nop                          ;($v_btree-node 38)
3746    p-load-class                        ;($v_class 39)
3747    p-load-load-function                ;($v_load-function 40)
3748    p-load-pload-barrier                ;($v_pload-barrier 41)
3749    ))
3750
3751(defparameter *subtype->bytes-per-element*
3752  #(nil                                 ; 0 - unused
3753    2                                   ; 1 - $v_bignum
3754    nil                                 ; 2 - $v_macptr - not supported
3755    4                                   ; 3 - $v_badptr
3756    2                                   ; 4 - $v_nlfunv
3757    nil                                 ; 5 - unused
3758    2                                   ; 6 - $v_xstr - extended string
3759    1                                   ; 7 - $v_ubytev - unsigned byte vector
3760    2                                   ; 8 - $v_uwordv - unsigned word vector
3761    8                                   ; 9 - $v_floatv - float vector
3762    4                                   ; 10 - $v_slongv - Signed long vector
3763    4                                   ; 11 - $v_ulongv - Unsigned long vector
3764    nil                                   ; 12 - $v_bitv - Bit vector (handled specially)
3765    1                                   ; 13 - $v_sbytev - Signed byte vector
3766    2                                   ; 14 - $v_swordv - Signed word vector
3767    1                                   ; 15 - $v_sstr - simple string
3768    4                                   ; 16 - $v_genv - simple general vector
3769    4                                   ; 17 - $v_arrayh - complex array header
3770    4                                   ; 18 - $v_struct - structure
3771    nil                                 ; 19 - $v_mark - buffer mark unimplemented
3772    4                                   ; 20 - $v_pkg
3773    nil                                 ; 21 - unused
3774    4                                   ; 22 - $v_istruct - type in first element
3775    4                                   ; 23 - $v_ratio
3776    4                                   ; 24 - $v_complex
3777    4                                   ; 25 - $v_instance - clos instance
3778    nil                                 ; 26 - unused
3779    nil                                 ; 27 - unused
3780    nil                                 ; 28 - unused
3781    4                                   ; 29 - $v_weakh - weak list header
3782    4                                   ; 30 - $v_poolfreelist - free pool header
3783    4                                   ; 31 - $v_nhash
3784    ; WOOD specific subtypes
3785    4                                   ; 32 - $v_area - area descriptor
3786    4                                   ; 33 - $v_segment - area segment
3787    1                                   ; 34 - $v_random-bits - vectors of random bits, e.g. resources
3788    4                                   ; 35 - $v_dbheader - database header
3789    nil                                 ; 36 - $v_segment-headers - specially allocated
3790    4                                   ; 37 - $v_btree
3791    nil                                 ; 38 - $v_btree-node - specially allocated
3792    4                                   ; 39 - $v_class
3793    4                                   ; 40 - $v_load-function
3794    4                                   ;($v_pload-barrier 41)
3795    ))
3796
3797(defparameter *p-store-subtype-functions*
3798  #(nil                                 ;($v_packed_sstr 0)
3799    p-store-ivector                     ;($v_bignum 1)
3800    nil                                 ;($v_macptr 2) - not supported
3801    p-store-ivector                     ;($v_badptr 3)
3802    nil                                 ;($v_nlfunv 4)
3803    nil                                 ;subtype 5 unused
3804    p-store-ivector                     ;($v_xstr 6)      ;16-bit string
3805    p-store-ivector                     ;($v_ubytev 7)    ;unsigned byte vector
3806    p-store-ivector                     ;($v_uwordv 8)    ;unsigned word vector
3807    p-store-ivector                     ;($v_floatv 9)    ;float vector
3808    p-store-ivector                     ;($v_slongv 10)   ;Signed long vector
3809    p-store-ivector                     ;($v_ulongv 11)   ;Unsigned long vector
3810    #-ppc-target p-store-ivector        ;($v_bitv 12)     ;Bit vector
3811    #+ppc-target p-store-bit-vector
3812    p-store-ivector                     ;($v_sbytev 13)   ;Signed byte vector
3813    p-store-ivector                     ;($v_swordv 14)   ;Signed word vector
3814    p-store-ivector                     ;($v_sstr 15)     ;simple string
3815    p-store-gvector                     ;($v_genv 16)     ;simple general vector
3816    p-store-gvector                     ;($v_arrayh 17)   ;complex array header
3817    p-store-gvector                     ;($v_struct 18)   ;structure
3818    nil                                 ;($v_mark 19)     ;buffer mark
3819    nil                                 ;($v_pkg 20)
3820    nil                                 ;subtype 21 unused
3821    p-store-gvector                     ;($v_istruct 22)
3822    p-store-ivector                     ;($v_ratio 23)
3823    p-store-ivector                     ;($v_complex 24)
3824    nil                                 ;($v_instance 25) ;clos instance
3825    nil                                 ;subtype 26 unused
3826    nil                                 ;subtype 27 unused
3827    nil                                 ;subtype 28 unused
3828    p-store-gvector                     ;($v_weakh 29)
3829    p-store-gvector                     ;($v_poolfreelist 30)
3830    p-store-gvector                     ;($v_nhash 31)
3831    ))
3832
3833(defparameter *subtype->uvreffer*
3834  #(nil                                 ; 0 - unused
3835    uvref-unsigned-word                 ; 1 - $v_bignum
3836    nil                                 ; 2 - $v_macptr - not supported
3837    uvref-unsigned-long                 ; 3 - $v_badptr
3838    uvref-unsigned-word                 ; 4 - $v_nlfunv
3839    nil                                 ; 5 - unused
3840    uvref-extended-string               ; 6 - $v_xstr - extended string
3841    uvref-unsigned-byte                 ; 7 - $v_ubytev - unsigned byte vector
3842    uvref-unsigned-word                 ; 8 - $v_uwordv - unsigned word vector
3843    uvref-dfloat                        ; 9 - $v_floatv - float vector
3844    uvref-signed-long                   ; 10 - $v_slongv - Signed long vector
3845    uvref-unsigned-long                 ; 11 - $v_ulongv - Unsigned long vector
3846    uvref-bit-vector                    ; 12 - $v_bitv - Bit vector
3847    uvref-signed-byte                   ; 13 - $v_sbytev - Signed byte vector
3848    uvref-signed-word                   ; 14 - $v_swordv - Signed word vector
3849    uvref-string                        ; 15 - $v_sstr - simple string
3850    uvref-genv                          ; 16 - $v_genv - simple general vector
3851    uvref-genv                          ; 17 - $v_arrayh - complex array header
3852    uvref-genv                          ; 18 - $v_struct - structure
3853    nil                                 ; 19 - $v_mark - buffer mark unimplemented
3854    uvref-genv                          ; 20 - $v_pkg
3855    nil                                 ; 21 - unused
3856    uvref-genv                          ; 22 - $v_istruct - type in first element
3857    uvref-genv                          ; 23 - $v_ratio
3858    uvref-genv                          ; 24 - $v_complex
3859    uvref-genv                          ; 25 - $v_instance - clos instance
3860    nil                                 ; 26 - unused
3861    nil                                 ; 27 - unused
3862    nil                                 ; 28 - unused
3863    uvref-genv                          ; 29 - $v_weakh - weak list header
3864    uvref-genv                          ; 30 - $v_poolfreelist - free pool header
3865    uvref-genv                          ; 31 - $v_nhash
3866    ; WOOD specific subtypes
3867    uvref-genv                          ; 32 - $v_area - area descriptor
3868    uvref-genv                          ; 33 - $v_segment - area segment
3869    uvref-unsigned-byte                 ; 34 - $v_random-bits - vectors of random bits, e.g. resources
3870    uvref-genv                          ; 35 - $v_dbheader - database header
3871    nil                                 ; 36 - $v_segment-headers - specially allocated
3872    uvref-genv                          ; 37 - $v_btree
3873    nil                                 ; 38 - $v_btree-node - specially allocated
3874    uvref-genv                          ; 39 - $v_class
3875    uvref-genv                          ; 40 - $v_load-function
3876    uvref-genv                          ; 41 - $v_pload-barrier
3877    ))
3878
3879(defparameter *subtype->uvsetter*
3880  #(nil                                 ; 0 - unused
3881    uvset-word                          ; 1 - $v_bignum
3882    nil                                 ; 2 - $v_macptr - not supported
3883    uvset-long                          ; 3 - $v_badptr
3884    uvset-word                          ; 4 - $v_nlfunv
3885    nil                                 ; 5 - unused
3886    uvset-extended-string               ; 6 - $v_xstr - extended string
3887    uvset-byte                          ; 7 - $v_ubytev - unsigned byte vector
3888    uvset-word                          ; 8 - $v_uwordv - unsigned word vector
3889    uvset-dfloat                        ; 9 - $v_floatv - float vector
3890    uvset-long                          ; 10 - $v_slongv - Signed long vector
3891    uvset-long                          ; 11 - $v_ulongv - Unsigned long vector
3892    uvset-bit-vector                    ; 12 - $v_bitv - Bit vector
3893    uvset-byte                          ; 13 - $v_sbytev - Signed byte vector
3894    uvset-word                          ; 14 - $v_swordv - Signed word vector
3895    uvset-string                        ; 15 - $v_sstr - simple string
3896    uvset-genv                          ; 16 - $v_genv - simple general vector
3897    uvset-genv                          ; 17 - $v_arrayh - complex array header
3898    uvset-genv                          ; 18 - $v_struct - structure
3899    nil                                 ; 19 - $v_mark - buffer mark unimplemented
3900    uvset-genv                          ; 20 - $v_pkg
3901    nil                                 ; 21 - unused
3902    uvset-genv                          ; 22 - $v_istruct - type in first element
3903    uvset-genv                          ; 23 - $v_ratio
3904    uvset-genv                          ; 24 - $v_complex
3905    uvset-genv                          ; 25 - $v_instance - clos instance
3906    nil                                 ; 26 - unused
3907    nil                                 ; 27 - unused
3908    nil                                 ; 28 - unused
3909    uvset-genv                          ; 29 - $v_weakh - weak list header
3910    uvset-genv                          ; 30 - $v_poolfreelist - free pool header
3911    uvset-genv                          ; 31 - $v_nhash
3912    ; WOOD specific subtypes
3913    uvset-genv                          ; 32 - $v_area - area descriptor
3914    uvset-genv                          ; 33 - $v_segment - area segment
3915    uvset-byte                          ; 34 - $v_random-bits - vectors of random bits, e.g. resources
3916    uvset-genv                          ; 35 - $v_dbheader - database header
3917    nil                                 ; 36 - $v_segment-headers - specially allocated
3918    uvset-genv                          ; 37 - $v_btree
3919    nil                                 ; 38 - $v_btree-node - specially allocated
3920    uvset-genv                          ; 39 - $v_class
3921    uvset-genv                          ; 40 - $v_load-function
3922    uvset-genv                          ; 41 - $v_pload-barrier
3923    ))
3924
3925(defparameter *subtype-initial-element*
3926  #(nil                                 ; 0 - unused
3927    nil                                 ; 1 - $v_bignum
3928    nil                                 ; 2 - $v_macptr not implemented
3929    nil                                 ; 3 - $v_badptr not implemented
3930    nil                                 ; 4 - $v_nlfunv
3931    nil                                 ; 5 - unused
3932    nil                                 ; 6 - $v_xstr - extended string
3933    nil                                 ; 7 - $v_ubytev - unsigned byte vector
3934    nil                                 ; 8 - $v_uwordv - unsigned word vector
3935    0                                   ; 9 - $v_floatv - float vector
3936    nil                                 ; 10 - $v_slongv - Signed long vector
3937    nil                                 ; 11 - $v_ulongv - Unsigned long vector
3938    nil                                 ; 12 - $v_bitv - Bit vector
3939    nil                                 ; 13 - $v_sbytev - Signed byte vector
3940    nil                                 ; 14 - $v_swordv - Signed word vector
3941    nil                                 ; 15 - $v_sstr - simple string
3942    #.$pheap-nil                        ; 16 - $v_genv - simple general vector
3943    #.$pheap-nil                        ; 17 - $v_arrayh - complex array header
3944    #.$pheap-nil                        ; 18 - $v_struct - structure
3945    nil                                 ; 19 - $v_mark - buffer mark unimplemented
3946    #.$pheap-nil                        ; 20 - $v_pkg
3947    nil                                 ; 21 - unused
3948    #.$pheap-nil                        ; 22 - $v_istruct - type in first element
3949    0                                   ; 23 - $v_ratio
3950    0                                   ; 24 - $v_complex
3951    #.$pheap-nil                        ; 25 - $v_instance - clos instance
3952    nil                                 ; 26 - unused
3953    nil                                 ; 27 - unused
3954    nil                                 ; 28 - unused
3955    #.$pheap-nil                        ; 29 - $v_weakh - weak list header
3956    #.$pheap-nil                        ; 30 - $v_poolfreelist - free pool header
3957    nil                                 ; 31 - $v_nhash unused
3958    #.$pheap-nil                        ; 32 - $v_area - area descriptor
3959    #.$pheap-nil                        ; 33 - $v_segment - area segment
3960    nil                                 ; 34 - $v_random-bits - vectors of random bits, e.g. resources
3961    #.$pheap-nil                        ; 35 - $v_dbheader - database header
3962    nil                                 ; 36 - $v_segment-headers - specially allocated
3963    #.$pheap-nil                        ; 37 - $v_btree
3964    nil                                 ; 38 - $v_btree-node - specially allocated
3965    #.$pheap-nil                        ; 39 - $v_class
3966    #.$pheap-nil                        ; 40 - $v_load-function
3967    #.$pheap-nil                        ; 41 - $v_pload-barrier
3968    ))
3969
3970#+ppc-target
3971(macrolet ((fill-subtype<->subtag-tables ()
3972             (let ((assoc-table
3973                    (vector
3974                                                        ; $v_sstr unsupported
3975                     ppc::subtag-bignum $v_bignum       ; 1
3976                     ppc::subtag-macptr $v_macptr       ; 2
3977                     ppc::subtag-dead-macptr $v_badptr  ; 3
3978                                                        ; 4 $v_nlfunv unsupported
3979                                                        ; 5 subtype unused
3980                     ppc::subtag-simple-general-string $v_xstr  ; 6
3981                     ppc::subtag-u8-vector $v_ubytev    ; 7
3982                     ppc::subtag-u16-vector $v_uwordv   ; 8
3983                     ppc::subtag-double-float-vector $v_floatv          ; 9
3984                     ppc::subtag-s32-vector $v_slongv   ; 10
3985                     ppc::subtag-u32-vector $v_ulongv   ; 11
3986                     ppc::subtag-bit-vector $v_bitv     ; 12
3987                     ppc::subtag-s8-vector $v_sbytev    ; 13
3988                     ppc::subtag-s16-vector $v_swordv   ; 14
3989                     ppc::subtag-simple-base-string $v_sstr     ; 15
3990                     ppc::subtag-simple-vector $v_genv  ; 16
3991                                                        ; 17 $v_arrayh handled specially
3992                     ppc::subtag-struct $v_struct       ; 18
3993                     ppc::subtag-mark $v_mark           ; 19
3994                     ppc::subtag-package $v_pkg         ; 20
3995                                                        ; 21 subtype unused
3996                     ppc::subtag-istruct $v_istruct     ; 22
3997                     ppc::subtag-ratio $v_ratio         ; 23
3998                     ppc::subtag-complex $v_complex     ; 24
3999                                                        ; 25 $v_instance handled specially
4000                                                        ; 26 subtype unused
4001                                                        ; 27 subtype unused
4002                                                        ; 28 subtype unused
4003                     ppc::subtag-weak $v_weakh          ; 29
4004                     ppc::subtag-pool $v_poolfreelist   ; 30
4005                     ppc::subtag-hash-vector $v_nhash   ; 31
4006                     ))
4007                   (ccl->wood (make-array 256 :initial-element nil))
4008                   (wood->ccl (make-array 32 :initial-element nil)))
4009               (do* ((i 0 (+ i 2)))
4010                   ((>= i (length assoc-table)))
4011                 (let ((ccl-subtag (aref assoc-table i))
4012                       (wood-subtype (aref assoc-table (1+ i))))
4013                   (setf (aref ccl->wood ccl-subtag) wood-subtype
4014                         (aref wood->ccl wood-subtype) ccl-subtag)))
4015               (setf (aref ccl->wood ppc::subtag-arrayh) $v_arrayh
4016                     (aref ccl->wood ppc::subtag-vectorh) $v_arrayh)
4017               `(progn
4018                  (setq *wood-subtype->ccl-subtag-table* ,wood->ccl
4019                        *ccl-subtag->wood-subtype-table* ,ccl->wood)
4020                  nil))))
4021  (fill-subtype<->subtag-tables))
4022
4023
4024#|
4025
4026; Remove a pptr from the caches.
4027; Used while debugging p-xxx accessors
4028(defun pptr-decache (pptr)
4029  (let* ((pheap (pptr-pheap pptr))
4030         (pointer (pptr-pointer pptr))
4031         (pheap->mem-hash (pheap->mem-hash pheap)))
4032    (multiple-value-bind (value found) (gethash pointer pheap->mem-hash)
4033      (when found
4034        (remhash pointer pheap->mem-hash)
4035        (remhash value (mem->pheap-hash pheap))))))
4036   
4037
4038(defun init-temp-pheap ()
4039  (declare (special pheap dc))
4040  (when (boundp 'pheap)
4041    (close-pheap pheap))
4042  (delete-file "temp.pheap")
4043  (create-pheap "temp.pheap")
4044  (setq pheap (open-pheap "temp.pheap")
4045        dc (pheap-disk-cache pheap))
4046  (dolist (w (windows :class 'inspector::inspector-window))
4047    (window-close w))
4048  (inspect dc))
4049
4050(setq p $pheap-nil)
4051
4052(time
4053 (dotimes (i 200)
4054   (setq p (dc-cons dc i p t nil))))
4055
4056(time
4057   (dotimes (i 1000)
4058     (setq p (dc-make-uvector dc 12 $v_genv nil p))))
4059
4060(defun crash-close (pheap)
4061  (let ((disk-cache (pheap-disk-cache pheap)))
4062    (close (disk-cache-stream disk-cache))
4063    (setq *open-disk-caches* (delq disk-cache *open-disk-caches*)
4064          *open-pheaps* (delq pheap *open-pheaps*)))
4065  nil)
4066
4067|#
4068;;;    1   3/10/94  bill         1.8d247
4069;;;    2   6/22/94  bill         1.9d002
4070;;;    3   7/26/94  Derek        1.9d027
4071;;;    4   9/19/94  Cassels      1.9d061
4072;;;    5  10/04/94  bill         1.9d071
4073;;;    6  10/13/94  gz           1.9d074
4074;;;    7  10/30/94  gz           1.9d083
4075;;;    8  11/01/94  Derek        1.9d085 Bill's Saving Library Task
4076;;;    9  11/03/94  Moon         1.9d086
4077;;;    10  11/05/94  kab         1.9d087
4078;;;    11  11/21/94  gsb         1.9d100
4079;;;    12  12/02/94  gsb         1.9d111 (patch upload)
4080;;;    13  12/12/94  RŽti        1.9d112
4081;;;    2   2/18/95  RŽti         1.10d019
4082;;;    3   3/23/95  bill         1.11d010
4083;;;    4   6/02/95  bill         1.11d040
4084;;;    5   8/01/95  bill         1.11d065
4085;;;    6   8/18/95  bill         1.11d071
4086;;;    7   8/25/95  Derek        Derek and Neil's massive bug fix upload
4087;;;    8   9/13/95  bill         1.11d080
Note: See TracBrowser for help on using the repository browser.