From a15a7f2e085272db270c571983774abf094b4ef2 Mon Sep 17 00:00:00 2001 From: ivg Date: Fri, 19 Aug 2022 13:12:34 -0400 Subject: [PATCH] restores unit tracking in the plugin facility 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 https://github.com/ocaml/ocaml/pull/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 (https://github.com/ocaml/dune/issues/6081) and I hope that eventually we will have it working. --- lib/bap_plugins/bap_plugins.ml | 2 +- lib/bap_plugins/bap_plugins_units.ml | 138 ++++++++++++++++------ lib/bap_plugins/bap_plugins_units.mli | 45 +------ lib/bap_plugins/bap_plugins_units_intf.ml | 44 +++++++ oasis/plugins | 3 +- 5 files changed, 150 insertions(+), 82 deletions(-) create mode 100644 lib/bap_plugins/bap_plugins_units_intf.ml diff --git a/lib/bap_plugins/bap_plugins.ml b/lib/bap_plugins/bap_plugins.ml index 15f52c869..48cca3b1b 100644 --- a/lib/bap_plugins/bap_plugins.ml +++ b/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 diff --git a/lib/bap_plugins/bap_plugins_units.ml b/lib/bap_plugins/bap_plugins_units.ml index e705ce505..21aac8dd0 100644 --- a/lib/bap_plugins/bap_plugins_units.ml +++ b/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)) diff --git a/lib/bap_plugins/bap_plugins_units.mli b/lib/bap_plugins/bap_plugins_units.mli index 6128c0d53..60564da37 100644 --- a/lib/bap_plugins/bap_plugins_units.mli +++ b/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 diff --git a/lib/bap_plugins/bap_plugins_units_intf.ml b/lib/bap_plugins/bap_plugins_units_intf.ml new file mode 100644 index 000000000..6ec28549a --- /dev/null +++ b/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 diff --git a/oasis/plugins b/oasis/plugins index f707b2a34..d7c028234 100644 --- a/oasis/plugins +++ b/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