From 7f09979853ed853b66633e267f3bd80d32fd3194 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fran=C3=A7ois=20Bobot?= Date: Thu, 23 Aug 2018 13:41:01 +0200 Subject: [PATCH] Adds support for findlib.dynload MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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 --- doc/advanced-topics.rst | 52 +++++++++++++++ src/exe.ml | 7 +- src/findlib.mli | 2 + src/lib.ml | 18 ++++++ src/lib.mli | 10 +++ src/link_time_code_gen.ml | 64 +++++++++++++++++++ src/link_time_code_gen.mli | 9 +++ src/mode.ml | 4 ++ src/mode.mli | 2 + src/package.mli | 2 - src/stdune/interned.ml | 2 + src/stdune/interned.mli | 1 + test/blackbox-tests/dune.inc | 9 +++ test/blackbox-tests/gen_tests.ml | 1 + .../test-cases/findlib-dynload/a.ml | 2 + .../test-cases/findlib-dynload/a.opam | 0 .../test-cases/findlib-dynload/c_thread.ml | 5 ++ .../test-cases/findlib-dynload/c_thread.opam | 0 .../test-cases/findlib-dynload/dune | 54 ++++++++++++++++ .../test-cases/findlib-dynload/dune-project | 1 + .../test-cases/findlib-dynload/main.ml | 12 ++++ .../test-cases/findlib-dynload/main_auto.ml | 11 ++++ .../findlib-dynload/mytool-plugin-b.opam | 0 .../test-cases/findlib-dynload/mytool.opam | 0 .../findlib-dynload/mytool_plugin_b.ml | 4 ++ .../test-cases/findlib-dynload/register.ml | 1 + .../test-cases/findlib-dynload/run.t | 60 +++++++++++++++++ 27 files changed, 329 insertions(+), 4 deletions(-) create mode 100644 src/link_time_code_gen.ml create mode 100644 src/link_time_code_gen.mli create mode 100644 test/blackbox-tests/test-cases/findlib-dynload/a.ml create mode 100644 test/blackbox-tests/test-cases/findlib-dynload/a.opam create mode 100644 test/blackbox-tests/test-cases/findlib-dynload/c_thread.ml create mode 100644 test/blackbox-tests/test-cases/findlib-dynload/c_thread.opam create mode 100644 test/blackbox-tests/test-cases/findlib-dynload/dune create mode 100644 test/blackbox-tests/test-cases/findlib-dynload/dune-project create mode 100644 test/blackbox-tests/test-cases/findlib-dynload/main.ml create mode 100644 test/blackbox-tests/test-cases/findlib-dynload/main_auto.ml create mode 100644 test/blackbox-tests/test-cases/findlib-dynload/mytool-plugin-b.opam create mode 100644 test/blackbox-tests/test-cases/findlib-dynload/mytool.opam create mode 100644 test/blackbox-tests/test-cases/findlib-dynload/mytool_plugin_b.ml create mode 100644 test/blackbox-tests/test-cases/findlib-dynload/register.ml create mode 100644 test/blackbox-tests/test-cases/findlib-dynload/run.t diff --git a/doc/advanced-topics.rst b/doc/advanced-topics.rst index 3099c5ad..72571cbe 100644 --- a/doc/advanced-topics.rst +++ b/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 +_` 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 diff --git a/src/exe.ml b/src/exe.ml index 2deb3659..60637715 100644 --- a/src/exe.ml +++ b/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 diff --git a/src/findlib.mli b/src/findlib.mli index e1eb110d..41a2419b 100644 --- a/src/findlib.mli +++ b/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 diff --git a/src/lib.ml b/src/lib.ml index 8c3987c6..c8af9217 100644 --- a/src/lib.ml +++ b/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 | +-----------------------------------------------------------------+ *) diff --git a/src/lib.mli b/src/lib.mli index 2d6644c6..8d0b7ff7 100644 --- a/src/lib.mli +++ b/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 *) diff --git a/src/link_time_code_gen.ml b/src/link_time_code_gen.ml new file mode 100644 index 00000000..762dbfbb --- /dev/null +++ b/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 diff --git a/src/link_time_code_gen.mli b/src/link_time_code_gen.mli new file mode 100644 index 00000000..34188c86 --- /dev/null +++ b/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 *) diff --git a/src/mode.ml b/src/mode.ml index 53dd99a9..75b65109 100644 --- a/src/mode.ml +++ b/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 diff --git a/src/mode.mli b/src/mode.mli index 2ae6df44..b12438fa 100644 --- a/src/mode.mli +++ b/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 diff --git a/src/package.mli b/src/package.mli index 4859721c..2950ae70 100644 --- a/src/package.mli +++ b/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 diff --git a/src/stdune/interned.ml b/src/stdune/interned.ml index 96716e1d..d17635be 100644 --- a/src/stdune/interned.ml +++ b/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 diff --git a/src/stdune/interned.mli b/src/stdune/interned.mli index acfe25ac..70b9ba87 100644 --- a/src/stdune/interned.mli +++ b/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 diff --git a/test/blackbox-tests/dune.inc b/test/blackbox-tests/dune.inc index e9af82f5..9d37371e 100644 --- a/test/blackbox-tests/dune.inc +++ b/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) diff --git a/test/blackbox-tests/gen_tests.ml b/test/blackbox-tests/gen_tests.ml index 2487e649..83dbd3dd 100644 --- a/test/blackbox-tests/gen_tests.ml +++ b/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 diff --git a/test/blackbox-tests/test-cases/findlib-dynload/a.ml b/test/blackbox-tests/test-cases/findlib-dynload/a.ml new file mode 100644 index 00000000..435b8b9f --- /dev/null +++ b/test/blackbox-tests/test-cases/findlib-dynload/a.ml @@ -0,0 +1,2 @@ +let () = print_endline "a: init" +let called () = print_endline "a: called" diff --git a/test/blackbox-tests/test-cases/findlib-dynload/a.opam b/test/blackbox-tests/test-cases/findlib-dynload/a.opam new file mode 100644 index 00000000..e69de29b diff --git a/test/blackbox-tests/test-cases/findlib-dynload/c_thread.ml b/test/blackbox-tests/test-cases/findlib-dynload/c_thread.ml new file mode 100644 index 00000000..541a9e6e --- /dev/null +++ b/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) diff --git a/test/blackbox-tests/test-cases/findlib-dynload/c_thread.opam b/test/blackbox-tests/test-cases/findlib-dynload/c_thread.opam new file mode 100644 index 00000000..e69de29b diff --git a/test/blackbox-tests/test-cases/findlib-dynload/dune b/test/blackbox-tests/test-cases/findlib-dynload/dune new file mode 100644 index 00000000..3f5db6e3 --- /dev/null +++ b/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) +) diff --git a/test/blackbox-tests/test-cases/findlib-dynload/dune-project b/test/blackbox-tests/test-cases/findlib-dynload/dune-project new file mode 100644 index 00000000..de4fc209 --- /dev/null +++ b/test/blackbox-tests/test-cases/findlib-dynload/dune-project @@ -0,0 +1 @@ +(lang dune 1.0) diff --git a/test/blackbox-tests/test-cases/findlib-dynload/main.ml b/test/blackbox-tests/test-cases/findlib-dynload/main.ml new file mode 100644 index 00000000..00a879b0 --- /dev/null +++ b/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 diff --git a/test/blackbox-tests/test-cases/findlib-dynload/main_auto.ml b/test/blackbox-tests/test-cases/findlib-dynload/main_auto.ml new file mode 100644 index 00000000..03034368 --- /dev/null +++ b/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 diff --git a/test/blackbox-tests/test-cases/findlib-dynload/mytool-plugin-b.opam b/test/blackbox-tests/test-cases/findlib-dynload/mytool-plugin-b.opam new file mode 100644 index 00000000..e69de29b diff --git a/test/blackbox-tests/test-cases/findlib-dynload/mytool.opam b/test/blackbox-tests/test-cases/findlib-dynload/mytool.opam new file mode 100644 index 00000000..e69de29b diff --git a/test/blackbox-tests/test-cases/findlib-dynload/mytool_plugin_b.ml b/test/blackbox-tests/test-cases/findlib-dynload/mytool_plugin_b.ml new file mode 100644 index 00000000..60f9bf62 --- /dev/null +++ b/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 diff --git a/test/blackbox-tests/test-cases/findlib-dynload/register.ml b/test/blackbox-tests/test-cases/findlib-dynload/register.ml new file mode 100644 index 00000000..3800f22f --- /dev/null +++ b/test/blackbox-tests/test-cases/findlib-dynload/register.ml @@ -0,0 +1 @@ +let register s f = print_endline (s^": registering"); f () diff --git a/test/blackbox-tests/test-cases/findlib-dynload/run.t b/test/blackbox-tests/test-cases/findlib-dynload/run.t new file mode 100644 index 00000000..bc588c99 --- /dev/null +++ b/test/blackbox-tests/test-cases/findlib-dynload/run.t @@ -0,0 +1,60 @@ + $ 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 mytool-plugin-b + m: init + a: init + b: init + b: registering + b: called + a: called + + $ dune exec mytool mytool-plugin-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 mytool-plugin-b + a: init + m: init + b: init + b: registering + b: called + a: called + + $ dune exec mytool_with_a a mytool-plugin-b + a: init + m: init + b: init + b: registering + b: called + a: called + + $ dune exe mytool_auto + m: init + a: init + b: init + b: registering + b: called + a: called + + $ dune exe mytool c_thread + m: init + c_thread: registering