source: branches/lispworks/persistent-heap.lisp@ 21

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

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