Move finding the ancestor vcs to the source tree

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

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 =

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

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

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

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

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

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

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

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