Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
Vladimir Sedach
storage
Commits
ca92680d
Commit
ca92680d
authored
Dec 23, 2011
by
Stas Boukarev
Browse files
Don't write relations at read-time, store them on disk.
Add a specialized type `list-of-objects'.
parent
c38add28
Changes
3
Hide whitespace changes
Inline
Side-by-side
benchmarks.lisp
View file @
ca92680d
...
@@ -14,7 +14,9 @@
...
@@ -14,7 +14,9 @@
do
(
write-object
object
stream
)))))
do
(
write-object
object
stream
)))))
(
defun
gc
()
(
defun
gc
()
#+
sbcl
(
sb-ext:gc
:full
t
))
#+
sbcl
(
sb-ext:gc
:full
t
)
#+
ccl
(
progn
(
ccl:set-lisp-heap-gc-threshold
(
*
1024
1024
64
))
(
ccl:gc
)))
(
defmacro
time-with-gc
(
&body
body
)
(
defmacro
time-with-gc
(
&body
body
)
`
(
progn
(
gc
)
`
(
progn
(
gc
)
...
...
disk.lisp
View file @
ca92680d
...
@@ -9,7 +9,8 @@
...
@@ -9,7 +9,8 @@
string
null
symbol
string
null
symbol
storable-class
storable-class
standard-object
standard-object
fixnum
bignum
ratio
)))
fixnum
bignum
ratio
list-of-objects
)))
(
declaim
(
type
simple-vector
*codes*
))
(
declaim
(
type
simple-vector
*codes*
))
...
@@ -303,22 +304,47 @@
...
@@ -303,22 +304,47 @@
(
defmethod
object-size
((
list
cons
))
(
defmethod
object-size
((
list
cons
))
(
let
((
count
(
+
1
1
)))
;; type + +end+
(
let
((
count
(
+
1
1
)))
;; type + +end+
(
mapc
(
lambda
(
x
)
(
cond
((
list-of-objects-p
list
)
(
incf
count
(
object-size
x
)))
(
incf
count
(
+
(
*
(
length
list
)
list
)
+id-length+
)
(
1-
+sequence-length+
))))
;; sans +end+
(
t
(
mapc
(
lambda
(
x
)
(
incf
count
(
object-size
x
)))
list
)))
count
))
count
))
(
defmethod
write-object
((
list
cons
)
stream
)
(
defmethod
write-object
((
list
cons
)
stream
)
(
write-n-bytes
#.
(
type-code
'cons
)
1
stream
)
(
cond
((
list-of-objects-p
list
)
(
dolist
(
item
list
)
(
write-list-of-objects
list
stream
))
(
write-object
item
stream
))
(
t
(
write-n-bytes
+end+
1
stream
))
(
write-n-bytes
#.
(
type-code
'cons
)
1
stream
)
(
dolist
(
item
list
)
(
write-object
item
stream
))
(
write-n-bytes
+end+
1
stream
))))
(
defreader
cons
(
stream
)
(
defreader
cons
(
stream
)
(
loop
for
code
=
(
read-n-bytes
1
stream
)
(
loop
for
code
=
(
read-n-bytes
1
stream
)
until
(
=
code
+end+
)
until
(
=
code
+end+
)
collect
(
call-reader
code
stream
)))
collect
(
call-reader
code
stream
)))
;;; list-of-objects
(
defun
list-of-objects-p
(
list
)
(
loop
for
i
in
list
always
(
typep
i
'standard-object
)))
(
defun
write-list-of-objects
(
list
stream
)
(
write-n-bytes
#.
(
type-code
'list-of-objects
)
1
stream
)
(
write-n-bytes
(
length
list
)
+sequence-length+
stream
)
(
dolist
(
object
list
)
(
write-n-bytes
(
id
object
)
+id-length+
stream
)))
(
defreader
list-of-objects
(
stream
)
(
loop
repeat
(
read-n-bytes
+sequence-length+
stream
)
for
id
=
(
read-n-bytes
+id-length+
stream
)
collect
(
get-instance
id
)))
;;; storable-class
;;; storable-class
(
defmethod
object-size
((
class
storable-class
))
(
defmethod
object-size
((
class
storable-class
))
...
@@ -500,8 +526,7 @@
...
@@ -500,8 +526,7 @@
(
let
((
*storage*
storage
)
(
let
((
*storage*
storage
)
(
*indexes*
*indexes*
))
(
*indexes*
*indexes*
))
(
clear-cashes
)
(
clear-cashes
)
(
read-file
(
or
file
(
storage-file
*storage*
)))
(
read-file
(
or
file
(
storage-file
*storage*
)))))
(
interlink-all-objects-first-time
)))
(
defun
save-data
(
storage
&optional
file
)
(
defun
save-data
(
storage
&optional
file
)
(
let
((
*storage*
storage
))
(
let
((
*storage*
storage
))
...
...
storage.lisp
View file @
ca92680d
...
@@ -101,34 +101,6 @@
...
@@ -101,34 +101,6 @@
(
interlink-slots
object
(
interlink-slots
object
(
standard-instance-access
object
loc
)
(
standard-instance-access
object
loc
)
relation
)))
relation
)))
;;;
(
defun
interlink-all-objects-first-time
()
(
map-data
(
lambda
(
class
objects
)
(
declare
(
ignore
class
))
(
loop
for
object
in
objects
do
(
interlink-objects-first-time
object
)))))
(
defun
link-slot-first-time
(
relation
object
target-object
)
(
if
(
and
(
consp
relation
)
(
eql
(
car
relation
)
:slot
))
(
push
object
(
slot-value
target-object
(
cadr
relation
)))
(
push
object
(
getf
(
relations
target-object
)
relation
))))
(
defun
interlink-slots-first-time
(
object
slot-value
relation
)
(
do-maybe-list
(
target
slot-value
)
(
when
(
typep
target
'identifiable
)
(
link-slot-first-time
relation
object
target
))))
(
defun
interlink-objects-first-time
(
object
)
(
loop
for
(
loc
.
relation
)
in
(
class-relations
(
class-of
object
))
do
(
interlink-slots-first-time
object
(
standard-instance-access
object
loc
)
relation
)))
;;;
;;;
(
defun
clear-cashes
()
(
defun
clear-cashes
()
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment