made some performance improvements by using a shared byte-vector buffer for serialization

bson/writer/writer-docs.factor

@@ -3,7 +3,7 @@
 USING: assocs help.markup help.syntax kernel ;
 IN: bson.writer
 
-HELP: assoc>array
+HELP: assoc>bv
 { $values
      { "assoc" assoc }
      { "byte-array" null }

bson/writer/writer.factor

@@ -1,17 +1,51 @@
 ! Copyright (C) 2008 Sascha Matzke.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs bson.constants byte-arrays fry io io.binary
+USING: accessors assocs bson.constants 
+byte-arrays byte-vectors calendar fry io io.binary io.encodings
 io.encodings.binary io.encodings.string io.encodings.utf8
-io.streams.byte-array kernel math math.parser quotations sequences
+io.streams.byte-array kernel math math.parser namespaces
-serialize strings words calendar ;
+quotations sequences serialize strings words ;
+
 
 IN: bson.writer
 
-#! Writes the object out to a stream in BSON format
+#! Writes the object out to a byte-vector in BSON format
 
 <PRIVATE
 
-GENERIC: bson-type? ( obj -- type )
+SYMBOL: shared-buffer 
+
+CONSTANT: INT32-SIZE 4
+
+: (buffer) ( -- buffer )
+    shared-buffer get
+    [ 4096 <byte-vector> [ shared-buffer set ] keep ] unless* ; inline
+
+PRIVATE>
+
+: ensure-buffer ( -- )
+    (buffer) drop ;
+
+: reset-buffer ( -- )
+    (buffer) 0 >>length drop ;
+
+: with-buffer ( quot -- byte-vector )
+    [ (buffer) ] dip [ output-stream get ] compose
+    with-output-stream* dup encoder? [ stream>> ] when ; inline
+
+: with-length ( quot: ( -- ) -- bytes-written start-index )
+    [ (buffer) [ length ] keep ] dip call
+    length swap [ - ] keep ; inline
+
+: with-length-prefix ( quot: ( -- ) -- )
+    [ B{ 0 0 0 0 } write ] prepose with-length
+    [ INT32-SIZE >le ] dip (buffer)
+    '[ _ over [ nth ] dip _ + _ set-nth ]
+    [ INT32-SIZE ] dip each-integer ; inline
+
+<PRIVATE
+
+GENERIC: bson-type? ( obj -- type ) foldable flushable
 GENERIC: bson-write ( obj -- )
 
 M: t bson-type? ( boolean -- type ) drop T_Boolean ; 
@@ -42,7 +76,6 @@ M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ;
 : write-type ( obj -- obj ) [ bson-type? write-byte ] keep ; inline
 : write-pair ( name object -- ) write-type [ write-cstring ] dip bson-write ; inline
 
-
 M: f bson-write ( f -- )
     drop 0 write-byte ; 
 
@@ -91,12 +124,10 @@ M: objref bson-write ( objref -- )
     write ;
     
 M: sequence bson-write ( array -- )
-    '[ _ [ [ write-type ] dip number>string write-cstring bson-write ]
+    '[ _ [ [ write-type ] dip number>string
-        each-index ]
+           write-cstring bson-write ] each-index
-        binary swap with-byte-writer
+       write-eoo
-        [ length 5 + bson-write ] keep
+    ] with-length-prefix ;
-        write
-        write-eoo ; 
 
 : write-oid ( assoc -- )
     [ MDB_OID_FIELD ] dip at*
@@ -106,20 +137,16 @@ M: sequence bson-write ( array -- )
     { "_id" "_mdb" } member? ; inline
 
 M: assoc bson-write ( assoc -- )
-    [ binary ] dip
     '[ _  [ write-oid ] keep
        [ over skip-field? [ 2drop ] [ write-pair ] if ] assoc-each
-    ] with-byte-writer
+       write-eoo ] with-length-prefix ; 
-    [ length 5 + bson-write ] keep
-    write
-    write-eoo ; 
 
 M: word bson-write name>> bson-write ;
 
 PRIVATE>
 
