Adds support for findlib.dynload

     which allows to easily dynlink packages and their dependencies.
     Dune is needed for putting in the binary the list of package
     statically linked.

Signed-off-by: François Bobot <francois.bobot@cea.fr>

src/exe.ml

@@ -138,10 +138,26 @@ let link_exe
       Build.dyn_paths (Build.arr (fun (modules, _) ->
         artifacts modules ~ext:ctx.ext_obj))
   in
+  let arg_spec_for_requires, flags =
+    match requires with
+    | Ok libs ->
+      let open Link_time_code_gen in
+      let l = create ~flags:(CC.flags cctx) libs in
+      let l = findlib_dynload ~name ~mode cctx l in
+      let arg_spec =
+        List.map l.libs_or_module ~f:(function
+          | Libs l -> Lib.L.link_flags l ~mode ~stdlib_dir:ctx.stdlib_dir
+          | Module m -> Dep (Module.cm_file_unsafe m ~obj_dir (Mode.cm_kind mode));
+        )
+      in
+      Ok (Arg_spec.S arg_spec),l.flags
+    | Error exn -> Error exn, (CC.flags cctx)
+  in
+  (* The rule *)
   SC.add_rule sctx
     (Build.fanout3
        (register_native_objs_deps modules_and_cm_files >>^ snd)
-       (Ocaml_flags.get (CC.flags cctx) mode)
+       (Ocaml_flags.get flags mode)
        link_flags
      >>>
      Build.of_result_map requires ~f:(fun libs ->
@@ -153,8 +169,7 @@ let link_exe
        ; A "-o"; Target exe
        ; As linkage.flags
        ; Dyn (fun (_, _, link_flags) -> As link_flags)
-       ; Arg_spec.of_result_map requires ~f:(fun libs ->
-           Lib.L.link_flags libs ~mode ~stdlib_dir:ctx.stdlib_dir)
+       ; Arg_spec.of_result_map arg_spec_for_requires ~f:(fun x -> x)
        ; Dyn (fun (cm_files, _, _) -> Deps cm_files)
        ]);
   if linkage.ext = ".bc" then

src/findlib.mli

@@ -31,6 +31,8 @@ module Package : sig
   val requires         : t -> string list
   val ppx_runtime_deps : t -> string list
   val dune_file        : t -> Path.t option
+
+  val preds : Variant.Set.t
 end
 
 module Unavailable_reason : sig

src/link_time_code_gen.ml

