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 =
    assert (0 <= bytes_per_hash && bytes_per_hash < 256);
    Printf.sprintf "PLEBEIA%s%c%c"
      (String.make 11 '\000')
      (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 bytes_per_hash = Char.code head_string.[19] in
      if bytes_per_hash = 0 then None
      else
        match Char.code head_string.[18] with
        | 0 -> Some (`Blake2B, bytes_per_hash)
        | 1 -> Some (`Blake3, bytes_per_hash)
        | _ -> None
end

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

let check_storage_config ~bytes_per_cell ~bytes_per_hash =
  if not (bytes_per_hash + 4 <= bytes_per_cell) then
    invalid_arg "bytes_per_cell is too small for the hash size"

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
  }

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

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

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

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
  }

let config_override { bytes_per_cell; hash_func; bytes_per_hash } 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;
  },
  f Envconf.keep_hash_override keep_hash

let mode t = Storage.mode t.storage

let get_storage c = c.storage

let memory_only ?hashcons ?(bytes_per_cell=32) ?(hash_func=`Blake2B) ?(bytes_per_hash=28)
    ?(keep_hash=false) () =
  let ({ bytes_per_cell; hash_func; bytes_per_hash } : config), keep_hash =
    config_override ({ bytes_per_cell; hash_func; bytes_per_hash } : config) keep_hash
  in
  check_storage_config ~bytes_per_cell ~bytes_per_hash;
  let hash = Hash.Hasher.make ~bytes_per_cell ~hash_func ~bytes_per_hash 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
  { storage= Storage.null
  ; hashcons
  ; node_cache
  ; stat= Stat.create ()
  ; hash
  ; keep_hash
  ; bytes_per_cell
  }

let is_memory_only t = Storage.is_null t.storage

let create ?hashcons ?node_cache
    ?(bytes_per_cell=32) ?(hash_func=`Blake2B) ?(bytes_per_hash=28)
    ?resize_step_bytes ?(keep_hash=false)
    fn =
  let { bytes_per_cell; hash_func; bytes_per_hash }, keep_hash =
    config_override { bytes_per_cell; hash_func; bytes_per_hash } keep_hash
  in
  check_storage_config ~bytes_per_cell ~bytes_per_hash;
  let hash = Hash.Hasher.make ~bytes_per_cell ~hash_func ~bytes_per_hash in
  let config = make_storage_config ~bytes_per_cell ~hash_func ~bytes_per_hash in
  let+ storage = Storage.create ~config ?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
  { storage
  ; hashcons
  ; node_cache
  ; stat = Stat.create ()
  ; hash
  ; keep_hash
  ; bytes_per_cell
  }

let open_ ?hashcons ?node_cache ~mode
    ?(bytes_per_cell=32) ?(hash_func=`Blake2B) ?(bytes_per_hash=28)
    ?resize_step_bytes
    ?(keep_hash=false)
    fn =
  let { bytes_per_cell; hash_func; bytes_per_hash }, keep_hash =
    config_override { bytes_per_cell; hash_func; bytes_per_hash } keep_hash
  in
  check_storage_config ~bytes_per_cell ~bytes_per_hash;
  let+ storage =
    let* res = Storage.open_ ~mode fn ?resize_step_bytes in
    match res with
    | Some (config, storage) ->
        if config.bytes_per_cell <> bytes_per_cell then invalid_arg "invalid bytes_per_cell";
        begin match Head_string.parse config.head_string with
          | None -> invalid_arg "invalid head string"
          | Some (hash_func', bytes_per_hash') ->
              if hash_func <> hash_func' then invalid_arg "invalid hash_func";
              if bytes_per_hash <> bytes_per_hash' then invalid_arg "invalid bytes_per_hash";
              Lwt.return storage
        end
    | None ->
        let config = make_storage_config ~bytes_per_cell ~hash_func ~bytes_per_hash in
        Storage.create ~config fn
  in
  let hash = Hash.Hasher.make ~bytes_per_cell ~hash_func ~bytes_per_hash 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
  { storage
  ; hashcons
  ; node_cache
  ; stat = Stat.create ()
  ; hash
  ; keep_hash
  ; bytes_per_cell
  }

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.)