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

db4
Sascha Matzke 2009-03-07 13:54:53 +01:00
parent f56df9e965
commit ca2459f729
5 changed files with 181 additions and 71 deletions

View File

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

View File

@ -1,17 +1,51 @@
! Copyright (C) 2008 Sascha Matzke. ! Copyright (C) 2008 Sascha Matzke.
! See http://factorcode.org/license.txt for BSD license. ! 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.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 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 <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 -- ) GENERIC: bson-write ( obj -- )
M: t bson-type? ( boolean -- type ) drop T_Boolean ; 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-type ( obj -- obj ) [ bson-type? write-byte ] keep ; inline
: write-pair ( name object -- ) write-type [ write-cstring ] dip bson-write ; inline : write-pair ( name object -- ) write-type [ write-cstring ] dip bson-write ; inline
M: f bson-write ( f -- ) M: f bson-write ( f -- )
drop 0 write-byte ; drop 0 write-byte ;
@ -91,12 +124,10 @@ M: objref bson-write ( objref -- )
write ; write ;
M: sequence bson-write ( array -- ) 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 -- ) : write-oid ( assoc -- )
[ MDB_OID_FIELD ] dip at* [ MDB_OID_FIELD ] dip at*
@ -106,20 +137,16 @@ M: sequence bson-write ( array -- )
{ "_id" "_mdb" } member? ; inline { "_id" "_mdb" } member? ; inline
M: assoc bson-write ( assoc -- ) M: assoc bson-write ( assoc -- )
[ binary ] dip
'[ _ [ write-oid ] keep '[ _ [ write-oid ] keep
[ over skip-field? [ 2drop ] [ write-pair ] if ] assoc-each [ 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 ; M: word bson-write name>> bson-write ;
PRIVATE> 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 -- ) : assoc>stream ( assoc -- )
bson-write ; inline bson-write ; inline

View File

@ -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 sequences formatting combinators namespaces io tools.time prettyprint
accessors words ; accessors words mongodb.driver ;
IN: mongodb.benchmark IN: mongodb.benchmark
SYMBOLS: per-trial batch-size collection host db port ; SYMBOLS: per-trial collection host db port ;
: get* ( symbol default -- value ) : get* ( symbol default -- value )
[ get ] dip or ; inline [ 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 : <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" "platform-as-a-service" "technology" "helps"
"developers" "focus" "building" "mongodb" "mongo" } } } "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 [ now "access-time" ] dip
[ set-at ] keep ] ; [ set-at ] keep ] ;
: (insert) ( quot: ( i -- doc ) collection -- ) : (insert) ( quot: ( i -- doc ) collection -- )
[ per-trial get ] 2dip [ trial-size ] 2dip
'[ _ call [ _ ] dip '[ _ call [ _ ] dip
result get lasterror>> [ save ] [ save-unsafe ] if ] each-integer ; inline 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 '[ _ call ] map ; inline
: (insert-batch) ( quot: ( i -- doc ) collection -- ) : (insert-batch) ( quot: ( i -- doc ) collection -- )
[ per-trial get batch-size get [ / ] keep ] 2dip [ trial-size batch-size [ / ] keep ] 2dip
'[ _ _ (prepare-batch) [ _ ] dip '[ _ _ (prepare-batch) [ _ ] dip
result get lasterror>> [ save ] [ save-unsafe ] if result get lasterror>> [ save ] [ save-unsafe ] if
] each-integer ; inline ] each-integer ; inline
: prepare-collection ( -- collection ) : bchar ( boolean -- char )
[ "t" ] [ "f" ] if ; inline
: collection-name ( -- collection )
collection "benchmark" get* 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 [ "_x_idx" drop-index ] keep
[ drop-collection ] keep [ drop-collection ] keep
[ create-collection ] keep ; inline [ create-collection ] keep ; inline
@ -138,6 +163,26 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" }
result get batch>> result get batch>>
[ '[ _ _ (insert-batch) ] ] [ '[ _ _ (insert) ] ] if ; [ '[ _ _ (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 ( -- ) : batch ( -- )
result [ t >>batch ] change ; inline result [ t >>batch ] change ; inline
@ -147,46 +192,80 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" }
: errcheck ( -- ) : errcheck ( -- )
result [ t >>lasterror ] change ; inline result [ t >>lasterror ] change ; inline
: bchar ( boolean -- char )
[ "t" ] [ "f" ] if ; inline
: print-result ( time -- ) : print-result ( time -- )
[ result get [ doc>> ] keep [ result get [ collection>> ] keep
[ batch>> bchar ] keep [ batch>> bchar ] keep
[ index>> bchar ] keep [ index>> bchar ] keep
lasterror>> bchar lasterror>> bchar
per-trial get ] dip trial-size ] dip
1000000 / /i 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 sprintf print flush ; inline
: print-separator ( -- ) : print-separator ( -- )
"-----------------------------------------------" print flush ; inline "--------------------------------------------------------------" print flush ; inline
: print-separator-bold ( -- )
"==============================================================" print flush ; inline
: print-header ( -- ) : 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 sprintf print flush
print-separator ; print-separator-bold ;
: with-result ( quot: ( -- ) -- ) : with-result ( quot: ( -- ) -- )
[ <result> ] prepose [ <result> ] prepose
[ print-result ] compose with-scope ; inline [ 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 ] 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 ( -- ) : run-benchmarks ( -- )
db "db" get* host "127.0.0.1" get* port 27020 get* <mdb> db "db" get* host "127.0.0.1" get* port 27020 get* <mdb>
[ [
print-header 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 } { 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 ; ] with-db ;

View File

@ -1,6 +1,6 @@
USING: accessors assocs fry io.sockets kernel math mongodb.msg formatting linked-assocs destructors continuations 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 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 IN: mongodb.driver
@ -52,7 +52,7 @@ SYMBOL: mdb-instance
nodes>> [ f ] dip at inet>> ; nodes>> [ f ] dip at inet>> ;
: with-db ( mdb quot -- ... ) : with-db ( mdb quot -- ... )
[ [ '[ _ [ mdb-instance set ] keep master>> [ [ '[ _ [ mdb-instance set ensure-buffer ] keep master>>
[ remote-address set ] keep [ remote-address set ] keep
binary <client> binary <client>
local-address set local-address set

View File

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