steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
bson/writer/writer-docs.factor
View File

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

67
bson/writer/writer.factor
View File

@ -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
serialize strings words calendar ;
io.streams.byte-array kernel math math.parser namespaces
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 ]
each-index ]
binary swap with-byte-writer
[ length 5 + bson-write ] keep
write
write-eoo ;
'[ _ [ [ write-type ] dip number>string
write-cstring bson-write ] each-index
write-eoo
] with-length-prefix ;
: 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
[ length 5 + bson-write ] keep
write
write-eoo ;
write-eoo ] with-length-prefix ;
M: word bson-write name>> bson-write ;
PRIVATE>
: assoc>array ( assoc -- byte-array )
'[ _ bson-write ] binary swap with-byte-writer ; inline
: assoc>bv ( assoc -- byte-vector )
[ '[ _ bson-write ] with-buffer ] with-scope ; inline
: assoc>stream ( assoc -- )
bson-write ; inline

151
mongodb/benchmark/benchmark.factor
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
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 ) )
result [ "small" >>doc ] change
DOC-SMALL clone
'[ "x" _ [ set-at ] keep ] ; inline
: set-doc ( name -- )
[ result ] dip '[ _ >>doc ] change ; inline
: medium-doc ( -- quot: ( i -- doc ) )
result [ "medium" >>doc ] change
DOC-MEDIUM clone
'[ "x" _ [ set-at ] keep ] ; inline
: small-doc ( -- )
"small" set-doc ; inline
: large-doc ( -- quot: ( i -- doc ) )
result [ "large" >>doc ] change
DOC-LARGE clone
'[ "x" _ [ set-at ] keep
: medium-doc ( -- )
"medium" set-doc ; inline
: 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
batch-size get
"MongoDB Factor Driver Benchmark\n%d ops per Trial, Batch-Size: %d\n"
trial-size
batch-size
"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 -- )
'[ _ swap
: bench-quot ( feat-seq op-word -- quot: ( elt -- ) )
'[ _ swap _
'[ [ [ _ execute ] dip
[ execute ] each insert benchmark ] with-result ] each
print-separator ] each ;
[ execute ] each _ execute benchmark ] with-result ] 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 } { index errcheck } { batch index errcheck } } run-insert-bench
{ { } { index } } run-find-one-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 ;

4
mongodb/driver/driver.factor
View File

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

28
mongodb/operations/operations.factor
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
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 -- )
MSG-HEADER-SIZE + write-int32
: write-header ( message -- )
[ 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
[ length write-header ] keep
write flush ; inline
'[ [ [ _ write-header ] dip _ call ] with-length-prefix ] with-buffer
write flush reset-buffer ; 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
returnfields>> [ assoc>array write ] when*
[ build-query-object assoc>stream ] keep
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
object>> assoc>array write
[ selector>> assoc>stream ] keep
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 -- )