-: assoc>array ( assoc -- byte-array )
+: assoc>bv ( assoc -- byte-vector )
-    '[ _ bson-write ] binary swap with-byte-writer ; inline
+    [ '[ _ bson-write ] with-buffer ] with-scope ; inline
 
 : assoc>stream ( assoc -- )
     bson-write ; inline

mongodb/benchmark/benchmark.factor

@@ -1,15 +1,21 @@
-USING: mongodb.driver calendar math fry kernel assocs math.ranges
+USING: calendar math fry kernel assocs math.ranges
 sequences formatting combinators namespaces io tools.time prettyprint
-accessors words ;
+accessors words mongodb.driver ;
 
 IN: mongodb.benchmark
 
-SYMBOLS: per-trial batch-size collection host db port ;
+SYMBOLS: per-trial collection host db port ;
 
 : get* ( symbol default -- value )
     [ get ] dip or ; inline
 
-TUPLE: result doc index batch lasterror ;
+: trial-size ( -- size )
+    per-trial 10000 get* ; inline flushable
+
+: batch-size ( -- size )
+    \ batch-size 100 get* ; inline flushable
+
+TUPLE: result doc collection index batch lasterror ;
 
 : <result> ( -- ) result new result set ; inline
 
@@ -91,25 +97,34 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" }
                                              "platform-as-a-service" "technology" "helps" 
                                              "developers" "focus" "building" "mongodb" "mongo" } } }
 
-: small-doc ( -- quot: ( i -- doc ) )
+: set-doc ( name -- )
-    result [ "small" >>doc ] change
+    [ result ] dip '[ _ >>doc ] change ; inline
-    DOC-SMALL clone 
-    '[ "x" _ [ set-at ] keep ] ; inline
 
-: medium-doc ( -- quot: ( i -- doc ) )
+: small-doc ( -- )
-    result [ "medium" >>doc ] change
+    "small" set-doc ; inline
-    DOC-MEDIUM clone
-    '[ "x" _ [ set-at ] keep ] ; inline
 
-: large-doc ( -- quot: ( i -- doc ) )
+: medium-doc ( -- )
-    result [ "large" >>doc ] change
+    "medium" set-doc ; inline
-    DOC-LARGE clone 
+
-    '[ "x" _ [ set-at ] keep 
+: large-doc ( -- )
+    "large" set-doc ; inline
+
+: small-doc-prepare ( -- quot: ( i -- doc ) )
+    small-doc
+    '[ "x" DOC-SMALL clone [ set-at ] keep ] ; inline
+
+: medium-doc-prepare ( -- quot: ( i -- doc ) )
+    medium-doc
+    '[ "x" DOC-MEDIUM clone [ set-at ] keep ] ; inline
+
+: large-doc-prepare ( -- quot: ( i -- doc ) )
+    large-doc
+    [ "x" DOC-LARGE clone [ set-at ] keep 
        [ now "access-time" ] dip
        [ set-at ] keep ] ;
 
 : (insert) ( quot: ( i -- doc ) collection -- )
-    [ per-trial get ] 2dip
+    [ trial-size ] 2dip
     '[ _ call [ _ ] dip
        result get lasterror>> [ save ] [ save-unsafe ] if ] each-integer ; inline
 
@@ -118,13 +133,23 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" }
     '[ _ call ] map ; inline
 
 : (insert-batch) ( quot: ( i -- doc ) collection -- )
-    [ per-trial get batch-size get [ / ] keep ] 2dip
+    [ trial-size batch-size [ / ] keep ] 2dip
     '[ _ _ (prepare-batch) [ _ ] dip
        result get lasterror>> [ save ] [ save-unsafe ] if
     ] each-integer ; inline
 
-: prepare-collection ( -- collection )
+: bchar ( boolean -- char )
+    [ "t" ] [ "f" ] if ; inline
+
+: collection-name ( -- collection )
     collection "benchmark" get*
+    result get doc>>
+    result get index>> bchar
+    "%s-%s-%s" sprintf
+    [ [ result get ] dip >>collection drop ] keep ; inline
+    
+: prepare-collection ( -- collection )
+    collection-name
     [ "_x_idx" drop-index ] keep
     [ drop-collection ] keep
     [ create-collection ] keep ; inline
@@ -138,6 +163,26 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" }
     result get batch>>
     [ '[ _ _ (insert-batch) ] ] [ '[ _ _ (insert) ] ] if ;
 
