Skip to content
Newer
Older
100644 828 lines (701 sloc) 26.7 KB
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
1 ;;; -*- Mode: Lisp -*-
2
3 (in-package #:storage)
4
5 (eval-when (:compile-toplevel :load-toplevel :execute)
d18fea4 @stassats Code clean up.
authored
6 (defparameter *codes*
7 #(ascii-string
71abee5 @stassats Better symbols format.
authored
8 identifiable
9 cons
10 string
11 null
0b10cf5 @stassats Store T symbol separately.
authored
12 t
d18fea4 @stassats Code clean up.
authored
13 storable-class
71abee5 @stassats Better symbols format.
authored
14 fixnum
15 bignum
26801b4 @stassats Add a new type, fixnum-ratio.
authored
16 fixnum-ratio
71abee5 @stassats Better symbols format.
authored
17 ratio
9065dad @stassats Add float and complex types.
authored
18 double-float
19 single-float
20 complex
71abee5 @stassats Better symbols format.
authored
21 list-of-objects
22 symbol
23 intern-package-and-symbol
92a4f44 @stassats Add more data types.
authored
24 intern-symbol
25 character
26 simple-vector
f19bc56 @stassats Split complex array into complex vector.
authored
27 vector
92a4f44 @stassats Add more data types.
authored
28 array
287edce @stassats Add pathname type.
authored
29 hash-table
30 pathname)))
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
31
32 (defvar *statistics* ())
33 (defun collect-stats (code)
34 (let* ((type (aref *codes* code))
35 (cons (assoc type *statistics*)))
36 (if cons
37 (incf (cdr cons))
38 (push (cons type 1) *statistics*))
39 type))
40
f65dd3a @stassats New way of storing symbols.
authored
41 (defvar *indexes*)
19797e1 @stassats Store index array in *indexes*, not in an index slot of *storage*.
authored
42 (declaim (simple-vector *indexes*))
43
f65dd3a @stassats New way of storing symbols.
authored
44 (defvar *read-packages*)
45 (defvar *read-symbols*)
46 (declaim (vector *read-packages* *read-symbols*))
47
48 (defvar *write-packages*)
49 (defvar *write-symbols*)
50 (declaim (hash-table *write-packages* *write-symbols*))
92a4f44 @stassats Add more data types.
authored
51
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
52 (eval-when (:compile-toplevel :load-toplevel :execute)
53 (defun type-code (type)
54 (position type *codes*)))
55
569ad22 @stassats Rename *code-functions* to *readers*.
authored
56 (defparameter *readers* (make-array (length *codes*)))
57 (declaim (type (simple-array function (*)) *readers*))
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
58
59 (defmacro defreader (type (stream) &body body)
60 (let ((name (intern (format nil "~a-~a" type '#:reader))))
61 `(progn
62 (defun ,name (,stream)
63 ,@body)
569ad22 @stassats Rename *code-functions* to *readers*.
authored
64 (setf (aref *readers* ,(type-code type))
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
65 #',name))))
66
50bcdca @stassats slightly optimize call-reader.
authored
67 (declaim (inline call-reader))
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
68 (defun call-reader (code stream)
184dd25 @stassats Don't collect stats.
authored
69 ;; (collect-stats code)
569ad22 @stassats Rename *code-functions* to *readers*.
authored
70 (funcall (aref *readers* code) stream))
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
71
72 ;;;
73
74 (defconstant +sequence-length+ 2)
75 (eval-when (:compile-toplevel :load-toplevel :execute)
b6b6ebc @stassats Add arbitrary (actually, up to 8160-bit bignums) length integers and …
authored
76 (defconstant +fixnum-length+ 4))
bfe21a9 @stassats Increase character size to 3 bytes.
authored
77 (defconstant +char-length+ 3)
b6b6ebc @stassats Add arbitrary (actually, up to 8160-bit bignums) length integers and …
authored
78 (defconstant +id-length+ 3)
92a4f44 @stassats Add more data types.
authored
79 (defconstant +hash-table-length+ 3)
f19bc56 @stassats Split complex array into complex vector.
authored
80 (defconstant +vector-length+ 4)
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
81
96b45ab @stassats Don't write list length to disk, use +end+ as the end marker.
authored
82 (defconstant +end+ 255)
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
83
84 (defconstant +ascii-char-limit+ (code-char 128))
85
86 (deftype ascii-string ()
3dded72 @stassats Optimize ascii-string checking on SBCL.
authored
87 '(or
0179081 @stassats Improve bignum reading and writing.
authored
88 #+sb-unicode simple-base-string ; on #-sb-unicode the limit is 255
3dded72 @stassats Optimize ascii-string checking on SBCL.
authored
89 (satisfies ascii-string-p)))
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
90
6362dbf @stassats Optimize ascii-string-p on SBCL.
authored
91 #-sb-unicode
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
92 (defun ascii-string-p (string)
7fe2325 @stassats Optimize ascii-string-p.
authored
93 (declare (simple-string string))
94 (loop for char across string
95 always (char< char +ascii-char-limit+)))
054a959 @stassats Declare string to be simple-strings.
authored
96
6362dbf @stassats Optimize ascii-string-p on SBCL.
authored
97 #+sb-unicode
98 (defun ascii-string-p (string)
99 (optimized-ascii-string-p string))
100
d18fea4 @stassats Code clean up.
authored
101 (deftype storage-fixnum ()
102 `(signed-byte ,(* +fixnum-length+ 8)))
103
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
104 ;;;
105
106 (defun slot-effective-definition (class slot-name)
107 (find slot-name (class-slots class) :key #'slot-definition-name))
108
109 (defgeneric write-object (object stream))
110
a0be8bb @stassats Get rid of last-id slot in storage class.
authored
111 (defun assign-ids ()
112 (let ((last-id 0))
113 (declare (fixnum last-id))
068c72d @stassats Micro-optimize writing.
authored
114 (map-all-data
a0be8bb @stassats Get rid of last-id slot in storage class.
authored
115 (lambda (class objects)
068c72d @stassats Micro-optimize writing.
authored
116 (let ((slot (slot-definition-location (find-slot 'id class))))
117 (dolist (object objects)
118 (setf (standard-instance-access object slot) last-id)
119 (incf last-id)))))))
a0be8bb @stassats Get rid of last-id slot in storage class.
authored
120
104f009 @stassats Don't write descriptions of classes with no objects to disk.
authored
121 (defun number-of-non-empty-classes (storage)
112a78b @stassats Don't write the total number of objects to disk.
authored
122 (count-if #'objects-of-class
123 (storage-data storage)))
104f009 @stassats Don't write descriptions of classes with no objects to disk.
authored
124
40c7c78 @stassats Preallocate objects at the very beginning.
authored
125 (defun write-classes-info (stream)
104f009 @stassats Don't write descriptions of classes with no objects to disk.
authored
126 (write-n-bytes (number-of-non-empty-classes *storage*)
8d832ed @stassats Clean up.
authored
127 +sequence-length+ stream)
068c72d @stassats Micro-optimize writing.
authored
128 (map-all-data
129 (lambda (class objects)
130 (write-object class stream)
131 (write-n-bytes (length objects)
132 +id-length+ stream))))
40c7c78 @stassats Preallocate objects at the very beginning.
authored
133
134 (defun dump-data (stream)
135 (write-classes-info stream)
802fd25 @stassats save-data: Put with-packages at the right place.
authored
136 (assign-ids)
068c72d @stassats Micro-optimize writing.
authored
137 (map-all-data
138 (lambda (class objects)
c24219e @stassats Change the way slots are identified, saving disk space.
authored
139 (let ((slots (slot-locations-and-initforms class))
140 (bytes-for-slots (number-of-bytes-for-slots class)))
068c72d @stassats Micro-optimize writing.
authored
141 (dolist (object objects)
c24219e @stassats Change the way slots are identified, saving disk space.
authored
142 (write-standard-object object slots bytes-for-slots stream))))))
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
143
19797e1 @stassats Store index array in *indexes*, not in an index slot of *storage*.
authored
144 (declaim (inline read-next-object))
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
145 (defun read-next-object (stream)
146 (call-reader (read-n-bytes 1 stream) stream))
147
66f9c38 @stassats Handle NIL specially, not as a symbol.
authored
148 ;;; NIL
149
150 (defmethod write-object ((object null) stream)
151 (write-n-bytes #.(type-code 'null) 1 stream))
152
153 (defreader null (stream)
154 (declare (ignore stream))
155 nil)
156
0b10cf5 @stassats Store T symbol separately.
authored
157 ;;; T
158
159 (defmethod write-object ((object (eql t)) stream)
160 (write-n-bytes #.(type-code t) 1 stream))
161
162 (defreader t (stream)
163 (declare (ignore stream))
164 t)
165
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
166 ;;; Symbol
167
f65dd3a @stassats New way of storing symbols.
authored
168 (defmacro with-writing-packages (&body body)
169 `(let ((*write-packages* (make-hash-table :test #'eq))
170 (*write-symbols* (make-hash-table :test #'eq
171 :size 256)))
172 ,@body))
173
174 (defmacro with-reading-packages (&body body)
175 `(let ((*read-packages* (make-s-packages))
176 (*read-symbols* (make-s-symbols)))
8d832ed @stassats Clean up.
authored
177 ,@body))
178
71abee5 @stassats Better symbols format.
authored
179 (defun make-s-packages ()
f65dd3a @stassats New way of storing symbols.
authored
180 (make-array 16 :adjustable t :fill-pointer 0))
181
182 (defun make-s-symbols ()
183 (make-array 256 :adjustable t :fill-pointer 0))
71abee5 @stassats Better symbols format.
authored
184
185 (defun make-s-package (package)
f65dd3a @stassats New way of storing symbols.
authored
186 (vector-push-extend package *read-packages*))
71abee5 @stassats Better symbols format.
authored
187
188 (defun find-s-package (package)
f65dd3a @stassats New way of storing symbols.
authored
189 (loop for i below (length *read-packages*)
190 for stored-package = (aref *read-packages* i)
71abee5 @stassats Better symbols format.
authored
191 when (eq package stored-package)
f65dd3a @stassats New way of storing symbols.
authored
192 return i
193 finally (return (values (make-s-package package) t))))
71abee5 @stassats Better symbols format.
authored
194
195 (defun s-intern (symbol)
f65dd3a @stassats New way of storing symbols.
authored
196 (multiple-value-bind (package-id new-package)
71abee5 @stassats Better symbols format.
authored
197 (find-s-package (symbol-package symbol))
198 (let* ((existing (and (not new-package)
f65dd3a @stassats New way of storing symbols.
authored
199 (position symbol *read-symbols*)))
71abee5 @stassats Better symbols format.
authored
200 (symbol-id (or existing
f65dd3a @stassats New way of storing symbols.
authored
201 (vector-push-extend symbol *read-symbols*))))
71abee5 @stassats Better symbols format.
authored
202 (values package-id symbol-id new-package (not existing)))))
203
f65dd3a @stassats New way of storing symbols.
authored
204 (defun find-s-package-for-writing (package)
205 (or (gethash package *write-packages*)
206 (values (setf (gethash package *write-packages*)
207 (hash-table-count *write-packages*))
208 t)))
209
210 (defun s-intern-for-writing (symbol)
211 (multiple-value-bind (package-id new-package)
212 (find-s-package-for-writing (symbol-package symbol))
213 (let* ((existing (and (not new-package)
214 (gethash symbol *write-symbols*)))
215 (symbol-id (or existing
216 (setf (gethash symbol *write-symbols*)
217 (hash-table-count *write-symbols*)))))
218 (values package-id symbol-id
219 new-package
220 (not existing)))))
221
222 (defun s-intern-existing (symbol)
223 (vector-push-extend symbol *read-symbols*)
224 symbol)
71abee5 @stassats Better symbols format.
authored
225
226 (defmethod write-object ((symbol symbol) stream)
f65dd3a @stassats New way of storing symbols.
authored
227 (multiple-value-bind (package-id symbol-id new-package new-symbol)
228 (s-intern-for-writing symbol)
71abee5 @stassats Better symbols format.
authored
229 (cond ((and new-package new-symbol)
230 (write-n-bytes #.(type-code 'intern-package-and-symbol) 1 stream)
231 (write-object (package-name (symbol-package symbol)) stream)
232 (write-object (symbol-name symbol) stream))
233 (new-symbol
234 (write-n-bytes #.(type-code 'intern-symbol) 1 stream)
235 (write-n-bytes package-id +sequence-length+ stream)
236 (write-object (symbol-name symbol) stream))
237 (t
238 (write-n-bytes #.(type-code 'symbol) 1 stream)
239 (write-n-bytes symbol-id +sequence-length+ stream)))))
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
240
241 (defreader symbol (stream)
f65dd3a @stassats New way of storing symbols.
authored
242 (let* ((symbol-id (read-n-bytes +sequence-length+ stream))
243 (symbol (aref *read-symbols* symbol-id)))
71abee5 @stassats Better symbols format.
authored
244 (or symbol
f65dd3a @stassats New way of storing symbols.
authored
245 (error "Symbol with id ~a is not found" symbol-id))))
71abee5 @stassats Better symbols format.
authored
246
247 (defreader intern-package-and-symbol (stream)
248 (let* ((package-name (read-next-object stream))
249 (symbol-name (read-next-object stream))
250 (package (or (find-package package-name)
f65dd3a @stassats New way of storing symbols.
authored
251 (error "Package ~a not found" package-name))))
252 (make-s-package package)
253 (s-intern-existing (intern symbol-name package))))
71abee5 @stassats Better symbols format.
authored
254
255 (defreader intern-symbol (stream)
256 (let* ((package-id (read-n-bytes +sequence-length+ stream))
257 (symbol-name (read-next-object stream))
f65dd3a @stassats New way of storing symbols.
authored
258 (package (or (aref *read-packages* package-id)
71abee5 @stassats Better symbols format.
authored
259 (error "Package with id ~a for symbol ~a not found"
f65dd3a @stassats New way of storing symbols.
authored
260 package-id symbol-name))))
261 (s-intern-existing (intern symbol-name package))))
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
262
263 ;;; Integer
264
26801b4 @stassats Add a new type, fixnum-ratio.
authored
265 (declaim (inline write-fixnum))
266 (defun write-fixnum (n stream)
267 (declare (storage-fixnum n))
268 (write-n-signed-bytes n +fixnum-length+ stream))
269
4f382ab @stassats Fix bignums.
authored
270 (declaim (inline sign))
271 (defun sign (n)
272 (if (minusp n)
273 1
274 0))
b6b6ebc @stassats Add arbitrary (actually, up to 8160-bit bignums) length integers and …
authored
275
276 (defun write-bignum (n stream)
8781904 @stassats Improve compatibility with lesser implmenentations.
authored
277 (declare (type (and integer (not storage-fixnum)) n))
4f382ab @stassats Fix bignums.
authored
278 (write-n-bytes (sign n) 1 stream)
0179081 @stassats Improve bignum reading and writing.
authored
279 (let* ((fixnum-bits (* +fixnum-length+ 8))
280 (n (abs n))
281 (size (ceiling (integer-length n) fixnum-bits)))
b6b6ebc @stassats Add arbitrary (actually, up to 8160-bit bignums) length integers and …
authored
282 (write-n-bytes size 1 stream)
0179081 @stassats Improve bignum reading and writing.
authored
283 (loop for position by fixnum-bits below (* size fixnum-bits)
877d164 @stassats Whitespace cleanup.
authored
284 do
0179081 @stassats Improve bignum reading and writing.
authored
285 (write-n-bytes (ldb (byte fixnum-bits position) n)
b6b6ebc @stassats Add arbitrary (actually, up to 8160-bit bignums) length integers and …
authored
286 +fixnum-length+ stream))))
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
287
01328d7 @stassats Revert "Optimize writing byte and 2 byte integers."
authored
288 (defmethod write-object ((object integer) stream)
289 (typecase object
d18fea4 @stassats Code clean up.
authored
290 (storage-fixnum
26801b4 @stassats Add a new type, fixnum-ratio.
authored
291 (write-n-bytes #.(type-code 'fixnum) 1 stream)
01328d7 @stassats Revert "Optimize writing byte and 2 byte integers."
authored
292 (write-fixnum object stream))
26801b4 @stassats Add a new type, fixnum-ratio.
authored
293 (t
294 (write-n-bytes #.(type-code 'bignum) 1 stream)
295 (write-bignum object stream))))
b6b6ebc @stassats Add arbitrary (actually, up to 8160-bit bignums) length integers and …
authored
296
0179081 @stassats Improve bignum reading and writing.
authored
297 (declaim (inline read-sign))
298 (defun read-sign (stream)
299 (if (plusp (read-n-bytes 1 stream))
300 -1
301 1))
302
b6b6ebc @stassats Add arbitrary (actually, up to 8160-bit bignums) length integers and …
authored
303 (defreader bignum (stream)
0179081 @stassats Improve bignum reading and writing.
authored
304 (let ((fixnum-bits (* +fixnum-length+ 8))
305 (sign (read-sign stream))
306 (size (read-n-bytes 1 stream))
307 (integer 0))
308 (loop for position by fixnum-bits below (* size fixnum-bits)
309 do
310 (setf (ldb (byte fixnum-bits position) integer)
311 (read-n-bytes +fixnum-length+ stream)))
312 (* sign integer)))
b6b6ebc @stassats Add arbitrary (actually, up to 8160-bit bignums) length integers and …
authored
313
314 (defreader fixnum (stream)
ffada14 @stassats Use two's complement for storing fixnums.
authored
315 (read-n-signed-bytes +fixnum-length+ stream))
b6b6ebc @stassats Add arbitrary (actually, up to 8160-bit bignums) length integers and …
authored
316
317 ;;; Ratio
318
26801b4 @stassats Add a new type, fixnum-ratio.
authored
319 (defmethod write-object ((n ratio) stream)
320 (let ((numerator (numerator n))
321 (denominator (denominator n)))
322 (cond ((and (typep numerator 'storage-fixnum)
323 (typep denominator 'storage-fixnum))
324 (write-n-bytes #.(type-code 'fixnum-ratio) 1 stream)
325 (write-fixnum numerator stream)
326 (write-fixnum denominator stream))
327 (t
328 (write-n-bytes #.(type-code 'ratio) 1 stream)
329 (write-object numerator stream)
330 (write-object denominator stream)))))
331
332 (defreader fixnum-ratio (stream)
333 (/ (the storage-fixnum (fixnum-reader stream))
334 (the storage-fixnum (fixnum-reader stream))))
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
335
b6b6ebc @stassats Add arbitrary (actually, up to 8160-bit bignums) length integers and …
authored
336 (defreader ratio (stream)
337 (/ (read-next-object stream)
338 (read-next-object stream)))
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
339
9065dad @stassats Add float and complex types.
authored
340 ;;; Float
341
342 (defun write-8-bytes (n stream)
343 (write-n-bytes (ldb (byte 32 0) n) 4 stream)
344 (write-n-bytes (ldb (byte 64 32) n) 4 stream))
345
346 (defun read-8-bytes (stream)
347 (logior (read-n-bytes 4 stream)
348 (ash (read-n-bytes 4 stream) 32)))
349
350 (defmethod write-object ((float float) stream)
351 (etypecase float
352 (single-float
353 (write-n-bytes #.(type-code 'single-float) 1 stream)
354 (write-n-bytes (ieee-floats:encode-float32 float) 4 stream))
355 (double-float
356 (write-n-bytes #.(type-code 'double-float) 1 stream)
357 (write-8-bytes (ieee-floats:encode-float64 float) stream))))
358
359 (defreader single-float (stream)
360 (ieee-floats:decode-float32 (read-n-bytes 4 stream)))
361
362 (defreader double-float (stream)
363 (ieee-floats:decode-float64 (read-8-bytes stream)))
364
365 ;;; Complex
366
367 (defmethod write-object ((complex complex) stream)
368 (write-n-bytes #.(type-code 'complex) 1 stream)
369 (write-object (realpart complex) stream)
370 (write-object (imagpart complex) stream))
371
372 (defreader complex (stream)
373 (complex (read-next-object stream)
374 (read-next-object stream)))
375
92a4f44 @stassats Add more data types.
authored
376 ;;; Characters
377
378 (defmethod write-object ((character character) stream)
379 (write-n-bytes #.(type-code 'character) 1 stream)
380 (write-n-bytes (char-code character) +char-length+ stream))
381
382 (defreader character (stream)
383 (code-char (read-n-bytes +char-length+ stream)))
384
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
385 ;;; Strings
386
387 (defun write-ascii-string (string stream)
054a959 @stassats Declare string to be simple-strings.
authored
388 (declare (simple-string string))
ce85ba8 @stassats Optimize writing of non-base ascii strings.
authored
389 (write-n-bytes #.(type-code 'ascii-string) 1 stream)
390 (write-n-bytes (length string) +sequence-length+ stream)
391 #-(and sb-unicode (or x86 x86-64))
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
392 (loop for char across string
ce85ba8 @stassats Optimize writing of non-base ascii strings.
authored
393 do (write-n-bytes (char-code char) 1 stream))
394 #+(and sb-unicode (or x86 x86-64))
395 (write-ascii-non-base-string-optimized string stream))
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
396
397 (defun write-multibyte-string (string stream)
054a959 @stassats Declare string to be simple-strings.
authored
398 (declare (simple-string string))
ce85ba8 @stassats Optimize writing of non-base ascii strings.
authored
399 (write-n-bytes #.(type-code 'string) 1 stream)
400 (write-n-bytes (length string) +sequence-length+ stream)
5594732 @stassats sbcl-io: Optimize multi-byte string writing.
authored
401 #-(and sb-unicode (or x86 x86-64))
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
402 (loop for char across string
ce85ba8 @stassats Optimize writing of non-base ascii strings.
authored
403 do (write-n-bytes (char-code char) +char-length+ stream))
5594732 @stassats sbcl-io: Optimize multi-byte string writing.
authored
404 #+(and sb-unicode (or x86 x86-64))
ce85ba8 @stassats Optimize writing of non-base ascii strings.
authored
405 (write-multibyte-string-optimized string stream))
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
406
407 (defmethod write-object ((string string) stream)
408 (etypecase string
b684f2a @stassats Handle non-simple strings.
authored
409 ((not simple-string)
410 (call-next-method))
724d5be @stassats io-sbcl: Optimize reading of multibyte strings.
authored
411 #+(and sb-unicode (or x86 x86-64))
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
412 (simple-base-string
413 (write-n-bytes #.(type-code 'ascii-string) 1 stream)
414 (write-n-bytes (length string) +sequence-length+ stream)
21db675 @stassats Optimize writing of simple-base-strings on SBCL.
authored
415 (write-ascii-string-optimized string stream))
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
416 (ascii-string
417 (write-ascii-string string stream))
418 (string
419 (write-multibyte-string string stream))))
420
96f2b37 @stassats More micro-optimizations.
authored
421 (declaim (inline read-ascii-string))
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
422 (defun read-ascii-string (length stream)
423 (let ((string (make-string length :element-type 'base-char)))
39ace35 @stassats Optimize ascii string reading on SBCL.
authored
424 #-sbcl
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
425 (loop for i below length
96f2b37 @stassats More micro-optimizations.
authored
426 do (setf (schar string i)
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
427 (code-char (read-n-bytes 1 stream))))
39ace35 @stassats Optimize ascii string reading on SBCL.
authored
428 #+(and sbcl (or x86 x86-64))
429 (read-ascii-string-optimized length string stream)
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
430 string))
431
432 (defreader ascii-string (stream)
433 (read-ascii-string (read-n-bytes +sequence-length+ stream) stream))
434
435 (defreader string (stream)
436 (let* ((length (read-n-bytes +sequence-length+ stream))
437 (string (make-string length :element-type 'character)))
724d5be @stassats io-sbcl: Optimize reading of multibyte strings.
authored
438 #-(and sb-unicode (or x86 x86-64))
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
439 (loop for i below length
96f2b37 @stassats More micro-optimizations.
authored
440 do (setf (schar string i)
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
441 (code-char (read-n-bytes +char-length+ stream))))
724d5be @stassats io-sbcl: Optimize reading of multibyte strings.
authored
442 #+(and sb-unicode (or x86 x86-64))
443 (read-multibyte-string-optimized length string stream)
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
444 string))
445
287edce @stassats Add pathname type.
authored
446 ;;; Pathname
447
448 (defmethod write-object ((pathname pathname) stream)
449 (write-n-bytes #.(type-code 'pathname) 1 stream)
450 (write-object (pathname-name pathname) stream)
451 (write-object (pathname-directory pathname) stream)
452 (write-object (pathname-device pathname) stream)
453 (write-object (pathname-type pathname) stream)
454 (write-object (pathname-version pathname) stream))
455
456 (defreader pathname (stream)
457 (make-pathname
458 :name (read-next-object stream)
459 :directory (read-next-object stream)
460 :device (read-next-object stream)
461 :type (read-next-object stream)
462 :version (read-next-object stream)))
463
9065dad @stassats Add float and complex types.
authored
464 ;;; Cons
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
465
466 (defmethod write-object ((list cons) stream)
d1c604b @stassats Rewrite SBCL I/O without using mmap(2).
authored
467 (cond ((alexandria:circular-list-p list)
585b9e9 @stassats Improper cons support.
authored
468 (error "Can't store circular lists"))
469 ((and (alexandria:proper-list-p list)
470 (list-of-objects-p list))
ca92680 @stassats Don't write relations at read-time, store them on disk.
authored
471 (write-list-of-objects list stream))
472 (t
473 (write-n-bytes #.(type-code 'cons) 1 stream)
f19bc56 @stassats Split complex array into complex vector.
authored
474 (write-cons list stream))))
475
476 (defun write-cons (cons stream)
477 (loop for cdr = cons then (cdr cdr)
478 do
479 (cond ((consp cdr)
480 (write-object (car cdr) stream))
481 (t
482 (write-n-bytes +end+ 1 stream)
483 (write-object cdr stream)
484 (return)))))
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
485
486 (defreader cons (stream)
585b9e9 @stassats Improper cons support.
authored
487 (let ((first-cons (list (read-next-object stream))))
488 (loop for previous-cons = first-cons then new-cons
489 for car = (let ((id (read-n-bytes 1 stream)))
490 (cond ((eq id +end+)
c24219e @stassats Change the way slots are identified, saving disk space.
authored
491 (setf (cdr previous-cons)
492 (read-next-object stream))
585b9e9 @stassats Improper cons support.
authored
493 (return))
494 ((call-reader id stream))))
495 for new-cons = (list car)
496 do (setf (cdr previous-cons) new-cons))
497 first-cons))
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
498
ca92680 @stassats Don't write relations at read-time, store them on disk.
authored
499 ;;; list-of-objects
500
501 (defun list-of-objects-p (list)
502 (loop for i in list
503 always (typep i 'standard-object)))
504
505 (defun write-list-of-objects (list stream)
506 (write-n-bytes #.(type-code 'list-of-objects) 1 stream)
507 (write-n-bytes (length list) +sequence-length+ stream)
508 (dolist (object list)
509 (write-n-bytes (id object) +id-length+ stream)))
510
511 (defreader list-of-objects (stream)
512 (loop repeat (read-n-bytes +sequence-length+ stream)
513 for id = (read-n-bytes +id-length+ stream)
514 collect (get-instance id)))
515
f19bc56 @stassats Split complex array into complex vector.
authored
516 ;;; vector
517
518 (declaim (inline bit-test))
519 (defun bit-test (byte index)
c24219e @stassats Change the way slots are identified, saving disk space.
authored
520 (declare (type (unsigned-byte 32) byte)
521 (type (integer 0 31) index))
f19bc56 @stassats Split complex array into complex vector.
authored
522 (ldb-test (byte 1 index) byte))
523
524 (declaim (inline read-fill-pointer))
525 (defun read-fill-pointer (byte stream)
526 (declare (type (unsigned-byte 8) byte))
527 (and (bit-test byte 0)
528 (read-n-bytes +vector-length+ stream)))
92a4f44 @stassats Add more data types.
authored
529
530 (defmethod write-object ((vector vector) stream)
531 (typecase vector
532 (simple-vector
533 (write-simple-vector vector stream))
534 (t
f19bc56 @stassats Split complex array into complex vector.
authored
535 (write-vector vector stream))))
536
537 (defun write-vector (vector stream)
538 (write-n-bytes #.(type-code 'vector) 1 stream)
539 (let ((byte 0)
540 (fp (array-has-fill-pointer-p vector))
541 (type (array-element-type vector)))
542 (declare (type (unsigned-byte 8) byte))
543 (when fp
544 (setf byte 1))
545 (when (adjustable-array-p vector)
546 (setf (ldb (byte 1 1) byte) 1))
547 (when (eq type t)
548 (setf (ldb (byte 1 2) byte) 1))
549 (write-n-bytes byte 1 stream)
550 (when fp
551 (write-n-bytes (fill-pointer vector) +vector-length+ stream))
552 (unless (eq type t)
553 (write-object (array-element-type vector) stream))
554 (write-n-bytes (length vector) +vector-length+ stream)
555 (loop for i below (length vector)
556 do (write-object (aref vector i) stream))))
557
558 (defreader vector (stream)
559 (let* ((byte (read-n-bytes 1 stream))
560 (fill-pointer (read-fill-pointer byte stream))
561 (length (read-n-bytes +vector-length+ stream))
562 (vector (make-array length
563 :fill-pointer fill-pointer
564 :element-type (if (bit-test byte 2)
565 t
566 (read-next-object stream))
567 :adjustable (bit-test byte 1))))
568 (loop for i below length
569 do (setf (aref vector i) (read-next-object stream)))
570 vector))
571
572 ;;; Simple-vector
92a4f44 @stassats Add more data types.
authored
573
574 (defun write-simple-vector (vector stream)
575 (declare (simple-vector vector))
576 (write-n-bytes #.(type-code 'simple-vector) 1 stream)
577 (write-n-bytes (length vector) +sequence-length+ stream)
578 (loop for elt across vector
579 do (write-object elt stream)))
580
581 (defreader simple-vector (stream)
582 (let ((vector (make-array (read-n-bytes +sequence-length+ stream))))
583 (loop for i below (length vector)
584 do (setf (svref vector i) (read-next-object stream)))
585 vector))
586
9065dad @stassats Add float and complex types.
authored
587 ;;; Array
92a4f44 @stassats Add more data types.
authored
588
589 (defmethod write-object ((array array) stream)
590 (write-n-bytes #.(type-code 'array) 1 stream)
84ba65f @stassats Pack information about non-simple arrays into a single bit.
authored
591 (let ((byte 0)
592 (type (array-element-type array)))
593 (declare (type (unsigned-byte 8) byte))
594 (when (adjustable-array-p array)
f19bc56 @stassats Split complex array into complex vector.
authored
595 (setf (ldb (byte 1 0) byte) 1))
84ba65f @stassats Pack information about non-simple arrays into a single bit.
authored
596 (when (eq type t)
f19bc56 @stassats Split complex array into complex vector.
authored
597 (setf (ldb (byte 1 1) byte) 1))
84ba65f @stassats Pack information about non-simple arrays into a single bit.
authored
598 (write-n-bytes byte 1 stream)
599 (unless (eq type t)
600 (write-object (array-element-type array) stream))
f19bc56 @stassats Split complex array into complex vector.
authored
601 (write-cons (array-dimensions array) stream)
84ba65f @stassats Pack information about non-simple arrays into a single bit.
authored
602 (loop for i below (array-total-size array)
603 do (write-object (row-major-aref array i) stream))))
92a4f44 @stassats Add more data types.
authored
604
605 (defreader array (stream)
84ba65f @stassats Pack information about non-simple arrays into a single bit.
authored
606 (let* ((byte (read-n-bytes 1 stream))
f19bc56 @stassats Split complex array into complex vector.
authored
607 (array (make-array (cons-reader stream)
608 :element-type (if (bit-test byte 1)
84ba65f @stassats Pack information about non-simple arrays into a single bit.
authored
609 t
610 (read-next-object stream))
f19bc56 @stassats Split complex array into complex vector.
authored
611 :adjustable (bit-test byte 0))))
92a4f44 @stassats Add more data types.
authored
612 (loop for i below (array-total-size array)
613 do (setf (row-major-aref array i) (read-next-object stream)))
614 array))
615
9065dad @stassats Add float and complex types.
authored
616 ;;; Hash-table
92a4f44 @stassats Add more data types.
authored
617
618 (defvar *hash-table-tests* #(eql equal equalp eq))
619 (declaim (simple-vector *hash-table-tests*))
620
621 (defun check-hash-table-test (hash-table)
622 (let* ((test (hash-table-test hash-table))
623 (test-id (position test *hash-table-tests*)))
624 (unless test-id
625 (error "Only standard hashtable tests are supported, ~a has ~a"
626 hash-table test))
627 test-id))
628
629 (defmethod write-object ((hash-table hash-table) stream)
630 (write-n-bytes #.(type-code 'hash-table) 1 stream)
631 (write-n-bytes (check-hash-table-test hash-table) 1 stream)
632 (write-n-bytes (hash-table-size hash-table) +hash-table-length+ stream)
633 (loop for key being the hash-keys of hash-table
634 using (hash-value value)
635 do
636 (write-object key stream)
637 (write-object value stream))
638 (write-n-bytes +end+ 1 stream))
639
640 (defreader hash-table (stream)
641 (let* ((test (svref *hash-table-tests* (read-n-bytes 1 stream)))
642 (size (read-n-bytes +hash-table-length+ stream))
643 (table (make-hash-table :test test :size size)))
644 (loop for id = (read-n-bytes 1 stream)
645 until (eq id +end+)
646 do (setf (gethash (call-reader id stream) table)
647 (read-next-object stream)))
648 table))
649
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
650 ;;; storable-class
651
652 (defmethod write-object ((class storable-class) stream)
653 (write-n-bytes #.(type-code 'storable-class) 1 stream)
654 (write-object (class-name class) stream)
1aa3979 @stassats disk.lisp: Check for finalization in more places.
authored
655 (unless (class-finalized-p class)
50bcdca @stassats slightly optimize call-reader.
authored
656 (finalize-inheritance class))
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
657 (let ((slots (slots-to-store class)))
658 (write-n-bytes (length slots) +sequence-length+ stream)
659 (loop for slot across slots
660 do (write-object (slot-definition-name slot)
661 stream))))
662
663 (defreader storable-class (stream)
ace1e4b @stassats Remove class cache, it's not used anywhere.
authored
664 (let ((class (find-class (read-next-object stream))))
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
665 (unless (class-finalized-p class)
666 (finalize-inheritance class))
667 (setf (objects-of-class class) nil)
668 (let* ((length (read-n-bytes +sequence-length+ stream))
669 (vector (make-array length)))
670 (loop for i below length
41dd636 @stassats Better handling of slot redefinition.
authored
671 for slot-d =
672 (slot-effective-definition class (read-next-object stream))
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
673 do (setf (aref vector i)
41dd636 @stassats Better handling of slot redefinition.
authored
674 (cons (slot-definition-location slot-d)
675 (slot-definition-initform slot-d))))
676 (setf (slot-locations-and-initforms-read class) vector))
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
677 class))
678
679 ;;; identifiable
680
681 (defmethod write-object ((object identifiable) stream)
682 (write-n-bytes #.(type-code 'identifiable) 1 stream)
40c7c78 @stassats Preallocate objects at the very beginning.
authored
683 (write-n-bytes (id object) +id-length+ stream))
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
684
e1ba1f0 @stassats interlink-slots: Speed up and reduce consing.
authored
685 (declaim (inline get-instance))
686 (defun get-instance (id)
19797e1 @stassats Store index array in *indexes*, not in an index slot of *storage*.
authored
687 (aref *indexes* id))
e1ba1f0 @stassats interlink-slots: Speed up and reduce consing.
authored
688
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
689 (defreader identifiable (stream)
96f2b37 @stassats More micro-optimizations.
authored
690 (get-instance (read-n-bytes +id-length+ stream)))
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
691
692 ;;; standard-object
0ec5127 @stassats Don't write object ids to disk.
authored
693
9b74fa4 @stassats Declaim make-slot-map inline.
authored
694 (declaim (inline make-slot-map))
c24219e @stassats Change the way slots are identified, saving disk space.
authored
695 (defun make-slot-map (object slots)
068c72d @stassats Micro-optimize writing.
authored
696 (declare (simple-vector slots))
c24219e @stassats Change the way slots are identified, saving disk space.
authored
697 (let ((map 0))
698 (declare (type (unsigned-byte 32) map))
699 (loop for i from (1- (length slots)) downto 0
700 for (location . initform) = (aref slots i)
701 for value = (standard-instance-access object location)
702 do (setf map
703 (if (eql value initform)
704 (the (unsigned-byte 32) (ash map 1))
705 (the (unsigned-byte 32) (+ map map 1)))))
706 map))
707
708 (defun write-standard-object (object slots bytes-for-slots stream)
709 (declare (simple-vector slots))
710 (let ((map (make-slot-map object slots)))
711 (declare (type (unsigned-byte 32) map))
712 (write-n-bytes map bytes-for-slots stream)
713 (loop for slot-id of-type (integer 0 32) from 0
714 while (plusp map)
715 when (oddp map)
716 do
717 (write-object
718 (standard-instance-access object (car (aref slots slot-id)))
719 stream)
720 do (setf map (ash map -1)))))
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
721
c24219e @stassats Change the way slots are identified, saving disk space.
authored
722 (defun read-standard-object (object slots bytes-for-slots stream)
0ec5127 @stassats Don't write object ids to disk.
authored
723 (declare (simple-vector slots))
c24219e @stassats Change the way slots are identified, saving disk space.
authored
724 (let ((map (read-n-bytes bytes-for-slots stream)))
725 (declare (type (unsigned-byte 32) map))
726 (loop for slot-id of-type (integer 0 32) from 0
727 while (plusp map)
728 when (oddp map)
729 do (setf (standard-instance-access object
730 (car (aref slots slot-id)))
731 (read-next-object stream))
732 do (setf map (ash map -1)))))
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
733
734 ;;;
735
40c7c78 @stassats Preallocate objects at the very beginning.
authored
736 #+sbcl (declaim (inline fast-allocate-instance))
737 #+sbcl
738 (defun fast-allocate-instance (wrapper initforms)
739 (declare (simple-vector initforms))
740 (let ((instance (sb-pcl::%make-standard-instance
8d832ed @stassats Clean up.
authored
741 (copy-seq initforms) (sb-pcl::get-instance-hash-code))))
40c7c78 @stassats Preallocate objects at the very beginning.
authored
742 (setf (sb-pcl::std-instance-wrapper instance)
8d832ed @stassats Clean up.
authored
743 wrapper)
40c7c78 @stassats Preallocate objects at the very beginning.
authored
744 instance))
745
746 #+sbcl
747 (defun preallocate-objects (array info)
c11f3e6 @stassats Micro-optimize preallocate-objects on SBCL.
authored
748 (declare (simple-vector array)
749 (optimize speed))
40c7c78 @stassats Preallocate objects at the very beginning.
authored
750 (loop with index = 0
8d832ed @stassats Clean up.
authored
751 for (class . length) in info
752 for initforms = (class-initforms class)
753 for wrapper = (sb-pcl::class-wrapper class)
4456821 @stassats Set objects-of-class while preallocating objects, that way it ensures
authored
754 do
755 (setf (objects-of-class class)
c11f3e6 @stassats Micro-optimize preallocate-objects on SBCL.
authored
756 (loop repeat (the fixnum length)
4456821 @stassats Set objects-of-class while preallocating objects, that way it ensures
authored
757 for instance = (fast-allocate-instance wrapper initforms)
758 collect instance
759 do
760 (setf (aref array index) instance)
761 (incf index)))))
40c7c78 @stassats Preallocate objects at the very beginning.
authored
762
763 #-sbcl
0179081 @stassats Improve bignum reading and writing.
authored
764 (defun initialize-slots (instance slot-cache)
71abee5 @stassats Better symbols format.
authored
765 (loop for (location . value) across slot-cache
0179081 @stassats Improve bignum reading and writing.
authored
766 do (setf (standard-instance-access instance location)
767 value))
768 instance)
769
770 #-sbcl
40c7c78 @stassats Preallocate objects at the very beginning.
authored
771 (defun preallocate-objects (array info)
772 (declare (simple-array array))
773 (loop with index = 0
8d832ed @stassats Clean up.
authored
774 for (class . length) in info
775 for slot-cache = (all-slot-locations-and-initforms class)
776 do
4456821 @stassats Set objects-of-class while preallocating objects, that way it ensures
authored
777 (setf (objects-of-class class)
778 (loop repeat length
779 for instance = (allocate-instance class)
780 collect instance
781 do (initialize-slots instance slot-cache)
782 (setf (aref array index) instance)
783 (incf index)))))
40c7c78 @stassats Preallocate objects at the very beginning.
authored
784
785 (defun prepare-classes (stream)
112a78b @stassats Don't write the total number of objects to disk.
authored
786 (loop repeat (read-n-bytes +sequence-length+ stream)
787 for class = (read-next-object stream)
788 for length = (read-n-bytes +id-length+ stream)
789 collect (cons class length) into info
790 sum length into array-length
791 finally
0ec5127 @stassats Don't write object ids to disk.
authored
792 (let ((array (make-array array-length)))
793 (preallocate-objects array info)
794 (return (values array info)))))
40c7c78 @stassats Preallocate objects at the very beginning.
authored
795
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
796 (defun read-file (file)
797 (with-io-file (stream file)
0ec5127 @stassats Don't write object ids to disk.
authored
798 (multiple-value-bind (array info) (prepare-classes stream)
799 (declare (simple-vector array))
0b116a0 @stassats Fix *indexes* being unbound.
authored
800 (let ((*indexes* array))
801 (loop with i = 0
802 for (class . n) of-type (t . fixnum) in info
803 for slots = (slot-locations-and-initforms-read class)
804 for bytes-for-slots = (number-of-bytes-for-slots class)
805 do
806 (loop repeat n
807 for instance = (aref array i)
808 do
809 (incf i)
810 (read-standard-object instance slots bytes-for-slots
811 stream)))))))
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
812
813 (defun load-data (storage &optional file)
0b116a0 @stassats Fix *indexes* being unbound.
authored
814 (let ((*storage* storage))
f65dd3a @stassats New way of storing symbols.
authored
815 (with-reading-packages
8d832ed @stassats Clean up.
authored
816 (read-file (or file (storage-file *storage*))))
0f2723f @stassats Add `modified' slot to `storage'.
authored
817 (interlink-all-objects-first-time)
818 (setf (modified storage) nil)))
8ebf1d1 @stassats Move on-disk storage code into a separate file.
authored
819
820 (defun save-data (storage &optional file)
8d832ed @stassats Clean up.
authored
821 (let ((*storage* storage))
1ecd518 @stassats Use an array for indexing, instead of a hash-table.
authored
822 (when (storage-data storage)
f65dd3a @stassats New way of storing symbols.
authored
823 (with-writing-packages
802fd25 @stassats save-data: Put with-packages at the right place.
authored
824 (with-io-file (stream (or file (storage-file storage))
d1c604b @stassats Rewrite SBCL I/O without using mmap(2).
authored
825 :direction :output)
0f2723f @stassats Add `modified' slot to `storage'.
authored
826 (dump-data stream)))
827 (setf (modified storage) nil))))
Something went wrong with that request. Please try again.