provides versioned backends for program units symbol tables

.travis.yml

@@ -37,9 +37,9 @@ cache:
   - $HOME/save_opam
 
 env:
-  - OCAML_VERSION=4.07 WITH_BUILD_CACHE=true
+  - OCAML_VERSION=4.07
   - OCAML_VERSION=4.08
-  - OCAML_VERSION=4.09
+  - OCAML_VERSION=4.09 WITH_BUILD_CACHE=true
 
 stage: Compile
 script: bash -ex .travis_install.sh
@@ -48,13 +48,13 @@ jobs:
   include:
   - stage: Unit tests, checks and bil tests
     env:
-    - OCAML_VERSION=4.07 WITH_BUILD_CACHE=true
+    - OCAML_VERSION=4.09 WITH_BUILD_CACHE=true
     script: bash -ex .run_travis_tests.sh unit_tests
   - stage: Unit tests, checks and bil tests
     env:
-    - OCAML_VERSION=4.07 WITH_BUILD_CACHE=true
+    - OCAML_VERSION=4.09 WITH_BUILD_CACHE=true
     script: bash -ex .run_travis_tests.sh checks
   - stage: Unit tests, checks and bil tests
     env:
-    - OCAML_VERSION=4.07 WITH_BUILD_CACHE=true
+    - OCAML_VERSION=4.09 WITH_BUILD_CACHE=true
     script: bash -ex .run_travis_tests.sh veri

lib/bap_plugins/.merlin

@@ -1,3 +1,6 @@
 PKG findlib
+B ../../_build/lib/bap_config
+B ../bap_bundle
+B ../bap_future
+
 REC
-B ../../_build/lib/bap_config

lib/bap_plugins/bap_plugins.ml

@@ -3,6 +3,7 @@ open Bap_bundle.Std
 open Bap_future.Std
 open Or_error.Monad_infix
 
+module Units = Bap_plugins_units
 module Filename = Caml.Filename
 
 module Plugin = struct
@@ -33,34 +34,12 @@ module Plugin = struct
   let system_events,event = Stream.create ()
   let notify (value : system_event) = Signal.send event value
 
-  type reason = [
-    | `In_core
-    | `Provided_by of string
-    | `Requested_by of string
-  ]
-
   let load = ref Dynlink.loadfile
-  let units : reason String.Table.t = String.Table.create ()
 
   let setup_dynamic_loader loader =
     load := loader
 
-  (* this function requires working Findlib infrastructure. *)
-  let unit_of_package pkg =
-    let preds = Findlib.recorded_predicates () in
-    try
-      Findlib.package_property preds pkg "archive" |>
-      Filename.chop_extension
-    with _ -> pkg  (* fails if the infrastructure is broken *)
-
-  let init = lazy begin
-    Findlib.(recorded_packages Record_core) |> List.iter ~f:(fun pkg ->
-        Hashtbl.set units ~key:(unit_of_package pkg) ~data:`In_core);
-    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)
-  end
+  let init = lazy (Units.init ())
 
   let of_path path =
     try
@@ -91,19 +70,19 @@ module Plugin = struct
   let find_library name =
     try Some (find_library_exn name) with _ -> None
 
-  let load_unit ~reason ~name pkg : unit or_error =
-    let open Format in
+  let load_unit ?(don't_register=false) ~reason ~name pkg : unit or_error =
     try
       notify (`Linking name);
       !load pkg;
-      Hashtbl.set units ~key:name ~data:reason;
+      if not (don't_register)
+      then Units.record name reason;
       Ok ()
     with
-    | Dynlink.Error err ->
-      Or_error.error_string (Dynlink.error_message err)
+    | Dynlink.Error err -> Units.handle_error name reason err
     | exn -> Or_error.of_exn exn
 
 
+
   let is_debugging () =
     try String.(Sys.getenv "BAP_DEBUG" <> "0") with Caml.Not_found -> false
 
@@ -134,7 +113,7 @@ module Plugin = struct
       overwritten). This is a known bug/issue in the OCaml runtime
       that we need to workaround.
   *)
-  let load_entry plugin name =
+  let load_entry ?don't_register plugin name =
     let suffix = if Dynlink.is_native then ".cmxs" else ".cma" in
     let name = Filename.basename name in
     let dst = Filename.(temp_file name suffix) in
@@ -143,17 +122,17 @@ module Plugin = struct
     Bundle.get_file ~name:dst plugin.bundle path |> function
     | Some uri ->
       let path = Uri.to_string uri in
-      let result = load_unit ~reason ~name path in
+      let result = load_unit ?don't_register ~reason ~name path in
       do_if_not_debugging Sys.remove path;
       result
     | None -> match find_library name with
       | Some lib ->
         let name = Filename.(basename name |> chop_extension) in
-        load_unit ~reason ~name lib
+        load_unit ?don't_register ~reason ~name lib
       | None -> Or_error.error_string "dependency not found"
 
   let validate_unit _plugin main =
-    match Hashtbl.find units main with
+    match Units.lookup main with
     | None -> Ok ()
     | Some (`Provided_by name) when String.equal name main -> Ok ()
     | Some reason ->
@@ -176,6 +155,8 @@ module Plugin = struct
           Or_error.errorf "Failed to load %s: %s" entry @@
           Error.to_string_hum err)
 
