disk.lisp 19.3 KB
Newer Older
1
2
3
4
5
;;; -*- Mode: Lisp -*-

(in-package #:storage)

(eval-when (:compile-toplevel :load-toplevel :execute)
Stas Boukarev's avatar
Stas Boukarev committed
6
7
  (defparameter *codes*
    #(ascii-string
Stas Boukarev's avatar
Stas Boukarev committed
8
9
10
11
      identifiable
      cons
      string
      null
Stas Boukarev's avatar
Stas Boukarev committed
12
13
      storable-class
      standard-object
Stas Boukarev's avatar
Stas Boukarev committed
14
15
16
17
18
19
20
      fixnum
      bignum
      ratio
      list-of-objects
      symbol
      intern-package-and-symbol
      intern-symbol)))
21
22
23
24
25
26
27
28
29
30
31
32

(declaim (type simple-vector *codes*))

(defvar *statistics* ())
(defun collect-stats (code)
  (let* ((type (aref *codes* code))
         (cons (assoc type *statistics*)))
    (if cons
        (incf (cdr cons))
        (push (cons type 1) *statistics*))
    type))

33
34
35
(defvar *indexes* #())
(declaim (simple-vector *indexes*))

36
37
38
39
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun type-code (type)
    (position type *codes*)))

40
41
(defparameter *readers* (make-array (length *codes*)))
(declaim (type (simple-array function (*)) *readers*))
42
43
44
45
46
47

