restores unit tracking in the plugin facility

lib/bap_plugins/bap_plugins.ml

@@ -3,7 +3,7 @@ open Bap_bundle.Std
 open Bap_future.Std
 open Or_error.Monad_infix
 
-module Units = Bap_plugins_units
+module Units = Bap_plugins_units.Make()
 module Filename = Caml.Filename
 module Sys = Caml.Sys
 

lib/bap_plugins/bap_plugins_units.ml

@@ -1,41 +1,107 @@
 open Core_kernel[@@warning "-D"]
 
-let name = "dynlink"
+open Bap_plugins_units_intf
+
+module Findlib = struct
+  let name = "findlib"
+  let units : reason String.Table.t = String.Table.create ()
+
+  let has_meta_information pkg =
+    try ignore (Findlib.package_meta_file pkg : string); true
+    with Findlib.No_such_package _ -> false
+
+  let report_missing_meta pkg =
+    failwithf
+      "Package %s was used to build the host program, but its meta \
+       information is not available at runtime. To be able to use \
+       plugins without installed META files, either update the version \
+       of OCaml to 4.08 or newer or provide them at the compilation \
+       time via the `used_MOD` predicates for each `MOD` linked into the
+    host binary." pkg ()
+
+
+  (* this function requires working Findlib infrastructure. *)
+  let unit_of_package ~findlib_is_required pkg =
+    if findlib_is_required && not (has_meta_information pkg)
+    then report_missing_meta pkg;
+    let preds = Findlib.recorded_predicates () in
+    try
+      Findlib.package_property preds pkg "archive" |>
+      Filename.chop_extension
+    with _ -> pkg
+
+
+  let string_of_reason = function
+    | `In_core -> "is core unit"
+    | `Provided_by plugin -> "was provided by " ^ plugin
+    | `Requested_by plugin -> "was loaded on request from " ^ plugin
+
+  let extract_units_from_predicates () =
+    Findlib.recorded_predicates () |> List.iter ~f:(fun pred ->
+        match String.chop_prefix pred ~prefix:"used_" with
+        | None -> ()
+        | Some lib -> Hashtbl.set units ~key:lib ~data:`In_core)
+
+  let extract_units_from_packages ~findlib_is_required =
+    Findlib.(recorded_packages Record_core) |> List.iter ~f:(fun pkg ->
+        Hashtbl.set units
+          (unit_of_package ~findlib_is_required pkg)
+          `In_core)
+
+  let init () =
+    if not (Hashtbl.is_empty units)
+    then failwith "the plugin system is already initialized";
+    extract_units_from_predicates ();
+    extract_units_from_packages ~findlib_is_required:(Hashtbl.is_empty units)
+
+  let record name reason =
+    Hashtbl.add_exn units name reason
+
+  let lookup = Hashtbl.find units
+
+  let list () = Hashtbl.keys units
+
+  let handle_error _ _ err = Or_error.error_string @@ Dynlink.error_message err
+end
+
+module Dynlink = struct
+  let name = "dynlink"
+
+  let units : reason String.Table.t = String.Table.create ()
+
+  (* see https://github.com/ocaml/ocaml/issues/9338
+     this ugly clutch could only be removed after we phase out
+     OCaml 4.11, as the fix (https://github.com/ocaml/ocaml/pull/9790)
+     was only merged in 4.12 *)
+  let init_dynlink () =
+    try Dynlink.loadfile "" with _ -> ()
+
+  let copy_units_from_dynlink () =
+    init_dynlink ();
+    Dynlink.all_units () |>
+    List.iter ~f:(fun unit -> Hashtbl.add_exn units unit `In_core)
+
+  let init () = copy_units_from_dynlink ()
+  let list () = Hashtbl.keys units
+  let record name reason = match Hashtbl.add units name reason with
+    | `Ok -> ()
+    | `Duplicate ->
+      failwithf "bap-plugins: internal error - \
+                 the unit %s is already loaded" name ()
+
+  let lookup = Hashtbl.find units
+  let handle_error name reason = function
+    | Dynlink.Module_already_loaded _ ->
+      Hashtbl.set units name reason;
+      Ok ()
+    | other ->
+      Or_error.error_string (Dynlink.error_message other)
+end
+
 
 let is_toplevel = Caml.Sys.interactive.contents
 
