makes the ABI processors usable programmatically (#1529)

Publishes several functions that make it easier to apply the ABI
processors. Also, fixes the naming scheme for the abi processors that
stopped to be unique, after we switched to the real ABI names. We now
use the target name for the name of the ABI.

Author: ivg

lib/bap_c/bap_c_abi.ml

@@ -1,4 +1,5 @@
 open Core_kernel[@@warning "-D"]
+open Bap_core_theory
 open Bap.Std
 open Bap_c_type
 open Monads.Std
@@ -184,10 +185,43 @@ let create_arg size i intent name t (data,exp) sub =
   let arg = Term.set_attr arg Attrs.layout layout in
   arg
 
-let registry = Hashtbl.create (module String)
-let register name abi = Hashtbl.set registry ~key:name ~data:abi
+
+
+let models = Hashtbl.create (module Theory.Target)
+
+let register_model target model =
+  if Hashtbl.mem models target
+  then invalid_argf "A data model for target %s is already set"
+      (Theory.Target.to_string target) ();
+  Hashtbl.add_exn models target (model :> Bap_c_size.base)
+
+let model target = match Hashtbl.find models target with
+  | Some m -> m
+  | None -> if Theory.Target.bits target = 32
+    then new Bap_c_size.base `LP32
+    else new Bap_c_size.base `LP64
+
+let registry = Hashtbl.create (module Theory.Target)
+
+let register name abi =
+  let target = match Theory.Target.lookup ~package:"bap" name with
+    | Some t -> t
+    | None -> invalid_argf
+                "The name of the abi should be a valid name. Got %s. \
+                 See `bap list targets` for the list valid names" name () in
+  Hashtbl.add registry ~key:target ~data:abi |> function
+  | `Ok -> ()
+  | `Duplicate ->
+    invalid_argf "The processor for ABI %s is already registered. \
+                  Please pick a unique name" name ()
 let register_abi = register
-let get_processor name = Hashtbl.find registry name
+
+let get_processor name =
+  match Theory.Target.lookup ~package:"bap" name with
+  | None -> None
+  | Some t -> Hashtbl.find registry t
+
+let lookup = Hashtbl.find registry
 
 
 let get_prototype gamma name = match gamma name with
@@ -212,6 +246,40 @@ let get_prototype gamma name = match gamma name with
         }
     }
 
+
+let apply_args abi size attrs t sub =
+  let t = decay_arrays t in
+  match abi.insert_args sub attrs t with
+  | None -> sub
+  | Some {return; hidden; params} ->
+    let params = List.mapi params ~f:(fun i a -> i,a) in
+    List.map2 params t.Bap_c_type.Proto.args ~f:(fun (i,a) (n,t) ->
+        create_arg size i (arg_intent t) n t a sub) |>
+    function
+    | Unequal_lengths ->
+      error "The ABI processor generated an incorrect number of \
+             argument terms for the subroutine %s: %d <> %d"
+        (Sub.name sub)
+        (List.length params)
+        (List.length t.args);
+      sub
+    | Ok args ->
+      let ret = match return with
+        | None -> []
+        | Some ret ->
+          let t = t.Bap_c_type.Proto.return in
+          [create_arg size 0 Out "result" t ret sub] in
+      let hid = List.mapi hidden ~f:(fun i (t,a) ->
+          let n = "hidden" ^ if i = 0 then "" else Int.to_string i in
+          create_arg size 0 Both n t a sub) in
+      List.fold (args@hid@ret) ~init:sub ~f:(Term.append arg_t)
+
+let apply abi size attrs t sub =
+  let sub = apply_args abi size attrs t sub in
+  let sub = Term.set_attr sub Attrs.proto t in
+  let sub = List.fold_right ~init:sub attrs ~f:Bap_c_attr.apply in
+  abi.apply_attrs attrs sub
+
 let create_api_processor size abi : Bap_api.t =
   let stage1 gamma = object(self)
     inherit Term.mapper as super
@@ -225,40 +293,7 @@ let create_api_processor size abi : Bap_api.t =
       else
         let name = Sub.name sub in
         let {Bap_c_type.Spec.t; attrs} = get_prototype gamma name in
-        let sub = self#apply_args sub attrs t in
-        let sub = Term.set_attr sub Attrs.proto t in
-        let sub = List.fold_right ~init:sub attrs ~f:Bap_c_attr.apply in
-        abi.apply_attrs attrs sub
-
-
-    method private apply_args sub attrs t =
-      let t = decay_arrays t in
-      match abi.insert_args sub attrs t with
-      | None ->
-        super#map_sub sub
-      | Some {return; hidden; params} ->
-        let params = List.mapi params ~f:(fun i a -> i,a) in
-        List.map2 params t.Bap_c_type.Proto.args ~f:(fun (i,a) (n,t) ->
-            create_arg size i (arg_intent t) n t a sub) |>
-        function
-        | Unequal_lengths ->
-          error "The ABI processor generated an incorrect number of \
-                 argument terms for the subroutine %s: %d <> %d"
-            (Sub.name sub)
-            (List.length params)
-            (List.length t.args);
-          sub
-        | Ok args ->
-          let ret = match return with
-            | None -> []
-            | Some ret ->
-              let t = t.Bap_c_type.Proto.return in
-              [create_arg size 0 Out "result" t ret sub] in
-          let hid = List.mapi hidden ~f:(fun i (t,a) ->
-              let n = "hidden" ^ if i = 0 then "" else Int.to_string i in
-              create_arg size 0 Both n t a sub) in
-          List.fold (args@hid@ret) ~init:sub ~f:(Term.append arg_t)
-
+        apply abi size attrs t sub
   end in
   let module Api = struct
     let language = "c"