+: check-for-key ( assoc key -- )
+    swap key? [ "ups... where's the key" throw ] unless ; inline
+
+: find-one ( -- quot: ( -- ) )
+    collection-name
+    trial-size 2 / "x" H{ } clone [ set-at ] keep
+    '[ _ _ <query> 1 limit find [ drop ] dip first "x" check-for-key  ] ;
+
+: find-all ( -- quot: ( -- ) )
+    collection-name
+    H{ } clone
+    '[ _ _ <query> find [ "x" check-for-key  ] each drop ] ;
+
+: find-range ( -- quot: ( -- ) )
+    collection-name
+    trial-size 2 / "$gt" H{ } clone [ set-at ] keep
+    [ trial-size 2 / batch-size + "$lt" ] dip [ set-at ] keep
+    "x" H{ } clone [ set-at ] keep
+    '[ _ _ <query> find [ "x" check-for-key ] each drop ] ;
+
 : batch ( -- )
     result [ t >>batch ] change ; inline
    
@@ -147,46 +192,80 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" }
 : errcheck ( -- )
     result [ t >>lasterror ] change ; inline
 
-: bchar ( boolean -- char )
-    [ "t" ] [ "f" ] if ; inline
-
 : print-result ( time -- )
-    [ result get [ doc>> ] keep
+    [ result get [ collection>> ] keep
       [ batch>> bchar ] keep
       [ index>> bchar ] keep
       lasterror>> bchar
-      per-trial get ] dip
+      trial-size ] dip
     1000000 / /i
-    "%-6s: {batch:%s,index:%s;errchk:%s} %7s op/s"
+    "%-18s: {batch:%s,index:%s;errchk:%s} %10s op/s"
     sprintf print flush ; inline
 
 : print-separator ( -- )
-    "-----------------------------------------------" print flush ; inline
+    "--------------------------------------------------------------" print flush ; inline
+
+: print-separator-bold ( -- )
+    "==============================================================" print flush ; inline
 
 : print-header ( -- )
-    per-trial get
+    trial-size
-    batch-size get
+    batch-size
-    "MongoDB Factor Driver Benchmark\n%d ops per Trial, Batch-Size: %d\n"
+    "MongoDB Factor Driver Benchmark\n%d ops per Trial, Batch-Size: %d"
     sprintf print flush
-    print-separator ;
+    print-separator-bold ;
 
 : with-result ( quot: ( -- ) -- )
     [ <result> ] prepose
     [ print-result ] compose with-scope ; inline
 
-: run-insert-bench ( doc-word-seq feat-seq -- )
+: bench-quot ( feat-seq op-word -- quot: ( elt -- ) )
-    '[ _ swap
+    '[ _ swap _
        '[ [ [ _ execute ] dip
-            [ execute ] each insert benchmark ] with-result ] each
+            [ execute ] each _ execute benchmark ] with-result ] each
-       print-separator ] each ;
+       print-separator ] ;
+   
+: run-insert-bench ( doc-word-seq feat-seq -- )
+    "Insert Tests" print
+    print-separator-bold
+    \ insert bench-quot each ;
+
+: run-find-one-bench ( doc-word-seq feat-seq -- )
+    "Query Tests - Find-One" print
+    print-separator-bold
+    \ find-one bench-quot each ;
+
+: run-find-all-bench ( doc-word-seq feat-seq -- )
+    "Query Tests - Find-All" print
+    print-separator-bold
+    \ find-all bench-quot each ;
+
+: run-find-range-bench ( doc-word-seq feat-seq -- )
+    "Query Tests - Find-Range" print
+    print-separator-bold
+    \ find-range bench-quot each ;
+
     
 : run-benchmarks ( -- )
     db "db" get* host "127.0.0.1" get* port 27020 get* <mdb>
     [
         print-header
+        ! insert
+        { small-doc-prepare medium-doc-prepare large-doc-prepare }
+        { { } { index } { errcheck } { index errcheck }
+          { batch } { batch errcheck }
+          { batch index errcheck } }
+        run-insert-bench
+        ! find-one
         { small-doc medium-doc large-doc }
-        { { } { errcheck } { batch } { batch errcheck }
+        { { } { index } } run-find-one-bench
-          { index } { index errcheck } { batch index errcheck } } run-insert-bench
+        ! find-all
+        { small-doc medium-doc large-doc }
+        { { } { index } } run-find-all-bench
+        ! find-range
+        { small-doc medium-doc large-doc }
+        { { } { index } } run-find-range-bench
+        
     ] with-db ;
         
 

