commons/ocollection/oassoc_buffer.ml

   1 open Common
   2
   3 open Oassoc
   4
   5 open Oassocb
   6 open Osetb
   7
   8 (* Take care that must often redefine all function in the original
   9  * oassoc.ml because if some methods are not redefined, for instance
  10  * #clear, then if do wrapper over a oassocdbm, then even if oassocdbm
  11  * redefine #clear, it will not be called, but instead the default
  12  * method will be called that internally will call another method.
  13  * So better delegate all the methods and override even the method
  14  * with a default definition.
  15  *
  16  * In the same way sometimes an exn can occur at weird time. When
  17  * we add an element, sometimes this may raise an exn such as Out_of_memory,
  18  * but as we dont add directly but only at flush time, the exn
  19  * may happen far later the user added something in this oassoc.
  20  * Also in the case of Out_of_memory, even if the entry is not
  21  * added in the wrapped, it will still be present in the cache
  22  * and so the next flush will still generate an exn that again
  23  * may not be cached. So for the moment if Out_of_memory then
  24  * do something special and erase the entry in the cache.
  25  *
  26  * Cf also oassoc_cache.ml which can be even more efficient.
  27  *)
  28
  29 (* !!take care!!: this class has side effect, not a pure oassoc *)
  30 (* can not make it pure, cos the assoc have side effect on the cache *)
  31 class ['a,'b] oassoc_buffer   max cached =
  32 object(o)
  33   inherit ['a,'b] oassoc
  34
  35   val counter = ref 0
  36   val cache = ref (new oassocb [])
  37   val dirty = ref (new osetb Setb.empty)
  38   val wrapped = ref cached
  39
  40   method private myflush =
  41
  42     let has_a_raised = ref false in
  43
  44     !dirty#iter (fun k ->
  45       try
  46         wrapped := !wrapped#add (k, !cache#assoc k)
  47       with Out_of_memory ->
  48         pr2 "PBBBBBB: Out_of_memory in oassoc_buffer, but still empty cache";
  49         has_a_raised := true;
  50     );
  51     dirty := (new osetb Setb.empty);
  52     cache := (new oassocb []);
  53     counter := 0;
  54     if !has_a_raised then raise Out_of_memory
  55
  56
  57   method misc_op_hook2 = o#myflush
  58
  59   method empty =
  60     raise Todo
  61
  62   (* what happens in k is already present ? or if add multiple times
  63    * the same k ? cache is a oassocb and so the previous binding is
  64    * still there, but dirty is a set, and in myflush we iter based
  65    * on dirty so we will flush only the last 'k' in the cache.
  66    *)
  67   method add (k,v) =
  68     cache := !cache#add (k,v);
  69     dirty := !dirty#add k;
  70     incr counter;
  71     if !counter > max then o#myflush;
  72     o
  73
  74   method iter f =
  75     o#myflush; (* bugfix: have to flush !!! *)
  76     !wrapped#iter f
  77
  78
  79   method keys =
  80     o#myflush; (* bugfix: have to flush !!! *)
  81     !wrapped#keys
  82
  83   method clear =
  84     o#myflush; (* bugfix: have to flush !!! *)
  85     !wrapped#clear
  86
  87
  88   method length =
  89     o#myflush;
  90     !wrapped#length
  91
  92   method view =
  93     raise Todo
  94
  95   method del (k,v) =
  96     cache := !cache#del (k,v);
  97     (* TODO as for delkey, do a try over wrapped *)
  98     wrapped := !wrapped#del (k,v);
  99     dirty := !dirty#del k;
 100     o
 101   method mem e = raise Todo
 102   method null = raise Todo
 103
 104   method assoc k =
 105     try !cache#assoc k
 106     with Not_found ->
 107       (* may launch Not_found, but this time, dont catch it *)
 108       let v = !wrapped#assoc k in
 109       begin
 110         cache := !cache#add (k,v);
 111         (* otherwise can use too much mem *)
 112         incr counter;
 113         if !counter > max then o#myflush;
 114         v
 115       end
 116
 117   method delkey k =
 118     cache := !cache#delkey k;
 119     (* sometimes have not yet flushed, so may not be yet in, (could
 120      * also flush in place of doing try).
 121      *
 122      * TODO would be better to see if was in cache (in case mean that
 123      * perhaps not flushed and do try and in other case just cos del
 124      * (without try) cos forcement flushed ou was an error *)
 125     begin
 126       try wrapped := !wrapped#delkey k
 127       with Not_found -> ()
 128     end;
 129     dirty := !dirty#del k;
 130     o
 131
 132 end
 133
 134