@@ -780,15 +815,14 @@ module Arg = struct
 
   let install target ruler pass =
     let open Bap_core_theory in
-    let abi = Theory.Target.abi target in
-    let abi_name = Format.asprintf "%s"
-        (KB.Name.unqualified (Theory.Abi.name abi)) in
+    let abi_name = KB.Name.unqualified (Theory.Target.name target) in
     let abi_processor = {
       apply_attrs = (fun _ x -> x);
       insert_args = fun _ attrs proto ->
         reify target ruler (pass attrs proto)
     } in
     register_abi abi_name abi_processor;
+    register_model target ruler;
     Bap_abi.register_pass @@ fun proj ->
     if Theory.Target.equal (Project.target proj) target
     then begin

lib/bap_c/bap_c_abi.mli

@@ -84,6 +84,24 @@ val data : #Bap_c_size.base -> Bap_c_type.t -> Bap_c_data.t
 val layout : #Bap_c_size.base -> Bap_c_type.t -> Bap_c_data.layout
 
 
+(** [model target] returns the data model for the given target.
+
+    @since 2.5.0  *)
+val model : Theory.Target.t -> Bap_c_size.base
+
+
+(** [apply processor attrs proto sub] applies the abi processor to the
+    subroutine [sub].
+
+    The function inserts arguments and attaches appropriate arguments
+    to the function and its subterms, such as strores the type of each
+    argument, the provided C attributes, stores the prototype, computes
+    and attaches data layouts, etc.
+
+    @since 2.5.0 *)
+val apply : t -> #Bap_c_size.base ->  attr list -> proto -> sub term -> sub term
+
+
 (** [arg_intent t] infers argument intention based on its C type.  If
     an argument is passed by value, i.e., it is a c basic type, then
     it is an input argument. If an argument is a reference, but not a
@@ -95,12 +113,25 @@ val layout : #Bap_c_size.base -> Bap_c_type.t -> Bap_c_data.layout
 val arg_intent : Bap_c_type.t -> intent
 
 (** [register name t] registers an abi processor [t] named [name] that
-    may be used by subroutines in this project.*)
+    may be used by subroutines in this project.
+
+    @after 2.5.0 fails if there is already a processor for the given [name].
+    @after 2.5.0 the abi name should be a valid target name.
+*)
 val register : string -> t -> unit
+[@@deprecated "[since 2022-07] use the Arg module"]
 
 (** [get_processor name] is used to access an abi processor with its
     name.*)
 val get_processor : string -> t option
+[@@deprecated "[since 2022-07] use [lookup]"]
+
+
+(** [lookup t] the abi processor associated with the target [t].
+
+    @since 2.5.0
+*)
+val lookup : Theory.Target.t -> t option
 
 
 (** An abstraction of a stack, commonly used in C compilers.   *)
@@ -403,10 +434,10 @@ module Arg : sig
       [arena] is empty; or if some other argument is already passed
       via memory.
 
-      @since 2.5.0 accepts the [rev] parameter.
-      @since 2.5.0 accepts the [limit] parameter.
+      @after 2.5.0 accepts the [rev] parameter.
+      @after 2.5.0 accepts the [limit] parameter.
 
-      @since 2.5.0 passes as much as possible (up to the limit) of the
+      @after 2.5.0 passes as much as possible (up to the limit) of the
       object via registers.
 
       @before 2.5.0 was passing at most one word via registers.

lib/x86_cpu/x86_target.ml

