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

CHANGELOG Mongodb buffer sharing is now always safe

libbase/buf.ml

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

libbase/buf.mli

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

libbase/mongo.ml

@@ -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");