Formalise special builtin support for findlib.dynload

CHANGES.md

@@ -56,6 +56,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)
 ------------------
 

src/dune_file.ml

@@ -785,6 +785,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
@@ -868,6 +889,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 =
@@ -924,6 +946,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 =
@@ -1017,6 +1043,7 @@ module Library = struct
            ; default_implementation
            ; private_modules
            ; stdlib
+           ; special_builtin_support
            })
 
   let has_stubs t =

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

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

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

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

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

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 *)

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
   }

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

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)