@@ -0,0 +1,100 @@
+open Import
+
+module CC = Compilation_context
+module SC = Super_context
+
+type libs_or_module =
+  | Libs of Lib.L.t
+  | Module of Module.t
+
+type t = {
+  libs_or_module: libs_or_module list;
+  flags: Ocaml_flags.t;
+}
+
+let create ?(flags=Ocaml_flags.empty) libs =
+  { libs_or_module = [Libs libs]; flags }
+
+let only_libs libs =
+  libs
+  |> List.filter_map ~f:(function Libs libs -> Some libs | Module _ -> None)
+  |> List.concat
+
+let rec cut_after_libs ~pkg_name before = function
+  | [] -> None
+  | a::l when String.equal (Lib.name a) pkg_name -> Some (List.rev (a::before),l)
+  | a::l -> cut_after_libs (a::before) ~pkg_name l
+
+let rec cut_after ~pkg_name before = function
+  | [] -> None
+  | ((Module _ ) as a)::l -> cut_after (a::before) ~pkg_name l
+  | ((Libs libs) as a)::l ->
+    begin
+      match cut_after_libs [] ~pkg_name libs with
+      | None -> cut_after (a::before) ~pkg_name l
+      | Some (a,b) -> Some (List.rev ((Libs a)::before), (Libs b)::l)
+    end
+
+let findlib_dynload ~name ~mode cctx t =
+  let sctx     = CC.super_context cctx in
+  let obj_dir  = CC.obj_dir       cctx in
+  match cut_after [] ~pkg_name:"findlib.dynload" t.libs_or_module with
+      | Some (before, after) ->
+        (* If findlib.dynload is linked, we stores in the binary the packages linked by linking just
+           after findlib.dynload a module containing the info *)
+        let libs =
+          List.filter
+            ~f:(fun lib -> match Lib.status lib with | Lib.Status.Private _ -> false | _ -> true)
+            (only_libs t.libs_or_module)
+        in
+        (* We can't use directly Findlib.Package.preds because there
+           are fixups in ocamlfind that adds the package "thread" as
+           dependency of all the packages when the predicate "mt" is
+           used. Also independently of ocamlfind it could be strange
+           if a library can be used without or with `thread` but
+           "thread" is forced during dynlink because we always add "mt". *)
+        let preds =
+          if List.exists libs ~f:(fun lib -> Lib.name lib = "threads")
+          then Findlib.Package.preds
+          else
+            Variant.Set.diff Findlib.Package.preds
+              (Variant.Set.of_list [Variant.mt;Variant.mt_posix])
+        in
+        let preds = Variant.Set.add preds (Mode.variant mode) in
+        let s =
+          Format.asprintf "%a@\nFindlib.record_package_predicates %a;;@."
+            (Fmt.list ~pp_sep:Fmt.nl (fun fmt lib ->
+               Format.fprintf fmt "Findlib.record_package Findlib.Record_core %S;;"
+                 (Lib.name lib)))
+            libs
+            (Fmt.ocaml_list Variant.pp) (Variant.Set.to_list preds)
+        in
+        let basename = Format.asprintf "%s_findlib_initl_%a" name Mode.pp mode in
+        let ml  = Path.relative obj_dir (basename ^ ".ml") in
+        SC.add_rule sctx (Build.write_file ml s);
+        let impl = Module.File.make OCaml ml in
+        let name = Module.Name.of_string basename in
+        let module_ = Module.make ~impl name in
+        let cctx = Compilation_context.(
+          create
+            ~super_context:sctx
+            ~scope:(scope cctx)
+            ~dir:(dir cctx)
+            ~dir_kind:(dir_kind cctx)
+            ~obj_dir:(obj_dir cctx)
+            ~modules:(Module.Name.Map.singleton name module_)
+            ~requires:(Lib.DB.find_many (SC.public_libs sctx) ["findlib"])
+            ~flags:Ocaml_flags.empty
+            ~opaque:true
+            ())
+        in
+        Module_compilation.build_module ~dynlink:false
+          ~dep_graphs:(Ocamldep.Dep_graphs.dummy module_)
+          cctx
+          module_;
+        {
+          libs_or_module = before@[Module module_]@after;
+          flags = Ocaml_flags.append_common t.flags ["-linkall"];
+        }
+      | None ->
+        t

src/link_time_code_gen.mli

@@ -0,0 +1,23 @@
+(** {1 Handle link time code generation} *)
+
+type libs_or_module =
+  | Libs of Lib.L.t
+  | Module of Module.t
+(** List of library and modules in link order *)
+
+type t = {
+  libs_or_module: libs_or_module list;
+  flags: Ocaml_flags.t;
+}
+
+
+val create: ?flags:Ocaml_flags.t -> Lib.L.t -> t
+(** Should be the complete list of library linked in dependency order *)
+
+val findlib_dynload:
+  name:string ->
+  mode:Mode.t ->
+  Compilation_context.t ->
+  t ->
+  t
+(** Insert link time generated code for findlib_dynload in the list *)

src/mode.ml

@@ -11,6 +11,10 @@ let t =
     ; "native" , Native
     ]
 
+let pp fmt = function
+  | Byte -> Format.pp_print_string fmt "byte"
+  | Native -> Format.pp_print_string fmt "native"
+
 let choose byte native = function
   | Byte   -> byte
   | Native -> native

src/mode.mli

@@ -16,6 +16,8 @@ val of_cm_kind : Cm_kind.t -> t
 
 val variant : t -> Variant.t
 
+val pp : t Fmt.t
+
 module Dict : sig
   type mode = t
 

src/package.mli

@@ -9,8 +9,6 @@ module Name : sig
 
   val opam_fn : t -> string
 
-  val pp : Format.formatter -> t -> unit
-
   include Interned.S with type t := t
 
   val t : t Sexp.Of_sexp.t

src/stdune/interned.ml

@@ -2,6 +2,7 @@ module type S = sig
   type t
   val compare : t -> t -> Ordering.t
   val to_string : t -> string
+  val pp: t Fmt.t
   val make : string -> t
   val get : string -> t option
   module Set : sig
@@ -119,6 +120,7 @@ module No_interning(R : Settings)() = struct
   let compare = String.compare
   let make s = s
   let to_string s = s
+  let pp fmt s = Format.fprintf fmt "%S" (to_string s)
   let get s = Some s
 
   module Set = struct

src/stdune/interned.mli

