From 76243bbf926ff2301be1d8a216b14230ac54c94f Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Sat, 27 Apr 2019 13:24:08 +0700 Subject: [PATCH 1/3] Remove all function that requires passing a db manually around Should fix #2085 Signed-off-by: Rudi Grinberg --- CHANGES.md | 3 ++ src/lib.ml | 103 ++++++++++++++++++++++++++++------------------------- 2 files changed, 57 insertions(+), 49 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 564527b00d3..e5aa2714a11 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -34,6 +34,9 @@ unreleased - Do not fail when a findlib directory doesn't exist (#2101, fix #2099, @diml) +- Fix crash when calculating library dependency closure (#2090, fixes #2085, + @rgrinberg) + 1.9.1 (11/04/2019) ------------------ diff --git a/src/lib.ml b/src/lib.ml index e7737ea7f4e..7086c2ceeb0 100644 --- a/src/lib.ml +++ b/src/lib.ml @@ -205,8 +205,9 @@ module T = struct ; resolved_selects : Resolved_select.t list ; user_written_deps : Dune_file.Lib_deps.t ; implements : t Or_exn.t option - ; (* this field cannot be forced until the library is instantiated *) + ; (* these fields cannot be forced until the library is instantiated *) default_implementation : t Or_exn.t Lazy.t option + ; implementations : t Or_exn.t list Variant.Map.t Lazy.t option ; (* This is mutable to avoid this error: {[ @@ -752,31 +753,33 @@ end = struct end (* Find implementation that matches given variants *) -let rec find_implementation_for db lib ~variants = +let find_implementation_for lib ~variants = match variants with | None -> Ok None | Some (loc, variants_set) -> - let available_implementations = db.find_implementations lib.name in - Variant.Set.fold variants_set - ~init:[] - ~f:(fun variant acc -> - List.rev_append acc - (Variant.Map.Multi.find available_implementations variant)) - |> List.sort_uniq ~compare:(fun (a:Lib_info.t) (b:Lib_info.t) -> - match Lib_name.compare a.name b.name with - | Eq -> Path.compare a.src_dir b.src_dir - | x -> x) - |> fun x -> match x, db.parent with - | [], None -> Ok None - | [], Some db -> find_implementation_for db lib ~variants - | [elem], _ -> Ok (Some elem) - | conflict, _ -> - Error (Error (Multiple_implementations_for_virtual_lib - { lib = lib.info - ; loc - ; given_variants = variants_set - ; conflict - })) + begin match lib.implementations with + | None -> Ok None (* shouldn't happen and yet it does.. *) + | Some (lazy available_implementations) -> + let* candidates = + Variant.Set.fold variants_set + ~init:[] + ~f:(fun variant acc -> + List.rev_append acc + (Variant.Map.Multi.find available_implementations variant)) + |> Result.List.all + in + match candidates with + | [] -> Ok None + | [elem] -> Ok (Some elem) + | conflict -> + let conflict = List.map conflict ~f:(fun lib -> lib.info) in + Error (Error (Multiple_implementations_for_virtual_lib + { lib = lib.info + ; loc + ; given_variants = variants_set + ; conflict + })) + end let rec instantiate db name (info : Lib_info.t) ~stack ~hidden = let id, stack = @@ -803,6 +806,13 @@ let rec instantiate db name (info : Lib_info.t) ~stack ~hidden = in let default_implementation = Option.map info.default_implementation ~f:(fun l -> lazy (resolve l)) in + let implementations = + Option.map info.virtual_ ~f:(fun _ -> lazy ( + let available_implementations = db.find_implementations name in + Variant.Map.map available_implementations ~f:( + List.map ~f:(fun (impl : Lib_info.t) -> + resolve (impl.loc, impl.name))))) + in let requires, pps, resolved_selects = resolve_user_deps db info.requires ~allow_private_deps ~pps:info.pps ~stack in @@ -835,6 +845,7 @@ let rec instantiate db name (info : Lib_info.t) ~stack ~hidden = ; sub_systems = Sub_system_name.Map.empty ; implements ; default_implementation + ; implementations } in t.sub_systems <- @@ -1026,7 +1037,7 @@ and resolve_user_deps db deps ~allow_private_deps ~pps ~stack = Assertion: libraries is a list of virtual libraries with no implementation. The goal is to find which libraries can safely be defaulted. *) -and resolve_default_libraries db libraries ~variants = +and resolve_default_libraries libraries ~variants = (* Map from a vlib to vlibs that are implemented in the transitive closure of its default impl. *) let vlib_status = Vlib_visit.create () in @@ -1037,23 +1048,20 @@ and resolve_default_libraries db libraries ~variants = | None -> Ok true | Some x -> let+ x = x in x <> vlib in - let name_to_lib (loc, name) = - resolve_dep db name ~allow_private_deps:true ~loc - ~stack:Dep_stack.empty - in (* Either by variants or by default. *) let impl_for vlib = - find_implementation_for db vlib ~variants - >>| function - | Some x -> Some (name_to_lib (x.loc, x.name)) - | None -> Option.map ~f:Lazy.force vlib.default_implementation + find_implementation_for vlib ~variants >>= function + | Some impl -> Ok (Some impl) + | None -> + begin match vlib.default_implementation with + | None -> Ok None + | Some d -> Result.map ~f:Option.some (Lazy.force d) + end in let impl_different_from_vlib_default vlib (impl : lib) = - impl_for vlib >>= function - | None -> Ok true - | Some lib -> - let+ lib = lib in - lib <> impl + impl_for vlib >>| function + | None -> true + | Some lib -> lib <> impl in let library_is_default lib = match Map.find !vlib_default_parent lib with @@ -1096,11 +1104,13 @@ and resolve_default_libraries db libraries ~variants = handling virtual lib. *) Ok ()) in - (* If the library has an implementation according to variants. *) + (* If the library has an implementation according to variants or default + impl. *) let* impl = impl_for lib in - Result.Option.iter impl ~f:(visit ~stack:(lib.info :: stack) (Some lib)) - (* If the library is a virtual library with a default - implementation. *) + begin match impl with + | None -> Ok () + | Some impl -> visit ~stack:(lib.info :: stack) (Some lib) impl + end ) in (* For each virtual library we know which vlibs will be implemented when @@ -1109,10 +1119,6 @@ and resolve_default_libraries db libraries ~variants = List.filter_map ~f:library_is_default libraries and closure_with_overlap_checks db ts ~stack:orig_stack ~linking ~variants = - let name_to_lib name loc = - resolve_dep (Option.value_exn db) name - ~allow_private_deps:true ~loc ~stack:Dep_stack.empty - in let visited = ref Map.empty in let unimplemented = ref Vlib.Unimplemented.empty in let res = ref [] in @@ -1165,14 +1171,13 @@ and closure_with_overlap_checks db ts ~stack:orig_stack ~linking ~variants = !unimplemented |> Vlib.Unimplemented.fold ~init:([], []) ~f:(fun lib (lst, def) -> let* impl = - find_implementation_for (Option.value_exn db) lib ~variants in + find_implementation_for lib ~variants in match impl, lib.default_implementation with | None, Some _ -> Ok (lst, (lib :: def)) | None, None -> Ok (lst, def) - | Some (impl_info : Lib_info.t), _ -> - let* impl = name_to_lib impl_info.name impl_info.loc in + | Some (impl : lib), _ -> Ok (impl :: lst, def)) in (* Manage unimplemented libraries that have a default implementation. *) @@ -1180,7 +1185,7 @@ and closure_with_overlap_checks db ts ~stack:orig_stack ~linking ~variants = | [], [] -> Ok () | [], def -> - resolve_default_libraries (Option.value_exn db) def ~variants + resolve_default_libraries def ~variants >>= handle ~stack | lst, _ -> handle lst ~stack From 0dd9fba2e9eb0c2d2ebac5a005a75345d1af886c Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Sat, 27 Apr 2019 13:43:15 +0700 Subject: [PATCH 2/3] Do not look for implementations for non virtual libs Signed-off-by: Rudi Grinberg --- src/lib.ml | 59 ++++++++++++++++++++++++++++-------------------------- 1 file changed, 31 insertions(+), 28 deletions(-) diff --git a/src/lib.ml b/src/lib.ml index 7086c2ceeb0..cff441c2f14 100644 --- a/src/lib.ml +++ b/src/lib.ml @@ -754,32 +754,32 @@ end (* Find implementation that matches given variants *) let find_implementation_for lib ~variants = + assert (Option.is_some lib.info.virtual_); match variants with | None -> Ok None | Some (loc, variants_set) -> - begin match lib.implementations with - | None -> Ok None (* shouldn't happen and yet it does.. *) - | Some (lazy available_implementations) -> - let* candidates = - Variant.Set.fold variants_set - ~init:[] - ~f:(fun variant acc -> - List.rev_append acc - (Variant.Map.Multi.find available_implementations variant)) - |> Result.List.all - in - match candidates with - | [] -> Ok None - | [elem] -> Ok (Some elem) - | conflict -> - let conflict = List.map conflict ~f:(fun lib -> lib.info) in - Error (Error (Multiple_implementations_for_virtual_lib - { lib = lib.info - ; loc - ; given_variants = variants_set - ; conflict - })) - end + let available_implementations = + Lazy.force (Option.value_exn lib.implementations) + in + let* candidates = + Variant.Set.fold variants_set + ~init:[] + ~f:(fun variant acc -> + List.rev_append acc + (Variant.Map.Multi.find available_implementations variant)) + |> Result.List.all + in + match candidates with + | [] -> Ok None + | [elem] -> Ok (Some elem) + | conflict -> + let conflict = List.map conflict ~f:(fun lib -> lib.info) in + Error (Error (Multiple_implementations_for_virtual_lib + { lib = lib.info + ; loc + ; given_variants = variants_set + ; conflict + })) let rec instantiate db name (info : Lib_info.t) ~stack ~hidden = let id, stack = @@ -1106,11 +1106,14 @@ and resolve_default_libraries libraries ~variants = in (* If the library has an implementation according to variants or default impl. *) - let* impl = impl_for lib in - begin match impl with - | None -> Ok () - | Some impl -> visit ~stack:(lib.info :: stack) (Some lib) impl - end + if Option.is_none lib.info.virtual_ then + Ok () + else + let* impl = impl_for lib in + begin match impl with + | None -> Ok () + | Some impl -> visit ~stack:(lib.info :: stack) (Some lib) impl + end ) in (* For each virtual library we know which vlibs will be implemented when From bffe5ba071982d41ca18539853d28bd8710255a4 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Mon, 29 Apr 2019 18:37:41 +0700 Subject: [PATCH 3/3] Look for implementations recursively Signed-off-by: Rudi Grinberg --- src/lib.ml | 26 +++++++++++++++++++++++--- 1 file changed, 23 insertions(+), 3 deletions(-) diff --git a/src/lib.ml b/src/lib.ml index cff441c2f14..866e9ecd14f 100644 --- a/src/lib.ml +++ b/src/lib.ml @@ -781,6 +781,16 @@ let find_implementation_for lib ~variants = ; conflict })) +let find_implementations db name = + let rec loop acc db = + let implementations = db.find_implementations name in + let acc = Variant.Map.Multi.rev_union acc implementations in + match db.parent with + | None -> acc + | Some db -> loop acc db + in + loop Variant.Map.empty db + let rec instantiate db name (info : Lib_info.t) ~stack ~hidden = let id, stack = Dep_stack.create_and_push stack name info.src_dir @@ -808,10 +818,20 @@ let rec instantiate db name (info : Lib_info.t) ~stack ~hidden = Option.map info.default_implementation ~f:(fun l -> lazy (resolve l)) in let implementations = Option.map info.virtual_ ~f:(fun _ -> lazy ( - let available_implementations = db.find_implementations name in + let available_implementations = find_implementations db name in + let seen_libs = ref Set.empty in Variant.Map.map available_implementations ~f:( - List.map ~f:(fun (impl : Lib_info.t) -> - resolve (impl.loc, impl.name))))) + List.filter_map ~f:(fun (impl : Lib_info.t) -> + match resolve (impl.loc, impl.name) with + | Error _ as e -> Some e + | Ok lib -> + if Set.mem !seen_libs lib then + None + else begin + seen_libs := Set.add !seen_libs lib; + Some (Ok lib) + end + )))) in let requires, pps, resolved_selects = resolve_user_deps db info.requires ~allow_private_deps ~pps:info.pps ~stack