WIP: directory targets with empty subdirs

Signed-off-by: Ambre Austen Suhamy <[email protected]>

boot/libs.ml

@@ -1,4 +1,4 @@
-let external_libraries = [ "unix"; "threads" ]
+let external_libraries = [ "threads.posix" ]
 
 let local_libraries =
   [ ("otherlibs/ordering", Some "Ordering", false, None)

src/dune_cache/local.ml

@@ -79,11 +79,20 @@ module Artifacts = struct
     (artifacts : Digest.t Targets.Produced.t)
     =
     let entries =
-      Targets.Produced.foldi artifacts ~init:[] ~f:(fun target file_digest entries ->
-        let entry : Metadata_entry.t =
-          { file_path = Path.Local.to_string target; file_digest }
-        in
-        entry :: entries)
+      Targets.Produced.foldi
+        artifacts
+        ~init:[]
+        ~f:(fun target ~is_file file_digest entries ->
+          (if Targets.Produced.debug_out
+           then
+             let open Pp.O in
+             Pp.to_fmt
+               Format.std_formatter
+               (Pp.paragraphf "[StoreMeta %S]" (Path.Local.to_string target) ++ Pp.space));
+          let entry : Metadata_entry.t =
+            { file_path = Path.Local.to_string target; file_digest; is_file }
+          in
+          entry :: entries)
       |> List.rev
     in
     Metadata_file.store ~mode { metadata; entries } ~rule_digest
@@ -103,12 +112,29 @@ module Artifacts = struct
     Result.try_with (fun () ->
       (* CR-someday rleshchinskiy: We recreate the directory structure here but it might be
          simpler to just use file digests instead of file names and no subdirectories. *)
-      Path.Local.Map.iteri targets.dirs ~f:(fun path _ ->
-        Path.mkdir_p (Path.append_local temp_dir path));
-      Targets.Produced.iteri targets ~f:(fun path _ ->
-        let path_in_build_dir = Path.build (Path.Build.append_local targets.root path) in
-        let path_in_temp_dir = Path.append_local temp_dir path in
-        portable_hardlink_or_copy ~src:path_in_build_dir ~dst:path_in_temp_dir))
+      (* The comment above seems outdated wrt. 'no subdirectories'... *)
+      Targets.Produced.iteri
+        targets
+        ~d:(fun dir _ ->
+          (if Targets.Produced.debug_out
+           then
+             let open Pp.O in
+             Pp.to_fmt
+               Format.std_formatter
+               (Pp.paragraphf "[Store_dir %S]" (Path.Local.to_string dir) ++ Pp.space));
+          Path.mkdir_p (Path.append_local temp_dir dir))
+        ~f:(fun file _ ->
+          let path_in_build_dir =
+            Path.build (Path.Build.append_local targets.root file)
+          in
+          let path_in_temp_dir = Path.append_local temp_dir file in
+          (if Targets.Produced.debug_out
+           then
+             let open Pp.O in
+             Pp.to_fmt
+               Format.std_formatter
+               (Pp.paragraphf "[Store_file: %S]" (Path.Local.to_string file) ++ Pp.space));
+          portable_hardlink_or_copy ~src:path_in_build_dir ~dst:path_in_temp_dir))
   ;;
 
   (* Step II of [store_skipping_metadata].
@@ -118,10 +144,18 @@ module Artifacts = struct
     : Digest.t Targets.Produced.t Or_exn.t Fiber.t
     =
     let open Fiber.O in
-    Fiber.collect_errors (fun () ->
-      Targets.Produced.parallel_map targets ~f:(fun path { Target.executable } ->
-        let file = Path.append_local temp_dir path in
-        compute_digest ~executable file))
+    let fff path { Target.executable } =
+      let file = Path.append_local temp_dir path in
+      (if Targets.Produced.debug_out
+       then
+         let open Pp.O in
+         Pp.to_fmt
+           Format.std_formatter
+           (Pp.paragraphf "[CompDigests %S]" (Path.Local.to_string path) ++ Pp.space));
+      compute_digest ~executable file
+    in
+    (* FIXME: nothing special here? *)
+    Fiber.collect_errors (fun () -> Targets.Produced.parallel_map targets ~f:fff ~d:fff)
     >>| Result.map_error ~f:(function
       | exn :: _ -> exn.Exn_with_backtrace.exn
       | [] -> assert false)
@@ -132,9 +166,18 @@ module Artifacts = struct
     Targets.Produced.foldi
       artifacts
       ~init:Store_result.empty
-      ~f:(fun target digest results ->
+      ~f:(fun target ~is_file digest results ->
+        (* FIXME: really? *)
+        let _ignored = is_file in
         let path_in_temp_dir = Path.append_local temp_dir target in
         let path_in_cache = file_path ~file_digest:digest in
+        (if Targets.Produced.debug_out
+         then
+           let open Pp.O in
+           Pp.to_fmt
+             Format.std_formatter
+             (Pp.paragraphf "[Store_to_cache %S]" (Path.Local.to_string target)
+              ++ Pp.space));
         let store_using_hardlinks () =
           match
             Dune_cache_storage.Util.Optimistically.link
@@ -281,10 +324,7 @@ module Artifacts = struct
          | Copy -> copy ~src ~dst);
         Unwind.push unwind (fun () -> Path.Build.unlink_no_err target)
       in
-      try
-        Path.Local.Map.iteri artifacts.dirs ~f:(fun dir _ -> mk_dir dir);
-        Targets.Produced.iteri artifacts ~f:mk_file
-      with
+      try Targets.Produced.iteri artifacts ~f:mk_file ~d:(fun dir _ -> mk_dir dir) with
       | exn ->
         Unwind.unwind unwind;
         reraise exn
@@ -296,8 +336,14 @@ module Artifacts = struct
       let artifacts =
         Path.Local.Map.of_list_map_exn
           entries
-          ~f:(fun { Metadata_entry.file_path; file_digest } ->
-            Path.Local.of_string file_path, file_digest)
+          ~f:(fun { Metadata_entry.file_path; file_digest; is_file } ->
+            (if Targets.Produced.debug_out
+             then
+               let open Pp.O in
+               Pp.to_fmt
+                 Format.std_formatter
+                 (Pp.paragraphf "[Restore: %S]" file_path ++ Pp.space));
+            Path.Local.of_string file_path, (file_digest, is_file))
         |> Targets.Produced.of_files target_dir
       in
       try

src/dune_cache/shared.ml

@@ -121,17 +121,24 @@ struct
         ]
     in
     let update_cached_digests ~targets_and_digests =
-      Targets.Produced.iteri targets_and_digests ~f:(fun path digest ->
+      Targets.Produced.iter_files targets_and_digests ~f:(fun path digest ->
         Cached_digest.set (Path.Build.append_local targets_and_digests.root path) digest)
     in
     match
       Targets.Produced.map_with_errors
         produced_targets
         ~all_errors:false
         ~f:(fun target () ->
+          (* All of this monad boilerplate seems unnecessary since we don't care about errors... *)
           match Local.Target.create target with
           | Some t -> Ok t
           | None -> Error ())
+        ~d:(fun target _meta ->
+          (* FIXME: maybe this vvvv create is only for files not dirs.
+             Also why ignore if meta is set or not? *)
+          match Local.Target.create target with
+          | Some t -> Some (Ok t)
+          | None -> Some (Error ()))
     with
     | Error _ -> Fiber.return None
     | Ok targets ->
@@ -194,6 +201,9 @@ struct
         produced_targets
         ~all_errors:true
         ~f:(fun target () -> compute_digest target)
+        ~d:(fun target meta ->
+          assert (Option.is_none meta);
+          Some (compute_digest target))
     with
     | Ok result -> result
     | Error errors ->

src/dune_cache_storage/dune_cache_storage.ml

@@ -217,21 +217,28 @@ module Artifacts = struct
     type t =
       { file_path : string
       ; file_digest : Digest.t
+      ; is_file : bool
       }
 
     let equal x y =
-      Digest.equal x.file_digest y.file_digest && String.equal x.file_path y.file_path
+      Digest.equal x.file_digest y.file_digest
+      && String.equal x.file_path y.file_path
+      && x.is_file = y.is_file
     ;;
 
-    let to_sexp { file_path; file_digest } =
-      Sexp.List [ Atom file_path; Atom (Digest.to_string file_digest) ]
+    let to_sexp { file_path; file_digest; is_file } =
+      Sexp.List
+        [ Atom file_path
+        ; Atom (Digest.to_string file_digest)
+        ; Atom (Bool.to_string is_file)
+        ]
     ;;
 
     let of_sexp = function
-      | Sexp.List [ Atom file_path; Atom file_digest ] ->
-        (match Digest.from_hex file_digest with
-         | Some file_digest -> Ok { file_path; file_digest }
-         | None ->
+      | Sexp.List [ Atom file_path; Atom file_digest; Atom is_file ] ->
+        (match Digest.from_hex file_digest, Bool.of_string is_file with
+         | Some file_digest, Some is_file -> Ok { file_path; file_digest; is_file }
+         | None, _ | _, None ->
            Error
              (Failure
                 (sprintf

src/dune_cache_storage/dune_cache_storage.mli

@@ -70,6 +70,8 @@ module Artifacts : sig
     type t =
       { file_path : string (** Can have more than one component for directory targets *)
       ; file_digest : Digest.t
+      ; is_file : bool
+      (* We need to be able to recreate them just from the metadata so we need to know the type *)
       }
   end
 

src/dune_engine/build_system.ml

@@ -955,6 +955,7 @@ end = struct
     | Build_under_directory_target { directory_target_ancestor = _ } ->
       (* To evaluate a glob in a generated directory, we have no choice but to build the
          whole directory and examine its contents. *)
+      (* But not the subdirectories? *)
       let+ path_map = build_dir dir in
       (match Targets.Produced.find_dir path_map (Path.as_in_build_dir_exn dir) with
        | Some files_and_digests ->

src/dune_engine/rule_cache.ml

@@ -138,9 +138,14 @@ module Workspace_local = struct
     match Targets.Produced.of_validated targets with
     | Error error -> Miss (Error_while_collecting_directory_targets error)
     | Ok targets ->
+      let f target _ = Cached_digest.build_file ~allow_dirs:true target in
       (match
-         Targets.Produced.map_with_errors targets ~all_errors:false ~f:(fun target () ->
-           Cached_digest.build_file ~allow_dirs:true target)
+         Targets.Produced.map_with_errors targets ~all_errors:false ~f ~d:(fun t e ->
+           match e with
+           (* FIXME: this is a useless distinction.
+              However the important thing might be that [Cached_digest.build_file] is just for files? *)
+           | None -> Some (f t None)
+           | Some meta -> Some (f t meta))
        with
        | Ok produced_targets -> Dune_cache.Hit_or_miss.Hit produced_targets
        | Error _ -> Miss Targets_missing)

src/dune_engine/target_promotion.ml

@@ -184,7 +184,16 @@ let promote ~(targets : _ Targets.Produced.t) ~(promote : Rule.Promote.t) ~promo
   in
   (* Here we know that the promotion directory exists but we may need to create
      additional subdirectories for [targets.dirs]. *)
-  Path.Local.Map.iteri targets.dirs ~f:(fun dir (_ : Digest.t Filename.Map.t) ->
+  Targets.Produced.iter_dirs targets ~f:(fun dir _ ->
+    (if Targets.Produced.debug_out
+     then
+       let open Pp.O in
+       Pp.to_fmt
+         Format.std_formatter
+         (Pp.paragraphf
+            "[Promote: %S]"
+            (Path.Build.to_string (Path.Build.append_local targets.root dir))
+          ++ Pp.space));
     create_directory_if_needed ~dir:(Path.Build.append_local targets.root dir));
   let promote_until_clean =
     match promote.lifetime with
@@ -209,7 +218,7 @@ let promote ~(targets : _ Targets.Produced.t) ~(promote : Rule.Promote.t) ~promo
   in
   (* There can be some files or directories left over from earlier builds, so we
      need to remove them from [targets.dirs]. *)
-  let remove_stale_files_and_subdirectories ~dir ~expected_filenames =
+  let remove_stale_files_and_subdirectories ~dir =
     (* CR-someday rleshchinskiy: This can probably be made more efficient by relocating
        root once. *)
     let build_dir = Path.Build.append_local targets.root dir in
@@ -224,17 +233,16 @@ let promote ~(targets : _ Targets.Produced.t) ~(promote : Rule.Promote.t) ~promo
     | Error unix_error -> directory_target_error ~unix_error ~dst_dir []
     | Ok dir_contents ->
       Fs_cache.Dir_contents.iter dir_contents ~f:(function
-        | filename, S_REG ->
-          if not (String.Map.mem expected_filenames filename)
-          then Path.unlink_no_err (Path.relative dst_dir filename)
-        | dirname, S_DIR ->
-          let src_dir = Path.Local.relative dir dirname in
-          if not (Path.Local.Map.mem targets.dirs src_dir)
-          then Path.rm_rf (Path.relative dst_dir dirname)
+        | file_name, S_REG ->
+          if not (Targets.Produced.mem targets (Path.Build.relative build_dir file_name))
+          then Path.unlink_no_err (Path.relative dst_dir file_name)
+        | dir_name, S_DIR ->
+          if not
+               (Targets.Produced.mem_dir targets (Path.Build.relative build_dir dir_name))
+          then Path.rm_rf (Path.relative dst_dir dir_name)
         | name, _kind -> Path.unlink_no_err (Path.relative dst_dir name))
   in
   Fiber.sequential_iter_seq
-    (Path.Local.Map.to_seq targets.dirs)
-    ~f:(fun (dir, filenames) ->
-      remove_stale_files_and_subdirectories ~dir ~expected_filenames:filenames)
+    (Targets.Produced.all_dirs_seq targets)
+    ~f:(fun (dir, _contents) -> remove_stale_files_and_subdirectories ~dir)
 ;;