@@ -4,6 +4,7 @@ module type S = sig
   type t
   val compare : t -> t -> Ordering.t
   val to_string : t -> string
+  val pp : t Fmt.t
 
   val make : string -> t
 

test/blackbox-tests/dune.inc

@@ -199,6 +199,14 @@
    test-cases/findlib
    (progn (run %{exe:cram.exe} -test run.t) (diff? run.t run.t.corrected)))))
 
+(alias
+ (name findlib-dynload)
+ (deps (package dune) (source_tree test-cases/findlib-dynload))
+ (action
+  (chdir
+   test-cases/findlib-dynload
+   (progn (run %{exe:cram.exe} -test run.t) (diff? run.t run.t.corrected)))))
+
 (alias
  (name findlib-error)
  (deps (package dune) (source_tree test-cases/findlib-error))
@@ -839,6 +847,7 @@
   (alias exec-missing)
   (alias fallback-dune)
   (alias findlib)
+  (alias findlib-dynload)
   (alias findlib-error)
   (alias fmt)
   (alias force-test)

test/blackbox-tests/gen_tests.ml

@@ -139,6 +139,7 @@ let exclusions =
   ; make "github764" ~skip_platforms:[Win]
   ; make "gen-opam-install-file" ~external_deps:true
   ; make "scope-ppx-bug" ~external_deps:true
+  ; make "findlib-dynload" ~external_deps:true
   (* The next test is disabled as it relies on configured opam
      swtiches and it's hard to get that working properly *)
   ; make "envs-and-contexts" ~external_deps:true ~enabled:false

test/blackbox-tests/test-cases/findlib-dynload/a.ml

@@ -0,0 +1,2 @@
+let () = print_endline "a: init"
+let called () = print_endline "a: called"

test/blackbox-tests/test-cases/findlib-dynload/b.ml

@@ -0,0 +1,4 @@
+let () = print_endline "b: init"
+let called () = print_endline "b: called"; A.called ()
+
+let () = Mytool.Register.register "b" called

test/blackbox-tests/test-cases/findlib-dynload/dune

@@ -0,0 +1,37 @@
+(library
+  (name a)
+  (public_name a)
+  (modules a)
+)
+
+(library
+  (name b)
+  (public_name b)
+  (modules b)
+  (libraries a mytool)
+)
+
+(library
+  (name mytool)
+  (public_name mytool)
+  (modules register)
+)
+
+(executable
+  (name main)
+  (modules main)
+  (public_name mytool)
+  (package mytool)
+  (libraries mytool findlib.dynload)
+ )
+
+
+(rule (copy main.ml main_with_a.ml))
+
+(executable
+  (name main_with_a)
+  (modules main_with_a)
+  (public_name mytool_with_a)
+  (package mytool)
+  (libraries mytool findlib.dynload a)
+ )

test/blackbox-tests/test-cases/findlib-dynload/dune-project

@@ -0,0 +1 @@
+(lang dune 1.0)

test/blackbox-tests/test-cases/findlib-dynload/main.ml

@@ -0,0 +1,9 @@
+let () = print_endline "m: init"
+
+let () =
+  for i = 1 to (Array.length Sys.argv - 1); do
+    try
+      Fl_dynload.load_packages [Sys.argv.(i)]
+    with Fl_package_base.No_such_package(pkg, _) ->
+      Printf.printf "The package %S can't be found.\n%!" pkg
+  done

test/blackbox-tests/test-cases/findlib-dynload/register.ml

@@ -0,0 +1 @@
+let register s f = print_endline (s^": registering"); f ()

test/blackbox-tests/test-cases/findlib-dynload/run.t

@@ -0,0 +1,48 @@
+  $ dune build
+
+  $ dune exec mytool
+  m: init
+
+  $ dune exec mytool inexistent
+  m: init
+  The package "inexistent" can't be found.
+
+  $ dune exec mytool a
+  m: init
+  a: init
+
+  $ dune exec mytool b
+  m: init
+  a: init
+  b: init
+  b: registering
+  b: called
+  a: called
+
+  $ dune exec mytool b a
+  m: init
+  a: init
+  b: init
+  b: registering
+  b: called
+  a: called
+
+  $ dune exec mytool_with_a
+  a: init
+  m: init
+
+  $ dune exec mytool_with_a b
+  a: init
+  m: init
+  b: init
+  b: registering
+  b: called
+  a: called
+
+  $ dune exec mytool_with_a a b
+  a: init
+  m: init
+  b: init
+  b: registering
+  b: called
+  a: called