(defmacro defreader (type (stream) &body body)
  (let ((name (intern (format nil "~a-~a" type '#:reader))))
    `(progn
       (defun ,name (,stream)
         ,@body)
48
       (setf (aref *readers* ,(type-code type))
49
50
             #',name))))

Stas Boukarev's avatar
Stas Boukarev committed
51
(declaim (inline call-reader))
52
(defun call-reader (code stream)
Stas Boukarev's avatar
Stas Boukarev committed
53
  ;; (collect-stats code)
54
  (funcall (aref *readers* code) stream))
55
56
57
58
59

;;;

(defconstant +sequence-length+ 2)
(eval-when (:compile-toplevel :load-toplevel :execute)
60
  (defconstant +fixnum-length+ 4))
61
(defconstant +char-length+ 2)
62
(defconstant +id-length+ 3)
63

64
(defconstant +end+ 255)
65
66
67
68

(defconstant +ascii-char-limit+ (code-char 128))

(deftype ascii-string ()
69
70
  '(or 
    #+sb-unicode simple-base-string ; on #-sb-unicode the limit is 255
Stas Boukarev's avatar
Stas Boukarev committed
71
72
    (and simple-string
     (satisfies ascii-string-p))))
73
74

(defun ascii-string-p (string)
Stas Boukarev's avatar
Stas Boukarev committed
75
76
77
  (declare (simple-string string))
  (loop for char across string
        always (char< char +ascii-char-limit+)))
78

Stas Boukarev's avatar
Stas Boukarev committed
79
80
81
(deftype storage-fixnum ()
  `(signed-byte ,(* +fixnum-length+ 8)))

82
83
84
85
86
87
88
89
90
;;;

(defun slot-effective-definition (class slot-name)
  (find slot-name (class-slots class) :key #'slot-definition-name))

(defgeneric write-object (object stream))
(defgeneric object-size (object))

(defun measure-size ()
91
  (let ((result +sequence-length+)) ;; number of classes
92
    (map-data (lambda (class objects)
93
                (when objects
94
95
96
97
                  (incf result (object-size class))
                  (dolist (object objects)
                    (incf result
                          (standard-object-size object))))))
Stas Boukarev's avatar
Stas Boukarev committed
98
    (setf (fill-pointer *packages*) 0)
99
100
    result))

101
102
103
104
105
106
107
108
(defun assign-ids ()
  (let ((last-id 0))
    (declare (fixnum last-id))
    (map-data
     (lambda (class objects)
       (declare (ignore class))
       (dolist (object objects)
         (setf (id object) last-id)
109
         (incf last-id))))))
110

111
(defun number-of-non-empty-classes (storage)
112
113
  (count-if #'objects-of-class
            (storage-data storage)))
114

115
(defun write-classes-info (stream)
116
  (assign-ids)
117
  (write-n-bytes (number-of-non-empty-classes *storage*)
118
		 +sequence-length+ stream)
119
  (map-data (lambda (class objects)
120
121
122
123
              (when objects
                (write-object class stream)
                (write-n-bytes (length objects)
                               +id-length+ stream)))))
124
125
126

(defun dump-data (stream)
  (write-classes-info stream)
127
128
129
130
131
  (map-data (lambda (class objects)
              (declare (ignore class))
              (dolist (object objects)
                (write-standard-object object stream)))))

132
(declaim (inline read-next-object))
133
134
135
(defun read-next-object (stream)
  (call-reader (read-n-bytes 1 stream) stream))

136
137
138
139
140
141
142
143
144
145
146
147
;;; NIL

(defmethod object-size ((object null))
  1)

(defmethod write-object ((object null) stream)
  (write-n-bytes #.(type-code 'null) 1 stream))

(defreader null (stream)
  (declare (ignore stream))
  nil)

148
149
;;; Symbol

Stas Boukarev's avatar
Stas Boukarev committed
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
(defvar *packages* #())
(declaim (vector *packages*))

(defun make-s-packages ()
  (make-array 10 :adjustable t :fill-pointer 0))

(defun make-s-package (package)
  (let ((symbols (make-array 100 :adjustable t :fill-pointer 0)))
    (values (vector-push-extend (cons package symbols) *packages*)
            symbols
            t)))

(defun find-s-package (package)
  (loop for i below (length *packages*)
        for (stored-package . symbols) = (aref *packages* i)
        when (eq package stored-package)
        return (values i symbols)
        finally (return (make-s-package package))))

(defun s-intern (symbol)
  (multiple-value-bind (package-id symbols new-package)
      (find-s-package (symbol-package symbol))
    (let* ((existing (and (not new-package)
                          (position symbol symbols)))
           (symbol-id (or existing
                          (vector-push-extend symbol symbols))))
      (values package-id symbol-id new-package (not existing)))))

(defun s-intern-existing (symbol symbols)
  (vector-push-extend symbol symbols))

(defmethod object-size ((symbol symbol))
  (+ 1 ;; type
     (multiple-value-bind (package-id symbol-id
                           new-package new-symbol) (s-intern symbol)
       (declare (ignore package-id symbol-id))
       (cond ((and new-package new-symbol)
              (+ (object-size (package-name (symbol-package symbol)))
                 (object-size (symbol-name symbol))))
             (new-symbol
              (+ +sequence-length+
                 (object-size (symbol-name symbol))))
             (t
              (+ +sequence-length+
                 +sequence-length+))))))

(defmethod write-object ((symbol symbol) stream)
  (multiple-value-bind (package-id symbol-id
                        new-package new-symbol) (s-intern symbol)
    (cond ((and new-package new-symbol)
           (write-n-bytes #.(type-code 'intern-package-and-symbol) 1 stream)
           (write-object (package-name (symbol-package symbol)) stream)
           (write-object (symbol-name symbol) stream))
          (new-symbol
           (write-n-bytes #.(type-code 'intern-symbol) 1 stream)
           (write-n-bytes package-id +sequence-length+ stream)
           (write-object (symbol-name symbol) stream))
          (t
           (write-n-bytes #.(type-code 'symbol) 1 stream)
           (write-n-bytes package-id +sequence-length+ stream)
           (write-n-bytes symbol-id +sequence-length+ stream)))))
211
212

(defreader symbol (stream)
Stas Boukarev's avatar
Stas Boukarev committed
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
  (let* ((package-id (read-n-bytes +sequence-length+ stream))
         (symbol-id (read-n-bytes +sequence-length+ stream))
         (package (or (aref *packages* package-id)
                      (error "Package with id ~a not found" package-id)))
         (symbol (aref (cdr package) symbol-id)))
    (or symbol
        (error "Symbol with id ~a in package ~a not found"
               symbol-id (car package)))))

(defreader intern-package-and-symbol (stream)
  (let* ((package-name (read-next-object stream))
         (symbol-name (read-next-object stream))
         (package (or (find-package package-name)
                      (error "Package ~a not found" package-name)))
         (symbol (intern symbol-name package))
         (s-package (nth-value 1 (make-s-package package))))
    (s-intern-existing symbol s-package)
    symbol))

(defreader intern-symbol (stream)
  (let* ((package-id (read-n-bytes +sequence-length+ stream))
         (symbol-name (read-next-object stream))
         (package (or (aref *packages* package-id)
                      (error "Package with id ~a for symbol ~a not found"
                             package-id symbol-name)))
         (symbol (intern symbol-name (car package))))
    (s-intern-existing symbol (cdr package))
    symbol))
241
242
243
244

;;; Integer

(defmethod object-size ((object integer))
245
246
  (+ 1 ;; tag
     (typecase object
Stas Boukarev's avatar
Stas Boukarev committed
247
       (storage-fixnum +fixnum-length+)
248
249
       (t (+ 1 ;; sign
             1 ;; size
250
             (* (ceiling (integer-length (abs object))
Stas Boukarev's avatar
Stas Boukarev committed
251
252
253
254
255
256
257
258
                         (* +fixnum-length+ 8))
                +fixnum-length+))))))

(declaim (inline sign))
(defun sign (n)
  (if (minusp n)
      1
      0))
259
260

(defun write-fixnum (n stream)
Stas Boukarev's avatar
Stas Boukarev committed
261
  (declare (storage-fixnum n))
262
  (write-n-bytes #.(type-code 'fixnum) 1 stream)
263
  (write-n-signed-bytes n +fixnum-length+ stream))
264
265

(defun write-bignum (n stream)
Stas Boukarev's avatar
Stas Boukarev committed
266
  (declare ((and integer (not storage-fixnum)) n))
267
  (write-n-bytes #.(type-code 'bignum) 1 stream)
Stas Boukarev's avatar
Stas Boukarev committed
268
  (write-n-bytes (sign n) 1 stream)
269
270
271
  (let* ((fixnum-bits (* +fixnum-length+ 8))
         (n (abs n))
         (size (ceiling (integer-length n) fixnum-bits)))
272
    (write-n-bytes size 1 stream)
273
    (loop for position by fixnum-bits below (* size fixnum-bits)
Stas Boukarev's avatar
Stas Boukarev committed
274
          do
275
          (write-n-bytes (ldb (byte fixnum-bits position) n)
276
                         +fixnum-length+ stream))))
277
278

(defmethod write-object ((object integer) stream)
279
  (typecase object
Stas Boukarev's avatar
Stas Boukarev committed
280
    (storage-fixnum
Stas Boukarev's avatar
Stas Boukarev committed
281
     (write-fixnum object stream))
282
283
    (t (write-bignum object stream))))

284
285
286
287
288
289
(declaim (inline read-sign))
(defun read-sign (stream)
  (if (plusp (read-n-bytes 1 stream))
      -1
      1))

290
(defreader bignum (stream)
291
292
293
294
295
296
297
298
299
  (let ((fixnum-bits (* +fixnum-length+ 8))
        (sign (read-sign stream))
        (size (read-n-bytes 1 stream))
        (integer 0))
    (loop for position by fixnum-bits below (* size fixnum-bits)
          do
          (setf (ldb (byte fixnum-bits position) integer)
                (read-n-bytes +fixnum-length+ stream)))
    (* sign integer)))
300
301

(defreader fixnum (stream)
302
  (read-n-signed-bytes +fixnum-length+ stream))
303
304
305
306
307
308
309
310
311
312
313
314

;;; Ratio

(defmethod object-size ((object ratio))
  (+ 1
     (object-size (numerator object))
     (object-size (denominator object))))

(defmethod write-object ((object ratio) stream)
  (write-n-bytes #.(type-code 'ratio) 1 stream)
  (write-object (numerator object) stream)
  (write-object (denominator object) stream))
315

316
317
318
(defreader ratio (stream)
  (/ (read-next-object stream)
     (read-next-object stream)))
319
320
321
322
323
324
325
326
327
328
329
330

;;; Strings

(defmethod object-size ((string string))
  (+ 1
     +sequence-length+
     (etypecase string
       (ascii-string (length string))
       (string (* (length string)
                  +char-length+)))))

(defun write-ascii-string (string stream)
331
  (declare (simple-string string))
332
333
334
335
  (loop for char across string
        do (write-n-bytes (char-code char) 1 stream)))

(defun write-multibyte-string (string stream)
336
  (declare (simple-string string))
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
  (loop for char across string
        do (write-n-bytes (char-code char) +char-length+ stream)))

(defmethod write-object ((string string) stream)
  (etypecase string
    #+sb-unicode
    (simple-base-string
     (write-n-bytes #.(type-code 'ascii-string) 1 stream)
     (write-n-bytes (length string) +sequence-length+ stream)
     (write-ascii-string-optimized (length string) string stream))
    (ascii-string
     (write-n-bytes #.(type-code 'ascii-string) 1 stream)
     (write-n-bytes (length string) +sequence-length+ stream)
     (write-ascii-string string stream))
    (string
     (write-n-bytes #.(type-code 'string) 1 stream)
     (write-n-bytes (length string) +sequence-length+ stream)
     (write-multibyte-string string stream))))

Stas Boukarev's avatar
Stas Boukarev committed
356
(declaim (inline read-ascii-string))
357
358
359
360
(defun read-ascii-string (length stream)
  (let ((string (make-string length :element-type 'base-char)))
    #-sbcl
    (loop for i below length
Stas Boukarev's avatar
Stas Boukarev committed
361
          do (setf (schar string i)
362
363
364
365
366
367
368
369
370
371
372
373
                   (code-char (read-n-bytes 1 stream))))
    #+(and sbcl (or x86 x86-64))
    (read-ascii-string-optimized length string stream)
    string))

(defreader ascii-string (stream)
  (read-ascii-string (read-n-bytes +sequence-length+ stream) stream))

(defreader string (stream)
  (let* ((length (read-n-bytes +sequence-length+ stream))
         (string (make-string length :element-type 'character)))
    (loop for i below length
Stas Boukarev's avatar
Stas Boukarev committed
374
          do (setf (schar string i)
375
376
377
378
379
380
                   (code-char (read-n-bytes +char-length+ stream))))
    string))

;;; cons

(defmethod object-size ((list cons))
381
  (let ((count (+ 1 1))) ;; type + +end+
382
383
384
385
386
387
388
389
    (cond ((list-of-objects-p list)
           (incf count (+ (* (length list)
                             +id-length+)
                          (1- +sequence-length+)))) ;; sans +end+
          (t
           (mapc (lambda (x)
                   (incf count (object-size x)))
                 list)))
390
391
392
    count))

(defmethod write-object ((list cons) stream)
393
394
395
396
397
398
399
  (cond ((list-of-objects-p list)
         (write-list-of-objects list stream))
        (t
         (write-n-bytes #.(type-code 'cons) 1 stream)
         (dolist (item list)
           (write-object item stream))
         (write-n-bytes +end+ 1 stream))))
400
401

(defreader cons (stream)
402
403
404
  (loop for code = (read-n-bytes 1 stream)
        until (= code +end+)
        collect (call-reader code stream)))
405

406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
;;; list-of-objects

(defun list-of-objects-p (list)
  (loop for i in list
        always (typep i 'standard-object)))

(defun write-list-of-objects (list stream)
  (write-n-bytes #.(type-code 'list-of-objects) 1 stream)
  (write-n-bytes (length list) +sequence-length+ stream)
  (dolist (object list)
    (write-n-bytes (id object) +id-length+ stream)))

(defreader list-of-objects (stream)
  (loop repeat (read-n-bytes +sequence-length+ stream)
        for id = (read-n-bytes +id-length+ stream)
        collect (get-instance id)))

423
424
425
;;; storable-class

(defmethod object-size ((class storable-class))
426
427
  (unless (class-finalized-p class)
    (finalize-inheritance class))
428
429
430
431
432
  (+ 1 ;; type
     (object-size (class-name class))
     +sequence-length+ ;; list length
     (reduce #'+ (slots-to-store class)
             :key (lambda (x)
433
434
                    (object-size (slot-definition-name x))))
     +id-length+)) ;; size of objects
435
436
437
438

(defmethod write-object ((class storable-class) stream)
  (write-n-bytes #.(type-code 'storable-class) 1 stream)
  (write-object (class-name class) stream)
439
  (unless (class-finalized-p class)
Stas Boukarev's avatar
Stas Boukarev committed
440
    (finalize-inheritance class))
441
442
443
444
445
446
447
  (let ((slots (slots-to-store class)))
    (write-n-bytes (length slots) +sequence-length+ stream)
    (loop for slot across slots
          do (write-object (slot-definition-name slot)
                           stream))))

(defreader storable-class (stream)
448
  (let ((class (find-class (read-next-object stream))))
449
450
451
452
453
454
    (unless (class-finalized-p class)
      (finalize-inheritance class))
    (setf (objects-of-class class) nil)
    (let* ((length (read-n-bytes +sequence-length+ stream))
           (vector (make-array length)))
      (loop for i below length
455
456
            for slot-d =
            (slot-effective-definition class (read-next-object stream))
457
            do (setf (aref vector i)
458
459
460
                     (cons (slot-definition-location slot-d)
                           (slot-definition-initform slot-d))))
      (setf (slot-locations-and-initforms-read class) vector))
461
462
463
464
465
    class))

;;; identifiable

(defmethod object-size ((object identifiable))
466
  (+ 1 ;; type
467
     +id-length+))
468
469
470

(defmethod write-object ((object identifiable) stream)
  (write-n-bytes #.(type-code 'identifiable) 1 stream)
471
  (write-n-bytes (id object) +id-length+ stream))
472

473
474
(declaim (inline get-instance))
(defun get-instance (id)
475
  (aref *indexes* id))
476

477
(defreader identifiable (stream)
Stas Boukarev's avatar
Stas Boukarev committed
478
  (get-instance (read-n-bytes +id-length+ stream)))
479
480
481
482

;;; standard-object

(defun standard-object-size (object)
483
  (let ((slots (slot-locations-and-initforms (class-of object))))
484
    (declare (simple-vector slots))
485
    (+ 1           ;; data type
486
       +id-length+ ;; id
487
       (loop for (location . initform) across slots
488
489
490
             sum (let ((value (standard-instance-access object
                                                        location)))
                   (if (eql value initform)
491
492
493
494
495
496
497
498
499
                       0
                       (+ 1 ;; slot id
                          (object-size value)))))
       1))) ;; end-of-slots

;;; Can't use write-object method, because it would conflict with
;;; writing a pointer to a standard object
(defun write-standard-object (object stream)
  (write-n-bytes #.(type-code 'standard-object) 1 stream)
500
  (let* ((class (class-of object))
501
         (slots (slot-locations-and-initforms class)))
502
    (declare (simple-vector slots))
503
    (write-n-bytes (id object) +id-length+ stream)
504
505
    (loop for id below (length slots)
          for (location . initform) = (aref slots id)
506
507
          for value = (standard-instance-access object location)
          unless (eql value initform)
508
          do
509
          (write-n-bytes id 1 stream)
510
          (write-object value stream))
511
    (write-n-bytes +end+ 1 stream)))
512
513

(defreader standard-object (stream)
514
515
516
  (let* ((instance (get-instance
		    (read-n-bytes +id-length+ stream)))
	 (class (class-of instance))
517
         (slots (slot-locations-and-initforms-read class)))
518
    (declare (simple-vector slots))
519
    (loop for slot-id = (read-n-bytes 1 stream)
520
          until (= slot-id +end+)
521
522
          do (setf (standard-instance-access instance
                                             (car (aref slots slot-id)))
523
524
525
526
527
                   (read-next-object stream)))
    instance))

;;;

528
529
530
531
532
533
534
535
536
537
538
539
540
#+sbcl (declaim (inline fast-allocate-instance))

#+sbcl
(defun fast-allocate-instance (wrapper initforms)
  (declare (simple-vector initforms))
  (let ((instance (sb-pcl::%make-standard-instance
		   (copy-seq initforms) (sb-pcl::get-instance-hash-code))))
    (setf (sb-pcl::std-instance-wrapper instance)
	  wrapper)
    instance))

#+sbcl
(defun preallocate-objects (array info)
541
542
  (declare (simple-vector array)
           (optimize speed))
543
544
545
546
  (loop with index = 0
	for (class . length) in info
	for initforms = (class-initforms class)
	for wrapper = (sb-pcl::class-wrapper class)
547
548
        do
        (setf (objects-of-class class)
549
              (loop repeat (the fixnum length)
550
551
552
553
554
                    for instance = (fast-allocate-instance wrapper initforms)
                    collect instance
                    do
                    (setf (aref array index) instance)
                    (incf index)))))
555

556
557
#-sbcl
(defun initialize-slots (instance slot-cache)
Stas Boukarev's avatar
Stas Boukarev committed
558
  (loop for (location . value) across slot-cache
559
560
561
562
        do (setf (standard-instance-access instance location)
                 value))
  instance)

563
564
565
566
567
#-sbcl
(defun preallocate-objects (array info)
  (declare (simple-array array))
  (loop with index = 0
	for (class . length) in info
568
	for slot-cache = (all-slot-locations-and-initforms class)
569
570
571
572
573
574
575
576
	do
        (setf (objects-of-class class)
              (loop repeat length
                    for instance = (allocate-instance class)
                    collect instance
                    do (initialize-slots instance slot-cache)
                       (setf (aref array index) instance)
                       (incf index)))))
577
578

(defun prepare-classes (stream)
579
580
581
582
583
584
585
  (loop repeat (read-n-bytes +sequence-length+ stream)
        for class = (read-next-object stream)
        for length = (read-n-bytes +id-length+ stream)
        collect (cons class length) into info
        sum length into array-length
        finally
        (preallocate-objects (setf *indexes* (make-array array-length)) info)))
586

587
588
(defun read-file (file)
  (with-io-file (stream file)
589
    (unwind-protect
590
591
592
	 (progn (prepare-classes stream)
		(loop until (stream-end-of-file-p stream)
		      do (read-next-object stream)))
593
      (setf *indexes* #()))))
594
595

(defun load-data (storage &optional file)
596
  (let ((*storage* storage)
Stas Boukarev's avatar
Stas Boukarev committed
597
598
        (*indexes* *indexes*)
        (*packages* (make-s-packages)))
599
    (clear-cashes)
600
601
    (read-file (or file (storage-file *storage*)))
    (interlink-all-objects-first-time)))
602
603

(defun save-data (storage &optional file)
Stas Boukarev's avatar
Stas Boukarev committed
604
605
  (let ((*storage* storage)
        (*packages* (make-s-packages)))
606
607
    (when (storage-data storage)
      (with-io-file (stream (or file (storage-file storage))
608
609
610
                            :direction :output
                            :size (measure-size))
        (dump-data stream)))))