From 836474830e8b90588fd9be3c247015d7794eb102 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Wed, 1 May 2019 20:56:32 +0100 Subject: [PATCH 1/2] Formalise special builtin support for findlib.dynload So that we can extend it to other libraries in the future without more hard-coding. Signed-off-by: Jeremie Dimino --- src/dune_file.ml | 27 +++++++++++++++++++++++++++ src/dune_file.mli | 11 +++++++++++ src/dune_package.ml | 18 +++++++++++++++--- src/dune_package.mli | 4 ++++ src/findlib.ml | 6 ++++++ src/lib.ml | 12 ++++++++++-- src/lib.mli | 6 ++++++ src/lib_info.ml | 3 +++ src/lib_info.mli | 1 + src/link_time_code_gen.ml | 37 +++++++++++++++++-------------------- 10 files changed, 100 insertions(+), 25 deletions(-) diff --git a/src/dune_file.ml b/src/dune_file.ml index 29cb17b02a9..4d9d17328b1 100644 --- a/src/dune_file.ml +++ b/src/dune_file.ml @@ -774,6 +774,27 @@ module Library = struct | From of (Loc.t * Lib_name.t) end + module Special_builtin_support = struct + module T = struct + type t = + | Findlib_dynload + let compare = compare + end + + include T + module Map = Map.Make(T) + + let decode = + enum + [ "findlib_dynload", Findlib_dynload + ] + + let encode t = + Dune_lang.atom + (match t with + | Findlib_dynload -> "findlib_dynload") + end + module Stdlib = struct type t = { modules_before_stdlib : Module.Name.Set.t @@ -857,6 +878,7 @@ module Library = struct ; default_implementation : (Loc.t * Lib_name.t) option ; private_modules : Ordered_set_lang.t option ; stdlib : Stdlib.t option + ; special_builtin_support : Special_builtin_support.t option } let decode = @@ -913,6 +935,10 @@ module Library = struct Ordered_set_lang.decode) and+ stdlib = field_o "stdlib" (Syntax.since Stdlib.syntax (0, 1) >>> Stdlib.decode) + and+ special_builtin_support = + field_o "special_builtin_support" + (Syntax.since Stanza.syntax (1, 10) >>> + Special_builtin_support.decode) in let wrapped = Wrapped.make ~wrapped ~implements in let name = @@ -1006,6 +1032,7 @@ module Library = struct ; default_implementation ; private_modules ; stdlib + ; special_builtin_support }) let has_stubs t = diff --git a/src/dune_file.mli b/src/dune_file.mli index ed106fa72c9..88bfeee9fd5 100644 --- a/src/dune_file.mli +++ b/src/dune_file.mli @@ -193,6 +193,16 @@ module Library : sig } end + module Special_builtin_support : sig + type t = + | Findlib_dynload + + val compare : t -> t -> Ordering.t + include Dune_lang.Conv with type t := t + + module Map : Map.S with type key := t + end + type t = { name : (Loc.t * Lib_name.Local.t) ; public : Public_lib.t option @@ -222,6 +232,7 @@ module Library : sig ; default_implementation : (Loc.t * Lib_name.t) option ; private_modules : Ordered_set_lang.t option ; stdlib : Stdlib.t option + ; special_builtin_support : Special_builtin_support.t option } val has_stubs : t -> bool diff --git a/src/dune_package.ml b/src/dune_package.ml index e9f445c7ec8..a138b773d92 100644 --- a/src/dune_package.ml +++ b/src/dune_package.ml @@ -27,13 +27,16 @@ module Lib = struct ; requires : (Loc.t * Lib_name.t) list ; version : string option ; modes : Mode.Dict.Set.t + ; special_builtin_support : + Dune_file.Library.Special_builtin_support.t option } let make ~loc ~kind ~name ~synopsis ~archives ~plugins ~foreign_objects ~foreign_archives ~jsoo_runtime ~main_module_name ~sub_systems ~requires ~ppx_runtime_deps ~implements ~variant ~default_implementation ~virtual_ ~modules ~modes - ~version ~orig_src_dir ~obj_dir = + ~version ~orig_src_dir ~obj_dir + ~special_builtin_support = let dir = Obj_dir.dir obj_dir in let map_path p = if Path.is_managed p then @@ -65,6 +68,7 @@ module Lib = struct ; modules ; modes ; obj_dir + ; special_builtin_support } let obj_dir t = t.obj_dir @@ -84,7 +88,7 @@ module Lib = struct ; ppx_runtime_deps ; sub_systems ; virtual_ ; implements ; variant ; default_implementation ; main_module_name ; version = _; obj_dir ; orig_src_dir - ; modules ; modes + ; modules ; modes ; special_builtin_support } = let open Dune_lang.Encoder in let no_loc f (_loc, x) = f x in @@ -117,6 +121,8 @@ module Lib = struct (match modules with | None -> [] | Some modules -> Lib_modules.encode modules) + ; field_o "special_builtin_support" + Dune_file.Library.Special_builtin_support.encode special_builtin_support ] @ (Sub_system_name.Map.to_list sub_systems |> List.map ~f:(fun (name, (_ver, sexps)) -> field_l (Sub_system_name.to_string name) sexp sexps)) @@ -159,7 +165,11 @@ module Lib = struct and+ sub_systems = Sub_system_info.record_parser () and+ orig_src_dir = field_o "orig_src_dir" path and+ modules = field_o "modules" (Lib_modules.decode - ~implements:(Option.is_some implements) ~obj_dir) + ~implements:(Option.is_some implements) ~obj_dir) + and+ special_builtin_support = + field_o "special_builtin_support" + (Syntax.since Stanza.syntax (1, 10) >>> + Dune_file.Library.Special_builtin_support.decode) in let modes = Mode.Dict.Set.of_list modes in { kind @@ -184,6 +194,7 @@ module Lib = struct ; obj_dir ; modules ; modes + ; special_builtin_support } ) @@ -207,6 +218,7 @@ module Lib = struct let variant t = t.variant let default_implementation t = t.default_implementation let modes t = t.modes + let special_builtin_support t = t.special_builtin_support let compare_name x y = Lib_name.compare x.name y.name let wrapped t = Option.map t.modules ~f:Lib_modules.wrapped diff --git a/src/dune_package.mli b/src/dune_package.mli index bbf75d0f032..05750426c8b 100644 --- a/src/dune_package.mli +++ b/src/dune_package.mli @@ -25,6 +25,8 @@ module Lib : sig val implements : _ t -> (Loc.t * Lib_name.t) option val variant : _ t -> Variant.t option val default_implementation : _ t -> (Loc.t * Lib_name.t) option + val special_builtin_support + : _ t -> Dune_file.Library.Special_builtin_support.t option val dir_of_name : Lib_name.t -> Path.Local.t @@ -57,6 +59,8 @@ module Lib : sig -> version:string option -> orig_src_dir:Path.t option -> obj_dir:Obj_dir.t + -> special_builtin_support: + Dune_file.Library.Special_builtin_support.t option -> 'a t val set_subsystems : 'a t -> 'b Sub_system_name.Map.t -> 'b t diff --git a/src/findlib.ml b/src/findlib.ml index 0e7d0db2055..d8c80383274 100644 --- a/src/findlib.ml +++ b/src/findlib.ml @@ -238,6 +238,12 @@ module Package = struct ~version:(version t) ~modes ~obj_dir + ~special_builtin_support:( + (* findlib has been around for much longer than dune, so it is + acceptable to have a special case in dune for findlib. *) + match Lib_name.to_string t.name with + | "findlib.dynload" -> Some Findlib_dynload + | _ -> None) let parse db ~meta_file ~name ~parent_dir ~vars = let pkg_dir = Vars.get vars "directory" Ps.empty in diff --git a/src/lib.ml b/src/lib.ml index 3b398484ab9..2b08760ff53 100644 --- a/src/lib.ml +++ b/src/lib.ml @@ -282,6 +282,8 @@ let status t = t.info.status let foreign_objects t = t.info.foreign_objects +let special_builtin_support t = t.info.special_builtin_support + let main_module_name t = match t.info.main_module_name with | This mmn -> Ok mmn @@ -387,6 +389,13 @@ module L = struct Id.Top_closure.top_closure l ~key:(fun t -> unique_id (key t)) ~deps + + let special_builtin_support l = + let module M = Dune_file.Library.Special_builtin_support.Map in + List.fold_left l ~init:M.empty ~f:(fun acc lib -> + match lib.info.special_builtin_support with + | None -> acc + | Some x -> M.add acc x lib) end module Lib_and_module = struct @@ -1701,5 +1710,4 @@ let to_dune_lib ({ name ; info ; _ } as lib) ~lib_modules ~foreign_objects ~dir ~modules:(Some lib_modules) ~main_module_name:(Result.ok_exn (main_module_name lib)) ~sub_systems:(Sub_system.dump_config lib) - - + ~special_builtin_support:info.special_builtin_support diff --git a/src/lib.mli b/src/lib.mli index 00aab911d01..ba0d61394dc 100644 --- a/src/lib.mli +++ b/src/lib.mli @@ -40,6 +40,9 @@ val wrapped : t -> Wrapped.t option Or_exn.t val virtual_ : t -> Lib_modules.t Lib_info.Source.t option +val special_builtin_support + : t -> Dune_file.Library.Special_builtin_support.t option + (** A unique integer identifier. It is only unique for the duration of the process *) module Id : sig @@ -94,6 +97,9 @@ module L : sig -> key:('a -> lib) -> deps:('a -> 'a list) -> ('a list, 'a list) Result.t + + val special_builtin_support + : t -> lib Dune_file.Library.Special_builtin_support.Map.t end with type lib := t (** Operation on list of libraries and modules *) diff --git a/src/lib_info.ml b/src/lib_info.ml index 43063baee97..318c17160f3 100644 --- a/src/lib_info.ml +++ b/src/lib_info.ml @@ -77,6 +77,7 @@ type t = ; wrapped : Wrapped.t Dune_file.Library.Inherited.t option ; main_module_name : Dune_file.Library.Main_module_name.t ; modes : Mode.Dict.Set.t + ; special_builtin_support : Dune_file.Library.Special_builtin_support.t option } let user_written_deps t = @@ -182,6 +183,7 @@ let of_library_stanza ~dir ; main_module_name ; modes ; wrapped = Some conf.wrapped + ; special_builtin_support = conf.special_builtin_support } let of_dune_lib dp = @@ -227,4 +229,5 @@ let of_dune_lib dp = ; default_implementation = Lib.default_implementation dp ; modes = Lib.modes dp ; wrapped + ; special_builtin_support = Lib.special_builtin_support dp } diff --git a/src/lib_info.mli b/src/lib_info.mli index ab757176568..657ff05785f 100644 --- a/src/lib_info.mli +++ b/src/lib_info.mli @@ -58,6 +58,7 @@ type t = private ; wrapped : Wrapped.t Dune_file.Library.Inherited.t option ; main_module_name : Dune_file.Library.Main_module_name.t ; modes : Mode.Dict.Set.t + ; special_builtin_support : Dune_file.Library.Special_builtin_support.t option } val of_library_stanza diff --git a/src/link_time_code_gen.ml b/src/link_time_code_gen.ml index 5cdbfca9e22..65aadb4ba6f 100644 --- a/src/link_time_code_gen.ml +++ b/src/link_time_code_gen.ml @@ -43,11 +43,6 @@ let generate_and_compile_module cctx ~name:basename ~code ~requires = module_; module_ -let is_findlib_dynload lib = - match Lib_name.to_string (Lib.name lib) with - | "findlib.dynload" -> true - | _ -> false - let findlib_init_code ~preds ~libs = let public_libs = List.filter @@ -65,15 +60,15 @@ let findlib_init_code ~preds ~libs = \"native\" else \"byte\") :: preds in@\n"; Format.fprintf ppf "Findlib.record_package_predicates preds;;@\n") -let handle_special_libs cctx = +let handle_special_libs cctx = Result.map (CC.requires_link cctx) ~f:(fun libs -> let sctx = CC.super_context cctx in - let has_findlib_dynload = - List.exists libs ~f:is_findlib_dynload - in - if not has_findlib_dynload then + let module M = Dune_file.Library.Special_builtin_support.Map in + let specials = Lib.L.special_builtin_support libs in + let to_link = Lib.Lib_and_module.L.of_libs libs in + if not (M.mem specials Findlib_dynload) then { force_linkall = false - ; to_link = Lib.Lib_and_module.L.of_libs libs + ; to_link } else begin (* If findlib.dynload is linked, we stores in the binary the @@ -96,17 +91,19 @@ let handle_special_libs cctx = ~code ~requires in - let rec insert = function + let rec insert = function | [] -> assert false - | lib :: libs -> - if is_findlib_dynload lib then - Lib.Lib_and_module.Lib lib - :: Module module_ - :: Lib.Lib_and_module.L.of_libs libs - else - Lib lib :: insert libs + | x :: l -> + match x with + | Lib.Lib_and_module.Module _ -> + x :: insert l + | Lib lib -> + match Lib.special_builtin_support lib with + | Some Findlib_dynload -> + x :: Module module_ :: l + | _ -> x :: insert l in { force_linkall = true - ; to_link = insert libs + ; to_link = insert to_link } end) From a6fe74d3843fb85b0233682c65b413aadbfacf9e Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Thu, 2 May 2019 14:43:25 +0100 Subject: [PATCH 2/2] Added changelog entry Signed-off-by: Jeremie Dimino --- CHANGES.md | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index a6e47b7e017..ba352ffc4aa 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -46,6 +46,13 @@ unreleased - Fix crash when calculating library dependency closure (#2090, fixes #2085, @rgrinberg) +- Clean up the special support for `findlib.dynload`. Before, Dune + would simply match on the library name. Now, we only match on the + findlib package name when the library doesn't come from + Dune. Someone writing a library called `findlib.dynload` with Dune + would have to add `(special_builton_support findlib_dynload)` to + trigger the special behavior. (#2115, @diml) + 1.9.1 (11/04/2019) ------------------