restores unit tracking in the plugin facility (#1548)

After we switched to OCaml 4.08 and above, we trashed custom unit
tracking from our plugin system and started to rely on the Dynlink
facility, provided by OCaml, that offers precise unit
tracking. However, Dynlink is not allowed inside OCaml Toplevel, which
wasn't noticed, because it wasn't properly initialized (though
apparently it worked fine for our needs). But after 4.12
(see ocaml/ocaml#9790) it was properly
initialized so we started to get "The dynlink.cma library cannot be used
inside the OCaml toplevel" messages when trying to use `baptop` or
`bap.top`. A quick-fix (#1541) did only worse as it disabled any unit
tracking and enabled double-loading of plugins and libraries (which is
perfectly allowed in OCaml toplevel and is not a bug, as it was in
regular OCaml runtime). Of course, double-loading could crash bap as
many of bap libraries have their own state, which got reset after
reloading.

This PR restores the old findlib-based unit tracker. This tracker is
not precise and may still miss loaded units. For example, if you load
bap manually and the do `#require "bap.top"` it will reload bap (which
should be a problem, but who knows). With that said, we had used this
tracker for many years, up until BAP 2.4.0, so I do have some trust in
it. Also, I don't want to invest more time in this issue as we are in
the process of switching to dune and thhe dune plugin system (that has
its own unit tracking system, which is precise). To be honest, dune
plugins also do not work in toplevel right now, but this is a
developing story (ocaml/dune#6081) and I
hope that eventually we will have it working.

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