source: branches/portable/persistent-heap.lisp@ 31

Last change on this file since 31 was 31, checked in by wws, 10 years ago

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