Memoize dir contents

src/dir_contents.mli

@@ -34,11 +34,19 @@ val lookup_module : t -> Module.Name.t -> Dune_file.Buildable.t option
 (** All mld files attached to this documentation stanza *)
 val mlds : t -> Dune_file.Documentation.t -> Path.t list
 
-val get : Super_context.t -> dir:Path.t -> t
+type get_result =
+  | Standalone_or_root of t
+  | Group_part of Path.t
+
+(** Produces rules for all group parts when it returns [Standalone_or_root].
+    Does not generate any rules when it returns [Group_part]. *)
+val get : Super_context.t -> dir:Path.t -> get_result
+
+val get_without_rules : Super_context.t -> dir:Path.t -> t
 
 type kind = private
   | Standalone
-  | Group_root of t list Lazy.t (** Sub-directories part of the group *)
+  | Group_root of (unit -> t list) (** Sub-directories part of the group *)
   | Group_part of t
 
 val kind : t -> kind

src/dir_status.ml

@@ -2,6 +2,11 @@ open Stdune
 open Dune_file
 
 module T = struct
+  type is_component_of_a_group_but_not_the_root = {
+    group_root : Path.t;
+    stanzas : Stanza.t list Dir_with_dune.t option;
+  }
+
   type t =
     | Standalone of
         (File_tree.Dir.t * Stanza.t list Dir_with_dune.t option) option
@@ -13,17 +18,22 @@ module T = struct
                     * Stanza.t list Dir_with_dune.t
     (* Directory with [(include_subdirs x)] where [x] is not [no] *)
 
-    | Is_component_of_a_group_but_not_the_root of
-        Stanza.t list Dir_with_dune.t option
+    | Is_component_of_a_group_but_not_the_root of is_component_of_a_group_but_not_the_root
     (* Sub-directory of a [Group_root _] *)
 
   let to_sexp _ = Sexp.Atom "<dir-status is opaque>"
 end
 include T
 
-let is_standalone = function
-  | Standalone _ -> true
-  | _ -> false
+type enclosing_group =
+  | No_group
+  | Group_root of Path.t
+
+let current_group dir = function
+  | Standalone _ -> No_group
+  | Group_root _ -> Group_root dir
+  | Is_component_of_a_group_but_not_the_root { group_root; _ } ->
+    Group_root group_root
 
 let get_include_subdirs stanzas =
   List.fold_left stanzas ~init:None ~f:(fun acc stanza ->
@@ -59,18 +69,23 @@ module DB = struct
 
   let get db ~dir =
     let get ~dir = Memo.exec db.fn dir in
+    let enclosing_group ~dir =
+      match Path.parent dir with
+      | None ->
+        No_group
+      | Some parent_dir ->
+        current_group parent_dir (get ~dir:parent_dir)
+    in
     match
       Option.bind (Path.drop_build_context dir)
         ~f:(File_tree.find_dir db.file_tree)
     with
     | None -> begin
-        match Path.parent dir with
-        | None -> Standalone None
-        | Some dir ->
-          if is_standalone (get ~dir) then
-            Standalone None
-          else
-            Is_component_of_a_group_but_not_the_root None
+        match enclosing_group ~dir  with
+        | No_group -> Standalone None
+        | Group_root group_root ->
+          Is_component_of_a_group_but_not_the_root
+            { stanzas = None; group_root }
       end
     | Some ft_dir ->
       let project_root =
@@ -79,23 +94,32 @@ module DB = struct
         |> Path.of_local in
       match stanzas_in db ~dir with
       | None ->
-        if Path.equal dir project_root ||
-           is_standalone (get ~dir:(Path.parent_exn dir)) then
+        if Path.equal dir project_root  then
           Standalone (Some (ft_dir, None))
         else
-          Is_component_of_a_group_but_not_the_root None
+          (match enclosing_group ~dir with
+           | No_group ->
+             Standalone (Some (ft_dir, None))
+           | Group_root group_root ->
+             Is_component_of_a_group_but_not_the_root
+               { stanzas = None; group_root })
       | Some d ->
         match get_include_subdirs d.data with
         | Some Unqualified ->
           Group_root (ft_dir, d)
         | Some No ->
           Standalone (Some (ft_dir, Some d))
         | None ->
-          if dir <> project_root &&
-             not (is_standalone (get ~dir:(Path.parent_exn dir)))
+          if dir <> project_root
           then begin
-            check_no_module_consumer d.data;
-            Is_component_of_a_group_but_not_the_root (Some d)
+            match enclosing_group ~dir with
+            | Group_root group_root ->
+              (
+                check_no_module_consumer d.data;
+                Is_component_of_a_group_but_not_the_root
+                  { stanzas = (Some d); group_root })
+            | No_group ->
+              Standalone (Some (ft_dir, Some d))
           end else
             Standalone (Some (ft_dir, Some d))
 

src/dir_status.mli

@@ -1,5 +1,10 @@
 open Stdune
 
+type is_component_of_a_group_but_not_the_root = {
+  group_root : Path.t;
+  stanzas : Stanza.t list Dir_with_dune.t option;
+}
+
 type t =
   | Standalone of
       (File_tree.Dir.t * Stanza.t list Dir_with_dune.t option) option
@@ -11,8 +16,7 @@ type t =
                   * Stanza.t list Dir_with_dune.t
   (* Directory with [(include_subdirs x)] where [x] is not [no] *)
 
-  | Is_component_of_a_group_but_not_the_root of
-      Stanza.t list Dir_with_dune.t option
+  | Is_component_of_a_group_but_not_the_root of is_component_of_a_group_but_not_the_root
   (* Sub-directory of a [Group_root _] *)
 
 module DB : sig

src/gen_rules.ml

@@ -240,16 +240,20 @@ module Gen(P : sig val sctx : Super_context.t end) = struct
          | Some _ ->
            (* This interprets "rule" and "copy_files" stanzas. *)
            let dir_contents = Dir_contents.get sctx ~dir in
-           match Dir_contents.kind dir_contents with
-           | Standalone ->
-             ignore (gen_rules dir_contents [] ~dir : _ list)
+           match dir_contents with
            | Group_part root ->
-             Build_system.load_dir ~dir:(Dir_contents.dir root)
-           | Group_root (lazy subs) ->
-             let cctxs = gen_rules dir_contents [] ~dir in
-             List.iter subs ~f:(fun dc ->
-               ignore (gen_rules dir_contents cctxs ~dir:(Dir_contents.dir dc)
-                       : _ list))
+             Build_system.load_dir ~dir:root
+           | Standalone_or_root dir_contents ->
+             match Dir_contents.kind dir_contents with
+             | Group_part _ -> assert false
+             | Standalone ->
+               ignore (gen_rules dir_contents [] ~dir : _ list)
+             | Group_root subs ->
+               let cctxs = gen_rules dir_contents [] ~dir in
+               let subs = subs () in
+               List.iter subs ~f:(fun dc ->
+                 ignore (gen_rules dir_contents cctxs ~dir:(Dir_contents.dir dc)
+                         : _ list))
        end);
     match components with
     | [] -> These (String.Set.of_list [".js"; "_doc"; ".ppx"])

