From c9c2e90ce97de508759c7b379e36e9df8bff87b2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20Ch=C3=A1varri?= Date: Sun, 26 Feb 2023 19:36:39 +0000 Subject: [PATCH 1/9] perf: run parse_compilation_units once MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Javier Chávarri --- src/dune_rules/dep_rules.ml | 26 +++++++++++++++++++------- src/dune_rules/ocamldep.ml | 4 ++-- src/dune_rules/ocamldep.mli | 6 +++++- 3 files changed, 26 insertions(+), 10 deletions(-) diff --git a/src/dune_rules/dep_rules.ml b/src/dune_rules/dep_rules.ml index 1cbe6ed0d37..fb09ebce4a8 100644 --- a/src/dune_rules/dep_rules.ml +++ b/src/dune_rules/dep_rules.ml @@ -43,7 +43,7 @@ let ooi_deps { vimpl; sctx; dir; obj_dir; modules = _; stdlib = _; sandbox = _ } in read -let deps_of_module ({ modules; _ } as md) ~ml_kind m = +let deps_of_module ({ modules; _ } as md) ~ml_kind ~parse_compilation_units m = match Module.kind m with | Wrapped_compat -> let interface_module = @@ -53,7 +53,7 @@ let deps_of_module ({ modules; _ } as md) ~ml_kind m = in List.singleton interface_module |> Action_builder.return |> Memo.return | _ -> ( - let+ deps = Ocamldep.deps_of md ~ml_kind m in + let+ deps = Ocamldep.deps_of md ~ml_kind ~parse_compilation_units m in match Modules.alias_for modules m with | [] -> deps | aliases -> @@ -85,7 +85,8 @@ let deps_of_vlib_module ({ obj_dir; vimpl; dir; sctx; _ } as md) ~ml_kind m = in Ocamldep.read_deps_of ~obj_dir:vlib_obj_dir ~modules ~ml_kind m -let rec deps_of md ~ml_kind (m : Modules.Sourced_module.t) = +let rec deps_of md ~ml_kind ~parse_compilation_units + (m : Modules.Sourced_module.t) = let is_alias = match m with | Impl_of_virtual_module _ -> false @@ -103,9 +104,12 @@ let rec deps_of md ~ml_kind (m : Modules.Sourced_module.t) = match m with | Imported_from_vlib m -> skip_if_source_absent (deps_of_vlib_module md ~ml_kind) m - | Normal m -> skip_if_source_absent (deps_of_module md ~ml_kind) m + | Normal m -> + skip_if_source_absent + (deps_of_module md ~ml_kind ~parse_compilation_units) + m | Impl_of_virtual_module impl_or_vlib -> ( - deps_of md ~ml_kind + deps_of md ~ml_kind ~parse_compilation_units @@ let m = Ml_kind.Dict.get impl_or_vlib ml_kind in match ml_kind with @@ -135,7 +139,11 @@ let dict_of_func_concurrently f = Ml_kind.Dict.make ~impl ~intf let for_module md module_ = - dict_of_func_concurrently (deps_of md (Normal module_)) + let parse_compilation_units = + Ocamldep.parse_compilation_units ~modules:md.modules + in + dict_of_func_concurrently + (deps_of md ~parse_compilation_units (Normal module_)) let rules md = let modules = md.modules in @@ -144,6 +152,10 @@ let rules md = | None -> dict_of_func_concurrently (fun ~ml_kind -> let+ per_module = - Modules.obj_map_build modules ~f:(deps_of md ~ml_kind) + let parse_compilation_units = + Ocamldep.parse_compilation_units ~modules:md.modules + in + Modules.obj_map_build modules + ~f:(deps_of md ~ml_kind ~parse_compilation_units) in Dep_graph.make ~dir:md.dir ~per_module) diff --git a/src/dune_rules/ocamldep.ml b/src/dune_rules/ocamldep.ml index 92ebbb33b21..60f6921a101 100644 --- a/src/dune_rules/ocamldep.ml +++ b/src/dune_rules/ocamldep.ml @@ -70,7 +70,7 @@ let parse_deps_exn ~file lines = let deps_of ({ sandbox; modules; sctx; dir; obj_dir; vimpl = _; stdlib = _ } as md) - ~ml_kind unit = + ~ml_kind ~parse_compilation_units unit = let source = Option.value_exn (Module.source unit ~ml_kind) in let dep = Obj_dir.Module.dep obj_dir in let context = Super_context.context sctx in @@ -135,7 +135,7 @@ let deps_of in let all_deps_file = Path.build all_deps_file in Action_builder.lines_of all_deps_file - |> Action_builder.map ~f:(Staged.unstage @@ parse_compilation_units ~modules) + |> Action_builder.map ~f:(Staged.unstage @@ parse_compilation_units) |> Action_builder.memoize (Path.to_string all_deps_file) let read_deps_of ~obj_dir ~modules ~ml_kind unit = diff --git a/src/dune_rules/ocamldep.mli b/src/dune_rules/ocamldep.mli index 9ec16efcbcf..a504a089018 100644 --- a/src/dune_rules/ocamldep.mli +++ b/src/dune_rules/ocamldep.mli @@ -22,8 +22,9 @@ end val deps_of : Modules_data.t -> ml_kind:Ml_kind.t + -> parse_compilation_units:(string list -> 'a) Import.Staged.t -> Module.t - -> Module.t list Action_builder.t Memo.t + -> 'a Action_builder.t Memo.t val read_deps_of : obj_dir:Path.Build.t Obj_dir.t @@ -32,6 +33,9 @@ val read_deps_of : -> Module.t -> Module.t list Action_builder.t +val parse_compilation_units : + modules:Modules.t -> (string list -> Module.t list) Staged.t + (** [read_immediate_deps_of ~obj_dir ~modules ~ml_kind unit] returns the immediate dependencies found in the modules of [modules] for the file with kind [ml_kind] of the module [unit]. If there is no such file with kind From cbc36218cda05290497ddcb754e17f7ed6ded085 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20Ch=C3=A1varri?= Date: Tue, 28 Feb 2023 20:10:09 +0000 Subject: [PATCH 2/9] benchmark: run in branch MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Javier Chávarri --- .github/workflows/bench.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/bench.yml b/.github/workflows/bench.yml index 2038df6dc74..aa4a6cf0655 100644 --- a/.github/workflows/bench.yml +++ b/.github/workflows/bench.yml @@ -5,7 +5,7 @@ on: push: branches: - main - - bench/add-synthetic-benchmark + - perf/run-parse_compilation_units-once permissions: # deployments permission to deploy GitHub pages website From edf57240801025b4b31b09677ac5b267652075a8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20Ch=C3=A1varri?= Date: Wed, 1 Mar 2023 20:56:25 +0000 Subject: [PATCH 3/9] move unique_map to modules MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Javier Chávarri --- src/dune_rules/dep_rules.ml | 26 +--- src/dune_rules/modules.ml | 260 +++++++++++++++++++++--------------- src/dune_rules/modules.mli | 2 +- src/dune_rules/ocamldep.ml | 22 +-- src/dune_rules/ocamldep.mli | 6 +- src/dune_rules/vimpl.ml | 8 +- 6 files changed, 172 insertions(+), 152 deletions(-) diff --git a/src/dune_rules/dep_rules.ml b/src/dune_rules/dep_rules.ml index fb09ebce4a8..1cbe6ed0d37 100644 --- a/src/dune_rules/dep_rules.ml +++ b/src/dune_rules/dep_rules.ml @@ -43,7 +43,7 @@ let ooi_deps { vimpl; sctx; dir; obj_dir; modules = _; stdlib = _; sandbox = _ } in read -let deps_of_module ({ modules; _ } as md) ~ml_kind ~parse_compilation_units m = +let deps_of_module ({ modules; _ } as md) ~ml_kind m = match Module.kind m with | Wrapped_compat -> let interface_module = @@ -53,7 +53,7 @@ let deps_of_module ({ modules; _ } as md) ~ml_kind ~parse_compilation_units m = in List.singleton interface_module |> Action_builder.return |> Memo.return | _ -> ( - let+ deps = Ocamldep.deps_of md ~ml_kind ~parse_compilation_units m in + let+ deps = Ocamldep.deps_of md ~ml_kind m in match Modules.alias_for modules m with | [] -> deps | aliases -> @@ -85,8 +85,7 @@ let deps_of_vlib_module ({ obj_dir; vimpl; dir; sctx; _ } as md) ~ml_kind m = in Ocamldep.read_deps_of ~obj_dir:vlib_obj_dir ~modules ~ml_kind m -let rec deps_of md ~ml_kind ~parse_compilation_units - (m : Modules.Sourced_module.t) = +let rec deps_of md ~ml_kind (m : Modules.Sourced_module.t) = let is_alias = match m with | Impl_of_virtual_module _ -> false @@ -104,12 +103,9 @@ let rec deps_of md ~ml_kind ~parse_compilation_units match m with | Imported_from_vlib m -> skip_if_source_absent (deps_of_vlib_module md ~ml_kind) m - | Normal m -> - skip_if_source_absent - (deps_of_module md ~ml_kind ~parse_compilation_units) - m + | Normal m -> skip_if_source_absent (deps_of_module md ~ml_kind) m | Impl_of_virtual_module impl_or_vlib -> ( - deps_of md ~ml_kind ~parse_compilation_units + deps_of md ~ml_kind @@ let m = Ml_kind.Dict.get impl_or_vlib ml_kind in match ml_kind with @@ -139,11 +135,7 @@ let dict_of_func_concurrently f = Ml_kind.Dict.make ~impl ~intf let for_module md module_ = - let parse_compilation_units = - Ocamldep.parse_compilation_units ~modules:md.modules - in - dict_of_func_concurrently - (deps_of md ~parse_compilation_units (Normal module_)) + dict_of_func_concurrently (deps_of md (Normal module_)) let rules md = let modules = md.modules in @@ -152,10 +144,6 @@ let rules md = | None -> dict_of_func_concurrently (fun ~ml_kind -> let+ per_module = - let parse_compilation_units = - Ocamldep.parse_compilation_units ~modules:md.modules - in - Modules.obj_map_build modules - ~f:(deps_of md ~ml_kind ~parse_compilation_units) + Modules.obj_map_build modules ~f:(deps_of md ~ml_kind) in Dep_graph.make ~dir:md.dir ~per_module) diff --git a/src/dune_rules/modules.ml b/src/dune_rules/modules.ml index b7980569c60..147379669e5 100644 --- a/src/dune_rules/modules.ml +++ b/src/dune_rules/modules.ml @@ -730,6 +730,11 @@ module Wrapped = struct end type t = + { unique_map : Module.t Module_name.Unique.Map.t Lazy.t + ; modules : modules + } + +and modules = | Singleton of Module.t | Unwrapped of Unwrapped.t | Wrapped of Wrapped.t @@ -741,39 +746,93 @@ and impl = ; vlib : t } +module Sourced_module = struct + type t = + | Normal of Module.t + | Imported_from_vlib of Module.t + | Impl_of_virtual_module of Module.t Ml_kind.Dict.t +end + +let rec obj_map : + 'a. modules -> f:(Sourced_module.t -> 'a) -> 'a Module.Obj_map.t = + fun t ~f -> + let normal m = f (Sourced_module.Normal m) in + match t with + | Singleton m -> Module.Obj_map.add_exn Module.Obj_map.empty m (normal m) + | Unwrapped m -> Unwrapped.obj_map m ~f:normal + | Wrapped w -> Wrapped.obj_map w ~f:normal + | Stdlib w -> Stdlib.obj_map w ~f:normal + | Impl { vlib; impl } -> + Module.Obj_map.merge (obj_map vlib.modules ~f:Fun.id) + (obj_map impl.modules ~f:Fun.id) ~f:(fun _ vlib impl -> + match (vlib, impl) with + | None, None -> assert false + | Some (Normal m), None -> + Some (f (Sourced_module.Imported_from_vlib m)) + | None, Some (Normal m) -> Some (f (Normal m)) + | Some (Normal intf), Some (Normal impl) -> + Some (f (Sourced_module.Impl_of_virtual_module { intf; impl })) + | Some (Imported_from_vlib _ | Impl_of_virtual_module _), _ + | _, Some (Imported_from_vlib _ | Impl_of_virtual_module _) -> + assert false) + +let unique_map modules = + obj_map modules ~f:(function + | Sourced_module.Normal m -> m + | Imported_from_vlib m -> m + | Impl_of_virtual_module { intf = _; impl } -> impl) + |> Module.Obj_map.to_list_map ~f:(fun m _ -> (Module.obj_name m, m)) + |> Module_name.Unique.Map.of_list_exn + +let obj_map_build : + 'a. t -> f:(Sourced_module.t -> 'a Memo.t) -> 'a Module.Obj_map.t Memo.t = + fun t ~f -> + Module.Obj_map_traversals.parallel_map (obj_map t.modules ~f) ~f:(fun _ x -> + x) + +let with_unique_map modules = + let unique_map = lazy (unique_map modules) in + { unique_map; modules } + +let unique_map t = Lazy.force t.unique_map + let equal (x : t) (y : t) = Poly.equal x y let rec encode t ~src_dir = let open Dune_lang in - match t with + match t.modules with | Singleton m -> List (atom "singleton" :: Module.encode m ~src_dir) | Unwrapped m -> List (atom "unwrapped" :: Unwrapped.encode m ~src_dir) | Wrapped m -> List (atom "wrapped" :: Wrapped.encode m ~src_dir) | Stdlib m -> List (atom "stdlib" :: Stdlib.encode m ~src_dir) | Impl { impl; _ } -> encode impl ~src_dir -let singleton m = Singleton m +let singleton m = with_unique_map (Singleton m) let decode ~src_dir = let open Dune_lang.Decoder in sum [ ( "singleton" , let+ m = Module.decode ~src_dir in - Singleton m ) + let modules = Singleton m in + with_unique_map modules ) ; ( "unwrapped" , let+ modules = Unwrapped.decode ~src_dir in - Unwrapped modules ) + let modules = Unwrapped modules in + with_unique_map modules ) ; ( "wrapped" , let+ w = Wrapped.decode ~src_dir in - Wrapped w ) + let modules = Wrapped w in + with_unique_map modules ) ; ( "stdlib" , let+ stdlib = Stdlib.decode ~src_dir in - Stdlib stdlib ) + let modules = Stdlib stdlib in + with_unique_map modules ) ] -let rec to_dyn = +let rec to_dyn t = let open Dyn in - function + match t.modules with | Singleton m -> variant "Singleton" [ Module.to_dyn m ] | Unwrapped m -> variant "Unwrapped" [ Unwrapped.to_dyn m ] | Wrapped w -> variant "Wrapped" [ Wrapped.to_dyn w ] @@ -784,14 +843,16 @@ and dyn_of_impl { impl; vlib } = let open Dyn in record [ ("impl", to_dyn impl); ("vlib", to_dyn vlib) ] -let rec lib_interface = function +let rec lib_interface t = + match t.modules with | Singleton m -> Some m | Unwrapped _ -> None | Wrapped w -> Some (Wrapped.lib_interface w) | Stdlib w -> Stdlib.lib_interface w | Impl { impl = _; vlib } -> lib_interface vlib -let rec main_module_name = function +let rec main_module_name t = + match t.modules with | Singleton m -> Some (Module.name m) | Unwrapped _ -> None | Wrapped w -> Some w.group.name @@ -805,34 +866,40 @@ let lib ~obj_dir ~main_module_name ~wrapped ~stdlib ~lib_name ~implements (Wrapped.make ~obj_dir ~lib_name ~implements ~modules ~main_module_name ~wrapped) in - match stdlib with - | Some stdlib -> - let main_module_name = Option.value_exn main_module_name in - let modules = Module_trie.to_map modules in - Stdlib (Stdlib.make ~stdlib ~modules ~wrapped ~main_module_name) - | None -> ( - match (wrapped, main_module_name, Module_trie.as_singleton modules) with - | Simple false, _, Some m -> Singleton m - | Simple false, _, None -> - let mangle = Mangle.Unwrapped in - Unwrapped (Unwrapped.of_trie modules ~mangle ~obj_dir) - | (Yes_with_transition _ | Simple true), Some main_module_name, Some m -> - if Module.name m = main_module_name && not implements then Singleton m - else make_wrapped main_module_name - | (Yes_with_transition _ | Simple true), Some main_module_name, None -> - make_wrapped main_module_name - | (Simple true | Yes_with_transition _), None, _ -> - Code_error.raise "Modules.lib: cannot wrap without main module name" []) + let modules = + match stdlib with + | Some stdlib -> + let main_module_name = Option.value_exn main_module_name in + let modules = Module_trie.to_map modules in + Stdlib (Stdlib.make ~stdlib ~modules ~wrapped ~main_module_name) + | None -> ( + match (wrapped, main_module_name, Module_trie.as_singleton modules) with + | Simple false, _, Some m -> Singleton m + | Simple false, _, None -> + let mangle = Mangle.Unwrapped in + Unwrapped (Unwrapped.of_trie modules ~mangle ~obj_dir) + | (Yes_with_transition _ | Simple true), Some main_module_name, Some m -> + if Module.name m = main_module_name && not implements then Singleton m + else make_wrapped main_module_name + | (Yes_with_transition _ | Simple true), Some main_module_name, None -> + make_wrapped main_module_name + | (Simple true | Yes_with_transition _), None, _ -> + Code_error.raise "Modules.lib: cannot wrap without main module name" []) + in + with_unique_map modules let impl impl ~vlib = - match (impl, vlib) with - | _, Impl _ | Impl _, _ | Stdlib _, _ | _, Stdlib _ -> - Code_error.raise "Modules.impl: invalid arguments" - [ ("impl", to_dyn impl); ("vlib", to_dyn vlib) ] - | _, _ -> Impl { impl; vlib } + let modules = + match (impl.modules, vlib.modules) with + | _, Impl _ | Impl _, _ | Stdlib _, _ | _, Stdlib _ -> + Code_error.raise "Modules.impl: invalid arguments" + [ ("impl", to_dyn impl); ("vlib", to_dyn vlib) ] + | _, _ -> Impl { impl; vlib } + in + with_unique_map modules let rec find t name = - match t with + match t.modules with | Singleton m -> Option.some_if (Module.name m = name) m | Unwrapped m -> Unwrapped.find m name | Stdlib w -> Stdlib.find w name @@ -856,7 +923,7 @@ let find_dep = if Module.name of_ = name then [] else let result = - match t with + match t.modules with | Unwrapped w -> ( match Unwrapped.find_dep w ~of_ name with | Ok s -> from_impl_or_lib s @@ -881,16 +948,20 @@ let find_dep = | exception Parent_cycle -> Error `Parent_cycle let make_singleton m mangle = - Singleton - (let name = Module.name m in - let m = Module.set_path m [ name ] in - Mangle.wrap_module mangle m ~interface:None) + let modules = + Singleton + (let name = Module.name m in + let m = Module.set_path m [ name ] in + Mangle.wrap_module mangle m ~interface:None) + in + with_unique_map modules let singleton_exe m = make_singleton m Exe let exe_unwrapped modules ~obj_dir = let mangle = Mangle.Unwrapped in - Unwrapped (Unwrapped.of_trie modules ~mangle ~obj_dir) + let modules = Unwrapped (Unwrapped.of_trie modules ~mangle ~obj_dir) in + with_unique_map modules let make_wrapped ~obj_dir ~modules kind = let mangle : Mangle.t = @@ -900,9 +971,14 @@ let make_wrapped ~obj_dir ~modules kind = in match Module_trie.as_singleton modules with | Some m -> make_singleton m mangle - | None -> Wrapped (Wrapped.make_exe_or_melange ~obj_dir ~modules mangle) + | None -> + let modules = + Wrapped (Wrapped.make_exe_or_melange ~obj_dir ~modules mangle) + in + with_unique_map modules -let rec impl_only = function +let rec impl_only t = + match t.modules with | Stdlib w -> Stdlib.impl_only w | Singleton m -> if Module.has ~ml_kind:Impl m then [ m ] else [] | Unwrapped m -> @@ -912,7 +988,7 @@ let rec impl_only = function | Impl { vlib; impl } -> impl_only impl @ impl_only vlib let rec exists t ~f = - match t with + match t.modules with | Stdlib w -> Stdlib.exists w ~f | Wrapped m -> Wrapped.exists m ~f | Singleton m -> f m @@ -924,7 +1000,7 @@ let has_impl = exists ~f:has let rec fold_no_vlib t ~init ~f = - match t with + match t.modules with | Stdlib w -> Stdlib.fold w ~init ~f | Singleton m -> f m init | Unwrapped m -> Unwrapped.fold m ~f ~init @@ -933,7 +1009,7 @@ let rec fold_no_vlib t ~init ~f = let fold_no_vlib_with_aliases = let rec group_of_alias t m = - match t with + match t.modules with | Wrapped w -> Some (Wrapped.group_of_alias w m) | Unwrapped w -> Some (Unwrapped.group_of_alias w m) | Impl { vlib; impl } -> ( @@ -980,7 +1056,7 @@ type split_by_lib = let split_by_lib t = let f m acc = m :: acc in let init = [] in - match t with + match t.modules with | Impl { vlib; impl } -> let vlib = fold_no_vlib vlib ~init ~f in let impl = fold_no_vlib impl ~init ~f in @@ -988,7 +1064,7 @@ let split_by_lib t = | _ -> { impl = fold_no_vlib t ~init ~f; vlib = [] } let compat_for_exn t m = - match t with + match t.modules with | Singleton _ | Stdlib _ | Unwrapped _ -> assert false | Impl _ -> Code_error.raise "wrapped compat not supported for vlib" [] | Wrapped { group; _ } -> ( @@ -997,12 +1073,13 @@ let compat_for_exn t m = | Some (Module m) -> m | Some (Group g) -> Group.lib_interface g) -let wrapped_compat = function +let wrapped_compat t = + match t.modules with | Stdlib _ | Singleton _ | Impl _ | Unwrapped _ -> Module_name.Map.empty | Wrapped w -> w.wrapped_compat let rec fold_user_available t ~f ~init = - match t with + match t.modules with | Stdlib w -> Stdlib.fold w ~init ~f | Singleton m -> f m init | Unwrapped modules -> Unwrapped.fold modules ~init ~f @@ -1018,7 +1095,7 @@ let is_user_written m = let rec fold_user_written t ~f ~init = let f m acc = if is_user_written m then f m acc else acc in - match t with + match t.modules with | Stdlib w -> Stdlib.fold w ~init ~f | Singleton m -> f m init | Unwrapped modules -> Unwrapped.fold modules ~init ~f @@ -1028,73 +1105,40 @@ let rec fold_user_written t ~f ~init = let rec map_user_written t ~f = let f m = if is_user_written m then f m else Memo.return m in let open Memo.O in - match t with + match t.modules with | Singleton m -> let+ res = f m in - Singleton res + with_unique_map (Singleton res) | Unwrapped m -> let+ res = Unwrapped.Memo_traversals.parallel_map m ~f in - Unwrapped res + with_unique_map (Unwrapped res) | Stdlib w -> let+ res = Stdlib.traverse w ~f in - Stdlib res + with_unique_map (Stdlib res) | Wrapped ({ group; wrapped_compat = _; wrapped = _; toplevel_module = _ } as w) -> let+ group = Group.Memo_traversals.parallel_map group ~f in - Wrapped { w with group } + with_unique_map (Wrapped { w with group }) | Impl t -> - let+ vlib = map_user_written t.vlib ~f in - Impl { t with vlib } + let+ modules = map_user_written t.vlib ~f in + with_unique_map (Impl { t with vlib = modules }) let version_installed t ~src_root ~install_dir = let f = Module.version_installed ~src_root ~install_dir in - let rec loop = function - | Singleton m -> Singleton (f m) - | Unwrapped m -> Unwrapped (Unwrapped.map ~f m) - | Stdlib w -> Stdlib (Stdlib.map w ~f) - | Wrapped w -> Wrapped (Wrapped.map w ~f) - | Impl w -> Impl { w with impl = loop w.impl } + let rec loop t = + match t.modules with + | Singleton m -> with_unique_map (Singleton (f m)) + | Unwrapped m -> with_unique_map (Unwrapped (Unwrapped.map ~f m)) + | Stdlib w -> with_unique_map (Stdlib (Stdlib.map w ~f)) + | Wrapped w -> with_unique_map (Wrapped (Wrapped.map w ~f)) + | Impl w -> with_unique_map (Impl { w with impl = loop w.impl }) in loop t -module Sourced_module = struct - type t = - | Normal of Module.t - | Imported_from_vlib of Module.t - | Impl_of_virtual_module of Module.t Ml_kind.Dict.t -end - -let rec obj_map : 'a. t -> f:(Sourced_module.t -> 'a) -> 'a Module.Obj_map.t = - fun t ~f -> - let normal m = f (Sourced_module.Normal m) in - match t with - | Singleton m -> Module.Obj_map.add_exn Module.Obj_map.empty m (normal m) - | Unwrapped m -> Unwrapped.obj_map m ~f:normal - | Wrapped w -> Wrapped.obj_map w ~f:normal - | Stdlib w -> Stdlib.obj_map w ~f:normal - | Impl { vlib; impl } -> - Module.Obj_map.merge (obj_map vlib ~f:Fun.id) (obj_map impl ~f:Fun.id) - ~f:(fun _ vlib impl -> - match (vlib, impl) with - | None, None -> assert false - | Some (Normal m), None -> - Some (f (Sourced_module.Imported_from_vlib m)) - | None, Some (Normal m) -> Some (f (Normal m)) - | Some (Normal intf), Some (Normal impl) -> - Some (f (Sourced_module.Impl_of_virtual_module { intf; impl })) - | Some (Imported_from_vlib _ | Impl_of_virtual_module _), _ - | _, Some (Imported_from_vlib _ | Impl_of_virtual_module _) -> - assert false) - -let obj_map_build : - 'a. t -> f:(Sourced_module.t -> 'a Memo.t) -> 'a Module.Obj_map.t Memo.t = - fun t ~f -> - Module.Obj_map_traversals.parallel_map (obj_map t ~f) ~f:(fun _ x -> x) - let entry_modules t = List.filter ~f:(fun m -> Module.visibility m = Public) - (match t with + (match t.modules with | Stdlib w -> Stdlib.lib_interface w |> Option.to_list | Singleton m -> [ m ] | Unwrapped m -> Unwrapped.entry_modules m @@ -1111,7 +1155,8 @@ let virtual_module_names = | Virtual -> Module_name.Path.Set.add acc [ Module.name m ] | _ -> acc) -let rec wrapped = function +let rec wrapped t = + match t.modules with | Wrapped w -> w.wrapped | Singleton _ | Unwrapped _ -> Simple false | Stdlib _ -> Simple true @@ -1121,7 +1166,7 @@ let rec alias_for t m = match Module.kind m with | Root -> [] | _ -> ( - match t with + match t.modules with | Singleton _ -> [] | Unwrapped w -> Unwrapped.alias_for w m | Wrapped w -> Wrapped.alias_for w m @@ -1129,7 +1174,7 @@ let rec alias_for t m = | Impl { impl; vlib = _ } -> alias_for impl m) let rec group_interfaces t m = - match t with + match t.modules with | Wrapped w -> Wrapped.group_interfaces w m | Impl { impl; vlib } -> group_interfaces impl m @ group_interfaces vlib m | Singleton w -> [ w ] @@ -1141,15 +1186,17 @@ let local_open t m = Module.obj_name m |> Module_name.Unique.to_name ~loc:Loc.none) let is_stdlib_alias t m = - match t with + match t.modules with | Stdlib w -> w.main_module_name = Module.name m | _ -> false -let exit_module = function +let exit_module t = + match t.modules with | Stdlib w -> Stdlib.exit_module w | _ -> None -let as_singleton = function +let as_singleton t = + match t.modules with | Singleton m -> Some m | _ -> None @@ -1171,6 +1218,7 @@ let canonical_path t (group : Group.t) m = For example: foo/foo.ml would has the path [ "Foo"; "Foo" ] *) List.remove_last_exn path in - match t with - | Impl { impl = Wrapped w; _ } | Wrapped w -> w.group.name :: path + match t.modules with + | Impl { impl = { modules = Wrapped w; _ }; _ } | Wrapped w -> + w.group.name :: path | _ -> Module.path m diff --git a/src/dune_rules/modules.mli b/src/dune_rules/modules.mli index eb471655f64..fac6310ac59 100644 --- a/src/dune_rules/modules.mli +++ b/src/dune_rules/modules.mli @@ -92,7 +92,7 @@ module Sourced_module : sig | Impl_of_virtual_module of Module.t Ml_kind.Dict.t end -val obj_map : t -> f:(Sourced_module.t -> 'a) -> 'a Module.Obj_map.t +val unique_map : t -> Module.t Module_name.Unique.Map.t val obj_map_build : t -> f:(Sourced_module.t -> 'a Memo.t) -> 'a Module.Obj_map.t Memo.t diff --git a/src/dune_rules/ocamldep.ml b/src/dune_rules/ocamldep.ml index 60f6921a101..5dcfac8ee25 100644 --- a/src/dune_rules/ocamldep.ml +++ b/src/dune_rules/ocamldep.ml @@ -35,18 +35,10 @@ let parse_module_names ~dir ~(unit : Module.t) ~modules words = ]) let parse_compilation_units ~modules = - let obj_map = - Modules.obj_map modules ~f:(function - | Normal m -> m - | Imported_from_vlib m -> m - | Impl_of_virtual_module { intf = _; impl } -> impl) - |> Module.Obj_map.to_list_map ~f:(fun m _ -> (Module.obj_name m, m)) - |> Module_name.Unique.Map.of_list_exn - in - Staged.stage - (List.filter_map ~f:(fun m -> - let obj_name = Module_name.Unique.of_string m in - Module_name.Unique.Map.find obj_map obj_name)) + let unique_map = Modules.unique_map modules in + List.filter_map ~f:(fun m -> + let obj_name = Module_name.Unique.of_string m in + Module_name.Unique.Map.find unique_map obj_name) let parse_deps_exn ~file lines = let invalid () = @@ -70,7 +62,7 @@ let parse_deps_exn ~file lines = let deps_of ({ sandbox; modules; sctx; dir; obj_dir; vimpl = _; stdlib = _ } as md) - ~ml_kind ~parse_compilation_units unit = + ~ml_kind unit = let source = Option.value_exn (Module.source unit ~ml_kind) in let dep = Obj_dir.Module.dep obj_dir in let context = Super_context.context sctx in @@ -135,13 +127,13 @@ let deps_of in let all_deps_file = Path.build all_deps_file in Action_builder.lines_of all_deps_file - |> Action_builder.map ~f:(Staged.unstage @@ parse_compilation_units) + |> Action_builder.map ~f:(parse_compilation_units ~modules) |> Action_builder.memoize (Path.to_string all_deps_file) let read_deps_of ~obj_dir ~modules ~ml_kind unit = let all_deps_file = Obj_dir.Module.dep obj_dir (Transitive (unit, ml_kind)) in Action_builder.lines_of (Path.build all_deps_file) - |> Action_builder.map ~f:(Staged.unstage @@ parse_compilation_units ~modules) + |> Action_builder.map ~f:(parse_compilation_units ~modules) |> Action_builder.memoize (Path.Build.to_string all_deps_file) let read_immediate_deps_of ~obj_dir ~modules ~ml_kind unit = diff --git a/src/dune_rules/ocamldep.mli b/src/dune_rules/ocamldep.mli index a504a089018..40224f9325a 100644 --- a/src/dune_rules/ocamldep.mli +++ b/src/dune_rules/ocamldep.mli @@ -22,9 +22,8 @@ end val deps_of : Modules_data.t -> ml_kind:Ml_kind.t - -> parse_compilation_units:(string list -> 'a) Import.Staged.t -> Module.t - -> 'a Action_builder.t Memo.t + -> Module.t list Action_builder.t Memo.t val read_deps_of : obj_dir:Path.Build.t Obj_dir.t @@ -33,8 +32,7 @@ val read_deps_of : -> Module.t -> Module.t list Action_builder.t -val parse_compilation_units : - modules:Modules.t -> (string list -> Module.t list) Staged.t +val parse_compilation_units : modules:Modules.t -> string list -> Module.t list (** [read_immediate_deps_of ~obj_dir ~modules ~ml_kind unit] returns the immediate dependencies found in the modules of [modules] for the file with diff --git a/src/dune_rules/vimpl.ml b/src/dune_rules/vimpl.ml index bcdc1de521e..2afead4be44 100644 --- a/src/dune_rules/vimpl.ml +++ b/src/dune_rules/vimpl.ml @@ -30,13 +30,7 @@ let make ~vlib ~impl ~vlib_modules ~vlib_foreign_objects = in Mode.cm_kind (if byte then Byte else Native) in - let vlib_obj_map = - Modules.obj_map vlib_modules ~f:(function - | Normal m -> m - | _ -> assert false) - |> Module.Obj_map.fold ~init:Module_name.Unique.Map.empty ~f:(fun m acc -> - Module_name.Unique.Map.add_exn acc (Module.obj_name m) m) - in + let vlib_obj_map = Modules.unique_map vlib_modules in { impl; impl_cm_kind; vlib; vlib_modules; vlib_foreign_objects; vlib_obj_map } let vlib_stubs_o_files = function From 9595e7084a6e091bb252ef8f48eaec42fdd33fdc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20Ch=C3=A1varri?= Date: Wed, 1 Mar 2023 21:12:57 +0000 Subject: [PATCH 4/9] update Modules.equal MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Javier Chávarri --- src/dune_rules/modules.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/dune_rules/modules.ml b/src/dune_rules/modules.ml index 147379669e5..a0f8a2373ff 100644 --- a/src/dune_rules/modules.ml +++ b/src/dune_rules/modules.ml @@ -796,7 +796,7 @@ let with_unique_map modules = let unique_map t = Lazy.force t.unique_map -let equal (x : t) (y : t) = Poly.equal x y +let equal (x : t) (y : t) = Poly.equal x.modules y.modules let rec encode t ~src_dir = let open Dune_lang in From 955fab5f9bced5987da8265b16f4ca2bcafcfd03 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20Ch=C3=A1varri?= Date: Thu, 2 Mar 2023 15:43:20 +0000 Subject: [PATCH 5/9] refactor: simplify Modules.obj_map MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Javier Chávarri --- src/dune_rules/modules.ml | 132 +++++++++++++++++++----------------- src/dune_rules/modules.mli | 2 +- src/dune_rules/ocamldep.ml | 4 +- src/dune_rules/ocamldep.mli | 2 - src/dune_rules/vimpl.ml | 6 +- 5 files changed, 74 insertions(+), 72 deletions(-) diff --git a/src/dune_rules/modules.ml b/src/dune_rules/modules.ml index a0f8a2373ff..50febe315d0 100644 --- a/src/dune_rules/modules.ml +++ b/src/dune_rules/modules.ml @@ -730,7 +730,7 @@ module Wrapped = struct end type t = - { unique_map : Module.t Module_name.Unique.Map.t Lazy.t + { obj_map : Module.t Module_name.Unique.Map.t Lazy.t ; modules : modules } @@ -753,7 +753,7 @@ module Sourced_module = struct | Impl_of_virtual_module of Module.t Ml_kind.Dict.t end -let rec obj_map : +let rec obj_map' : 'a. modules -> f:(Sourced_module.t -> 'a) -> 'a Module.Obj_map.t = fun t ~f -> let normal m = f (Sourced_module.Normal m) in @@ -763,8 +763,8 @@ let rec obj_map : | Wrapped w -> Wrapped.obj_map w ~f:normal | Stdlib w -> Stdlib.obj_map w ~f:normal | Impl { vlib; impl } -> - Module.Obj_map.merge (obj_map vlib.modules ~f:Fun.id) - (obj_map impl.modules ~f:Fun.id) ~f:(fun _ vlib impl -> + Module.Obj_map.merge (obj_map' vlib.modules ~f:Fun.id) + (obj_map' impl.modules ~f:Fun.id) ~f:(fun _ vlib impl -> match (vlib, impl) with | None, None -> assert false | Some (Normal m), None -> @@ -776,25 +776,25 @@ let rec obj_map : | _, Some (Imported_from_vlib _ | Impl_of_virtual_module _) -> assert false) -let unique_map modules = - obj_map modules ~f:(function +let obj_map_build : + 'a. t -> f:(Sourced_module.t -> 'a Memo.t) -> 'a Module.Obj_map.t Memo.t = + fun t ~f -> + Module.Obj_map_traversals.parallel_map (obj_map' t.modules ~f) ~f:(fun _ x -> + x) + +let obj_map modules = + obj_map' modules ~f:(function | Sourced_module.Normal m -> m | Imported_from_vlib m -> m | Impl_of_virtual_module { intf = _; impl } -> impl) |> Module.Obj_map.to_list_map ~f:(fun m _ -> (Module.obj_name m, m)) |> Module_name.Unique.Map.of_list_exn -let obj_map_build : - 'a. t -> f:(Sourced_module.t -> 'a Memo.t) -> 'a Module.Obj_map.t Memo.t = - fun t ~f -> - Module.Obj_map_traversals.parallel_map (obj_map t.modules ~f) ~f:(fun _ x -> - x) - -let with_unique_map modules = - let unique_map = lazy (unique_map modules) in - { unique_map; modules } +let with_obj_map modules = + let obj_map = lazy (obj_map modules) in + { obj_map; modules } -let unique_map t = Lazy.force t.unique_map +let obj_map t = Lazy.force t.obj_map let equal (x : t) (y : t) = Poly.equal x.modules y.modules @@ -807,28 +807,27 @@ let rec encode t ~src_dir = | Stdlib m -> List (atom "stdlib" :: Stdlib.encode m ~src_dir) | Impl { impl; _ } -> encode impl ~src_dir -let singleton m = with_unique_map (Singleton m) +let singleton m = with_obj_map (Singleton m) let decode ~src_dir = let open Dune_lang.Decoder in - sum - [ ( "singleton" - , let+ m = Module.decode ~src_dir in - let modules = Singleton m in - with_unique_map modules ) - ; ( "unwrapped" - , let+ modules = Unwrapped.decode ~src_dir in - let modules = Unwrapped modules in - with_unique_map modules ) - ; ( "wrapped" - , let+ w = Wrapped.decode ~src_dir in - let modules = Wrapped w in - with_unique_map modules ) - ; ( "stdlib" - , let+ stdlib = Stdlib.decode ~src_dir in - let modules = Stdlib stdlib in - with_unique_map modules ) - ] + let+ modules = + sum + [ ( "singleton" + , let+ m = Module.decode ~src_dir in + Singleton m ) + ; ( "unwrapped" + , let+ modules = Unwrapped.decode ~src_dir in + Unwrapped modules ) + ; ( "wrapped" + , let+ w = Wrapped.decode ~src_dir in + Wrapped w ) + ; ( "stdlib" + , let+ stdlib = Stdlib.decode ~src_dir in + Stdlib stdlib ) + ] + in + with_obj_map modules let rec to_dyn t = let open Dyn in @@ -886,7 +885,7 @@ let lib ~obj_dir ~main_module_name ~wrapped ~stdlib ~lib_name ~implements | (Simple true | Yes_with_transition _), None, _ -> Code_error.raise "Modules.lib: cannot wrap without main module name" []) in - with_unique_map modules + with_obj_map modules let impl impl ~vlib = let modules = @@ -896,7 +895,7 @@ let impl impl ~vlib = [ ("impl", to_dyn impl); ("vlib", to_dyn vlib) ] | _, _ -> Impl { impl; vlib } in - with_unique_map modules + with_obj_map modules let rec find t name = match t.modules with @@ -954,14 +953,14 @@ let make_singleton m mangle = let m = Module.set_path m [ name ] in Mangle.wrap_module mangle m ~interface:None) in - with_unique_map modules + with_obj_map modules let singleton_exe m = make_singleton m Exe let exe_unwrapped modules ~obj_dir = let mangle = Mangle.Unwrapped in let modules = Unwrapped (Unwrapped.of_trie modules ~mangle ~obj_dir) in - with_unique_map modules + with_obj_map modules let make_wrapped ~obj_dir ~modules kind = let mangle : Mangle.t = @@ -975,7 +974,7 @@ let make_wrapped ~obj_dir ~modules kind = let modules = Wrapped (Wrapped.make_exe_or_melange ~obj_dir ~modules mangle) in - with_unique_map modules + with_obj_map modules let rec impl_only t = match t.modules with @@ -1105,33 +1104,40 @@ let rec fold_user_written t ~f ~init = let rec map_user_written t ~f = let f m = if is_user_written m then f m else Memo.return m in let open Memo.O in - match t.modules with - | Singleton m -> - let+ res = f m in - with_unique_map (Singleton res) - | Unwrapped m -> - let+ res = Unwrapped.Memo_traversals.parallel_map m ~f in - with_unique_map (Unwrapped res) - | Stdlib w -> - let+ res = Stdlib.traverse w ~f in - with_unique_map (Stdlib res) - | Wrapped - ({ group; wrapped_compat = _; wrapped = _; toplevel_module = _ } as w) -> - let+ group = Group.Memo_traversals.parallel_map group ~f in - with_unique_map (Wrapped { w with group }) - | Impl t -> - let+ modules = map_user_written t.vlib ~f in - with_unique_map (Impl { t with vlib = modules }) + let+ modules = + match t.modules with + | Singleton m -> + let+ res = f m in + Singleton res + | Unwrapped m -> + let+ res = Unwrapped.Memo_traversals.parallel_map m ~f in + Unwrapped res + | Stdlib w -> + let+ res = Stdlib.traverse w ~f in + Stdlib res + | Wrapped + ({ group; wrapped_compat = _; wrapped = _; toplevel_module = _ } as w) + -> + let+ group = Group.Memo_traversals.parallel_map group ~f in + Wrapped { w with group } + | Impl t -> + let+ modules = map_user_written t.vlib ~f in + Impl { t with vlib = modules } + in + with_obj_map modules let version_installed t ~src_root ~install_dir = let f = Module.version_installed ~src_root ~install_dir in let rec loop t = - match t.modules with - | Singleton m -> with_unique_map (Singleton (f m)) - | Unwrapped m -> with_unique_map (Unwrapped (Unwrapped.map ~f m)) - | Stdlib w -> with_unique_map (Stdlib (Stdlib.map w ~f)) - | Wrapped w -> with_unique_map (Wrapped (Wrapped.map w ~f)) - | Impl w -> with_unique_map (Impl { w with impl = loop w.impl }) + let modules = + match t.modules with + | Singleton m -> Singleton (f m) + | Unwrapped m -> Unwrapped (Unwrapped.map ~f m) + | Stdlib w -> Stdlib (Stdlib.map w ~f) + | Wrapped w -> Wrapped (Wrapped.map w ~f) + | Impl w -> Impl { w with impl = loop w.impl } + in + with_obj_map modules in loop t diff --git a/src/dune_rules/modules.mli b/src/dune_rules/modules.mli index fac6310ac59..cf555ea212e 100644 --- a/src/dune_rules/modules.mli +++ b/src/dune_rules/modules.mli @@ -92,7 +92,7 @@ module Sourced_module : sig | Impl_of_virtual_module of Module.t Ml_kind.Dict.t end -val unique_map : t -> Module.t Module_name.Unique.Map.t +val obj_map : t -> Module.t Module_name.Unique.Map.t val obj_map_build : t -> f:(Sourced_module.t -> 'a Memo.t) -> 'a Module.Obj_map.t Memo.t diff --git a/src/dune_rules/ocamldep.ml b/src/dune_rules/ocamldep.ml index 5dcfac8ee25..30b0f2d2568 100644 --- a/src/dune_rules/ocamldep.ml +++ b/src/dune_rules/ocamldep.ml @@ -35,10 +35,10 @@ let parse_module_names ~dir ~(unit : Module.t) ~modules words = ]) let parse_compilation_units ~modules = - let unique_map = Modules.unique_map modules in + let obj_map = Modules.obj_map modules in List.filter_map ~f:(fun m -> let obj_name = Module_name.Unique.of_string m in - Module_name.Unique.Map.find unique_map obj_name) + Module_name.Unique.Map.find obj_map obj_name) let parse_deps_exn ~file lines = let invalid () = diff --git a/src/dune_rules/ocamldep.mli b/src/dune_rules/ocamldep.mli index 40224f9325a..9ec16efcbcf 100644 --- a/src/dune_rules/ocamldep.mli +++ b/src/dune_rules/ocamldep.mli @@ -32,8 +32,6 @@ val read_deps_of : -> Module.t -> Module.t list Action_builder.t -val parse_compilation_units : modules:Modules.t -> string list -> Module.t list - (** [read_immediate_deps_of ~obj_dir ~modules ~ml_kind unit] returns the immediate dependencies found in the modules of [modules] for the file with kind [ml_kind] of the module [unit]. If there is no such file with kind diff --git a/src/dune_rules/vimpl.ml b/src/dune_rules/vimpl.ml index 2afead4be44..a64121aefc9 100644 --- a/src/dune_rules/vimpl.ml +++ b/src/dune_rules/vimpl.ml @@ -6,7 +6,6 @@ type t = ; vlib_modules : Modules.t ; vlib_foreign_objects : Path.t list ; impl_cm_kind : Cm_kind.t - ; vlib_obj_map : Module.t Module_name.Unique.Map.t } let vlib_modules t = t.vlib_modules @@ -30,11 +29,10 @@ let make ~vlib ~impl ~vlib_modules ~vlib_foreign_objects = in Mode.cm_kind (if byte then Byte else Native) in - let vlib_obj_map = Modules.unique_map vlib_modules in - { impl; impl_cm_kind; vlib; vlib_modules; vlib_foreign_objects; vlib_obj_map } + { impl; impl_cm_kind; vlib; vlib_modules; vlib_foreign_objects } let vlib_stubs_o_files = function | None -> [] | Some t -> t.vlib_foreign_objects -let vlib_obj_map t = t.vlib_obj_map +let vlib_obj_map t = Modules.obj_map t.vlib_modules From 559e885f0af7f1d9b4bc1b590496e8a637195de2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20Ch=C3=A1varri?= Date: Thu, 2 Mar 2023 23:03:55 +0000 Subject: [PATCH 6/9] return sourced_module from obj_map MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Javier Chávarri --- src/dune_rules/dep_rules.ml | 40 ++++++++++++++++++++++++++----------- src/dune_rules/modules.ml | 28 ++++++++++++++------------ src/dune_rules/modules.mli | 4 +++- src/dune_rules/ocamldep.mli | 4 ++-- src/dune_rules/vimpl.mli | 2 +- 5 files changed, 49 insertions(+), 29 deletions(-) diff --git a/src/dune_rules/dep_rules.ml b/src/dune_rules/dep_rules.ml index 1cbe6ed0d37..35692c2a8a2 100644 --- a/src/dune_rules/dep_rules.ml +++ b/src/dune_rules/dep_rules.ml @@ -3,11 +3,14 @@ open Memo.O open Ocamldep.Modules_data let transitive_deps_contents modules = - List.map modules ~f:(fun m -> Module_name.to_string (Module.name m)) + List.map modules ~f:(fun m -> + Module_name.to_string (Module.name (Modules.Sourced_module.to_module m))) |> String.concat ~sep:"\n" let ooi_deps { vimpl; sctx; dir; obj_dir; modules = _; stdlib = _; sandbox = _ } - ~dune_version ~vlib_obj_map ~(ml_kind : Ml_kind.t) (m : Module.t) = + ~dune_version ~vlib_obj_map ~(ml_kind : Ml_kind.t) + (sourced_module : Modules.Sourced_module.t) = + let m = Modules.Sourced_module.to_module sourced_module in let cm_kind = match ml_kind with | Intf -> Cm_kind.Cmi @@ -54,14 +57,16 @@ let deps_of_module ({ modules; _ } as md) ~ml_kind m = List.singleton interface_module |> Action_builder.return |> Memo.return | _ -> ( let+ deps = Ocamldep.deps_of md ~ml_kind m in + let open Action_builder.O in + let+ deps = deps in + let deps = List.map ~f:Modules.Sourced_module.to_module deps in match Modules.alias_for modules m with | [] -> deps - | aliases -> - let open Action_builder.O in - let+ deps = deps in - aliases @ deps) + | aliases -> aliases @ deps) -let deps_of_vlib_module ({ obj_dir; vimpl; dir; sctx; _ } as md) ~ml_kind m = +let deps_of_vlib_module ({ obj_dir; vimpl; dir; sctx; _ } as md) ~ml_kind + sourced_module = + let m = Modules.Sourced_module.to_module sourced_module in let vimpl = Option.value_exn vimpl in let vlib = Vimpl.vlib vimpl in match Lib.Local.of_lib vlib with @@ -71,7 +76,13 @@ let deps_of_vlib_module ({ obj_dir; vimpl; dir; sctx; _ } as md) ~ml_kind m = let impl = Vimpl.impl vimpl in Dune_project.dune_version impl.project in - ooi_deps md ~dune_version ~vlib_obj_map ~ml_kind m + let open Memo.O in + let+ deps = + ooi_deps md ~dune_version ~vlib_obj_map ~ml_kind sourced_module + in + let open Action_builder.O in + let+ deps = deps in + List.map ~f:Modules.Sourced_module.to_module deps | Some lib -> let modules = Vimpl.vlib_modules vimpl in let info = Lib.Local.info lib in @@ -83,7 +94,11 @@ let deps_of_vlib_module ({ obj_dir; vimpl; dir; sctx; _ } as md) ~ml_kind m = let+ () = Super_context.add_rule sctx ~dir (Action_builder.symlink ~src ~dst) in - Ocamldep.read_deps_of ~obj_dir:vlib_obj_dir ~modules ~ml_kind m + let open Action_builder.O in + let+ deps = + Ocamldep.read_deps_of ~obj_dir:vlib_obj_dir ~modules ~ml_kind m + in + List.map ~f:Modules.Sourced_module.to_module deps let rec deps_of md ~ml_kind (m : Modules.Sourced_module.t) = let is_alias = @@ -96,12 +111,13 @@ let rec deps_of md ~ml_kind (m : Modules.Sourced_module.t) = in if is_alias then Memo.return (Action_builder.return []) else - let skip_if_source_absent f m = - if Module.has m ~ml_kind then f m + let skip_if_source_absent f sourced_module = + let m = Modules.Sourced_module.to_module m in + if Module.has m ~ml_kind then f sourced_module else Memo.return (Action_builder.return []) in match m with - | Imported_from_vlib m -> + | Imported_from_vlib _ -> skip_if_source_absent (deps_of_vlib_module md ~ml_kind) m | Normal m -> skip_if_source_absent (deps_of_module md ~ml_kind) m | Impl_of_virtual_module impl_or_vlib -> ( diff --git a/src/dune_rules/modules.ml b/src/dune_rules/modules.ml index 50febe315d0..85b15fbca60 100644 --- a/src/dune_rules/modules.ml +++ b/src/dune_rules/modules.ml @@ -729,8 +729,20 @@ module Wrapped = struct let alias_for t m = Group.alias_for t.group m end +module Sourced_module = struct + type t = + | Normal of Module.t + | Imported_from_vlib of Module.t + | Impl_of_virtual_module of Module.t Ml_kind.Dict.t + + let to_module = function + | Normal m -> m + | Imported_from_vlib m -> m + | Impl_of_virtual_module { intf = _; impl } -> impl +end + type t = - { obj_map : Module.t Module_name.Unique.Map.t Lazy.t + { obj_map : Sourced_module.t Module_name.Unique.Map.t Lazy.t ; modules : modules } @@ -746,13 +758,6 @@ and impl = ; vlib : t } -module Sourced_module = struct - type t = - | Normal of Module.t - | Imported_from_vlib of Module.t - | Impl_of_virtual_module of Module.t Ml_kind.Dict.t -end - let rec obj_map' : 'a. modules -> f:(Sourced_module.t -> 'a) -> 'a Module.Obj_map.t = fun t ~f -> @@ -783,11 +788,8 @@ let obj_map_build : x) let obj_map modules = - obj_map' modules ~f:(function - | Sourced_module.Normal m -> m - | Imported_from_vlib m -> m - | Impl_of_virtual_module { intf = _; impl } -> impl) - |> Module.Obj_map.to_list_map ~f:(fun m _ -> (Module.obj_name m, m)) + obj_map' modules ~f:Fun.id + |> Module.Obj_map.to_list_map ~f:(fun m s -> (Module.obj_name m, s)) |> Module_name.Unique.Map.of_list_exn let with_obj_map modules = diff --git a/src/dune_rules/modules.mli b/src/dune_rules/modules.mli index cf555ea212e..769a21d3295 100644 --- a/src/dune_rules/modules.mli +++ b/src/dune_rules/modules.mli @@ -90,9 +90,11 @@ module Sourced_module : sig | Normal of Module.t | Imported_from_vlib of Module.t | Impl_of_virtual_module of Module.t Ml_kind.Dict.t + + val to_module : t -> Module.t end -val obj_map : t -> Module.t Module_name.Unique.Map.t +val obj_map : t -> Sourced_module.t Module_name.Unique.Map.t val obj_map_build : t -> f:(Sourced_module.t -> 'a Memo.t) -> 'a Module.Obj_map.t Memo.t diff --git a/src/dune_rules/ocamldep.mli b/src/dune_rules/ocamldep.mli index 9ec16efcbcf..aaa41e7e041 100644 --- a/src/dune_rules/ocamldep.mli +++ b/src/dune_rules/ocamldep.mli @@ -23,14 +23,14 @@ val deps_of : Modules_data.t -> ml_kind:Ml_kind.t -> Module.t - -> Module.t list Action_builder.t Memo.t + -> Modules.Sourced_module.t list Action_builder.t Memo.t val read_deps_of : obj_dir:Path.Build.t Obj_dir.t -> modules:Modules.t -> ml_kind:Ml_kind.t -> Module.t - -> Module.t list Action_builder.t + -> Modules.Sourced_module.t list Action_builder.t (** [read_immediate_deps_of ~obj_dir ~modules ~ml_kind unit] returns the immediate dependencies found in the modules of [modules] for the file with diff --git a/src/dune_rules/vimpl.mli b/src/dune_rules/vimpl.mli index 4b989bd8c53..ca8b440c63d 100644 --- a/src/dune_rules/vimpl.mli +++ b/src/dune_rules/vimpl.mli @@ -28,4 +28,4 @@ val vlib_stubs_o_files : t option -> Path.t list val impl_cm_kind : t -> Cm_kind.t -val vlib_obj_map : t -> Module.t Module_name.Unique.Map.t +val vlib_obj_map : t -> Modules.Sourced_module.t Module_name.Unique.Map.t From 81d333991e480a7305a601fcfe6831146d06ebb1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Javier=20Ch=C3=A1varri?= Date: Fri, 3 Mar 2023 19:50:25 +0000 Subject: [PATCH 7/9] simplify to_modules handling MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: Javier Chávarri --- src/dune_rules/dep_rules.ml | 7 +------ src/dune_rules/ocamldep.ml | 3 ++- src/dune_rules/ocamldep.mli | 4 ++-- 3 files changed, 5 insertions(+), 9 deletions(-) diff --git a/src/dune_rules/dep_rules.ml b/src/dune_rules/dep_rules.ml index 35692c2a8a2..9d17c0b6266 100644 --- a/src/dune_rules/dep_rules.ml +++ b/src/dune_rules/dep_rules.ml @@ -59,7 +59,6 @@ let deps_of_module ({ modules; _ } as md) ~ml_kind m = let+ deps = Ocamldep.deps_of md ~ml_kind m in let open Action_builder.O in let+ deps = deps in - let deps = List.map ~f:Modules.Sourced_module.to_module deps in match Modules.alias_for modules m with | [] -> deps | aliases -> aliases @ deps) @@ -94,11 +93,7 @@ let deps_of_vlib_module ({ obj_dir; vimpl; dir; sctx; _ } as md) ~ml_kind let+ () = Super_context.add_rule sctx ~dir (Action_builder.symlink ~src ~dst) in - let open Action_builder.O in - let+ deps = - Ocamldep.read_deps_of ~obj_dir:vlib_obj_dir ~modules ~ml_kind m - in - List.map ~f:Modules.Sourced_module.to_module deps + Ocamldep.read_deps_of ~obj_dir:vlib_obj_dir ~modules ~ml_kind m let rec deps_of md ~ml_kind (m : Modules.Sourced_module.t) = let is_alias = diff --git a/src/dune_rules/ocamldep.ml b/src/dune_rules/ocamldep.ml index 30b0f2d2568..7fd48c40f81 100644 --- a/src/dune_rules/ocamldep.ml +++ b/src/dune_rules/ocamldep.ml @@ -38,7 +38,8 @@ let parse_compilation_units ~modules = let obj_map = Modules.obj_map modules in List.filter_map ~f:(fun m -> let obj_name = Module_name.Unique.of_string m in - Module_name.Unique.Map.find obj_map obj_name) + Module_name.Unique.Map.find obj_map obj_name + |> Option.map ~f:Modules.Sourced_module.to_module) let parse_deps_exn ~file lines = let invalid () = diff --git a/src/dune_rules/ocamldep.mli b/src/dune_rules/ocamldep.mli index aaa41e7e041..9ec16efcbcf 100644 --- a/src/dune_rules/ocamldep.mli +++ b/src/dune_rules/ocamldep.mli @@ -23,14 +23,14 @@ val deps_of : Modules_data.t -> ml_kind:Ml_kind.t -> Module.t - -> Modules.Sourced_module.t list Action_builder.t Memo.t + -> Module.t list Action_builder.t Memo.t val read_deps_of : obj_dir:Path.Build.t Obj_dir.t -> modules:Modules.t -> ml_kind:Ml_kind.t -> Module.t - -> Modules.Sourced_module.t list Action_builder.t + -> Module.t list Action_builder.t (** [read_immediate_deps_of ~obj_dir ~modules ~ml_kind unit] returns the immediate dependencies found in the modules of [modules] for the file with From df4c4a53725c8699a569cdaf0ad68e148edb49fc Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Fri, 3 Mar 2023 15:46:12 -0600 Subject: [PATCH 8/9] _ Signed-off-by: Rudi Grinberg --- CHANGES.md | 3 +++ src/dune_rules/dep_rules.ml | 14 +++++++------- 2 files changed, 10 insertions(+), 7 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index ef0d8059f7c..fa660a4a308 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,9 @@ Unreleased ---------- +- Speed up rule generation for libraries and executables with many modules + (#7187, @jchavarri) + - Do not re-render UI on every frame if the UI doesn't change (#7186, fix #7184, @rgrinberg) diff --git a/src/dune_rules/dep_rules.ml b/src/dune_rules/dep_rules.ml index 9d17c0b6266..8e7dc45eb96 100644 --- a/src/dune_rules/dep_rules.ml +++ b/src/dune_rules/dep_rules.ml @@ -4,7 +4,8 @@ open Ocamldep.Modules_data let transitive_deps_contents modules = List.map modules ~f:(fun m -> - Module_name.to_string (Module.name (Modules.Sourced_module.to_module m))) + (* TODO use object names *) + Modules.Sourced_module.to_module m |> Module.name |> Module_name.to_string) |> String.concat ~sep:"\n" let ooi_deps { vimpl; sctx; dir; obj_dir; modules = _; stdlib = _; sandbox = _ } @@ -57,11 +58,12 @@ let deps_of_module ({ modules; _ } as md) ~ml_kind m = List.singleton interface_module |> Action_builder.return |> Memo.return | _ -> ( let+ deps = Ocamldep.deps_of md ~ml_kind m in - let open Action_builder.O in - let+ deps = deps in match Modules.alias_for modules m with | [] -> deps - | aliases -> aliases @ deps) + | aliases -> + let open Action_builder.O in + let+ deps = deps in + aliases @ deps) let deps_of_vlib_module ({ obj_dir; vimpl; dir; sctx; _ } as md) ~ml_kind sourced_module = @@ -79,9 +81,7 @@ let deps_of_vlib_module ({ obj_dir; vimpl; dir; sctx; _ } as md) ~ml_kind let+ deps = ooi_deps md ~dune_version ~vlib_obj_map ~ml_kind sourced_module in - let open Action_builder.O in - let+ deps = deps in - List.map ~f:Modules.Sourced_module.to_module deps + Action_builder.map deps ~f:(List.map ~f:Modules.Sourced_module.to_module) | Some lib -> let modules = Vimpl.vlib_modules vimpl in let info = Lib.Local.info lib in From fbd5aaef6edda260f3ba918c74bb9b7a4f8a9ade Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Fri, 3 Mar 2023 16:11:02 -0600 Subject: [PATCH 9/9] _ Signed-off-by: Rudi Grinberg --- src/dune_rules/dep_graph.ml | 14 ++++--- src/dune_rules/dep_graph.mli | 2 +- src/dune_rules/dep_rules.ml | 4 +- src/dune_rules/module.ml | 2 - src/dune_rules/module.mli | 7 ---- src/dune_rules/module_name.ml | 1 + src/dune_rules/module_name.mli | 6 +++ src/dune_rules/modules.ml | 68 +++++++++++----------------------- src/dune_rules/modules.mli | 3 -- 9 files changed, 41 insertions(+), 66 deletions(-) diff --git a/src/dune_rules/dep_graph.ml b/src/dune_rules/dep_graph.ml index 87da47c5f1c..1ad6c43991f 100644 --- a/src/dune_rules/dep_graph.ml +++ b/src/dune_rules/dep_graph.ml @@ -3,20 +3,20 @@ open Action_builder.O type t = { dir : Path.Build.t - ; per_module : Module.t list Action_builder.t Module.Obj_map.t + ; per_module : Module.t list Action_builder.t Module_name.Unique.Map.t } let make ~dir ~per_module = { dir; per_module } let deps_of t (m : Module.t) = - match Module.Obj_map.find t.per_module m with + match Module_name.Unique.Map.find t.per_module (Module.obj_name m) with | Some x -> x | None -> Code_error.raise "Ocamldep.Dep_graph.deps_of" [ ("dir", Path.Build.to_dyn t.dir) ; ( "modules" , Dyn.(list Module_name.Unique.to_dyn) - (Module.Obj_map.keys t.per_module |> List.map ~f:Module.obj_name) ) + (Module_name.Unique.Map.keys t.per_module) ) ; ("m", Module.to_dyn m) ] @@ -24,8 +24,8 @@ module Top_closure = Top_closure.Make (Module_name.Unique.Set) (Action_builder) let top_closed t modules = let+ res = - Top_closure.top_closure modules ~key:Module.obj_name - ~deps:(Module.Obj_map.find_exn t.per_module) + Top_closure.top_closure modules ~key:Module.obj_name ~deps:(fun m -> + Module_name.Unique.Map.find_exn t.per_module (Module.obj_name m)) in match res with | Ok modules -> modules @@ -58,7 +58,9 @@ let top_closed_implementations t modules = let dummy (m : Module.t) = { dir = Path.Build.root - ; per_module = Module.Obj_map.singleton m (Action_builder.return []) + ; per_module = + Module_name.Unique.Map.singleton (Module.obj_name m) + (Action_builder.return []) } module Ml_kind = struct diff --git a/src/dune_rules/dep_graph.mli b/src/dune_rules/dep_graph.mli index 1a7b0854531..547b390ea6d 100644 --- a/src/dune_rules/dep_graph.mli +++ b/src/dune_rules/dep_graph.mli @@ -6,7 +6,7 @@ type t val make : dir:Path.Build.t - -> per_module:Module.t list Action_builder.t Module.Obj_map.t + -> per_module:Module.t list Action_builder.t Module_name.Unique.Map.t -> t val deps_of : t -> Module.t -> Module.t list Action_builder.t diff --git a/src/dune_rules/dep_rules.ml b/src/dune_rules/dep_rules.ml index 8e7dc45eb96..6eb54443525 100644 --- a/src/dune_rules/dep_rules.ml +++ b/src/dune_rules/dep_rules.ml @@ -155,6 +155,8 @@ let rules md = | None -> dict_of_func_concurrently (fun ~ml_kind -> let+ per_module = - Modules.obj_map_build modules ~f:(deps_of md ~ml_kind) + Modules.obj_map modules + |> Module_name.Unique.Map_traversals.parallel_map + ~f:(fun _obj_name m -> deps_of md ~ml_kind m) in Dep_graph.make ~dir:md.dir ~per_module) diff --git a/src/dune_rules/module.ml b/src/dune_rules/module.ml index b0b965b4e88..cbf1d7f6c0b 100644 --- a/src/dune_rules/module.ml +++ b/src/dune_rules/module.ml @@ -326,8 +326,6 @@ module Obj_map = struct end) end -module Obj_map_traversals = Memo.Make_map_traversals (Obj_map) - let encode ({ source; obj_name; pp = _; visibility; kind; install_as = _ } as t) ~src_dir = let open Dune_lang.Encoder in diff --git a/src/dune_rules/module.mli b/src/dune_rules/module.mli index 72c5d927c45..19b35e25bec 100644 --- a/src/dune_rules/module.mli +++ b/src/dune_rules/module.mli @@ -112,13 +112,6 @@ module Obj_map : sig val find_exn : 'a t -> module_ -> 'a end -module Obj_map_traversals : sig - val parallel_iter : 'a Obj_map.t -> f:(t -> 'a -> unit Memo.t) -> unit Memo.t - - val parallel_map : - 'a Obj_map.t -> f:(t -> 'a -> 'b Memo.t) -> 'b Obj_map.t Memo.t -end - val sources : t -> Path.t list val visibility : t -> Visibility.t diff --git a/src/dune_rules/module_name.ml b/src/dune_rules/module_name.ml index 79b26b30132..6f1d645efa3 100644 --- a/src/dune_rules/module_name.ml +++ b/src/dune_rules/module_name.ml @@ -117,6 +117,7 @@ module Unique = struct module Map = Map module Set = Set + module Map_traversals = Map_traversals end module Path = struct diff --git a/src/dune_rules/module_name.mli b/src/dune_rules/module_name.mli index baf881935a6..1a829a55797 100644 --- a/src/dune_rules/module_name.mli +++ b/src/dune_rules/module_name.mli @@ -66,6 +66,12 @@ module Unique : sig include Dune_lang.Conv.S with type t := t include Comparable_intf.S with type key := t + + module Map_traversals : sig + val parallel_iter : 'a Map.t -> f:(t -> 'a -> unit Memo.t) -> unit Memo.t + + val parallel_map : 'a Map.t -> f:(t -> 'a -> 'b Memo.t) -> 'b Map.t Memo.t + end end module Path : sig diff --git a/src/dune_rules/modules.ml b/src/dune_rules/modules.ml index 85b15fbca60..8eac22ffc9d 100644 --- a/src/dune_rules/modules.ml +++ b/src/dune_rules/modules.ml @@ -113,10 +113,6 @@ module Stdlib = struct let exit_module = stdlib.exit_module in { modules; unwrapped; exit_module; main_module_name } - let obj_map t ~f = - Module_name.Map.fold t.modules ~init:Module.Obj_map.empty ~f:(fun m acc -> - Module.Obj_map.add_exn acc m (f m)) - let impl_only t = Module_name.Map.values t.modules |> List.filter ~f:(fun m -> @@ -575,10 +571,6 @@ module Unwrapped = struct let map t ~f = Group.map_modules t ~f - let obj_map t ~f = - fold t ~init:Module.Obj_map.empty ~f:(fun m acc -> - Module.Obj_map.add_exn acc m (f m)) - let entry_modules m = Module_name.Map.to_list_map m ~f:(fun _ m -> match (m : Group.node) with @@ -702,11 +694,6 @@ module Wrapped = struct ; toplevel_module = `Hidden } - let obj_map { group; wrapped_compat; wrapped = _; toplevel_module = _ } ~f = - let add_module m acc = Module.Obj_map.add_exn acc m (f m) in - let init = Group.fold group ~init:Module.Obj_map.empty ~f:add_module in - Module_name.Map.fold ~init wrapped_compat ~f:add_module - let impl_only { group; wrapped_compat; wrapped = _; toplevel_module = _ } = let init = Module_name.Map.values wrapped_compat in Group.fold group ~init ~f:(fun v acc -> @@ -758,39 +745,28 @@ and impl = ; vlib : t } -let rec obj_map' : - 'a. modules -> f:(Sourced_module.t -> 'a) -> 'a Module.Obj_map.t = - fun t ~f -> - let normal m = f (Sourced_module.Normal m) in - match t with - | Singleton m -> Module.Obj_map.add_exn Module.Obj_map.empty m (normal m) - | Unwrapped m -> Unwrapped.obj_map m ~f:normal - | Wrapped w -> Wrapped.obj_map w ~f:normal - | Stdlib w -> Stdlib.obj_map w ~f:normal - | Impl { vlib; impl } -> - Module.Obj_map.merge (obj_map' vlib.modules ~f:Fun.id) - (obj_map' impl.modules ~f:Fun.id) ~f:(fun _ vlib impl -> - match (vlib, impl) with - | None, None -> assert false - | Some (Normal m), None -> - Some (f (Sourced_module.Imported_from_vlib m)) - | None, Some (Normal m) -> Some (f (Normal m)) - | Some (Normal intf), Some (Normal impl) -> - Some (f (Sourced_module.Impl_of_virtual_module { intf; impl })) - | Some (Imported_from_vlib _ | Impl_of_virtual_module _), _ - | _, Some (Imported_from_vlib _ | Impl_of_virtual_module _) -> - assert false) - -let obj_map_build : - 'a. t -> f:(Sourced_module.t -> 'a Memo.t) -> 'a Module.Obj_map.t Memo.t = - fun t ~f -> - Module.Obj_map_traversals.parallel_map (obj_map' t.modules ~f) ~f:(fun _ x -> - x) - -let obj_map modules = - obj_map' modules ~f:Fun.id - |> Module.Obj_map.to_list_map ~f:(fun m s -> (Module.obj_name m, s)) - |> Module_name.Unique.Map.of_list_exn +let rec obj_map : 'a. modules -> Sourced_module.t Module_name.Unique.Map.t = + let module Map = Module_name.Unique.Map in + let normal m = Sourced_module.Normal m in + let f m acc = Map.add_exn acc (Module.obj_name m) (normal m) in + fun t -> + match t with + | Singleton m -> Map.add_exn Map.empty (Module.obj_name m) (normal m) + | Unwrapped m -> Unwrapped.fold m ~init:Map.empty ~f + | Wrapped w -> Wrapped.fold w ~init:Map.empty ~f + | Stdlib w -> Stdlib.fold w ~init:Map.empty ~f + | Impl { vlib; impl } -> + Map.merge (obj_map vlib.modules) (obj_map impl.modules) + ~f:(fun _ vlib impl -> + match (vlib, impl) with + | None, None -> assert false + | Some (Normal m), None -> Some (Sourced_module.Imported_from_vlib m) + | None, Some (Normal m) -> Some (Normal m) + | Some (Normal intf), Some (Normal impl) -> + Some (Sourced_module.Impl_of_virtual_module { intf; impl }) + | Some (Imported_from_vlib _ | Impl_of_virtual_module _), _ + | _, Some (Imported_from_vlib _ | Impl_of_virtual_module _) -> + assert false) let with_obj_map modules = let obj_map = lazy (obj_map modules) in diff --git a/src/dune_rules/modules.mli b/src/dune_rules/modules.mli index 769a21d3295..907e72827ba 100644 --- a/src/dune_rules/modules.mli +++ b/src/dune_rules/modules.mli @@ -96,9 +96,6 @@ end val obj_map : t -> Sourced_module.t Module_name.Unique.Map.t -val obj_map_build : - t -> f:(Sourced_module.t -> 'a Memo.t) -> 'a Module.Obj_map.t Memo.t - (** List of entry modules visible to users of the library. For wrapped libraries, this is always one module. For unwrapped libraries, this could be more than one. *)