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

open Lwt.Syntax

let hard_limit_max_tag = 256

module Int64 = Stdint.Int64

module Head_string = struct
  let make ~hash_func ~bytes_per_hash ~with_count =
    assert (0 <= bytes_per_hash && bytes_per_hash < 256);
    Printf.sprintf "PLEBEIA%s%c%c%c"
      (String.make 10 '\000')
      (Char.chr (if with_count then 1 else 0))
      (Char.chr (match hash_func with `Blake2B -> 0 | `Blake3 -> 1))
      (Char.chr bytes_per_hash)

  let _parse head_string =
    if String.length head_string <> 20 then None
    else if String.sub head_string 0 7 <> "PLEBEIA" then None
    else
      let open Option.Syntax in
      let* bytes_per_hash =
        match Char.code head_string.[19] with
        | 0 -> None
        | n -> Some n
      in
      let* hash_func =
        match Char.code head_string.[18] with
        | 0 -> Some `Blake2B
        | 1 -> Some `Blake3
        | _ -> None
      in
      let+ with_count =
        match Char.code head_string.[17] with
        | 0 -> Some false
        | 1 -> Some true
        | _ -> None
      in
      (hash_func, bytes_per_hash, with_count)
end

let make_storage_config ~bytes_per_cell ~hash_func ~bytes_per_hash ~with_count =
  (* 01234567890123456789
     PLEBEIA<-- 0 --->CHB
  *)
  Storage.{
    head_string = Head_string.make ~hash_func ~bytes_per_hash ~with_count;
    version = Version.version;
    bytes_per_cell;
    max_index = Index.(max_int - Unsafe.of_int hard_limit_max_tag);
  }

type t =
  { storage : Storage.t
  ; hashcons : Hashcons.t (* Hashcons tbl *)
  ; node_cache : Index.t Node_cache.t
  ; stat : Stat.t (* Statistics *)
  ; hash : Hash.Hasher.t
  ; keep_hash : bool
  ; bytes_per_cell : int
  ; with_count : bool
  ; offsets : Node_offsets.t
  }

type config =
  { bytes_per_cell : int
  ; hash_func : [`Blake2B | `Blake3 ]
  ; bytes_per_hash : int
  ; with_count : bool
  }