src/install_rules.ml

@@ -31,7 +31,7 @@ let gen_dune_package sctx ~version ~(pkg : Local_package.t) =
             |> List.map ~f:(fun lib ->
               let name = Lib.name lib in
               let dir_contents =
-                Dir_contents.get sctx ~dir:(Lib.src_dir lib) in
+                Dir_contents.get_without_rules sctx ~dir:(Lib.src_dir lib) in
               let lib_modules =
                 Dir_contents.modules_of_library dir_contents ~name in
               let foreign_objects =
@@ -380,7 +380,7 @@ let init_install sctx (package : Local_package.t) entries =
                  ; dune_version = _
                  } ->
               let sub_dir = (Option.value_exn lib.public).sub_dir in
-              let dir_contents = Dir_contents.get sctx ~dir in
+              let dir_contents = Dir_contents.get_without_rules sctx ~dir in
               lib_install_files sctx ~dir ~sub_dir lib ~scope
                 ~dir_kind ~dir_contents)
   in

src/odoc.ml

@@ -437,7 +437,7 @@ let setup_package_aliases sctx (pkg : Package.t) =
   )
 
 let entry_modules_by_lib sctx lib =
-  Dir_contents.get sctx ~dir:(Lib.src_dir lib)
+  Dir_contents.get_without_rules sctx ~dir:(Lib.src_dir lib)
   |> Dir_contents.modules_of_library ~name:(Lib.name lib)
   |> Lib_modules.entry_modules
 

src/packages.ml

@@ -22,7 +22,7 @@ let mlds_by_package_def =
        |> List.concat_map ~f:(fun (w : _ Dir_with_dune.t) ->
          List.filter_map w.data ~f:(function
            | Documentation d ->
-             let dc = Dir_contents.get sctx ~dir:w.ctx_dir in
+             let dc = Dir_contents.get_without_rules sctx ~dir:w.ctx_dir in
              let mlds = Dir_contents.mlds dc d in
              Some (d.package.name, mlds)
            | _ ->

src/virtual_rules.ml

@@ -252,7 +252,7 @@ let impl sctx ~dir ~(lib : Dune_file.Library.t) ~scope ~modules =
         | Local, Local ->
           let name = Lib.name vlib in
           let dir_contents =
-            Dir_contents.get sctx ~dir:(Lib.src_dir vlib) in
+            Dir_contents.get_without_rules sctx ~dir:(Lib.src_dir vlib) in
           let modules =
             let pp_spec =
               Pp_spec.make lib.buildable.preprocess