Adds support for findlib.dynload

doc/advanced-topics.rst

@@ -57,6 +57,58 @@ set of predicates:
   it is linked as part of a driver or meant to add a ``-ppx`` argument
   to the compiler, choose the former behavior
 
+Dynamic loading of packages
+===========================
+
+Dune supports the ``findlib.dynload`` package from `findlib
+<http://projects.camlcity.org/projects/findlib.html>_` that allows to dynamically
+load packages and their dependencies (using OCaml Dynlink module).
+So adding the ability for an application to have plugins just requires
+to add ``findlib.dynload`` to the set of library dependencies:
+
+.. code:: scheme
+    (library
+      (name mytool)
+      (public_name mytool)
+      (modules ...)
+    )
+
+    (executable
+      (name main)
+      (public_name mytool)
+      (libraries mytool findlib.dynload)
+      (modules ...)
+    )
+
+
+Then you could use in your application ``Fl_dynload.load_packages l``
+that will load the list ``l`` of packages. The packages are loaded
+only once. So trying to load a package statically linked does nothing.
+
+A plugin creator just need to link to your library:
+
+.. code:: scheme
+    (library
+      (name mytool_plugin_a)
+      (public_name mytool-plugin-a)
+      (libraries mytool)
+    )
+
+By choosing some naming convention, for example all the plugins of
+``mytool`` should start with ``mytool-plugin-``. You can automatically
+load all the plugins installed for your tool by listing the existing packages:
+
+.. code:: ocaml
+    let () = Findlib.init ()
+    let () =
+      let pkgs = Fl_package_base.list_packages () in
+      let pkgs =
+        List.filter
+          (fun pkg -> 14 <= String.length pkg && String.sub pkg 0 14 = "mytool-plugin-")
+          pkgs
+      in
+      Fl_dynload.load_packages pkgs
+
 .. _advanced-cross-compilation:
 
 Cross Compilation

src/exe.ml

@@ -139,6 +139,10 @@ let link_exe
       Build.dyn_paths (Build.arr (fun (modules, _) ->
         artifacts modules ~ext:ctx.ext_obj))
   in
+  let arg_spec_for_requires =
+    Result.map requires ~f:(Link_time_code_gen.libraries_link ~name ~mode cctx)
+  in
+  (* The rule *)
   SC.add_rule sctx
     (Build.fanout3
        (register_native_objs_deps modules_and_cm_files >>^ snd)
@@ -154,8 +158,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

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

src/lib.ml

@@ -440,6 +440,24 @@ module L = struct
     loop [] l Int.Set.empty
 end
 
+module Lib_and_module = struct
+  type nonrec t =
+    | Lib of t
+    | Module of Module.t * Path.t (** obj_dir *)
+
+  let link_flags ts ~mode ~stdlib_dir =
+    let libs = List.filter_map ts ~f:(function Lib lib -> Some lib | Module _ -> None) in
+    Arg_spec.S
+      (L.c_include_flags libs ~stdlib_dir ::
+       List.map ts ~f:(function
+         | Lib t ->
+           Arg_spec.Deps (Mode.Dict.get t.info.archives mode)
+         | Module (m,obj_dir) ->
+           Dep (Module.cm_file_unsafe m ~obj_dir (Mode.cm_kind mode))
+       ))
+
+end
+
 (* +-----------------------------------------------------------------+
    | Sub-systems                                                     |
    +-----------------------------------------------------------------+ *)

src/lib.mli

@@ -77,6 +77,16 @@ module L : sig
   val remove_dups : t -> t
 end
 
+(** Operation on list of libraries and modules *)
+module Lib_and_module : sig
+  type nonrec t =
+    | Lib of t
+    | Module of Module.t * Path.t (** obj_dir *)
+
+  val link_flags : t list -> mode:Mode.t -> stdlib_dir:Path.t -> _ Arg_spec.t
+
+end
+
 (** {1 Raw library descriptions} *)
 
 (** Information about a library *)

src/link_time_code_gen.ml

@@ -0,0 +1,64 @@
+open Import
+
+module CC = Compilation_context
+module SC = Super_context
+
+let of_libs = List.map ~f:(fun l -> Lib.Lib_and_module.Lib l)
+
+let rec cut_after_libs ~pkg_name before = function
+  | [] -> None
+  | a::l when Lib_name.compare (Lib.name a) pkg_name = Eq -> Some (List.rev (a::before),l)
+  | a::l -> cut_after_libs (a::before) ~pkg_name l
+
+let findlib_dynload = Lib_name.of_string_exn ~loc:None "findlib.dynload"
+
+let libraries_link ~name ~mode cctx libs =
+  let sctx       = CC.super_context cctx in
+  let ctx        = SC.context       sctx in
+  let obj_dir    = CC.obj_dir       cctx in
+  let stdlib_dir = ctx.stdlib_dir in
+  match cut_after_libs [] ~pkg_name:findlib_dynload libs 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)
+        libs
+    in
+    let preds = Variant.Set.add Findlib.Package.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 %a;;"
+             Lib_name.pp_quoted (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) [Lib_name.of_string_exn ~loc:None "findlib"])
+        ~flags:Ocaml_flags.empty
+        ~opaque:true
+        ())
+    in
+    Module_compilation.build_module ~dynlink:false
+      ~dep_graphs:(Ocamldep.Dep_graphs.dummy module_)
+      cctx
+      module_;
+    let lm = (of_libs before)@[Lib.Lib_and_module.Module (module_,obj_dir)]@(of_libs after) in
+    Arg_spec.S [A "-linkall"; Lib.Lib_and_module.link_flags lm ~mode ~stdlib_dir]
+  | None ->
+    Lib.L.link_flags libs ~mode ~stdlib_dir

