diff --git a/bin/common.ml b/bin/common.ml index b310ca75dbd..8b573b7ef90 100644 --- a/bin/common.ml +++ b/bin/common.ml @@ -148,15 +148,11 @@ let init ?log_file c = in Dune_config.init config; Dune_util.Log.init () ?file:log_file; - Dune_engine.Source_tree.init + Dune_engine.Execution_parameters.init (let open Memo.Build.O in - let module S = Dune_engine.Source_tree.Settings in let+ w = Dune_rules.Workspace.workspace () in - S.builtin_default - |> S.set_ancestor_vcs c.root.ancestor_vcs - |> S.set_execution_parameters - (Dune_engine.Execution_parameters.builtin_default - |> Dune_rules.Workspace.update_execution_parameters w)); + Dune_engine.Execution_parameters.builtin_default + |> Dune_rules.Workspace.update_execution_parameters w); Dune_rules.Global.init ~capture_outputs:c.capture_outputs; let cache_config = match config.cache_enabled with diff --git a/bin/workspace_root.ml b/bin/workspace_root.ml index e886e653d7f..c99437e973e 100644 --- a/bin/workspace_root.ml +++ b/bin/workspace_root.ml @@ -29,11 +29,9 @@ type t = ; to_cwd : string list ; reach_from_root_prefix : string ; kind : Kind.t - ; ancestor_vcs : Dune_engine.Vcs.t option } -let make kind dir = - { kind; dir; to_cwd = []; ancestor_vcs = None; reach_from_root_prefix = "" } +let make kind dir = { kind; dir; to_cwd = []; reach_from_root_prefix = "" } let find () = let cwd = Sys.getcwd () in @@ -52,30 +50,15 @@ let find () = candidate | files -> let files = String.Set.of_list (Array.to_list files) in - let new_candidate = + let candidate = match Kind.of_dir_contents files with | Some kind when Kind.priority kind <= Kind.priority candidate.kind -> - Some - { kind - ; dir - ; to_cwd - ; ancestor_vcs = None - ; (* This field is computed at the end *) reach_from_root_prefix = - "" - } - | _ -> None - in - let candidate = - match (new_candidate, candidate.ancestor_vcs) with - | Some c, _ -> c - | None, Some _ -> candidate - | None, None -> ( - match Vcs.Kind.of_dir_contents files with - | Some kind -> - { candidate with - ancestor_vcs = Some { kind; root = Path.of_string dir } - } - | None -> candidate) + { kind + ; dir + ; to_cwd + ; (* This field is computed at the end *) reach_from_root_prefix = "" + } + | _ -> candidate in cont counter ~candidate dir ~to_cwd and cont counter ~candidate ~to_cwd dir = @@ -92,12 +75,7 @@ let find () = let t = loop 0 ~to_cwd:[] cwd ~candidate: - { kind = Cwd - ; dir = cwd - ; to_cwd = [] - ; ancestor_vcs = None - ; reach_from_root_prefix = "" - } + { kind = Cwd; dir = cwd; to_cwd = []; reach_from_root_prefix = "" } in { t with reach_from_root_prefix = diff --git a/bin/workspace_root.mli b/bin/workspace_root.mli index c500fedfe6d..82b0f81f593 100644 --- a/bin/workspace_root.mli +++ b/bin/workspace_root.mli @@ -14,7 +14,6 @@ type t = ; reach_from_root_prefix : string (** Prefix filenames with this to reach them from the root *) ; kind : Kind.t (** Closest VCS in directories strictly above the root *) - ; ancestor_vcs : Dune_engine.Vcs.t option } val create : specified_by_user:string option -> t diff --git a/otherlibs/stdune-unstable/fpath.mli b/otherlibs/stdune-unstable/fpath.mli index f821930ae50..77bb20f452b 100644 --- a/otherlibs/stdune-unstable/fpath.mli +++ b/otherlibs/stdune-unstable/fpath.mli @@ -26,3 +26,5 @@ val unlink : string -> unit val unlink_no_err : string -> unit val initial_cwd : string + +val is_root : string -> bool diff --git a/src/dune_engine/build_system.ml b/src/dune_engine/build_system.ml index 0b80e672118..fa41a72b806 100644 --- a/src/dune_engine/build_system.ml +++ b/src/dune_engine/build_system.ml @@ -1566,8 +1566,11 @@ end = struct let head_target = Path.Build.Set.choose_exn targets in let* action, deps = exec_build_request action and* execution_parameters = - Source_tree.execution_parameters_of_dir - (Path.Build.drop_build_context_exn dir) + match Dpath.Target_dir.of_target dir with + | Regular (With_context (_, dir)) + | Anonymous_action (With_context (_, dir)) -> + Source_tree.execution_parameters_of_dir dir + | _ -> Execution_parameters.default in Memo.Build.of_reproducible_fiber (let open Fiber.O in diff --git a/src/dune_engine/execution_parameters.ml b/src/dune_engine/execution_parameters.ml index 28327ca1b37..29678c34d4d 100644 --- a/src/dune_engine/execution_parameters.ml +++ b/src/dune_engine/execution_parameters.ml @@ -38,3 +38,12 @@ let should_remove_write_permissions_on_generated_files t = let should_expand_aliases_when_sandboxing t = t.dune_version >= (3, 0) let swallow_stdout_on_success t = t.swallow_stdout_on_success + +let default = Fdecl.create Dyn.Encoder.opaque + +let init t = Fdecl.set default t + +let default = + let open Memo.Build.O in + let* () = Memo.Build.return () in + Fdecl.get default diff --git a/src/dune_engine/execution_parameters.mli b/src/dune_engine/execution_parameters.mli index b22eaf9b157..08c5ce75601 100644 --- a/src/dune_engine/execution_parameters.mli +++ b/src/dune_engine/execution_parameters.mli @@ -31,6 +31,9 @@ val set_dune_version : Dune_lang.Syntax.Version.t -> t -> t val set_swallow_stdout_on_success : bool -> t -> t +(** As configured by [init] *) +val default : t Memo.Build.t + (** {1 Accessors} *) val dune_version : t -> Dune_lang.Syntax.Version.t @@ -40,3 +43,7 @@ val should_remove_write_permissions_on_generated_files : t -> bool val should_expand_aliases_when_sandboxing : t -> bool val swallow_stdout_on_success : t -> bool + +(** {1 Initialisation} *) + +val init : t Memo.Build.t -> unit diff --git a/src/dune_engine/source_tree.ml b/src/dune_engine/source_tree.ml index b7fc23d5962..3ee36729b06 100644 --- a/src/dune_engine/source_tree.ml +++ b/src/dune_engine/source_tree.ml @@ -270,12 +270,16 @@ module Output = struct end module Dir0 = struct + type vcs = + | Ancestor_vcs + | This of Vcs.t + type t = { path : Path.Source.t ; status : Sub_dirs.Status.t ; contents : contents ; project : Dune_project.t - ; vcs : Vcs.t option + ; vcs : vcs } and contents = @@ -298,7 +302,10 @@ module Dir0 = struct [ ("path", Path.Source.to_dyn path) ; ("status", Sub_dirs.Status.to_dyn status) ; ("contents", dyn_of_contents contents) - ; ("vcs", Dyn.Encoder.option Vcs.to_dyn vcs) + ; ( "vcs" + , match vcs with + | Ancestor_vcs -> Dyn.Variant ("Ancestor_vcs", []) + | This vcs -> Dyn.Variant ("This", [ Vcs.to_dyn vcs ]) ) ] and dyn_of_sub_dir { sub_dir_status; sub_dir_as_t; virtual_ } = @@ -355,29 +362,24 @@ module Dir0 = struct Path.Source.Set.add acc (Path.Source.relative t.path s)) end -module Settings = struct - type t = - { ancestor_vcs : Vcs.t option - ; execution_parameters : Execution_parameters.t - } - - let builtin_default = - { ancestor_vcs = None - ; execution_parameters = Execution_parameters.builtin_default - } - - let set_ancestor_vcs x t = { t with ancestor_vcs = x } - - let set_execution_parameters x t = { t with execution_parameters = x } - - let t : t Memo.Build.t Fdecl.t = Fdecl.create Dyn.Encoder.opaque - - let set x = Fdecl.set t x - - let get () = Fdecl.get t -end - -let init = Settings.set +let ancestor_vcs = + Memo.lazy_ (fun () -> + if Config.inside_dune then + Memo.Build.return None + else + let rec loop dir = + if Fpath.is_root dir then + None + else + let dir = Filename.dirname dir in + match + Sys.readdir dir |> Array.to_list |> String.Set.of_list + |> Vcs.Kind.of_dir_contents + with + | Some kind -> Some { Vcs.kind; root = Path.of_string dir } + | None -> loop dir + in + Memo.Build.return (loop (Path.to_absolute_filename Path.root))) module rec Memoized : sig val root : unit -> Dir0.t Memo.Build.t @@ -520,10 +522,9 @@ end = struct | None -> Vcs.Kind.of_dir_contents files with | None -> vcs - | Some kind -> Some { Vcs.kind; root = Path.(append_source root) path } + | Some kind -> Dir0.This { Vcs.kind; root = Path.(append_source root) path } let root () = - let* settings = Settings.get () in let path = Path.Source.root in let dir_status : Sub_dirs.Status.t = Normal in let readdir = @@ -544,9 +545,7 @@ end = struct | None -> Dune_project.anonymous ~dir:path | Some p -> p in - let vcs = - get_vcs ~default:settings.ancestor_vcs ~path:Path.Source.root ~readdir - in + let vcs = get_vcs ~default:Ancestor_vcs ~path:Path.Source.root ~readdir in let dirs_visited = Dirs_visited.singleton path in let+ contents, visited = contents readdir ~dirs_visited ~project ~path ~dir_status @@ -659,9 +658,8 @@ let nearest_dir path = let execution_parameters_of_dir = let f path = let+ dir = nearest_dir path - and+ settings = Settings.get () in - settings.execution_parameters - |> Dune_project.update_execution_parameters (Dir0.project dir) + and+ ep = Execution_parameters.default in + Dune_project.update_execution_parameters (Dir0.project dir) ep in let memo = Memo.create "execution-parameters-of-dir" @@ -672,7 +670,11 @@ let execution_parameters_of_dir = in Memo.exec memo -let nearest_vcs path = nearest_dir path >>| Dir0.vcs +let nearest_vcs path = + let* dir = nearest_dir path in + match Dir0.vcs dir with + | This vcs -> Memo.Build.return (Some vcs) + | Ancestor_vcs -> Memo.Lazy.force ancestor_vcs let files_of path = find_dir path >>| function diff --git a/src/dune_engine/source_tree.mli b/src/dune_engine/source_tree.mli index 72513aef28e..b750db58575 100644 --- a/src/dune_engine/source_tree.mli +++ b/src/dune_engine/source_tree.mli @@ -57,8 +57,6 @@ module Dir : sig val sub_dir_names : t -> String.Set.t - val vcs : t -> Vcs.t option - val status : t -> Sub_dirs.Status.t (** Return the contents of the dune (or jbuild) file in this directory *) @@ -70,24 +68,6 @@ module Dir : sig val to_dyn : t -> Dyn.t end -module Settings : sig - (** Global source tree settings. *) - type t - - val builtin_default : t - - (** The default vcs. If there is no vcs at the root of the workspace, then - this is the vcs that will be used for the root. *) - val set_ancestor_vcs : Vcs.t option -> t -> t - - (** The default execution parameters. *) - val set_execution_parameters : Execution_parameters.t -> t -> t -end - -(** Set the global settings for this module. This function must be called - exactly once at the beginning of the process. *) -val init : Settings.t Memo.Build.t -> unit - val root : unit -> Dir.t Memo.Build.t module Make_map_reduce_with_progress (M : Memo.Build) (Outcome : Monoid) : sig diff --git a/src/dune_engine/vcs.ml b/src/dune_engine/vcs.ml index 1f54525f25c..fca7a1e0e17 100644 --- a/src/dune_engine/vcs.ml +++ b/src/dune_engine/vcs.ml @@ -5,6 +5,7 @@ module Kind = struct | Git | Hg + (* The list should be sorted by [t] according to [compare]. [of_readd *) let filenames = [ (".git", Git); (".hg", Hg) ] let of_filename = List.assoc filenames