├── .gitignore ├── src ├── rebuild-dispatch.lisp ├── example-extension.asd ├── end-action.lisp ├── features.lisp ├── example-extension-codespace.lisp ├── sbcl-utilities.lisp ├── sbcl-special-hash-tables.lisp ├── pathname.lisp ├── simple-vector.lisp ├── object-info.lisp ├── reference-count.lisp ├── actions.lisp ├── magic-numbers.lisp ├── hash-table.lisp ├── basic-codespace-codes.lisp ├── reference-coding.lisp ├── cl-binary-store-user.lisp ├── symbols.lisp ├── example-extension.lisp ├── unsigned-bytes.lisp ├── array.lisp ├── cl-binary-store.lisp ├── type-discrimination.lisp ├── cons.lisp ├── basic-codespace.lisp ├── sap-ref.lisp ├── user.lisp ├── referrers-and-fixup.lisp ├── numbers.lisp ├── objects.lisp └── storage.lisp ├── .github └── workflows │ ├── blarg.yml~ │ └── ci-workflow.yml ├── LICENSE ├── cl-binary-store.asd ├── benchmarks.lisp └── type-discrimination.md /.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl 2 | *.lisp~ 3 | *.asd~ 4 | -------------------------------------------------------------------------------- /src/rebuild-dispatch.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-binary-store) 2 | 3 | -------------------------------------------------------------------------------- /src/example-extension.asd: -------------------------------------------------------------------------------- 1 | (defsystem #:example-extension 2 | :depends-on (#:cl-binary-store) 3 | :components ((:file "example-extension") 4 | (:file "example-extension-codespace" :depends-on ("example-extension")))) 5 | -------------------------------------------------------------------------------- /src/end-action.lisp: -------------------------------------------------------------------------------- 1 | ;; An end marker, useful for cases when sending data over the network 2 | ;; or reading from raw memory. 3 | 4 | (in-package :cl-binary-store) 5 | 6 | (defstruct (end-marker (:include action (code +end-action-code+)))) 7 | 8 | (defmethod action ((code (eql +end-action-code+)) storage references restore-object) 9 | (values nil :end)) 10 | 11 | (defmethod store-action ((action end-marker) storage store-code)) 12 | -------------------------------------------------------------------------------- /src/features.lisp: -------------------------------------------------------------------------------- 1 | ;; To enable debugging execute the below line and recompile everything 2 | ;; (pushnew :dribble-cbs *features*) 3 | ;; (pushnew :debug-cbs *features*) 4 | ;; (pushnew :info-cbs *features*) 5 | ;; To disable debugging execute the below and recompile everything which can be done 6 | ;; by saving this file and quickload'ing the package again 7 | ;; (setf *features* (remove-if (lambda (x) (member x '(:dribble-cbs :debug-cbs :info-cbs))) *features*)) 8 | -------------------------------------------------------------------------------- /src/example-extension-codespace.lisp: -------------------------------------------------------------------------------- 1 | (in-package :example-extension) 2 | 3 | (define-codespace ("extension-codespace" +extension-codespace+ :inherits-from +basic-codespace+) 4 | ;; Disable storing and loading of double-floats because we hate them or something 5 | (delete-store double-float) 6 | (delete-restore cl-binary-store::+double-float-code+) 7 | ;; Add low-level support for something-else objects 8 | (defstore something-else (store-something-else obj storage store-object)) 9 | (defrestore +test-code+ (restore-something-else restore-object))) 10 | -------------------------------------------------------------------------------- /src/sbcl-utilities.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-binary-store) 2 | 3 | #+sbcl 4 | (sb-alien:define-alien-routine "memcpy" sb-alien:void 5 | (dest sb-alien:system-area-pointer :in) 6 | (src sb-alien:system-area-pointer :in) 7 | (n sb-alien:int :in)) 8 | 9 | (declaim (inline copy-sap)) 10 | (defun copy-sap (target-sap target-offset source-sap source-offset n) 11 | (case n 12 | (0) 13 | (1 14 | (set-sap-ref-8 target-sap target-offset (sap-ref-8 source-sap source-offset))) 15 | (2 16 | (set-sap-ref-16 target-sap target-offset (sap-ref-16 source-sap source-offset))) 17 | (4 18 | (set-sap-ref-32 target-sap target-offset (sap-ref-32 source-sap source-offset))) 19 | (8 20 | (set-sap-ref-64 target-sap target-offset (sap-ref-64 source-sap source-offset))) 21 | (t 22 | #+sbcl (memcpy (sb-sys:sap+ target-sap target-offset) 23 | (sb-sys:sap+ source-sap source-offset) 24 | n) 25 | #-sbcl (static-vectors:replace-foreign-memory 26 | (cffi:inc-pointer target-sap target-offset) 27 | (cffi:inc-pointer source-sap source-offset) 28 | n)))) 29 | -------------------------------------------------------------------------------- /src/sbcl-special-hash-tables.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-binary-store) 2 | 3 | (declaim (inline double-float-=)) 4 | (defun double-float-= (dfa dfb) 5 | (declare (type double-float dfa dfb)) 6 | (= dfa dfb)) 7 | 8 | (declaim (inline double-float-hash)) 9 | (defun double-float-hash (df) 10 | (declare (type double-float df)) 11 | (sxhash df)) 12 | 13 | (declaim (inline string-hash)) 14 | (defun string-hash (simple-string) 15 | (declare (type simple-string simple-string)) 16 | (sxhash simple-string)) 17 | 18 | (declaim (inline string-and-type-=)) 19 | (defun string-and-type-= (stringa stringb) 20 | "These are not displaced strings, etc. Just simple strings." 21 | (declare (type simple-string stringa stringb) (optimize (speed 3) (safety 0))) 22 | (let ((is-simple-base-string (typep stringa 'simple-base-string))) 23 | (if is-simple-base-string 24 | (and (typep stringb 'simple-base-string) (string= stringa stringb)) 25 | (and (not (typep stringb 'simple-base-string)) (string= stringa stringb))))) 26 | 27 | (sb-ext:define-hash-table-test double-float-= double-float-hash) 28 | (sb-ext:define-hash-table-test string-and-type-= string-hash) 29 | -------------------------------------------------------------------------------- /src/pathname.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-binary-store) 2 | 3 | ;; Pathname code is pretty much identical to cl-store 4 | 5 | (declaim (inline store-pathname)) 6 | (defun store-pathname (obj store-object) 7 | (declare (optimize speed safety) (type pathname obj) (type function store-object)) 8 | #-sbcl (funcall store-object (pathname-host obj)) 9 | #+sbcl (funcall store-object (host-namestring obj)) 10 | (funcall store-object (pathname-device obj)) 11 | (funcall store-object (pathname-directory obj)) 12 | (funcall store-object (pathname-name obj)) 13 | (funcall store-object (pathname-type obj)) 14 | (funcall store-object (pathname-version obj))) 15 | 16 | (defun restore-pathname (restore-object) 17 | (declare (type function restore-object)) 18 | (handler-case 19 | (make-pathname 20 | :host #+sbcl (funcall restore-object) 21 | #-sbcl (funcall restore-object) 22 | :device (funcall restore-object) 23 | :directory (funcall restore-object) 24 | :name (funcall restore-object) 25 | :type (funcall restore-object) 26 | :version (funcall restore-object)) 27 | (error () (unexpected-data "pathname malformed")))) 28 | -------------------------------------------------------------------------------- /src/simple-vector.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-binary-store) 2 | 3 | (declaim (inline store-simple-vector)) 4 | (defun store-simple-vector (sv storage store-object) 5 | (declare (optimize speed safety) (type simple-vector sv) (type function store-object)) 6 | (when storage 7 | (store-ub8/no-tag +simple-vector-code+ storage) 8 | (store-tagged-unsigned-fixnum/interior (length sv) storage)) 9 | (map nil store-object sv)) 10 | 11 | (declaim (inline restore-simple-vector)) 12 | (defun restore-simple-vector (storage restore-object) 13 | (declare (optimize speed safety)) 14 | (let* ((num-elts (restore-tagged-unsigned-fixnum/interior storage))) 15 | (unless (< num-elts (ash most-positive-fixnum -3)) 16 | (unexpected-data "simple vector too long")) 17 | (check-if-too-much-data (read-storage-max-to-read storage) (* num-elts 8)) 18 | (let ((sv (make-array num-elts))) 19 | ;; It's possible that we can refer to an 20 | ;; object that is not fully reified yet 21 | ;; (the only possibility is an array displaced 22 | ;; to us to which we hold a reference) 23 | (dotimes (idx num-elts) 24 | (restore-object-to (svref sv idx) restore-object)) 25 | sv))) 26 | -------------------------------------------------------------------------------- /.github/workflows/blarg.yml~: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: 4 | push: 5 | branches: [ "main" ] 6 | paths-ignore: 7 | - 'README.org' 8 | pull_request: 9 | branches: [ "main" ] 10 | workflow_dispatch: 11 | schedule: 12 | - cron: '0 0 1 * *' 13 | 14 | jobs: 15 | test: 16 | name: ${{ matrix.lisp }} on ${{ matrix.os }} 17 | runs-on: ${{ matrix.os }} 18 | strategy: 19 | matrix: 20 | lisp: [sbcl-bin, ccl-bin/1.13, ecl/24.5.10] 21 | os: [ubuntu-latest, windows-latest, macos-latest] 22 | exclude: 23 | - os: windows-latest 24 | lisp: ecl/24.5.10 25 | - os: windows-latest 26 | lisp: ccl-bin/1.13 27 | - os: macos-latest 28 | lisp: ccl-bin/1.13 29 | env: 30 | LISP: ${{ matrix.lisp }} 31 | steps: 32 | - uses: actions/checkout@v1 33 | - name: Install Roswell 34 | env: 35 | LISP: ${{ matrix.lisp }} 36 | run: | 37 | curl -L https://raw.githubusercontent.com/roswell/roswell/master/scripts/install-for-ci.sh | sh 38 | - name: Install Ultralisp 39 | run: ros -e '(ql-dist:install-dist "http://dist.ultralisp.org/" :prompt nil)' 40 | - name: Install Rove 41 | run: ros install fukamachi/rove 42 | - name: Run tests 43 | run: | 44 | PATH="~/.roswell/bin:$PATH" 45 | rove dexador-test.asd 46 | -------------------------------------------------------------------------------- /.github/workflows/ci-workflow.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: 4 | push: 5 | branches: [ "main" ] 6 | paths-ignore: 7 | - 'README.org' 8 | pull_request: 9 | branches: [ "main" ] 10 | workflow_dispatch: 11 | schedule: 12 | - cron: '0 0 1 * *' 13 | 14 | jobs: 15 | test: 16 | name: ${{ matrix.lisp }} on ${{ matrix.os }} 17 | runs-on: ${{ matrix.os }} 18 | strategy: 19 | matrix: 20 | lisp: [sbcl-bin, ccl-bin/1.13, ecl/24.5.10] 21 | os: [ubuntu-latest, macos-latest] 22 | exclude: 23 | - os: macos-latest 24 | lisp: ccl-bin/1.13 25 | - os: macos-latest 26 | lisp: ecl/24.5.10 27 | env: 28 | LISP: ${{ matrix.lisp }} 29 | steps: 30 | - uses: actions/checkout@v1 31 | - name: Install Roswell 32 | env: 33 | LISP: ${{ matrix.lisp }} 34 | run: | 35 | curl -L https://raw.githubusercontent.com/roswell/roswell/master/scripts/install-for-ci.sh | sh 36 | - name: Install Ultralisp 37 | run: ros -e '(ql-dist:install-dist "http://dist.ultralisp.org/" :prompt nil)' 38 | - name: Install Rove 39 | run: ros install parachute 40 | - name: Run tests 41 | run: ros run -e '(quicklisp:quickload :cl-binary-store) (quicklisp:quickload :cl-binary-store/tests) (defparameter *exit-on-test-failures* t) (parachute:test :cl-binary-store-tests)' 42 | -------------------------------------------------------------------------------- /src/object-info.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-binary-store) 2 | 3 | ;; We store some meta-information about the structure-object or 4 | ;; standard-object. We store part of this information (slot-names and 5 | ;; type into the serialization stream... only once though, with either 6 | ;; an explicit reference scheme if *track-references* is T or an implicit 7 | ;; tracking scheme that uses object-info-ref-id and overloads the length 8 | ;; of the slot-name vector as a reference id.) 9 | 10 | (declaim (inline object-info-class object-info-slot-names object-info-type 11 | object-info-specialized-constructor 12 | object-info-slot-value-filter-func 13 | object-info-specialized-serializer 14 | object-info-specialized-deserializer 15 | object-info-use-initialize-instance 16 | object-info-ref-id 17 | make-object-info 18 | object-info-p)) 19 | (defstruct object-info 20 | (class (find-class 'structure-object)) 21 | (slot-names #() :type simple-vector) 22 | (type 'object-info :type symbol) 23 | (slot-value-filter-func nil :type (or null function)) 24 | (use-initialize-instance nil :type boolean) 25 | (specialized-constructor nil :type (or null function)) 26 | (specialized-serializer nil :type (or null function)) 27 | (specialized-deserializer nil :type (or null function)) 28 | (ref-id nil :type (or null (and fixnum (integer * -1))))) 29 | -------------------------------------------------------------------------------- /src/reference-count.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-binary-store) 2 | 3 | ;; During restore we use a vector of references. It nominally auto-grows as 4 | ;; we see references during restore. Since we know the number of references 5 | ;; after restore (since we have allocated them reference ids!) we can write 6 | ;; the number in advance to the file to avoid having to keep growing the vector. 7 | ;; This only matters when the number of references is huge and is just a small 8 | ;; performance tweak. 9 | 10 | (defstruct (write-reference-count (:include action (code +set-reference-action-code+))) 11 | (reference-count nil :type fixnum :read-only t)) 12 | 13 | (defun write-reference-count (number-of-references store-object) 14 | (funcall store-object (make-write-reference-count :reference-count number-of-references))) 15 | 16 | (defmethod store-action ((action write-reference-count) storage store-object) 17 | (store-tagged-unsigned-fixnum (write-reference-count-reference-count action) storage)) 18 | 19 | (defmethod action ((code (eql +set-reference-action-code+)) storage references restore-object) 20 | (let ((num-refs (restore-tagged-unsigned-fixnum storage))) 21 | #+info-cbs(format t "This file has ~A references~%" num-refs) 22 | (unless (<= 0 num-refs (ash most-positive-fixnum -3)) 23 | (unexpected-data "num-refs stored in file invalid")) 24 | (check-if-too-much-data (read-storage-max-to-read storage) (* 8 num-refs)) 25 | (values (setf (references-vector references) (make-array num-refs :initial-element nil)) 26 | :ignore))) 27 | 28 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | BSD 3-Clause License 2 | 3 | Copyright (c) 2024, Andrew J. Berkley 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | 1. Redistributions of source code must retain the above copyright notice, this 9 | list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright notice, 12 | this list of conditions and the following disclaimer in the documentation 13 | and/or other materials provided with the distribution. 14 | 15 | 3. Neither the name of the copyright holder nor the names of its 16 | contributors may be used to endorse or promote products derived from 17 | this software without specific prior written permission. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 20 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 21 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 22 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 23 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 24 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 25 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 26 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 27 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | -------------------------------------------------------------------------------- /src/actions.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-binary-store) 2 | 3 | ;; An action is a sub-dispatch mechanism for codes in the file. 4 | ;; It's currently used for magic-numbers (versioning) and for 5 | ;; set-reference-count which sets the size of the reference vector 6 | ;; during restore. The hook is via the generic function ACTION 7 | ;; which you can specialize to your action-codes. See for example 8 | ;; magic-numbers.lisp and set-references.lisp 9 | 10 | ;; An ACTION should return two values, the first value may be 11 | ;; an object to store into the stream, the second value may be 12 | ;; :ignore if the object is to be ignored and not presented to 13 | ;; the user or :end if this is the end of data, or nil if the 14 | ;; object is to be collected. 15 | 16 | (declaim (inline make-action)) 17 | (defstruct action 18 | (code nil :type (unsigned-byte 8) :read-only t)) 19 | 20 | ;; Allocated action numbers 21 | (defconstant +magic-number-action-code+ 0) 22 | (defconstant +set-reference-action-code+ 1) 23 | (defconstant +end-action-code+ 2) 24 | 25 | (defgeneric action (command storage references restore-object) 26 | (:documentation "If we hit an +action-code+ during restore, 27 | we will call this which should specialize on command (a ub8). 28 | You can read anything from the file here as arguments to 29 | the action. Return two values, an object/nil and a second 30 | value which is :ignore, :end, or nil if the object is to be 31 | collected for the user. The second value only works if the 32 | object is a top level object (that is one of the objects in 33 | the call to store (store nil obj-a obj-b (make-instance 'end-action))") 34 | (:method ((command t) (storage t) (references t) (restore-object t)) 35 | (unexpected-data "Expected an action command" command))) 36 | 37 | (defgeneric store-action (action storage store-object) 38 | (:documentation "Call during the serialization phase. You can 39 | write whatever you want to the file from here. Specialize on 40 | the structure-object you made that inherits from `action'")) 41 | 42 | (defun restore-action& (storage references restore-object) 43 | (let ((command (restore-ub8 storage))) 44 | (action command storage references restore-object))) 45 | 46 | (defun store-action& (action storage store-object) 47 | (when storage 48 | (storage-write-byte storage +action-code+) 49 | (storage-write-byte storage (action-code action))) 50 | (store-action action storage store-object)) 51 | -------------------------------------------------------------------------------- /src/magic-numbers.lisp: -------------------------------------------------------------------------------- 1 | ;; Simple versioning mechanism. All versioned output should start 2 | ;; with +magic-number-code+ and then a number (though it can occur 3 | ;; anywhere and even multiple times in the stream / file, not sure why 4 | ;; you'd want that). When restored, the magic number is used to 5 | ;; pull up the correct `codespace' in *codespaces* and then restoration 6 | ;; continues. If there is no codespace matching that magic number 7 | ;; an error will be signalled. 8 | 9 | (in-package :cl-binary-store) 10 | 11 | (defvar *write-version* #x0001 12 | "Set this to the magic number you wish to write into the file. It may 13 | be queried by serialization routines if desired.") 14 | 15 | (defvar *allow-codespace-switching* nil 16 | "Set this to NIL if you want to specify the format of file you want to load and 17 | not allow it to be set automatically based on the data format of the file.") 18 | 19 | (defstruct (magic-number (:include action (code +magic-number-action-code+))) 20 | (number #x0001 :type integer :read-only t)) 21 | 22 | (defmethod action ((code (eql +magic-number-action-code+)) storage references restore-object) 23 | (let ((magic-number (funcall restore-object))) 24 | (let ((codespace (gethash magic-number *codespaces*))) 25 | (unless codespace 26 | (error 'invalid-input-data 27 | :format-control "Unsupported codespace version #x~X, we have ~{~x~X~^ ~}~%" 28 | :format-arguments (list 29 | magic-number (loop for key being the hash-keys of *codespaces* 30 | collect key)))) 31 | (cond 32 | ((not (eq *current-codespace* codespace)) 33 | (cond 34 | (*allow-codespace-switching* 35 | (format t "Switching codespace from ~A to #x~X (~A)~%" 36 | (codespace-name *current-codespace*) 37 | magic-number 38 | (codespace-name codespace)) 39 | (setf *current-codespace* codespace) 40 | (setf *version-being-read* magic-number) 41 | (restore-objects storage)) 42 | (t 43 | (error 'invalid-input-data 44 | :format-control "Switching codespace away from #x~X (~A) is DISALLOWED" 45 | :format-arguments (list 46 | (codespace-magic-number *current-codespace*) 47 | (codespace-name *current-codespace*)))))) 48 | (t 49 | (setf *version-being-read* magic-number) 50 | (format t "Deserializing from version #x~X (~A)~%" 51 | magic-number (codespace-name codespace)) 52 | (values nil :ignore)))))) 53 | 54 | (defmethod store-action ((action magic-number) storage store-object) 55 | (when storage (store-fixnum (magic-number-number action) storage))) 56 | 57 | -------------------------------------------------------------------------------- /src/hash-table.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-binary-store) 2 | 3 | (defun store-hash-table (ht storage store-object) 4 | (declare (optimize speed safety) (type hash-table ht) (type function store-object)) 5 | (when storage 6 | (store-ub8/no-tag +hash-table-code+ storage) 7 | (store-tagged-unsigned-fixnum (hash-table-count ht) storage) 8 | (store-tagged-unsigned-fixnum (hash-table-size ht) storage)) 9 | (funcall store-object (hash-table-test ht)) ;; a symbol 10 | (funcall store-object (hash-table-rehash-threshold ht)) ;; float 11 | (funcall store-object (hash-table-rehash-size ht)) ;; float 12 | #+sbcl (when storage (store-boolean (sb-ext:hash-table-synchronized-p ht) storage)) 13 | #-sbcl (when storage (store-nil storage)) 14 | #+sbcl (funcall store-object (sb-ext:hash-table-weakness ht)) 15 | #-sbcl (when storage (store-nil storage)) 16 | (maphash (lambda (k v) 17 | (funcall store-object k) 18 | (funcall store-object v)) 19 | ht)) 20 | 21 | (defun restore-hash-table (storage restore-object) 22 | (declare (type function restore-object)) 23 | (let* ((hash-table-count (restore-tagged-unsigned-fixnum storage)) 24 | (size (restore-tagged-unsigned-fixnum storage)) 25 | (ht 26 | (let ((test (funcall restore-object)) 27 | (rehash-threshold (funcall restore-object)) 28 | (rehash-size (funcall restore-object)) 29 | (synchronized (funcall restore-object)) 30 | (weakness (funcall restore-object))) 31 | #-sbcl (declare (ignore synchronized weakness)) 32 | ;; weakness works as far as I can discern 33 | ;; because of how we do reference restoration 34 | (unless (typep rehash-size '(or (integer 1 *) (float (1.0) *))) 35 | (unexpected-data "rehash-size is not correct")) 36 | (unless (< size (ash most-positive-fixnum -4)) 37 | (unexpected-data "hash table too large")) 38 | (check-if-too-much-data (read-storage-max-to-read storage) 39 | (* 16 size)) ;; an estimate 40 | (make-hash-table :test test :size size 41 | :rehash-size rehash-size 42 | :rehash-threshold rehash-threshold 43 | #+sbcl :synchronized #+sbcl synchronized 44 | #+sbcl :weakness #+sbcl weakness)))) 45 | ;; the keys may not be fully reified yet, so we need to 46 | ;; potentially delay these settings. Actually worse than this 47 | ;; everything referred to by the KEY must be re-ified, if this is 48 | ;; a non-eql hash table. As far as I can tell, while Common Lisp 49 | ;; allows some insanely build order dependent situations with 50 | ;; EQUALP hash tables, but there is no way to discover or 51 | ;; reproduce that at serialization or deserialization time. 52 | (dotimes (i hash-table-count) 53 | (let ((key (funcall restore-object))) 54 | (restore-object-to (gethash key ht) restore-object))) 55 | ht)) 56 | 57 | 58 | 59 | 60 | -------------------------------------------------------------------------------- /src/basic-codespace-codes.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-binary-store) 2 | 3 | ;; USER CODES START AT 225 and end at 250 4 | ;; [0 33] for various objects 5 | ;; [35 63] for small reference ids coded in the tag byte 6 | ;; [64 127] for 14 bit reference codes stored in the tag byte and one additional byte 7 | ;; [128 191] for 22 bit reference codes stored in the tag byte and two additional bytes 8 | ;; [192 224] for small integers [-16 16] 9 | ;; [225 250] for user codes 10 | ;; [251 255] reserved for bug fixing, extensions 11 | 12 | (defconstant +ub8-code+ 0) 13 | (defconstant +ub16-code+ 1) 14 | (defconstant +ub32-code+ 2) 15 | (defconstant +fixnum-code+ 3) 16 | (defconstant +first-direct-unsigned-integer-interior-code+ 4) 17 | (defconstant +interior-coded-max-integer+ (- 255 +first-direct-unsigned-integer-interior-code+)) 18 | ;; Inside of another tag region, when encoding an unsigned integer, 0 19 | ;; - 3 is a tag for an extended number, and 4-255 are direct coded 20 | ;; lengths. If 0-3 is used, then the number encoded is shifted down 21 | ;; by +interior-coded-max-integer+. 22 | (defconstant +cons-code+ 4) 23 | (defconstant +nil-code+ 5) 24 | (defconstant +sb8-code+ 6) 25 | (defconstant +sb16-code+ 7) 26 | (defconstant +sb32-code+ 8) 27 | (defconstant +bignum-code+ 9) 28 | (defconstant +single-float-code+ 10) 29 | (defconstant +double-float-code+ 11) 30 | (defconstant +double-float-zero-code+ 12) 31 | (defconstant +ratio-code+ 13) 32 | (defconstant +complex-code+ 14) 33 | (defconstant +complex-double-float-code+ 15) 34 | (defconstant +complex-single-float-code+ 16) 35 | (defconstant +symbol-code+ 17) 36 | (defconstant +uninterned-symbol-code+ 18) 37 | (defconstant +standard/structure-object-code+ 19) 38 | (defconstant +t-code+ 20) 39 | (defconstant +simple-specialized-vector-code+ 21) 40 | (defconstant +simple-vector-code+ 22) 41 | (defconstant +simple-specialized-array-code+ 23) 42 | (defconstant +array-code+ 24) 43 | (defconstant +object-info-code+ 25) 44 | (defconstant +unbound-code+ 26) 45 | (defconstant +pathname-code+ 27) 46 | (defconstant +hash-table-code+ 28) 47 | (defconstant +simple-base-string-code+ 29) 48 | (defconstant +simple-string-code+ 30) 49 | (defconstant +action-code+ 31 50 | "A request to perform an action. Used for checking codespace versions and for 51 | updating reference vector size and for marking the end of data") 52 | (defconstant +finite-length-list-code+ 32 53 | "When tracking references, we know all list lengths in advance") 54 | (defconstant +tagged-reference-code+ 33 55 | "A reference to an object") 56 | (defconstant +new-reference-indicator-code+ 34 57 | "Note that the next object to be read should be assigned the next consecutive reference id") 58 | (defconstant +first-direct-reference-id-code+ 35 59 | "[35 63] used for direct reference codes (tag only) ref id [1 29]") 60 | (defconstant +last-direct-reference-id-code+ 63) 61 | (defconstant +first-one-byte-reference-id-code+ 64 62 | "[64 127] used for the tag + one byte reference codes (6 bits)") 63 | (defconstant +last-one-byte-reference-id-code+ 127) 64 | (defconstant +first-two-byte-reference-id-code+ 128 65 | "[128 191] used for the two byte codes (6 bits)") 66 | (defconstant +last-two-byte-reference-id-code+ 191) 67 | (defconstant +first-small-integer-code+ 192 68 | "[192 224] is used for small signed integers [-16 16]") 69 | (defconstant +small-integer-zero-code+ 208) 70 | (defconstant +last-small-integer-code+ 224) 71 | (defconstant +first-user-code+ (+ 1 +last-small-integer-code+)) 72 | (defconstant +last-user-code+ 255) 73 | 74 | (defconstant +maximum-untagged-unsigned-integer+ (- +last-small-integer-code+ 75 | +small-integer-zero-code+)) 76 | (defconstant +minimum-untagged-signed-integer+ (- +first-small-integer-code+ 77 | +small-integer-zero-code+)) 78 | 79 | -------------------------------------------------------------------------------- /src/reference-coding.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-binary-store) 2 | 3 | (defconstant +reference-direct-min-ref-id+ 1) 4 | (defconstant +reference-direct-max-ref-id+ 5 | (+ +reference-direct-min-ref-id+ 6 | (- +last-direct-reference-id-code+ +first-direct-reference-id-code+))) 7 | (defconstant +reference-one-byte-min-ref-id+ (+ +reference-direct-max-ref-id+ 1)) 8 | (defconstant +reference-one-byte-max-ref-id+ (+ (ash 255 6) +reference-one-byte-min-ref-id+)) 9 | (defconstant +reference-two-byte-min-ref-id+ (+ +reference-one-byte-max-ref-id+ 1)) 10 | (defconstant +reference-two-byte-max-ref-id+ (+ (ash 65535 6) +reference-two-byte-min-ref-id+)) 11 | 12 | (declaim (inline decode-reference-direct)) 13 | (defun decode-reference-direct (raw-8-bit) 14 | "Result will be between [1 30]. This uses just the tag byte" 15 | (declare (optimize (speed 3) (safety 1)) (type (unsigned-byte 8) raw-8-bit)) 16 | (assert (<= +first-direct-reference-id-code+ raw-8-bit +last-direct-reference-id-code+)) 17 | (+ 1 (- raw-8-bit +first-direct-reference-id-code+))) 18 | 19 | (declaim (inline decode-reference-one-byte)) 20 | (defun decode-reference-one-byte (tag-byte next-byte) 21 | "Result will be between [31 16414]. This uses the tag byte plus another byte" 22 | (declare (type (unsigned-byte 8) tag-byte next-byte) (optimize (speed 3) (safety 1))) 23 | ;;(format t "Tag byte is ~A, next-byte is ~A~%" tag-byte next-byte) 24 | (assert (<= +first-one-byte-reference-id-code+ tag-byte +last-one-byte-reference-id-code+)) 25 | (+ +reference-one-byte-min-ref-id+ (logxor tag-byte #x40) (ash next-byte 6))) 26 | 27 | (declaim (inline decode-reference-two-bytes)) 28 | (defun decode-reference-two-bytes (tag-byte next-16-bits) 29 | "Result will be between [16415 4210718]. This uses the tag byte plus 2 additional bytes" 30 | (declare (type (unsigned-byte 8) tag-byte) (type (unsigned-byte 16) next-16-bits) 31 | (optimize (speed 3) (safety 1))) 32 | ;;(format t "Tag byte is ~A, next-16-bits is ~A~%" tag-byte next-16-bits) 33 | (assert (<= +first-two-byte-reference-id-code+ tag-byte +last-two-byte-reference-id-code+)) 34 | (+ +reference-two-byte-min-ref-id+ (logxor tag-byte #x80) (ash next-16-bits 6))) 35 | 36 | (declaim (inline decode-reference-tagged)) 37 | (defun decode-reference-tagged (number) 38 | "Number ranges from -16 to wherever. This uses the reference-tag byte plus the tagged integer 39 | which can be anywhere from 1 byte direct tagged to arbitrarily large." 40 | (declare (optimize (speed 3) (safety 1))) 41 | (if (and (typep number 'fixnum) (>= number +minimum-untagged-signed-integer+) 42 | (<= number #.(expt 2 54))) ;; arbitrary 1 TB limit on number of references! 43 | (truly-the fixnum 44 | (+ (- +minimum-untagged-signed-integer+) 45 | (truly-the fixnum number) 46 | 1 +reference-two-byte-max-ref-id+)) 47 | (unexpected-data "reference tag not valid"))) 48 | 49 | (declaim (inline encode-reference-direct)) 50 | (defun encode-reference-direct (ref-index) 51 | "reference indicies start a 1, so we subtract one here." 52 | (+ (- +first-direct-reference-id-code+ 1) ref-index)) 53 | 54 | ;; Little endian, least significant byte first 55 | (declaim (inline encode-reference-one-byte)) 56 | (defun encode-reference-one-byte (ref-index) 57 | "Returns a 16 bit value" 58 | (let* ((shifted-ref-index 59 | (- ref-index +reference-one-byte-min-ref-id+)) 60 | (tag-byte (+ #x40 (logand shifted-ref-index #x3F)))) 61 | (+ tag-byte (ash (logand shifted-ref-index #xFFC0) 2)))) 62 | 63 | (declaim (inline encode-reference-two-bytes)) 64 | (defun encode-reference-two-bytes (ref-index) 65 | (let ((shifted-ref-index 66 | (- ref-index +reference-two-byte-min-ref-id+))) 67 | (values (+ #x80 (logand shifted-ref-index #x3F)) 68 | (ash shifted-ref-index -6)))) 69 | 70 | (declaim (inline encode-reference-tagged)) 71 | (defun encode-reference-tagged (ref-index) 72 | (+ (- ref-index (+ 1 +reference-two-byte-max-ref-id+)) +minimum-untagged-signed-integer+)) 73 | -------------------------------------------------------------------------------- /cl-binary-store.asd: -------------------------------------------------------------------------------- 1 | (defsystem #:cl-binary-store 2 | :version "1.0.0" 3 | :description "Fast serialization / deserialization library" 4 | :author "Andrew J. Berkley " 5 | :long-name "Fast serialization / deserialization library" 6 | :pathname "src/" 7 | :depends-on (#:flexi-streams 8 | #:babel 9 | #:static-vectors #:alexandria 10 | #-sbcl #:cffi) 11 | :components ((:file "features") 12 | (:file "cl-binary-store") 13 | (:file "cl-binary-store-user" :depends-on ("cl-binary-store")) 14 | (:file "codespaces" :depends-on ("features" "unsigned-bytes")) 15 | (:file "sbcl-special-hash-tables" :if-feature :sbcl) 16 | (:file "type-discrimination") 17 | (:file "object-info") 18 | (:file "basic-codespace-codes") 19 | (:file "reference-coding" :depends-on ("basic-codespace-codes")) 20 | (:file "actions" :depends-on ("storage" "features" "basic-codespace-codes" 21 | "unsigned-bytes")) 22 | (:file "basic-codespace" :depends-on ("sbcl-special-hash-tables" 23 | "type-discrimination" "hash-table" 24 | "features" "codespaces" 25 | "actions" "object-info" "pathname" 26 | "basic-codespace-codes" "cons" 27 | "reference-coding" 28 | "unsigned-bytes" 29 | "referrers-and-fixup" 30 | "numbers" "objects")) 31 | (:file "sap-ref") 32 | (:file "storage" :depends-on ("features" "cl-binary-store" "sap-ref")) 33 | (:file "unsigned-bytes" :depends-on ("storage" "features" "cl-binary-store" 34 | "basic-codespace-codes" "sap-ref")) 35 | (:file "referrers-and-fixup" :depends-on ("unsigned-bytes" "features" 36 | "basic-codespace-codes")) 37 | (:file "numbers" :depends-on ("unsigned-bytes" "referrers-and-fixup" 38 | "features" "sap-ref" 39 | "basic-codespace-codes")) 40 | (:file "reference-count" :depends-on ("actions" "numbers" "features")) 41 | (:file "magic-numbers" :depends-on ("actions" "numbers")) 42 | (:file "end-action" :depends-on ("actions" "numbers")) 43 | (:file "cons" :depends-on ("referrers-and-fixup" "numbers" "unsigned-bytes" 44 | "features" "symbols")) 45 | (:file "sbcl-utilities" :if-feature :sbcl :depends-on ("features")) 46 | (:file "simple-array" 47 | :depends-on ("referrers-and-fixup" "numbers" "features" "sap-ref" "storage" 48 | "unsigned-bytes")) 49 | (:file "simple-vector" :depends-on ("unsigned-bytes" "referrers-and-fixup" 50 | "features" "numbers")) 51 | (:file "symbols" :depends-on ("unsigned-bytes" "referrers-and-fixup" 52 | "features" "numbers")) 53 | (:file "array" :depends-on ("unsigned-bytes" "cons" "symbols" "numbers" 54 | "referrers-and-fixup" "features")) 55 | (:file "pathname" :depends-on ("referrers-and-fixup" "symbols" "numbers" 56 | "unsigned-bytes" "features")) 57 | (:file "hash-table" :depends-on ("referrers-and-fixup" "symbols" "numbers" "unsigned-bytes" "features" "symbols")) 58 | (:file "objects" :depends-on ("symbols" "simple-vector" "referrers-and-fixup" "numbers" "unsigned-bytes" "features" "codespaces")) 59 | (:file "user" :depends-on ("basic-codespace" "cons" "storage" "features" "magic-numbers" "reference-count" "end-action"))) 60 | :license :BSD-3 61 | :in-order-to ((asdf:test-op (asdf:test-op :cl-binary-store-tests)))) 62 | 63 | (defsystem #:cl-binary-store/tests 64 | :description "Unit tests for CL-BINARY-STORE" 65 | :author "Andrew J. Berkley " 66 | :license :BSD-3 67 | :depends-on (#:parachute #:cl-binary-store) 68 | :pathname "test/" 69 | :components ((:file "cl-binary-store-tests")) 70 | :perform (test-op (o c) (uiop:symbol-call :parachute :test :cl-binary-store-tests))) 71 | -------------------------------------------------------------------------------- /src/cl-binary-store-user.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:cl-binary-store-user 2 | (:use #:common-lisp #:cl-binary-store) 3 | (:documentation "A Common Lisp serialization/deserialization library 4 | for Common Lisp objects to a binary format. Optimized for speed and 5 | lightly for flexibility. It is about 10x faster than cl-store and 6 | produces reasonably compact files (plug it into a gzip stream if you 7 | want more). Currently only works on SBCL. 8 | 9 | Out of the box we support reading/writing from/to streams, 10 | reading/writing from/to in-memory vectors, reading/writing to raw 11 | memory. 12 | 13 | Extending this with your own serializer / deserializer is 14 | straightforward as it is expected that the default standard-object 15 | and structure-object serialization may not meet everyones needs. 16 | 17 | All number types are supported, but we provide specialized compact writers for: 18 | ub8, ub16, ub32, ub64, fixnum, single-float, double-float 19 | (complex double-float) (complex single-float) 20 | 21 | All array types are supported. 22 | 23 | On SBCL we provide fast and compact serialization of vectors and simple-arrays of: 24 | bit (simple-bit-vector in 1D or multi-dimensional) 25 | base-char (simple-base-string in 1D or multi-dimensional) 26 | character (simple-string in 1D or multi-dimensional) 27 | single-float 28 | double-float 29 | fixnum 30 | signed-byte: 8 16 32 64 31 | unsigned-byte: 2 4 7 8 15 16 31 32 62 64") 32 | (:export 33 | ;; General user interface 34 | #:store 35 | #:restore 36 | ;; Serializing to / from sbcl specific raw memory SAP 37 | #:store-to-sap 38 | #:restore-from-sap 39 | #:replace-store-sap-buffer 40 | #:out-of-space 41 | #:out-of-space-current-offset 42 | #:out-of-space-wanted-bytes 43 | ;; Streams 44 | #:restore-from-stream 45 | #:store-to-stream 46 | ;; In memory ub8 vectors 47 | #:restore-from-vector 48 | #:store-to-vector 49 | #:store-to-extant-vector 50 | #:out-of-space-in-fixed-vector 51 | 52 | #:out-of-data 53 | #:store-to-file 54 | #:restore-from-file 55 | ;; Support complex circular lists 56 | #:*support-shared-list-structures* 57 | ;; Do any sort of reference tracking 58 | #:*track-references* 59 | ;; Write an end marker 60 | #:*output-end-marker* 61 | 62 | ;; Versioning 63 | #:*current-codespace* 64 | #:*write-version* 65 | #:*version-being-read* 66 | #:*output-magic-number* 67 | 68 | ;; Safety rails 69 | #:*max-to-write* 70 | #:*max-to-read* 71 | 72 | ;; Fun 73 | #:*load/save-progress-indicator* 74 | 75 | ;; Error if symbol package does not exist 76 | #:missing-package-during-restore 77 | ;; Restarts to recover from the above error 78 | #:create-package 79 | #:change-package 80 | 81 | ;; Hinting how many objects you will want to track 82 | #:*eq-refs-table-size* 83 | #:*num-eq-refs-table-size* 84 | #:*double-float-refs-table-size* 85 | 86 | ;; Structure-object or standard-object type does not exist during restore 87 | #:object-type-not-found 88 | #:object-type-not-found-object-info 89 | ;; restarts 90 | #:create-structure-object 91 | #:create-standard-object 92 | #:use-different-class 93 | 94 | ;; Missing slots during restore 95 | #:missing-slot 96 | #:missing-slot-slot-name 97 | #:missing-slot-type 98 | #:missing-slot-data-slots 99 | #:missing-slot-image-slots 100 | ;; Restarts 101 | #:discard 102 | #:map-to-new-slot-name 103 | 104 | ;; A parameter to specialized-object-constructor is an object-info 105 | #:object-info 106 | #:object-info-slot-names 107 | #:object-info-type 108 | 109 | ;; Extensions for modifying object serialization 110 | #:serializable-object-info 111 | #:specialized-object-constructor 112 | #:specialized-serializer/deserializer 113 | 114 | ;; More conditions 115 | #:invalid-input-data 116 | #:too-much-data 117 | #:maybe-expected-error 118 | )) 119 | 120 | (in-package #:cl-binary-store-user) 121 | 122 | -------------------------------------------------------------------------------- /src/symbols.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-binary-store) 2 | 3 | (declaim (inline store-nil)) 4 | (defun store-nil (storage) 5 | (store-ub8/no-tag +nil-code+ storage)) 6 | 7 | (declaim (inline store-t)) 8 | (defun store-t (storage) 9 | (store-ub8/no-tag +t-code+ storage)) 10 | 11 | (declaim (inline store-boolean)) 12 | (defun store-boolean (boolean storage) 13 | (if boolean (store-t storage) (store-nil storage))) 14 | 15 | (declaim (inline restore-boolean)) 16 | (defun restore-boolean (storage) 17 | (= (restore-ub8 storage) +t-code+)) 18 | 19 | (declaim (inline restore-nil)) 20 | (defun restore-nil () 21 | nil) 22 | 23 | (declaim (inline restore-t)) 24 | (defun restore-t () 25 | t) 26 | 27 | (declaim (notinline store-symbol)) 28 | (defun store-symbol (symbol storage eq-refs store-object assign-new-reference-id) 29 | (declare (notinline store-simple-specialized-vector)) 30 | (maybe-store-reference-instead (symbol storage eq-refs assign-new-reference-id) 31 | (let ((symbol-package (symbol-package symbol))) 32 | (cond 33 | (symbol-package 34 | #+debug-cbs 35 | (format t "Storing symbol ~S from package ~S~%" 36 | (symbol-name symbol) (package-name (symbol-package symbol))) 37 | (when storage 38 | (storage-write-byte storage +symbol-code+) 39 | (store-string/no-refs (symbol-name symbol) storage)) 40 | ;; Nominally we can use the eq-refs table but we don't 41 | (funcall (the function store-object) (package-name symbol-package))) 42 | (t ;; uninterned symbols. We don't bother de-duplicating the string representations 43 | #+debug-cbs (format t "Storing symbol without a package ~S~%" symbol) 44 | (when storage 45 | (storage-write-byte storage +uninterned-symbol-code+) 46 | (store-string/no-refs (symbol-name symbol) storage))))))) 47 | 48 | (define-condition missing-package-during-restore (maybe-expected-error) 49 | ((symbol-string :initarg :symbol-string :reader missing-package-symbol-string) 50 | (package-string :initarg :package-string :reader missing-package-package-string))) 51 | 52 | (defmethod print-object ((obj missing-package-during-restore) stream) 53 | (format stream "~S says it is from package ~S, but no such package!" 54 | (missing-package-symbol-string obj) 55 | (missing-package-package-string obj))) 56 | 57 | (defun ask-for-new-package-name () 58 | (format t "Enter a new package name: ") 59 | (let ((read (read))) 60 | (list 61 | (if (stringp read) read (format nil "~A" read))))) 62 | 63 | (defun signal-missing-package (symbol-string package-string) 64 | (restart-case 65 | (error 'missing-package-during-restore 66 | :symbol-string symbol-string :package-string package-string) 67 | (create-package () :report "Create package" 68 | (make-package package-string :use '("COMMON-LISP")) 69 | (assert (find-package package-string)) 70 | (intern symbol-string package-string)) 71 | (change-package (new-package-string) 72 | :report "Rehome to another package" 73 | :interactive ask-for-new-package-name 74 | (if (find-package new-package-string) 75 | (intern symbol-string new-package-string) 76 | (signal-missing-package symbol-string package-string))))) 77 | 78 | (declaim (inline ensure-string)) 79 | (defun ensure-string (maybe-string) 80 | (if (stringp maybe-string) 81 | maybe-string 82 | (progn (unexpected-data "expected a string, it was not") ""))) 83 | 84 | (declaim (inline restore-symbol)) 85 | (defun restore-symbol (storage restore-object) 86 | "Do not call me directly because if you called store-symbol you may have 87 | ended up writing a reference to the symbol object instead of the symbol object." 88 | (let* ((symbol-string (restore-string storage)) 89 | (package-string (ensure-string (funcall (the function restore-object)))) ;; might be a reference 90 | (package (find-package package-string))) 91 | (if package 92 | (values (intern symbol-string package)) 93 | (signal-missing-package symbol-string package-string)))) 94 | 95 | (defun restore-uninterned-symbol (storage) 96 | "You can call this directly since we never store references" 97 | (values (make-symbol (restore-string storage)))) 98 | -------------------------------------------------------------------------------- /src/example-extension.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :example-extension 2 | (:use :common-lisp :cl-binary-store) 3 | (:export #:test-special-serializer/deserializer 4 | #:test-serializable-object-info 5 | #:test-unable-to-restore-double-floats)) 6 | 7 | (in-package :example-extension) 8 | 9 | (defclass blarg () 10 | ((a-not-serializable :initform (lambda () "I was initialized!")) 11 | (b-serializable :initarg :b-serializable))) 12 | 13 | ;; Here we specialize this method to tell cl-binary-store to only 14 | ;; serialize one slot and to call initialize-instance on the object 15 | ;; after restoring it (instead of the default which assumes all slots 16 | ;; will be populated on loading) 17 | (defmethod serializable-object-info ((type (eql 'blarg))) 18 | (values (list 'b-serializable))) 19 | 20 | (defmethod specialized-object-constructor ((type (eql 'blarg))) 21 | (lambda (object-info slot-values) 22 | (assert (= (length slot-values) 1)) 23 | (assert (= (length (object-info-slot-names object-info)) 1)) 24 | (assert (eq (svref (object-info-slot-names object-info) 0) 'b-serializable)) 25 | (make-instance 'blarg :b-serializable (nth 0 slot-values)))) 26 | 27 | (defun test-serializable-object-info () 28 | (let* ((b (make-instance 'blarg :b-serializable "asdf")) 29 | (b-restored (restore (store nil b)))) 30 | (assert (string= (funcall (slot-value b-restored 'a-not-serializable)) 31 | "I was initialized!")) 32 | (assert (string= (slot-value b-restored 'b-serializable) "asdf")) 33 | (format t "Success!~%"))) 34 | 35 | ;; Here is another way to do this 36 | 37 | (defconstant +extension-codespace+ #x9999 38 | "This is our magic number / version number") 39 | (defconstant +test-code+ 225) ;; must be in the user space land of [225 255] see basic-codespace-codes.lisp 40 | 41 | (defclass something-else () 42 | ((information :initform (format nil "Hi from slot information!") :accessor information))) 43 | 44 | (defun store-something-else (obj storage store-object) 45 | (when storage 46 | (store-ub8/no-tag +test-code+ storage) 47 | (store-ub16 12345 storage)) 48 | (funcall store-object (format nil "Hi, I decided to write this instead of a 'something-else~%")) 49 | (funcall store-object (format nil "But actually, it told me to tell you:~%")) 50 | (funcall store-object (information obj))) 51 | 52 | (defun restore-something-else (restore-object) 53 | (assert (= *version-being-read* +extension-codespace+)) 54 | (assert (= (funcall restore-object) 12345)) 55 | (format t (funcall restore-object)) 56 | (format t (funcall restore-object)) 57 | (format t (funcall restore-object)) 58 | "And here is a bonus thing returned to you") 59 | 60 | (defun test-special-serializer/deserializer () 61 | ;; Option one write the version number into the stream 62 | (format t "Example of writing something completely different for a 'something-else object:~%~%") 63 | (format t "First example writing a version number into the stream to switch codespaces~%") 64 | (let ((*write-version* +extension-codespace+) 65 | (*output-magic-number* t)) 66 | (print (restore (store nil (make-instance 'something-else))))) 67 | (format t "~%~%Second example forcing the right codespace~%") 68 | ;; Option two just keep track of it yourself 69 | (let ((*write-version* +extension-codespace+) 70 | (*read-version* +extension-codespace+) 71 | (*output-magic-number* nil)) 72 | (restore (store nil (make-instance 'something-else))))) 73 | 74 | ;; Note that in extension-codespace we have explicitly deleted support for double-floats 75 | ;; let's verify that. 76 | 77 | (defun test-unable-to-restore-double-floats () 78 | (let ((bad-output 79 | (let ((*write-version* +basic-codespace+) 80 | (*output-magic-number* t)) 81 | (store nil 1.23d0)))) 82 | (let ((*read-version* +extension-codespace+) 83 | (*allow-codespace-switching* nil)) 84 | (handler-case 85 | (restore bad-output) 86 | (error (e) 87 | (format t "Successfully denied codespace switching!~%Error was: ~A~%" e)))) 88 | (let ((output-with-double-float 89 | (let ((*write-version* +basic-codespace+) 90 | (*output-magic-number* nil)) 91 | (store nil 1.23d0)))) 92 | (handler-case 93 | (let ((*read-version* +extension-codespace+)) 94 | (restore output-with-double-float)) 95 | (error (e) 96 | (format t "Interpreting of double-float not supported in our codespace!~%Error was: ~A~%" e))) 97 | (let ((*read-version* +basic-codespace+)) 98 | (let ((restored (restore output-with-double-float))) 99 | (if (= restored 1.23d0) 100 | (format t "Successfully read double-float when we were allowed to!~%") 101 | (format t "COULD NOT READ DOUBLE FLOAT BUG BUG BUG!~%"))))))) 102 | 103 | -------------------------------------------------------------------------------- /src/unsigned-bytes.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-binary-store) 2 | 3 | #+allegro 4 | (eval-when (:compile-toplevel) 5 | (setf declared-fixnums-remain-fixnums-switch t) 6 | (declaim (optimize (speed 3) (safety 1) 7 | (space 0) (debug 0) (compilation-speed 0)))) 8 | 9 | (declaim (#-debug-cbs inline #+debug-cbs notinline maybe-restore-ub8)) 10 | (defun maybe-restore-ub8 (storage) 11 | "Maybe restore an (unsigned-byte 8) value from storage that has previously 12 | been stored by STORE-UB8. If there is no more data available will return NIL." 13 | (declare #-debug-cbs(optimize (speed 3) (safety 0) (debug 0))) ;; this is called all the time! 14 | (and (ensure-enough-data storage 1 t) 15 | (let ((offset (read-storage-offset storage))) 16 | (declare (type fixnum offset)) 17 | (setf (read-storage-offset storage) (truly-the fixnum (1+ offset))) 18 | (sap-ref-8 (read-storage-sap storage) offset)))) 19 | 20 | (declaim (#-debug-cbs inline #+debug-cbs notinline restore-ub8)) 21 | (defun restore-ub8 (storage) 22 | "Restore an (unsigned-byte 8) value from storage that has previously 23 | been stored by STORE-UB8." 24 | (declare #-debug-cbs(optimize (speed 3) (safety 0) (debug 0))) ;; called all the time! 25 | (ensure-enough-data storage 1) 26 | (let ((offset (read-storage-offset storage))) 27 | (prog1 28 | (sap-ref-8 (read-storage-sap storage) offset) 29 | (setf (read-storage-offset storage) (truly-the fixnum (+ 1 offset)))))) 30 | 31 | (declaim (#-debug-cbs inline #+debug-cbs notinline restore-ub16)) 32 | (defun restore-ub16 (storage) 33 | "Restore a (unsigned-byte 16) from STORAGE which has previously been stored 34 | by STORE-UB16." 35 | (declare (optimize (speed 3) (safety 1))) 36 | (ensure-enough-data storage 2) 37 | (let ((offset (read-storage-offset storage)) 38 | (sap (read-storage-sap storage))) 39 | (declare (type fixnum offset)) 40 | (setf (read-storage-offset storage) (truly-the fixnum (+ 2 offset))) 41 | (sap-ref-16 sap offset))) 42 | 43 | (declaim (inline restore-ub32)) 44 | (defun restore-ub32 (storage) 45 | "Restore a (unsigned-byte 32) from STORAGE which has previously been stored 46 | by STORE-UB32." 47 | (declare (optimize (speed 3) (safety 1))) 48 | (ensure-enough-data storage 4) 49 | (let ((offset (read-storage-offset storage)) 50 | (sap (read-storage-sap storage))) 51 | (setf (read-storage-offset storage) (truly-the fixnum (+ 4 offset))) 52 | (sap-ref-32 sap offset))) 53 | 54 | (declaim (inline store-ub8/no-tag)) 55 | (defun store-ub8/no-tag (ub8 storage) 56 | "Store an (unsigned-byte 8) value UB8 to STORAGE. If TAG is nil then 57 | we will skip writing a tag byte; use if your deserializer will know that 58 | the next byte is a UB8. Do not call except during storage phase" 59 | (declare (optimize (speed 3) (safety 1)) 60 | (type (unsigned-byte 8) ub8) 61 | (type write-storage storage)) 62 | (with-write-storage (storage :offset offset :reserve-bytes 1 :sap sap) 63 | (set-sap-ref-8 sap offset ub8))) 64 | 65 | (declaim (inline store-ub8/tag)) 66 | (defun store-ub8/tag (ub8 storage) 67 | "Store an (unsigned-byte 8) value UB8 to STORAGE. If TAG is nil then 68 | we will skip writing a tag byte; use if your deserializer will know that 69 | the next byte is a UB8. Do not call except during storage phase" 70 | (declare (optimize (speed 3) (safety 1)) 71 | (type (unsigned-byte 8) ub8) 72 | (type write-storage storage)) 73 | (with-write-storage (storage :offset offset :reserve-bytes 2 :sap sap) 74 | ;; Annotations for bad compilers 75 | (set-sap-ref-16 sap offset (truly-the fixnum (+ +ub8-code+ (truly-the fixnum (ash ub8 8))))))) 76 | 77 | (declaim (inline store-ub16)) 78 | (defun store-ub16 (ub16 storage &optional (tag +ub16-code+)) 79 | "Store an (unsigned-byte 16) value UB16 to STORAGE. If TAG is true will 80 | emit +UB16-CODE+ to STORAGE first. Set TAG NIL if the deserializer will 81 | know from the context that the value is a UB16 to save a byte." 82 | (declare (optimize (speed 3) (safety 1)) (type (unsigned-byte 16) ub16)) 83 | (with-write-storage (storage :offset offset :reserve-bytes (if tag 3 2) :sap sap) 84 | (when tag 85 | (set-sap-ref-8 sap offset tag) 86 | (incf offset)) 87 | (set-sap-ref-16 sap offset ub16))) 88 | 89 | (declaim (inline store-ub32)) 90 | (defun store-ub32 (ub32 storage &optional (tag +ub32-code+)) 91 | "Store an (unsigned-byte 32) value UB32 to STORAGE. If TAG is true will 92 | emit +UB32-CODE+ to STORAGE first. Set TAG NIL if the deserializer will 93 | know from the context that the value is a UB32 to save a byte." 94 | (declare (optimize (speed 3) (safety 1)) (type (unsigned-byte 32) ub32) 95 | (type (or null (unsigned-byte 8)) tag)) 96 | (with-write-storage (storage :offset offset :reserve-bytes (if tag 5 4) :sap sap) 97 | (when tag 98 | (set-sap-ref-8 sap offset tag) 99 | (incf offset)) 100 | (set-sap-ref-32 sap offset ub32))) 101 | -------------------------------------------------------------------------------- /src/array.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-binary-store) 2 | 3 | (defun is-type-specifier-p (type-specifier) 4 | "Returns true if TYPE-SPECIFIER is a valid type specifier." 5 | (or #+sbcl (sb-ext:valid-type-specifier-p type-specifier) 6 | #+ccl (ccl:type-specifier-p type-specifier) 7 | #+ecl (c::valid-type-specifier type-specifier))) 8 | 9 | (defun restore-array (storage restore-object) 10 | (declare (type function restore-object) (optimize (speed 3) (safety 1))) 11 | (let* ((has-fill-pointer (funcall restore-object)) 12 | (fill-pointer (when has-fill-pointer (restore-tagged-unsigned-fixnum storage))) 13 | (adjustable (funcall restore-object)) 14 | (array-rank (the (unsigned-byte 8) (restore-ub8 storage))) 15 | (dimensions (loop repeat array-rank 16 | collect (restore-tagged-unsigned-fixnum storage))) 17 | (displaced (funcall restore-object)) 18 | (array-total-size (if dimensions (reduce #'* dimensions) 0)) 19 | (element-type (funcall restore-object))) 20 | (unless (and (typep array-total-size 'fixnum) (>= array-total-size 0)) 21 | (unexpected-data "Array total size is too large")) 22 | #+ecl 23 | (unless element-type 24 | (unexpected-data "ECL does not support empty arrays with nil element type")) 25 | (unless (is-type-specifier-p element-type) 26 | (unexpected-data "Invalid array element-type")) 27 | (check-if-too-much-data (read-storage-max-to-read storage) array-total-size) 28 | (labels ((check-fill-pointer (dimensions) 29 | (when has-fill-pointer 30 | (unless (= array-rank 1) 31 | (unexpected-data "found fill-pointer for a non-vector")) 32 | (unless (<= fill-pointer (first dimensions)) 33 | (unexpected-data "fill-pointer > vector length"))) 34 | (values))) 35 | (if displaced 36 | (let ((offset (restore-tagged-unsigned-fixnum storage)) 37 | (displaced-to (funcall restore-object))) 38 | (unless (typep displaced-to 'array) 39 | (unexpected-data "displaced to a non array?!")) 40 | (unless (typep (array-element-type displaced-to) element-type) 41 | (unexpected-data "array displaced to array of different element-type")) 42 | (unless (< offset (array-total-size displaced-to)) 43 | (unexpected-data "array displaced to too small array")) 44 | (when has-fill-pointer (check-fill-pointer dimensions)) 45 | (make-array dimensions :element-type element-type :adjustable adjustable 46 | :fill-pointer fill-pointer :displaced-to displaced-to 47 | :displaced-index-offset offset)) 48 | (progn 49 | (when has-fill-pointer (check-fill-pointer dimensions)) 50 | (let ((array 51 | (make-array dimensions :element-type element-type :adjustable adjustable 52 | :fill-pointer fill-pointer))) 53 | ;; We need to make our array first in case any of the array elements refer to it! 54 | ;; If we are ever referred to, then there will already be a fixup in place for 55 | ;; our array handled by `restore-new-reference-indicator'. 56 | (loop for idx fixnum from 0 below array-total-size 57 | do (restore-object-to (row-major-aref array idx) restore-object)) 58 | array)))))) 59 | 60 | (defun store-array (array storage eq-refs store-object assign-new-reference-id) 61 | (declare (optimize speed safety) (type array array) (type function store-object)) 62 | (maybe-store-reference-instead (array storage eq-refs assign-new-reference-id) 63 | #+debug-cbs(format t "~A array of type ~A~%" 64 | (if storage "Storing" "Analyzing") 65 | (type-of array)) 66 | (when storage 67 | (store-ub8/no-tag +array-code+ storage) 68 | (cond 69 | ((array-has-fill-pointer-p array) 70 | (store-t storage) 71 | (store-tagged-unsigned-fixnum (fill-pointer array) storage)) 72 | (t 73 | (store-nil storage))) 74 | (store-boolean (adjustable-array-p array) storage) 75 | (let ((array-dimensions (array-dimensions array))) 76 | (store-ub8/no-tag (length array-dimensions) storage) ;; sbcl limits to 128 77 | (dolist (a array-dimensions) 78 | (store-tagged-unsigned-fixnum (the fixnum a) storage)))) 79 | (multiple-value-bind (next-array offset) 80 | (array-displacement array) 81 | (when storage (store-boolean next-array storage)) 82 | ;; element type may be a reference, so we store it after determining 83 | ;; the array displacement which allows the restore side to register 84 | ;; the reference for the array either as a delayed/fixup or by 85 | ;; creating the actual array. 86 | (let ((elt-type (array-element-type array))) 87 | (if (eq elt-type t) 88 | (when storage (store-t storage)) 89 | (if (symbolp elt-type) 90 | (store-symbol elt-type storage eq-refs store-object assign-new-reference-id) 91 | (funcall store-object elt-type)))) 92 | (cond 93 | (next-array 94 | (when storage 95 | (store-tagged-unsigned-fixnum offset storage)) 96 | (store-array next-array storage eq-refs store-object assign-new-reference-id)) 97 | (t 98 | ;; We have to store the array elements even past the fill pointer 99 | (dotimes (idx (array-total-size array)) 100 | (funcall store-object (row-major-aref array idx)))))))) 101 | -------------------------------------------------------------------------------- /src/cl-binary-store.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :cl-binary-store 2 | (:use :common-lisp 3 | #+sbcl #:sb-mop 4 | #+allegro #:mop 5 | #+abcl #:mop 6 | #+lispworks #:clos 7 | #+clasp #:clos 8 | #+ecl #:clos 9 | #+ccl #:ccl) 10 | (:import-from #:alexandria #:once-only) 11 | (:documentation "A package that exports tools used inside cl-binary-store for use by 12 | someone writing their own specialized serialization or deserialization routine.") 13 | (:export 14 | ;; Complex circularity handling during restore 15 | #:restore-object-to 16 | 17 | ;; Normal circularity handling 18 | #:check/store-reference ; during store 19 | 20 | #:store-boolean 21 | #:store-t 22 | #:store-nil 23 | #:store-ub8/tag 24 | #:store-ub8/no-tag 25 | #:store-ub16 26 | #:store-ub32 27 | #:store-fixnum 28 | #:store-tagged-unsigned-fixnum 29 | #:store-tagged-unsigned-integer 30 | 31 | #:store-double-float 32 | #:restore-double-float 33 | #:restore-double-float-to 34 | #:store-single-float 35 | #:restore-single-float 36 | 37 | #:store-ratio 38 | #:restore-ratio 39 | #:store-bignum 40 | #:restore-bignum 41 | #:store-complex 42 | #:restore-complex 43 | #:store-complex-single-float 44 | #:restore-complex-single-float 45 | #:store-complex-double-float 46 | #:restore-complex-double-float 47 | 48 | #:store-array 49 | #:restore-array 50 | 51 | #+sbcl #:store-simple-specialized-array 52 | #+sbcl #:restore-simple-specialized-array 53 | #+sbcl #:store-simple-specialized-vector 54 | #+sbcl #:restore-simple-specialized-vector 55 | 56 | #:store-string 57 | #:store-string/no-refs 58 | #:restore-string 59 | 60 | #:store-simple-vector 61 | #:restore-simple-vector 62 | 63 | #:store-standard/structure-object 64 | #:restore-standard/structure-object 65 | 66 | #:action 67 | #:action-code 68 | 69 | #:with-pinned-objects 70 | #:vector-sap 71 | 72 | ;; General user interface 73 | #:store 74 | #:restore 75 | ;; Serializing to / from sbcl specific raw memory SAP 76 | #:store-to-sap 77 | #:restore-from-sap 78 | #:replace-store-sap-buffer 79 | #:out-of-space 80 | ;; Streams 81 | #:restore-from-stream 82 | #:store-to-stream 83 | ;; In memory ub8 vectors 84 | #:restore-from-vector 85 | #:store-to-vector 86 | #:store-to-extant-vector 87 | #:out-of-space-in-fixed-vector 88 | 89 | #:out-of-data 90 | #:store-to-file 91 | #:restore-from-file 92 | ;; Support complex circular lists 93 | #:*support-shared-list-structures* 94 | ;; Do any sort of reference tracking 95 | #:*track-references* 96 | ;; Write an end marker 97 | #:*output-end-marker* 98 | 99 | ;; Versioning 100 | #:*write-version* 101 | #:*version-being-read* 102 | #:*output-magic-number* 103 | #:*current-codespace* 104 | 105 | #:out-of-space-current-offset 106 | #:out-of-space-wanted-bytes 107 | 108 | ;; Adding a new type 109 | #:defstore 110 | #:defrestore 111 | #:storage 112 | #:obj 113 | #:store-object 114 | #:restore-object 115 | #:make-end-marker 116 | 117 | ;; Low level stuff for serializing/deserializing data from read-storage-sap and write-storage-sap 118 | #:set-sap-ref-double 119 | #:sap-ref-double 120 | #:set-sap-ref-single 121 | #:sap-ref-single 122 | #:set-signed-sap-ref-64 123 | #:signed-sap-ref-64 124 | #:set-sap-ref-64 125 | #:sap-ref-64 126 | #:set-sap-ref-32 127 | #:sap-ref-32 128 | #:set-sap-ref-16 129 | #:sap-ref-16 130 | #:set-sap-ref-8 131 | #:sap-ref-8 132 | #:ensure-enough-data 133 | #:with-write-storage 134 | #:write-storage-offset 135 | #:read-storage-offset 136 | #:write-storage-sap 137 | #:read-storage-sap 138 | #:write-storage-store 139 | #:read-storage-store 140 | #:copy-sap 141 | 142 | ;; Basic codespace names 143 | #:eq-refs 144 | #:double-float-refs 145 | #:num-eq-refs 146 | #:define-codespace 147 | #:+action-code+ 148 | #:store-action& 149 | #:restore-action& 150 | #:references 151 | #:+basic-codespace+ 152 | #:*read-version* 153 | #:store-symbol 154 | #:restore-symbol 155 | #:assign-new-reference-id 156 | #:*eq-refs-table-size* 157 | #:*double-float-refs-table-size* 158 | #:*num-eq-refs-table-size* 159 | #:implicit-eql-refs 160 | #:implicit-ref-id 161 | 162 | ;; Error if symbol package does not exist and handling the case 163 | #:missing-package-during-restore 164 | #:change-package 165 | #:create-package 166 | 167 | ;; Structure-object or standard-object type does not exist during restore 168 | #:object-type-not-found 169 | #:object-type-not-found-object-info 170 | ;; restarts 171 | #:create-structure-object 172 | #:create-standard-object 173 | #:use-different-class 174 | 175 | ;; Missing slots during restore 176 | #:missing-slot 177 | #:missing-slot-slot-name 178 | #:missing-slot-type 179 | #:missing-slot-data-slots 180 | #:missing-slot-image-slots 181 | ;; Restarts 182 | #:discard 183 | #:map-to-new-slot-name 184 | 185 | ;; A parameter to specialized-object-constructor is an object-info 186 | #:object-info 187 | #:object-info-slot-names 188 | #:object-info-type 189 | 190 | ;; Extensions for modifying object serialization 191 | #:serializable-object-info 192 | #:specialized-object-constructor 193 | #:specialized-serializer/deserializer 194 | 195 | ;; Codespace manipulations 196 | #:delete-restore 197 | #:delete-store 198 | #:delete-codespace 199 | #:*codespaces* 200 | #:*allow-codespace-switching* 201 | #:*max-to-write* 202 | #:*max-to-read* 203 | #:*output-magic-number* 204 | 205 | ;; Conditions 206 | #:invalid-input-data 207 | #:too-much-data 208 | #:maybe-expected-error)) 209 | 210 | 211 | (in-package :cl-binary-store) 212 | 213 | (define-condition invalid-input-data (simple-error) 214 | ()) 215 | 216 | (defun unexpected-data (message &optional (data nil data-provided-p)) 217 | (error 'invalid-input-data 218 | :format-control "~A~A" 219 | :format-arguments (list message 220 | (if data-provided-p 221 | ;; be careful not to provide anything 222 | ;; that cannot be printed trivially here! 223 | (format nil ", found ~A" data) 224 | "")))) 225 | 226 | (define-condition maybe-expected-error (invalid-input-data) 227 | () 228 | (:documentation "Things like MISSING-PACKAGE-DURING-RESTORE, MISSING-SLOT")) 229 | -------------------------------------------------------------------------------- /src/type-discrimination.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-binary-store) 2 | 3 | (defvar *preferred-dispatch-order* 4 | '(cons fixnum symbol single-float double-float vector array structure-object 5 | standard-object bignum t) 6 | "To change this, setf it and call (rebuild-dispatch). 7 | In benchmarking you will see factors of two speed differences by tweaking this 8 | (test-cl-binary-store-on-data (long-list-of-small-integers) :track-references nil)") 9 | 10 | (defun strict-subtype-ordering (type-specs &key (key #'identity) 11 | (type-groups *preferred-dispatch-order*)) 12 | ;; This sort of works, but some weird issues I haven't debugged yet 13 | ;; with the type hierarchy. 14 | ;; We need to order these by subtypep, a simple sort won't work 15 | ;; because we have disjoint sets. So first, we have to sort into 16 | ;; disjoint sets, then sort, then recombine. 17 | (let* ((groups (make-array (length type-groups) :initial-element nil))) 18 | (loop for item in type-specs 19 | do (loop for count below (length type-groups) 20 | for type-group in type-groups 21 | until (subtypep (funcall key item) type-group) 22 | finally 23 | (push item (svref groups count)))) 24 | (loop for g across groups 25 | appending (stable-sort (reverse g) #'subtypep :key key)))) 26 | 27 | 28 | ;; This has to be the most hideous code I've written in awhile, 29 | 30 | (defun binned-disjoint-types (type-specifiers) 31 | "Returns an alist with keys being a type and values being sub-types of the values. 32 | CL-USER> (binned-disjoint-types '(fixnum (unsigned-byte 8) standard-object)) -> 33 | ((STANDARD-OBJECT) (FIXNUM (UNSIGNED-BYTE 8)))" 34 | (loop with bins = nil 35 | while type-specifiers 36 | for new-type = (pop type-specifiers) 37 | do 38 | (push (cons new-type nil) bins) 39 | (let ((bins bins)) 40 | (setf type-specifiers 41 | (loop 42 | with remaining-types = type-specifiers 43 | with bin-definition-changed = t 44 | with bin = (pop bins) 45 | while (and remaining-types bin-definition-changed) 46 | for bin-type = (car bin) 47 | do (setf bin-definition-changed nil) 48 | (setf remaining-types 49 | (loop for type in remaining-types 50 | while type 51 | for type-is-a-subtype-of-bin 52 | = (subtypep type bin-type) 53 | for type-is-a-supertype-of-bin 54 | = (subtypep bin-type type) 55 | when (and type-is-a-supertype-of-bin 56 | type-is-a-subtype-of-bin) 57 | do (error "~A is identical to ~A" 58 | bin-type type) 59 | if type-is-a-supertype-of-bin 60 | do (setf bin-definition-changed t) 61 | (let ((old-super-type (car bin))) 62 | (setf (car bin) type) 63 | (setf bin-type type) 64 | (push old-super-type (cdr bin))) 65 | else 66 | if type-is-a-subtype-of-bin 67 | do (push type (cdr bin)) 68 | else 69 | collect type)) 70 | unless bin-definition-changed 71 | do 72 | (setf bin (pop bins)) 73 | finally (return remaining-types)))) 74 | finally (return bins))) 75 | 76 | (binned-disjoint-types '((unsigned-byte 8) (unsigned-byte 16))) 77 | 78 | (defun satisfies-test (x) (< x 3)) 79 | (deftype satisfies-something () '(satisfies satisfies-test)) 80 | (defstruct another) 81 | (defstruct blarg-td) 82 | (defstruct (includes-blarg-td (:include blarg-td))) 83 | 84 | (defclass class-a () ()) 85 | (defclass class-b (class-a) ()) 86 | (defclass class-c (class-a) ()) 87 | 88 | (defparameter *many-types* 89 | `(real complex ratio integer fixnum 90 | (complex double-float) (complex single-float) 91 | (unsigned-byte 8) (unsigned-byte 16) (unsigned-byte 32) 92 | (unsigned-byte 64) 93 | bignum 94 | standard-object 95 | standard-class 96 | blarg-td 97 | includes-blarg-td 98 | another 99 | satisfies-something 100 | vector 101 | simple-vector 102 | array 103 | simple-array 104 | null 105 | double-float 106 | (eql t) 107 | (simple-array (unsigned-byte 8) (*)) 108 | (simple-array single-float (*)) 109 | (simple-array double-float (*)) 110 | (simple-array fixnum (*)) 111 | (simple-array fixnum *))) 112 | 113 | (defvar *good-top-levels* '(fixnum cons single-float nil simple-vector simple-array vector 114 | array structure-object structure-class t)) 115 | 116 | (defun build-discriminator-tree 117 | (type-specifiers &optional (top-level-type-bins *good-top-levels*)) 118 | (let* ((fixed-bins top-level-type-bins) 119 | (trimmed-type-specifiers (remove-if 120 | (lambda (type) (member type fixed-bins :test 'equal)) 121 | type-specifiers)) 122 | (bins (loop with remaining-types = trimmed-type-specifiers 123 | for bin-type in fixed-bins 124 | for sub-types = (remove-if-not 125 | (lambda (type) 126 | (and (not (eq type bin-type)) (subtypep type bin-type))) 127 | remaining-types) 128 | do (setf remaining-types (remove-if 129 | (lambda (type) (member type sub-types :test 'equal)) 130 | remaining-types)) 131 | collect (cons bin-type sub-types)))) 132 | (labels ((walk (bins) 133 | (loop for (parent-type . sub-types) in bins 134 | collect (cons parent-type (walk (binned-disjoint-types sub-types)))))) 135 | (walk bins)))) 136 | 137 | #+cl-ppcre 138 | (defun analyze-discriminators 139 | (type-specifiers &optional (top-level-type-bins *good-top-levels*)) 140 | "A nice discrimator tree: 141 | (simulate-discriminators *many-types* 142 | '(cons fixnum null (eql t) single-float array number structure-object standard-object t))" 143 | (let ((results (build-discriminator-tree type-specifiers top-level-type-bins))) 144 | (labels ((print-it (bins parent &optional (spacing "") (num-branches 0) 145 | (num-instructions 0) (function-calls 0)) 146 | (loop for (type . sub-types) in bins 147 | for discriminator = `(lambda (x) 148 | (declare 149 | (optimize 150 | (speed 3) (safety 0) (debug 0)) 151 | (type (and ,parent 152 | ,@(loop for fail in failed-types 153 | collect `(not ,fail))) 154 | x)) 155 | (typep x ',type)) 156 | for code 157 | = (with-output-to-string (str) 158 | (disassemble (compile nil discriminator) :stream str)) 159 | do 160 | (incf function-calls (cl-ppcre:count-matches "FDEF" code)) 161 | (incf num-branches (+ (cl-ppcre:count-matches "JEQ" code) 162 | (cl-ppcre:count-matches "JE" code) 163 | (cl-ppcre:count-matches "JB" code) 164 | (cl-ppcre:count-matches "JA" code) 165 | (cl-ppcre:count-matches "JNE" code) 166 | (cl-ppcre:count-matches "CMOV" code))) 167 | (incf num-instructions (count #\Newline code)) 168 | (format t "~A~A ~A compares, ~A instructions, and ~A function-calls~%" 169 | spacing type num-branches num-instructions function-calls) 170 | (print-it sub-types type 171 | (concatenate 'string " " spacing) 172 | num-branches 173 | num-instructions 174 | function-calls) 175 | collect type into failed-types))) 176 | (print-it results t)))) 177 | -------------------------------------------------------------------------------- /src/cons.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-binary-store) 2 | 3 | (defvar *support-shared-list-structures* nil 4 | "If this is T, then circular lists of all types and structures that 5 | share list parts will be serialized correctly. This is very 6 | expensive.") 7 | 8 | ;; There is one trick we play here. If we have *track-references* t 9 | ;; and *support-shared-list-structures* nil then we can determine the 10 | ;; length of every list in advance before writing it out, and can then 11 | ;; write out the list without cons tags. That is a 12 | ;; +finite-length-list+ versus a +cons-code+. This saves a lot of 13 | ;; space. 14 | 15 | (declaim (inline length/detect-dotted)) 16 | (defun length/detect-dotted (list) 17 | "length of a list, returns nil if the list is dotted" 18 | (loop for c on list 19 | for count fixnum from 1 20 | for next = (cdr c) 21 | unless (typep next '(or null cons)) 22 | do (return-from length/detect-dotted count) 23 | finally (return count))) 24 | 25 | (declaim (inline store-cons/indefinite)) 26 | (defun store-cons/indefinite (cons storage eq-refs store-object assign-new-reference-id) 27 | "This is called during the actual storage output phase." 28 | (declare (optimize (speed 3) (safety 0) (debug 0)) 29 | (type write-storage storage) (type function store-object)) 30 | (tagbody start 31 | (when (referenced-already cons storage eq-refs assign-new-reference-id) 32 | (return-from store-cons/indefinite (values))) 33 | (with-write-storage (storage :offset offset :reserve-bytes 1 :sap sap) 34 | (set-sap-ref-8 sap offset +cons-code+)) 35 | (funcall store-object (car cons)) 36 | (let ((cdr (cdr cons))) 37 | (if (consp cdr) 38 | (progn (setf cons cdr) (go start)) 39 | (if (null cdr) 40 | (when storage (store-nil storage)) 41 | (funcall store-object (the (and (not null) (not cons)) cdr))))))) 42 | 43 | (declaim (inline store-cons/finite-length)) 44 | (defun store-cons/finite (cons storage eq-refs store-object assign-new-reference-id list-lengths) 45 | "This is called during the actual storage output phase if we have already computed the list 46 | length. This is not called when *support-shared-list-structures* is true." 47 | (declare (optimize (speed 3) (safety 1)) 48 | (type write-storage storage) (type function store-object)) 49 | (maybe-store-reference-instead (cons storage eq-refs assign-new-reference-id) 50 | (let ((length (or (and list-lengths (gethash cons list-lengths)) 51 | (length/detect-dotted cons)))) 52 | (locally 53 | (declare (type fixnum length)) 54 | (with-write-storage (storage :offset offset :reserve-bytes 1 :sap sap) 55 | (set-sap-ref-8 sap offset +finite-length-list-code+)) 56 | (store-tagged-unsigned-fixnum/interior length storage) 57 | (dotimes (count length) 58 | (cond 59 | ((= count (- length 1)) 60 | (funcall store-object (car cons)) 61 | (let ((cdr (cdr cons))) 62 | (if (null cdr) 63 | (store-nil storage) ;; need to store nil in case last element is dotted 64 | (funcall store-object (cdr cons))))) 65 | (t 66 | (funcall store-object (car cons)) 67 | (setf cons (cdr cons))))))))) 68 | 69 | (declaim (inline search-cons/indefinite)) 70 | (defun search-cons/indefinite (cons references store-object) 71 | "This is only called when *track-references* is t and *support-shared-list-structures* is t." 72 | (declare (optimize (speed 3) (safety 0) (debug 0)) (type function store-object)) 73 | (tagbody start 74 | (when (check-reference cons references) 75 | (return-from search-cons/indefinite (values))) 76 | (funcall store-object (car cons)) 77 | (let ((cdr (cdr cons))) 78 | (if (consp cdr) 79 | (progn 80 | (setf cons cdr) 81 | (go start)) 82 | (funcall store-object cdr))))) 83 | 84 | (declaim (inline store-cons)) 85 | (defun store-cons (cons storage eq-refs store-object assign-new-reference-id list-lengths 86 | support-shared-list-structures) 87 | (if support-shared-list-structures 88 | (store-cons/indefinite cons storage eq-refs store-object assign-new-reference-id) 89 | (store-cons/finite cons storage eq-refs store-object assign-new-reference-id list-lengths))) 90 | 91 | (declaim (inline search-cons/finite)) 92 | (defun search-cons/finite (cons references store-object list-lengths) 93 | "This is called during the reference counting phase and only when we have only very 94 | simple list circularity (CDR (LAST LIST)) -> LIST or another reference list that we 95 | have seen before." 96 | (declare (optimize (speed 3) (safety 0) (debug 0)) (type function store-object)) 97 | (let ((length 1) 98 | (head cons)) 99 | (declare (type fixnum length)) 100 | (unless (check-reference cons references) 101 | (tagbody continue 102 | (setf (gethash head list-lengths) length) 103 | (progn 104 | (funcall store-object (car cons)) 105 | (setf cons (cdr cons)) 106 | (cond 107 | ((not (consp cons)) 108 | (setf (gethash head list-lengths) length) 109 | (funcall store-object cons)) 110 | (t 111 | (truly-the fixnum (incf length)) 112 | (go continue)))))))) 113 | 114 | (declaim (inline search-cons)) 115 | (defun search-cons (cons eq-refs store-object list-lengths support-shared-list-structures) 116 | (if support-shared-list-structures 117 | (search-cons/indefinite cons eq-refs store-object) 118 | (search-cons/finite cons eq-refs store-object list-lengths))) 119 | 120 | (declaim (inline restore-cons/indefinite)) 121 | (defun restore-cons/indefinite (storage restore-object) 122 | (declare (optimize (speed 3) (safety 0) (debug 0))) 123 | (let ((first-cons (cons nil nil))) 124 | (loop 125 | with cons = first-cons 126 | do 127 | (restore-object-to (car cons) restore-object) 128 | (let ((next (restore-ub8 storage))) 129 | (case next 130 | (#.+cons-code+ 131 | (let ((next (cons nil nil))) 132 | (setf (cdr cons) next) 133 | (setf cons next))) 134 | (#.+nil-code+ 135 | (setf (cdr cons) nil) 136 | (return-from restore-cons/indefinite first-cons)) 137 | (t 138 | (restore-object-to (cdr cons) restore-object next) 139 | (return-from restore-cons/indefinite first-cons))))))) 140 | 141 | (declaim (inline restore-list/known-length)) 142 | (defun restore-list/known-length (storage restore-object) 143 | (declare (optimize (speed 3) (safety 0))) 144 | (let* ((length (restore-tagged-unsigned-fixnum/interior storage))) 145 | (unless (and (<= 0 length (ash most-positive-fixnum -4)) 146 | (<= 147 | (ash length 4) 148 | (truly-the fixnum 149 | (- (read-storage-max-to-read storage) (read-storage-total-read storage))))) 150 | (error 'too-much-data :max-bytes (read-storage-max-to-read storage) 151 | :bytes (+ (ash length 4) (read-storage-total-read storage)))) 152 | (when (> length 0) 153 | (let* ((head (make-list length)) 154 | (cons head)) 155 | (dotimes (count (1- length)) 156 | (restore-object-to (car cons) restore-object) 157 | (setf cons (cdr cons))) 158 | ;; Support dotted end of list 159 | (restore-object-to (car cons) restore-object) 160 | (restore-object-to (cdr cons) restore-object) 161 | head)))) 162 | -------------------------------------------------------------------------------- /src/basic-codespace.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-binary-store) 2 | 3 | #+allegro 4 | (eval-when (:compile-toplevel) 5 | (declaim (optimize (speed 3) (safety 1) 6 | (space 0) (debug 0) (compilation-speed 0)))) 7 | 8 | (defvar *eq-refs-table-size* 7 9 | "A hint for the starting size of the object tracking hash table used for most objects") 10 | (defvar *double-float-refs-table-size* 7 11 | "A hint for the starting size of the double float tracking reference table") 12 | (defvar *num-eq-refs-table-size* 7 13 | "A hint for the starting size of the hash table tracking misc number types 14 | (complex, ratios, bignums)") 15 | 16 | (defconstant +basic-codespace+ #x0001 17 | "This is the basic codespace of cl-binary-store.") 18 | 19 | ;; Enable debug to get source code saved to a file so the debugger does the right thing 20 | (define-codespace ("basic codespace" +basic-codespace+ :debug nil) 21 | (register-references num-eq-refs (make-hash-table :test #'eq :size *num-eq-refs-table-size*)) 22 | (register-references 23 | double-float-refs (make-hash-table :test #+sbcl #'double-float-= #-sbcl #'eql 24 | :size *double-float-refs-table-size*)) 25 | (register-references eq-refs (make-hash-table :test #'eq :size *eq-refs-table-size*)) 26 | (register-global-state list-lengths (make-hash-table :test #'eq) :store t) 27 | (register-global-state support-shared-list-structures 28 | (progn 29 | (when *support-shared-list-structures* 30 | (assert *track-references* nil 31 | "To use *support-shared-list-structures* you must have ~ 32 | *track-references* t")) 33 | *support-shared-list-structures*) 34 | :store t) 35 | 36 | (register-global-state object-info (make-hash-table :test #'eq) 37 | :type hash-table :dynamic-extent t :store t 38 | :documentation 39 | "An eql hash table which maps from structure-object or standard-class 40 | type name to a `object-info' structure. This is bound locally during 41 | operation of store-objects. During restore we use the reference tables") 42 | 43 | (register-global-state implicit-eql-refs (make-hash-table :test #'eql) :dynamic-extent t 44 | :store t :restore t :documentation "When *track-references* is nil, 45 | still want to do some reference tracking. To do that we use this 46 | implicit-eql-refs table and the assign-new-reference-id function. 47 | This is used for `object-info's.") 48 | 49 | (register-global-state implicit-ref-id (cons 0 nil) :type (cons fixnum null) 50 | :dynamic-extent t :restore t :store t 51 | :documentation "A counter used during store and restore for implicit 52 | reference id labelling even if *track-references* is nil.") 53 | 54 | (defstore fixnum (store-fixnum obj storage) :call-during-reference-phase nil) 55 | (defrestore +ub8-code+ (restore-ub8 storage)) 56 | (defrestore +ub16-code+ (restore-ub16 storage)) 57 | (defrestore +ub32-code+ (restore-ub32 storage)) 58 | (defrestore +fixnum-code+ (restore-fixnum storage)) 59 | (defrestore +sb8-code+ (restore-sb8 storage)) 60 | (defrestore +sb16-code+ (restore-sb16 storage)) 61 | (defrestore +sb32-code+ (restore-sb32 storage)) 62 | 63 | (defstore bignum (store-bignum obj storage) :check-for-ref-in num-eq-refs 64 | :call-during-reference-phase nil) 65 | (defrestore +bignum-code+ (restore-bignum storage)) 66 | 67 | (defstore single-float (store-single-float obj storage) :call-during-reference-phase nil) 68 | (defrestore +single-float-code+ (restore-single-float storage)) 69 | 70 | (defstore double-float 71 | (store-double-float obj storage double-float-refs assign-new-reference-id)) 72 | (defrestore +double-float-code+ (restore-double-float storage)) 73 | (defrestore +double-float-zero-code+ (restore-double-float-zero)) 74 | 75 | (defstore ratio (store-ratio obj storage num-eq-refs assign-new-reference-id)) 76 | (defrestore +ratio-code+ (restore-ratio restore-object)) 77 | 78 | (defstore complex (store-complex obj storage store-object) :check-for-ref-in num-eq-refs) 79 | (defrestore +complex-code+ (restore-complex restore-object)) 80 | (defrestore +complex-double-float-code+ (restore-complex-double-float storage)) 81 | (defrestore +complex-single-float-code+ (restore-complex-single-float storage)) 82 | 83 | ;; CONS 84 | 85 | (defstore cons (store-cons obj storage eq-refs store-object assign-new-reference-id 86 | list-lengths support-shared-list-structures) 87 | :call-during-reference-phase (search-cons obj eq-refs store-object list-lengths 88 | support-shared-list-structures)) 89 | 90 | (defrestore +cons-code+ (restore-cons/indefinite storage restore-object)) 91 | (defrestore +finite-length-list-code+ (restore-list/known-length storage restore-object)) 92 | 93 | ;; T and NIL (STORED DISJOINT FROM SYMBOLS) 94 | 95 | (defstore null (store-nil storage) :call-during-reference-phase nil) 96 | (defrestore +nil-code+ (restore-nil)) 97 | (defstore (eql t) (store-t storage) :call-during-reference-phase nil) 98 | (defrestore +t-code+ (restore-t)) 99 | 100 | ;; INTERNED SYMBOLS / KEYWORDS / UNINTERNED SYMBOLS 101 | (defstore (and symbol (not null) (not (eql t))) 102 | (store-symbol obj storage eq-refs store-object assign-new-reference-id)) 103 | (defrestore +symbol-code+ (restore-symbol storage restore-object)) 104 | (defrestore +uninterned-symbol-code+ (restore-uninterned-symbol storage)) 105 | 106 | ;; STRUCTURE-OBJECTS (defstruct) and STANDARD-CLASS (defclass) 107 | ;; We use two defstore lines to help with the typecase dispatch 108 | 109 | (defstore structure-object (store-standard/structure-object 110 | obj storage eq-refs store-object assign-new-reference-id nil 111 | object-info implicit-eql-refs implicit-ref-id)) 112 | (defstore standard-object (store-standard/structure-object 113 | obj storage eq-refs store-object assign-new-reference-id t 114 | object-info implicit-eql-refs implicit-ref-id)) 115 | ;; On sbcl a condition is neither a structure-object nor a standard-object 116 | #+sbcl 117 | (defstore condition (store-standard/structure-object 118 | obj storage eq-refs store-object assign-new-reference-id t 119 | object-info implicit-eql-refs implicit-ref-id)) 120 | 121 | (defrestore +standard/structure-object-code+ 122 | (restore-standard/structure-object storage restore-object)) 123 | 124 | ;; REFERENCES 125 | ;; direct integer encoding [-16 16] in the tag byte 126 | (defrestore (<= +first-small-integer-code+ code +last-small-integer-code+) 127 | (truly-the fixnum (- (truly-the (unsigned-byte 8) code) +small-integer-zero-code+))) 128 | ;; small refs in the tag byte from [1 30] 129 | (defrestore (<= +first-direct-reference-id-code+ code +last-direct-reference-id-code+) 130 | (restore-reference (decode-reference-direct code) references)) 131 | ;; 64 - 127 14 bit references (tag byte plus another byte) 132 | (defrestore (<= +first-one-byte-reference-id-code+ code +last-one-byte-reference-id-code+) 133 | (restore-reference (decode-reference-one-byte code (restore-ub8 storage)) references)) 134 | ;; 128 - 191 22 bit references (tag byte plus another two bytes) 135 | (defrestore (<= +first-two-byte-reference-id-code+ code +last-two-byte-reference-id-code+) 136 | (restore-reference (decode-reference-two-bytes code (restore-ub16 storage)) references)) 137 | ;; Anything more than that uses a fully tagged integer code subtracting off 138 | (defrestore +tagged-reference-code+ 139 | (restore-reference (decode-reference-tagged (funcall restore-object)) references)) 140 | (defrestore +new-reference-indicator-code+ 141 | (restore-new-reference-indicator references restore-object)) 142 | 143 | ;; SIMPLE VECTORS 144 | (defstore (simple-array * (*)) (store-simple-specialized-vector obj storage) :check-for-ref-in eq-refs) 145 | (defrestore +simple-specialized-vector-code+ (restore-simple-specialized-vector storage)) 146 | 147 | (defstore simple-vector (store-simple-vector obj storage store-object) :check-for-ref-in eq-refs) 148 | (defrestore +simple-vector-code+ (restore-simple-vector storage restore-object)) 149 | 150 | ;; SIMPLE ARRAYS 151 | #+sbcl 152 | (defstore (and (simple-array * *) (not (simple-array t *))) 153 | (store-simple-specialized-array obj storage) :check-for-ref-in eq-refs :call-during-reference-phase nil) 154 | #+sbcl 155 | (defrestore +simple-specialized-array-code+ (restore-simple-specialized-array storage)) 156 | 157 | ;; COMPLEX VECTORS AND ARRAYS 158 | (defstore array (store-array obj storage eq-refs store-object assign-new-reference-id)) 159 | (defrestore +array-code+ (restore-array storage restore-object)) 160 | 161 | (defstore object-info (store-object-info obj storage eq-refs store-object implicit-eql-refs assign-new-reference-id)) 162 | (defrestore +object-info-code+ (restore-object-info storage restore-object implicit-eql-refs 163 | implicit-ref-id)) 164 | 165 | ;; UNBOUND MARKER 166 | (defrestore +unbound-code+ (restore-unbound)) 167 | 168 | ;; PATHNAMES 169 | (defstore pathname (store-pathname obj store-object) 170 | :check-for-ref-in eq-refs :write-phase-code +pathname-code+) 171 | (defrestore +pathname-code+ (restore-pathname restore-object)) 172 | 173 | ;; HASH-TABLE 174 | (defstore hash-table (store-hash-table obj storage store-object) :check-for-ref-in eq-refs) 175 | (defrestore +hash-table-code+ (restore-hash-table storage restore-object)) 176 | 177 | ;; STRINGS 178 | ;; I made a mess of internal dispatch around this so have to clean it up to take advantage of check-for-ref-in. 179 | ;; TODO clean this up 180 | (defstore simple-base-string (store-simple-base-string obj storage) :check-for-ref-in eq-refs 181 | :call-during-reference-phase nil) 182 | (defrestore +simple-base-string-code+ (restore-simple-base-string storage)) 183 | 184 | (defstore simple-string (store-simple-string obj storage) 185 | :check-for-ref-in eq-refs 186 | :call-during-reference-phase nil) 187 | (defrestore +simple-string-code+ (restore-simple-string storage)) 188 | 189 | (defstore action (store-action& obj storage store-object)) 190 | (defrestore +action-code+ (restore-action& storage references restore-object))) 191 | -------------------------------------------------------------------------------- /src/sap-ref.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-binary-store) 2 | 3 | ;; Functions to access foreign memory and set it from lisp values or 4 | ;; read into lisp values. Uses SBCL stuff for SBCL, CFFI for other 5 | ;; impls, and some other work around. Here we provide an interface 6 | ;; for accessing unaligned 8, 16, 32, 64 unsigned bits and 32, 64 7 | ;; signed bits, and unaligned single-floats and double-floats. 8 | 9 | ;; Some not so smart compilers require me to write macros instead of just functions 10 | ;; SBCL makes this so much easier, but... has to be fast for other impls too 11 | ;; Allegro only allows aligned memory accesses with CFFI, so we have to work around it 12 | 13 | (defmacro set-sap-ref-8 (sap offset ub8) 14 | #+sbcl `(setf (sb-sys:sap-ref-8 ,sap ,offset) ,ub8) 15 | #-sbcl `(setf (cffi:mem-ref ,sap :uint8 ,offset) ,ub8)) 16 | 17 | (defmacro set-sap-ref-16 (sap offset ub16) 18 | #+sbcl `(setf (sb-sys:sap-ref-16 ,sap ,offset) ,ub16) 19 | #-(or sbcl allegro) `(setf (cffi:mem-ref ,sap :uint16 ,offset) ,ub16) 20 | #+allegro 21 | (alexandria:once-only (offset ub16) 22 | `(progn 23 | (setf (cffi:mem-ref ,sap :uint8 ,offset) (logand ,ub16 #xFF)) 24 | (setf (cffi:mem-ref ,sap :uint8 (+ ,offset 1)) (ash ,ub16 -8))))) 25 | 26 | (defmacro set-sap-ref-32 (sap offset ub32) 27 | #+sbcl `(setf (sb-sys:sap-ref-32 ,sap ,offset) ,ub32) 28 | #-(or sbcl allegro) `(setf (cffi:mem-ref ,sap :uint32 ,offset) ,ub32) 29 | #+allegro 30 | (alexandria:once-only (offset ub32) 31 | `(progn 32 | (setf (cffi:mem-ref ,sap :uint8 ,offset) (logand ,ub32 #xFF)) 33 | (setf (cffi:mem-ref ,sap :uint8 (+ ,offset 1)) (logand (ash ,ub32 -8) #xFF)) 34 | (setf (cffi:mem-ref ,sap :uint8 (+ ,offset 2)) (logand (ash ,ub32 -16) #xFF)) 35 | (setf (cffi:mem-ref ,sap :uint8 (+ ,offset 3)) (ash ,ub32 -24))))) 36 | 37 | (defmacro set-sap-ref-64 (sap offset ub64) 38 | #+sbcl `(setf (sb-sys:sap-ref-64 ,sap ,offset) ,ub64) 39 | #-(or sbcl allegro) `(setf (cffi:mem-ref ,sap :uint64 ,offset) ,ub64) 40 | #+allegro 41 | (alexandria:once-only (sap offset ub64) 42 | `(progn (setf (cffi:mem-ref ,sap :uint8 (+ ,offset 0)) (logand (ash ,ub64 0) #xFF)) 43 | (setf (cffi:mem-ref ,sap :uint8 (+ ,offset 1)) (logand (ash ,ub64 -8) #xFF)) 44 | (setf (cffi:mem-ref ,sap :uint8 (+ ,offset 2)) (logand (ash ,ub64 -16) #xFF)) 45 | (setf (cffi:mem-ref ,sap :uint8 (+ ,offset 3)) (logand (ash ,ub64 -24) #xFF)) 46 | (setf (cffi:mem-ref ,sap :uint8 (+ ,offset 4)) (logand (ash ,ub64 -32) #xFF)) 47 | (setf (cffi:mem-ref ,sap :uint8 (+ ,offset 5)) (logand (ash ,ub64 -40) #xFF)) 48 | (setf (cffi:mem-ref ,sap :uint8 (+ ,offset 6)) (logand (ash ,ub64 -48) #xFF)) 49 | (setf (cffi:mem-ref ,sap :uint8 (+ ,offset 7)) (ash ,ub64 -56))))) 50 | 51 | ;; Have to do this silliness because there are some very bad compilers out there 52 | (defmacro sap-ref-8 (sap offset) 53 | #+sbcl `(sb-sys:sap-ref-8 ,sap ,offset) 54 | #-sbcl `(cffi:mem-ref ,sap :uint8 ,offset)) 55 | 56 | (defmacro sap-ref-16 (sap offset) 57 | #+sbcl `(sb-sys:sap-ref-16 ,sap ,offset) 58 | #-(or sbcl allegro) `(cffi:mem-ref ,sap :uint16 ,offset) 59 | #+allegro 60 | (alexandria:once-only (sap offset) 61 | `(+ (ash (cffi:mem-ref ,sap :uint8 ,offset) 0) 62 | (ash (cffi:mem-ref ,sap :uint8 (+ ,offset 1)) 8)))) 63 | 64 | (defmacro sap-ref-32 (sap offset) 65 | #+sbcl `(sb-sys:sap-ref-32 ,sap ,offset) 66 | #-(or sbcl allegro) `(cffi:mem-ref ,sap :uint32 ,offset) 67 | #+allegro 68 | (alexandria:once-only (sap offset) 69 | `(+ (ash (cffi:mem-ref ,sap :uint8 ,offset) 0) 70 | (ash (cffi:mem-ref ,sap :uint8 (+ ,offset 1)) 8) 71 | (ash (cffi:mem-ref ,sap :uint8 (+ ,offset 2)) 16) 72 | (ash (cffi:mem-ref ,sap :uint8 (+ ,offset 3)) 24)))) 73 | 74 | (defmacro sap-ref-64 (sap offset) 75 | #+sbcl `(sb-sys:sap-ref-64 ,sap ,offset) 76 | #-(or sbcl allegro) `(cffi:mem-ref ,sap :uint64 ,offset) 77 | #+allegro 78 | (alexandria:once-only (sap offset) 79 | `(+ (ash (cffi:mem-ref ,sap :uint8 ,offset) 0) 80 | (ash (cffi:mem-ref ,sap :uint8 (+ ,offset 1)) 8) 81 | (ash (cffi:mem-ref ,sap :uint8 (+ ,offset 2)) 16) 82 | (ash (cffi:mem-ref ,sap :uint8 (+ ,offset 3)) 24) 83 | (ash (cffi:mem-ref ,sap :uint8 (+ ,offset 4)) 32) 84 | (ash (cffi:mem-ref ,sap :uint8 (+ ,offset 5)) 40) 85 | (ash (cffi:mem-ref ,sap :uint8 (+ ,offset 6)) 48) 86 | (ash (cffi:mem-ref ,sap :uint8 (+ ,offset 7)) 56)))) 87 | 88 | (defmacro sap-ref-double (sap offset) 89 | #+sbcl `(sb-sys:sap-ref-double ,sap ,offset) 90 | #-(or sbcl allegro) `(cffi:mem-ref ,sap :double ,offset) 91 | #+allegro 92 | (alexandria:once-only (sap offset) 93 | `(excl:shorts-to-double-float 94 | (sap-ref-16 ,sap (+ ,offset 6)) 95 | (sap-ref-16 ,sap (+ ,offset 4)) 96 | (sap-ref-16 ,sap (+ ,offset 2)) 97 | (sap-ref-16 ,sap (+ ,offset 0))))) 98 | 99 | (defmacro set-sap-ref-double (sap offset double) 100 | #+sbcl `(setf (sb-sys:sap-ref-double ,sap ,offset) ,double) 101 | #-(or sbcl allegro) `(setf (cffi:mem-ref ,sap :double ,offset) ,double) 102 | #+allegro 103 | (alexandria:once-only (double sap offset) 104 | (alexandria:with-gensyms (s3 s2 s1 s0) 105 | `(multiple-value-bind (,s3 ,s2 ,s1 ,s0) 106 | (excl:double-float-to-shorts ,double) 107 | (set-sap-ref-16 ,sap ,offset ,s0) 108 | (set-sap-ref-16 ,sap (+ ,offset 2) ,s1) 109 | (set-sap-ref-16 ,sap (+ ,offset 4) ,s2) 110 | (set-sap-ref-16 ,sap (+ ,offset 6) ,s3))))) 111 | 112 | (defmacro sap-ref-single (sap offset) 113 | #+sbcl `(sb-sys:sap-ref-single ,sap ,offset) 114 | #-(or sbcl allegro) `(cffi:mem-ref ,sap :float ,offset) 115 | #+allegro 116 | (alexandria:once-only (sap offset) 117 | `(excl:shorts-to-single-float 118 | (sap-ref-16 ,sap (+ ,offset 2)) 119 | (sap-ref-16 ,sap (+ ,offset 0))))) 120 | 121 | (defmacro set-sap-ref-single (sap offset single-float) 122 | #+sbcl `(setf (sb-sys:sap-ref-single ,sap ,offset) ,single-float) 123 | #-(or sbcl allegro) `(setf (cffi:mem-ref ,sap :float ,offset) ,single-float) 124 | #+allegro 125 | (alexandria:once-only (sap offset single-float) 126 | (alexandria:with-gensyms (s1 s0) 127 | `(multiple-value-bind (,s1 ,s0) 128 | (excl:single-float-to-shorts ,single-float) 129 | (set-sap-ref-16 ,sap ,offset ,s0) 130 | (set-sap-ref-16 ,sap (+ ,offset 2) ,s1))))) 131 | 132 | (defmacro mask-signed (x size) 133 | "Re-interpret a SIZE bit lisp number as if it were a signed twos complement number" 134 | (alexandria:once-only (x) 135 | `(logior ,x (- (mask-field (byte 1 (1- ,size)) ,x))))) 136 | 137 | (defmacro negative-to-twos-complement/8 (x) 138 | (alexandria:once-only (x) 139 | `(progn 140 | (assert (< ,x 0)) 141 | (logand (+ 1 (logxor (- ,x) #xFF)) #xFF)))) 142 | 143 | (defmacro negative-to-twos-complement/16 (x) 144 | (alexandria:once-only (x) 145 | `(progn 146 | (assert (< ,x 0)) 147 | (logand (+ 1 (logxor (- ,x) #xFFFF)) #xFFFF)))) 148 | 149 | (defmacro negative-to-twos-complement/32 (x) 150 | (alexandria:once-only (x) 151 | `(progn 152 | (assert (< ,x 0)) 153 | (logand (+ 1 (logxor (- ,x) #xFFFFFFFF)) #xFFFFFFFF)))) 154 | 155 | (defmacro negative-to-twos-complement/64 (x) 156 | (alexandria:once-only (x) 157 | `(progn 158 | (assert (< ,x 0)) 159 | (logand (+ 1 (logxor (- ,x) #xFFFFFFFFFFFFFFFF)) #xFFFFFFFFFFFFFFFF)))) 160 | 161 | (defmacro signed-sap-ref-8 (sap offset) 162 | #+sbcl `(sb-sys:signed-sap-ref-8 ,sap ,offset) 163 | #-(or sbcl allegro) `(cffi:mem-ref ,sap :int8 ,offset) 164 | #+allegro `(mask-signed (sap-ref-8 ,sap ,offset) 8)) 165 | 166 | (defmacro signed-sap-ref-16 (sap offset) 167 | #+sbcl `(sb-sys:signed-sap-ref-16 ,sap ,offset) 168 | #-(or sbcl allegro) `(cffi:mem-ref ,sap :int16 ,offset) 169 | #+allegro `(mask-signed (sap-ref-16 ,sap ,offset) 16)) 170 | 171 | (defmacro signed-sap-ref-32 (sap offset) 172 | #+sbcl `(sb-sys:signed-sap-ref-32 ,sap ,offset) 173 | #-(or sbcl allegro) `(cffi:mem-ref ,sap :int32 ,offset) 174 | #+allegro `(mask-signed (sap-ref-32 ,sap ,offset) 32)) 175 | 176 | (defmacro signed-sap-ref-64 (sap offset) 177 | #+sbcl `(sb-sys:signed-sap-ref-64 ,sap ,offset) 178 | #-(or sbcl allegro) `(cffi:mem-ref ,sap :int64 ,offset) 179 | #+allegro `(mask-signed (sap-ref-64 ,sap ,offset) 64)) 180 | 181 | (defmacro set-signed-sap-ref-8 (sap offset value) 182 | #+sbcl `(setf (sb-sys:signed-sap-ref-8 ,sap ,offset) ,value) 183 | #-(or sbcl allegro) `(setf (cffi:mem-ref ,sap :int8 ,offset) ,value) 184 | #+allegro 185 | (alexandria:once-only (sap offset value) 186 | ` (set-sap-ref-8 ,sap ,offset 187 | (if (< ,value 0) 188 | (negative-to-twos-complement/8 ,value) 189 | ,value)))) 190 | 191 | (defmacro set-signed-sap-ref-16 (sap offset value) 192 | #+sbcl `(setf (sb-sys:signed-sap-ref-16 ,sap ,offset) ,value) 193 | #-(or sbcl allegro) `(setf (cffi:mem-ref ,sap :int16 ,offset) ,value) 194 | #+allegro 195 | (alexandria:once-only (sap offset value) 196 | ` (set-sap-ref-16 ,sap ,offset 197 | (if (< ,value 0) 198 | (negative-to-twos-complement/16 ,value) 199 | ,value)))) 200 | 201 | (defmacro set-signed-sap-ref-32 (sap offset value) 202 | #+sbcl `(setf (sb-sys:signed-sap-ref-32 ,sap ,offset) ,value) 203 | #-(or sbcl allegro) `(setf (cffi:mem-ref ,sap :int32 ,offset) ,value) 204 | #+allegro 205 | (alexandria:once-only (sap offset value) 206 | ` (set-sap-ref-32 ,sap ,offset 207 | (if (< ,value 0) 208 | (negative-to-twos-complement/32 ,value) 209 | ,value)))) 210 | 211 | (defmacro set-signed-sap-ref-64 (sap offset value) 212 | #+sbcl `(setf (sb-sys:signed-sap-ref-64 ,sap ,offset) ,value) 213 | #-(or sbcl allegro) `(setf (cffi:mem-ref ,sap :int64 ,offset) ,value) 214 | #+allegro 215 | (alexandria:once-only (sap offset value) 216 | ` (set-sap-ref-64 ,sap ,offset 217 | (if (< ,value 0) 218 | (negative-to-twos-complement/64 ,value) 219 | ,value)))) 220 | 221 | (defmacro array-sap (array) 222 | "Return a pointer referring to the backing store of an array (on sbcl)" 223 | (declare (ignorable array)) 224 | #+sbcl 225 | (let ((g (gensym))) 226 | `(sb-kernel:with-array-data ((,g ,array) (start) (end)) 227 | (declare (ignore end)) 228 | (assert (zerop start)) 229 | (with-pinned-objects (,g) 230 | (vector-sap ,g)))) 231 | #-sbcl 232 | (error "unimplemented")) 233 | 234 | (defmacro with-pinned-objects ((&rest objects) &body body) 235 | (declare (ignorable objects)) 236 | #+sbcl 237 | `(sb-sys:with-pinned-objects ,objects 238 | ,@body) 239 | #-sbcl `(progn ,@body)) 240 | 241 | (defmacro vector-sap (vector) 242 | "On sbcl, return a SAP referring to the backing store of vector" 243 | (declare (ignorable vector)) 244 | #+sbcl `(sb-sys:vector-sap ,vector) 245 | #-sbcl (error "unimplemented")) 246 | -------------------------------------------------------------------------------- /src/user.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-binary-store) 2 | 3 | ;; User facing interface is generally just `restore' and `store' except 4 | ;; for SAPs which would be `restore-from-sap' `store-to-sap' and `replace-store-sap-buffer' 5 | 6 | (defvar *output-magic-number* nil 7 | "If T we will write out a magic number and *write-version* to the output, which will be 8 | validated against our existing *codespaces* when we read it back.") 9 | 10 | (defvar *read-version* #x0001 11 | "The default codespace version to use if no versioning information is in the stream") 12 | 13 | ;;; STREAMS 14 | 15 | (defun store-to-stream (stream &rest elements) 16 | (declare (dynamic-extent elements) (optimize speed safety)) 17 | (let ((*current-codespace* (or *current-codespace* (gethash *write-version* *codespaces*)))) 18 | (with-storage/write (storage :flusher (make-write-into-storage/stream stream)) 19 | (apply #'store-objects storage elements) 20 | (values)))) 21 | 22 | (defun restore-from-stream (stream) 23 | (declare (optimize speed safety)) 24 | (let ((*current-codespace* (or *current-codespace* (gethash *read-version* *codespaces*)))) 25 | (with-storage/read (storage :flusher (make-read-into-storage/stream stream) :max 0 :buffer-size 32768) 26 | (restore-objects storage)))) 27 | 28 | ;;; UB8 VECTORS 29 | 30 | (defun store-to-vector (&rest elements) 31 | (declare (dynamic-extent elements) (optimize speed safety)) 32 | "Returns an (array (unsigned-byte 8) (*)) with the data" 33 | (let* ((output-vector (make-array 16 :element-type '(unsigned-byte 8) :fill-pointer 0 34 | :adjustable t)) 35 | (*current-codespace* (or *current-codespace* (gethash *write-version* *codespaces*)))) 36 | (with-storage/write (storage :flusher (make-write-into-adjustable-ub8-vector output-vector)) 37 | (apply #'store-objects storage elements) 38 | output-vector))) 39 | 40 | (defun store-to-extant-vector (vector &rest data) 41 | (declare (optimize (speed 3) (safety 1))) 42 | (let* ((*current-codespace* (or *current-codespace* (gethash *write-version* *codespaces*))) 43 | (offset 0) 44 | ;; We cannot pin objects on other lisps, so copy in those cases 45 | (is-simple-octet-array #+sbcl (typep vector '(simple-array (unsigned-byte 8) (*))) #-sbcl nil) 46 | (is-adjustable (adjustable-array-p vector)) 47 | (vector-len (length vector)) 48 | (flusher 49 | (cond 50 | (is-simple-octet-array 51 | (lambda (storage) (write-storage-offset storage))) 52 | (is-adjustable 53 | (make-write-into-adjustable-ub8-vector vector)) 54 | (t 55 | (lambda (storage) 56 | #+dribble-cbs(format t "Flusher called with vector-len ~A, offset ~A and write-storage-offset ~A~%" vector-len offset (write-storage-offset storage)) 57 | (assert (>= (- vector-len offset) 58 | (write-storage-offset storage)) 59 | nil 60 | 'out-of-space 61 | :current-offset offset 62 | :wanted-bytes (write-storage-offset storage)) 63 | #+dribble-cbs(format t "Copying into storage vector from temp array~%") 64 | #+dribble-cbs(format t "Storage-vector being written from ~A to ~A from write-storage-store of ~A to ~A~%" 65 | offset (+ offset (write-storage-offset storage)) 0 (write-storage-offset storage)) 66 | (replace vector (write-storage-store storage) 67 | :start1 offset :start2 0 68 | :end2 (write-storage-offset storage)) 69 | (incf offset (write-storage-offset storage)) 70 | (setf (write-storage-offset storage) 0)))))) 71 | (declare (dynamic-extent flusher) (type fixnum vector-len offset)) 72 | (labels ((store (storage) 73 | (apply #'store-objects storage data) 74 | (if is-simple-octet-array 75 | (write-storage-offset storage) 76 | offset))) 77 | (cond 78 | (is-simple-octet-array 79 | (with-pinned-objects (vector) ;; does nothing on #-sbcl 80 | (with-storage/write (storage :flusher flusher :store vector) 81 | (store storage)))) 82 | (t 83 | (with-storage/write (storage :flusher flusher) 84 | (store storage))))))) 85 | 86 | (defun restore-from-vector (vector) 87 | (declare (optimize speed safety)) 88 | #+debug-cbs(format t "Restoring from a vector with ~A bytes in it~%" (length vector)) 89 | (let ((*current-codespace* (or *current-codespace* (gethash *read-version* *codespaces*)))) 90 | ;; Cannot read/write 91 | (if #+sbcl (typep vector '(simple-array (unsigned-byte 8) (*))) #-sbcl nil 92 | (with-storage/read (storage 93 | :flusher 94 | (lambda (storage) 95 | (the fixnum (- (read-storage-max storage) 96 | (read-storage-offset storage)))) 97 | :store vector :max (length vector)) 98 | (restore-objects storage)) 99 | (flexi-streams:with-input-from-sequence (str vector) 100 | (with-storage/read (storage :flusher (make-read-into-storage/stream str) :max 0) 101 | (restore-objects storage)))))) 102 | 103 | ;;; SAP vectors 104 | 105 | (defun replace-store-sap-buffer (sap &key (sap-size 0) (sap-offset 0)) 106 | (invoke-restart 'replace-storage sap sap-size sap-offset)) 107 | 108 | (defun store-to-sap (sap size &rest data) 109 | "This may error with `out-of-space' (which contains 110 | out-of-space-current-offset and out-of-space-wanted-bytes). The 111 | out-of-space-current-offset is the amount of data that has been 112 | written so far. out-of-space-wanted-bytes is not useful unless you 113 | happen to be writing very large stuff as it will likely be a small 114 | number representing the immediate need. Best to allocate a big chunk 115 | and when this finally returns we return the amount of data we wrote 116 | to the chunk. Call (replace-store-sap-buffer sap sap-offset) in a 117 | handler-bind to do this updating. See test test-sap-write/read for 118 | an example." 119 | (let ((*current-codespace* (or *current-codespace* (gethash *write-version* *codespaces*))) 120 | (store (make-array 0 :element-type '(unsigned-byte 8)))) 121 | (declare (dynamic-extent store)) 122 | (with-storage/write (storage :flusher (lambda (storage) (write-storage-offset storage)) 123 | :sap sap :store store :max size :buffer-size nil) 124 | (apply #'store-objects storage data) 125 | (write-storage-offset storage)))) 126 | 127 | (defun restore-from-sap (sap size) 128 | (declare (optimize speed safety)) 129 | (let ((*current-codespace* (or *current-codespace* (gethash *read-version* *codespaces*))) 130 | (store (make-array 0 :element-type '(unsigned-byte 8)))) 131 | (declare (dynamic-extent store)) 132 | (with-storage/read (storage :flusher 133 | (lambda (storage) 134 | (the fixnum (- (read-storage-max storage) 135 | (read-storage-offset storage)))) 136 | :sap sap :max size :store store :buffer-size nil :size 0) 137 | (values (restore-objects storage))))) 138 | 139 | ;;; FILES 140 | 141 | (defun store-to-file (filename &rest elements) 142 | (declare (optimize speed safety)) 143 | (let ((*current-codespace* (or *current-codespace* (gethash *write-version* *codespaces*)))) 144 | (with-open-file (str filename :direction :output 145 | :if-exists :supersede 146 | :element-type '(unsigned-byte 8)) 147 | (with-storage/write (storage :flusher (make-write-into-storage/stream str)) 148 | (apply #'store-objects storage elements))) 149 | filename)) 150 | 151 | (defun restore-from-file (filename) 152 | (declare (optimize speed safety)) 153 | (let ((*current-codespace* (or *current-codespace* (gethash *read-version* *codespaces*)))) 154 | (with-open-file (str filename :direction :input :element-type '(unsigned-byte 8)) 155 | (with-storage/read (storage :flusher (make-read-into-storage/stream str) :max 0 156 | :stream str) 157 | (restore-objects storage))))) 158 | 159 | ;;; General interface 160 | 161 | (defun restore (place &key 162 | (load/save-progress-indicator *load/save-progress-indicator*) 163 | (allow-codespace-switching *allow-codespace-switching*) 164 | (max-to-read *max-to-read*) 165 | (read-version *read-version*)) 166 | "PLACE may be a string or pathname designating a file to read from, or a stream to 167 | read from (must have element type (unsigned-byte 8)), or a vector. 168 | 169 | (restore #(14 39 37 0 2 72 73 15)) -> (values :hi)) 170 | (store filename (list (list :hi :bye) :something) :as-separate-objects t) 171 | (restore filename/stream/place) -> (values (list :hi :bye) :something) 172 | (restore-from-vector (store nil :hi :bye)) -> (values :hi :bye) 173 | 174 | If ALLOW-CODESPACE-SWITCHING then the file can specify a version different from 175 | READ-VERSION and we will switch to it if it is available. 176 | 177 | MAX-TO-READ specifies the maximum amount of data in bytes we should load. 178 | 179 | LOAD/SAVE-PROGRESS-INDICATOR, if T, shows you some indications while loading" 180 | (let ((*current-codespace* (or *current-codespace* (gethash *read-version* *codespaces*))) 181 | (*load/save-progress-indicator* load/save-progress-indicator) 182 | (*allow-codespace-switching* allow-codespace-switching) 183 | (*max-to-read* max-to-read) 184 | (*read-version* read-version)) 185 | (handler-case 186 | (etypecase place 187 | ((or string pathname) 188 | (restore-from-file place)) 189 | (stream 190 | (restore-from-stream place)) 191 | (vector 192 | (restore-from-vector place))) 193 | (babel:character-decoding-error (e) 194 | (unexpected-data "Expected UTF-8 data" e))))) 195 | 196 | (defun store (place data &key (track-references *track-references*) 197 | (support-shared-list-structures *support-shared-list-structures*) 198 | (max-to-write *max-to-write*) 199 | (as-separate-objects nil) 200 | (output-end-marker *output-end-marker*) 201 | (output-magic-number *output-magic-number*) 202 | (write-version *write-version*) 203 | (load/save-progress-indicator *load/save-progress-indicator*)) 204 | "When PLACE is NIL, returns a (vector (unsigned-byte 8) (*)) with fill-pointer 205 | ex: (store nil (list 1.234d56)) #(32 5 11 90 215 48 169 108 33 148 75 5) 206 | 207 | When PLACE is a filename/string/pathname writes data to the respective file. 208 | 209 | When PLACE is a vector writes data to it and returns num used bytes... if vector is 210 | adjustable, it may be adjusted. Otherwise we error if we run out of space. 211 | 212 | If you provide a list of objects in DATA and you specify AS-SEPARATE-OBJECTS 213 | they will come back from RESTORE as multiple values. Otherwise we just store the list. 214 | 215 | ex: (restore (store filename (list :hi :bye) :data-is-list-of-separate-objects t)) -> (values :hi :bye). 216 | 217 | If OUTPUT-MAGIC-NUMBER we write out WRITE-VERSION at the beginning of the stream and 218 | it will then be validated on restore. 219 | 220 | MAX-TO-WRITE is the maximum number of bytes you want to write out before erroring. 221 | 222 | SUPPORT-SHARED-LIST-STRUCTURES should be T if you have circular lists or share tails of lists and 223 | want them to come back properly EQL. 224 | 225 | TRACK-REFERENCES should be T if you have references between the elements in data. 226 | 227 | LOAD/SAVE-PROGRESS-INDICATOR, if T, shows you some indications while loading" 228 | (declare (optimize speed safety)) 229 | (let* ((magic-number (make-magic-number :number *write-version*)) 230 | (*current-codespace* (gethash *write-version* *codespaces*)) 231 | (*write-version* write-version) 232 | (*max-to-write* max-to-write) 233 | (*support-shared-list-structures* support-shared-list-structures) 234 | (*track-references* track-references) 235 | (*load/save-progress-indicator* load/save-progress-indicator) 236 | (*output-end-marker* output-end-marker) 237 | (data* (if output-magic-number 238 | (if as-separate-objects 239 | (cons magic-number data) 240 | (list magic-number data)) 241 | (if as-separate-objects 242 | data 243 | (list data))))) 244 | (declare (dynamic-extent magic-number data*)) 245 | (assert *current-codespace* nil 246 | (format nil "Write-version ~A does not have an existing codespace, we have ~A" 247 | *write-version* (loop for key being the hash-keys of *codespaces* 248 | collect (list key (codespace-name 249 | (gethash key *codespaces* )))))) 250 | (etypecase place 251 | ((or string pathname) 252 | (apply #'store-to-file place data*) 253 | place) 254 | (stream 255 | (apply #'store-to-stream place data*) 256 | place) 257 | (vector ;; returns length 258 | (apply #'store-to-extant-vector place data*)) 259 | (null 260 | (apply #'store-to-vector data*))))) 261 | 262 | 263 | -------------------------------------------------------------------------------- /benchmarks.lisp: -------------------------------------------------------------------------------- 1 | ;;(quicklisp:quickload "cl-store") 2 | ;;#-(or lispworks allegro)(quicklisp:quickload "hyperluminal-mem") 3 | ;;(quicklisp:quickload "cl-conspack") 4 | ;;#+sbcl (require 'sb-sprof) 5 | 6 | (in-package :cl-binary-store) 7 | 8 | (defmacro timed ((annotation &optional (repeats 1) output-size-MB) &body body) 9 | (let ((start (gensym)) 10 | (end (gensym))) 11 | `(let ((,start (get-internal-real-time))) 12 | (multiple-value-prog1 13 | ,@body 14 | (let* ((,end (get-internal-real-time))) 15 | (cond 16 | ((= ,end ,start) 17 | (format t "~A too fast to resolve~%" ,annotation)) 18 | (t 19 | (let ((ms-per (/ (- ,end ,start) 20 | (* 0.001f0 internal-time-units-per-second) 21 | ,repeats))) 22 | (format t "~A ~,2f ms ~A~%" ,annotation ms-per 23 | ,(if output-size-MB 24 | `(format nil "at ~d MB/sec" (round (/ ,output-size-MB ms-per 1f-3))) 25 | "")))))))))) 26 | 27 | 28 | #-(or allegro abcl lispworks windows) ;; crashes on abcl 29 | (defun test-hlmem-on-data (data &key (repeats 20)) 30 | (let* ((words (hyperluminal-mem:msize 0 data)) 31 | (output-size (/ (* 8 words) 1e6))) 32 | (format t "HYPERLUMINAL-MEM~%") 33 | (format t " OUTPUT SIZE: ~,2f MB~%" output-size) 34 | (static-vectors:with-static-vector (a-store (* 8 words)) 35 | (timed (" WRITE:" repeats output-size) 36 | (dotimes (x repeats) 37 | (hyperluminal-mem::mwrite (static-vectors:static-vector-pointer a-store) 0 words data))) 38 | ;; returns words 39 | (timed (" READ :" repeats output-size) 40 | (dotimes (x repeats) 41 | (hyperluminal-mem:mread (static-vectors:static-vector-pointer a-store) 0 words)))))) 42 | 43 | (defun test-cl-binary-store-on-data 44 | (data &key (track-references t) (support-shared-list-structures nil) (repeats 20) 45 | (read t) (write t) (file nil)) 46 | (let* ((cl-binary-store:*support-shared-list-structures* support-shared-list-structures) 47 | (cl-binary-store:*track-references* track-references) 48 | (store (coerce 49 | (cl-binary-store:store nil data) 50 | '(simple-array (unsigned-byte 8) (*)))) 51 | (size (length store)) 52 | (output-size-MB (/ size 1e6))) 53 | (format t "CL-BINARY-STORE~%") 54 | (format t " OUTPUT SIZE: ~,2f MB~%" output-size-MB) 55 | (when write 56 | (timed (" WRITE:" repeats output-size-MB) 57 | (dotimes (x repeats) (cl-binary-store:store store data))) 58 | (when file 59 | (timed (" FILE WRITE:" repeats output-size-MB) 60 | (dotimes (x repeats) 61 | (with-open-file (str "blarg.bin" :if-exists :supersede :if-does-not-exist :create 62 | :direction :output :element-type '(unsigned-byte 8)) 63 | (cl-binary-store:store str data)))))) 64 | ;;(assert (equalp (cl-binary-store:restore store) data)) 65 | (when read 66 | (timed (" READ :" repeats output-size-MB) 67 | (dotimes (x repeats) (cl-binary-store:restore store))) 68 | (when file 69 | (timed (" FILE READ :" repeats output-size-MB) 70 | (dotimes (x repeats) 71 | (with-open-file (str "blarg.bin" :direction :input :element-type '(unsigned-byte 8)) 72 | (cl-binary-store:restore str)))))) 73 | (values))) 74 | 75 | (defun test-conspack-on-data (data &key (repeats 10) (read t) (write t) (to-file nil) 76 | (track-references t)) 77 | (format t "CL-CONSPACK~%") 78 | (let* ((encoded-data (if track-references 79 | (conspack:tracking-refs () 80 | (conspack:encode data)) 81 | (conspack:encode data))) 82 | (output-size-MB (/ (length encoded-data) 1e6))) 83 | (format t " OUTPUT SIZE: ~,2fMB~%" output-size-MB) 84 | (when write 85 | (when to-file 86 | (timed (" FILE WRITE:" repeats output-size-MB) 87 | (dotimes (x repeats) 88 | (with-open-file (str "blarg.bin" :if-exists :supersede :if-does-not-exist :create 89 | :direction :output :element-type '(unsigned-byte 8)) 90 | (if track-references 91 | (conspack:tracking-refs () 92 | (conspack:encode data :stream str)) 93 | (conspack:encode data :stream str)))))) 94 | (timed (" WRITE:" repeats output-size-MB) 95 | (dotimes (x repeats) 96 | (if track-references 97 | (conspack:tracking-refs () 98 | (conspack:encode data)) 99 | (conspack:encode data))))) 100 | (when read 101 | (when to-file 102 | (timed (" FILE READ :" repeats output-size-MB) 103 | (dotimes (x repeats) 104 | (with-open-file (str "blarg.bin" :element-type '(unsigned-byte 8)) 105 | (if track-references 106 | (conspack:tracking-refs () 107 | (conspack:decode-stream str)) 108 | (conspack:decode-stream str)))))) 109 | (timed (" READ :" repeats output-size-MB) 110 | (if track-references 111 | (dotimes (x repeats) 112 | (conspack:tracking-refs () 113 | (conspack:decode encoded-data))) 114 | (dotimes (x repeats) 115 | (conspack:decode encoded-data))))) 116 | (values))) 117 | 118 | (defun test-cl-store-on-data 119 | (data &key (check-for-circs nil) (repeats 10) (read t) (write t) 120 | (precise-list-storage nil)) 121 | ;; if you try and dump it to a flexi-streams sequence it's 4x slower than this! 122 | (let ((cl-store:*check-for-circs* check-for-circs) 123 | (cl-store:*precise-list-storage* precise-list-storage)) 124 | (format t "CL-STORE~%") 125 | (cl-store:store data "blarg.bin") 126 | (let ((output-size-MB 127 | (with-open-file (str "blarg.bin") 128 | (/ (file-length str) 1e6)))) 129 | (format t " OUTPUT SIZE: ~,2fMB~%" output-size-MB) 130 | (when write 131 | (timed (" WRITE:" repeats output-size-MB) 132 | (dotimes (x repeats) (cl-store:store data "blarg.bin")))) 133 | (when read 134 | (timed (" READ :" repeats output-size-MB) 135 | (dotimes (x repeats) (cl-store:restore "blarg.bin"))))))) 136 | 137 | (defun test-on-data (data &key (hlmem t) (cl-store t) (cl-binary-store t) (conspack t)) 138 | #-(or allegro abcl lispworks windows) 139 | (when hlmem 140 | (test-hlmem-on-data data)) 141 | (when cl-binary-store 142 | (test-cl-binary-store-on-data data :track-references (not hlmem) 143 | :support-shared-list-structures (and (not hlmem) 144 | (not cl-store)))) 145 | (when conspack 146 | (test-conspack-on-data data :track-references (not hlmem))) 147 | (when cl-store 148 | (test-cl-store-on-data data :check-for-circs (not hlmem)))) 149 | 150 | ;; Data to test on 151 | (defun long-list-of-tiny-integers (&optional (n 1000000)) 152 | (loop repeat n collect (- (random 33) 16))) 153 | 154 | (defun long-simple-vector-of-tiny-integers (&optional (n 1000000)) 155 | (coerce (long-list-of-tiny-integers n) 'simple-vector)) 156 | 157 | (defun long-list-of-not-tiny-integers (&optional (n 1000000)) 158 | (make-list n :initial-element (random 256))) 159 | 160 | (defun long-list-of-random-fixnums (&optional (n 1000000)) 161 | (loop repeat n collect (random #-ccl(- (expt 2 61) (expt 2 60)) 162 | #+ccl (- (expt 2 59) (expt 2 58))))) 163 | 164 | (defun long-list-of-random-double-floats (&optional (n 1000000)) 165 | (loop repeat n collect (random 1d0))) 166 | 167 | (defun long-list-of-random-single-floats (&optional (n 1000000)) 168 | (loop repeat n collect (random 1f0))) 169 | 170 | (defun long-list-of-random-complex-double-floats (&optional (n 1000000)) 171 | (loop repeat n collect (complex (random 1d0) (random 1d0)))) 172 | 173 | (defun long-list-of-big-ub8-vectors (&optional (n 1000)) 174 | (loop repeat n 175 | collect 176 | (coerce 177 | (loop for i fixnum from 0 below 10000 178 | collect 123) 179 | '(simple-array (unsigned-byte 8) (*))))) 180 | 181 | (defun long-list-of-big-simple-bit-vectors () 182 | (loop repeat 1000 183 | collect 184 | (coerce 185 | (loop for i fixnum from 0 below 10000 186 | collect (random 1)) 187 | '(simple-array bit (*))))) 188 | 189 | (defun long-list-of-big-simple-double-float-vectors () 190 | (loop repeat 1000 191 | collect 192 | (coerce 193 | (loop for i fixnum from 0 below 1000 194 | collect (random 1d0)) 195 | '(simple-array double-float (*))))) 196 | 197 | (defun list-of-double-float-matrices () 198 | (loop repeat 100 199 | collect 200 | (let ((m (make-array '(100 100) :element-type 'double-float))) 201 | (dotimes (i 100) 202 | (dotimes (j 100) 203 | (setf (aref m i j) (random 1d0)))) 204 | m))) 205 | 206 | (defun long-complex-list () 207 | (loop repeat 1000000 collect (if (> (random 1000) 500) 208 | 3.1415d0 209 | ;; (complex 1d0) ;; cl-store chokes 210 | ;; (random 1d0) ;; cl-store chokes 211 | (if (> (random 100) 50) 212 | ;;(random 1f0) ;; <- makes cl-store take forever! 213 | "hi" ;;(format nil "~A" (random 123)) 214 | (if (> (random 100) 50) 215 | (cons (random 30) 2) 216 | (if (= (random 2) 1) 217 | (complex 1d0 1d0) 218 | ;; (random 1f0) slows cl-store crazily 219 | #())))))) 220 | 221 | (defun lots-of-the-same-string () 222 | (let ((string (coerce "asdf" 'simple-base-string))) 223 | (loop for i fixnum from 0 below 1000000 224 | collect string))) 225 | 226 | (defun lots-of-keywords (&optional (n 100000)) 227 | "With some repeats" 228 | (loop for i fixnum from 0 below n 229 | collect (intern (format nil "~A" (random n)) 'keyword))) 230 | 231 | (defun lots-of-symbols (&optional (N 100000)) 232 | "With some repeats" 233 | (loop for i fixnum from 0 below n 234 | collect (intern (format nil "~A" (random n)) 'cl-user))) 235 | 236 | (defun lots-of-uninterned-symbols (&optional (N 100000)) 237 | "With some repeats" 238 | (let ((symbol-pool (loop for i fixnum below (floor N 5) collect (gensym "HELLO")))) 239 | (loop repeat 5 appending symbol-pool))) 240 | 241 | (defstruct bench-blarg 242 | a 243 | b) 244 | 245 | (conspack:defencoding bench-blarg 246 | a b) 247 | 248 | #-(or allegro windows) 249 | (defmethod hyperluminal-mem:msize-object ((b bench-blarg) index) 250 | (hyperluminal-mem:msize* index (bench-blarg-a b) (bench-blarg-b b))) 251 | 252 | #-(or allegro windows) 253 | (defmethod hyperluminal-mem:mwrite-object ((b bench-blarg) ptr index end-index) 254 | (hyperluminal-mem:mwrite* ptr index end-index (bench-blarg-a b) (bench-blarg-b b))) 255 | 256 | #-(or allegro windows) 257 | (defmethod hyperluminal-mem:mread-object ((type (eql 'bench-blarg)) ptr index end-index &key) 258 | (hyperluminal-mem:with-mread* (a b new-index) (ptr index end-index) 259 | (values 260 | (make-bench-blarg :a a :b b) 261 | new-index))) 262 | 263 | (defun lots-of-structure-objects (&optional (n 100000)) 264 | (coerce 265 | (loop for i below n 266 | collect (make-bench-blarg :a (random 1d0) :b (coerce (format nil "~A" (random 100)) 'simple-base-string))) 267 | 'simple-vector)) 268 | 269 | (defclass c-blarg 270 | () 271 | ((a :initarg :a) 272 | (b :initarg :b))) 273 | 274 | (conspack:defencoding c-blarg 275 | a b) 276 | 277 | (defun lots-of-standard-objects (&optional (n 100000)) 278 | (coerce 279 | (loop for i below n 280 | collect (make-instance 'c-blarg :a (random 256) :b "hello")) 281 | 'simple-vector)) 282 | 283 | (defun simple-base-strings () 284 | (loop for i below 100000 285 | collect (coerce (format nil "~A" (random 1000000)) 'simple-base-string))) 286 | 287 | (defun simple-strings () 288 | (loop for i below 100000 289 | collect (format nil "~A~A" (random 1000000) 290 | #+(or abcl allegro) (code-char #x03b1) 291 | #-(or abcl allegro) #\U+03b1))) 292 | 293 | (defun a-pile-of-tangled-conses (&optional (number 1000)) 294 | (let ((a (make-array number))) 295 | (loop for n below number do (setf (svref a n) (cons nil nil))) 296 | (loop repeat (* 10 number) 297 | do (setf (car (svref a (random number))) 298 | (svref a (random number))) 299 | (setf (cdr (svref a (random number))) 300 | (svref a (random number)))) 301 | a)) 302 | 303 | (defun a-bunch-of-specialized-arrays (&optional (n 10000)) 304 | (loop for type in '((unsigned-byte 1) 305 | (unsigned-byte 2) 306 | (unsigned-byte 4) 307 | (unsigned-byte 8) 308 | (unsigned-byte 16) 309 | (unsigned-byte 32) 310 | fixnum 311 | (unsigned-byte 64) 312 | (signed-byte 8) 313 | (signed-byte 16) 314 | (signed-byte 32) 315 | (signed-byte 64) 316 | single-float 317 | double-float) 318 | for elt in (list 1 2 15 255 65535 (1- (expt 2 32)) (expt 2 50) (1- (expt 2 64)) 319 | -1 -128 -32768 -100000 1f0 -1d0) 320 | collect 321 | (make-array n :element-type type :initial-element elt))) 322 | 323 | 324 | (defstruct address 325 | (street "Ave Greene" :type simple-string) 326 | (state "QC" :type simple-string) 327 | (zip "H3Z1Z9" :type simple-base-string)) 328 | 329 | (defstruct person 330 | (first "Andrew" :type simple-string) 331 | (second "Berkley" :type simple-string) 332 | (age 49 :type (unsigned-byte 8)) ;; take that future people living to 256 years old! 333 | (addresses nil :type list) 334 | (telephone "" :type simple-base-string) 335 | (email "" :type simple-string)) 336 | 337 | (defun a-lot-of-people-and-addresses (&optional (n 10000)) 338 | (let* ((addresses (coerce 339 | (loop repeat n 340 | collect (make-address :street (format nil "~A" (random 1000000)) 341 | :state (format nil "~A" (random 100)) 342 | :zip (format nil "~A" (random 100000)))) 343 | 'simple-vector)) 344 | (people-with-addresses 345 | (coerce 346 | (loop repeat n 347 | collect (make-person 348 | :first (format nil "~A" (random 10000000)) 349 | :second (format nil "~A" (random 10000000)) 350 | :age (random 100) 351 | :addresses (list (svref addresses (random n))) 352 | :telephone (format nil "~A" (random 1000000)) 353 | :email (format nil "~A" (random 100000000)))) 354 | 'simple-vector))) 355 | people-with-addresses)) 356 | 357 | 358 | 359 | -------------------------------------------------------------------------------- /src/referrers-and-fixup.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-binary-store) 2 | 3 | #+allegro 4 | (eval-when (:compile-toplevel) 5 | (setf declared-fixnums-remain-fixnums-switch t) 6 | (declaim (optimize (speed 3) (safety 1) 7 | (space 0) (debug 0) (compilation-speed 0)))) 8 | 9 | ;; References are used to handle both circularity and the maintenance 10 | ;; of equality of objects. For example if you have two references to 11 | ;; the same object in your data you do not want them to be restored as 12 | ;; separate objects! Or if you have a circular list we need to detect 13 | ;; the circularity so we can store and restore it. 14 | 15 | ;; We use references when the underlying common lisp structure allow 16 | ;; sharing transparently to the user (double-floats, complex, ratio, 17 | ;; or bignums) or if the objects were #'eq originally. That is, in 18 | ;; addition to maintaining #'eq-uality, (and number (not fixnum) 19 | ;; (not `single-float')) will be de-duplicated during serialization. 20 | ;; 21 | ;; During the initial phase of serialization, we do an explicit 22 | ;; reference counting pass through the data and record (almost) every 23 | ;; (referrable) object we see (there are some small exceptions --- the 24 | ;; contents of specialized vectors and arrays, the symbol-names of 25 | ;; uninterned symbols, (complex double-float), (complex 26 | ;; single-float)). Then, if we have seen an object multiple times we 27 | ;; keep it around in a hash-table for the storage pass where we will 28 | ;; assign it a sequential reference id and emit a code that says "the 29 | ;; next object should be assigned a new reference id" when we store 30 | ;; objects that we know will be multiply referenced. We also add a 31 | ;; note in the file of the total number of references the file 32 | ;; contains which helps restore speed. The counting is implicit --- 33 | ;; so the restoration side keeps a count as it sees objects registered 34 | ;; as referrable. 35 | 36 | ;; The other complexity handled in this file is that an object may be 37 | ;; referred to during deserialization *before* it has been fully 38 | ;; created. This is rare, but can happen with displaced-arrays for 39 | ;; example. To handle this we put a placeholder object in the reference 40 | ;; vector during restore and anyone who finds a reference to that object 41 | ;; can register a "fix-up" which we will call once the object is fully 42 | ;; constructed to resolve the object. This allows circular list building 43 | ;; among other things. See `restore-object-to'. 44 | 45 | (declaim (inline references-vector make-references references-ref-id)) 46 | (defstruct references 47 | "During deserialization this array contains all the references we 48 | have seen so far, and a running count ref-id of assigned ids. Nominally 49 | the array size is hinted at the start of restore, but the code allows it 50 | to grow if needed." 51 | (vector (make-array 0) :type simple-vector) 52 | (ref-id 0 :type fixnum)) ;; ref-ids run from 1 to infinity; they are incf'ed from here 53 | 54 | (declaim (inline check-reference)) 55 | (defun check-reference (object references &optional (add-new-reference t)) 56 | "Returns T if OBJECT has already been seen and updates its reference count. 57 | If OBJECT has not been seen, and ADD-NEW-REFERENCE is T, then adds it to 58 | references and returns NIL. If ADD-NEW-REFERENCE is NIL, just returns NIL. 59 | This should *ONLY* be called during the reference counting phase, that is when 60 | storage is nil." 61 | (when references 62 | (if add-new-reference 63 | (let ((number-of-times-referenced (gethash object references 0))) 64 | (declare (type fixnum number-of-times-referenced)) 65 | ;; We store the number of times an object is referenced as 1 or 2, where 2 means anything 66 | ;; more than 1 (except if debug-cbs is in *features* then we keep track of the exact 67 | ;; number). The logic below is unnecessarily complex, clean this up with clear brain. 68 | ;; When :info-cbs is in features, we do a complete count of occurences. 69 | (cond 70 | ((zerop number-of-times-referenced) 71 | (setf (gethash object references) 1) 72 | nil) 73 | (#+info-cbs (>= number-of-times-referenced 1) ;; do actual reference counting 74 | #-info-cbs (= number-of-times-referenced 1) 75 | #+info-cbs (the fixnum (incf (the fixnum (gethash object references)))) 76 | #-info-cbs(setf (gethash object references) 2) 77 | t) 78 | #-info-cbs((= number-of-times-referenced 2) t) 79 | (t nil))) 80 | (gethash object references)))) 81 | 82 | (declaim (inline store-new-reference-indicator)) 83 | (defun store-new-reference-indicator (storage) 84 | "Write an indicator that we should assign a reference id to the next object; that is place 85 | it in the restore reference-vector (and increment the ref-id counter)." 86 | (with-write-storage (storage :offset offset :reserve-bytes 1 :sap sap) 87 | (set-sap-ref-8 sap offset +new-reference-indicator-code+))) 88 | 89 | (declaim (inline referenced-already)) 90 | (defun referenced-already (object storage references assign-new-reference-id) 91 | "Returns T if OBJECT is in REFERENCES and writes out a reference to it to storage. 92 | Otherwise returns NIL if it is not a reference at all. This should 93 | *ONLY* be called during the actual storage phase, not the reference 94 | counting phase." 95 | (declare (type write-storage storage) (optimize (speed 3) (safety 1))) 96 | (when references 97 | (let ((ref-idx (gethash object references))) 98 | ;; When ref-idx is positive, it's a note that we have already written out the 99 | ;; actual value, so we can just store the reference id. If it is negative, 100 | ;; it means we must write out the ref-idx and the object as this is the first time 101 | ;; it has appeared in the output. 102 | (cond 103 | ((eq ref-idx t) 104 | ;; Assign a reference id 105 | (let ((new-ref-id (funcall (the function assign-new-reference-id)))) 106 | (declare (type fixnum new-ref-id)) 107 | #+dribble-cbs (format t "Storing reference definition (#~A) for next object: ~A~%" 108 | new-ref-id (type-of object)) 109 | (setf (gethash object references) new-ref-id)) 110 | ;; We know the reference id here, so we could write it out, but it wastes a lot 111 | ;; of space, so until we want to do parallel store and restore leave it implicit 112 | ;; for the reader. 113 | (store-new-reference-indicator storage) 114 | nil) 115 | ((typep ref-idx 'fixnum) 116 | #+dribble-cbs (format t "Storing a reference (#~A) which is to a ~A~%" 117 | ref-idx (type-of object)) 118 | (store-reference ref-idx storage) 119 | t) 120 | (t nil))))) 121 | 122 | (declaim (inline check/store-reference)) 123 | (defun check/store-reference (object storage references assign-new-reference-id &key (add-new-reference t)) 124 | "Used during the storage phase both during the reference counting 125 | step and the serialization step. This function returns T if this 126 | object has already been written out, in which case the caller should 127 | NOT write OBJECT out to storage. If NIL, then you must write the 128 | OBJECT out. If ADD-NEW-REFERENCE is T, in the case where this 129 | function returns NIL, we will generate a new reference id for this 130 | object so it can be used in the future. The only case where 131 | ADD-NEW-REFERENCE should be NIL is if you are explicitly 132 | dis-allowing (for performance reasons) circularity, as we optionally 133 | do during cons serialization." 134 | (declare (optimize (speed 3) (safety 1))) 135 | (if storage ; we are in the storage phase, writing things out 136 | (referenced-already object storage references assign-new-reference-id) 137 | (check-reference object references add-new-reference))) 138 | 139 | ;; RESTORE PHASE 140 | 141 | (defun grow-references-vector (references ref-id) 142 | (let* ((vec (references-vector references)) 143 | (len (length vec))) 144 | (setf (references-vector references) 145 | (adjust-array vec 146 | (max (the fixnum (* 2 len)) 147 | (the fixnum (1+ ref-id))))))) 148 | 149 | (declaim (inline ensure-references-vector)) 150 | (defun ensure-references-vector (references ref-id) 151 | "Return / resize references-vector which can hold ref-id" 152 | (let* ((vec (references-vector references)) 153 | (len (length vec))) 154 | (if (<= len ref-id) 155 | (setf (references-vector references) (grow-references-vector references ref-id)) 156 | vec))) 157 | 158 | (declaim (inline update-reference)) 159 | (defun update-reference (ref-id value references) 160 | "Used during RESTORE" 161 | (declare (optimize (speed 3) (safety 1)) (type fixnum ref-id)) 162 | #+debug-cbs 163 | (let ((*print-circle* t)) 164 | (format t "Updating reference id ~A to ~S~%" ref-id value)) 165 | (let ((vec (ensure-references-vector references ref-id))) 166 | (locally (declare (optimize (speed 3) (safety 0))) 167 | (setf (svref vec ref-id) value)))) 168 | 169 | ;; During restoring, we cannot always construct objects before we have 170 | ;; restored a bunch of other information (for example building displaced 171 | ;; arrays). So we need to be able to fix-up references to the not yet built 172 | ;; object (which may have been restored while determining how to build the 173 | ;; object). 174 | 175 | (declaim (inline fixup-p make-fixup fixup-list fixup-ref-id)) 176 | (defstruct fixup 177 | (list nil :type list) 178 | (ref-id -1 :type fixnum)) 179 | 180 | (defun fixup (fixup new-value references) 181 | (declare (optimize (speed 3) (safety 1))) 182 | "Resolve a delayed object construction. Returns new-value." 183 | #+debug-cbs (format t "Executing ~A fixups for reference id ~A of type ~A~%" 184 | (length (fixup-list fixup)) (fixup-ref-id fixup) 185 | (type-of new-value)) 186 | (mapc (lambda (func) 187 | (funcall (the function func) new-value)) 188 | (fixup-list fixup)) 189 | (update-reference (fixup-ref-id fixup) new-value references)) 190 | 191 | (defmacro with-delayed-reference/fixup ((ref-id references) &body body) 192 | "When we know an object is going to be referred to multiple times, 193 | we place it in the *references* array immediately before we even start 194 | building it because it may not be buildable without restoring other objects 195 | that might refer to it. So we always stick a fixup in the references array 196 | first for any of those newly created objects to hang their requests to be 197 | notified of the final object once it is constructed. BODY must eventually yield 198 | the fully constructed object. Not hygenic, " 199 | (let ((fixup (gensym)) 200 | (num (gensym))) 201 | `(let* ((,num ,ref-id) 202 | (,fixup (make-fixup :ref-id ,num))) 203 | (declare (dynamic-extent ,fixup)) 204 | (update-reference ,num ,fixup ,references) 205 | (fixup ,fixup (progn ,@body) references)))) 206 | 207 | (defmacro restore-object-to (place restore-object &optional tag) 208 | "If you are deserializing an object which contains slots (for 209 | example an array, a list, hash-table, or structure-object or a 210 | standard-object) which may point to other lisp objects which have yet 211 | to be fully reified, then please update your slots with this macro 212 | which will handle circularity fixups for you. 213 | 214 | Note that we capture any parameters of place so you may safely use this 215 | in loops or with references to variables whose values may be updated later" 216 | (let* ((restored (gensym)) 217 | (new-object (gensym)) 218 | (variables-to-capture (cdr place)) 219 | (names (loop repeat (length variables-to-capture) collect (gensym)))) 220 | `(let ((,restored (funcall (the function ,restore-object) ,@(when tag (list tag))))) 221 | (if (fixup-p ,restored) 222 | (push 223 | (let (,@(mapcar #'list names variables-to-capture)) 224 | (lambda (,new-object) 225 | (setf (,(first place) ,@names) ,new-object))) 226 | (fixup-list ,restored)) 227 | (setf ,place ,restored))))) 228 | 229 | (defmacro maybe-store-reference-instead ((obj storage references assign-new-reference-id 230 | &key (add-new-reference t)) 231 | &body body) 232 | "Objects may be seen multiple times during serialization, 233 | so where object equality after deserialization is expected (pretty 234 | much every object except numbers) or not determinable (double-floats, 235 | complex, ratios, bignum), we record objects along with reference ids 236 | that we can refer to later in the serialization to point to the 237 | original object. The counting of objects is done explicitly in the 238 | writing phase, so there is nothing to do in the reading phase except 239 | to plunk objects into the right place in the *references* array." 240 | `(or (check/store-reference ,obj ,storage ,references ,assign-new-reference-id 241 | :add-new-reference ,add-new-reference) 242 | (progn 243 | ,@body))) 244 | 245 | (declaim (inline restore-new-reference-indicator)) 246 | (defun restore-new-reference-indicator (references restore-object) 247 | (let ((ref-id (incf (references-ref-id references)))) 248 | (setf (svref (references-vector references) ref-id) 249 | (with-delayed-reference/fixup (ref-id references) 250 | (funcall (the function restore-object)))))) 251 | 252 | (declaim (notinline store-reference)) 253 | (defun store-reference (ref-index storage) 254 | "Write a reference id to the output which will be resolved at restore time to an object. The 255 | basic-codespace implementation here reserves 6 bits of the codespace for reference ids which 256 | makes these pretty cheap." 257 | (declare (type (and (integer 1) fixnum) ref-index) 258 | (type (not null) storage)) 259 | (when storage 260 | #+dribble-cbs (format t "Writing reference ~A~%" ref-index) 261 | (cond 262 | ((<= +reference-direct-min-ref-id+ ref-index +reference-direct-max-ref-id+) 263 | (with-write-storage (storage :offset offset :reserve-bytes 1 :sap sap) 264 | (set-sap-ref-8 sap offset (encode-reference-direct ref-index)))) 265 | ((<= ref-index +reference-one-byte-max-ref-id+) 266 | (with-write-storage (storage :offset offset :reserve-bytes 2 :sap sap) 267 | ;;(format t "~16,'0b~%" (encode-reference-one-byte ref-index)) 268 | (set-sap-ref-16 sap offset (encode-reference-one-byte ref-index)))) 269 | ((<= ref-index +reference-two-byte-max-ref-id+) 270 | (multiple-value-bind (tag-byte second-two-bytes) 271 | (encode-reference-two-bytes ref-index) 272 | ;;(format t "~16,'0b~8,'0b~%" second-two-bytes tag-byte) 273 | (with-write-storage (storage :offset offset :reserve-bytes 3 :sap sap) 274 | (set-sap-ref-8 sap offset tag-byte) 275 | (set-sap-ref-16 sap (incf offset) second-two-bytes)))) 276 | (t 277 | (with-write-storage (storage :offset offset :reserve-bytes 1 :sap sap) 278 | (set-sap-ref-8 sap offset +tagged-reference-code+)) 279 | (when storage 280 | (store-tagged-unsigned-fixnum (encode-reference-tagged ref-index) storage)))))) 281 | 282 | (declaim (#-debug-cbs inline #+debug-cbs notinline restore-reference)) 283 | (defun restore-reference (ref-id references) 284 | "The reference has already been calculated in the dispatch code for us. 285 | If we are actually restoring the next object, it may not be re-ified before 286 | someone refers to it, so we have to store a fixup for those other objects 287 | to hang their reference onto." 288 | (declare (optimize (speed 3) (safety 1)) (type (and (integer 0) fixnum) ref-id)) 289 | (let* ((vec (references-vector references)) 290 | (len (length vec))) 291 | (if (>= ref-id len) 292 | (progn 293 | (cerror "Use NIL" 'invalid-input-data :format-control "Invalid data, reference to non-existent id ~A" :format-arguments (list ref-id)) 294 | nil) 295 | (locally (declare (optimize (speed 3) (safety 0))) 296 | (svref vec ref-id))))) 297 | -------------------------------------------------------------------------------- /type-discrimination.md: -------------------------------------------------------------------------------- 1 | # Context 2 | 3 | This file was just me figuring out that you need to do some by hand 4 | tweaking of type dispatching to get good results. 5 | 6 | # Serialization speed and type dispatching 7 | 8 | So, this whole thing works reasonably well for the use case I have and 9 | deserialization of complex objects is blazingly fast. But 10 | serialization in the case of non-multiply referenced data (and no 11 | circularity) is still a bit slower than hyperluminal-mem. So I did 12 | a bit of benchmarking and found that about 30% of my time is spent in 13 | type dispatch (this is for a very synthetic example of a list of a 14 | million small numbers). My dispatch mechanism is just a flat 15 | etypecase grouped into disjoint types and sorted by subtype. So, for 16 | example, I allow dispatch to different functions for an (unsigned-byte 17 | 8) and a fixnum, or for a (simple-array double-float (*)) versus just 18 | a simple-vector. 19 | 20 | I had hoped the compiler would do some magic with perfect tag hashes 21 | and jump-tables as I see some of that in the source code, but I wasn't 22 | able to get it to do it, so I ran down this rabbit hole a little bit 23 | to see if nesting type-cases is worth it. 24 | 25 | Nominally I'd expect the CLOS infrastructure for dispatch to be 26 | relatively fast, but you cannot do easy top level specialization for 27 | things like (simple-array (signed-byte 8) (4)), for example, which in 28 | some cases it makes sense to do (for what I care about, maybe not for 29 | the rest of the world!). 30 | 31 | So, you'll find in the file src/type-discrimation.lisp my very crude 32 | cut at determining how fast I'd expect a not-so-smart compiler to be 33 | able to determine types of objects. Remember, I am currently just 34 | using a flat typecase sorted by subtype for cl-binary-store. Anyway, 35 | here my model is a bunch of nested, auto-generated, typecases that 36 | mirror the Common Lisp type hierarchy. Now, nominally there are 37 | tricks that are smarter than this based on tag hashing and jump tables 38 | probably, but I've got to start with my understanding somewhere. So, 39 | anyway, I cobbled together an estimator for what it would take to do 40 | dispatch using a tree of discriminators (don't judge the code please, 41 | I wrote it as fast as possible because I wanted to see the results). 42 | 43 | First, I cut my type space automatically into disjoint subsets (either 44 | fully or with some hinting as to a good order to do the top level 45 | discrimination) and then I compile discriminators, like I'd expect the 46 | compiler to do in a nested typecase scenario. At each node in the 47 | tree, I know what the object under test's super-type is (even if just 48 | T) and what I have learned so far about what the object is not. I do 49 | a rough count of the number of instructions, function-calls, and 50 | compares done to get to a decision. So, for an example, here I choose 51 | a not so random top-level ordering (the first few are 52 | immediate/unboxed objects in a sense, and so should be easy to 53 | discriminate) (you can also run this with just '(t) as a singular tree 54 | root, but it's far from optimal!). 55 | 56 | (simulate-discriminators *many-types* 57 | '(cons fixnum null (eql t) single-float 58 | array number structure-object standard-object t)) 59 | 60 | Here's my ascii art representation of the resulting tree and some annotations run 61 | on sbcl 2.4.4. 62 | 63 | CONS 3 compares, 13 instructions, and 0 function-calls 64 | FIXNUM 4 compares, 22 instructions, and 0 function-calls 65 | (UNSIGNED-BYTE 32) 5 compares, 32 instructions, and 0 function-calls 66 | (UNSIGNED-BYTE 16) 6 compares, 42 instructions, and 0 function-calls 67 | (UNSIGNED-BYTE 8) 7 compares, 52 instructions, and 0 function-calls 68 | NULL 5 compares, 31 instructions, and 0 function-calls 69 | (EQL T) 6 compares, 39 instructions, and 0 function-calls 70 | SINGLE-FLOAT 7 compares, 48 instructions, and 0 function-calls 71 | ARRAY 9 compares, 61 instructions, and 0 function-calls 72 | SIMPLE-ARRAY 10 compares, 72 instructions, and 0 function-calls 73 | (SIMPLE-ARRAY FIXNUM *) 14 compares, 91 instructions, and 0 function-calls 74 | VECTOR 11 compares, 81 instructions, and 0 function-calls 75 | SIMPLE-VECTOR 12 compares, 90 instructions, and 0 function-calls 76 | (SIMPLE-ARRAY (UNSIGNED-BYTE 8) (*)) 13 compares, 99 instructions, and 0 function-calls 77 | (SIMPLE-ARRAY SINGLE-FLOAT (*)) 14 compares, 108 instructions, and 0 function-calls 78 | (SIMPLE-ARRAY DOUBLE-FLOAT (*)) 15 compares, 117 instructions, and 0 function-calls 79 | (SIMPLE-ARRAY FIXNUM (*)) 16 compares, 126 instructions, and 0 function-calls 80 | NUMBER 11 compares, 74 instructions, and 0 function-calls 81 | COMPLEX 13 compares, 89 instructions, and 0 function-calls 82 | (COMPLEX DOUBLE-FLOAT) 14 compares, 98 instructions, and 0 function-calls 83 | (COMPLEX SINGLE-FLOAT) 15 compares, 107 instructions, and 0 function-calls 84 | REAL 17 compares, 104 instructions, and 0 function-calls 85 | RATIONAL 20 compares, 119 instructions, and 0 function-calls 86 | INTEGER 22 compares, 132 instructions, and 0 function-calls 87 | (UNSIGNED-BYTE 64) 31 compares, 155 instructions, and 0 function-calls 88 | BIGNUM 32 compares, 164 instructions, and 0 function-calls 89 | RATIO 22 compares, 138 instructions, and 0 function-calls 90 | DOUBLE-FLOAT 21 compares, 128 instructions, and 0 function-calls 91 | STRUCTURE-OBJECT 14 compares, 88 instructions, and 0 function-calls 92 | ANOTHER 15 compares, 99 instructions, and 0 function-calls 93 | BLARG 16 compares, 110 instructions, and 0 function-calls 94 | INCLUDES-BLARG 17 compares, 121 instructions, and 0 function-calls 95 | STANDARD-OBJECT 15 compares, 94 instructions, and 1 function-calls 96 | STANDARD-CLASS 15 compares, 100 instructions, and 2 function-calls 97 | T 15 compares, 100 instructions, and 1 function-calls 98 | SATISFIES-SOMETHING 17 compares, 115 instructions, and 2 function-calls 99 | 100 | So to read this you can say the code that would be generated by this 101 | set of typecases would take 3 compares to determine that something was 102 | a cons and dispatch to the relevant function, if it was not a cons, 103 | then we need one more comparison to determine if it is a fixnum or 104 | not, and if it was, then say 2 more to determine if the number is an 105 | (unsigned-byte 16). If we weren't a fixnum, then in the end to 106 | determine if we are a standard-object (near the end) we would have 107 | performed 15 total compares, 94 instructions and one function call. 108 | 109 | You can tell that this is obviously a silly thing to do in some cases, 110 | why would you test if something was a REAL, then a RATIONAL then an 111 | INTEGER, as you likely would actually be testing already (OR INTEGER 112 | RATIO). In fact you can see that's the case, because it takes 22 113 | compares to get to INTEGER and also 22 to get to RATIO. But, we can 114 | make one of them faster than the other by removing the RATIONAL type 115 | node intermediary from \*many-types\*. Focusing just on this part, we 116 | find: 117 | 118 | NUMBER 11 compares, 74 instructions, and 0 function-calls 119 | COMPLEX 13 compares, 89 instructions, and 0 function-calls 120 | (COMPLEX DOUBLE-FLOAT) 14 compares, 98 instructions, and 0 function-calls 121 | (COMPLEX SINGLE-FLOAT) 15 compares, 107 instructions, and 0 function-calls 122 | REAL 17 compares, 104 instructions, and 0 function-calls 123 | RATIO 19 compares, 116 instructions, and 0 function-calls 124 | INTEGER 22 compares, 131 instructions, and 0 function-calls 125 | BIGNUM 23 compares, 140 instructions, and 0 function-calls 126 | (UNSIGNED-BYTE 64) 24 compares, 149 instructions, and 0 function-calls 127 | DOUBLE-FLOAT 23 compares, 140 instructions, and 0 function-calls 128 | 129 | So here the discrimination is best-cased for ratio which is tested 130 | before integer. So far I haven't put this information into use, but 131 | it's cool. Anyhow, this is a work in progress, I'm posting this to in 132 | the hope that someone will get annoyed and show me a how to do this 133 | way faster. 134 | 135 | ## What does sbcl generate for a typecase? 136 | 137 | I couldn't get it to generate anything complex, but there are strong hints in the source 138 | code that it can do some really smart dispatch generation with jump-tables and hashing, but 139 | I couldn't figure out the magic incantation yet. Let's just examine what I get out of the 140 | box and see if my estimates above are reasonable. See *trust-sbcl* in type-discrimination.lisp 141 | which is just a simple flat typecase with a bunch of types in it without any re-ordering: 142 | 143 | (simulate-discriminators '((unsigned-byte 8) (unsigned-byte 16) (unsigned-byte 32) 144 | (unsigned-byte 64) fixnum blarg includes-blarg 145 | (simple-array double-float (*)) simple-array vector 146 | array ratio complex) 147 | '((unsigned-byte 8) (unsigned-byte 16) (unsigned-byte 32) 148 | (unsigned-byte 64) fixnum blarg includes-blarg 149 | (simple-array double-float (*)) simple-array vector 150 | array ratio complex)) 151 | 152 | versus 153 | 154 | (defun trust-sbcl (x) 155 | (declare (optimize (speed 3) (safety 0) (debug 0))) 156 | (typecase x 157 | ((unsigned-byte 8) 0) 158 | ((unsigned-byte 16) 1) 159 | ((unsigned-byte 32) 2) 160 | ((unsigned-byte 64) 3) 161 | (fixnum 4) 162 | (blarg 5) 163 | (includes-blarg 6) 164 | ((simple-array double-float (*)) 7) 165 | (simple-array 8) 166 | (vector 9) 167 | (array 10) 168 | (ratio 11) 169 | (complex 12))) 170 | 171 | (UNSIGNED-BYTE 8) 1 compares, 10 instructions, and 0 function-calls 172 | (UNSIGNED-BYTE 16) 2 compares, 20 instructions, and 0 function-calls 173 | (UNSIGNED-BYTE 32) 3 compares, 30 instructions, and 0 function-calls 174 | (UNSIGNED-BYTE 64) 11 compares, 54 instructions, and 0 function-calls 175 | FIXNUM 12 compares, 63 instructions, and 0 function-calls 176 | BLARG 14 compares, 77 instructions, and 0 function-calls 177 | INCLUDES-BLARG 14 compares, 83 instructions, and 0 function-calls 178 | (SIMPLE-ARRAY DOUBLE-FLOAT (*)) 16 compares, 95 instructions, and 0 function-calls 179 | SIMPLE-ARRAY 18 compares, 109 instructions, and 0 function-calls 180 | VECTOR 20 compares, 123 instructions, and 0 function-calls 181 | ARRAY 22 compares, 136 instructions, and 0 function-calls 182 | RATIO 24 compares, 148 instructions, and 0 function-calls 183 | COMPLEX 26 compares, 163 instructions, and 0 function-calls 184 | 185 | versus the sbcl code below. Note that there is a lot of complexity in the ub32->ub64 thing 186 | reflected in the assembly below. You can see that testing for fixnum first would have been 187 | way smarter. 188 | 189 | ; disassembly for TRUST-SBCL 190 | ; Size: 307 bytes. Origin: #x55414696 ; TRUST-SBCL 191 | ; 696: 48F7C201FEFFFF TEST RDX, -511 192 | ; 69D: 7505 JNE L1 193 | ; 69F: 31D2 XOR EDX, EDX <--- unsigned-byte 8 return 0 194 | ; 6A1: L0: C9 LEAVE 195 | ; 6A2: F8 CLC 196 | ; 6A3: C3 RET 197 | ; 6A4: L1: 48F7C20100FEFF TEST RDX, -131071 198 | ; 6AB: 0F840E010000 JEQ L15 <--- (unsigned-byte 16) 199 | ; 6B1: 488515C0FFFFFF TEST RDX, [RIP-64] ; [#x55414678] = #xFFFFFFFE00000001 200 | ; 6B8: 0F84F7000000 JEQ L14 <--- (unsigned-byte 32) 201 | ; 6BE: 4885142560000050 TEST RDX, [#x50000060] 202 | ; 6C6: 0F84DF000000 JEQ L13 <--- one possible case of (unsigned-byte 64)? 203 | ; 6CC: 8D42F1 LEA EAX, [RDX-15] 204 | ; 6CF: A80F TEST AL, 15 205 | ; 6D1: 752D JNE L3 206 | ; 6D3: 488B42F1 MOV RAX, [RDX-15] 207 | ; 6D7: 483D11010000 CMP RAX, 273 208 | ; 6DD: 7414 JEQ L2 209 | ; 6DF: 482D11020000 SUB RAX, 529 210 | ; 6E5: 7519 JNE L3 211 | ; 6E7: 48394201 CMP [RDX+1], RAX 212 | ; 6EB: 0F84BA000000 JEQ L13 <--- another possible case of (unsigned-byte 64) 213 | ; 6F1: EB0D JMP L3 214 | ; 6F3: L2: 488B42F9 MOV RAX, [RDX-7] 215 | ; 6F7: 4885C0 TEST RAX, RAX 216 | ; 6FA: 0F89AB000000 JNS L13 <--- again (unsigned-byte 64) 217 | ; 700: L3: F6C201 TEST DL, 1 218 | ; 703: 0F8498000000 JEQ L12 <--- fixnum (sure would have been easier to do this first!) 219 | ; 709: 8D42FD LEA EAX, [RDX-3] 220 | ; 70C: A80F TEST AL, 15 221 | ; 70E: 7516 JNE L4 222 | ; 710: 8B4201 MOV EAX, [RDX+1] 223 | ; 713: 81784D5B010000 CMP DWORD PTR [RAX+77], 347 224 | ; 71A: 750A JNE L4 225 | ; 71C: BA0A000000 MOV EDX, 10 226 | ; 721: E97BFFFFFF JMP L0 227 | ; 726: L4: 488D4AF1 LEA RCX, [RDX-15] 228 | ; 72A: F6C10F TEST CL, 15 229 | ; 72D: 752C JNE L5 230 | ; 72F: 8A09 MOV CL, [RCX] 231 | ; 731: 8BC1 MOV EAX, ECX 232 | ; 733: 3CD5 CMP AL, -43 233 | ; 735: 7460 JEQ L11 <--- (simple-array double-float (*)) 234 | ; 737: 8BC1 MOV EAX, ECX 235 | ; 739: 2C81 SUB AL, -127 236 | ; 73B: 3C64 CMP AL, 100 237 | ; 73D: 764E JBE L10 <--- simple-array 238 | ; 73F: 8BC1 MOV EAX, ECX 239 | ; 741: 2C85 SUB AL, -123 240 | ; 743: 3C70 CMP AL, 112 241 | ; 745: 763C JBE L9 <--- vector 242 | ; 747: 8BC1 MOV EAX, ECX 243 | ; 749: 3C81 CMP AL, -127 244 | ; 74B: 732C JAE L8 <--- array 245 | ; 74D: 8BC1 MOV EAX, ECX 246 | ; 74F: 3C15 CMP AL, 21 247 | ; 751: 741C JEQ L7 <--- ratio 248 | ; 753: 8BC1 MOV EAX, ECX 249 | ; 755: 2C21 SUB AL, 33 250 | ; 757: 3C08 CMP AL, 8 251 | ; 759: 760A JBE L6 <--- complex 252 | ; 75B: L5: BA17010050 MOV EDX, #x50000117 ; NIL 253 | ; 760: E93CFFFFFF JMP L0 <--- otherwise (no match) 254 | ; 765: L6: BA18000000 MOV EDX, 24 255 | ; 76A: E932FFFFFF JMP L0 256 | ; 76F: L7: BA16000000 MOV EDX, 22 257 | ; 774: E928FFFFFF JMP L0 258 | ; 779: L8: BA14000000 MOV EDX, 20 259 | ; 77E: E91EFFFFFF JMP L0 260 | ; 783: L9: BA12000000 MOV EDX, 18 261 | ; 788: E914FFFFFF JMP L0 262 | ; 78D: L10: BA10000000 MOV EDX, 16 263 | ; 792: E90AFFFFFF JMP L0 264 | ; 797: L11: BA0E000000 MOV EDX, 14 265 | ; 79C: E900FFFFFF JMP L0 266 | ; 7A1: L12: BA08000000 MOV EDX, 8 267 | ; 7A6: E9F6FEFFFF JMP L0 268 | ; 7AB: L13: BA06000000 MOV EDX, 6 269 | ; 7B0: E9ECFEFFFF JMP L0 270 | ; 7B5: L14: BA04000000 MOV EDX, 4 271 | ; 7BA: E9E2FEFFFF JMP L0 272 | ; 7BF: L15: BA02000000 MOV EDX, 2 273 | ; 7C4: E9D8FEFFFF JMP L0 274 | 275 | ## Conclusions 276 | 277 | So with some synthetic tests, you can see big differences here. In benchmarking.lisp, 278 | if you change the \*preferred-dispatch-order\* you can see on a long list of small integers 279 | that putting fixnum last in the dispatch slows things down from 550 million objects a second 280 | to about 300 million objects a second. Not a surprise, but nice to see. 281 | 282 | # Deserialization speed 283 | 284 | Here sbcl generates a nice jumptable for the case statement and I've ordered things more or 285 | less in a reasonable order by hand. -------------------------------------------------------------------------------- /src/numbers.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-binary-store) 2 | 3 | 4 | #+allegro 5 | (eval-when (:compile-toplevel) 6 | (setf declared-fixnums-remain-fixnums-switch t) 7 | (declaim (optimize (speed 3) (safety 0) 8 | (space 0) (debug 0) (compilation-speed 0)))) 9 | 10 | ;; See also unsigned-bytes.lisp for smaller unsigned numbers 11 | 12 | (declaim (inline store-sb8)) 13 | (defun store-sb8 (sb8 storage &optional (tag +sb8-code+)) 14 | "Store an (integer -255 0) value SB8 to STORAGE. Set TAG to NIL if your 15 | deserializer will know this is a SB8 value and the value will be written 16 | without a tag byte. It's a bit odd to have (integer -255 0) but the dispatch 17 | cost is negligible.... the tag byte is the sign bit." 18 | (declare (optimize (speed 3) (safety 1)) (type (integer -255 0) sb8) 19 | (type write-storage storage)) 20 | (let ((ub8 (- sb8))) 21 | (if tag 22 | (with-write-storage (storage :offset offset :reserve-bytes 2 :sap sap) 23 | (set-sap-ref-16 sap offset (+ tag (ash ub8 8)))) 24 | (with-write-storage (storage :offset offset :reserve-bytes 1 :sap sap) 25 | (set-sap-ref-8 sap offset ub8))))) 26 | 27 | (declaim (notinline store-sb16)) 28 | (defun store-sb16 (sb16 storage &optional (tag +sb16-code+)) 29 | (declare (optimize (speed 3) (safety 1)) (type (integer -65535 0) sb16)) 30 | (store-ub16 (- sb16) storage tag)) 31 | 32 | (declaim (notinline store-sb32)) 33 | (defun store-sb32 (sb32 storage &optional (tag +sb32-code+)) 34 | (declare (optimize (speed 3) (safety 1)) (type (integer -4294967295 0) sb32)) 35 | (store-ub32 (- sb32) storage tag)) 36 | 37 | (declaim (inline restore-sb8)) 38 | (defun restore-sb8 (storage) 39 | "Despite the name, restore an (integer -255 0) value from storage 40 | that has previously been stored by STORE-SB8" 41 | (- (restore-ub8 storage))) 42 | 43 | (declaim (notinline restore-sb16)) 44 | (defun restore-sb16 (storage) 45 | "Restore an (integer -65535 0) value from storage that has previously 46 | been stored by STORE-SB16." 47 | (- (restore-ub16 storage))) 48 | 49 | (declaim (notinline restore-sb32)) 50 | (defun restore-sb32 (storage) 51 | "Restore an (integer -4294967295 0) value from storage that has previously 52 | been stored by STORE-UB32." 53 | (- (restore-ub32 storage))) 54 | 55 | (declaim (inline store-only-fixnum)) 56 | (defun store-only-fixnum (fixnum storage &optional (tag +fixnum-code+)) 57 | (declare #-debug-cbs (optimize (speed 3) (safety 0)) (type fixnum fixnum) 58 | (type (or null write-storage) storage)) 59 | (with-write-storage (storage :offset offset :reserve-bytes (if tag 9 8) :sap sap) 60 | (when tag 61 | (set-sap-ref-8 sap offset tag) 62 | (incf offset)) 63 | (set-signed-sap-ref-64 sap offset fixnum))) 64 | 65 | (declaim (inline store-tagged-unsigned-fixnum)) 66 | (defun store-tagged-unsigned-fixnum (fixnum storage) 67 | "Store and tag a number from 0 to max-positive-fixnum. 68 | You can call `restore-tagged-unsigned-fixnum' to restore it (or restore-object). Do 69 | not call this except during the actual storage phase." 70 | (declare (optimize (speed 3) (safety 1)) 71 | (type fixnum fixnum) (type write-storage storage)) 72 | (if (<= fixnum +maximum-untagged-unsigned-integer+) 73 | (store-ub8/no-tag (truly-the fixnum (+ fixnum +small-integer-zero-code+)) storage) 74 | (if (< fixnum 256) 75 | (store-ub8/tag (truly-the fixnum fixnum) storage) 76 | (if (< fixnum 65536) 77 | (store-ub16 fixnum storage) 78 | (if (< fixnum #.(expt 2 32)) 79 | (store-ub32 fixnum storage) 80 | (store-only-fixnum fixnum storage)))))) 81 | 82 | (declaim (inline store-tagged-unsigned-fixnum/interior)) 83 | (defun store-tagged-unsigned-fixnum/interior (fixnum storage) 84 | "Use this paired with restore-tagged-unsigned-fixnum if you are inside another tagged 85 | region for storing unsigned numbers. Somewhat more dense as we only need tags 0-3 for 86 | tagging unsigned numbers." 87 | (declare (type fixnum fixnum) (type write-storage storage)) 88 | (if (<= fixnum +interior-coded-max-integer+) 89 | (store-ub8/no-tag (+ +first-direct-unsigned-integer-interior-code+ fixnum) 90 | storage) ;; direct coded 91 | (let ((fixnum (- fixnum +interior-coded-max-integer+ 1))) ;; code shifted 92 | (if (< fixnum 256) 93 | (store-ub8/tag (truly-the fixnum fixnum) storage) 94 | (if (< fixnum 65536) 95 | (store-ub16 fixnum storage) 96 | (if (< fixnum #.(expt 2 32)) 97 | (store-ub32 fixnum storage) 98 | (store-only-fixnum fixnum storage))))))) 99 | 100 | (declaim (inline restore-fixnum)) 101 | (defun restore-fixnum (storage) 102 | (declare (optimize (speed 3) (safety 0))) 103 | (ensure-enough-data storage 8) 104 | (let* ((offset (read-storage-offset storage)) 105 | (fixnum (signed-sap-ref-64 (read-storage-sap storage) offset))) 106 | (unless (typep fixnum 'fixnum) 107 | (unexpected-data "expected fixnum" fixnum)) 108 | (setf (read-storage-offset storage) (truly-the fixnum (+ offset 8))) 109 | (truly-the fixnum fixnum))) 110 | 111 | (declaim (inline store-fixnum)) 112 | (defun store-fixnum (fixnum storage) 113 | "Store and tag a fixnum; if inside another tag" 114 | (declare (type fixnum fixnum) (optimize (speed 3) (safety 1)) (type write-storage storage)) 115 | (if (>= fixnum 0) 116 | (store-tagged-unsigned-fixnum fixnum storage) 117 | (if (>= fixnum +minimum-untagged-signed-integer+) 118 | (store-ub8/no-tag (+ fixnum +small-integer-zero-code+) storage) 119 | (if (> fixnum -256) 120 | (store-sb8 fixnum storage) 121 | (if (> fixnum -65536) 122 | (store-sb16 fixnum storage) 123 | (if (> fixnum #.(- (expt 2 32))) 124 | (store-sb32 fixnum storage) 125 | (store-only-fixnum fixnum storage))))))) 126 | 127 | ;; Bignum code is based on code from the CL-STORE package which is 128 | ;; Copyright (c) 2004 Sean Ross 129 | ;; and follows the MIT license 130 | ;; and can be found at https://cl-store.common-lisp.dev/ 131 | (defun num->bits (num) 132 | (loop for val = (abs num) then (ash val -32) 133 | for count from 0 134 | until (zerop val) 135 | collect (logand val #XFFFFFFFF) into bits 136 | finally (return (values bits count)))) 137 | 138 | (defun bits->num (bits) 139 | (loop with sum = 0 140 | for pos from 0 by 32 141 | for bit in bits 142 | finally (return sum) 143 | :do (incf sum (* bit (expt 2 pos))))) 144 | 145 | (defun restore-bignum (storage) 146 | (declare (optimize (speed 3) (safety 1))) 147 | (let* ((count (restore-tagged-fixnum storage)) 148 | (num-words (abs count))) 149 | (declare (type fixnum count)) 150 | (unless (<= num-words (ash most-positive-fixnum -2)) 151 | (unexpected-data "number of words in bignum" num-words)) 152 | (check-if-too-much-data (read-storage-max-to-read storage) 153 | (truly-the fixnum (* 4 num-words))) 154 | (let ((sum 0)) 155 | (loop 156 | repeat num-words 157 | for pos from 0 by 32 158 | do 159 | (ensure-enough-data storage 4) 160 | (incf sum (* (restore-ub32 storage) (expt 2 pos)))) 161 | (* (if (< count 0) -1 1) sum)))) 162 | 163 | (defun store-bignum (bignum storage) 164 | (when storage 165 | (with-write-storage (storage :offset offset :reserve-bytes 1 :sap sap) 166 | (set-sap-ref-8 sap offset +bignum-code+)) 167 | (multiple-value-bind (ub32s count) 168 | (num->bits bignum) 169 | (declare (type fixnum count)) 170 | (store-fixnum (if (minusp bignum) (- count) count) storage) 171 | (dolist (ub32 ub32s) (store-ub32 ub32 storage nil))))) 172 | 173 | (declaim (inline restore-single-float)) 174 | (defun restore-single-float (storage) 175 | (declare (optimize (speed 3) (safety 1))) 176 | (ensure-enough-data storage 4) 177 | (let ((offset (read-storage-offset storage)) 178 | (sap (read-storage-sap storage))) 179 | (setf (read-storage-offset storage) (truly-the fixnum (+ 4 offset))) 180 | (sap-ref-single sap offset))) 181 | 182 | (declaim (inline store-single-float)) 183 | (defun store-single-float (single-float storage &optional (tag t)) 184 | (declare (optimize (speed 3) (safety 1)) (type single-float single-float)) 185 | (with-write-storage (storage :offset offset :reserve-bytes (if tag 5 4) :sap sap) 186 | (when tag 187 | (set-sap-ref-8 sap offset +single-float-code+) 188 | (incf offset)) 189 | (set-sap-ref-single sap offset single-float))) 190 | 191 | (declaim (inline restore-double-float)) 192 | (defun restore-double-float (storage) 193 | (declare (optimize (speed 3) (safety 1))) 194 | (ensure-enough-data storage 8) 195 | (let ((offset (read-storage-offset storage)) 196 | (sap (read-storage-sap storage))) 197 | (setf (read-storage-offset storage) (truly-the fixnum (+ 8 offset))) 198 | (sap-ref-double sap offset))) 199 | 200 | (declaim (inline restore-double-float-zero)) 201 | (defun restore-double-float-zero () 202 | 0d0) 203 | 204 | (defmacro restore-double-float-to (slot storage) 205 | "Restore a double-float to an object that is not 206 | constructed yet." 207 | (assert (atom storage)) 208 | `(progn 209 | (ensure-enough-data ,storage 8) 210 | (let ((offset (read-storage-offset ,storage)) 211 | (sap (read-storage-sap ,storage))) 212 | (setf (read-storage-offset ,storage) (truly-the fixnum (+ 8 offset))) 213 | (setf ,slot (sap-ref-double sap offset))))) 214 | 215 | (declaim (inline store-double-float)) 216 | (defun store-double-float (double-float storage double-float-refs assign-new-reference-id 217 | &optional (tag t)) 218 | (declare (optimize (speed 3) (safety 1)) (type double-float double-float)) 219 | ;; We de-duplicate double-floats as there is no visible way to 220 | ;; determine this from common lisp, and it saves space in the image 221 | ;; and on disk if there are repeated numbers (like 0d0). 222 | (if (= double-float 0d0) 223 | (when storage 224 | (storage-write-byte storage +double-float-zero-code+)) 225 | (maybe-store-reference-instead (double-float storage double-float-refs 226 | assign-new-reference-id) 227 | (with-write-storage (storage :offset offset :reserve-bytes (if tag 9 8) :sap sap) 228 | (when tag 229 | (set-sap-ref-8 sap offset +double-float-code+) 230 | (incf offset)) 231 | (set-sap-ref-double sap offset double-float))))) 232 | 233 | (declaim (inline ensure-integer)) 234 | (defun ensure-integer (x) 235 | (if (integerp x) 236 | x 237 | (progn (unexpected-data "expected an integer") 0))) 238 | 239 | (defun restore-ratio (restore-object) 240 | (declare (optimize (speed 3) (safety 1)) (type function restore-object)) 241 | (let ((a (ensure-integer (funcall restore-object))) 242 | (b (ensure-integer (funcall restore-object)))) 243 | (declare (type integer a b)) 244 | (when (= b 0) 245 | (unexpected-data "ratio denominator is 0")) 246 | (/ (the integer a) (the integer b)))) 247 | 248 | (defun store-ratio (ratio storage num-eq-refs assign-new-reference-id) 249 | "Nominally we don't need to do references here, but if someone has two bignums and takes 250 | a ratio of them, we don't want to store the bignums twice." 251 | (declare (optimize (speed 3) (safety 1))) 252 | (maybe-store-reference-instead (ratio storage num-eq-refs assign-new-reference-id) 253 | (with-write-storage (storage :offset offset :sap sap :reserve-bytes 1) 254 | (set-sap-ref-8 sap offset +ratio-code+)) 255 | (labels ((store-integer (integer) 256 | (if (typep integer 'fixnum) 257 | (when storage (store-fixnum integer storage)) 258 | (store-bignum integer storage)))) 259 | (store-integer (numerator ratio)) 260 | (store-integer (denominator ratio))))) 261 | 262 | (declaim (inline ensure-real)) 263 | (defun ensure-real (x) 264 | (if (typep x 'real) 265 | x 266 | (progn (unexpected-data "real") 0))) 267 | 268 | (defun restore-complex (restore-object) 269 | (declare (type function restore-object)) 270 | (complex (ensure-real (funcall restore-object)) 271 | (ensure-real (funcall restore-object)))) 272 | 273 | (declaim (inline restore-complex-double-float)) 274 | (defun restore-complex-double-float (storage) 275 | (declare (optimize (speed 3) (safety 1))) 276 | (complex (restore-double-float storage) 277 | (restore-double-float storage))) 278 | 279 | (declaim (inline store-complex-double-float)) 280 | (defun store-complex-double-float (complex-double-float storage) 281 | (declare (optimize (speed 3) (safety 1)) (type (complex double-float) complex-double-float)) 282 | (with-write-storage (storage :offset offset :sap sap :reserve-bytes 1) 283 | (set-sap-ref-8 sap offset +complex-double-float-code+)) 284 | (store-double-float (realpart complex-double-float) storage nil nil nil) 285 | (store-double-float (imagpart complex-double-float) storage nil nil nil)) 286 | 287 | (declaim (inline restore-complex-single-float)) 288 | (defun restore-complex-single-float (storage) 289 | (declare (optimize (speed 3) (safety 1))) 290 | (complex (restore-single-float storage) 291 | (restore-single-float storage))) 292 | 293 | (declaim (inline store-complex-single-float)) 294 | (defun store-complex-single-float (complex-single-float storage) 295 | (declare (optimize (speed 3) (safety 1)) (type (complex single-float) complex-single-float)) 296 | (with-write-storage (storage :offset offset :sap sap :reserve-bytes 1) 297 | (set-sap-ref-8 sap offset +complex-single-float-code+)) 298 | (store-single-float (realpart complex-single-float) storage nil) 299 | (store-single-float (imagpart complex-single-float) storage nil)) 300 | 301 | (defun store-complex (complex storage store-object) 302 | (declare (type complex complex) (type (or null write-storage) storage)) 303 | (typecase complex 304 | ;; We do not try to match double-floats in complex numbers to others... (except 0d0) 305 | ((complex double-float) (store-complex-double-float complex storage)) 306 | ((complex single-float) (store-complex-single-float complex storage)) 307 | (t 308 | (with-write-storage (storage :offset offset :reserve-bytes 1 :sap sap) 309 | (set-sap-ref-8 sap offset +complex-code+)) 310 | (locally (declare (type function store-object)) 311 | ;; We know it's a number, but overhead is small 312 | (funcall store-object (realpart complex)) 313 | (funcall store-object (imagpart complex)))))) 314 | 315 | (declaim (inline restore-tagged-unsigned-fixnum/interior)) 316 | (defun restore-tagged-unsigned-fixnum/interior (storage) 317 | "Use this if you know that this is an unsigned number (so after 318 | another tag bit). This opens up the direct coding space for up to 319 | +interior-coded-max-integer+." 320 | (declare (type read-storage storage) (optimize (speed 3) (safety 1))) 321 | (let ((tag (restore-ub8 storage))) 322 | (if (>= tag +first-direct-unsigned-integer-interior-code+) 323 | (- tag +first-direct-unsigned-integer-interior-code+) 324 | (truly-the fixnum 325 | (+ (case tag 326 | (#.+ub8-code+ (restore-ub8 storage)) 327 | (#.+ub16-code+ (restore-ub16 storage)) 328 | (#.+ub32-code+ (restore-ub32 storage)) 329 | (#.+fixnum-code+ 330 | (let ((fixnum (restore-fixnum storage))) 331 | (unless (<= 0 fixnum (- most-positive-fixnum +interior-coded-max-integer+ 1)) 332 | (unexpected-data "expected unsigned fixnum/interior" fixnum)) 333 | (truly-the fixnum fixnum))) 334 | (otherwise (unexpected-data "expected tag for unsigned fixnum" tag))) 335 | +interior-coded-max-integer+ 1))))) 336 | 337 | (declaim (ftype (function (read-storage) 338 | #+sbcl (values fixnum &optional) 339 | #-sbcl fixnum) 340 | restore-tagged-unsigned-fixnum)) 341 | (defun restore-tagged-unsigned-fixnum (storage) 342 | "Read back a number written by `store-tagged-unsigned-fixnum'." 343 | (declare (optimize (speed 3) (safety 1))) 344 | (let ((tag (restore-ub8 storage))) 345 | (if (<= +small-integer-zero-code+ tag +last-small-integer-code+) 346 | (- tag +small-integer-zero-code+) 347 | (case tag 348 | (#.+ub8-code+ (restore-ub8 storage)) 349 | (#.+ub16-code+ (restore-ub16 storage)) 350 | (#.+ub32-code+ (restore-ub32 storage)) 351 | (#.+fixnum-code+ (restore-fixnum storage)) 352 | (otherwise (unexpected-data "expected tag for unsigned fixnum" tag)))))) 353 | 354 | (declaim (ftype (function (read-storage) 355 | #+sbcl (values fixnum &optional) 356 | #-sbcl fixnum) restore-tagged-fixnum)) 357 | (defun restore-tagged-fixnum (storage) 358 | "Read back a number written by `store-tagged-unsigned-fixnum'." 359 | (let ((tag (restore-ub8 storage))) 360 | (if (<= +first-small-integer-code+ tag +last-small-integer-code+) 361 | (- tag +small-integer-zero-code+) 362 | (case tag 363 | (#.+ub8-code+ (restore-ub8 storage)) 364 | (#.+ub16-code+ (restore-ub16 storage)) 365 | (#.+ub32-code+ (restore-ub32 storage)) 366 | (#.+fixnum-code+ (restore-fixnum storage)) 367 | (#.+sb8-code+ (restore-sb8 storage)) 368 | (#.+sb16-code+ (restore-sb16 storage)) 369 | (#.+sb32-code+ (restore-sb32 storage)) 370 | (otherwise (unexpected-data "expected tag for fixnum" tag)))))) 371 | 372 | (declaim (inline store-tagged-unsigned-integer)) 373 | 374 | (defun store-tagged-unsigned-integer (integer storage) 375 | "Store and tag any unsigned integer. For restoring this, call restore-object as this may 376 | be a bignum. Prefer `store-tagged-unsigned-fixnum' if you are sure this isn't a bignum" 377 | (if (typep integer 'fixnum) 378 | (when storage 379 | (store-tagged-unsigned-fixnum integer storage)) 380 | (store-bignum integer storage))) 381 | -------------------------------------------------------------------------------- /src/objects.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-binary-store) 2 | 3 | ;; Here we deal with `STRUCTURE-OBJECT's and `STANDARD-OBJECT's 4 | ;; For each object type we meet, we serialize / deserialize a 5 | ;; single description of it an `object-info'. That contains the 6 | ;; type-name and slot-values. Locally during store and restore we 7 | ;; also keep track of any user specified extension behaviors within 8 | ;; this `object-info'. 9 | 10 | ;; During restore, we provide reasonable and comprehensive restarts 11 | ;; for missing defstruct, defclass, and slots. 12 | 13 | (defvar *store-class-slots* nil 14 | "If set / let to T, then slots in standard-objects with :class allocation 15 | will be stored, otherwise not.") 16 | 17 | ;; We provide three extension points to customize how objects are 18 | ;; serialized and deserialized. 19 | 20 | ;; First is `SERIALIZABLE-OBJECT-INFO' which may return slot-names to 21 | ;; serialize or a function that will be called on each object and 22 | ;; slot-name to determine what to serialize for it. 23 | ;; 24 | ;; For example: 25 | ;; (defstruct blarg 26 | ;; (a-may-contain-sensitive-info) 27 | ;; (b-do-not-serialize)) 28 | ;; 29 | ;; (defmethod serializable-object-info ((type (eql 'blarg))) 30 | ;; (values (vector 'a-may-contain-sensitive-info) nil)) 31 | ;; 32 | ;; If you use the above technique for a structure-object, you may want 33 | ;; to provide a `specialized-object-constructor' too as the 34 | ;; unserialized slots are undefined. For a standard-object they are 35 | ;; just unbound which is fine, but for a structure-object it's 36 | ;; undefined what they are. 37 | ;; 38 | ;; Or if you want to filter out sensitive information on a per object basis: 39 | ;; 40 | ;; (defmethod serializable-object-info ((type (eql 'blarg))) 41 | ;; (values nil 42 | ;; (lambda (slot-name slot-value) 43 | ;; (if (sensitive-information-p slot-name slot-value) 44 | ;; "censored" 45 | ;; slot-value)))) 46 | 47 | ;; Second is `SPECIALIZED-OBJECT-CONSTRUCTOR' which can return a function 48 | ;; which will be used to build an object from restored slot values. The 49 | ;; function will be called with an object-info structure and a dynamic-extent 50 | ;; simple-vector of slot values equal to the length and in the same order as 51 | ;; (object-info-slot-names object-info). 52 | 53 | ;; Warning: be careful here if you have circular references. 54 | 55 | ;; Convenient if you want to have, for example, initialize-instance called on your object 56 | ;; instead of the default allocate-instance: 57 | ;; 58 | ;; (defmethod specialized-object-constructor ((type (eql 'my-type))) 59 | ;; (lambda (object-info slot-values) 60 | ;; (apply #'make-instance 'my-type 61 | ;; (garble (object-info-slot-names object-info) slot-values)))) 62 | 63 | 64 | ;; (defmethod initialize-instance :after 65 | ;; ((obj my-object-type &rest initargs &key &allow-other-keys)) 66 | ;; ;; do something here to touch up obj or cause side effects 67 | ;; ) 68 | 69 | ;; Third is `SPECIALIZED-SERIALIZER/DESERIALIZER' which can return as 70 | ;; two values, two functions which will replace the default 71 | ;; serialization / deserialization of objects of that type. If you do 72 | ;; this, you probably want to define a new codespace anyway, so you 73 | ;; could just do it directly with defstore / defrestore functions, but 74 | ;; there is no penalty to doing it this way. 75 | 76 | ;; The specialized-serializer function will be called with 77 | ;; (lambda (object storage eq-refs store-object assign-new-reference-id)) 78 | ;; which should have the side effect of modifying storage, eq-refs, calling store-object 79 | ;; and or assign-new-reference-id. 80 | ;; Correspondingly, the specialized-deserializer function will be called with: 81 | ;; (lambda (storage restore-object) 82 | 83 | (defun get-slot-names (class) 84 | "Return a list of slot names (symbols) skipping :class allocation slots if 85 | *store-class-slots* is t." 86 | (assert class) 87 | (unless (class-finalized-p class) 88 | (finalize-inheritance class)) 89 | (loop with store-class-slots = *store-class-slots* 90 | with is-structure-object = (or (typep class 'structure-class) ;; allegro work around 91 | (subtypep class 'structure-class)) 92 | for slot in (class-slots class) 93 | when (or is-structure-object 94 | store-class-slots 95 | (not (eql (slot-definition-allocation slot) :class))) 96 | collect 97 | #+abcl (if is-structure-object 98 | (sys::dsd-name slot) 99 | (slot-definition-name slot)) 100 | #-abcl (slot-definition-name slot))) 101 | 102 | (defgeneric serializable-object-info (type) 103 | (:documentation 104 | "Must return two values. The first value must be a 105 | list of slot-names (symbols) which should be serialized for this 106 | object. 107 | 108 | The second value may be NIL or a function which will be 109 | called with each slot-name and slot-value and should return a 110 | serializable object (like nil) for that slot.") 111 | (:method (type) 112 | (get-slot-names (find-class type)))) 113 | 114 | (defgeneric specialized-object-constructor (type) 115 | (:documentation "May return a function that will be used to construct an object from 116 | an `object-info' structure and a simple vector of slot-values in the same order as 117 | (object-info-slot-names object-info): 118 | (lambda (object-info slot-values) -> object) 119 | Be careful in the case of circular references: it may be in that case that a slot-value 120 | is a `fixup', in which case you have to provide a function to be called back when the 121 | object is fully reified. See restore-object-to for the logic.") 122 | (:method (type) 123 | (declare (ignorable type)) 124 | nil)) 125 | 126 | (defgeneric specialized-serializer/deserializer (type) 127 | (:documentation "Returns two values, the first value is a 128 | function (or nil) that will be called as a: 129 | (lambda (object storage eq-refs store-object assign-new-reference-id)) 130 | and as side effects should write to storage, etc. The second value should be a function 131 | that has a signature (lambda (storage restore-object) -> object)") 132 | (:method (type) 133 | (declare (ignorable type)) 134 | (values nil nil))) 135 | 136 | (defun compute-object-info (type implicit-ref-id) 137 | "Takes a symbol denoting the type of an object and returns an `object-info' allowing for 138 | the various user methods to override behaviors." 139 | (declare (optimize speed safety)) 140 | (multiple-value-bind (slot-names slot-value-filter-func) 141 | (serializable-object-info type) 142 | (let* ((slot-names-vector (coerce (the list slot-names) 'simple-vector))) 143 | (multiple-value-bind (specialized-serializer specialized-deserializer) 144 | (specialized-serializer/deserializer type) 145 | (make-object-info 146 | :class (find-class type) 147 | :type type 148 | :slot-names slot-names-vector 149 | :slot-value-filter-func slot-value-filter-func 150 | :specialized-constructor (specialized-object-constructor type) 151 | :specialized-serializer specialized-serializer 152 | :specialized-deserializer specialized-deserializer 153 | :ref-id (- (the fixnum (incf (the fixnum (car implicit-ref-id)))))))))) 154 | 155 | (defmacro maybe-store-local-reference-instead ((object-info storage eql-refs) &body body) 156 | "Called during the serialization / storage phase. This is a kludged 157 | implicit referencing scheme used when the global *track-references* 158 | is disabled. This lets us avoid calculating and writing and reading 159 | what each object type is." 160 | (assert (atom storage)) ;; or rewrite to use alexandria:once-only 161 | (assert (atom object-info)) 162 | (assert (atom eql-refs)) 163 | `(unless (and ,eql-refs storage 164 | (cond 165 | ((gethash ,object-info ,eql-refs) 166 | ;; We have already stored this object-info, write a reference to it 167 | (store-ub8/no-tag +object-info-code+ ,storage) 168 | (store-fixnum (object-info-ref-id ,object-info) ,storage) 169 | t) 170 | (t 171 | (setf (gethash ,object-info ,eql-refs) t) 172 | nil))) 173 | ,@body)) 174 | 175 | (defun maybe-store-to-reference-table (object-info implicit-eql-refs) 176 | "Called during the deserialization / restore phase. We store the constructed 177 | object-info into our reference hash table using its reference id." 178 | (when implicit-eql-refs 179 | (setf (gethash (object-info-ref-id object-info) implicit-eql-refs) object-info)) 180 | object-info) 181 | 182 | (defun store-object-info (object-info storage eq-refs store-object implicit-eql-refs 183 | assign-new-reference-id) 184 | (declare (optimize speed safety) (type object-info object-info)) 185 | (maybe-store-reference-instead (object-info storage eq-refs assign-new-reference-id) 186 | (maybe-store-local-reference-instead (object-info storage implicit-eql-refs) 187 | (let ((slot-names (object-info-slot-names object-info))) 188 | (when storage 189 | (store-ub8/no-tag +object-info-code+ storage) 190 | (store-tagged-unsigned-fixnum (length slot-names) storage)) 191 | (store-symbol (object-info-type object-info) storage eq-refs store-object 192 | assign-new-reference-id) 193 | (loop for name across slot-names 194 | do (store-symbol name storage eq-refs store-object assign-new-reference-id)))))) 195 | 196 | (define-condition object-type-not-found (maybe-expected-error) 197 | ((object-info :initarg :object-info :reader object-type-not-found-object-info))) 198 | 199 | (defmethod print-object ((obj object-type-not-found) str) 200 | (let ((object-info (object-type-not-found-object-info obj))) 201 | (format str "Class or struct of type ~S not found" (object-info-type object-info)))) 202 | 203 | (defun ask-for-new-class () 204 | (format t "Enter a new class or struct type name (unquoted symbol): ") 205 | (list (read))) 206 | 207 | (defun use-custom-building-function () 208 | (format t "Enter a function which will build instances from slot-values~%That is with signature (lambda (object-info slot-values) constructed-object): ") 209 | (let ((read (read))) 210 | (list (eval read)))) 211 | 212 | (defun function-designator-p (thing) 213 | (if (symbolp thing) (symbol-function thing) (functionp thing))) 214 | 215 | (defun signal-object-type-not-found (object-info) 216 | (restart-case 217 | (error 'object-type-not-found :object-info object-info) 218 | (use-different-class (new-type) 219 | :report "USE DIFFERENT CLASS" 220 | :interactive ask-for-new-class 221 | (setf (object-info-type object-info) new-type)) 222 | (create-standard-object () 223 | :report "CREATE STANDARD OBJECT" 224 | (eval `(defclass ,(object-info-type object-info) () 225 | ,(loop for slot-name across (object-info-slot-names object-info) 226 | collect (list slot-name)))) 227 | (finalize-inheritance (find-class (object-info-type object-info)))) 228 | (create-structure-object () 229 | :report "CREATE STRUCTURE OBJECT" 230 | (eval `(defstruct ,(object-info-type object-info) 231 | ,@(loop for slot-name across (object-info-slot-names object-info) 232 | collect (list slot-name nil)))) 233 | (finalize-inheritance (find-class (object-info-type object-info)))))) 234 | 235 | (defun really-find-class (object-info) 236 | (loop for class = (setf (object-info-class object-info) 237 | (find-class (object-info-type object-info) nil)) 238 | until class 239 | do (signal-object-type-not-found object-info) 240 | finally (return class))) 241 | 242 | (define-condition missing-slot (maybe-expected-error) 243 | ((slot-name :initarg :slot-name :reader missing-slot-name) 244 | (type :initarg :type :reader missing-slot-type) 245 | (data-slots :initarg :data-slots :reader missing-slot-data-slots) 246 | (image-slots :initarg :image-slots :reader missing-slot-image-slots))) 247 | 248 | (defmethod print-object ((obj missing-slot) stream) 249 | (format stream "Missing slot ~S in ~S, data file has slots ~A, current image has slots ~A" 250 | (missing-slot-name obj) (missing-slot-type obj) 251 | (missing-slot-data-slots obj) (missing-slot-image-slots obj))) 252 | 253 | (defun ask-for-new-slot-name () 254 | (format t "Enter a slot-name to store value into (string or symbol): ") 255 | (let ((read (read))) 256 | (list (if (stringp read) (intern read) read)))) 257 | 258 | (defun validate-slot-names (type restored-slot-names image-slot-names) 259 | "If all of restored-slot-names are a subset of current-image-slot-names just 260 | return restored-slot-names. If not, provide restarts to allow building of a 261 | work around for the user. May return a specialized-object-constructor." 262 | (declare (type simple-vector restored-slot-names) (type list image-slot-names)) 263 | (let ((ignorable-slots) 264 | (renamed-slots)) 265 | (loop for slot-name across restored-slot-names 266 | unless (find slot-name image-slot-names) 267 | do (restart-case 268 | (error 'missing-slot :slot-name slot-name :type type 269 | :data-slots restored-slot-names 270 | :image-slots image-slot-names) 271 | (discard () 272 | :report "DISCARD SLOT DATA" 273 | (push slot-name ignorable-slots)) 274 | (map-to-new-slot-name (new-slot-name) 275 | :report "STORE TO DIFFERENT SLOT" 276 | :interactive ask-for-new-slot-name 277 | (push (cons slot-name new-slot-name) renamed-slots)))) 278 | (when (or ignorable-slots renamed-slots) 279 | (lambda (object-info slot-values) 280 | (let* ((class (object-info-class object-info)) 281 | (struct (allocate-instance class))) 282 | (loop for name across (object-info-slot-names object-info) 283 | for value in slot-values 284 | unless (find name ignorable-slots) 285 | do (setf 286 | (slot-value struct (or (cdr (assoc name renamed-slots)) name)) 287 | value)) 288 | struct))))) 289 | 290 | (defun restore-object-info (storage restore-object implicit-eql-refs implicit-ref-id) 291 | (declare (optimize speed safety) (type function restore-object)) 292 | (let* ((num-slots (restore-tagged-fixnum storage))) 293 | (if (< num-slots 0) ; it's a reference id, look it up in our implicit tracking table 294 | (gethash num-slots implicit-eql-refs) 295 | (progn 296 | (if (> num-slots (ash most-positive-fixnum -3)) 297 | (unexpected-data "too many slots in object-info" num-slots) 298 | (check-if-too-much-data (read-storage-max-to-read storage) (* 8 num-slots))) 299 | (let ((slot-name-vector (make-array num-slots)) 300 | (type (funcall restore-object)) 301 | (ref-id (- (the fixnum (incf (the fixnum (car implicit-ref-id))))))) 302 | (unless (symbolp type) 303 | (unexpected-data "expected a symbol")) 304 | ;; No circularity possible below as these are symbols 305 | (loop for idx fixnum from 0 below num-slots 306 | do (setf (svref slot-name-vector idx) (funcall restore-object))) 307 | (multiple-value-bind (specialized-serializer specialized-deserializer) 308 | (specialized-serializer/deserializer type) 309 | (declare (ignore specialized-serializer)) 310 | (let ((specialized-constructor (specialized-object-constructor type))) 311 | (cond 312 | ((or specialized-constructor specialized-deserializer) 313 | (maybe-store-to-reference-table 314 | (make-object-info :class nil :type type 315 | :specialized-constructor specialized-constructor 316 | :specialized-deserializer specialized-deserializer 317 | :slot-names slot-name-vector 318 | :ref-id ref-id) 319 | implicit-eql-refs)) 320 | (t 321 | (let* ((si (maybe-store-to-reference-table 322 | (make-object-info 323 | :type type :slot-names slot-name-vector :ref-id ref-id) 324 | implicit-eql-refs)) 325 | (class (really-find-class si))) 326 | (setf (object-info-class si) class) 327 | (setf (object-info-type si) (class-name class)) 328 | (let ((image-slot-names (get-slot-names class))) 329 | ;; Now validate that the slot-names we restored are a subset of 330 | ;; those in the current image object 331 | (setf (object-info-specialized-constructor si) 332 | (validate-slot-names type slot-name-vector image-slot-names)) 333 | ;; The order of slot names may be different, use the order 334 | ;; stored in the file! 335 | (setf (object-info-slot-names si) slot-name-vector)) 336 | si)))))))))) 337 | 338 | (defun get-object-info (object object-info implicit-ref-id) 339 | (let ((type (type-of object))) 340 | (or (gethash type object-info) 341 | (setf (gethash type object-info) 342 | (compute-object-info type implicit-ref-id))))) 343 | 344 | (declaim (inline store-unbound)) 345 | (defun store-unbound (storage) 346 | (store-ub8/no-tag +unbound-code+ storage)) 347 | 348 | (declaim (inline restore-unbound)) 349 | (defun restore-unbound () 350 | 'unbound-slot) 351 | 352 | (defun store-standard/structure-object 353 | (obj storage eq-refs store-object assign-new-reference-id is-standard-object object-info 354 | implicit-eql-refs implicit-ref-id) 355 | (declare (optimize speed safety) (type (or structure-object standard-object condition) obj)) 356 | (maybe-store-reference-instead (obj storage eq-refs assign-new-reference-id) 357 | (when storage 358 | (store-ub8/no-tag +standard/structure-object-code+ storage)) 359 | (let* ((object-info (get-object-info obj object-info implicit-ref-id)) 360 | (object-info-specialized-serializer (object-info-specialized-serializer object-info))) 361 | (cond 362 | (object-info-specialized-serializer 363 | (funcall object-info-specialized-serializer 364 | obj storage eq-refs store-object assign-new-reference-id)) 365 | (t 366 | (store-object-info object-info storage eq-refs store-object implicit-eql-refs 367 | assign-new-reference-id) 368 | (let ((filter (object-info-slot-value-filter-func object-info))) 369 | (declare (type function store-object)) 370 | (if is-standard-object 371 | (loop for name across (object-info-slot-names object-info) 372 | do (if (slot-boundp obj name) 373 | (let* ((value (slot-value obj name)) 374 | (filtered-value (if filter (funcall filter name value) value))) 375 | (funcall store-object filtered-value)) 376 | (when storage (store-unbound storage)))) 377 | (loop for name across (object-info-slot-names object-info) ;; structure-object 378 | for value = (slot-value obj name) 379 | for filtered-value = (if filter (funcall filter name value) value) 380 | do (funcall store-object filtered-value))))))))) 381 | 382 | (defun (setf slot-value*) (value object name) 383 | "Handle internal 'unbound-slot value" 384 | (if (eq value 'unbound-slot) 385 | (slot-makunbound object name) 386 | (setf (slot-value object name) value))) 387 | 388 | (defun restore-standard/structure-object (storage restore-object) 389 | (declare (type function restore-object) (ignorable storage) (optimize speed safety)) 390 | (let ((object-info (funcall restore-object))) 391 | (unless (object-info-p object-info) 392 | (unexpected-data "expected an object-info")) 393 | (let* ((specialized-deserializer (object-info-specialized-deserializer object-info)) 394 | (constructor (object-info-specialized-constructor object-info))) 395 | (cond 396 | (specialized-deserializer 397 | (funcall specialized-deserializer storage restore-object)) 398 | (constructor 399 | (let* ((slot-names (object-info-slot-names object-info)) 400 | (num-slots (length slot-names)) 401 | (slot-values (make-list num-slots))) 402 | (declare (dynamic-extent slot-values) (type (unsigned-byte 16) num-slots)) 403 | (loop for value on slot-values 404 | do (setf (car value) (funcall restore-object))) 405 | (funcall constructor object-info slot-values))) 406 | (t 407 | (let* ((class (object-info-class object-info)) 408 | (obj (allocate-instance class))) 409 | (if (typep class 'structure-class) 410 | (loop for name across (object-info-slot-names object-info) 411 | do (restore-object-to (slot-value obj name) restore-object)) 412 | (loop for name across (object-info-slot-names object-info) 413 | do (restore-object-to (slot-value* obj name) restore-object))) 414 | obj)))))) 415 | -------------------------------------------------------------------------------- /src/storage.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-binary-store) 2 | 3 | (defvar *max-to-write* 10000000000 4 | "The default maximum of data to write to disk (10GB) before complaining.") 5 | 6 | (defvar *max-to-read* 2000000000 7 | "The maximum amount of data to restore (2GB) before complaining.") 8 | 9 | (defvar *load/save-progress-indicator* nil 10 | "If T will write out some progress while loading and saving") 11 | 12 | (declaim (inline make-read-storage read-storage-offset read-storage-max read-storage-sap 13 | read-storage-flusher read-storage-store read-storage-size 14 | read-storage-underlying-stream read-storage-total-read 15 | read-storage-max-to-read 16 | (setf read-storage-offset))) 17 | 18 | (defstruct read-storage 19 | "A static memory buffer (SAP) with an OFFSET, which is the offset in bytes of the 20 | first valid piece of unread data in SAP. Then MAX which is the end of valid data 21 | within the buffer. Then SIZE is the size in bytes of the SAP (used to inform chunked 22 | copying). FLUSHER is a (lambda (storage)) which when called will try to fill the buffer 23 | with new data. It will return the number of available bytes and may modify offset and 24 | max. 25 | 26 | We also have a STORE, which *may* if it exists be a 27 | (simple-array (unsigned-byte 8) (SIZE)) which the static memory 28 | buffer is based on (used only to speed up utf8 encoding). 29 | UNDERLYING-STREAM which will be a stream if we are just a buffer in 30 | front of a stream (unused). 31 | 32 | The flusher is responsible for updating total-read and checking against max-to-read" 33 | (offset 0 :type fixnum) 34 | (max 0 :type fixnum) 35 | (sap nil #+sbcl :type #+sbcl sb-alien::system-area-pointer 36 | #+allegro :type #+allegro fixnum) 37 | (size 0 :type fixnum) 38 | (flusher nil :type function) ;; reads more data (lambda (storage)) 39 | (store nil :type (or null (simple-array (unsigned-byte 8) (*)))) 40 | (underlying-stream nil :type (or null stream)) 41 | (total-read 0 :type fixnum) 42 | (max-to-read *max-to-read* :type fixnum)) 43 | 44 | (declaim (inline make-write-storage write-storage-offset write-storage-max write-storage-sap 45 | write-storage-flusher write-storage-store write-storage-size 46 | write-storage-underlying-stream 47 | (setf write-storage-offset))) 48 | (defstruct write-storage 49 | "A static memory buffer (SAP) with an OFFSET, which is the offset in bytes where you should 50 | write new data to. MAX is the size of the SAP buffer. STORE, if it exists, is an 51 | (simple-array (unsigned-byte 8) (MAX)) which is the vector on which the SAP is based. 52 | FLUSHER is a function (lambda (write-storage)) which flushes data out of the buffer and returns the 53 | new OFFSET (and updates OFFSET). UNDERLYING-STREAM, if exists, is the stream which is is used by 54 | the flusher." 55 | (offset 0 :type fixnum) ;; index of the next valid location to write data to 56 | (max 0 :type fixnum) ;; size of SAP in bytes 57 | (sap nil #+sbcl :type #+sbcl sb-alien::system-area-pointer 58 | #+allegro :type #+allegro fixnum) 59 | (flusher nil :type function) ;; writes out data from sap/store and returns new storage-offset 60 | (store nil :type (or null (simple-array (unsigned-byte 8) (*)))) 61 | (underlying-stream nil :type (or null stream))) 62 | 63 | (defmacro truly-the (type &body body) 64 | #+sbcl `(sb-ext:truly-the ,type ,@body) 65 | #-sbcl `(the ,type ,@body)) 66 | 67 | (defmacro with-write-storage ((storage &key offset reserve-bytes sap) 68 | &body body) 69 | "Skips the body if storage does not exist, like during the reference scanning phase" 70 | (assert (atom storage)) 71 | (let ((original-offset (gensym)) 72 | (reserve-bytes-sym (when reserve-bytes (gensym "RESERVE")))) 73 | `(when storage 74 | (let* (,@(when reserve-bytes `((,reserve-bytes-sym ,reserve-bytes))) 75 | (,original-offset ,(if reserve-bytes 76 | `(ensure-enough-room-to-write ,storage ,reserve-bytes-sym) 77 | `(write-storage-offset ,storage))) 78 | ,@(when offset `((,offset ,original-offset))) 79 | ,@(when sap 80 | `((,sap (write-storage-sap ,storage))))) 81 | (declare (ignorable ,original-offset) (type fixnum ,offset)) 82 | (progn ,@body 83 | ,(when reserve-bytes 84 | `(setf (write-storage-offset ,storage) (truly-the fixnum (+ ,original-offset ,reserve-bytes-sym))))))))) 85 | 86 | (declaim (inline storage-write-byte)) 87 | (defun storage-write-byte (storage byte) 88 | (with-write-storage (storage :offset offset :reserve-bytes 1 :sap sap) 89 | (set-sap-ref-8 sap offset byte))) 90 | 91 | (defmethod print-object ((s write-storage) stream) 92 | (print-unreadable-object (s stream :type t :identity t) 93 | (format stream "WRITE-STORAGE (FROM ~A), OFFSET: ~A MAX: ~A SAP: ~A" 94 | (cond 95 | ((write-storage-underlying-stream s) "STREAM") 96 | ((write-storage-store s) "UB8 VECTOR") 97 | (t "RAW SAP BUFFER")) 98 | (write-storage-offset s) (write-storage-max s) (write-storage-sap s)))) 99 | 100 | (defmethod print-object ((s read-storage) stream) 101 | (print-unreadable-object (s stream :type t :identity t) 102 | (format stream "READ-STORAGE (FROM ~A) OFFSET: ~A MAX: ~A SAP: ~A" 103 | (cond 104 | ((read-storage-underlying-stream s) "STREAM") 105 | ((read-storage-store s) "UB8 VECTOR") 106 | (t "RAW SAP BUFFER")) 107 | (read-storage-offset s) (read-storage-max s) 108 | (read-storage-sap s)))) 109 | 110 | (define-condition too-much-data (invalid-input-data) 111 | ((bytes-read :initarg :bytes :reader too-much-data-bytes) 112 | (max-bytes :initarg :max-bytes :reader too-much-data-max-bytes)) 113 | (:documentation "Tried to read / write more than allowed amount of data. If you choose 114 | any of the continue options, the current operation will continue (which might be a make-array 115 | or make-list call which may exceed what you input)")) 116 | 117 | (defun ask-for-new-amount () 118 | (format t "Enter a new number of allowed bytes: ") 119 | (list (read))) 120 | 121 | (defmacro check-if-too-much-data (max-byte-place total-bytes) 122 | `(let ((max ,max-byte-place)) 123 | (declare (type (or null fixnum) max)) 124 | (when max 125 | (when (> (the fixnum ,total-bytes) (the fixnum max)) 126 | (restart-case 127 | (error 'too-much-data :format-control "TOO-MUCH-DATA: ~A bytes, allowed ~A bytes" 128 | :format-arguments (list max ,total-bytes) 129 | :max-bytes max :bytes ,total-bytes) 130 | (double-allowed-amount () 131 | :report "Double allowed amount" 132 | (setf ,max-byte-place (the fixnum (* 2 (the fixnum ,max-byte-place))))) 133 | (increase-allowed-amount-to (new-amount) 134 | :report "Set allowed amount to version input interactively" 135 | :interactive ask-for-new-amount 136 | (setf ,max-byte-place (the fixnum new-amount)))))))) 137 | 138 | (defmacro with-tracking-data ((total-bytes update-fcn &optional (leader-default "Read ")) 139 | &body body) 140 | "Provides a function (update bytes &optional eof) which should be called when new 141 | bytes are read or written. Used for *load/save-progress-indicator*" 142 | (declare (ignorable leader-default)) 143 | `(let* ((,total-bytes 0) 144 | (start-time (get-internal-real-time)) 145 | (last-time start-time) 146 | (print-time-seconds 0.1f0) 147 | (done nil)) 148 | (declare (type fixnum ,total-bytes start-time last-time) (type single-float print-time-seconds) (type boolean done)) 149 | (labels 150 | ((print-update (now &optional (leader ,leader-default leader-provided-p)) 151 | (when (or leader-provided-p (> now (+ (* internal-time-units-per-second 152 | print-time-seconds) last-time))) 153 | (setf print-time-seconds (* 2f0 print-time-seconds)) 154 | (setf last-time now) 155 | (unless (= last-time start-time) 156 | (format t "~A~,2f MB in ~A seconds (~,2f MB/sec)~%" 157 | leader 158 | (/ ,total-bytes 1f6) (/ (- last-time start-time) internal-time-units-per-second 1f0) 159 | (/ ,total-bytes 1f6 (/ (- last-time start-time) internal-time-units-per-second 1f0)))))) 160 | (,update-fcn (bytes &optional eof) 161 | (incf ,total-bytes bytes) 162 | (when *load/save-progress-indicator* 163 | (let ((now (get-internal-real-time))) 164 | (if eof 165 | (unless done (print-update now "Finished ") (setf done t)) 166 | (print-update now)))))) 167 | ,@body))) 168 | 169 | (defun make-read-into-storage/stream (stream) 170 | (declare (optimize (speed 3) (safety 1))) 171 | (with-tracking-data (total-bytes update "Read ") 172 | (lambda (storage) 173 | (let ((seq (read-storage-store storage))) 174 | (let ((new-bytes-end-at (read-sequence seq stream :start (read-storage-max storage)))) 175 | (update (- new-bytes-end-at (read-storage-max storage)) 176 | (= new-bytes-end-at (read-storage-offset storage))) 177 | (setf (read-storage-total-read storage) total-bytes) 178 | (check-if-too-much-data (read-storage-max-to-read storage) total-bytes) 179 | (setf (read-storage-max storage) new-bytes-end-at) 180 | (truly-the fixnum (- new-bytes-end-at (read-storage-offset storage)))))))) 181 | 182 | (defun make-write-into-storage/stream (stream) 183 | (declare (optimize (speed 3) (safety 1))) 184 | (with-tracking-data (total-bytes update "Wrote ") 185 | (lambda (storage) 186 | (declare (optimize (speed 3) (safety 1))) 187 | (let ((seq (write-storage-store storage)) 188 | (bytes-to-write (write-storage-offset storage))) 189 | (update bytes-to-write (= bytes-to-write 0)) 190 | (write-sequence seq stream :end bytes-to-write) 191 | (check-if-too-much-data *max-to-write* total-bytes) 192 | (setf (write-storage-offset storage) 0))))) 193 | 194 | (defun make-write-into-adjustable-ub8-vector (vector) 195 | (assert (adjustable-array-p vector)) 196 | (with-tracking-data (total-bytes update "Wrote ") 197 | (lambda (storage) 198 | (let* ((num-bytes (write-storage-offset storage)) 199 | (bytes-available (- (array-total-size vector) (fill-pointer vector)))) 200 | (unless (>= bytes-available num-bytes) 201 | (setf vector 202 | (adjust-array vector 203 | (let ((current-size (array-total-size vector))) 204 | (max (* 2 current-size) 205 | (+ current-size (- num-bytes bytes-available))))))) 206 | (let ((start (fill-pointer vector))) 207 | (incf (fill-pointer vector) (write-storage-offset storage)) 208 | (replace vector (write-storage-store storage) 209 | :start1 start 210 | :end1 (+ start num-bytes) 211 | :start2 0 212 | :end2 (write-storage-offset storage)) 213 | (update (write-storage-offset storage) (= num-bytes 0)) 214 | (check-if-too-much-data *max-to-write* total-bytes) 215 | (setf (write-storage-offset storage) 0)))))) 216 | 217 | (defmacro with-storage/read ((storage &key stream (buffer-size 8192) 218 | sap flusher store max size) &body body) 219 | "Used to create a read-storage from user provided stream or sap or stream" 220 | ;; If you pass in store, it must be a static-vector and pinned 221 | (cond 222 | (sap ;; no need to allocate a store 223 | `(let* ((,storage (make-read-storage 224 | :flusher ,flusher 225 | :store ,store 226 | :max ,max 227 | :sap ,sap 228 | :underlying-stream ,stream 229 | :size ,size))) 230 | (declare (dynamic-extent ,storage)) 231 | ,@body)) 232 | (store ;; must be a static-vector and pinned! 233 | (let ((storesym (gensym)) 234 | (sapsym (gensym))) 235 | `(let* ((,storesym ,store)) 236 | (with-pinned-objects (,storesym) 237 | (let* ((,sapsym (static-vectors:static-vector-pointer ,storesym)) 238 | (,storage (make-read-storage 239 | :flusher ,flusher 240 | :store ,storesym 241 | :max ,(or max `(length ,storesym)) 242 | :sap ,sapsym 243 | :underlying-stream ,stream 244 | :size ,(or size `(length ,storesym))))) 245 | (declare (dynamic-extent ,storage)) 246 | ,@body))))) 247 | (t ;; create a static vector buffer 248 | (let ((vector (gensym))) 249 | `(static-vectors:with-static-vector 250 | (,vector ,buffer-size :element-type '(unsigned-byte 8)) 251 | (let ((,storage (make-read-storage 252 | :flusher ,flusher 253 | :store ,vector 254 | :max ,(or max `(length ,vector)) 255 | :sap ,(or sap `(static-vectors:static-vector-pointer ,vector)) 256 | :underlying-stream ,stream 257 | :size ,(or size `(length ,vector))))) 258 | (declare (dynamic-extent ,storage)) 259 | ,@body)))))) 260 | 261 | (defmacro with-storage/write ((storage &key stream (buffer-size 8192) 262 | sap flusher store max 263 | (offset 0)) &body body) 264 | "Used to create a write-storage from user provided sap, store, or stream." 265 | ;; If you pass in store, it better be a static-vector (or otherwise on 266 | ;; sbcl where we can 267 | (cond 268 | (sap ;; no need to allocate a store 269 | `(let* ((,storage (make-write-storage 270 | :flusher ,flusher 271 | :store ,store 272 | :offset ,offset 273 | :max ,max 274 | :sap ,sap 275 | :underlying-stream ,stream))) 276 | (declare (dynamic-extent ,storage)) 277 | (multiple-value-prog1 278 | (progn ,@body) 279 | (flush-write-storage storage) 280 | (when *load/save-progress-indicator* (flush-write-storage storage))))) 281 | (store 282 | (let ((storesym (gensym)) 283 | (sapsym (gensym))) 284 | `(let* ((,storesym ,store)) 285 | (with-pinned-objects (,store) 286 | (let* ((,sapsym (static-vectors:static-vector-pointer ,storesym)) 287 | (,storage (make-write-storage 288 | :flusher ,flusher 289 | :store ,storesym 290 | :offset ,offset 291 | :max ,(or max `(length ,storesym)) 292 | :sap ,sapsym 293 | :underlying-stream ,stream))) 294 | (declare (dynamic-extent ,storage)) 295 | (multiple-value-prog1 296 | (progn 297 | ,@body) 298 | (flush-write-storage storage) 299 | (when *load/save-progress-indicator* (flush-write-storage storage)))))))) 300 | (t 301 | (let ((vector (gensym))) 302 | `(static-vectors:with-static-vector 303 | (,vector ,buffer-size :element-type '(unsigned-byte 8)) 304 | (let ((,storage (make-write-storage 305 | :flusher ,flusher 306 | :store ,vector 307 | :offset ,offset 308 | :max ,(or max `(length ,vector)) 309 | :sap ,(or sap `(static-vectors:static-vector-pointer ,vector)) 310 | :underlying-stream ,stream))) 311 | (declare (dynamic-extent ,storage)) 312 | (multiple-value-prog1 313 | (progn 314 | ,@body) 315 | (flush-write-storage ,storage) 316 | (when *load/save-progress-indicator* (flush-write-storage ,storage))))))))) 317 | 318 | (defun shift-data-to-beginning (read-storage) 319 | "Move the data in seq to the beginning and update storage-offset and storage-max. 320 | Returns the index where new data can be written (read-storage-max storage)" 321 | (let ((store (read-storage-store read-storage)) 322 | (offset (read-storage-offset read-storage)) 323 | (max (read-storage-max read-storage))) 324 | (replace store store :start1 0 :start2 offset :end2 max) ;; move data to beginning of array 325 | (setf (read-storage-offset read-storage) 0) 326 | (setf (read-storage-max read-storage) (- max offset)))) 327 | 328 | (defun maybe-shift-data-to-beginning-of-read-storage (read-storage bytes) 329 | "If all we have is a sap the store is a length 0 vector so this 330 | fails gracefully" 331 | (declare (optimize (speed 3) (safety 1)) (type fixnum bytes)) 332 | (let ((vector-length (read-storage-size read-storage)) 333 | (valid-data-ends-at (read-storage-max read-storage))) 334 | (when (and (> bytes (the fixnum (- vector-length valid-data-ends-at))) ;; we don't have room 335 | (<= bytes vector-length)) 336 | #+debug-cbs(format t "Shifting data to beginning~%") 337 | (shift-data-to-beginning read-storage) 338 | #+debug-cbs(format t "Now storage offset is ~A and storage max is ~A~%" 339 | (read-storage-offset read-storage) 340 | (read-storage-max read-storage))))) 341 | 342 | (define-condition out-of-data (invalid-input-data) 343 | () 344 | (:default-initargs :format-control "Out of data") 345 | (:documentation "Ran out of data while expecting more while reading /deserializing")) 346 | 347 | (defun refill-read-storage (storage bytes return-nil-on-eof) 348 | (declare #+debug-cbs (optimize (debug 3)) #-debug-cbs (optimize (speed 3) (safety 1)) 349 | (type fixnum bytes)) 350 | #+dribble-cbs (format t "Asked to read ~A bytes from storage (return-nil-on-eof ~A)~%" 351 | bytes return-nil-on-eof) 352 | (maybe-shift-data-to-beginning-of-read-storage storage bytes) 353 | (let ((num-bytes-available (the fixnum (funcall (read-storage-flusher storage) storage)))) 354 | (if (< num-bytes-available bytes) 355 | (if return-nil-on-eof 356 | nil 357 | (progn 358 | #+dribble-cbs (format t "Valid data is from ~A to ~A (~A bytes, wanted ~A)~%" 359 | (read-storage-offset storage) (read-storage-max storage) 360 | (- (read-storage-max storage) (read-storage-offset storage)) 361 | bytes) 362 | (error 'out-of-data))) 363 | t))) 364 | 365 | (declaim (#-debug-cbs inline #+debug-cbs notinline ensure-enough-data)) 366 | (defun ensure-enough-data (read-storage bytes &optional (return-nil-on-eof nil)) 367 | "For RESTORE operation. 368 | Ensure that we have at least BYTES of data in STORAGE. May signal `out-of-data' 369 | unless return-nil-on-eof is t. Do not ask for more than (storage-size storage), 370 | which is guaranteed to be >8192 bytes." 371 | (declare #-debug-cbs (optimize (speed 3) (safety 0) (debug 0)) 372 | (type (and fixnum (integer 0)) bytes)) 373 | (or (<= #+sbcl (sb-ext:truly-the fixnum (+ (read-storage-offset read-storage) bytes)) 374 | #-sbcl (the fixnum (+ (read-storage-offset read-storage) bytes)) 375 | (read-storage-max read-storage)) 376 | (refill-read-storage read-storage bytes return-nil-on-eof))) 377 | 378 | (declaim (notinline flush-write-storage)) 379 | (declaim (ftype (function (write-storage &optional fixnum) (values fixnum &optional)) 380 | flush-write-storage)) 381 | 382 | (define-condition out-of-space (error) 383 | ((current-offset :initarg :current-offset :reader out-of-space-current-offset) 384 | (wanted-bytes :initarg :wanted-bytes :reader out-of-space-wanted-bytes)) 385 | (:documentation "Ran out of space while writing data")) 386 | 387 | (defun flush-write-storage (storage &optional (bytes 0)) 388 | "Make sure everything is written out of storage to whatever backing store 389 | there is, and assert there is room to write a further number of BYTES returns 390 | the current (write-storage-offset write-storage) after flushing. Will signal an 391 | error if not enough room available" 392 | (let ((offset (funcall (write-storage-flusher storage) storage))) 393 | (when (> bytes (- (write-storage-max storage) offset)) 394 | ;; In the case where we are writing to a raw sap, we can restart this 395 | ;; gracefully, not so for the case where we need to keep the object 396 | ;; pinned. So we only throw this in the case of zero length storage 397 | ;; which is the signal we are storing to a sap. 398 | (if (= (length (write-storage-store storage)) 0) 399 | (restart-case 400 | (error 'out-of-space :current-offset (write-storage-offset storage)) 401 | (replace-storage (sap sap-size sap-offset) 402 | :report "Replace storage (non interactive only!)" 403 | (setf (write-storage-sap storage) sap) 404 | (setf (write-storage-max storage) sap-size) 405 | (setf (write-storage-offset storage) sap-offset))) 406 | (error 'out-of-space :current-offset (write-storage-offset storage)))) 407 | offset)) 408 | 409 | (declaim (ftype (function (write-storage fixnum) 410 | #+sbcl (values fixnum &optional) 411 | #-sbcl fixnum) 412 | ensure-enough-room-to-write)) 413 | (declaim (inline ensure-enough-room-to-write)) 414 | (defun ensure-enough-room-to-write (write-storage bytes) 415 | "Ensure that we have room to write BYTES to STORAGE. Returns storage offset." 416 | (declare (optimize (speed 3) (safety 0)) (type fixnum bytes)) 417 | (let ((offset (write-storage-offset write-storage))) 418 | (if (< #+sbcl (sb-ext:truly-the fixnum (+ offset bytes)) 419 | #-sbcl (the fixnum (+ offset bytes)) 420 | (write-storage-max write-storage)) 421 | offset 422 | (flush-write-storage write-storage bytes)))) 423 | 424 | --------------------------------------------------------------------------------