src/link_time_code_gen.mli

@@ -0,0 +1,9 @@
+(** {1 Handle link time code generation} *)
+
+val libraries_link
+  :  name:string
+  -> mode:Mode.t
+  -> Compilation_context.t
+  -> Lib.L.t
+  -> _ Arg_spec.t
+(** Insert link time generated code for findlib_dynload in the list *)

src/mode.ml

@@ -12,6 +12,10 @@ let dparse =
     ; "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 dparse : t Dsexp.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

@@ -207,6 +207,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))
@@ -848,6 +856,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/c_thread.ml

@@ -0,0 +1,5 @@
+let t =
+  Thread.create
+    (fun () -> Thread.delay 0.0001 ) ()
+
+let () = Mytool.Register.register "c_thread" (fun () -> Thread.join t)

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

@@ -0,0 +1,54 @@
+(library
+  (name a)
+  (public_name a)
+  (modules a)
+)
+
+(library
+  (name mytool_plugin_b)
+  (public_name mytool-plugin-b)
+  (modules mytool_plugin_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 threads)
+ )
+
+
+(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 threads)
+ )
+
+
+(executable
+  (name main_auto)
+  (modules main_auto)
+  (public_name mytool_auto)
+  (package mytool)
+  (libraries mytool findlib.dynload findlib threads)
+ )
+
+
+(library
+  (name c_thread)
+  (public_name c_thread)
+  (modules c_thread)
+  (libraries threads mytool)
+)

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,12 @@
+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
+    | Dynlink.Error error ->
+      Printf.printf "Error during dynlink: %s\n%!" (Dynlink.error_message error)
+  done

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

@@ -0,0 +1,11 @@
+let () = print_endline "m: init"
+
+let () = Findlib.init ()
+let () =
+  let pkgs = Fl_package_base.list_packages () in
+  let pkgs =
+    List.filter
+      (fun pkg -> 14 <= String.length pkg && String.sub pkg 0 14 = "mytool-plugin-")
+      pkgs
+  in
+  Fl_dynload.load_packages pkgs

test/blackbox-tests/test-cases/findlib-dynload/mytool_plugin_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/register.ml

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