diff --git a/src/dune_engine/build_config.ml b/src/dune_engine/build_config.ml index e80772e0080..71cd113d457 100644 --- a/src/dune_engine/build_config.ml +++ b/src/dune_engine/build_config.ml @@ -11,10 +11,14 @@ module Context_or_install = struct | Context s -> Context_name.to_dyn s end -type extra_sub_directories_to_keep = Subdir_set.t +type rules = + { build_dir_only_sub_dirs : Subdir_set.t + ; directory_targets : Loc.t Path.Build.Map.t + ; rules : Rules.t Memo.t + } type gen_rules_result = - | Rules of extra_sub_directories_to_keep * Rules.t + | Rules of rules | Unknown_context_or_install | Redirect_to_parent diff --git a/src/dune_engine/build_config.mli b/src/dune_engine/build_config.mli index 744136dd177..5c32f2be10b 100644 --- a/src/dune_engine/build_config.mli +++ b/src/dune_engine/build_config.mli @@ -13,10 +13,26 @@ module Context_or_install : sig val to_dyn : t -> Dyn.t end -type extra_sub_directories_to_keep = Subdir_set.t +(** Rules for a given directory. This type is structured so that all generated + sub-directories (either directory targets or internal generated directories + such as [.ppx]) are known immediately, while the actual build rules are + computed in a second stage. The staging is to avoid computation cycles + created during the computation of the rules. *) +type rules = + { build_dir_only_sub_dirs : Subdir_set.t + (** Sub-directories that don't exist in the source tree but exists in + the build directory. This is for internal directories such as + [.dune] or [.ppx]. *) + ; directory_targets : Loc.t Path.Build.Map.t + (** Directories that are target of a rule. For each directory target, + give the location of the rule that generates it. The keys in this + map must correspond exactly to the set of directory targets that + will be produces by [rules]. *) + ; rules : Rules.t Memo.t + } type gen_rules_result = - | Rules of extra_sub_directories_to_keep * Rules.t + | Rules of rules | Unknown_context_or_install | Redirect_to_parent (** [Redirect_to_parent] means that the parent will generate the rules for diff --git a/src/dune_engine/build_system.ml b/src/dune_engine/build_system.ml index 40abe9f9bc2..3f0316c73c7 100644 --- a/src/dune_engine/build_system.ml +++ b/src/dune_engine/build_system.ml @@ -250,7 +250,7 @@ module type Rec = sig val build_file : Path.t -> Digest.t Memo.t - val build_dir : Path.t -> (Digest.t * Digest.t Path.Build.Map.t) option Memo.t + val build_dir : Path.t -> (Digest.t * Digest.t Path.Build.Map.t) Memo.t val build_deps : Dep.Set.t -> Dep.Facts.t Memo.t @@ -282,11 +282,14 @@ and Exported : sig val execute_rule : Rule.t -> rule_execution_result Memo.t + type target_kind = + | File_target + | Dir_target of { generated_file_digests : Digest.t Path.Build.Map.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 * Digest.t Path.Build.Map.t option) Memo.Table.t + val build_file_memo : (Path.t, Digest.t * target_kind) Memo.Table.t [@@warning "-32"] val build_alias_memo : (Alias.t, Dep.Fact.Files.t) Memo.Table.t @@ -867,14 +870,23 @@ end = struct in Io.read_file (Path.build target) - (* A rule can have multiple targets but calls to [execute_rule] are memoized, - so the rule will be executed only once. + type target_kind = + | File_target + | Dir_target of { generated_file_digests : Digest.t Path.Build.Map.t } - [build_file_impl] returns both the set of dependencies of the file as well - as its digest. *) + let target_kind_equal a b = + match (a, b) with + | File_target, File_target -> true + | ( Dir_target { generated_file_digests = a } + , Dir_target { generated_file_digests = b } ) -> + Path.Build.Map.equal a b ~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 = Load_rules.get_rule_or_source path >>= function - | Source digest -> Memo.return (digest, None) + | Source digest -> Memo.return (digest, File_target) | Rule (path, rule) -> ( let+ { deps = _; targets } = Memo.push_stack_frame @@ -883,7 +895,7 @@ end = struct Pp.text (Path.to_string_maybe_quoted (Path.build path))) in match Path.Build.Map.find targets path with - | Some digest -> (digest, None) + | Some digest -> (digest, File_target) | None -> ( (* CR-someday amokhov: [Cached_digest.build_file] doesn't do a good job for computing directory digests -- it relies on [mtime] instead of @@ -891,7 +903,9 @@ end = struct the consequences, we currently can't support the early cutoff for directory targets. *) match Cached_digest.build_file ~allow_dirs:true path with - | Ok digest -> (digest, Some targets) (* Must be a directory target *) + | Ok digest -> + (digest, Dir_target { generated_file_digests = targets }) + (* Must be a directory target *) | No_such_file | Broken_symlink | Cyclic_symlink @@ -965,13 +979,8 @@ end = struct module Pred = struct let build_impl g = let dir = File_selector.dir g in - let* build_dir = - Load_rules.is_target dir >>= function - | No -> Memo.return None - | Yes _ | Under_directory_target_so_cannot_say -> build_dir dir - in - match build_dir with - | None -> + Load_rules.load_dir ~dir >>= function + | Non_build _ | Build _ -> let* paths = Pred.eval g in let+ files = Memo.parallel_map (Path.Set.to_list paths) ~f:(fun p -> @@ -981,7 +990,8 @@ end = struct Dep.Fact.Files.make ~files:(Path.Map.of_list_exn files) ~dirs:Path.Map.empty - | Some (digest, path_map) -> + | Build_under_directory_target _ -> + let* digest, path_map = build_dir dir in let files = Path.Build.Map.foldi path_map ~init:Path.Map.empty ~f:(fun path digest acc -> @@ -994,16 +1004,11 @@ end = struct let dirs = Path.Map.singleton dir digest in Memo.return (Dep.Fact.Files.make ~files ~dirs) - (* CR-someday amokhov: This function is broken for [dir]s located inside a - directory target. To check this and give a good error message we need to - call [load_dir] on the parent directory but that creates a dependency - cycle because of [copy_rules]. So, for now, this function just silently - produces a wrong result (the glob evalutes to the empty set of files). Of - course, we'd like to eventually fix this. *) let eval_impl g = let dir = File_selector.dir g in - Load_rules.load_dir ~dir >>| function - | Non_build targets -> Path.Set.filter targets ~f:(File_selector.test g) + Load_rules.load_dir ~dir >>= function + | Non_build targets -> + Memo.return (Path.Set.filter targets ~f:(File_selector.test g)) | Build { rules_here; _ } -> let only_generated_files = File_selector.only_generated_files g in (* We look only at [by_file_targets] because [File_selector] does not @@ -1015,7 +1020,13 @@ end = struct | _ -> let s = Path.build s in if File_selector.test g s then s :: acc else acc) - |> Path.Set.of_list + |> Path.Set.of_list |> Memo.return + | Build_under_directory_target _ -> + (* To evaluate a glob in a generated directory, we have no choice but to + build the whole directory, so we might as well build the + predicate. *) + let+ fact = Pred.build g in + Dep.Fact.Files.paths fact |> Path.Set.of_keys let eval_memo = Memo.create "eval-pred" @@ -1037,19 +1048,18 @@ end = struct end let build_file_memo = - let cutoff = - Tuple.T2.equal Digest.equal - (Option.equal (Path.Build.Map.equal ~equal:Digest.equal)) - in + let cutoff = Tuple.T2.equal Digest.equal target_kind_equal in Memo.create "build-file" ~input:(module Path) ~cutoff build_file_impl let build_file path = Memo.exec build_file_memo path >>| fst let build_dir path = - let+ digest, path_map = Memo.exec build_file_memo path in - match path_map with - | Some path_map -> Some (digest, path_map) - | None -> None + let+ digest, kind = Memo.exec build_file_memo path in + match kind with + | Dir_target { generated_file_digests } -> (digest, generated_file_digests) + | File_target -> + Code_error.raise "build_dir called on a file target" + [ ("path", Path.to_dyn path) ] let build_alias_memo = Memo.create "build-alias" @@ -1095,25 +1105,32 @@ let build_pred = Pred.build the results of both [Action_builder.static_deps] and [Action_builder.exec] are cached. *) let file_exists fn = - Load_rules.load_dir ~dir:(Path.parent_exn fn) >>| function - | Non_build targets -> Path.Set.mem targets fn - | Build { rules_here; _ } -> ( - match Path.as_in_build_dir fn with - | None -> false - | Some fn -> ( - match Path.Build.Map.mem rules_here.by_file_targets fn with - | true -> true - | false -> ( - match Path.Build.parent fn with - | None -> false - | Some dir -> Path.Build.Map.mem rules_here.by_directory_targets dir))) + Load_rules.load_dir ~dir:(Path.parent_exn fn) >>= function + | Non_build targets -> Memo.return (Path.Set.mem targets fn) + | Build { rules_here; _ } -> + Memo.return + (Path.Build.Map.mem rules_here.by_file_targets + (Path.as_in_build_dir_exn fn)) + | Build_under_directory_target { directory_target_ancestor } -> + let+ _digest, path_map = build_dir (Path.build directory_target_ancestor) in + Path.Build.Map.mem path_map (Path.as_in_build_dir_exn fn) let files_of ~dir = - Load_rules.load_dir ~dir >>| function - | Non_build file_targets -> file_targets + Load_rules.load_dir ~dir >>= function + | Non_build file_targets -> Memo.return file_targets | Build { rules_here; _ } -> - Path.Build.Map.keys rules_here.by_file_targets - |> Path.Set.of_list_map ~f:Path.build + Memo.return + (Path.Build.Map.keys rules_here.by_file_targets + |> Path.Set.of_list_map ~f:Path.build) + | Build_under_directory_target { directory_target_ancestor } -> + let+ _digest, path_map = build_dir (Path.build directory_target_ancestor) in + let dir = Path.as_in_build_dir_exn dir in + Path.Build.Map.foldi path_map ~init:Path.Set.empty + ~f:(fun path _digest acc -> + let parent = Path.Build.parent_exn path in + match Path.Build.equal parent dir with + | true -> Path.Set.add acc (Path.build path) + | false -> acc) let package_deps ~packages_of (pkg : Package.t) files = (* CR-someday amokhov: We should get rid of this mutable state. *) diff --git a/src/dune_engine/load_rules.ml b/src/dune_engine/load_rules.ml index ef1cdcd8699..94e9ac25da3 100644 --- a/src/dune_engine/load_rules.ml +++ b/src/dune_engine/load_rules.ml @@ -34,6 +34,8 @@ module Loaded = struct type t = | Non_build of Path.Set.t | Build of build + | Build_under_directory_target of + { directory_target_ancestor : Path.Build.t } let no_rules ~allowed_subdirs = Build @@ -59,6 +61,13 @@ module Dir_triage = struct let hash t = Path.Build.hash t.dir let to_dyn t = Path.Build.to_dyn t.dir + + let parent t = + Option.map (Path.Source.parent t.sub_dir) ~f:(fun sub_dir -> + { dir = Path.Build.parent_exn t.dir + ; context_or_install = t.context_or_install + ; sub_dir + }) end type t = @@ -294,9 +303,7 @@ let eval_source_file : type a. a Action_builder.eval_mode -> Path.t -> a Memo.t module rec Load_rules : sig val load_dir : dir:Path.t -> Loaded.t Memo.t - val file_targets_of : dir:Path.t -> Path.Set.t Memo.t - - val directory_targets_of : dir:Path.t -> Path.Set.t Memo.t + val is_under_directory_target : Path.t -> bool Memo.t val lookup_alias : Alias.t -> (Loc.t * Rules.Dir_rules.Alias_spec.item) list option Memo.t @@ -357,26 +364,13 @@ end = struct | Some rule1, Some rule2 -> report_rule_conflict target rule1 rule2); { Loaded.by_file_targets; by_directory_targets } - let file_targets_of ~dir = - load_dir ~dir >>| function - | Non_build file_targets -> file_targets - | Build { rules_here; _ } -> - Path.Build.Map.keys rules_here.by_file_targets - |> Path.Set.of_list_map ~f:Path.build - - let directory_targets_of ~dir = - load_dir ~dir >>| function - | Non_build _file_targets -> Path.Set.empty - | Build { rules_here; _ } -> - Path.Build.Map.keys rules_here.by_directory_targets - |> Path.Set.of_list_map ~f:Path.build - let lookup_alias alias = load_dir ~dir:(Path.build (Alias.dir alias)) >>| function | Non_build _ -> Code_error.raise "Alias in a non-build dir" [ ("alias", Alias.to_dyn alias) ] | Build { aliases; _ } -> Alias.Name.Map.find aliases (Alias.name alias) + | Build_under_directory_target _ -> None let alias_exists alias = lookup_alias alias >>| function @@ -484,7 +478,8 @@ end = struct load_dir ~dir:(Path.build dir) >>| function | Non_build _ -> Dir_set.just_the_root | Build { allowed_subdirs; _ } -> - Dir_set.descend allowed_subdirs subdir)) + Dir_set.descend allowed_subdirs subdir + | Build_under_directory_target _ -> Dir_set.empty)) let allowed_by_parent ~dir = allowed_dirs @@ -492,66 +487,104 @@ end = struct ~subdir:(Path.Build.basename dir) end + type gen_rules_result = + | Under_directory_target of { directory_target_ancestor : Path.Build.t } + | Normal of + { build_dir_only_sub_dirs : Subdir_set.t + ; directory_targets : Loc.t Path.Build.Map.t + ; rules : Rules.t Memo.Lazy.t + } + module rec Gen_rules : sig - val gen_rules : - Dir_triage.Build_directory.t -> (Subdir_set.t * Rules.t) Memo.t + val gen_rules : Dir_triage.Build_directory.t -> gen_rules_result Memo.t end = struct - let gen_rules_impl - { Dir_triage.Build_directory.dir; context_or_install; sub_dir } = + let check_all_directory_targets_are_descendant ~of_:dir directory_targets = + Path.Build.Map.iteri directory_targets ~f:(fun p _loc -> + if not (Path.Build.is_descendant p ~of_:dir) then + Code_error.raise + "[gen_rules] returned directory target in a directory that is \ + not a descendant of the directory it was called for" + [ ("dir", Path.Build.to_dyn dir) + ; ("example", Path.Build.to_dyn p) + ]) + + let check_all_rules_are_descendant ~of_:dir rules = + match + Path.Build.Map.find_key (Rules.to_map rules) ~f:(fun p -> + not (Path.Build.is_descendant p ~of_:dir)) + with + | None -> () + | Some p -> + let dir_rules = + Rules.find rules (Path.build p) |> Rules.Dir_rules.consume + in + Code_error.raise + "[gen_rules] returned rules in a directory that is not a descendant \ + of the directory it was called for" + [ ("dir", Path.Build.to_dyn dir) + ; ( "example" + , match dir_rules with + | { rules = r :: _; _ } -> + Dyn.Variant + ( "Rule" + , [ Dyn.Record + [ ("targets", Targets.Validated.to_dyn r.targets) ] + ] ) + | { rules = []; aliases } -> ( + match Alias.Name.Map.choose aliases with + | None -> assert false + | Some (name, _) -> + Dyn.Variant + ( "Alias" + , [ Dyn.Record + [ ("dir", Path.Build.to_dyn p) + ; ("name", Alias.Name.to_dyn name) + ] + ] )) ) + ] + + let call_rules_generator + ({ Dir_triage.Build_directory.dir; context_or_install; sub_dir } as d) = let (module RG : Build_config.Rule_generator) = (Build_config.get ()).rule_generator in let sub_dir_components = Path.Source.explode sub_dir in RG.gen_rules context_or_install ~dir sub_dir_components >>= function - | Rules (subdirs, rules) -> ( - match - Path.Build.Map.find_key (Rules.to_map rules) ~f:(fun p -> - not (Path.Build.is_descendant p ~of_:dir)) - with - | None -> Memo.return (subdirs, rules) - | Some p -> - let dir_rules = - Rules.find rules (Path.build p) |> Rules.Dir_rules.consume - in - Code_error.raise - "[gen_rules] returned rules in a directory that is not a \ - descendant of the directory it was called for" - [ ("dir", Path.Build.to_dyn dir) - ; ( "example" - , match dir_rules with - | { rules = r :: _; _ } -> - Dyn.Variant - ( "Rule" - , [ Dyn.Record - [ ("targets", Targets.Validated.to_dyn r.targets) ] - ] ) - | { rules = []; aliases } -> ( - match Alias.Name.Map.choose aliases with - | None -> assert false - | Some (name, _) -> - Dyn.Variant - ( "Alias" - , [ Dyn.Record - [ ("dir", Path.Build.to_dyn p) - ; ("name", Alias.Name.to_dyn name) - ] - ] )) ) - ]) + | Rules { build_dir_only_sub_dirs; directory_targets; rules } -> + check_all_directory_targets_are_descendant ~of_:dir directory_targets; + let rules = + Memo.lazy_ (fun () -> + let+ rules = rules in + check_all_rules_are_descendant ~of_:dir rules; + rules) + in + Memo.return + (Normal { build_dir_only_sub_dirs; directory_targets; rules }) | Unknown_context_or_install -> Code_error.raise "[gen_rules] did not specify rules for the context" [ ("context_or_install", Context_or_install.to_dyn context_or_install) ] | Redirect_to_parent -> ( - match Path.Source.parent sub_dir with + match Dir_triage.Build_directory.parent d with | None -> Code_error.raise "[gen_rules] returned Redirect_to_parent on a root direcoty" [ ( "context_or_install" , Context_or_install.to_dyn context_or_install ) ] - | Some sub_dir -> - Gen_rules.gen_rules - { dir = Path.Build.parent_exn dir; context_or_install; sub_dir }) + | Some d' -> Gen_rules.gen_rules d') + + let gen_rules_impl d = + match Dir_triage.Build_directory.parent d with + | None -> call_rules_generator d + | Some d' -> ( + Gen_rules.gen_rules d' >>= function + | Under_directory_target _ as res -> Memo.return res + | Normal rules -> + if Path.Build.Map.mem rules.directory_targets d.dir then + Memo.return + (Under_directory_target { directory_target_ancestor = d.dir }) + else call_rules_generator d) let gen_rules = let memo = @@ -562,6 +595,14 @@ end = struct fun x -> Memo.exec memo x end + let report_rule_internal_dir_conflict target_name loc = + User_error.raise ~loc + [ Pp.textf + "This rule defines a target %S whose name conflicts with an internal \ + directory used by Dune. Please use a different name." + target_name + ] + let load_build_directory_exn ({ Dir_triage.Build_directory.dir; context_or_install; sub_dir } as build_dir) = @@ -569,227 +610,248 @@ end = struct let (module RG : Build_config.Rule_generator) = (Build_config.get ()).rule_generator in - let* extra_subdirs_to_keep, rules_produced = - Gen_rules.gen_rules build_dir - in - let rules = - let dir = Path.build dir in - Rules.find rules_produced dir - in - let collected = Rules.Dir_rules.consume rules in - let rules = collected.rules in - (* Compute the set of sources and targets promoted to the source tree that - must not be copied to the build directory. *) - let source_files_to_ignore, source_dirnames_to_ignore = - List.fold_left rules ~init:(Path.Build.Set.empty, String.Set.empty) - ~f:(fun (acc_files, acc_dirnames) { Rule.targets; mode; loc; _ } -> - let target_filenames = - Path.Build.Set.to_list_map ~f:Path.Build.basename targets.files - |> String.Set.of_list - in - let target_dirnames = - Path.Build.Set.to_list_map ~f:Path.Build.basename targets.dirs - |> String.Set.of_list - in - (* Check if this rule defines any directory targets that conflict with - internal Dune directories listed in [extra_subdirs_to_keep]. *) - (match - String.Set.choose - (Subdir_set.inter_set extra_subdirs_to_keep - (String.Set.union target_filenames target_dirnames)) - with - | None -> () - | Some target_name -> - User_error.raise ~loc - [ Pp.textf - "This rule defines a target %S whose name conflicts with an \ - internal directory used by Dune. Please use a different \ - name." - target_name - ]); - match mode with - | Ignore_source_files -> - ( Path.Build.Set.union acc_files targets.files - , String.Set.union acc_dirnames target_dirnames ) - | Promote { only; _ } -> - (* Note that the [only] predicate applies to the files inside the - directory targets rather than to directory names themselves. *) - let target_files = - match only with - | None -> targets.files - | Some pred -> - let is_promoted file = - Predicate_lang.Glob.exec pred - (Path.reach (Path.build file) ~from:(Path.build dir)) - ~standard:Predicate_lang.any - in - Path.Build.Set.filter targets.files ~f:is_promoted + Gen_rules.gen_rules build_dir >>= function + | Under_directory_target { directory_target_ancestor } -> + Memo.return + (Loaded.Build_under_directory_target { directory_target_ancestor }) + | Normal { rules; build_dir_only_sub_dirs; directory_targets } -> + Path.Build.Map.iteri directory_targets ~f:(fun dir_target loc -> + let name = Path.Build.basename dir_target in + if + Path.Build.equal (Path.Build.parent_exn dir_target) dir + && Subdir_set.mem build_dir_only_sub_dirs name + then report_rule_internal_dir_conflict name loc); + let* rules_produced = Memo.Lazy.force rules in + let rules = + let dir = Path.build dir in + Rules.find rules_produced dir + in + let collected = Rules.Dir_rules.consume rules in + let rules = collected.rules in + (* Compute the set of sources and targets promoted to the source tree that + must not be copied to the build directory. *) + let source_files_to_ignore, source_dirnames_to_ignore = + List.fold_left rules ~init:(Path.Build.Set.empty, String.Set.empty) + ~f:(fun (acc_files, acc_dirnames) { Rule.targets; mode; loc; _ } -> + let target_filenames = + Path.Build.Set.to_list_map ~f:Path.Build.basename targets.files + |> String.Set.of_list in - ( Path.Build.Set.union acc_files target_files - , String.Set.union acc_dirnames target_dirnames ) - | Standard | Fallback -> (acc_files, acc_dirnames)) - in - (* Take into account the source files *) - let* to_copy, source_dirs = - match context_or_install with - | Install _ -> Memo.return (None, String.Set.empty) - | Context context_name -> - let+ files, subdirs = - Source_tree.find_dir sub_dir >>| function - | None -> (Path.Source.Set.empty, String.Set.empty) - | Some dir -> - (Source_tree.Dir.file_paths dir, Source_tree.Dir.sub_dir_names dir) - in - let files = - let source_files_to_ignore = - Path.Build.Set.to_list_map ~f:Path.Build.drop_build_context_exn - source_files_to_ignore - |> Path.Source.Set.of_list + let target_dirnames = + Path.Build.Set.to_list_map ~f:Path.Build.basename targets.dirs + |> String.Set.of_list + in + (* Check if this rule defines any file targets that conflict with + internal Dune directories listed in [build_dir_only_sub_dirs]. We + don't check directory targets as these are already checked + earlier. *) + (match + String.Set.choose + (Subdir_set.inter_set build_dir_only_sub_dirs target_filenames) + with + | None -> () + | Some target_name -> + report_rule_internal_dir_conflict target_name loc); + match mode with + | Ignore_source_files -> + ( Path.Build.Set.union acc_files targets.files + , String.Set.union acc_dirnames target_dirnames ) + | Promote { only; _ } -> + (* Note that the [only] predicate applies to the files inside the + directory targets rather than to directory names themselves. *) + let target_files = + match only with + | None -> targets.files + | Some pred -> + let is_promoted file = + Predicate_lang.Glob.exec pred + (Path.reach (Path.build file) ~from:(Path.build dir)) + ~standard:Predicate_lang.any + in + Path.Build.Set.filter targets.files ~f:is_promoted + in + ( Path.Build.Set.union acc_files target_files + , String.Set.union acc_dirnames target_dirnames ) + | Standard | Fallback -> (acc_files, acc_dirnames)) + in + (* Take into account the source files *) + let* to_copy, source_dirs = + match context_or_install with + | Install _ -> Memo.return (None, String.Set.empty) + | Context context_name -> + let+ files, subdirs = + Source_tree.find_dir sub_dir >>| function + | None -> (Path.Source.Set.empty, String.Set.empty) + | Some dir -> + (Source_tree.Dir.file_paths dir, Source_tree.Dir.sub_dir_names dir) in - let source_files_to_ignore = - Target_promotion.delete_stale_dot_merlin_file ~dir - ~source_files_to_ignore + let files = + let source_files_to_ignore = + Path.Build.Set.to_list_map ~f:Path.Build.drop_build_context_exn + source_files_to_ignore + |> Path.Source.Set.of_list + in + let source_files_to_ignore = + Target_promotion.delete_stale_dot_merlin_file ~dir + ~source_files_to_ignore + in + Path.Source.Set.diff files source_files_to_ignore in - Path.Source.Set.diff files source_files_to_ignore - in - let subdirs = String.Set.diff subdirs source_dirnames_to_ignore in - if Path.Source.Set.is_empty files then (None, subdirs) - else - let ctx_path = Context_name.build_dir context_name in - (Some (ctx_path, files), subdirs) - in - (* Filter out fallback rules *) - let rules = - match to_copy with - | None -> - (* If there are no source files to copy, fallback rules are - automatically kept *) - rules - | Some (_, to_copy) -> filter_out_fallback_rules ~to_copy rules - in - (* Compile the rules and cleanup stale artifacts *) - let rules = - (match to_copy with - | None -> [] - | Some (ctx_dir, source_files) -> - create_copy_rules ~ctx_dir ~non_target_source_files:source_files) - @ rules - in - let* allowed_by_parent = - match (context_or_install, Path.Source.to_string sub_dir) with - | Context _, ".dune" -> - (* GROSS HACK: this is to avoid a cycle as the rules for all directories - force the generation of ".dune/configurator". We need a better way to - deal with such cases. *) - Memo.return Generated_directory_restrictions.Unrestricted - | _ -> Generated_directory_restrictions.allowed_by_parent ~dir - in - let* () = - match allowed_by_parent with - | Unrestricted -> Memo.return () - | Restricted restriction -> ( - match Path.Build.Map.find (Rules.to_map rules_produced) dir with - | None -> Memo.return () - | Some rules -> - let+ restriction = Memo.Lazy.force restriction in - if not (Dir_set.here restriction) then - Code_error.raise - "Generated rules in a directory not allowed by the parent" - [ ("dir", Path.Build.to_dyn dir) - ; ("rules", Rules.Dir_rules.to_dyn rules) - ]) - in - let* descendants_to_keep = - let rules_generated_in = - Rules.to_map rules_produced - |> Path.Build.Map.foldi ~init:Dir_set.empty ~f:(fun p _ acc -> - match Path.Local_gen.descendant ~of_:dir p with - | None -> acc - | Some p -> Dir_set.union acc (Dir_set.singleton p)) + let subdirs = String.Set.diff subdirs source_dirnames_to_ignore in + if Path.Source.Set.is_empty files then (None, subdirs) + else + let ctx_path = Context_name.build_dir context_name in + (Some (ctx_path, files), subdirs) in - let subdirs_to_keep = - match extra_subdirs_to_keep with - | All -> Subdir_set.All - | These set -> These (String.Set.union source_dirs set) + (* Filter out fallback rules *) + let rules = + match to_copy with + | None -> + (* If there are no source files to copy, fallback rules are + automatically kept *) + rules + | Some (_, to_copy) -> filter_out_fallback_rules ~to_copy rules in - let+ allowed_grand_descendants_of_parent = + (* Compile the rules and cleanup stale artifacts *) + let rules = + (match to_copy with + | None -> [] + | Some (ctx_dir, source_files) -> + create_copy_rules ~ctx_dir ~non_target_source_files:source_files) + @ rules + in + let* allowed_by_parent = + match (context_or_install, Path.Source.to_string sub_dir) with + | Context _, ".dune" -> + (* GROSS HACK: this is to avoid a cycle as the rules for all + directories force the generation of ".dune/configurator". We need a + better way to deal with such cases. *) + Memo.return Generated_directory_restrictions.Unrestricted + | _ -> Generated_directory_restrictions.allowed_by_parent ~dir + in + let* () = match allowed_by_parent with - | Unrestricted -> - (* In this case the parent isn't going to be able to create any - generated grand descendant directories. Rules that attempt to do so - may run into the [allowed_by_parent] check or will be simply - ignored. *) - Memo.return Dir_set.empty - | Restricted restriction -> Memo.Lazy.force restriction + | Unrestricted -> Memo.return () + | Restricted restriction -> ( + match Path.Build.Map.find (Rules.to_map rules_produced) dir with + | None -> Memo.return () + | Some rules -> + let+ restriction = Memo.Lazy.force restriction in + if not (Dir_set.here restriction) then + Code_error.raise + "Generated rules in a directory not allowed by the parent" + [ ("dir", Path.Build.to_dyn dir) + ; ("rules", Rules.Dir_rules.to_dyn rules) + ]) in - Dir_set.union_all - [ rules_generated_in - ; Subdir_set.to_dir_set subdirs_to_keep - ; allowed_grand_descendants_of_parent - ] - in - let subdirs_to_keep = Subdir_set.of_dir_set descendants_to_keep in - let rules_here = compile_rules ~dir ~source_dirs rules in - remove_old_artifacts ~dir ~rules_here ~subdirs_to_keep; - remove_old_sub_dirs_in_anonymous_actions_dir - ~dir: - (Path.Build.append_local Dpath.Build.anonymous_actions_dir - (Path.Build.local dir)) - ~subdirs_to_keep; - let+ aliases = - match context_or_install with - | Context _ -> compute_alias_expansions ~collected ~dir - | Install _ -> - (* There are no aliases in the [_build/install] directory *) - Memo.return Alias.Name.Map.empty - in - { Loaded.allowed_subdirs = descendants_to_keep; rules_here; aliases } + let* descendants_to_keep = + let rules_generated_in = + Rules.to_map rules_produced + |> Path.Build.Map.foldi ~init:Dir_set.empty ~f:(fun p _ acc -> + match Path.Local_gen.descendant ~of_:dir p with + | None -> acc + | Some p -> Dir_set.union acc (Dir_set.singleton p)) + in + let subdirs_to_keep = + match build_dir_only_sub_dirs with + | All -> Subdir_set.All + | These set -> These (String.Set.union source_dirs set) + in + let+ allowed_grand_descendants_of_parent = + match allowed_by_parent with + | Unrestricted -> + (* In this case the parent isn't going to be able to create any + generated grand descendant directories. Rules that attempt to do + so may run into the [allowed_by_parent] check or will be simply + ignored. *) + Memo.return Dir_set.empty + | Restricted restriction -> Memo.Lazy.force restriction + in + Dir_set.union_all + [ rules_generated_in + ; Subdir_set.to_dir_set subdirs_to_keep + ; allowed_grand_descendants_of_parent + ] + in + let subdirs_to_keep = Subdir_set.of_dir_set descendants_to_keep in + let rules_here = compile_rules ~dir ~source_dirs rules in + let real_directory_targets = + Path.Build.Set.of_keys rules_here.by_directory_targets + in + let directory_targets = Path.Build.Set.of_keys directory_targets in + if not (Path.Build.Set.equal directory_targets real_directory_targets) + then + Code_error.raise + "gen_rules returned a set of directory targets that doesn't match \ + the set of directory targets from returned rules" + [ ("dir", Path.Build.to_dyn dir) + ; ("directory_targets", Path.Build.Set.to_dyn directory_targets) + ; ( "real_directory_targets" + , Path.Build.Set.to_dyn real_directory_targets ) + ]; + remove_old_artifacts ~dir ~rules_here ~subdirs_to_keep; + remove_old_sub_dirs_in_anonymous_actions_dir + ~dir: + (Path.Build.append_local Dpath.Build.anonymous_actions_dir + (Path.Build.local dir)) + ~subdirs_to_keep; + let+ aliases = + match context_or_install with + | Context _ -> compute_alias_expansions ~collected ~dir + | Install _ -> + (* There are no aliases in the [_build/install] directory *) + Memo.return Alias.Name.Map.empty + in + Loaded.Build + { Loaded.allowed_subdirs = descendants_to_keep; rules_here; aliases } let load_dir_impl ~dir : Loaded.t Memo.t = get_dir_triage ~dir >>= function | Known l -> Memo.return l - | Build_directory x -> - let+ build = load_build_directory_exn x in - Loaded.Build build + | Build_directory x -> load_build_directory_exn x let load_dir = let load_dir_impl dir = load_dir_impl ~dir in let memo = Memo.create "load-dir" ~input:(module Path) load_dir_impl in fun ~dir -> Memo.exec memo dir + + let is_under_directory_target p = + match Path.parent p with + | None -> Memo.return false + | Some dir -> ( + get_dir_triage ~dir >>= function + | Known _ -> Memo.return false + | Build_directory d -> ( + Gen_rules.gen_rules d >>| function + | Under_directory_target _ -> true + | Normal { directory_targets; _ } -> + Path.Build.Map.mem directory_targets (Path.as_in_build_dir_exn p))) end include Load_rules -let load_dir_and_get_buildable_targets ~dir = - load_dir ~dir >>| function - | Non_build _ -> Loaded.no_rules_here - | Build { rules_here; _ } -> rules_here - -let get_rule_for_directory_target path = - let rec loop dir = - match Path.Build.parent dir with - | None -> Memo.return None - | Some parent_dir -> ( - let* rules = - load_dir_and_get_buildable_targets ~dir:(Path.build parent_dir) - in - match Path.Build.Map.find rules.by_directory_targets dir with - | None -> loop parent_dir - | Some _ as rule -> Memo.return rule) - in - loop path +let get_rule_internal path = + let dir = Path.Build.parent_exn path in + load_dir ~dir:(Path.build dir) >>= function + | Non_build _ -> assert false + | Build { rules_here; _ } -> ( + match Path.Build.Map.find rules_here.by_file_targets path with + | Some _ as rule -> Memo.return rule + | None -> + Memo.return (Path.Build.Map.find rules_here.by_directory_targets path)) + | Build_under_directory_target { directory_target_ancestor } -> ( + load_dir ~dir:(Path.build (Path.Build.parent_exn directory_target_ancestor)) + >>= function + | Non_build _ | Build_under_directory_target _ -> assert false + | Build { rules_here; _ } -> + Memo.return + (Path.Build.Map.find rules_here.by_directory_targets + directory_target_ancestor)) let get_rule path = match Path.as_in_build_dir path with | None -> Memo.return None - | Some path -> ( - let dir = Path.Build.parent_exn path in - load_dir ~dir:(Path.build dir) >>= function - | Non_build _ -> assert false - | Build { rules_here; _ } -> ( - match Path.Build.Map.find rules_here.by_file_targets path with - | Some _ as rule -> Memo.return rule - | None -> get_rule_for_directory_target path)) + | Some path -> get_rule_internal path type rule_or_source = | Source of Digest.t @@ -798,16 +860,12 @@ type rule_or_source = let get_rule_or_source path = let dir = Path.parent_exn path in if Path.is_strict_descendant_of_build_dir dir then - let* rules = load_dir_and_get_buildable_targets ~dir in let path = Path.as_in_build_dir_exn path in - match Path.Build.Map.find rules.by_file_targets path with + get_rule_internal path >>= function | Some rule -> Memo.return (Rule (path, rule)) - | None -> ( - get_rule_for_directory_target path >>= function - | Some rule -> Memo.return (Rule (path, rule)) - | None -> - let* loc = Current_rule_loc.get () in - no_rule_found ~loc path) + | None -> + let* loc = Current_rule_loc.get () in + no_rule_found ~loc path else let+ d = source_file_digest path in Source d @@ -848,7 +906,8 @@ let all_direct_targets () = All_targets.combine (Path.Build.Map.map rules_here.by_file_targets ~f:(fun _ -> File)) (Path.Build.Map.map rules_here.by_directory_targets ~f:(fun _ -> - Directory)))) + Directory)) + | Build_under_directory_target _ -> All_targets.empty)) >>| All_targets.reduce let get_alias_definition alias = @@ -866,24 +925,17 @@ type is_target = | Under_directory_target_so_cannot_say let is_target file = - match Path.is_in_build_dir file with - | false -> Memo.return No - | true -> ( - let parent_dir = Path.parent_exn file in - let* file_targets = file_targets_of ~dir:parent_dir in - match Path.Set.mem file_targets file with - | true -> Memo.return (Yes File) - | false -> - let rec loop file' = - match Path.parent file' with - | None -> Memo.return No - | Some dir -> ( - let* directory_targets = directory_targets_of ~dir in - match Path.Set.mem directory_targets file' with - | true -> - Memo.return - (if Path.equal file file' then Yes Directory - else Under_directory_target_so_cannot_say) - | false -> loop dir) - in - loop file) + match Path.parent file with + | None -> Memo.return No + | Some dir -> ( + load_dir ~dir >>| function + | Non_build _ -> No + | Build { rules_here; _ } -> ( + let file = Path.as_in_build_dir_exn file in + match Path.Build.Map.find rules_here.by_file_targets file with + | Some _ -> Yes File + | None -> ( + match Path.Build.Map.find rules_here.by_directory_targets file with + | Some _ -> Yes Directory + | None -> No)) + | Build_under_directory_target _ -> Under_directory_target_so_cannot_say) diff --git a/src/dune_engine/load_rules.mli b/src/dune_engine/load_rules.mli index 30d947c55d5..ae95c6dd641 100644 --- a/src/dune_engine/load_rules.mli +++ b/src/dune_engine/load_rules.mli @@ -24,6 +24,8 @@ module Loaded : sig type t = | Non_build of Path.Set.t | Build of build + | Build_under_directory_target of + { directory_target_ancestor : Path.Build.t } val no_rules : allowed_subdirs:Path.Unspecified.w Dir_set.t -> t end @@ -51,6 +53,21 @@ type is_target = val is_target : Path.t -> is_target Memo.t +(** [is_under_directory_target p] returns [true] iff [p] is a descendant of one. + Returns [true] if [p] is a directory target itself. + + This is similar to: + + {[ + is_target p >>= function + | No | Yes File -> false + | Yes Directory | under_directory_target_so_cannot_say -> true + ]} + + Except that it forces less rules to be computed, thus creating less + opportunities for creating computation cycles. *) +val is_under_directory_target : Path.t -> bool Memo.t + (** List of all buildable direct targets. This does not include files and directory produced under a directory target. *) val all_direct_targets : unit -> target_type Path.Build.Map.t Memo.t diff --git a/src/dune_rules/dir_contents.ml b/src/dune_rules/dir_contents.ml index 8b609fb71eb..45788ad3c83 100644 --- a/src/dune_rules/dir_contents.ml +++ b/src/dune_rules/dir_contents.ml @@ -38,11 +38,16 @@ let empty kind ~dir = ; coq = Memo.Lazy.of_val Coq_sources.empty } +type standalone_or_root = + { root : t + ; subdirs : t list + ; rules : Rules.t + } + type triage = | Standalone_or_root of - { root : t - ; subdirs : t list - ; rules : Rules.t + { directory_targets : Loc.t Path.Build.Map.t + ; contents : standalone_or_root Memo.Lazy.t } | Group_part of Path.Build.t @@ -190,7 +195,10 @@ end = struct type result0 = | See_above of Path.Build.t - | Here of result0_here + | Here of + { directory_targets : Loc.t Path.Build.Map.t + ; contents : result0_here Memo.Lazy.t + } module Key = struct module Super_context = Super_context.As_memo_key @@ -214,20 +222,11 @@ end = struct let rec walk st_dir ~dir ~local = let* status = Dir_status.DB.get dir_status_db ~dir in match status with - | Is_component_of_a_group_but_not_the_root { stanzas = d; group_root = _ } - -> - let+ a, b = - Memo.fork_and_join - (fun () -> - let+ files = - match d with - | None -> Memo.return (Source_tree.Dir.files st_dir) - | Some d -> load_text_files sctx st_dir d - in - Appendable_list.singleton (dir, List.rev local, files)) - (fun () -> walk_children st_dir ~dir ~local) - in - Appendable_list.( @ ) a b + | Is_component_of_a_group_but_not_the_root { stanzas; group_root = _ } -> + let+ l = walk_children st_dir ~dir ~local in + Appendable_list.( @ ) + (Appendable_list.singleton (dir, List.rev local, st_dir, stanzas)) + l | Generated | Source_only _ | Standalone _ | Group_root _ -> Memo.return Appendable_list.empty and walk_children st_dir ~dir ~local = @@ -245,109 +244,174 @@ end = struct let+ l = walk_children st_dir ~dir ~local:[] in Appendable_list.to_list l + let extract_directory_targets ~dir stanzas = + List.fold_left stanzas ~init:Path.Build.Map.empty ~f:(fun acc stanza -> + match stanza with + | Rule { targets = Static { targets = l; _ }; loc = rule_loc; _ } -> + List.fold_left l ~init:acc ~f:(fun acc (target, kind) -> + let loc = String_with_vars.loc target in + match (kind : Targets_spec.Kind.t) with + | File -> acc + | Directory -> ( + match String_with_vars.text_only target with + | None -> + User_error.raise ~loc + [ Pp.text "Variables are not allowed in directory targets." + ] + | Some target -> + let dir_target = + Path.Build.relative ~error_loc:loc dir target + in + if not (Path.Build.is_descendant dir_target ~of_:dir) then + (* This will be checked when we interpret the stanza + completely, so just ignore this rule for now. *) + acc + else + (* We ignore duplicates here as duplicates are detected and + reported by [Load_rules]. *) + Path.Build.Map.set acc dir_target rule_loc)) + | _ -> acc) + let get0_impl (sctx, dir) : result0 Memo.t = let dir_status_db = Super_context.dir_status_db sctx in let ctx = Super_context.context sctx in let lib_config = (Super_context.context sctx).lib_config in let* status = Dir_status.DB.get dir_status_db ~dir in + let human_readable_description () = + Pp.textf "Computing directory contents of %s" + (Path.to_string_maybe_quoted (Path.build dir)) + in match status with | Is_component_of_a_group_but_not_the_root { group_root; stanzas = _ } -> Memo.return (See_above group_root) | Generated | Source_only _ -> Memo.return (Here - { t = empty Standalone ~dir - ; rules = Rules.empty - ; subdirs = Path.Build.Map.empty + { directory_targets = Path.Build.Map.empty + ; contents = + Memo.lazy_ (fun () -> + Memo.return + { t = empty Standalone ~dir + ; rules = Rules.empty + ; subdirs = Path.Build.Map.empty + }) }) | Standalone (st_dir, d) -> - let include_subdirs = (Loc.none, Include_subdirs.No) in - let+ files, rules = - Rules.collect (fun () -> load_text_files sctx st_dir d) - in - let dirs = [ (dir, [], files) ] in - let ml = - Memo.lazy_ (fun () -> - let lookup_vlib = lookup_vlib sctx in - let loc = loc_of_dune_file st_dir in - Ml_sources.make d ~lib_config ~loc ~include_subdirs ~lookup_vlib - ~dirs) - in - Here - { t = - { kind = Standalone - ; dir - ; text_files = files - ; ml - ; mlds = Memo.lazy_ (fun () -> build_mlds_map d ~files) - ; foreign_sources = - Memo.lazy_ (fun () -> - Foreign_sources.make d ~lib_config:ctx.lib_config - ~include_subdirs ~dirs - |> Memo.return) - ; coq = - Memo.lazy_ (fun () -> - Coq_sources.of_dir d ~include_subdirs ~dirs |> Memo.return) - } - ; rules - ; subdirs = Path.Build.Map.empty - } + Memo.return + (Here + { directory_targets = extract_directory_targets ~dir d.data + ; contents = + Memo.lazy_ ~human_readable_description (fun () -> + let include_subdirs = (Loc.none, Include_subdirs.No) in + let+ files, rules = + Rules.collect (fun () -> load_text_files sctx st_dir d) + in + let dirs = [ (dir, [], files) ] in + let ml = + Memo.lazy_ (fun () -> + let lookup_vlib = lookup_vlib sctx in + let loc = loc_of_dune_file st_dir in + Ml_sources.make d ~lib_config ~loc ~include_subdirs + ~lookup_vlib ~dirs) + in + { t = + { kind = Standalone + ; dir + ; text_files = files + ; ml + ; mlds = Memo.lazy_ (fun () -> build_mlds_map d ~files) + ; foreign_sources = + Memo.lazy_ (fun () -> + Foreign_sources.make d ~lib_config:ctx.lib_config + ~include_subdirs ~dirs + |> Memo.return) + ; coq = + Memo.lazy_ (fun () -> + Coq_sources.of_dir d ~include_subdirs ~dirs + |> Memo.return) + } + ; rules + ; subdirs = Path.Build.Map.empty + }) + }) | Group_root (st_dir, qualif_mode, d) -> let loc = loc_of_dune_file st_dir in let include_subdirs = let loc, qualif_mode = qualif_mode in (loc, Dune_file.Include_subdirs.Include qualif_mode) in - let+ (files, (subdirs : (Path.Build.t * _ * _) list)), rules = - Rules.collect (fun () -> - Memo.fork_and_join - (fun () -> load_text_files sctx st_dir d) - (fun () -> collect_group sctx ~st_dir ~dir)) - in - let dirs = (dir, [], files) :: subdirs in - let ml = - Memo.lazy_ (fun () -> - let lookup_vlib = lookup_vlib sctx in - Ml_sources.make d ~lib_config ~loc ~lookup_vlib ~include_subdirs - ~dirs) + let* subdirs = collect_group sctx ~st_dir ~dir in + let directory_targets = + let dirs = (dir, [], st_dir, Some d) :: subdirs in + List.fold_left dirs ~init:Path.Build.Map.empty + ~f:(fun acc (dir, _, _, d) -> + match d with + | None -> acc + | Some (d : _ Dir_with_dune.t) -> + Path.Build.Map.union acc (extract_directory_targets ~dir d.data) + ~f:(fun _ _ x -> Some x)) in - let foreign_sources = - Memo.lazy_ (fun () -> - Foreign_sources.make d ~include_subdirs ~lib_config:ctx.lib_config - ~dirs - |> Memo.return) - in - let coq = - Memo.lazy_ (fun () -> - Coq_sources.of_dir d ~dirs ~include_subdirs |> Memo.return) - in - let subdirs = - List.map subdirs ~f:(fun (dir, _local, files) -> - { kind = Group_part - ; dir - ; text_files = files - ; ml - ; foreign_sources - ; mlds = Memo.lazy_ (fun () -> build_mlds_map d ~files) - ; coq + let contents = + Memo.lazy_ ~human_readable_description (fun () -> + let+ (files, (subdirs : (Path.Build.t * _ * _) list)), rules = + Rules.collect (fun () -> + Memo.fork_and_join + (fun () -> load_text_files sctx st_dir d) + (fun () -> + Memo.parallel_map subdirs + ~f:(fun (dir, local, st_dir, stanzas) -> + let+ files = + match stanzas with + | None -> Memo.return (Source_tree.Dir.files st_dir) + | Some d -> load_text_files sctx st_dir d + in + (dir, local, files)))) + in + let dirs = (dir, [], files) :: subdirs in + let ml = + Memo.lazy_ (fun () -> + let lookup_vlib = lookup_vlib sctx in + Ml_sources.make d ~lib_config ~loc ~lookup_vlib + ~include_subdirs ~dirs) + in + let foreign_sources = + Memo.lazy_ (fun () -> + Foreign_sources.make d ~include_subdirs + ~lib_config:ctx.lib_config ~dirs + |> Memo.return) + in + let coq = + Memo.lazy_ (fun () -> + Coq_sources.of_dir d ~dirs ~include_subdirs |> Memo.return) + in + let subdirs = + List.map subdirs ~f:(fun (dir, _local, files) -> + { kind = Group_part + ; dir + ; text_files = files + ; ml + ; foreign_sources + ; mlds = Memo.lazy_ (fun () -> build_mlds_map d ~files) + ; coq + }) + in + let t = + { kind = Group_root subdirs + ; dir + ; text_files = files + ; ml + ; foreign_sources + ; mlds = Memo.lazy_ (fun () -> build_mlds_map d ~files) + ; coq + } + in + { t + ; rules + ; subdirs = + Path.Build.Map.of_list_map_exn subdirs ~f:(fun x -> (x.dir, x)) }) in - let t = - { kind = Group_root subdirs - ; dir - ; text_files = files - ; ml - ; foreign_sources - ; mlds = Memo.lazy_ (fun () -> build_mlds_map d ~files) - ; coq - } - in - Here - { t - ; rules - ; subdirs = - Path.Build.Map.of_list_map_exn subdirs ~f:(fun x -> (x.dir, x)) - } + Memo.return (Here { directory_targets; contents }) let memo0 = Memo.create "dir-contents-get0" @@ -359,11 +423,15 @@ end = struct let get sctx ~dir = Memo.exec memo0 (sctx, dir) >>= function - | Here { t; rules = _; subdirs = _ } -> Memo.return t + | Here { directory_targets = _; contents } -> + let+ { t; rules = _; subdirs = _ } = Memo.Lazy.force contents in + t | See_above group_root -> ( - Memo.exec memo0 (sctx, group_root) >>| function + Memo.exec memo0 (sctx, group_root) >>= function | See_above _ -> assert false - | Here { t; rules = _; subdirs = _ } -> t) + | Here { directory_targets = _; contents } -> + let+ { t; rules = _; subdirs = _ } = Memo.Lazy.force contents in + t) let () = let f sctx ~dir ~name = @@ -376,9 +444,13 @@ end = struct let triage sctx ~dir = Memo.exec memo0 (sctx, dir) >>| function | See_above group_root -> Group_part group_root - | Here { t; rules; subdirs } -> + | Here { directory_targets; contents } -> Standalone_or_root - { root = t; subdirs = Path.Build.Map.values subdirs; rules } + { directory_targets + ; contents = + Memo.Lazy.map contents ~f:(fun { t; rules; subdirs } -> + { root = t; subdirs = Path.Build.Map.values subdirs; rules }) + } end include Load diff --git a/src/dune_rules/dir_contents.mli b/src/dune_rules/dir_contents.mli index 485aac03c44..87019d42285 100644 --- a/src/dune_rules/dir_contents.mli +++ b/src/dune_rules/dir_contents.mli @@ -40,11 +40,17 @@ val get : Super_context.t -> dir:Path.Build.t -> t Memo.t not part of a group. *) val dirs : t -> t list +type standalone_or_root = + { root : t + ; subdirs : t list (** Sub-directories part of the group *) + ; rules : Rules.t + } + type triage = | Standalone_or_root of - { root : t - ; subdirs : t list (** Sub-directories part of the group *) - ; rules : Rules.t + { directory_targets : Loc.t Path.Build.Map.t + (** ALl directory targets that are part of the group. *) + ; contents : standalone_or_root Memo.Lazy.t } | Group_part of Path.Build.t diff --git a/src/dune_rules/gen_rules.ml b/src/dune_rules/gen_rules.ml index b68bdb9dc16..21517c5126d 100644 --- a/src/dune_rules/gen_rules.ml +++ b/src/dune_rules/gen_rules.ml @@ -339,9 +339,14 @@ let gen_rules_for_automatic_sub_dir ~sctx ~dir kind = let dst = File_binding.Expanded.dst_path t ~dir in Super_context.add_rule sctx ~loc ~dir (Action_builder.symlink ~src ~dst)) -let has_rules m = - let+ subdirs, rules = Rules.collect (fun () -> m) in - Build_config.Rules (subdirs, rules) +let has_rules subdirs f = + let rules = Rules.collect_unit f in + Memo.return + (Build_config.Rules + { build_dir_only_sub_dirs = subdirs + ; directory_targets = Path.Build.Map.empty + ; rules + }) let redirect_to_parent = Memo.return Build_config.Redirect_to_parent @@ -351,24 +356,26 @@ let gen_rules ~sctx ~dir components : Build_config.gen_rules_result Memo.t = let module S = Subdir_set in match components with | [ ".dune"; "ccomp" ] -> + has_rules S.empty (fun () -> + (* Add rules for C compiler detection *) + Cxx_rules.rules ~sctx ~dir) + | [ ".dune" ] -> has_rules - ((* Add rules for C compiler detection *) - let+ () = Cxx_rules.rules ~sctx ~dir in - S.empty) - | [ ".dune" ] -> has_rules (Memo.return S.empty) + (S.These (String.Set.of_list [ "ccomp" ])) + (fun () -> Context.gen_configurator_rules (Super_context.context sctx)) | ".js" :: rest -> has_rules - (let+ () = Jsoo_rules.setup_separate_compilation_rules sctx rest in - match rest with - | [] -> S.All - | _ -> S.empty) + (match rest with + | [] -> S.All + | _ -> S.empty) + (fun () -> Jsoo_rules.setup_separate_compilation_rules sctx rest) | "_doc" :: rest -> Odoc.gen_rules sctx rest ~dir | ".ppx" :: rest -> has_rules - (let+ () = Preprocessing.gen_rules sctx rest in - match rest with - | [] -> S.All - | _ -> S.empty) + (match rest with + | [] -> S.All + | _ -> S.empty) + (fun () -> Preprocessing.gen_rules sctx rest) | _ -> ( let src_dir = Path.Build.drop_build_context_exn dir in Source_tree.find_dir src_dir >>= function @@ -384,58 +391,54 @@ let gen_rules ~sctx ~dir components : Build_config.gen_rules_result Memo.t = with | None -> redirect_to_parent | Some kind -> - has_rules - (gen_rules_for_automatic_sub_dir ~sctx ~dir kind - >>> Memo.return Subdir_set.empty))) + has_rules Subdir_set.empty (fun () -> + gen_rules_for_automatic_sub_dir ~sctx ~dir kind))) | Some source_dir -> ( (* This interprets "rule" and "copy_files" stanzas. *) Dir_contents.triage sctx ~dir >>= function | Group_part _ -> redirect_to_parent - | Standalone_or_root { root = dir_contents; subdirs; rules } -> - has_rules - (let* () = Rules.produce rules in - let* () = - let project = Source_tree.Dir.project source_dir in - if - Path.Build.equal - (Path.Build.append_source - (Super_context.context sctx).build_dir - (Dune_project.root project)) - dir - then gen_project_rules sctx project - else Memo.return () - in - let* cctxs = gen_rules sctx dir_contents [] ~source_dir ~dir in - let+ () = - Memo.parallel_iter subdirs ~f:(fun dc -> - gen_rules sctx dir_contents cctxs ~source_dir - ~dir:(Dir_contents.dir dc) - >>| ignore) - in - let subdirs = String.Set.of_keys automatic_sub_dirs_map in - let subdirs = - match components with - | [] -> - String.Set.union subdirs - (String.Set.of_list [ ".js"; "_doc"; ".ppx"; ".dune" ]) - | _ -> subdirs - in - S.These subdirs))) - -let gen_rules ~sctx ~dir components = - let module S = Subdir_set in - match components with - | [ ".dune" ] -> - has_rules - ((* [.dune] is treated specifically as generating the rules in all other - directories forces the production of the configurator files for which - the rules are setup in this branch. *) - let+ () = Context.gen_configurator_rules (Super_context.context sctx) in - S.These (String.Set.of_list [ "ccomp" ])) - | _ -> - let* () = Memo.Lazy.force Context.force_configurator_files in - gen_rules ~sctx ~dir components + | Standalone_or_root { directory_targets; contents } -> + let rules = + let* () = Memo.Lazy.force Context.force_configurator_files in + let* { Dir_contents.root = dir_contents; subdirs; rules } = + Memo.Lazy.force contents + in + let* rules' = + Rules.collect_unit (fun () -> + let* () = + let project = Source_tree.Dir.project source_dir in + if + Path.Build.equal + (Path.Build.append_source + (Super_context.context sctx).build_dir + (Dune_project.root project)) + dir + then gen_project_rules sctx project + else Memo.return () + in + let* cctxs = gen_rules sctx dir_contents [] ~source_dir ~dir in + Memo.parallel_iter subdirs ~f:(fun dc -> + gen_rules sctx dir_contents cctxs ~source_dir + ~dir:(Dir_contents.dir dc) + >>| ignore)) + in + Memo.return (Rules.union rules rules') + in + let subdirs = String.Set.of_keys automatic_sub_dirs_map in + let subdirs = + match components with + | [] -> + String.Set.union subdirs + (String.Set.of_list [ ".js"; "_doc"; ".ppx"; ".dune" ]) + | _ -> subdirs + in + Memo.return + (Build_config.Rules + { build_dir_only_sub_dirs = S.These subdirs + ; directory_targets + ; rules + }))) let with_context ctx ~f = Super_context.find ctx >>= function @@ -447,6 +450,10 @@ let gen_rules ctx_or_install ~dir components = | Install ctx -> with_context ctx ~f:(fun sctx -> let+ subdirs, rules = Install_rules.symlink_rules sctx ~dir in - Build_config.Rules (subdirs, rules)) + Build_config.Rules + { build_dir_only_sub_dirs = subdirs + ; directory_targets = Path.Build.Map.empty + ; rules = Memo.return rules + }) | Context ctx -> with_context ctx ~f:(fun sctx -> gen_rules ~sctx ~dir components) diff --git a/src/dune_rules/odoc.ml b/src/dune_rules/odoc.ml index 13e836e6d52..6f049f99f0a 100644 --- a/src/dune_rules/odoc.ml +++ b/src/dune_rules/odoc.ml @@ -758,19 +758,36 @@ let setup_private_library_doc_alias sctx ~scope ~dir (l : Dune_file.Library.t) = (lib |> Dep.html_alias ctx |> Dune_engine.Dep.alias |> Action_builder.dep) let has_rules m = - let+ rules = Rules.collect_unit (fun () -> m) in - Build_config.Rules (Subdir_set.empty, rules) + let rules = Rules.collect_unit (fun () -> m) in + Memo.return + (Build_config.Rules + { rules + ; build_dir_only_sub_dirs = Subdir_set.empty + ; directory_targets = Path.Build.Map.empty + }) let with_package sctx pkg ~f = let pkg = Package.Name.of_string pkg in let packages = Super_context.packages sctx in match Package.Name.Map.find packages pkg with - | None -> Memo.return (Build_config.Rules (Subdir_set.empty, Rules.empty)) + | None -> + Memo.return + (Build_config.Rules + { rules = Memo.return Rules.empty + ; build_dir_only_sub_dirs = Subdir_set.empty + ; directory_targets = Path.Build.Map.empty + }) | Some pkg -> has_rules (f pkg) let gen_rules sctx ~dir:_ rest = match rest with - | [] -> Memo.return (Build_config.Rules (Subdir_set.All, Rules.empty)) + | [] -> + Memo.return + (Build_config.Rules + { rules = Memo.return Rules.empty + ; build_dir_only_sub_dirs = Subdir_set.All + ; directory_targets = Path.Build.Map.empty + }) | [ "_html" ] -> has_rules (setup_css_rule sctx >>> setup_toplevel_index_rule sctx) | [ "_mlds"; pkg ] -> diff --git a/src/dune_rules/simple_rules.ml b/src/dune_rules/simple_rules.ml index 084194fa790..23d1419795a 100644 --- a/src/dune_rules/simple_rules.ml +++ b/src/dune_rules/simple_rules.ml @@ -164,12 +164,22 @@ let copy_files sctx ~dir ~expander ~src_dir (def : Copy_files.t) = let pred = Path.basename glob_in_src |> Glob.of_string_exn loc |> Glob.to_pred in - let* exists = + let src_in_build = + match Path.as_in_source_tree src_in_src with + | None -> src_in_src + | Some src_in_src -> + let context = Super_context.context sctx in + Path.Build.append_source context.build_dir src_in_src |> Path.build + in + let* exists_or_generated = match Path.as_in_source_tree src_in_src with | None -> Memo.return (Path.exists src_in_src) - | Some src_in_src -> Source_tree.dir_exists src_in_src + | Some src_in_src -> ( + Source_tree.dir_exists src_in_src >>= function + | true -> Memo.return true + | false -> Load_rules.is_under_directory_target src_in_build) in - if not exists then + if not exists_or_generated then User_error.raise ~loc [ Pp.textf "Cannot find directory: %s" (Path.to_string src_in_src) ]; if Path.equal src_in_src (Path.source src_dir) then @@ -179,13 +189,6 @@ let copy_files sctx ~dir ~expander ~src_dir (def : Copy_files.t) = is not the current directory." ]; (* add rules *) - let src_in_build = - match Path.as_in_source_tree src_in_src with - | None -> src_in_src - | Some src_in_src -> - let context = Super_context.context sctx in - Path.Build.append_source context.build_dir src_in_src |> Path.build - in let* files = Build_system.eval_pred (File_selector.create ~dir:src_in_build pred) in diff --git a/test/blackbox-tests/test-cases/directory-targets/copy-files.t b/test/blackbox-tests/test-cases/directory-targets/copy-files.t index 9883051baa3..1273ac39d4f 100644 --- a/test/blackbox-tests/test-cases/directory-targets/copy-files.t +++ b/test/blackbox-tests/test-cases/directory-targets/copy-files.t @@ -8,6 +8,11 @@ Copy files from inside a directory target Copy from a generated sub-directory ----------------------------------- +This test just documents that copying from a generated sub-directory +causes a cycle. In theory, it would be possible to avoid but it would +requires deep changes in Dune. The cycle exists at the moment because +Dune loads all the rules of a directory at once. + $ cat >dune < (rule > (target (dir foo)) @@ -17,10 +22,10 @@ Copy from a generated sub-directory > EOF $ dune build - File "dune", line 5, characters 12-17: - 5 | (copy_files foo/*) - ^^^^^ - Error: Cannot find directory: foo + Error: Dependency cycle between: + Computing directory contents of _build/default + -> Evaluating predicate in directory _build/default/foo + -> Computing directory contents of _build/default [1] $ ls _build/default/ @@ -42,12 +47,8 @@ Copy from a generated directory somewhere else > EOF $ dune build b - File "b/dune", line 1, characters 12-22: - 1 | (copy_files ../a/foo/*) - ^^^^^^^^^^ - Error: Cannot find directory: a/foo - [1] - $ dir="_build/default/b" - $ if [ -d $dir ]; then echo "$dir exists"; else echo "$dir does not exist"; fi - _build/default/b does not exist + $ ls _build/default/b + x + y + z diff --git a/test/blackbox-tests/test-cases/watching/fs-memo.t b/test/blackbox-tests/test-cases/watching/fs-memo.t index 82545fd2dca..143784d452f 100644 --- a/test/blackbox-tests/test-cases/watching/fs-memo.t +++ b/test/blackbox-tests/test-cases/watching/fs-memo.t @@ -452,18 +452,12 @@ Here is what should have happened: $ test "echo force > dep" ------------------------------------------ - Failure - Failure - File "dir", line 1, characters 0-0: - Error: File unavailable: dir - Broken symbolic link - Had errors, waiting for filesystem changes... - File "dir", line 1, characters 0-0: - Error: File unavailable: dir - Broken symbolic link - Had errors, waiting for filesystem changes... + Executing rule... + Success, waiting for filesystem changes... + Executing rule... + Success, waiting for filesystem changes... ------------------------------------------ - result = '357' -> '357' -> '357' + result = '357' -> '35' -> '35' ------------------------------------------ Updating dir_contents cache for "dep": Skipped Updating file_digest cache for "dep": Updated { changed = true }