Fix serialization of circular structure
parent
4e0c0dab49
commit
ea2723a5a0
|
@ -73,7 +73,7 @@ IN: db.postgresql.lib
|
|||
sql-spec-type {
|
||||
{ FACTOR-BLOB [
|
||||
dup [
|
||||
binary [ serialize ] with-byte-writer
|
||||
object>bytes
|
||||
malloc-byte-array/length ] [ 0 ] if ] }
|
||||
{ BLOB [
|
||||
dup [ malloc-byte-array/length ] [ 0 ] if ] }
|
||||
|
@ -164,7 +164,7 @@ M: postgresql-malloc-destructor dispose ( obj -- )
|
|||
{ BLOB [ pq-get-blob ] }
|
||||
{ FACTOR-BLOB [
|
||||
pq-get-blob
|
||||
dup [ binary [ deserialize ] with-byte-reader ] when ] }
|
||||
dup [ bytes>object ] when ] }
|
||||
[ no-sql-type ]
|
||||
} case ;
|
||||
! PQgetlength PQgetisnull
|
||||
|
|
|
@ -94,7 +94,7 @@ IN: db.sqlite.lib
|
|||
{ TIMESTAMP [ sqlite-bind-text-by-name ] }
|
||||
{ BLOB [ sqlite-bind-blob-by-name ] }
|
||||
{ FACTOR-BLOB [
|
||||
binary [ serialize ] with-byte-writer
|
||||
object>bytes
|
||||
sqlite-bind-blob-by-name
|
||||
] }
|
||||
{ +native-id+ [ sqlite-bind-int-by-name ] }
|
||||
|
@ -131,7 +131,7 @@ IN: db.sqlite.lib
|
|||
{ BLOB [ sqlite-column-blob ] }
|
||||
{ FACTOR-BLOB [
|
||||
sqlite-column-blob
|
||||
dup [ binary [ deserialize ] with-byte-reader ] when
|
||||
dup [ bytes>object ] when
|
||||
] }
|
||||
! { NULL [ 2drop f ] }
|
||||
[ no-sql-type ]
|
||||
|
|
|
@ -0,0 +1,28 @@
|
|||
USING: assocs words sequences arrays compiler tools.time
|
||||
io.styles io prettyprint vocabs kernel sorting generator
|
||||
optimizer math ;
|
||||
IN: report.optimizer
|
||||
|
||||
: count-optimization-passes ( nodes n -- n )
|
||||
>r optimize-1
|
||||
[ r> 1+ count-optimization-passes ] [ drop r> ] if ;
|
||||
|
||||
: results
|
||||
[ [ second ] swap compose compare ] curry sort 20 tail*
|
||||
print
|
||||
standard-table-style
|
||||
[
|
||||
[ [ [ pprint-cell ] each ] with-row ] each
|
||||
] tabular-output ;
|
||||
|
||||
: optimizer-report
|
||||
all-words [ compiled? ] subset
|
||||
[
|
||||
dup [
|
||||
word-dataflow nip 1 count-optimization-passes
|
||||
] benchmark nip 2array
|
||||
] { } map>assoc
|
||||
[ first ] "Worst number of optimizer passes:" results
|
||||
[ second ] "Worst compile times:" results ;
|
||||
|
||||
MAIN: optimizer-report
|
|
@ -4,7 +4,7 @@
|
|||
USING: tools.test kernel serialize io io.streams.byte-array math
|
||||
alien arrays byte-arrays sequences math prettyprint parser
|
||||
classes math.constants io.encodings.binary random
|
||||
combinators.lib ;
|
||||
combinators.lib assocs ;
|
||||
IN: serialize.tests
|
||||
|
||||
: test-serialize-cell
|
||||
|
@ -56,19 +56,23 @@ C: <serialize-test> serialize-test
|
|||
} ;
|
||||
|
||||
: check-serialize-1 ( obj -- ? )
|
||||
"=====" print
|
||||
dup class .
|
||||
dup .
|
||||
dup
|
||||
binary [ serialize ] with-byte-writer
|
||||
binary [ deserialize ] with-byte-reader = ;
|
||||
object>bytes
|
||||
bytes>object
|
||||
dup . = ;
|
||||
|
||||
: check-serialize-2 ( obj -- ? )
|
||||
dup number? over wrapper? or [
|
||||
drop t ! we don't care if numbers aren't interned
|
||||
] [
|
||||
"=====" print
|
||||
dup class .
|
||||
dup 2array
|
||||
binary [ serialize ] with-byte-writer
|
||||
binary [ deserialize ] with-byte-reader
|
||||
dup 2array dup .
|
||||
object>bytes
|
||||
bytes>object dup .
|
||||
first2 eq?
|
||||
] if ;
|
||||
|
||||
|
@ -79,3 +83,17 @@ C: <serialize-test> serialize-test
|
|||
[ t ] [ pi check-serialize-1 ] unit-test
|
||||
[ serialize ] must-infer
|
||||
[ deserialize ] must-infer
|
||||
|
||||
[ t ] [
|
||||
V{ } dup dup push
|
||||
object>bytes
|
||||
bytes>object
|
||||
dup first eq?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
H{ } dup dup dup set-at
|
||||
object>bytes
|
||||
bytes>object
|
||||
dup keys first eq?
|
||||
] unit-test
|
||||
|
|
|
@ -11,8 +11,9 @@ USING: namespaces sequences kernel math io math.functions
|
|||
io.binary strings classes words sbufs tuples arrays
|
||||
vectors byte-arrays bit-arrays quotations hashtables
|
||||
assocs help.syntax help.markup float-arrays splitting
|
||||
io.encodings.string io.encodings.utf8 combinators new-slots
|
||||
accessors ;
|
||||
io.encodings.string io.encodings.utf8 combinators
|
||||
combinators.cleave new-slots accessors locals prettyprint
|
||||
compiler.units sequences.private tuples.private ;
|
||||
|
||||
! Variable holding a assoc of objects already serialized
|
||||
SYMBOL: serialized
|
||||
|
@ -69,7 +70,8 @@ GENERIC: (serialize) ( obj -- )
|
|||
|
||||
: serialize-shared ( obj quot -- )
|
||||
>r dup object-id
|
||||
[ CHAR: o write1 serialize-cell drop ] r> if* ; inline
|
||||
[ CHAR: o write1 serialize-cell drop ]
|
||||
r> if* ; inline
|
||||
|
||||
M: f (serialize) ( obj -- )
|
||||
drop CHAR: n write1 ;
|
||||
|
@ -96,75 +98,93 @@ M: ratio (serialize) ( obj -- )
|
|||
dup numerator (serialize)
|
||||
denominator (serialize) ;
|
||||
|
||||
: serialize-string ( obj code -- )
|
||||
write1
|
||||
dup utf8 encode dup length serialize-cell write
|
||||
add-object ;
|
||||
|
||||
M: string (serialize) ( obj -- )
|
||||
[ CHAR: s serialize-string ] serialize-shared ;
|
||||
|
||||
: serialize-elements ( seq -- )
|
||||
[ (serialize) ] each CHAR: . write1 ;
|
||||
: serialize-seq ( obj code -- )
|
||||
[
|
||||
write1
|
||||
[ add-object ]
|
||||
[ length serialize-cell ]
|
||||
[ [ (serialize) ] each ] tri
|
||||
] curry serialize-shared ;
|
||||
|
||||
M: tuple (serialize) ( obj -- )
|
||||
[
|
||||
CHAR: T write1
|
||||
dup tuple>array serialize-elements
|
||||
add-object
|
||||
[ class (serialize) ]
|
||||
[ add-object ]
|
||||
[ tuple>array 1 tail (serialize) ]
|
||||
tri
|
||||
] serialize-shared ;
|
||||
|
||||
: serialize-seq ( seq code -- )
|
||||
[
|
||||
write1
|
||||
dup serialize-elements
|
||||
add-object
|
||||
] curry serialize-shared ;
|
||||
|
||||
M: array (serialize) ( obj -- )
|
||||
CHAR: a serialize-seq ;
|
||||
|
||||
M: byte-array (serialize) ( obj -- )
|
||||
[
|
||||
CHAR: A write1
|
||||
dup dup length serialize-cell write
|
||||
add-object
|
||||
] serialize-shared ;
|
||||
|
||||
M: bit-array (serialize) ( obj -- )
|
||||
[
|
||||
CHAR: b write1
|
||||
dup length serialize-cell
|
||||
dup [ 1 0 ? ] B{ } map-as write
|
||||
add-object
|
||||
] serialize-shared ;
|
||||
|
||||
M: quotation (serialize) ( obj -- )
|
||||
CHAR: q serialize-seq ;
|
||||
|
||||
M: float-array (serialize) ( obj -- )
|
||||
[
|
||||
CHAR: f write1
|
||||
dup length serialize-cell
|
||||
dup [ double>bits 8 >be write ] each
|
||||
add-object
|
||||
CHAR: q write1 [ >array (serialize) ] [ add-object ] bi
|
||||
] serialize-shared ;
|
||||
|
||||
M: hashtable (serialize) ( obj -- )
|
||||
[
|
||||
CHAR: h write1
|
||||
dup >alist (serialize)
|
||||
add-object
|
||||
[ add-object ] [ >alist (serialize) ] bi
|
||||
] serialize-shared ;
|
||||
|
||||
M: word (serialize) ( obj -- )
|
||||
M: bit-array (serialize) ( obj -- )
|
||||
CHAR: b serialize-seq ;
|
||||
|
||||
M: byte-array (serialize) ( obj -- )
|
||||
[
|
||||
CHAR: w write1
|
||||
dup word-name (serialize)
|
||||
dup word-vocabulary (serialize)
|
||||
add-object
|
||||
CHAR: A write1
|
||||
[ add-object ]
|
||||
[ length serialize-cell ]
|
||||
[ write ] tri
|
||||
] serialize-shared ;
|
||||
|
||||
M: float-array (serialize) ( obj -- )
|
||||
[
|
||||
CHAR: f write1
|
||||
[ add-object ]
|
||||
[ length serialize-cell ]
|
||||
[ [ double>bits 8 >be write ] each ]
|
||||
tri
|
||||
] serialize-shared ;
|
||||
|
||||
M: string (serialize) ( obj -- )
|
||||
[
|
||||
CHAR: s write1
|
||||
[ add-object ]
|
||||
[
|
||||
utf8 encode
|
||||
[ length serialize-cell ]
|
||||
[ write ] bi
|
||||
] bi
|
||||
] serialize-shared ;
|
||||
|
||||
: serialize-true ( word -- )
|
||||
drop CHAR: t write1 ;
|
||||
|
||||
: serialize-gensym ( word -- )
|
||||
[
|
||||
CHAR: G write1
|
||||
[ add-object ]
|
||||
[ word-def (serialize) ]
|
||||
[ word-props (serialize) ]
|
||||
tri
|
||||
] serialize-shared ;
|
||||
|
||||
: serialize-word ( word -- )
|
||||
CHAR: w write1
|
||||
[ word-name (serialize) ]
|
||||
[ word-vocabulary (serialize) ]
|
||||
bi ;
|
||||
|
||||
M: word (serialize) ( obj -- )
|
||||
{
|
||||
{ [ dup t eq? ] [ serialize-true ] }
|
||||
{ [ dup word-vocabulary not ] [ serialize-gensym ] }
|
||||
{ [ t ] [ serialize-word ] }
|
||||
} cond ;
|
||||
|
||||
M: wrapper (serialize) ( obj -- )
|
||||
CHAR: W write1
|
||||
wrapped (serialize) ;
|
||||
|
@ -179,6 +199,9 @@ SYMBOL: deserialized
|
|||
: deserialize-false ( -- f )
|
||||
f ;
|
||||
|
||||
: deserialize-true ( -- f )
|
||||
t ;
|
||||
|
||||
: deserialize-positive-integer ( -- number )
|
||||
deserialize-cell ;
|
||||
|
||||
|
@ -204,53 +227,63 @@ SYMBOL: deserialized
|
|||
(deserialize-string) dup intern-object ;
|
||||
|
||||
: deserialize-word ( -- word )
|
||||
(deserialize) dup (deserialize) lookup
|
||||
[ dup intern-object ] [ "Unknown word" throw ] ?if ;
|
||||
(deserialize) (deserialize) 2dup lookup
|
||||
dup [ 2nip ] [
|
||||
"Unknown word: " -rot
|
||||
2array unparse append throw
|
||||
] if ;
|
||||
|
||||
: deserialize-gensym ( -- word )
|
||||
gensym
|
||||
dup intern-object
|
||||
dup (deserialize) define
|
||||
dup (deserialize) swap set-word-props ;
|
||||
|
||||
: deserialize-wrapper ( -- wrapper )
|
||||
(deserialize) <wrapper> ;
|
||||
|
||||
SYMBOL: +stop+
|
||||
|
||||
: (deserialize-seq) ( -- seq )
|
||||
[ (deserialize) dup +stop+ get eq? not ] [ ] [ drop ] unfold ;
|
||||
|
||||
: deserialize-seq ( seq -- array )
|
||||
>r (deserialize-seq) r> like dup intern-object ;
|
||||
:: (deserialize-seq) ( exemplar quot -- seq )
|
||||
deserialize-cell exemplar new
|
||||
[ intern-object ]
|
||||
[ dup [ drop quot call ] change-each ] bi ; inline
|
||||
|
||||
: deserialize-array ( -- array )
|
||||
{ } deserialize-seq ;
|
||||
{ } [ (deserialize) ] (deserialize-seq) ;
|
||||
|
||||
: deserialize-quotation ( -- array )
|
||||
[ ] deserialize-seq ;
|
||||
|
||||
: (deserialize-byte-array) ( -- byte-array )
|
||||
deserialize-cell read B{ } like ;
|
||||
(deserialize) >quotation dup intern-object ;
|
||||
|
||||
: deserialize-byte-array ( -- byte-array )
|
||||
(deserialize-byte-array) dup intern-object ;
|
||||
B{ } [ read1 ] (deserialize-seq) ;
|
||||
|
||||
: deserialize-bit-array ( -- bit-array )
|
||||
(deserialize-byte-array) [ 0 > ] ?{ } map-as
|
||||
dup intern-object ;
|
||||
?{ } [ (deserialize) ] (deserialize-seq) ;
|
||||
|
||||
: deserialize-float-array ( -- float-array )
|
||||
deserialize-cell
|
||||
8 * read 8 <groups> [ be> bits>double ] F{ } map-as
|
||||
dup intern-object ;
|
||||
F{ } [ 8 read be> bits>double ] (deserialize-seq) ;
|
||||
|
||||
: deserialize-hashtable ( -- hashtable )
|
||||
(deserialize) >hashtable dup intern-object ;
|
||||
H{ } clone
|
||||
[ intern-object ]
|
||||
[ (deserialize) update ]
|
||||
[ ] tri ;
|
||||
|
||||
: copy-seq-to-tuple ( seq tuple -- )
|
||||
>r dup length [ 1+ ] map r> [ set-array-nth ] curry 2each ;
|
||||
|
||||
: deserialize-tuple ( -- array )
|
||||
(deserialize-seq) >tuple dup intern-object ;
|
||||
#! Ugly because we have to intern the tuple before reading
|
||||
#! slots
|
||||
(deserialize) construct-empty
|
||||
[ intern-object ]
|
||||
[
|
||||
[ (deserialize) ]
|
||||
[ [ copy-seq-to-tuple ] keep ] bi*
|
||||
] bi ;
|
||||
|
||||
: deserialize-unknown ( -- object )
|
||||
deserialize-cell deserialized get nth ;
|
||||
|
||||
: deserialize-stop ( -- object )
|
||||
+stop+ get ;
|
||||
|
||||
: deserialize* ( -- object ? )
|
||||
read1 [
|
||||
{
|
||||
|
@ -265,14 +298,15 @@ SYMBOL: +stop+
|
|||
{ CHAR: h [ deserialize-hashtable ] }
|
||||
{ CHAR: m [ deserialize-negative-integer ] }
|
||||
{ CHAR: n [ deserialize-false ] }
|
||||
{ CHAR: t [ deserialize-true ] }
|
||||
{ CHAR: o [ deserialize-unknown ] }
|
||||
{ CHAR: p [ deserialize-positive-integer ] }
|
||||
{ CHAR: q [ deserialize-quotation ] }
|
||||
{ CHAR: r [ deserialize-ratio ] }
|
||||
{ CHAR: s [ deserialize-string ] }
|
||||
{ CHAR: w [ deserialize-word ] }
|
||||
{ CHAR: G [ deserialize-word ] }
|
||||
{ CHAR: z [ deserialize-zero ] }
|
||||
{ CHAR: . [ deserialize-stop ] }
|
||||
} case t
|
||||
] [
|
||||
f f
|
||||
|
@ -283,13 +317,15 @@ SYMBOL: +stop+
|
|||
|
||||
: deserialize ( -- obj )
|
||||
[
|
||||
V{ } clone deserialized set
|
||||
gensym +stop+ set
|
||||
(deserialize)
|
||||
] with-scope ;
|
||||
V{ } clone deserialized
|
||||
[ (deserialize) ] with-variable
|
||||
] with-compilation-unit ;
|
||||
|
||||
: serialize ( obj -- )
|
||||
[
|
||||
H{ } clone serialized set
|
||||
(serialize)
|
||||
] with-scope ;
|
||||
H{ } clone serialized [ (serialize) ] with-variable ;
|
||||
|
||||
: bytes>object ( bytes -- obj )
|
||||
binary [ deserialize ] with-byte-reader ;
|
||||
|
||||
: object>bytes ( obj -- bytes )
|
||||
binary [ serialize ] with-byte-writer ;
|
Loading…
Reference in New Issue