diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor index b48c87f0ca..928b51dc59 100755 --- a/extra/db/postgresql/lib/lib.factor +++ b/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 diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index d630522eb8..2e9248c429 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/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 ] diff --git a/extra/reports/optimizer/optimizer.factor b/extra/reports/optimizer/optimizer.factor new file mode 100755 index 0000000000..294ec8c979 --- /dev/null +++ b/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 diff --git a/extra/serialize/serialize-tests.factor b/extra/serialize/serialize-tests.factor index 1831495924..c5734b2ae8 100755 --- a/extra/serialize/serialize-tests.factor +++ b/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 } ; : 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 [ 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 diff --git a/extra/serialize/serialize.factor b/extra/serialize/serialize.factor index f573499695..65464d4e32 100755 --- a/extra/serialize/serialize.factor +++ b/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 -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) ; -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 [ 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 ; \ No newline at end of file + H{ } clone serialized [ (serialize) ] with-variable ; + +: bytes>object ( bytes -- obj ) + binary [ deserialize ] with-byte-reader ; + +: object>bytes ( obj -- bytes ) + binary [ serialize ] with-byte-writer ; \ No newline at end of file