makes the ABI processors usable programmatically

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 ()