Permalink
Browse files

[fix] libbase/mongo: using GC finalise to do safe pool handling

CHANGELOG Mongodb buffer sharing is now always safe
  • Loading branch information...
OpaOnWindowsNow committed Apr 11, 2012
1 parent a472b05 commit 227e03834b397c15cf7bb989239bd570ff7294fc
Showing with 88 additions and 16 deletions.
  1. +11 −1 libbase/buf.ml
  2. +5 −1 libbase/buf.mli
  3. +72 −14 libbase/mongo.ml
View
@@ -1,5 +1,5 @@
(*
Copyright © 2011 MLstate
Copyright © 2011, 2012 MLstate
This file is part of OPA.
@@ -81,6 +81,16 @@ let autoresize buf extra msg =
let copy buf = { str=String.copy buf.str; i=buf.i }
let finalize buf unused younger =
buf.i <- younger.i;
buf.str <- younger.str;
unused buf
let mark_as_used ~unused buf =
let younger = { str=buf.str; i=buf.i } in
Gc.finalise (finalize buf unused) younger;
younger
let clear buf = buf.i <- 0
let reset buf = buf.str <- ""; buf.i <- 0
View
@@ -1,5 +1,5 @@
(*
Copyright © 2011 MLstate
Copyright © 2011, 2012 MLstate
This file is part of OPA.
@@ -61,3 +61,7 @@ val resize : buf -> int -> unit
val extend : buf -> int -> unit
val real_length : buf -> int
val spare : buf -> int
(** to handle a pool of buffer with GC cooperation
create a shallow copy of buffer and attach a finalisation taking original buffer updated on it *)
val mark_as_used : unused:(buf -> unit) -> buf -> buf
View
@@ -1,5 +1,5 @@
(*
Copyright © 2011 MLstate
Copyright © 2011, 2012 MLstate
This file is part of OPA.
@@ -142,19 +142,77 @@ let set_header m requestId responseTo opCode =
St.lei32 m.Bson.buf.Buf.str 12 opCode;
m.Bson.buf.Buf.i <- 16
let buflst = ref ([]:Buf.t list)
let bufcnt = ref 0
let buflog = ref (fun str -> Printf.eprintf "%s\n%!" str)
let get_buf ?(hint=4096) () =
match !buflst with
| [] -> (#<If$minlevel 2>!buflog (Printf.sprintf "get_buf(%d): new" !bufcnt)#<End>; Buf.create hint)
| b::t -> (#<If$minlevel 2>!buflog (Printf.sprintf "get_buf(%d): old" !bufcnt)#<End>; buflst := t; decr bufcnt; Buf.clear b; b)
let free_buf b =
if Buf.length b <= (10*1024*1024)
then (#<If$minlevel 2>!buflog (Printf.sprintf "free_buf(%d): return" !bufcnt)#<End>; buflst := b::(!buflst); incr bufcnt)
else (#<If$minlevel 2>!buflog (Printf.sprintf "free_buf(%d): reset" !bufcnt)#<End>; Buf.reset b)
(* handle a pool of buffer for short lives buffer, and diverges to standard allocation (pure GC) when the pool is failing
performance gains (vs standard) are not huge (at most 15% on persistant db actors)
detection of unused buffer is based on finalise (i.e. depends on GC),
that can explain the gain is small compared to pure GC *)
module Pool = struct
type pool = {
mutable list : Buf.t list; (* free buffers *)
mutable free : int; (* number of free *)
mutable total : int; (* number of buffer = free + used *)
maximal_total : int; (* maximal pool total size *)
initial_size : int; (* default initial size for buffers *)
dealloc_size : int (* automatic forget of bigger buffer *)
}
let buflog = ref (fun str -> Printf.eprintf "%s\n%!" str)
let _Kb = 1024
let _Mb = 1024 * _Kb
let default () = {
list = [];
total = 0;
free = 0;
maximal_total = 1024;
initial_size = _Kb * 4;
dealloc_size = _Mb * 16
}
let collect () = () (*ignore(Gc.minor ())*) (* triggering gc changes almost nothing *)
let independant_alloc _pool hint =
#<If$minlevel 2>!buflog "extra wild buffer"#<End>;
Buf.create hint
let pool_alloc pool hint =
#<If$minlevel 2>!buflog (Printf.sprintf "get_buf(%d/%d): %s" pool.free pool.total (if pool.list=[] then "new" else "old"))#<End>;
if pool.list = [] then collect ();
match pool.list with
| [] ->
pool.total <- pool.total + 1;
Buf.create hint
| b::t ->
pool.free <- pool.free - 1;
pool.list <- t;
Buf.clear b;
b
let unsafe_free pool b =
if (Buf.length b < pool.dealloc_size) && (pool.total <= pool.maximal_total) then (
#<If$minlevel 2>!buflog (Printf.sprintf "free_buf(%d): return" pool.free)#<End>;
pool.list <- b::pool.list;
pool.free <- pool.free + 1
) else (
#<If$minlevel 2>!buflog (Printf.sprintf "free_buf(%d): reset" pool.free)#<End>;
(* Bug.reset ; USELESS *)
pool.total <- pool.total - 1;
)
let alloc pool =
fun ?(hint=pool.initial_size) () ->
if pool.total >= pool.maximal_total && pool.list==[] then independant_alloc pool hint
else Buf.mark_as_used ~unused:(unsafe_free pool) (pool_alloc pool hint)
end
let pool_mongo = Pool.default ()
let get_buf = Pool.alloc pool_mongo
let free_buf _b = ()
let create size =
if size < 16 then raise (Failure "Mongo.create: ridiculous size value");

0 comments on commit 227e038

Please sign in to comment.