Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Add precise-list-storage. Add custom serializers for T and NIL.

darcs-hash:20090224124041-b71ba-09307a76813cbcc8a1ce0466778c69e994722aa0.gz
  • Loading branch information...
commit 38750495faf5cb0a3cd24f9b116bb28ec19cc8b3 1 parent afcc41f
sross authored
View
9 ChangeLog
@@ -1,3 +1,12 @@
+2009-02-24 Sean Ross <sross@common-lisp.net>
+ 0.8.9
+ * default-backend.lisp, circularities.lisp: Updated the serialization of lists to fix the bug reported by gugamilare@gmail.com.
+ OPTIMIZATION: T and NIL are no longer stored as symbols but have custom serializers (which only writes out the type code)
+ FEATURE: Correct List Serialization. A new symbol *precise-list-storage* is now exported from CL-STORE. When bound to true
+ all lists will be serialized in as correct a manner as possible ensuring that shared list structure is correctly tracked.
+ The unfortunate downside to this is that, due to the recursive nature of the method, storing large lists will blow the stack.
+ This provides a workaround for a bug reported in November 2007 by szergling.
+
2009-01-05 Sean Ross <sross@common-lisp.net>
0.8.6
* default-backend.lisp: Use find-symbol to lookup sb-c::&optional-dispatch. Reported by .Andrea Chiumenti
View
9 circularities.lisp
@@ -102,8 +102,8 @@
(defvar *grouped-store-hash*)
(defvar *grouped-restore-hash*)
-(defun create-serialize-hash ()
- (make-hash-table :test #'eql :size *store-hash-size*))
+(defun create-serialize-hash (&key (size *store-hash-size*))
+ (make-hash-table :test #'eql :size size))
(defmacro with-serialization-unit ((&key store-hash restore-hash)
&body body)
@@ -154,7 +154,7 @@ hash-tables as produced by the function create-serialize-hash."
(deftype not-circ ()
"Type grouping integers and characters, which we
don't bother to check if they have been stored before"
- '(or integer character))
+ '(or integer character (member t nil)))
(defun needs-checkp (obj)
"Do we need to check if this object has been stored before?"
@@ -228,6 +228,7 @@ hash-tables as produced by the function create-serialize-hash."
(handle-normal backend reader place))
(t (new-val (internal-restore-object backend reader place))))))
+
(defmethod backend-restore-object ((backend resolving-backend) (place t))
"Retrieve a object from PLACE, does housekeeping for circularity fixing."
(declare (optimize speed (safety 1) (debug 0)))
@@ -245,7 +246,7 @@ hash-tables as produced by the function create-serialize-hash."
(defgeneric int-or-char-p (backend fn)
(:method ((backend backend) (fn symbol))
"Is function FN registered to restore an integer or character in BACKEND."
- (member fn '(integer character))))
+ (member fn '(integer character))))
(defun new-val (val)
"Tries to get a referred value to reduce unnecessary cirularity fixing."
View
112 default-backend.lisp
@@ -1,14 +1,15 @@
-7;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;; See the file LICENCE for licence information.
;; The cl-store backend.
(in-package :cl-store)
-(defbackend cl-store :magic-number 1395477571
+(defbackend cl-store :magic-number 1279478851
+ :compatible-magic-numbers '(1395477571)
:stream-type '(unsigned-byte 8)
:old-magic-numbers (1912923 1886611788 1347635532 1886611820 1414745155
- 1349740876 1884506444 1347643724 1349732684 1953713219
- 1416850499)
+ 1349740876 1884506444 1347643724 1349732684 1953713219
+ 1416850499 1395477571)
:extends (resolving-backend)
:fields ((restorers :accessor restorers
:initform (make-hash-table :size 100))))
@@ -20,7 +21,6 @@
name))
code)
-
;; Type code constants
(defparameter +referrer-code+ (register-code 1 'referrer))
(defparameter +special-float-code+ (register-code 2 'special-float))
@@ -64,6 +64,10 @@
(defparameter +t-code+ (register-code 40 't-object))
(defparameter +nil-code+ (register-code 41 'nil-object))
+(defparameter +iterative-cons-code+ (register-code 43 'iterative-cons))
+(defparameter +correct-cons-code+ (register-code 44 'correct-cons))
+
+
;; setups for type code mapping
(defun output-type-code (code stream)
(declare (type ub32 code))
@@ -93,6 +97,7 @@
(error "Type code ~A is not registered." type-code))))
+
;; referrer, Required for a resolving backend
(defmethod store-referrer ((backend cl-store) (ref t) (stream t))
(output-type-code +referrer-code+ stream)
@@ -114,7 +119,6 @@
(defrestore-cl-store (nil-object stream)
nil)
-
;; integers
;; The theory is that most numbers will fit in 32 bits
;; so we we have a little optimization for it
@@ -122,9 +126,7 @@
;; We need this for circularity stuff.
(defmethod int-or-char-p ((backend cl-store) (type symbol))
(declare (optimize speed (safety 0) (space 0) (debug 0)))
- (or (eql type '32-bit-integer)
- (eql type 'integer)
- (eql type 'character)))
+ (find type '(32-bit-integer integer character t-object nil-object)))
(defstore-cl-store (obj integer stream)
(declare (optimize speed (safety 1) (debug 0)))
@@ -314,17 +316,78 @@
;; Lists
-(defun dump-list (list length last stream)
- (declare (optimize speed (safety 1) (debug 0))
- (type cons list))
- (output-type-code +cons-code+ stream)
- (store-object length stream)
- (loop repeat length
- for x on list do
- (store-object (car x) stream))
- (store-object last stream))
-
-(defun restore-list (stream)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defvar *cdr-code* 0)
+ (defvar *eol-code* 1)
+ (defun store-list-code (x stream)
+ (write-byte x stream))
+ (defun read-list-code (stream)
+ (read-byte stream)))
+
+(defun correct-list-store (list stream)
+ (output-type-code +correct-cons-code+ stream)
+ (store-object (car list) stream)
+ (store-object (cdr list) stream))
+
+(defrestore-cl-store (correct-cons stream)
+ (resolving-object (x (cons nil nil))
+ (setting (car x) (restore-object stream))
+ (setting (cdr x) (restore-object stream))))
+
+
+(defun iterative-list-store (list stream)
+ (output-type-code +iterative-cons-code+ stream)
+ (loop for (object . remaining) on list :do
+ (store-object object stream)
+ (cond ((atom remaining)
+ (store-list-code *eol-code* stream)
+ (store-object remaining stream)
+ (return))
+ ((and *check-for-circs* (gethash remaining *stored-values*))
+ (store-list-code *eol-code* stream)
+ (store-referrer *current-backend* (get-ref remaining) stream)
+ (return))
+ (t (store-list-code *cdr-code* stream)))))
+
+(defrestore-cl-store (iterative-cons stream)
+ (let* ((result (list (restore-object stream)))
+ (tail result))
+ (when (and *check-for-circs* (referrer-p (car result)))
+ (push (delay
+ (setf (car result) (referred-value (car result) *restored-values*)))
+ *need-to-fix*))
+ (loop for next-elt = (read-list-code stream) :do
+ (ecase next-elt
+ ((#.*eol-code*)
+ (let ((obj (restore-object stream)))
+ (if (and *check-for-circs* (referrer-p obj))
+ (push (delay (setf (cdr tail) (referred-value obj *restored-values*)))
+ *need-to-fix*)
+ (setf (cdr tail) obj))
+ (return result)))
+ ((#.*cdr-code*)
+ (setf (cdr tail) (list (restore-object stream))
+ tail (cdr tail))
+ (when (and *check-for-circs* (referrer-p (car tail)))
+ (let ((tail tail))
+ (push (delay (setf (car tail) (referred-value (car tail) *restored-values*)))
+ *need-to-fix*))))))))
+
+(defvar *precise-list-storage* nil
+ "When bound to true the precise list serializer will be used which will ensure that
+all shared structure in a list will be serialized and deserialized correctly.
+This method of storing lists, while more correct than the default, will NOT work with
+large lists as it will blow the stack.
+Binding this variable to true only affects storing and makes no difference when restoring lists.")
+
+(defstore-cl-store (list cons stream)
+ (if *precise-list-storage*
+ (correct-list-store list stream)
+ (iterative-list-store list stream)))
+
+
+;; backward compatability for old lists
+(defrestore-cl-store (cons stream)
(declare (optimize speed (safety 1) (debug 0)))
(let* ((conses (restore-object stream))
(ret ())
@@ -340,7 +403,7 @@
(referred-value obj *restored-values*)))
*need-to-fix*)))
(if ret
- (setf (cdr tail) (list obj)
+ (setf (cdr tail) (list obj)
tail (cdr tail))
(setf ret (list obj)
tail (last ret)))))
@@ -353,13 +416,6 @@
(setf (cdr tail) last1)))
ret))
-(defstore-cl-store (list cons stream)
- (multiple-value-bind (length last) (safe-length list)
- (dump-list list length last stream)))
-
-(defrestore-cl-store (cons stream)
- (restore-list stream))
-
;; pathnames
(defstore-cl-store (obj pathname stream)
View
2  package.lisp
@@ -25,7 +25,7 @@
#:store-32-bit #:read-32-bit #:*check-for-circs*
#:*store-hash-size* #:*restore-hash-size* #:get-slot-details
#:*store-used-packages* #:*nuke-existing-packages*
- #:serializable-slots-using-class
+ #:serializable-slots-using-class #:*precise-list-storage*
;; Hooks into lower level circularity tracking
;; to reduce consing.
View
11 tests.lisp
@@ -559,9 +559,12 @@ bar")
(store list *test-file*)
(let ((ret (restore *test-file*)))
(and (eq ret (caadr ret))
- (eq ret (third ret)))))
+ (eq ret (third ret))
+ (eq (cadr ret) (cddr ret)))))
t)
+
+
;; large circular lists
#-abcl
(deftest large.1 (let ((list (make-list 100000)))
@@ -578,6 +581,12 @@ bar")
list))
+;; Correct list Storing
+(deftest correct.list.1 (let ((*precise-list-storage* t))
+ (store '(1 2 (a b . #1=(c d e)) 3 4 . #1#) *test-file*)
+ (let ((restore (restore *test-file*)))
+ (eq (cddr (third restore)) (nthcdr 5 restore))))
+ t)
;; custom storing
(defclass random-obj () ((size :accessor size :initarg :size)))
Please sign in to comment.
Something went wrong with that request. Please try again.