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>
This commit is contained in:
parent
fc0d99c9bb
commit
7f09979853
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
18
src/lib.ml
18
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 |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
|
10
src/lib.mli
10
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 *)
|
||||
|
|
|
@ -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
|
|
@ -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 *)
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -0,0 +1,2 @@
|
|||
let () = print_endline "a: init"
|
||||
let called () = print_endline "a: called"
|
|
@ -0,0 +1,5 @@
|
|||
let t =
|
||||
Thread.create
|
||||
(fun () -> Thread.delay 0.0001 ) ()
|
||||
|
||||
let () = Mytool.Register.register "c_thread" (fun () -> Thread.join t)
|
|
@ -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)
|
||||
)
|
|
@ -0,0 +1 @@
|
|||
(lang dune 1.0)
|
|
@ -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
|
|
@ -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
|
|
@ -0,0 +1,4 @@
|
|||
let () = print_endline "b: init"
|
||||
let called () = print_endline "b: called"; A.called ()
|
||||
|
||||
let () = Mytool.Register.register "b" called
|
|
@ -0,0 +1 @@
|
|||
let register s f = print_endline (s^": registering"); f ()
|
|
@ -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
|
Loading…
Reference in New Issue