From ffbec34cd856c94bd40c9a9a6cf51d75493e11b2 Mon Sep 17 00:00:00 2001 From: Arseniy Alekseyev Date: Fri, 22 Mar 2019 13:11:56 +0000 Subject: [PATCH] Use memoization in Dir_contents. - Replace all occurrences of lazy in the file with Memo.lazy_. - Make all the rules generated by get be only produced when forcing the root of the directory group (and not individual subdirectories) so the behavior is more well-defined. In the future we'll need a proper mechanism that sorts the rules by directory, but at the moment the rule collectors play that role. Signed-off-by: Arseniy Alekseyev --- src/dir_contents.ml | 366 ++++++++++++++++++++++++++----------------- src/dir_contents.mli | 12 +- src/gen_rules.ml | 22 +-- src/install_rules.ml | 4 +- src/odoc.ml | 2 +- src/packages.ml | 2 +- src/virtual_rules.ml | 2 +- 7 files changed, 253 insertions(+), 157 deletions(-) diff --git a/src/dir_contents.ml b/src/dir_contents.ml index 01d804d7258..f13f5925656 100644 --- a/src/dir_contents.ml +++ b/src/dir_contents.ml @@ -177,14 +177,14 @@ type t = { kind : kind ; dir : Path.t ; text_files : String.Set.t - ; modules : Modules.t Lazy.t - ; c_sources : C_sources.t Lazy.t - ; mlds : (Dune_file.Documentation.t * Path.t list) list Lazy.t + ; modules : unit -> Modules.t + ; c_sources : unit -> C_sources.t + ; mlds : unit -> (Dune_file.Documentation.t * Path.t list) list } and kind = | Standalone - | Group_root of t list Lazy.t + | Group_root of (unit -> t list) | Group_part of t let kind t = t.kind @@ -193,14 +193,14 @@ let dir t = t.dir let dirs t = match t.kind with | Standalone -> [t] - | Group_root (lazy l) - | Group_part { kind = Group_root (lazy l); _ } -> t :: l + | Group_root l + | Group_part { kind = Group_root l; _ } -> t :: l () | Group_part { kind = _; _ } -> assert false let text_files t = t.text_files let modules_of_library t ~name = - let map = (Lazy.force t.modules).libraries in + let map = (t.modules ()).libraries in match Lib_name.Map.find map name with | Some m -> m | None -> @@ -210,7 +210,7 @@ let modules_of_library t ~name = ] let modules_of_executables t ~first_exe = - let map = (Lazy.force t.modules).executables in + let map = (t.modules ()).executables in match String.Map.find map first_exe with | Some m -> m | None -> @@ -220,13 +220,13 @@ let modules_of_executables t ~first_exe = ] let c_sources_of_library t ~name = - C_sources.for_lib (Lazy.force t.c_sources) ~dir:t.dir ~name + C_sources.for_lib (t.c_sources ()) ~dir:t.dir ~name let lookup_module t name = - Module.Name.Map.find (Lazy.force t.modules).rev_map name + Module.Name.Map.find (t.modules ()).rev_map name let mlds t (doc : Documentation.t) = - let map = Lazy.force t.mlds in + let map = t.mlds () in match List.find_map map ~f:(fun (doc', x) -> Option.some_if (Loc.equal doc.loc doc'.loc) x) @@ -314,16 +314,16 @@ let modules_of_files ~dir ~files = let build_mlds_map (d : _ Dir_with_dune.t) ~files = let dir = d.ctx_dir in - let mlds = lazy ( - String.Set.fold files ~init:String.Map.empty ~f:(fun fn acc -> - match String.lsplit2 fn ~on:'.' with - | Some (s, "mld") -> String.Map.add acc s fn - | _ -> acc)) + let mlds = Memo.lazy_ (fun () -> ( + String.Set.fold files ~init:String.Map.empty ~f:(fun fn acc -> + match String.lsplit2 fn ~on:'.' with + | Some (s, "mld") -> String.Map.add acc s fn + | _ -> acc))) in List.filter_map d.data ~f:(function | Documentation doc -> let mlds = - let mlds = Lazy.force mlds in + let mlds = mlds () in Ordered_set_lang.String.eval_unordered doc.mld_files ~parse:(fun ~loc s -> match String.Map.find mlds s with @@ -339,144 +339,228 @@ let build_mlds_map (d : _ Dir_with_dune.t) ~files = Some (doc, List.map (String.Map.values mlds) ~f:(Path.relative dir)) | _ -> None) -let cache = Hashtbl.create 32 +type result0_here = { + t : t; + (* [rules] includes rules for subdirectories too *) + rules : Build_system.rule_collection_implicit_output option; + subdirs : t Path.Map.t; +} -let clear_cache () = - Hashtbl.reset cache +type result0 = + | See_above of Path.t + | Here of result0_here -let () = Hooks.End_of_build.always clear_cache +let get_without_rules_fdecl : (Super_context.t * Path.t -> t) Fdecl.t = + Fdecl.create () -let rec get sctx ~dir = - match Hashtbl.find cache dir with - | Some t -> t - | None -> - let dir_status_db = Super_context.dir_status_db sctx in - match Dir_status.DB.get dir_status_db ~dir with - | Standalone x -> - let t = - match x with - | Some (ft_dir, Some d) -> +module Key = struct + type t = Super_context.t * Path.t + + let to_dyn (sctx, path) = + Dyn.Tuple [Super_context.to_dyn sctx; Path.to_dyn path;] + + let to_sexp t = Dyn.to_sexp (to_dyn t) + let equal = Tuple.T2.equal Super_context.equal Path.equal + let hash = Tuple.T2.hash Super_context.hash Path.hash +end + +let get0_impl (sctx, dir) : result0 = + let dir_status_db = Super_context.dir_status_db sctx in + match Dir_status.DB.get dir_status_db ~dir with + | Standalone x -> + (match x with + | Some (ft_dir, Some d) -> + let files, rules = + Memo.Implicit_output.collect_sync + Build_system.rule_collection_implicit_output + (fun () -> load_text_files sctx ft_dir d) + in + Here { + t = { kind = Standalone + ; dir + ; text_files = files + ; modules = Memo.lazy_ (fun () -> + Modules.make d + ~modules:(modules_of_files ~dir:d.ctx_dir ~files)) + ; mlds = Memo.lazy_ (fun () -> build_mlds_map d ~files) + ; c_sources = Memo.lazy_ (fun () -> + let dune_version = d.dune_version in + C_sources.make d + ~c_sources:(C_sources.load_sources ~dune_version ~dir:d.ctx_dir + ~files)) + }; + rules; + subdirs = Path.Map.empty; + } + | Some (_, None) + | None -> + Here { + t = { kind = Standalone + ; dir + ; text_files = String.Set.empty + ; modules = (fun () -> Modules.empty) + ; mlds = (fun () -> []) + ; c_sources = (fun () -> C_sources.empty) + }; + rules = None; + subdirs = Path.Map.empty; + }) + | Is_component_of_a_group_but_not_the_root { group_root; _ } -> + See_above group_root + | Group_root (ft_dir, d) -> + let rec walk ft_dir ~dir acc = + match + Dir_status.DB.get dir_status_db ~dir + with + | Is_component_of_a_group_but_not_the_root { stanzas = d; group_root = _ } -> + let files = + match d with + | None -> File_tree.Dir.files ft_dir + | Some d -> load_text_files sctx ft_dir d + in + walk_children ft_dir ~dir ((dir, files) :: acc) + | _ -> acc + and walk_children ft_dir ~dir acc = + String.Map.foldi (File_tree.Dir.sub_dirs ft_dir) ~init:acc + ~f:(fun name ft_dir acc -> + let dir = Path.relative dir name in + walk ft_dir ~dir acc) + in + let (files, subdirs), rules = + Memo.Implicit_output.collect_sync + Build_system.rule_collection_implicit_output (fun () -> let files = load_text_files sctx ft_dir d in - { kind = Standalone - ; dir - ; text_files = files - ; modules = lazy (Modules.make d - ~modules:(modules_of_files ~dir:d.ctx_dir ~files)) - ; mlds = lazy (build_mlds_map d ~files) - ; c_sources = lazy ( - let dune_version = d.dune_version in - C_sources.make d - ~c_sources:(C_sources.load_sources ~dune_version ~dir:d.ctx_dir - ~files)) - } - | Some (_, None) - | None -> - { kind = Standalone - ; dir - ; text_files = String.Set.empty - ; modules = lazy Modules.empty - ; mlds = lazy [] - ; c_sources = lazy C_sources.empty - } - in - Hashtbl.add cache dir t; - t - | Is_component_of_a_group_but_not_the_root _ -> begin - match Hashtbl.find cache dir with - | Some t -> t - | None -> - ignore (get sctx ~dir:(Path.parent_exn dir) : t); - (* Filled while scanning the group root *) - Hashtbl.find_exn cache dir - end - | Group_root (ft_dir, d) -> - let rec walk ft_dir ~dir acc = - match - Dir_status.DB.get dir_status_db ~dir - with - | Is_component_of_a_group_but_not_the_root d -> - let files = - match d with - | None -> File_tree.Dir.files ft_dir - | Some d -> load_text_files sctx ft_dir d - in - walk_children ft_dir ~dir ((dir, files) :: acc) - | _ -> acc - and walk_children ft_dir ~dir acc = - String.Map.foldi (File_tree.Dir.sub_dirs ft_dir) ~init:acc - ~f:(fun name ft_dir acc -> - let dir = Path.relative dir name in - walk ft_dir ~dir acc) + let subdirs = walk_children ft_dir ~dir [] in + files, subdirs) + in + let modules = Memo.lazy_ (fun () -> + let modules = + List.fold_left ((dir, files) :: subdirs) ~init:Module.Name.Map.empty + ~f:(fun acc (dir, files) -> + let modules = modules_of_files ~dir ~files in + Module.Name.Map.union acc modules ~f:(fun name x y -> + Errors.fail (Loc.in_file + (match File_tree.Dir.dune_file ft_dir with + | None -> + Path.relative (File_tree.Dir.path ft_dir) + "_unknown_" + | Some d -> File_tree.Dune_file.path d)) + "Module %a appears in several directories:\ + @\n- %a\ + @\n- %a" + Module.Name.pp_quote name + (Fmt.optional Path.pp) (Module.Source.src_dir x) + (Fmt.optional Path.pp) (Module.Source.src_dir y))) in - let files = load_text_files sctx ft_dir d in - let subdirs = walk_children ft_dir ~dir [] in - let modules = lazy ( - let modules = - List.fold_left ((dir, files) :: subdirs) ~init:Module.Name.Map.empty - ~f:(fun acc (dir, files) -> - let modules = modules_of_files ~dir ~files in - Module.Name.Map.union acc modules ~f:(fun name x y -> + Modules.make d ~modules) + in + let c_sources = Memo.lazy_ (fun () -> + let dune_version = d.dune_version in + let init = C.Kind.Dict.make String.Map.empty in + let c_sources = + List.fold_left ((dir, files) :: subdirs) ~init + ~f:(fun acc (dir, files) -> + let sources = C_sources.load_sources ~dir ~dune_version ~files in + let f acc sources = + String.Map.union acc sources ~f:(fun name x y -> Errors.fail (Loc.in_file (match File_tree.Dir.dune_file ft_dir with | None -> Path.relative (File_tree.Dir.path ft_dir) "_unknown_" | Some d -> File_tree.Dune_file.path d)) - "Module %a appears in several directories:\ + "%a file %s appears in several directories:\ @\n- %a\ - @\n- %a" - Module.Name.pp_quote name - (Fmt.optional Path.pp) (Module.Source.src_dir x) - (Fmt.optional Path.pp) (Module.Source.src_dir y))) - in - Modules.make d ~modules) + @\n- %a\ + @\nThis is not allowed, please rename one of them." + (C.Kind.pp) (C.Source.kind x) + name + Path.pp_in_source (C.Source.src_dir x) + Path.pp_in_source (C.Source.src_dir y)) + in + C.Kind.Dict.merge acc sources ~f) in - let c_sources = lazy ( - let dune_version = d.dune_version in - let init = C.Kind.Dict.make String.Map.empty in - let c_sources = - List.fold_left ((dir, files) :: subdirs) ~init - ~f:(fun acc (dir, files) -> - let sources = C_sources.load_sources ~dir ~dune_version ~files in - let f acc sources = - String.Map.union acc sources ~f:(fun name x y -> - Errors.fail (Loc.in_file - (match File_tree.Dir.dune_file ft_dir with - | None -> - Path.relative (File_tree.Dir.path ft_dir) - "_unknown_" - | Some d -> File_tree.Dune_file.path d)) - "%a file %s appears in several directories:\ - @\n- %a\ - @\n- %a\ - @\nThis is not allowed, please rename one of them." - (C.Kind.pp) (C.Source.kind x) - name - Path.pp_in_source (C.Source.src_dir x) - Path.pp_in_source (C.Source.src_dir y)) - in - C.Kind.Dict.merge acc sources ~f) - in - C_sources.make d ~c_sources - ) in - let t = - { kind = Group_root - (lazy (List.map subdirs ~f:(fun (dir, _) -> get sctx ~dir))) + C_sources.make d ~c_sources + ) in + let t = + { kind = Group_root + (Memo.lazy_ (fun () -> + List.map subdirs ~f:(fun (dir, _) -> + Fdecl.get get_without_rules_fdecl (sctx, dir) + ))) + ; dir + ; text_files = files + ; modules + ; c_sources + ; mlds = Memo.lazy_ (fun () -> build_mlds_map d ~files) + } + in + let + subdirs = + List.map subdirs ~f:(fun (dir, files) -> + dir, + { kind = Group_part t ; dir ; text_files = files ; modules ; c_sources - ; mlds = lazy (build_mlds_map d ~files) - } - in - Hashtbl.add cache dir t; - List.iter subdirs ~f:(fun (dir, files) -> - Hashtbl.add cache dir - { kind = Group_part t - ; dir - ; text_files = files - ; modules - ; c_sources - ; mlds = lazy (build_mlds_map d ~files) - }); - t + ; mlds = Memo.lazy_ (fun () -> (build_mlds_map d ~files)) + }) + |> Path.Map.of_list_exn + in + Here { + t; + rules; + subdirs; + } + +let memo0 = + let module Output = struct + type t = result0 + let to_sexp _ = Sexp.Atom "" + end + in + Memo.create + "dir-contents-memo0" + ~input:(module Key) + ~output:(Simple (module Output)) + ~doc:"dir contents" + ~visibility:Hidden + Sync + (Some get0_impl) + +type get_result = + | Standalone_or_root of t + | Group_part of Path.t + +let get key = + match Memo.exec memo0 key with + | See_above group_root -> + None, Group_part group_root + | Here { t; rules; subdirs = _ } -> + rules, Standalone_or_root t + +let get_without_rules key = + let _rules, res = get key in + match res with + | Standalone_or_root t -> t + | Group_part group_root -> + let (sctx, dir) = key in + match Memo.exec memo0 (sctx, group_root) with + | See_above _ -> assert false + | Here { t = _; rules; subdirs } -> + ignore rules; + Path.Map.find_exn subdirs dir + +let () = + Fdecl.set get_without_rules_fdecl + get_without_rules + +let get_without_rules sctx ~dir = get_without_rules (sctx, dir) + +let get sctx ~dir = + let rules, res = get (sctx, dir) in + (Memo.Implicit_output.produce_opt + Build_system.rule_collection_implicit_output + rules); + res diff --git a/src/dir_contents.mli b/src/dir_contents.mli index 7c466c7abea..6e7d4ec1e0b 100644 --- a/src/dir_contents.mli +++ b/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 diff --git a/src/gen_rules.ml b/src/gen_rules.ml index 3e08adedfd7..f2d4c82c60e 100644 --- a/src/gen_rules.ml +++ b/src/gen_rules.ml @@ -244,16 +244,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"]) diff --git a/src/install_rules.ml b/src/install_rules.ml index 9f45c2f9deb..9b8d9e3ecc2 100644 --- a/src/install_rules.ml +++ b/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 diff --git a/src/odoc.ml b/src/odoc.ml index 8cf47c531cf..abda7724bf4 100644 --- a/src/odoc.ml +++ b/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 diff --git a/src/packages.ml b/src/packages.ml index 778cf892800..6f1f09850c3 100644 --- a/src/packages.ml +++ b/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) | _ -> diff --git a/src/virtual_rules.ml b/src/virtual_rules.ml index 04b80eab0ce..b8aad0d515d 100644 --- a/src/virtual_rules.ml +++ b/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