Source file copy.ml

(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 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.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Copy commits to one file to another *)

open Utils
open Lwt.Syntax
open Result_lwt.Syntax
open Result_lwt.Infix

let report_gc () =
  (* It takes 0.2 secs *)
  Stdlib.Gc.print_stat Stdlib.stderr

(* [cs] should be copied from older to newer for the better performance *)
(* XXX assuming we use the same hash function *)
let copy vc1 cs vc2 =
  (* Since it loops without Lwt for long, we use non Lwt logger *)
  Log.(set default);
  let commits1 = Vc.commit_db vc1 in
  let+=? (n_done, _, _) =
    Result_lwt.fold_leftM (fun (n_done, _last_src, _last_dst) c1 ->
        let* () =
          if n_done mod 100 = 0 then
            Lwt_fmt.eprintf "%d vc1: %a  vc2: %a@."
              n_done Context.pp_cache_for_debug (Vc.context vc1) Context.pp_cache_for_debug (Vc.context vc2)
          else Lwt.return_unit
        in
        let* () =
          if n_done mod 1000 = 0 then begin
            (* XXX I guess not really required *)
            let* () = Lwt_fmt.eprintf "%d reopen vc1@." n_done in
            let* (), sec = with_time_lwt @@ fun () ->
              Storage.reopen (Vc.context vc1).Context.storage in
            let* () = Lwt_fmt.eprintf "%d reopen vc1 in %a@." n_done Mtime.Span.pp sec in
            let* () = Lwt_fmt.eprintf "%d reopen vc2@." n_done in
            let* (), sec = with_time_lwt @@ fun () ->
              Storage.reopen (Vc.context vc2).Context.storage in
            Lwt_fmt.eprintf "%d reopen vc2 in %a@." n_done Mtime.Span.pp sec
          end else Lwt.return_unit
        in

        let* () =
          if n_done mod 1000 = 0 then begin
            (* This is VERY costy. *)
            Stdlib.Gc.compact ();
            let (), sec = with_time @@ report_gc in
            Lwt_fmt.eprintf "%d gc: %a@." n_done Mtime.Span.pp sec
          end else Lwt.return_unit
        in

        (* copy src with the info! *)
        let* src =
          Lwt.map from_Some @@ Vc.checkout ~keep_info:true vc1 c1.Commit.hash
        in

        (* search parents *)
        let*=? (parent, (psrc, pdst)) =
          match Commit_db.parent commits1 c1 with
          | Ok None | Error `Not_found ->
              (* c1 is genesis or its parent is not in the db*)
              Result_lwt.return (None, (Vc.empty vc1, Vc.empty vc2))
          | Ok (Some p1) ->
              (* Do we have copied it into [vc2] already? *)
              let+ p =
                let* res = Vc.checkout' vc2 p1.Commit.hash in
                match res with
                | None -> Lwt.return (Vc.empty vc1, Vc.empty vc2)
                | Some (_p2, cur2) ->
                    let+ pcur = Lwt.map from_Some @@ Vc.checkout vc1 p1.Commit.hash in
                    (pcur, cur2)
              in
              Ok (Some p1.Commit.hash, p)
        in
        let _, nhpsrc = Cursor.compute_hash psrc in
        let _, nhpdst = Cursor.compute_hash pdst in
        assert (nhpsrc = nhpdst);

        (* Diff psrc and src *)
        let Cursor.Cursor (tr, pn, ctxt1,  _) = psrc in
        let Cursor.Cursor (tr', n, ctxt1', info) = src  in

        let Cursor(_, _, dctxt, _) = pdst in

        (* visit the copied segments and scan the nodes under them *)
        let copies = info.Info.copies in
        if List.length copies <> 0 then
          Format.eprintf "%d COPIES %d@." n_done (List.length copies);

        (* Gather (hash,index) of the copy targets in pdst *)
        let tbl (* hash |-> index on vc1 *) = Hashtbl.create 1023 in
        let visit c segs =
          (* XXX go_up: true does not work because the internal access_gen moves the cursor elsewhere
             we move to the top at the end anyway
          *)
          Deep.deep ~go_up:false ~create_subtrees:false
            c
            segs
            (fun c seg ->
               (* should have Cursor.get_node? *)
               Cursor.access_gen c seg >>? function
               | Reached (c, _) ->
                   (* This traverse all the nodes and register the hashes.
                      XXX No point of rebuilding the tree.
                      XXX This can be huge!
                   *)
                   let node n =
                     let n, h = Node_hash.compute dctxt.hash (Node_storage.read_hash dctxt) n in
                     let v = Node_storage.view dctxt n in
                     if Hashtbl.mem tbl h then `Return (n, ())
                     else begin
                       let i = from_Some @@ Node_type.index n in
                       Hashtbl.add tbl h i;
                       `Continue v
                     end
                   in
                   let view = Node_type.Mapper.default_mkview in
                   let Cursor.Cursor (_, n, _, _) = c in
                   let n, () = Node_type.Mapper.map ~node ~view n in
                   let Cursor.Cursor (trail, _, ctxt, info) = c in
                   Ok (Cursor._Cursor (trail, n, ctxt, info), ())
               | HashOnly _ as e -> Cursor.error_access e
               | _res ->
                   Ok (c, ()) (* not found *)
            ) >|? fun (c, ()) ->
          (Cursor.go_top c, ())
        in
        let (pdst, ()), sec =
          with_time @@ fun () ->
          from_Ok @@ Result.fold_leftM (fun (c,()) path ->
              match visit c (Path.to_segments path) with
              | Ok res -> Ok res
              | Error _e ->
                  (* hmmm *)
                  Ok (c,())) (pdst,()) copies
        in

        (* Insert the copied nodes in pdst to the dctxt.node_cache *)
        let* () =
          if List.length copies <> 0 then begin
            let* () =
              Lwt_fmt.eprintf "%d COPIES %d HASHES %d visited in %a@."
                n_done
                (List.length copies)
                (Hashtbl.length tbl)
                Mtime.Span.pp sec
            in
            let (), sec = with_time @@ fun () ->
              Hashtbl.iter (fun h i ->
                  (* This gives score 256, which should be too high *)
                  Node_cache.add dctxt.node_cache h i ) tbl;
            in
            let* () =
              Lwt_fmt.eprintf "%d COPIES %d HASHES %d added in %a@."
                n_done
                (List.length copies)
                (Hashtbl.length tbl)
                Mtime.Span.pp sec
            in
            Lwt_fmt.eprintf "%d vc1: %a  vc2: %a@."
              n_done Context.pp_cache_for_debug (Vc.context vc1) Context.pp_cache_for_debug (Vc.context vc2)
          end else Lwt.return_unit
        in

        assert (tr = Cursor._Top && tr' = Cursor._Top);
        assert (ctxt1 == ctxt1');
        let diffs, sec = with_time @@ fun () -> Diff.diff ctxt1 pn n in

        let* () = Lwt_fmt.eprintf "%d DIFFS %d in %a@." n_done (List.length diffs) Mtime.Span.pp sec in

        let* res =
          with_time_lwt @@ fun () ->
          Result_lwt.fold_leftM (fun c diff ->
(*
            (* XXX resetting may load the nodes fully without sharing, which may cost lots of memory *)
            let diff, sec = with_time @@ fun () -> Diff.reset_for_another_context ctxt1 diff in
*)
            let diff, sec = with_time @@ fun () -> Diff.reset_for_another_context' ~src:ctxt1 ~dst:dctxt diff in
            let+ () =
              if Mtime.Span.to_s sec > 1.0 then
                Lwt_fmt.eprintf "%d DIFF reset took long time: %a@." n_done Mtime.Span.pp sec
              else Lwt.return_unit
            in
            Diff.apply c diff) pdst diffs
      in
      match res with
      | Error e, _ -> Lwt.return (Error e)
      | Ok cur2, sec ->
          let* () =
            Lwt_fmt.eprintf "%d DIFFS %d applied in %a@."
              n_done (List.length diffs) Mtime.Span.pp sec
          in

          let*=? cur2, _hp, _commit =
            Vc.commit
              ~allow_missing_parent: true
              vc2
              ~parent
              ~hash_override: (Some c1.Commit.hash)
              cur2
          in
          let _, nhsrc = Cursor.compute_hash src in
          let _, nhdst = Cursor.compute_hash cur2 in
          if nhsrc <> nhdst then begin
            Log.fatal "COPY IS BUGGY";
(* No point for huge trees
              let psrc = Cursor_storage.read_fully ~reset_index:false psrc in
              let src = Cursor_storage.read_fully ~reset_index:false src in
              let cur2 = Cursor_storage.read_fully ~reset_index:false cur2 in
              Debug.save_cursor_to_dot "src1.dot" psrc;
              Debug.save_cursor_to_dot "src2.dot" src;
              Debug.save_cursor_to_dot "copy.dot" cur2;
              Log.fatal "DIFF";
              List.iter (Log.fatal "%a" Diff.pp) diff;
              Format.eprintf "ODIFF@.";
              List.iter (Log.fatal "%a" Diff.pp) odiff;
*)
            assert (nhsrc = nhdst);
          end;

          (* Performance check *)
          let Cursor.Cursor (_, srcn, _, _) = src in
          let srci = from_Some @@ Node_type.index srcn in
          let Cursor.Cursor (_, cur2n, _, _) = cur2 in
          let cur2i = from_Some @@ Node_type.index cur2n in
          Log.notice "%d IDXs %a %a" n_done Index.pp srci Index.pp cur2i;
          Result_lwt.return (n_done + 1, src, cur2)
    ) (0, Vc.empty vc1, Vc.empty vc2) cs
  in
  n_done