+  let is_missing dep = Option.is_none (Units.lookup dep)
+
   let try_load (plugin : t) =
     if Future.is_decided plugin.loaded
     then Ok ()
@@ -185,19 +166,17 @@ module Plugin = struct
       let m = manifest plugin in
       let mains = Manifest.provides m in
       validate_provided plugin mains >>= fun () ->
-      let reqs = Manifest.requires m |>
-                 List.filter ~f:(fun r -> not (Hashtbl.mem units r)) in
+      let reqs = Manifest.requires m |> List.filter ~f:is_missing in
       let main = Manifest.main m in
       let old_bundle = main_bundle () in
       set_main_bundle (bundle plugin);
       load_entries plugin reqs >>= fun () ->
-      load_entry plugin main >>| fun () ->
+      load_entry ~don't_register:true plugin main >>| fun () ->
       Promise.fulfill plugin.finish ();
       notify (`Loaded plugin);
       set_main_bundle old_bundle;
       let reason = `Provided_by plugin.name in
-      List.iter mains ~f:(fun unit ->
-          Hashtbl.set units ~key:unit ~data:reason)
+      List.iter mains ~f:(fun unit -> Units.record unit reason)
 
 
   let with_argv argv f = match argv with
@@ -323,7 +302,6 @@ module Plugins = struct
           events_backtrace := ev :: !events_backtrace);
     Future.upon loaded (fun () -> events_backtrace := [])
 
-
   let run ?argv ?env ?provides ?(don't_setup_handlers=false) ?library ?exclude () =
     if not don't_setup_handlers
     then setup_default_handler ();
@@ -339,6 +317,6 @@ module Std = struct
   module Plugin = Plugin
   module Plugins = Plugins
   let setup_dynamic_loader = Plugin.setup_dynamic_loader
-  let list_loaded_units () = Hashtbl.keys Plugin.units
+  let list_loaded_units () = Units.list ()
 
 end

lib/bap_plugins/bap_plugins_units.ml

@@ -0,0 +1,26 @@
+open Core_kernel
+
+open Bap_plugins_units_intf
+
+[%%if ocaml_version < (4,08,0)]
+include Bap_plugins_units_fallback
+[%%else]
+let name = "dynlink"
+
+let units : reason String.Table.t = String.Table.create ()
+
+let copy_units_from_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 = Hashtbl.add_exn units name reason
+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)
+[%%endif]

lib/bap_plugins/bap_plugins_units.mli

@@ -0,0 +1 @@
+include Bap_plugins_units_intf.S

lib/bap_plugins/bap_plugins_units_fallback.ml

@@ -0,0 +1,63 @@
+open Bap_plugins_units_intf
+
+open Core_kernel
+
+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

lib/bap_plugins/bap_plugins_units_fallback.mli

@@ -0,0 +1 @@
+include Bap_plugins_units_intf.S

lib/bap_plugins/bap_plugins_units_intf.ml

@@ -0,0 +1,81 @@
+(** Internal module.  *)
+
+(** Interface for units table.
+
+    We need to maintain a set of compilation units that comprise the
+    program, first of all to prevent double-linking (which is possible
+    before 4.08 and will lead to a segfault at best) and second to
+    track plugin dependencies that we need and that are not
+    satisfied. Even after 4.08, the OCaml loader won't let us link an
+    already linked unit (which is not a problem, as they give us
+    access to the list of loaded units).
+
+    For now we have an implementation that supports older versions of
+    OCaml, which relies on the presence of the META files that
+    describe installed packages (we need to map package names (which
+    are recorded in the core file by findlib.dynload) to the unit
+    names, or on a presence of the `used_<UNIT>` predicates, which are
+    recorded by bap building system (or any other build system that is
+    capable of passing predicates to ocamlfind, e.g., _not_ dune).
+
+    If META files are not available and units are not recorded in the
+    host file via the predicates, then we bail out with an error. This
+    could happen, for example, when the host program is built with
+    dune (or with some other build system that doesn't record units in
+    the predicates) and then the toolchain is erased or otherwise made
+    unavailable, e.g., when the program together with plugins is
+    packed into a debian package. To be clear, nothing wrong will
+    happen with the BAP framework.
+
+    The other implementation, that is available for OCaml versions
+    4.08 and above, is totally safe and relies purely on facilities
+    provided by the language runtime.
+*)
+
+open Core_kernel
+
+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

@@ -7,5 +7,8 @@ Library bap_plugins
   Path:            lib/bap_plugins
   FindLibName:     bap-plugins
   Modules:         Bap_plugins
-  InternalModules: Bap_plugins_config
-  BuildDepends:    core_kernel, dynlink, fileutils, findlib, bap-bundle, bap-future
+  InternalModules: Bap_plugins_config,
+                   Bap_plugins_units,
+                   Bap_plugins_units_fallback,
+                   Bap_plugins_units_intf
+  BuildDepends:    core_kernel, dynlink, fileutils, findlib, bap-bundle, bap-future, ppx_jane