WIP: directory targets with empty subdirs

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

bin/exec.ml

@@ -223,15 +223,15 @@ let get_path_and_build_if_necessary sctx ~no_rebuild ~dir ~prog =
      | Ok p -> build_prog ~no_rebuild ~prog p)
   | Relative_to_current_dir ->
     let path = Path.relative_to_source_in_build_or_external ~dir prog in
-    Build_system.file_exists path
+    Build_system.path_exists path
     >>= (function
            | true -> Memo.return (Some path)
            | false ->
              if not (Filename.check_suffix prog ".exe")
              then Memo.return None
              else (
                let path = Path.extend_basename path ~suffix:".exe" in
-               Build_system.file_exists path
+               Build_system.path_exists path
                >>| function
                | true -> Some path
                | false -> None))

bin/ocaml/utop.ml

@@ -33,7 +33,7 @@ let term =
           let utop_target = Filename.concat dir Utop.utop_exe in
           Path.build (Path.Build.relative (Context.build_dir context) utop_target)
         in
-        Build_system.file_exists utop_target
+        Build_system.path_exists utop_target
         >>= function
         | false ->
           User_error.raise

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,22 @@ module Artifacts = struct
     : Digest.t Targets.Produced.t Or_exn.t Fiber.t
     =
     let open Fiber.O in
+    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:(fun path { Target.executable } ->
-        let file = Path.append_local temp_dir path in
-        compute_digest ~executable file))
+      Targets.Produced.parallel_map targets ~f:fff ~d:(fun path ->
+          function
+          | None -> Fiber.return None
+          | Some exe -> Fiber.map ~f:Option.some (fff path exe)))
     >>| Result.map_error ~f:(function
       | exn :: _ -> exn.Exn_with_backtrace.exn
       | [] -> assert false)
@@ -132,9 +170,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 +328,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 +340,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,33 @@ struct
         ]
     in
     let update_cached_digests ~targets_and_digests =
-      Targets.Produced.iteri targets_and_digests ~f:(fun path digest ->
-        Cached_digest.set (Path.Build.append_local targets_and_digests.root path) digest)
+      Targets.Produced.iteri
+        targets_and_digests
+        ~f:(fun path digest ->
+          Cached_digest.set (Path.Build.append_local targets_and_digests.root path) digest)
+        ~d:(fun path ->
+          function
+          | None -> ()
+          | Some 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 -> Ok (Some t)
+          | None -> Error ())
     with
     | Error _ -> Fiber.return None
     | Ok targets ->
@@ -194,6 +210,10 @@ struct
         produced_targets
         ~all_errors:true
         ~f:(fun target () -> compute_digest target)
