diff --git a/boot/libs.ml b/boot/libs.ml
index 6faacb217ec..b6aeed5a6d5 100644
--- a/boot/libs.ml
+++ b/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)
diff --git a/src/dune_cache/local.ml b/src/dune_cache/local.ml
index 4a38e900201..4ba3b47bf96 100644
--- a/src/dune_cache/local.ml
+++ b/src/dune_cache/local.ml
@@ -80,6 +80,12 @@ module Artifacts = struct
     =
     let entries =
       Targets.Produced.foldi artifacts ~init:[] ~f:(fun target 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 }
         in
@@ -103,12 +109,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].
@@ -121,6 +144,12 @@ module Artifacts = struct
     Fiber.collect_errors (fun () ->
       Targets.Produced.parallel_map targets ~f:(fun 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))
     >>| Result.map_error ~f:(function
       | exn :: _ -> exn.Exn_with_backtrace.exn
@@ -135,6 +164,13 @@ module Artifacts = struct
       ~f:(fun target digest results ->
         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 +317,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
@@ -297,6 +330,12 @@ module Artifacts = struct
         Path.Local.Map.of_list_map_exn
           entries
           ~f:(fun { Metadata_entry.file_path; file_digest } ->
+            (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)
         |> Targets.Produced.of_files target_dir
       in
diff --git a/src/dune_cache/shared.ml b/src/dune_cache/shared.ml
index 21577b83efb..b98e2c3e14e 100644
--- a/src/dune_cache/shared.ml
+++ b/src/dune_cache/shared.ml
@@ -121,7 +121,7 @@ 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
diff --git a/src/dune_engine/build_system.ml b/src/dune_engine/build_system.ml
index 7cb8e92c139..f8205ea6bb6 100644
--- a/src/dune_engine/build_system.ml
+++ b/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 ->
diff --git a/src/dune_engine/target_promotion.ml b/src/dune_engine/target_promotion.ml
index ebe09cbaa2a..3f86ec87fae 100644
--- a/src/dune_engine/target_promotion.ml
+++ b/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)
 ;;
diff --git a/src/dune_targets/dune_targets.ml b/src/dune_targets/dune_targets.ml
index 4fd1cf81fbc..19b32a9e3d6 100644
--- a/src/dune_targets/dune_targets.ml
+++ b/src/dune_targets/dune_targets.ml
@@ -63,6 +63,18 @@ module Validated = struct
     ; dirs : Filename.Set.t
     }
 
+  let pp { root; files; dirs } =
+    let open Pp.O in
+    Pp.hovbox
+      (Pp.textf "Validated: root=%S, files=[" (Path.Build.to_string root)
+       ++ Pp.concat
+            ~sep:(Pp.text "; ")
+            (Filename.Set.to_list_map files ~f:(Pp.textf "%S"))
+       ++ Pp.text "], dirs=["
+       ++ Pp.concat ~sep:(Pp.text "; ") (Filename.Set.to_list_map dirs ~f:(Pp.textf "%S"))
+       ++ Pp.char ']')
+  ;;
+
   let iter { root; files; dirs } ~file ~dir =
     Filename.Set.iter files ~f:(fun fn -> file (Path.Build.relative root fn));
     Filename.Set.iter dirs ~f:(fun dn -> dir (Path.Build.relative root dn))
@@ -162,12 +174,56 @@ module Produced = struct
   (* CR-someday amokhov: A hierarchical representation of the produced file
      trees may be better. It would allow for hierarchical traversals and reduce
      the number of internal invariants. *)
+
+  (** All file names and directory names are relative to the root (['a t]). *)
+  type 'a dir_contents =
+    { files : 'a Filename.Map.t (* mapping file name -> 'a *)
+    ; subdirs :
+        'a dir_contents Filename.Map.t (* mapping directory name -> 'a dir_contents *)
+    }
+
+  let is_empty_dir_conts { files; subdirs } =
+    Filename.Map.is_empty files && Filename.Map.is_empty subdirs
+  ;;
+
+  let rec pp_dir_conts ?(payload_printer = fun _ -> Pp.char '?') contents =
+    if is_empty_dir_conts contents
+    then Pp.text "<empty dir_contents>"
+    else (
+      let { files; subdirs } = contents in
+      let open Pp.O in
+      Pp.text "{ "
+      ++ Pp.hovbox
+           (Pp.text "Files: ("
+            ++ Pp.box
+                 (Pp.concat
+                    ~sep:(Pp.text ", ")
+                    (Filename.Map.to_list_map files ~f:(fun name payload ->
+                       Pp.textf "%S -> " name ++ payload_printer payload)))
+            ++ Pp.text ");"
+            ++ Pp.space
+            ++ Pp.hovbox
+                 (Pp.text "Subdirs: ("
+                  ++ Pp.concat
+                       ~sep:(Pp.text ", ")
+                       (Filename.Map.to_list_map subdirs ~f:(fun name sub ->
+                          Pp.textf "%S -> " name ++ pp_dir_conts ~payload_printer sub))
+                  ++ Pp.text ")"))
+      ++ Pp.char '}')
+  ;;
+
   type 'a t =
     { root : Path.Build.t
-    ; files : 'a Filename.Map.t
-    ; dirs : 'a Filename.Map.t Path.Local.Map.t
+    ; contents : 'a dir_contents
     }
 
+  let pp ?(payload_printer = fun _ -> Pp.char '?') { root; contents } =
+    let open Pp.O in
+    Pp.hovbox
+      (Pp.textf "root=%S, contents=" (Path.Build.to_string root)
+       ++ pp_dir_conts ~payload_printer contents)
+  ;;
+
   module Error = struct
     type t =
       | Missing_dir of Path.Build.t
@@ -215,181 +271,416 @@ module Produced = struct
     ;;
   end
 
-  let of_validated =
-    (* The call sites ensure that [dir = Path.Build.append_local validated.root local]. *)
-    let rec collect (dir : Path.Build.t) (local : Path.Local.t)
-      : (unit Filename.Map.t Path.Local.Map.t, Error.t) result
-      =
-      match Path.readdir_unsorted_with_kinds (Path.build dir) with
-      | Error (Unix.ENOENT, _, _) -> Error (Missing_dir dir)
-      | Error e -> Error (Unreadable_dir (dir, e))
-      | Ok dir_contents ->
-        let open Result.O in
-        let+ filenames, dirs =
-          Result.List.fold_left
-            dir_contents
-            ~init:(Filename.Map.empty, Path.Local.Map.empty)
-            ~f:(fun (acc_filenames, acc_dirs) (filename, kind) ->
-              match (kind : File_kind.t) with
-              (* CR-someday rleshchinskiy: Make semantics of symlinks more consistent. *)
-              | S_LNK | S_REG ->
-                Ok (Filename.Map.add_exn acc_filenames filename (), acc_dirs)
-              | S_DIR ->
-                let+ dir =
-                  collect
-                    (Path.Build.relative dir filename)
-                    (Path.Local.relative local filename)
-                in
-                acc_filenames, Path.Local.Map.union_exn acc_dirs dir
-              | _ -> Error (Unsupported_file (Path.Build.relative dir filename, kind)))
-        in
-        if not (Filename.Map.is_empty filenames)
-        then Path.Local.Map.add_exn dirs local filenames
-        else dirs
+  let debug_create = false
+  let debug_consume = false
+  let debug_out = false
+
+  let rec merge_contents c1 c2 =
+    let files =
+      Filename.Map.union c1.files c2.files ~f:(fun _ p1 p2 ->
+        assert (Poly.equal p1 p2);
+        Some p1)
     in
-    let directory root dirname =
-      let open Result.O in
-      let dir = Path.Build.relative root dirname in
-      let* files = collect dir (Path.Local.of_string dirname) in
-      if Path.Local.Map.is_empty files then Error (Empty_dir dir) else Ok files
+    let subdirs =
+      Filename.Map.union c1.subdirs c2.subdirs ~f:(fun _ s1 s2 ->
+        Some (merge_contents s1 s2))
     in
-    fun (validated : Validated.t) ->
-      match
-        Filename.Set.to_list validated.dirs
-        |> Result.List.map ~f:(directory validated.root)
-      with
-      | Error _ as error -> error
-      | Ok dirs ->
-        let files =
-          (* CR-someday rleshchinskiy: Check if the files actually exist here. Currently,
-             we check this here for directory targets but for files, the check is done by
-             the cache. *)
-          Filename.Set.to_map validated.files ~f:(fun _ -> ())
+    { files; subdirs }
+  ;;
+
+  let merge t1 t2 =
+    if not (Path.Build.equal t1.root t2.root)
+    then Code_error.raise "Can't merge two targets with different roots" [];
+    let contents = merge_contents t1.contents t2.contents in
+    { root = t1.root; contents }
+  ;;
+
+  (** The call sites ensure that [dir = Path.Build.append_local validated.root local].
+      No need for [local] actually... *)
+  let rec contents_of_dir ~file_f (dir : Path.Build.t) : ('a dir_contents, Error.t) result
+    =
+    let open Result.O in
+    let init = { files = Filename.Map.empty; subdirs = Filename.Map.empty } in
+    match Path.readdir_unsorted_with_kinds (Path.build dir) with
+    | Error (Unix.ENOENT, _, _) -> Error (Missing_dir dir)
+    | Error e -> Error (Unreadable_dir (dir, e))
+    | Ok dir_contents ->
+      let+ results =
+        Result.List.fold_left
+          dir_contents
+          ~init
+          ~f:(fun { files; subdirs } (name, kind) ->
+            match (kind : File_kind.t) with
+            | S_LNK | S_REG ->
+              let files =
+                match file_f (Path.Local.relative (Path.Build.local dir) name) with
+                | Some payload -> Filename.Map.add_exn files name payload
+                | None -> files
+              in
+              Ok { files; subdirs }
+            | S_DIR ->
+              let+ subdirs_contents =
+                contents_of_dir ~file_f (Path.Build.relative dir name)
+              in
+              { files; subdirs = Filename.Map.add_exn subdirs name subdirs_contents }
+            | _ -> Error (Unsupported_file (Path.Build.relative dir name, kind)))
+      in
+      (if debug_create
+       then
+         let open Pp.O in
+         Pp.to_fmt
+           Format.std_formatter
+           (Pp.paragraphf "In contents_of_dir %S =>" (Path.Build.to_string dir)
+            ++ pp_dir_conts results
+            ++ Pp.space));
+      results
+  ;;
+
+  let of_validated (validated : Validated.t) =
+    let open Result.O in
+    (* We assume here that [dir_name] is either a child of [root], or that we're ok with having [root/a/b] but not [root/a]. *)
+    let aggregate_dir { root; contents = { files; subdirs } } dir_name =
+      let dir = Path.Build.relative root dir_name in
+      let* new_contents = contents_of_dir ~file_f:(fun _ -> Some ()) dir in
+      if Filename.Map.is_empty new_contents.files
+         && Filename.Map.is_empty new_contents.subdirs
+      then Error (Empty_dir dir)
+      else (
+        let contents =
+          { files; subdirs = Filename.Map.add_exn subdirs dir_name new_contents }
         in
-        (* The [union_exn] below can't raise because each map in [dirs] contains
-           unique keys, which are paths rooted at the corresponding [dir]s. *)
-        let dirs =
-          List.fold_left dirs ~init:Path.Local.Map.empty ~f:Path.Local.Map.union_exn
+        Ok { root; contents })
+    in
+    let rooted_files = Filename.Set.to_map validated.files ~f:(Fun.const ()) in
+    let+ result =
+      Filename.Set.to_list validated.dirs
+      |> Result.List.fold_left
+           ~init:
+             { root = validated.root
+             ; contents = { files = rooted_files; subdirs = Filename.Map.empty }
+             }
+           ~f:aggregate_dir
+    in
+    (if debug_create
+     then
+       let open Pp.O in
+       Pp.to_fmt
+         Format.std_formatter
+         (Pp.hovbox
+            (Pp.paragraph "In of_validated("
+             ++ Pp.cut
+             ++ Validated.pp validated
+             ++ Pp.text ") => "
+             ++ pp ~payload_printer:(fun () -> Pp.text "()") result)
+          ++ Pp.text "\n\n"));
+    result
+  ;;
+
+  (** For each file, not only do we add it to the [t] in proper place, we also add the rest of the contents of the directories. *)
+  let of_files_with_neighbours root (file_list : 'a Path.Local.Map.t) =
+    let init = { files = Filename.Map.empty; subdirs = Filename.Map.empty } in
+    let contents =
+      Path.Local.Map.foldi file_list ~init ~f:(fun file payload contents ->
+        match Path.Local.explode file with
+        | [] -> failwith "TODO"
+        | [ at_root ] ->
+          { contents with files = Filename.Map.add_exn contents.files at_root payload }
+        | parent_dir :: _rest ->
+          let dir = Path.Build.relative root parent_dir in
+          (match
+             contents_of_dir
+               ~file_f:(fun name ->
+                 if debug_create
+                 then
+                   Pp.to_fmt
+                     Format.std_formatter
+                     (Pp.paragraphf "Examining %S...\n" (Path.Local.to_string name));
+                 if Path.Local.equal name file then Some payload else None)
+               dir
+           with
+           | Ok subdirs -> merge_contents subdirs contents
+           | Error _ -> contents))
+    in
+    (if debug_create
+     then
+       let open Pp.O in
+       Pp.to_fmt
+         Format.std_formatter
+         (Pp.text "In of_files_w_n ("
+          ++ Pp.hovbox
+               (Pp.concat
+                  ~sep:(Pp.text ", ")
+                  (Path.Local.Map.to_list_map file_list ~f:(fun file_name _payload ->
+                     Pp.textf "%S -> ?" (Path.Local.to_string file_name))))
+          ++ Pp.text ") => "
+          ++ pp_dir_conts contents));
+    { root; contents }
+  ;;
+
+  let of_files root file_list =
+    let rec aux payload { files; subdirs } = function
+      | [] ->
+        Code_error.raise
+          "I've been hoisted by my own petard! (path.explode)"
+          [ "file_list", Path.Local.Map.to_dyn Dyn.opaque file_list ]
+      | [ final ] -> { files = Filename.Map.add_exn files final payload; subdirs }
+      | parent :: rest ->
+        let subdirs =
+          Filename.Map.update subdirs parent ~f:(fun contents_opt ->
+            Some
+              (aux
+                 payload
+                 (Option.value
+                    contents_opt
+                    ~default:{ files = Filename.Map.empty; subdirs = Filename.Map.empty })
+                 rest))
         in
-        Ok { root = validated.root; files; dirs }
+        { files; subdirs }
+    in
+    let init = { files = Filename.Map.empty; subdirs = Filename.Map.empty } in
+    let contents =
+      Path.Local.Map.foldi file_list ~init ~f:(fun file payload contents ->
+        let parent = Path.Local.parent_exn file in
+        if Path.Local.is_root parent
+        then
+          { contents with
+            files =
+              Filename.Map.add_exn contents.files (Path.Local.to_string file) payload
+          }
+        else aux payload contents (Path.Local.explode file))
+    in
+    (if debug_create
+     then
+       let open Pp.O in
+       Pp.to_fmt
+         Format.std_formatter
+         (Pp.text "In of_files ("
+          ++ Pp.hovbox
+               (Pp.concat
+                  ~sep:(Pp.text ", ")
+                  (Path.Local.Map.to_list_map file_list ~f:(fun file_name _payload ->
+                     Pp.textf "%S -> ?" (Path.Local.to_string file_name))))
+          ++ Pp.text ") => "
+          ++ pp { root; contents }));
+    { root; contents }
   ;;
 
-  let of_files root files =
-    let f file payload t =
-      let parent = Path.Local.parent_exn file in
-      if Path.Local.is_root parent
-      then
-        { t with
-          files = Filename.Map.add_exn t.files (Path.Local.to_string file) payload
-        }
-      else (
-        let fn = Path.Local.basename file in
-        { t with
-          dirs =
-            Path.Local.Map.update t.dirs parent ~f:(fun files ->
-              let files = Option.value files ~default:Filename.Map.empty in
-              Some (Filename.Map.add_exn files fn payload))
-        })
+  let all_files_seq { contents; root = _ } =
+    let rec aux path { files; subdirs } =
+      Seq.append
+        (Filename.Map.to_seq files
+         |> Seq.map ~f:(fun (file_name, payload) ->
+           let file = Path.Local.relative path file_name in
+           (if debug_consume
+            then
+              let open Pp.O in
+              Pp.to_fmt
+                Format.std_formatter
+                (Pp.paragraphf "[FileSeq %S]" (Path.Local.to_string file) ++ Pp.space));
+           file, payload))
+        (Seq.concat
+           (Filename.Map.to_seq subdirs
+            |> Seq.map ~f:(fun (dir_name, subdir_contents) ->
+              aux (Path.Local.relative path dir_name) subdir_contents)))
     in
-    let init = { root; files = Filename.Map.empty; dirs = Path.Local.Map.empty } in
-    Path.Local.Map.foldi files ~init ~f
+    aux Path.Local.root contents
   ;;
 
-  let all_files_seq { root = _; files; dirs } =
-    Seq.append
-      (Filename.Map.to_seq files
-       |> Seq.map ~f:(fun (file, payload) -> Path.Local.of_string file, payload))
-      (Seq.concat
-         (Path.Local.Map.to_seq dirs
-          |> Seq.map ~f:(fun (dir, filenames) ->
-            Filename.Map.to_seq filenames
-            |> Seq.map ~f:(fun (filename, payload) ->
-              Path.Local.relative dir filename, payload))))
+  let all_dirs_seq { root = _; contents } =
+    let rec aux path { subdirs; files = _ } =
+      Seq.concat
+        (Filename.Map.to_seq subdirs
+         |> Seq.map ~f:(fun (subdir_name, subdir_contents) ->
+           let subdir = Path.Local.relative path subdir_name in
+           (if debug_consume
+            then
+              let open Pp.O in
+              Pp.to_fmt
+                Format.std_formatter
+                (Pp.paragraphf "[DirSeq %S] " (Path.Local.to_string subdir) ++ Pp.space));
+           Seq.cons (subdir, subdir_contents) (aux subdir subdir_contents)))
+    in
+    aux Path.Local.root contents
   ;;
 
-  let find { root; files; dirs } path =
+  let find ({ root; contents } as r) file =
     let open Option.O in
-    let* path =
-      Path.Local.descendant (Path.Build.local path) ~of_:(Path.Build.local root)
+    let rec find_aux path { files; subdirs } = function
+      | [] ->
+        Code_error.raise
+          "I've been hoisted by my own petard! (path.explode)"
+          [ "file", Path.Build.to_dyn file ]
+      | [ final ] -> Filename.Map.find files final
+      | parent :: rest ->
+        let path = Path.Local.relative path parent in
+        let* subdir = Filename.Map.find subdirs parent in
+        find_aux path subdir rest
     in
-    let* parent = Path.Local.parent path in
-    if Path.Local.is_root parent
-    then Filename.Map.find files (Path.Local.to_string path)
-    else
-      let* files = Path.Local.Map.find dirs parent in
-      Filename.Map.find files (Path.Local.basename path)
+    let root = Path.Build.local root in
+    let* path = Path.Local.descendant (Path.Build.local file) ~of_:root in
+    let result = find_aux root contents (Path.Local.explode path) in
+    (let open Pp.O in
+     if debug_consume
+     then
+       Pp.to_fmt
+         Format.std_formatter
+         (Pp.paragraphf "In find (%S):" (Path.Build.to_string file)
+          ++ Pp.space
+          ++ pp r
+          ++ Pp.text " => "
+          ++ Pp.paragraph
+               (if Option.is_some result then "found something!" else "found nothing!")
+          ++ Pp.text "\n\n"));
+    result
   ;;
 
   let mem t path = Option.is_some (find t path)
 
-  let find_dir { root; files; dirs } path =
-    match Path.Local.descendant (Path.Build.local path) ~of_:(Path.Build.local root) with
-    | Some dir when Path.Local.is_root dir -> Some files
-    | Some dir -> Path.Local.Map.find dirs dir
-    | None -> None
+  let find_dir ({ root; contents } as r) dir =
+    let open Option.O in
+    let rec find_dir_aux path { subdirs; files = _ } = function
+      | [] ->
+        Code_error.raise
+          "I've been hoisted by my own petard! (path.explode)"
+          [ "dir", Path.Build.to_dyn dir ]
+      | [ final ] ->
+        let+ subdir =
+          Filename.Map.find subdirs final
+          (* (Path.Local.relative path final) *)
+        in
+        subdir.files
+      | parent :: rest ->
+        let path = Path.Local.relative path parent in
+        let* subdir = Filename.Map.find subdirs parent in
+        find_dir_aux path subdir rest
+    in
+    let root = Path.Build.local root in
+    let* path = Path.Local.descendant (Path.Build.local dir) ~of_:root in
+    let result = find_dir_aux root contents (Path.Local.explode path) in
+    (let open Pp.O in
+     if debug_consume
+     then
+       Pp.to_fmt
+         Format.std_formatter
+         (Pp.paragraphf "In find_dir (%S): " (Path.Build.to_string dir)
+          ++ pp r
+          ++ Pp.text " => "
+          ++ Pp.paragraph
+               (if Option.is_some result then "found something!" else "found nothing!")
+          ++ Pp.text "\n\n"));
+    result
   ;;
 
+  let mem_dir t path = Option.is_some (find_dir t path)
+
   let equal
-    { root = root1; files = files1; dirs = dirs1 }
-    { root = root2; files = files2; dirs = dirs2 }
+    { root = root1; contents = contents1 }
+    { root = root2; contents = contents2 }
     ~equal
     =
-    Path.Build.equal root1 root2
-    && Filename.Map.equal files1 files2 ~equal
-    && Path.Local.Map.equal dirs1 dirs2 ~equal:(Filename.Map.equal ~equal)
+    let rec eq_aux { files = files1; subdirs = dirs1 } { files = files2; subdirs = dirs2 }
+      =
+      Filename.Map.equal files1 files2 ~equal
+      && Filename.Map.equal dirs1 dirs2 ~equal:eq_aux
+    in
+    Path.Build.equal root1 root2 && eq_aux contents1 contents2
   ;;
 
-  let exists { root = _; files; dirs } ~f =
-    Filename.Map.exists files ~f || Path.Local.Map.exists dirs ~f:(String.Map.exists ~f)
+  let exists { root = _; contents } ~f =
+    let rec aux { files; subdirs } =
+      Filename.Map.exists files ~f || Filename.Map.exists subdirs ~f:aux
+    in
+    aux contents
   ;;
 
-  let foldi { root = _; files; dirs } ~init ~f =
-    let acc =
-      Filename.Map.foldi files ~init ~f:(fun file acc ->
-        f (Path.Local.of_string file) acc)
+  let foldi { contents; root = _ } ~init ~f =
+    let rec aux path { files; subdirs } acc =
+      let acc =
+        Filename.Map.foldi files ~init:acc ~f:(fun file_name acc ->
+          let file = Path.Local.relative path file_name in
+          (if debug_consume
+           then
+             let open Pp.O in
+             Pp.to_fmt
+               Format.std_formatter
+               (Pp.paragraphf "[Foldi %S] " (Path.Local.to_string file) ++ Pp.space));
+          f file acc)
+      in
+      Filename.Map.foldi subdirs ~init:acc ~f:(fun dir_name ->
+        aux (Path.Local.relative path dir_name))
     in
-    Path.Local.Map.foldi dirs ~init:acc ~f:(fun dir filenames acc ->
-      String.Map.foldi filenames ~init:acc ~f:(fun filename payload acc ->
-        f (Path.Local.relative dir filename) payload acc))
+    aux Path.Local.root contents init
   ;;
 
-  let iteri { root = _; files; dirs } ~f =
-    Filename.Map.iteri files ~f:(fun file acc -> f (Path.Local.of_string file) acc);
-    Path.Local.Map.iteri dirs ~f:(fun dir filenames ->
-      String.Map.iteri filenames ~f:(fun filename payload ->
-        f (Path.Local.relative dir filename) payload))
+  let iteri { contents; root = _ } ~f ~d =
+    let rec aux path { files; subdirs } =
+      Filename.Map.iteri files ~f:(fun file_name payload ->
+        let file = Path.Local.relative path file_name in
+        (if debug_consume
+         then
+           let open Pp.O in
+           Pp.to_fmt
+             Format.std_formatter
+             (Pp.paragraphf "[Iteri F %S]" (Path.Local.to_string file) ++ Pp.space));
+        f file payload);
+      Filename.Map.iteri subdirs ~f:(fun dir_name dir_contents ->
+        let dir = Path.Local.relative path dir_name in
+        (if debug_consume
+         then
+           let open Pp.O in
+           Pp.to_fmt
+             Format.std_formatter
+             (Pp.paragraphf "[Iteri D %S]" (Path.Local.to_string dir) ++ Pp.space));
+        d dir dir_contents;
+        (* Depth-first traversal here. *)
+        aux dir dir_contents)
+    in
+    aux Path.Local.root contents
   ;;
 
+  let iter_files t ~f = iteri t ~f ~d:(fun _ _ -> ())
+  let iter_dirs t ~f = iteri t ~f:(fun _ _ -> ()) ~d:f
+
   module Path_traversal = Fiber.Make_parallel_map (Path.Local.Map)
   module Filename_traversal = Fiber.Make_parallel_map (String.Map)
 
-  let parallel_map { root; files; dirs } ~f =
+  let parallel_map { root; contents } ~f =
     let open Fiber.O in
-    let+ files, dirs =
-      Fiber.fork_and_join
-        (fun () ->
-          Filename_traversal.parallel_map files ~f:(fun file ->
-            f (Path.Local.of_string file)))
-        (fun () ->
-          Path_traversal.parallel_map dirs ~f:(fun dir files ->
-            Filename_traversal.parallel_map files ~f:(fun file payload ->
-              f (Path.Local.relative dir file) payload)))
+    let rec aux path { files; subdirs } =
+      let+ files, subdirs =
+        Fiber.fork_and_join
+          (fun () ->
+            Filename_traversal.parallel_map files ~f:(fun file_name ->
+              let file = Path.Local.relative path file_name in
+              (if debug_consume
+               then
+                 let open Pp.O in
+                 Pp.to_fmt
+                   Format.std_formatter
+                   (Pp.paragraphf "[Paramap %S]" (Path.Local.to_string file) ++ Pp.space));
+              f file))
+          (fun () ->
+            Filename_traversal.parallel_map subdirs ~f:(fun dir_name ->
+              aux (Path.Local.relative path dir_name)))
+      in
+      { files; subdirs }
     in
-    { root; files; dirs }
+    let+ contents = aux Path.Local.root contents in
+    { root; contents }
   ;;
 
-  let digest { root = _; files; dirs } =
-    let all_digests =
-      Filename.Map.values files
-      :: Path.Local.Map.to_list_map dirs ~f:(fun _ -> String.Map.values)
+  let digest { root = _; contents } =
+    let rec all_digests _ { files; subdirs } =
+      let ffiles = Filename.Map.values files in
+      List.concat (ffiles :: Filename.Map.to_list_map subdirs ~f:all_digests)
     in
-    Digest.generic (List.concat all_digests)
+    Digest.generic (all_digests "ignored" contents)
   ;;
 
   exception Short_circuit
 
   let map_with_errors
-    { root; files; dirs }
+    { root; contents }
     ~all_errors
     ~(f : Path.Build.t -> 'a -> ('b, 'e) result)
     =
@@ -401,32 +692,44 @@ module Produced = struct
         errors := (path, e) :: !errors;
         if all_errors then None else raise_notrace Short_circuit
     in
+    let rec aux path { files; subdirs } =
+      let files =
+        Filename.Map.filter_mapi files ~f:(fun file ->
+          (if debug_consume
+           then
+             let open Pp.O in
+             Pp.to_fmt
+               Format.std_formatter
+               (Pp.paragraphf
+                  "[Map/w/E %S]"
+                  (Path.Build.to_string (Path.Build.relative path file))
+                ++ Pp.space));
+          f (Path.Build.relative path file))
+      in
+      let subdirs =
+        Filename.Map.mapi subdirs ~f:(fun dir subdirs_contents ->
+          let dir = Path.Build.relative path dir in
+          aux dir subdirs_contents)
+      in
+      { files; subdirs }
+    in
     let result =
-      try
-        let files =
-          Filename.Map.filter_mapi files ~f:(fun file ->
-            f (Path.Build.relative root file))
-        in
-        let dirs =
-          Path.Local.Map.mapi dirs ~f:(fun dir ->
-            let dir = Path.Build.append_local root dir in
-            Filename.Map.filter_mapi ~f:(fun filename ->
-              f (Path.Build.relative dir filename)))
-        in
-        { root; files; dirs }
-      with
-      | Short_circuit -> { root; files = Filename.Map.empty; dirs = Path.Local.Map.empty }
+      try { root; contents = aux root contents } with
+      | Short_circuit ->
+        { root; contents = { files = Filename.Map.empty; subdirs = Filename.Map.empty } }
     in
     match Nonempty_list.of_list !errors with
     | None -> Ok result
     | Some list -> Error list
   ;;
 
-  let to_dyn { root; files; dirs } =
-    Dyn.record
-      [ "root", Path.Build.to_dyn root
-      ; "files", Filename.Map.to_dyn Dyn.opaque files
-      ; "dirs", Path.Local.Map.to_dyn (Filename.Map.to_dyn Dyn.opaque) dirs
-      ]
+  let to_dyn { root; contents } =
+    let rec aux { files; subdirs } =
+      Dyn.record
+        [ "files", Filename.Map.to_dyn Dyn.opaque files
+        ; "dirs", Filename.Map.to_dyn aux subdirs
+        ]
+    in
+    Dyn.record [ "root", Path.Build.to_dyn root; "contents", aux contents ]
   ;;
 end
diff --git a/src/dune_targets/dune_targets.mli b/src/dune_targets/dune_targets.mli
index 5b024d1decf..acb4dac50d4 100644
--- a/src/dune_targets/dune_targets.mli
+++ b/src/dune_targets/dune_targets.mli
@@ -40,6 +40,7 @@ module Validated : sig
     ; dirs : Filename.Set.t
     }
 
+  val pp : t -> _ Pp.t
   val iter : t -> file:(Path.Build.t -> unit) -> dir:(Path.Build.t -> unit) -> unit
 
   val fold
@@ -79,12 +80,24 @@ val all : t -> Path.Build.t list
 (** The set of targets produced by an action. Each target may be tagged with a
     payload, for example, the target's digest. *)
 module Produced : sig
+  (** All file names and directory names are relative to the root (['a t]). *)
+  type 'a dir_contents = private
+    { files : 'a Filename.Map.t (* mapping file name -> 'a *)
+    ; subdirs :
+        'a dir_contents Filename.Map.t (* mapping directory name -> 'a dir_contents *)
+    }
+
+  val pp_dir_conts : ?payload_printer:('a -> 'b Pp.t) -> 'a dir_contents -> 'b Pp.t
+
   type 'a t = private
-    { root : Path.Build.t (** [files] and [dirs] are relative to [root] *)
-    ; files : 'a Filename.Map.t
-    ; dirs : 'a Filename.Map.t Path.Local.Map.t
+    { root : Path.Build.t
+    ; contents : 'a dir_contents
     }
 
+  val merge : 'a t -> 'a t -> 'a t
+  val pp : ?payload_printer:('a -> 'b Pp.t) -> 'a t -> 'b Pp.t
+  val debug_out : bool
+
   module Error : sig
     type t
 
@@ -99,13 +112,21 @@ module Produced : sig
   (** Construct from a set of files in the root directory. *)
   val of_files : Path.Build.t -> 'a Path.Local.Map.t -> 'a t
 
-  (** Union of [t.files] and all files in [t.dirs] as [Seq.t] for efficient traversal.
+  val of_files_with_neighbours : Path.Build.t -> 'a Path.Local.Map.t -> 'a t
+
+  (** Union of all files in [t] and any [subdirs] as [Seq.t] for efficient traversal.
       The resulting [Path.Local.t]s are relative to [t.root]. *)
   val all_files_seq : 'a t -> (Path.Local.t * 'a) Seq.t
 
+  (** Union of all dirs and subdirs in [t] as [Seq.t], in depth-first order. *)
+  val all_dirs_seq : 'a t -> (Path.Local.t * 'a dir_contents) Seq.t
+
   (** Check if a file is present in the targets. *)
   val mem : 'a t -> Path.Build.t -> bool
 
+  (* Check if a directory is present in the targets. *)
+  val mem_dir : 'a t -> Path.Build.t -> bool
+
   (** Find the value associated with the file, if any. *)
   val find : 'a t -> Path.Build.t -> 'a option
 
@@ -115,7 +136,18 @@ module Produced : sig
   val equal : 'a t -> 'a t -> equal:('a -> 'a -> bool) -> bool
   val exists : 'a t -> f:('a -> bool) -> bool
   val foldi : 'a t -> init:'acc -> f:(Path.Local.t -> 'a -> 'acc -> 'acc) -> 'acc
-  val iteri : 'a t -> f:(Path.Local.t -> 'a -> unit) -> unit
+  val iter_files : 'a t -> f:(Path.Local.t -> 'a -> unit) -> unit
+  val iter_dirs : 'a t -> f:(Path.Local.t -> 'a dir_contents -> unit) -> unit
+
+  (** Iterate on all [f]iles & [d]irs in the targets, in depth-first order.
+      Will hit [dirA/fileA] before [dirA/dirB] before [dirA/dirB/fileB].
+      All [Path.Local.t]s are relative to [t.root]. *)
+  val iteri
+    :  'a t
+    -> f:(Path.Local.t -> 'a -> unit)
+    -> d:(Path.Local.t -> 'a dir_contents -> unit)
+    -> unit
+
   val parallel_map : 'a t -> f:(Path.Local.t -> 'a -> 'b Fiber.t) -> 'b t Fiber.t
 
   (** Aggregate all content digests. *)
diff --git a/test/blackbox-tests/test-cases/directory-targets/subdirs-only.t b/test/blackbox-tests/test-cases/directory-targets/subdirs-only.t
new file mode 100644
index 00000000000..0caf52f6481
--- /dev/null
+++ b/test/blackbox-tests/test-cases/directory-targets/subdirs-only.t
@@ -0,0 +1,23 @@
+We test that a directory target with only other subdirs can be
+properly promoted.
+
+  $ cat > dune-project <<EOF
+  > (lang dune 3.16)
+  > (using directory-targets 0.1)
+  > EOF
+
+  $ cat > dune <<EOF
+  > (rule
+  >  (targets (dir foo))
+  >  (mode (promote (until-clean)))
+  >  (action
+  >    (progn
+  >      (run mkdir -p foo/bar)
+  >      (run touch foo/bar/file1)
+  >      (run mkdir -p foo/bar/baz/qux)
+  >      (run touch foo/bar/baz/qux/file2))))
+  > EOF
+
+  $ dune build foo
+  $ ls foo/bar/baz/qux
+  file2