mongodb/driver/driver.factor

@@ -1,6 +1,6 @@
 USING: accessors assocs fry io.sockets kernel math mongodb.msg formatting linked-assocs destructors continuations
 mongodb.operations namespaces sequences splitting math.parser io.encodings.binary combinators io.streams.duplex
-arrays io memoize constructors sets strings uuid ;
+arrays io memoize constructors sets strings uuid bson.writer ;
 
 IN: mongodb.driver
 
@@ -52,7 +52,7 @@ SYMBOL: mdb-instance
     nodes>> [ f ] dip at inet>> ;
 
 : with-db ( mdb quot -- ... )
-    [ [ '[ _ [ mdb-instance set ] keep master>>
+    [ [ '[ _ [ mdb-instance set ensure-buffer ] keep master>>
            [ remote-address set ] keep
            binary <client>
            local-address set

mongodb/operations/operations.factor

@@ -3,6 +3,10 @@ io io.binary io.encodings.binary io.encodings.string io.encodings.utf8
 io.streams.byte-array kernel math mongodb.msg namespaces sequences
 locals assocs combinators linked-assocs ;
 
+IN: alien.c-types
+
+M: byte-vector byte-length length ;
+
 IN: mongodb.operations
 
 <PRIVATE
@@ -129,8 +133,7 @@ M: mdb-reply-op (read-message) ( msg-stub opcode -- message )
     read-int32 >>opcode
     read-int32 >>flags ; inline
 
-: write-header ( message length -- )
+: write-header ( message -- )
-    MSG-HEADER-SIZE + write-int32
     [ req-id>> write-int32 ] keep
     [ resp-id>> write-int32 ] keep 
     opcode>> write-int32 ; inline
@@ -145,10 +148,11 @@ PRIVATE>
 
 <PRIVATE
 
+USE: tools.walker
+
 : (write-message) ( message quot -- )
-     [ binary ] dip with-byte-writer 
+    '[ [ [ _ write-header ] dip _ call ] with-length-prefix ] with-buffer
-     [ length write-header ] keep 
+    write flush reset-buffer ; inline
-     write flush ; inline
 
 : build-query-object ( query -- selector )
     [let | selector [ H{ } clone ] |
@@ -158,7 +162,7 @@ PRIVATE>
           [ query>> "query" selector set-at ]
         } cleave
         selector
-    ] ;     
+    ] ; inline flushable    
 
 PRIVATE>
 
@@ -169,8 +173,8 @@ M: mdb-query-msg write-message ( message -- )
         [ collection>> write-cstring ] keep
         [ skip#>> write-int32 ] keep
         [ return#>> write-int32 ] keep
-        [ build-query-object assoc>array write ] keep
+        [ build-query-object assoc>stream ] keep
-        returnfields>> [ assoc>array write ] when* 
+        returnfields>> [ assoc>stream ] when* 
      ] (write-message) ;
  
 M: mdb-insert-msg write-message ( message -- )
@@ -178,7 +182,7 @@ M: mdb-insert-msg write-message ( message -- )
     '[ _
        [ flags>> write-int32 ] keep
        [ collection>> write-cstring ] keep
-       objects>> [ assoc>array write ] each
+       objects>> [ assoc>stream ] each
     ] (write-message) ;
 
 M: mdb-update-msg write-message ( message -- )
@@ -187,8 +191,8 @@ M: mdb-update-msg write-message ( message -- )
        [ flags>> write-int32 ] keep
        [ collection>> write-cstring ] keep
        [ upsert?>> write-int32 ] keep
-       [ selector>> assoc>array write ] keep
+       [ selector>> assoc>stream ] keep
-       object>> assoc>array write
+       object>> assoc>stream
     ] (write-message) ;
 
 M: mdb-delete-msg write-message ( message -- )
@@ -197,7 +201,7 @@ M: mdb-delete-msg write-message ( message -- )
        [ flags>> write-int32 ] keep
        [ collection>> write-cstring ] keep
        0 write-int32
-       selector>> assoc>array write
+       selector>> assoc>stream
     ] (write-message) ;
 
 M: mdb-getmore-msg write-message ( message -- )