+        ~d:(fun _target meta ->
+          (* FIXME: don't write code tired, I forgot why we can make that assertion... *)
+          assert (Option.is_none meta);
+          Ok None (* Result.map ~f:Option.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

@@ -160,14 +160,12 @@ and Exported : sig
 
   type target_kind =
     | File_target
-    | Dir_target of { targets : Digest.t Targets.Produced.t }
+    | Dir_target of Digest.t Targets.Produced.t
 
   (* The below two definitions are useless, but if we remove them we get an
      "Undefined_recursive_module" exception. *)
 
-  val build_file_memo : (Path.t, Digest.t * target_kind) Memo.Table.t Lazy.t
-  [@@warning "-32"]
-
+  val build_memo : (Path.t, Digest.t * target_kind) Memo.Table.t Lazy.t [@@warning "-32"]
   val build_alias_memo : (Alias.t, Dep.Fact.Files.t) Memo.Table.t [@@warning "-32"]
   val dep_on_alias_definition : Rules.Dir_rules.Alias_spec.item -> unit Action_builder.t
 end = struct
@@ -206,6 +204,7 @@ end = struct
       (* Fact: alias [a] expands to the set of file-digest pairs [digests] *)
       Dep.Fact.alias a digests
     | File f ->
+      (* Not necessarily a file. Can also be a directory... *)
       let+ digest = build_file f in
       (* Fact: file [f] has digest [digest] *)
       Dep.Fact.file f digest
@@ -820,22 +819,19 @@ end = struct
   type target_kind =
     | File_target
     | Dir_target of
-        { targets :
-            (* All targets of the rule which produced the directory target in question. *)
-            Digest.t Targets.Produced.t
-        }
+        (* All targets of the rule which produced the directory target in question. *)
+        Digest.t Targets.Produced.t
 
   let target_kind_equal a b =
     match a, b with
     | File_target, File_target -> true
-    | Dir_target { targets = a }, Dir_target { targets = b } ->
-      Targets.Produced.equal a b ~equal:Digest.equal
+    | Dir_target t1, Dir_target t2 -> Targets.Produced.equal t1 t2 ~equal:Digest.equal
     | File_target, Dir_target _ | Dir_target _, File_target -> false
   ;;
 
   (* A rule can have multiple targets but calls to [execute_rule] are memoized,
      so the rule will be executed only once. *)
-  let build_file_impl path =
+  let build_impl path =
     Load_rules.get_rule_or_source path
     >>= function
     | Source digest -> Memo.return (digest, File_target)
@@ -856,9 +852,12 @@ end = struct
             rleshchinskiy: Is this digest ever used? [build_dir] discards it and do we
             (or should we) ever use [build_file] to build directories? Perhaps this could
             be split in two memo tables, one for files and one for directories. *)
+         (* ElectreAAS: Tentative answer to above comments: a lot of functions are called
+            [build_file] or [create_file] even though they also handle directories.
+            Also yes this digest is used by [Exported.build_dep] defined above. *)
          (match Cached_digest.build_file ~allow_dirs:true path with
-          | Ok digest -> digest, Dir_target { targets }
-          (* Must be a directory target *)
+          (* Must be a directory target. *)
+          | Ok digest -> digest, Dir_target targets
           | Error _ ->
             (* CR-someday amokhov: The most important reason we end up here is
                [No_such_file]. I think some of the outcomes above are impossible
@@ -980,7 +979,7 @@ end = struct
 
   let eval_pred = Memo.exec eval_pred_memo
 
-  let build_file_memo =
+  let build_memo =
     lazy
       (let cutoff =
          match Dune_config.Config.(get cutoffs_that_reduce_concurrency_in_watch_mode) with
@@ -992,15 +991,15 @@ end = struct
          ~store:(module Path.Table)
          ~input:(module Path)
          ?cutoff
-         build_file_impl)
+         build_impl)
   ;;
 
-  let build_file path = Memo.exec (Lazy.force build_file_memo) path >>| fst
+  let build_file path = Memo.exec (Lazy.force build_memo) path >>| fst
 
   let build_dir path =
-    let+ (_ : Digest.t), kind = Memo.exec (Lazy.force build_file_memo) path in
+    let+ (_ : Digest.t), kind = Memo.exec (Lazy.force build_memo) path in
     match kind with
-    | Dir_target { targets } -> targets
+    | Dir_target targets -> targets
     | File_target ->
       Code_error.raise "build_dir called on a file target" [ "path", Path.to_dyn path ]
   ;;
@@ -1050,7 +1049,7 @@ include Exported
    when executing the very same [Action_builder.t] with [Action_builder.exec] --
    the results of both [Action_builder.static_deps] and [Action_builder.exec]
    are cached. *)
-let file_exists fn =
+let path_exists fn =
   Load_rules.load_dir ~dir:(Path.parent_exn fn)
   >>= function
   | Source { filenames } | External { filenames } ->
@@ -1060,7 +1059,7 @@ let file_exists fn =
       (Path.Build.Map.mem rules_here.by_file_targets (Path.as_in_build_dir_exn fn))
   | Build_under_directory_target { directory_target_ancestor } ->
     let+ path_map = build_dir (Path.build directory_target_ancestor) in
-    Targets.Produced.mem path_map (Path.as_in_build_dir_exn fn)
+    Targets.Produced.mem_dir path_map (Path.as_in_build_dir_exn fn)
 ;;
 
 let files_of ~dir =
@@ -1157,7 +1156,12 @@ let run_exn f =
 ;;
 
 let build_file p =
-  let+ (_ : Digest.t) = build_file p in
+  let+ _digest = build_file p in
+  ()
+;;
+
+let build_dir p =
+  let+ _targets = build_dir p in
   ()
 ;;