let default_config =
  { bytes_per_cell= 36
  ; hash_func= `Blake2B
  ; bytes_per_hash= 28
  ; with_count= true
  }

let config_name { bytes_per_cell; hash_func; bytes_per_hash; with_count } =
  Printf.sprintf "%s-%d-%d%s"
    (match hash_func with `Blake2B -> "2" | `Blake3 -> "3")
    bytes_per_hash
    bytes_per_cell
    (if with_count then "" else "-no-count")

let pp_config ppf { bytes_per_cell; hash_func; bytes_per_hash; with_count } =
  Format.fprintf ppf "@[{ bytes_per_cell= %d; hash_func= %s; bytes_per_hash= %d; with_count= %b }@]"
    bytes_per_cell
    (match hash_func with `Blake2B -> "`Blake2B" | `Blake3 -> "`Blake3")
    bytes_per_hash
    with_count

let get_config (t : t) : config =
  { bytes_per_cell= t.bytes_per_cell
  ; hash_func = t.hash.hash_func
  ; bytes_per_hash = t.hash.bytes
  ; with_count = t.with_count
  }

let config_override { bytes_per_cell; hash_func; bytes_per_hash; with_count } keep_hash =
  let f over x = Option.default x over in
  { bytes_per_cell= f Envconf.cell_bytes_override bytes_per_cell;
    bytes_per_hash= f Envconf.hash_bytes_override bytes_per_hash;
    hash_func= f Envconf.hash_function_override hash_func;
    with_count= f Envconf.with_count_override with_count;
  },
  f Envconf.keep_hash_override keep_hash

let mode t = Storage.mode t.storage

let get_storage c = c.storage

let memory_only ?hashcons ?(keep_hash=false) config =
  let ({ bytes_per_cell; hash_func; bytes_per_hash; with_count } : config), keep_hash =
    config_override config keep_hash
  in
  let hash = Hash.Hasher.make ~bytes_per_cell ~hash_func ~bytes_per_hash ~with_count in
  let hashcons = Hashcons.create (Option.default Hashcons.config_disabled hashcons) in
  let node_cache =
    (* dummy node_cache *)
    Node_cache.(create { threshold_at_shrink= 1
                       ; threshold_absolute= 1
                       ; shrink_ratio= 0.5 })
  in
  let offsets = Node_offsets.make_offsets ~bytes_per_cell ~bytes_per_hash ~with_count in
  { storage= Storage.null
  ; hashcons
  ; node_cache
  ; stat= Stat.create ()
  ; hash
  ; keep_hash
  ; bytes_per_cell
  ; with_count
  ; offsets
  }

let is_memory_only t = Storage.is_null t.storage

let create
    ?hashcons
    ?node_cache
    ?resize_step_bytes
    ?(keep_hash=false)
    config
    ~key
    fn =
  let { bytes_per_cell; hash_func; bytes_per_hash; with_count }, keep_hash =
    config_override config keep_hash
  in
  let hash = Hash.Hasher.make ~bytes_per_cell ~hash_func ~bytes_per_hash ~with_count in
  let config = make_storage_config ~bytes_per_cell ~hash_func ~bytes_per_hash ~with_count in
  let+ storage = Storage.create ~config ~key ?resize_step_bytes fn in
  let hashcons = Hashcons.create (Option.default Hashcons.config_disabled hashcons) in
  let node_cache = match node_cache with None -> Node_cache.(create config_disabled) | Some nc -> nc in
  let offsets = Node_offsets.make_offsets ~bytes_per_cell ~bytes_per_hash ~with_count in
  { storage
  ; hashcons
  ; node_cache
  ; stat = Stat.create ()
  ; hash
  ; keep_hash
  ; bytes_per_cell
  ; with_count
  ; offsets
  }

let open_existing_for_read
    ?hashcons
    ?node_cache
    ?(keep_hash=false)
    config
    fn =
  let open Result_lwt.Syntax in
  let { bytes_per_cell; hash_func; bytes_per_hash; with_count }, keep_hash =
    config_override config keep_hash
  in
  let config' = make_storage_config ~bytes_per_cell ~hash_func ~bytes_per_hash ~with_count in
  let*=? (config, storage) = Storage.open_existing_for_read fn in
  if config <> config' then
    Lwt.return_error @@ Storage.Config_mismatch { actual= config; expected= config' }
  else
    let hash = Hash.Hasher.make ~bytes_per_cell ~hash_func ~bytes_per_hash ~with_count in
    let hashcons = Hashcons.create (Option.default Hashcons.config_disabled hashcons) in
    let node_cache = match node_cache with None -> Node_cache.(create config_disabled) | Some nc -> nc in
    let offsets = Node_offsets.make_offsets ~bytes_per_cell ~bytes_per_hash ~with_count in
    Lwt.return_ok  { storage
                   ; hashcons
                   ; node_cache
                   ; stat = Stat.create ()
                   ; hash
                   ; keep_hash
                   ; bytes_per_cell
                   ; with_count
                   ; offsets
                   }

let open_for_write
    ?hashcons
    ?node_cache
    ?resize_step_bytes
    ?(keep_hash=false)
    config
    ~key
    fn =
  let { bytes_per_cell; hash_func; bytes_per_hash; with_count }, keep_hash =
    config_override config keep_hash
  in
  let config = make_storage_config ~bytes_per_cell ~hash_func ~bytes_per_hash ~with_count in
  let+ storage = Storage.open_for_write ?resize_step_bytes ~config ~key fn in
  let hash = Hash.Hasher.make ~bytes_per_cell ~hash_func ~bytes_per_hash ~with_count in
  let hashcons = Hashcons.create (Option.default Hashcons.config_disabled hashcons) in
  let node_cache = match node_cache with None -> Node_cache.(create config_disabled) | Some nc -> nc in
  let offsets = Node_offsets.make_offsets ~bytes_per_cell ~bytes_per_hash ~with_count in
  { storage
  ; hashcons
  ; node_cache
  ; stat = Stat.create ()
  ; hash
  ; keep_hash
  ; bytes_per_cell
  ; with_count
  ; offsets
  }

let close { storage ; _ } = Storage.close storage

let shrink_node_cache { node_cache ; _ } =
  Node_cache.shrink node_cache

let pp_cache_for_debug ppf { node_cache ; hashcons ; _ } =
  Format.fprintf ppf "node_cache %.02fMB hashcons %.02fMB"
    (float (Utils.reachable_words node_cache) *. float Sys.word_size /. 8_000_000.)
    (float (Utils.reachable_words hashcons) *. float Sys.word_size /. 8_000_000.)