Source file memory_cache.ml

(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019,2020 DaiLambda, Inc. <contact@dailambda.jp>            *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)
(* Node cache with some easy heuristics *)

open Utils
open Array.Syntax

type stat = { ever_hit : int ; ever_added : int }

type config =
  { threshold_at_shrink : int   (* max elems survive each shrink *)
  ; threshold_absolute : int (* max elems of any time *)
  ; shrink_ratio : float     (* how much we shrink *)
  }

let config_disabled =
  { threshold_at_shrink = 0
  ; threshold_absolute = 0
  ; shrink_ratio = 0.0
  }

module Make(Key : sig
    type t
    val equal : t -> t -> bool
    val hash : t -> int
  end) = struct

  module Tbl = Hashtbl.Make(struct
      type t = Key.t
      let equal = Key.equal
      let hash = Key.hash
    end)

  let validate_config c =
    assert
      (c.threshold_at_shrink <= c.threshold_absolute
       && 0. <= c.shrink_ratio && c.shrink_ratio <= 1.0)

  type 'a t =
    { tbl : (Key.t, ('a * int ref)) Hashtbl.t
    (* int ref for the score.

       Size: 16 words, 128bytes in 64bit arch
       for (Hash.t * (Index.t * int ref)) *)
    ; counters : int array
    (* counter.(i) : sum of entries that i equals the value of int ref in tbl *)
    ; mutable stat : stat
    ; config : config
    }

  let is_disabled t = t.config.threshold_absolute = 0

  let get_stat t = t.stat

  let max_cntr = 65536

  let incr_counters t i = t.counters.!(i) <- t.counters.!(i) + 1
  let decr_counters t i = t.counters.!(i) <- t.counters.!(i) - 1

  let create config =
    validate_config config;
    { tbl = Hashtbl.create 0
    ; counters = Array.make (max_cntr+1) 0
    ; stat = { ever_hit= 0; ever_added= 0 }
    ; config
    }

  let size t = Hashtbl.length t.tbl

  let update_counter t cntr n =
    let i = !cntr in
    decr_counters t i;
    cntr := n;
    incr_counters t n

  let find_opt t nh =
    if is_disabled t then None
    else
      match Hashtbl.find_opt t.tbl nh with
      | None -> None
      | Some (i, cntr) ->
          let cnt = Int.min max_cntr (!cntr + 256) in
          update_counter t cntr cnt; (* completely no logical idea *)
          t.stat <- { t.stat with ever_hit = t.stat.ever_hit + 1 };
          Some i

  let pp_stat ppf t =
    Format.fprintf ppf "size=%d added=%d hit=%d ratio=%.2f"
      (size t)
      t.stat.ever_added t.stat.ever_hit
      (float t.stat.ever_hit /. float (t.stat.ever_added + t.stat.ever_hit))

  let shrink' t threshold =
    let round_up_pow2 v =
      let v = v - 1 in
      let v = v lor (v lsr 1) in
      let v = v lor (v lsr 2) in
      let v = v lor (v lsr 4) in
      let v = v lor (v lsr 8) in
      let v = v lor (v lsr 16) in
      v + 1 in
    let log2_of_pow2 v =
      (* log2 using de Bruijn sequence
         Assume v is a power of 2 *)
      [|0; 1; 28; 2; 29; 14; 24; 3; 30; 22; 20; 15; 25; 17; 4; 8;
        31; 27; 13; 23; 21; 19; 16; 7; 26; 12; 18; 6; 11; 5; 10; 9|]
      .((v * 0x077cb531) lsr 27 land 0b11111) in
    let slide_array ary n =
      let rec slide ary n i =
        if i+n < Array.length ary then
          (ary.!(i) <- ary.!(i+n); slide ary n (i+1))
        else if i < Array.length ary then
          (ary.!(i) <- 0; slide ary n (i+1))
        else (ary.!(0) <- 0) in
      slide ary n 0 in
    (* Slide array [counters] until the sum of counters descreses n, a power of 2 *)
    let slide_counters t n =
      let rec f t n i m =
        if n <= m then i-1
        else
          let m = m + t.counters.(i) in
          f t n (i+1) m in
      let slide_i = f t n 0 0 in
      if slide_i = 0 then 0 else
        let slide_i = round_up_pow2 slide_i in
        let () = slide_array t.counters slide_i in
        log2_of_pow2 slide_i + 1 in

    let sz = size t in
    if sz > threshold then begin
      let goal = int_of_float @@ float threshold *. t.config.shrink_ratio in
      Log.notice "node_cache shrinking from %d to %d" sz goal;
      if Envconf.use_reachable_words then
        Log.notice "node_cache shrinking from %.2fMB" (Utils.reachable_mbs t);
      (* XXX Very simple inefficient loop.  Sometimes overclean things *)
      let shift_i = slide_counters t (sz - goal) in
      let f () =
        Hashtbl.filter_map_inplace (fun _nh (i, cntr) ->
            let n = !cntr lsr shift_i in
            if n = 0 then None else Some (i, ref n)) t.tbl in
      let (), secs = with_time f in
      let sz_current = size t in
      assert (sz_current <= goal);
      Log.notice "node_cache shrank from %d to %d in %a: %a"
        sz sz_current
        Mtime.Span.pp secs
        pp_stat t;
      if Envconf.use_reachable_words then
        Log.notice "node_cache shrank to %.2fMB" (Utils.reachable_mbs t);
    end

  let shrink t =
    if is_disabled t then ()
    else shrink' t t.config.threshold_at_shrink

  let add t nh i =
    if is_disabled t then ()
    else begin
      let cntr = match Hashtbl.find_opt t.tbl nh with
        | Some (_, cntr) ->
            let cnt = Int.min max_cntr (!cntr + 256) in
            update_counter t cntr cnt;
            cntr
        | None ->
            let cntr = ref 256 in
            incr_counters t !cntr;
            cntr in
      Hashtbl.replace t.tbl nh (i, cntr); (* survives 8 shrink loops at least *)
      t.stat <- { t.stat with ever_added= t.stat.ever_added + 1 };
      shrink' t t.config.threshold_absolute
    end
end