Fix serialization of circular structure

extra/db/postgresql/lib/lib.factor

@@ -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

extra/db/sqlite/lib/lib.factor

@@ -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 ]

extra/reports/optimizer/optimizer.factor

@@ -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

extra/serialize/serialize-tests.factor

@@ -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
+    object>bytes
-    binary [ deserialize ] with-byte-reader = ;
+    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
+        dup 2array dup .
-        binary [ serialize ] with-byte-writer
+        object>bytes
-        binary [ deserialize ] with-byte-reader
+        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

extra/serialize/serialize.factor

@@ -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
+io.encodings.string io.encodings.utf8 combinators
-accessors ;
+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 -- )
+: serialize-seq ( obj code -- )
-    write1
+    [
-    dup utf8 encode dup length serialize-cell write
+        write1
-    add-object ;
+        [ add-object ]
-
+        [ length serialize-cell ]
-M: string (serialize) ( obj -- )
+        [ [ (serialize) ] each ] tri
-    [ CHAR: s serialize-string ] serialize-shared ;
+    ] curry serialize-shared ;
-
-: serialize-elements ( seq -- )
-    [ (serialize) ] each CHAR: . write1 ;
 
 M: tuple (serialize) ( obj -- )
     [
         CHAR: T write1
-        dup tuple>array serialize-elements
+        [ class (serialize) ]
-        add-object
+        [ 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
+        CHAR: q write1 [ >array (serialize) ] [ add-object ] bi
-        dup length serialize-cell
-        dup [ double>bits 8 >be write ] each
-        add-object
     ] serialize-shared ;
 
 M: hashtable (serialize) ( obj -- )
     [
         CHAR: h write1
-        dup >alist (serialize)
+        [ add-object ] [ >alist (serialize) ] bi
-        add-object
     ] serialize-shared ;
 
-M: word (serialize) ( obj -- )
+M: bit-array (serialize) ( obj -- )
+    CHAR: b serialize-seq ;
+
+M: byte-array (serialize) ( obj -- )
     [
-        CHAR: w write1
+        CHAR: A write1
-        dup word-name (serialize)
+        [ add-object ]
-        dup word-vocabulary (serialize)
+        [ length serialize-cell ]
-        add-object
+        [ 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
+    (deserialize) (deserialize) 2dup lookup
-    [ dup intern-object ] [ "Unknown word" throw ] ?if ;
+    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) ( exemplar quot -- seq )
-
+    deserialize-cell exemplar new
-: (deserialize-seq) ( -- seq )
+    [ intern-object ]
-    [ (deserialize) dup +stop+ get eq? not ] [ ] [ drop ] unfold ;
+    [ dup [ drop quot call ] change-each ] bi ; inline
-
-: deserialize-seq ( seq -- array )
-    >r (deserialize-seq) r> like dup intern-object ;
 
 : deserialize-array ( -- array )
-    { } deserialize-seq ;
+    { } [ (deserialize) ] (deserialize-seq) ;
 
 : deserialize-quotation ( -- array )
-    [ ] deserialize-seq ;
+    (deserialize) >quotation dup intern-object ;
-
-: (deserialize-byte-array) ( -- byte-array )
-    deserialize-cell read B{ } like ;
 
 : 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
+    ?{ } [ (deserialize) ] (deserialize-seq) ;
-    dup intern-object ;
 
 : deserialize-float-array ( -- float-array )
-    deserialize-cell
+    F{ } [ 8 read be> bits>double ] (deserialize-seq) ;
-    8 * read 8 <groups> [ be> bits>double ] F{ } map-as
-    dup intern-object ;
 
 : 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
+        V{ } clone deserialized
-        gensym +stop+ set
+        [ (deserialize) ] with-variable
-        (deserialize)
+    ] with-compilation-unit ;
-    ] with-scope ;
 
 : serialize ( obj -- )
-    [
+    H{ } clone serialized [ (serialize) ] with-variable ;
-        H{ } clone serialized set
+
-        (serialize)
+: bytes>object ( bytes -- obj )
-    ] with-scope ;
+    binary [ deserialize ] with-byte-reader ;
+
+: object>bytes ( obj -- bytes )
+    binary [ serialize ] with-byte-writer ;