-type reason = [
-  | `In_core
-  | `Provided_by of string
-  | `Requested_by of string
-]
-
-let units : reason String.Table.t = String.Table.create ()
-
-(* see https://github.com/ocaml/ocaml/issues/9338
-   this ugly clutch could only be removed after we phase out
-   OCaml 4.11, as the fix (https://github.com/ocaml/ocaml/pull/9790)
-   was only merged in 4.12 *)
-let init_dynlink () =
-  try Dynlink.loadfile "" with _ -> ()
-
-let copy_units_from_dynlink () =
-  init_dynlink ();
-  Dynlink.all_units () |>
-  List.iter ~f:(fun unit -> Hashtbl.add_exn units unit `In_core)
-
-let init () = if not is_toplevel then copy_units_from_dynlink ()
-let list () = Hashtbl.keys units
-let record name reason = match Hashtbl.add units name reason with
-  | `Ok -> ()
-  | `Duplicate ->
-    failwithf "bap-plugins: internal error - \
-               the unit %s is already loaded" name ()
-
-let lookup = Hashtbl.find units
-let handle_error name reason = function
-  | Dynlink.Module_already_loaded _ ->
-    Hashtbl.set units name reason;
-    Ok ()
-  | other ->
-    Or_error.error_string (Dynlink.error_message other)
+module Make() =
+  (val if is_toplevel
+    then (module Findlib : S)
+    else (module Dynlink : S))

lib/bap_plugins/bap_plugins_units.mli

@@ -1,46 +1,3 @@
 (** Internal module.  *)
 
-open Core_kernel[@@warning "-D"]
-
-type reason = [
-  | `In_core
-  | `Provided_by of string
-  | `Requested_by of string
-]
-
-
-
-(** the name of the selected backend.
-
-    Currently, it should be [findlib] or [dynlink], and is
-    selected at configuration time via `./configure --plugins-backend`.
-*)
-val name : string
-
-(** initializes the unit system.
-
-    May fail if the selected backend is unable to provide safe
-    operation.
-
-    Could be only called once per program run.
-*)
-val init : unit -> unit
-
-
-(** [list ()] enumerates all currently linked modules.    *)
-val list : unit -> string list
-
-
-(** [record name reason] records unit [name] as well as the
-    reason, why it is linked.
-
-    pre: a unit with such name is not linked.
-*)
-val record : string -> reason -> unit
-
-
-(** [lookup name] checks if a unit with the given [name] is linked,
-    and returns a reason why it was linked. *)
-val lookup : string -> reason option
-
-val handle_error : string -> reason -> Dynlink.error -> unit Or_error.t
+module Make() : Bap_plugins_units_intf.S

lib/bap_plugins/bap_plugins_units_intf.ml

@@ -0,0 +1,44 @@
+(** Internal module.  *)
+
+open Core_kernel[@@warning "-D"]
+
+type reason = [
+  | `In_core
+  | `Provided_by of string
+  | `Requested_by of string
+]
+
+module type S = sig
+
+
+  (** the name of the selected backend.
+      Currently, it should be [findlib] or [dynlink], and is
+      selected at configuration time via `./configure --plugins-backend`.
+  *)
+  val name : string
+
+  (** initializes the unit system.
+      May fail if the selected backend is unable to provide safe
+      operation.
+      Could be only called once per program run.
+  *)
+  val init : unit -> unit
+
+
+  (** [list ()] enumerates all currently linked modules.    *)
+  val list : unit -> string list
+
+
+  (** [record name reason] records unit [name] as well as the
+      reason, why it is linked.
+      pre: a unit with such name is not linked.
+  *)
+  val record : string -> reason -> unit
+
+
+  (** [lookup name] checks if a unit with the given [name] is linked,
+      and returns a reason why it was linked. *)
+  val lookup : string -> reason option
+
+  val handle_error : string -> reason -> Dynlink.error -> unit Or_error.t
+end

oasis/plugins

@@ -8,6 +8,7 @@ Library bap_plugins
   FindLibName:     bap-plugins
   Modules:         Bap_plugins
   InternalModules: Bap_plugins_config,
-                   Bap_plugins_units
+                   Bap_plugins_units,
+                   Bap_plugins_units_intf
   BuildDepends:    core_kernel, dynlink, fileutils, findlib, bap-bundle, bap-future,
                    uri, ppx_bap