Source file hashcons.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.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(*
  Caching of small Value.t

  Strategy:

  * Value.t larger than max_leaf_size is never cached.

  * Any Value.t equal to or smaller than max_leaf_size is cached for small
    amount of time.
  * Each Value.t in the cache has its score.  Score decays gradually.
  * Once its score becomes 0, the Value.t may be removed from the cache.

  * If cache hits, the Value.t gains some score.
*)
open Utils
open Array.Syntax

type Error.t += Hashcons of string
let () = Error.register_printer @@ function
  | Hashcons s -> Some ("Hashcons: " ^ s)
  | _ -> None

type config =
  { max_leaf_size : int
  ; max_bytes_commit : int
  ; max_bytes_absolute : int
  ; shrink_ratio : float
  }

let config_enabled =
  { max_leaf_size= 36
  ; max_bytes_commit = 10_000_000 (* 10MB *)
  ; max_bytes_absolute = 50_000_000 (* 50MB *)
  ; shrink_ratio = 0.8
  }

let config_disabled =
  { max_leaf_size= 0
  ; max_bytes_commit = 0
  ; max_bytes_absolute = 0
  ; shrink_ratio = 0.0
  }

let check_config c =
  if c.max_leaf_size >= 0
  && c.max_bytes_commit <= c.max_bytes_absolute
  && 0. <= c.shrink_ratio && c.shrink_ratio <= 1.0
  then Ok () else Error ()

(* Number of blocks for the value of the given size in bytes *)
let blocks size =
  if size <= 32 then 2
  else if size <= 64 then 3
  else
    (* assuming using only 1 chunk *)
    (size + 6 + 31) / 32

type contents = { index: Index.t; mutable freq: int }

type t =
  { tbl : (Value.t, contents) Hashtbl.t
  ; config : config
  ; mutable current_bytes : int
  ; mutable saved_blocks : int
  ; by_size : int array
  ; scores : int array
  ; mutable warned_level : int
  }

let config t = t.config

let is_disabled t = t.config.max_leaf_size = 0

let max_freq = 10000

let entry_bytes len =
  (len / 8 + 2) * Sys.word_size / 8
  + 61 (* 61 bytes per Hashtbl entry *)

let score len freq =
  let blocks = blocks len in
  let gain = blocks * freq in
  let cost = entry_bytes len / 8 in
  gain / cost

let max_score len = score len max_freq

let score v { freq; _ } = score (Value.length v) freq

let entry_bytes v = entry_bytes (Value.length v)

let create config =
  { tbl = Hashtbl.create 101
  ; config
  ; current_bytes= 0
  ; saved_blocks= 0
  ; by_size= Array.make config.max_leaf_size 0
  ; scores = Array.make (max_score config.max_leaf_size + 1) 0
  ; warned_level = 1;
  }

let estimated_size_in_bytes t = t.current_bytes

let stat ppf t =
  Format.fprintf ppf "hashcons saved: %d  saved: %.2f MB  current_bytes: %d  max: %d@."
    t.saved_blocks (float t.saved_blocks *. float Sys.word_size /. 8_000_000.0)
    t.current_bytes
    t.config.max_bytes_commit

let stat_table ppf t =
  Format.fprintf ppf "hashcons buckets:@.";
  Array.iteri (fun i n ->
      Format.fprintf ppf "bksz %2d %6d@." (i+1) n) t.by_size

let find t v =
  let len = Value.length v in
  if len = 0 || len > t.config.max_leaf_size then
    Error (Hashcons "hashcons: too large or 0")
  else
    match Hashtbl.find_opt t.tbl v with
    | None -> Ok None
    | Some c ->
        let b = entry_bytes v in
        let s = score v c in
        t.scores.!(s) <- t.scores.(s) - b;
        c.freq <- Int.min max_freq (c.freq + 100);
        let s = score v c in
        t.scores.!(s) <- t.scores.(s) + b;
        t.saved_blocks <- t.saved_blocks + blocks len;
        Ok (Some c.index)

let shrink' t threshold =
  if t.current_bytes <= threshold then ()
  else begin
    let down_to = int_of_float @@ float threshold *. t.config.shrink_ratio in
    Log.notice "hashcons: shrinking from %d to %d ..." t.current_bytes down_to;
    if Envconf.use_reachable_words then
      Log.notice "hashcons: %.2f MB to..." (Utils.reachable_mbs t);
    let org_current_bytes = t.current_bytes in
    Format.kasprintf (Log.debug "%s") "%a" stat t;
    Format.kasprintf (Log.debug "%s") "%a" stat_table t;
    let (), secs = with_time @@ fun () ->
      let bound_score =
        let b = t.current_bytes - down_to in
        let rec f i s =
          let s = s + t.scores.(i) in
          t.scores.!(i) <- 0;
          if b <= s then i
          else f (i+1) s in
        f 0 0 in
      Hashtbl.filter_map_inplace (fun v c ->
          let cost = entry_bytes v in
          let s = score v c in
          if s <= bound_score then begin
            t.current_bytes <- t.current_bytes - cost;
            let i = Value.length v - 1 in
            t.by_size.!(i) <- t.by_size.!(i) - 1;
            None
          end
          else begin
            t.scores.!(s) <- t.scores.(s) - cost;
            c.freq <- c.freq * 9 / 10;
            let s = score v c in
            t.scores.!(s) <- t.scores.(s) + cost;
            Some c
          end) t.tbl;
      assert (t.current_bytes <= down_to)
    in
    Log.notice "hashcons: shrank from %d to %d in %a" org_current_bytes t.current_bytes Mtime.Span.pp secs;
    if Envconf.use_reachable_words then
      Log.notice "hashcons: shrank to %.2f MB" (Utils.reachable_mbs t);
    Format.kasprintf (Log.notice "%s") "%a" stat t;
    Format.kasprintf (Log.notice "%s") "%a" stat_table t
  end

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

let add t v index =
  let len = Value.length v in
  if len = 0 || len > t.config.max_leaf_size then
    Error (Hashcons "hashcons: too large or 0")
  else begin
    match Hashtbl.find_opt t.tbl v with
    | Some { index=index'; freq } ->
        (* Let's use newer index *)
        Hashtbl.replace t.tbl v { index= Index.max index index'; freq };
        Ok ()
    | None ->
        let c = { index; freq= 100 } in
        let b = entry_bytes v in
        Hashtbl.replace t.tbl v c;
        t.current_bytes <- t.current_bytes + b;
        t.by_size.!(len-1) <- t.by_size.!(len-1) + 1;
        let s = score v c in
        t.scores.(s) <- t.scores.(s) + b;
        shrink' t t.config.max_bytes_absolute;
        Ok ()
  end