@@ -544,14 +544,14 @@ module Abi = struct
 
   let calling_conventions = [
     (* 16-bit ABI *)
-    [i286], [
+    i286, [
       Abi.cdecl, cdecl16;
       Abi.pascal, pascal16;
       Abi.fortran, pascal16;
     ];
 
     (* 32-bit ABI  *)
-    [i386; i486; i586; i686], [
+    i386, [
       Abi.sysv, cdecl;
       Abi.cdecl, cdecl;
       Abi.pascal, pascal;
@@ -561,7 +561,7 @@ module Abi = struct
     ];
 
     (* 64-bit ABI *)
-    [amd64], [
+    amd64, [
       Abi.ms, ms64;
       Abi.sysv, sysv;
     ]
@@ -579,9 +579,8 @@ module Abi = struct
   ]
 
   let install_calling_conventions () =
-    List.iter calling_conventions ~f:(fun (targets,args) ->
-        List.cartesian_product targets args |>
-        List.iter ~f:(fun (parent,(abi,install)) ->
+    List.iter calling_conventions ~f:(fun (parent,abis) ->
+        List.iter abis ~f:(fun (abi,install) ->
             Theory.Target.filter ~parent ~abi () |>
             List.iter ~f:(fun t ->
                 if Theory.Target.bits t = Theory.Target.bits parent

plugins/arm/arm_gnueabi.ml

@@ -1,30 +1,26 @@
 open Core_kernel[@@warning "-D"]
 open Bap.Std
 open Bap_c.Std
-
-include Self()
+open Bap_core_theory
+
+module Arg = C.Abi.Arg
+open Arg.Language
+
+let data model = object(self)
+  inherit C.Size.base model
+  method! enum elts =
+    if Int64.(C.Size.max_enum_elt elts < (1L lsl 32))
+    then self#integer `uint
+    else self#integer `ulong_long
+  method! real = function
+    | `float -> `r32
+    | `double | `long_double -> `r64
+end
 
 module Aapcs32 = struct
-  open Bap_core_theory
-  open Bap_c.Std
-  open Bap.Std
-
-  module Arg = C.Abi.Arg
-  open Arg.Language
-
-  let model = object(self)
-    inherit C.Size.base `ILP32
-    method! enum elts =
-      if Int64.(C.Size.max_enum_elt elts < (1L lsl 32))
-      then self#integer `uint
-      else self#integer `ulong_long
-    method! real = function
-      | `float -> `r32
-      | `double | `long_double -> `r64
-  end
 
   let define t =
-    install t model @@ fun describe ->
+    install t (data `ILP32) @@ fun describe ->
     let* iargs = Arg.Arena.iargs t in
     let* irets = Arg.Arena.irets t in
     let rev = Theory.Endianness.(Theory.Target.endianness t = le) in
@@ -44,41 +40,15 @@ module Aapcs32 = struct
         Arg.memory
       ];
     ]
-
-  let supported_abis = Theory.Abi.[unknown; gnueabi; eabi]
-  let is_our_abi abi = List.exists supported_abis ~f:(Theory.Abi.equal abi)
-
-
-  let install () =
-    Theory.Target.family Arm_target.parent |>
-    List.iter ~f:(fun t ->
-        if Theory.Target.bits t = 32 &&
-           is_our_abi (Theory.Target.abi t)
-        then define t)
 end
 
-
 module Aapcs64 = struct
-  open Bap_core_theory
-  open Bap_c.Std
-  open Bap.Std
-
-  let name = "aapcs64"
-
-  module Arg = C.Abi.Arg
-  open Arg.Language
-
-  let data_model t =
-    let bits = Theory.Target.bits t in
-    new C.Size.base (if bits = 32 then `ILP32 else `LP64)
-
   let is_composite t =
     C.Type.(is_structure t || is_union t)
 
   let define t =
-    let model = data_model t in
+    let model = data `LP64 in
     let rev = Theory.Endianness.(Theory.Target.endianness t = le) in
-
     install t model @@ fun describe ->
     let* iargs = Arg.Arena.iargs t in
     let* irets = Arg.Arena.irets t in
@@ -126,20 +96,17 @@ module Aapcs64 = struct
         ]
       ]
     ]
-
-  let is_our_abi abi = List.exists ~f:(Theory.Abi.equal abi) Theory.Abi.[
-      unknown; gnu; eabi;
-    ]
-
-  let install () =
-    Theory.Target.family Arm_target.parent |>
-    List.iter ~f:(fun t ->
-        if Theory.Target.bits t = 64 && is_our_abi (Theory.Target.abi t)
-        then define t)
-
-
 end
 
+let is_our_abi abi = List.exists ~f:(Theory.Abi.equal abi) Theory.Abi.[
+    unknown; gnu; eabi; gnueabi;
+  ]
+
 let setup () =
-  Aapcs32.install ();
-  Aapcs64.install ();
+  Theory.Target.family Arm_target.parent |>
+  List.iter ~f:(fun t ->
+      if is_our_abi (Theory.Target.abi t)
+      then match Theory.Target.bits t with
+        | 64 -> Aapcs64.define t
+        | 32 -> Aapcs32.define t
+        | _ -> ())

plugins/arm/arm_main.ml

@@ -47,7 +47,7 @@ let () = Bap_main.Extension.declare ~doc @@ fun ctxt ->
   let backend = ctxt-->backend in
   let features = List.concat (ctxt-->features) in
   Arm_target.load ~features ?backend ?interworking ();
+  Arm_gnueabi.setup ();
   List.iter all_of_arms ~f:(fun arch ->
-      register_target (arch :> arch) (module ARM);
-      Arm_gnueabi.setup ());
+      register_target (arch :> arch) (module ARM));
   Ok ()