Allows libraries to be allocated at non-conflicting address spaces (#1559)

* Fix not propagating term attrs in `mangle_names` during lifting

* Fix style

* Update testsuite revision

* Log linking of lisp definitions

* Emit relocations for data symbols in LLVM

* KB interface for image loaders

* KB-ify the LLVM loader and prefer existing bias for the unit

* Add deps for `bap_llvm` library

* Add bitvec dep for `bap-std`

* Allocate libraries automatically

We will just round up to the nearest page after the previous
binary. Note that the main executable can go wherever it wants.

* Log the mangling of names in `stub-resolver`

* Load and map library segments in the Primus loader + apply relocations

* Ignore empty filename

* Rename and also log the steps of the Primus loader

* Adds `relative-relocation` to the schema

* Fix style

* Mark `llvm:relative-relocation` only when a symbol is unavailable

* Remove unused headers

* Fix for LLVM >= 12

Co-authored-by: bmourad01 <[email protected]>

Author: bmourad01

lib/bap/bap.mli

@@ -5738,18 +5738,35 @@ module Std : sig
         - [Error err] - a file was corrupted, according to the loader.
     *)
     module type Loader = sig
-
       (** [from_file name] loads a file with the given [name]. *)
       val from_file : string -> Ogre.doc option Or_error.t
 
       (** [from_data data] loads image from the specified array of bytes.  *)
       val from_data : Bigstring.t -> Ogre.doc option Or_error.t
-
     end
 
     (** [register_loader ~name backend] registers new loader. *)
     val register_loader : name:string -> (module Loader) -> unit
 
+    (** Interfaces for working with the Knowledge Base.
+
+        @since 2.6.0
+    *)
+    module KB : sig
+      (** Same as [Loader], but parameterized with the Knowledge monad.  *)
+      module type Loader = sig
+        (** [from_file name] loads a file with the given [name]. *)
+        val from_file : string -> Ogre.doc option knowledge
+
+        (** [from_data data] loads image from the specified array of bytes.  *)
+        val from_data : Bigstring.t -> Ogre.doc option knowledge
+      end
+
+      (** [register_loader ~name backend] registers a new loader that is
+          parameterized with the Knowledge monad. *)
+      val register_loader : name:string -> (module Loader) -> unit
+    end
+
     (** [find_loader name] lookups the loader registered under the
         given [name].
 
@@ -5946,6 +5963,13 @@ module Std : sig
       val relocation :
         (int64 * addr, (addr -> addr -> 'a) -> 'a) Ogre.attribute
 
+      (** [relative_relocation fixup] a value referenced at the code has
+          address [fixup] and refers to a pointer [p], which is relocated
+          to [p + base_address]. *)
+      val relative_relocation :
+        (addr, (addr -> 'a) -> 'a) Ogre.attribute
+
+
       (** [external_reference addr name] a piece of code at the
           specified address [addr] references an external symbol with
           the given [name]. *)

lib/bap/bap_project.ml

@@ -267,10 +267,47 @@ module Input = struct
         if Set.mem mems x then (xs, mems)
         else (x :: xs, Set.add mems x))
 
+  let provide_bias = Toplevel.var "provide-bias"
+  let provide_bias file = function
+    | None -> Ok ()
+    | Some bias -> try
+        let open KB.Syntax in
+        let bias = Word.to_bitvec bias in
+        Toplevel.put provide_bias begin
+          Theory.Unit.for_file file >>= fun unit ->
+          KB.collect Theory.Unit.bias unit >>= function
+          | Some _ -> !!()
+          | None ->
+            info "providing bias %a to unit %s" Bitvec.pp bias file;
+            KB.provide Theory.Unit.bias unit @@ Some bias
+        end;
+        Ok (Toplevel.get provide_bias)
+      with Toplevel.Conflict c ->
+        Or_error.errorf "%s: %s" file @@ KB.Conflict.to_string c
+
+  let page_align_up x =
+    let width = Addr.bitwidth x in
+    let align = Word.of_int ~width 0xFFF in
+    Addr.((x + align) land lnot align)
+
+  let next_bias ?bias img =
+    let memmap = Image.memory img in
+    match Memmap.(min_addr memmap, max_addr memmap) with
+    | None, _ | _, None -> bias
+    | Some lo, Some hi ->
+      Option.value_map bias ~default:hi ~f:(fun bias ->
+          let size = Addr.((hi - lo) ++ 1) in
+          Addr.(bias + size)) |>
+      page_align_up |> Option.some
+
   let of_image ?target ?loader ?(libraries = []) main =
-    List.map (main :: dedup libraries) ~f:(fun filename ->
-        Image.create ?backend:loader filename >>| fun (img,warns) ->
+    let rec aux ?bias acc = function
+      | [] -> Ok (List.rev acc)
+      | filename :: rest ->
+        provide_bias filename bias >>= fun () ->
+        Image.create ?backend:loader filename >>= fun (img,warns) ->
         List.iter warns ~f:(fun e -> warning "%a" Error.pp e);
+        let bias = next_bias img ?bias in
         let spec = Image.spec img in
         Signal.send Info.got_img img;
         let finish proj = {
@@ -283,8 +320,9 @@ module Input = struct
                   Term.set_attr sub Sub.entry_point ()
                 | _ -> sub)
         } in
-        result_of_image ?target finish filename img) |>
-    Or_error.all
+        let res = result_of_image ?target finish filename img in
+        aux (res :: acc) rest ?bias in
+    aux [] @@ dedup (main :: libraries)
 
   let from_image ?target ?loader ?(libraries = []) main () =
     of_image ?target ?loader main ~libraries |> ok_exn

lib/bap_image/bap_image.ml

@@ -1,4 +1,5 @@
 open Core_kernel[@@warning "-D"]
+open Bap_knowledge
 open Bap_core_theory
 open Regular.Std
 open Bap_types.Std
@@ -22,6 +23,29 @@ type loader = (module Loader)
 let backends : loader String.Table.t =
   String.Table.create ()
 
+module KB = struct
+  module type Loader = sig
+    val from_file : string -> doc option knowledge
+    val from_data : Bigstring.t -> doc option knowledge
+  end
+
+  let register_loader ~name (module Loader : Loader) =
+    let module Loader = struct
+      let result = Toplevel.var "load"
+      let from_file filename = try
+          Toplevel.put result @@ Loader.from_file filename;
+          Ok (Toplevel.get result)
+        with Toplevel.Conflict c ->
+          Or_error.errorf "%s" @@ KB.Conflict.to_string c
+      let from_data data = try
+          Toplevel.put result @@ Loader.from_data data;
+          Ok (Toplevel.get result)
+        with Toplevel.Conflict c ->
+          Or_error.errorf "%s" @@ KB.Conflict.to_string c
+    end in
+    Hashtbl.add_exn backends ~key:name ~data:(module Loader)
+end
+
 type location = {
   addr : addr;
   size : int;
@@ -147,6 +171,8 @@ module Scheme = struct
 
   let relocation () =
     declare "relocation" (scheme fixup $ addr) Tuple.T2.create
+  let relative_relocation () =
+    declare "relative-relocation" (scheme fixup) Fn.id
   let external_reference () =
     declare "external-reference" (scheme addr $ name) Tuple.T2.create
   let base_address () = declare "base-address" (scheme addr) Fn.id
@@ -683,7 +709,6 @@ let get_loader = function
         let from_data = fail
       end)
 
-
 let invoke load data arg = match load arg with
   | Ok (Some doc) -> from_spec (data arg) doc
   | Ok None ->

lib/bap_image/bap_image.mli

@@ -81,6 +81,14 @@ val register_loader : name:string -> (module Loader) -> unit
 val find_loader : string -> (module Loader) option
 val available_backends : unit -> string list
 
+module KB : sig
+  module type Loader = sig
+    val from_file : string -> Ogre.doc option KB.t
+    val from_data : Bigstring.t -> Ogre.doc option KB.t
+  end
+
+  val register_loader : name:string -> (module Loader) -> unit
+end
 
 module Scheme : sig
   open Ogre.Type
@@ -132,6 +140,9 @@ module Scheme : sig
   val relocation :
     (addr * addr, (addr -> addr -> 'a) -> 'a) Ogre.attribute
 
+  val relative_relocation :
+    (addr, (addr -> 'a) -> 'a) Ogre.attribute
+
   val external_reference :
     (addr * string, (addr -> string -> 'a) -> 'a) Ogre.attribute
 

lib/bap_llvm/bap_llvm_loader.ml

@@ -1,11 +1,21 @@
 open Core_kernel[@@warning "-D"]
+open Bap_knowledge
+open Bap_core_theory
 open Bap.Std
 open Monads.Std
 open Or_error
 
+include Self()
+
 module Sys = Caml.Sys
 module Unix = Caml_unix
 
+module Ogre = struct
+  include Ogre
+  include Ogre.Make(KB)
+end
+
+
 module Primitive = struct
   (** [bap_llvm_load data pdb_path] analyzes [data] and builds an llvm
       specification of the discovered meta-data.
@@ -46,6 +56,9 @@ module LLVM = struct
   let relocation () =
     Ogre.declare ~name:"llvm:relocation" (scheme at $ addr) Tuple.T2.create
 
+  let relative_relocation () =
+    Ogre.declare ~name:"llvm:relative-relocation" (scheme at) Fn.id
+
   (** an external symbols with the given name is referenced ad *)
   let name_reference () =
     Ogre.declare ~name:"llvm:name-reference" (scheme at $ name) Tuple.T2.create
@@ -129,17 +142,33 @@ let iter_rows fieldname f =
 let provide_if cond code =
   if cond then code else []
 
-let provide_base_and_bias new_base =
+let unit_bias file =
+  let open KB.Syntax in
+  match file with
+  | None | Some "" -> !!None
+  | Some file ->
+    Theory.Unit.for_file file >>=
+    KB.collect Theory.Unit.bias >>|
+    Option.map ~f:Bitvec.to_int64
+
+let provide_base_and_bias ?file new_base =
   Ogre.require LLVM.base_address >>= fun real ->
-  Ogre.sequence @@ match new_base with
-  | None -> [
-      Ogre.provide bias 0L;
-      Ogre.provide base_address real;
-    ]
-  | Some base -> [
-      Ogre.provide bias Int64.(base - real);
-      Ogre.provide base_address base;
+  Ogre.lift (unit_bias file) >>= function
+  | Some b ->
+    info "using provided bias 0x%Lx for file %s" b @@ Option.value_exn file;
+    Ogre.sequence [
+      Ogre.provide bias b;
+      Ogre.provide base_address Int64.(real + b)
     ]
+  | None -> Ogre.sequence @@ match new_base with
+    | None -> [
+        Ogre.provide bias 0L;
+        Ogre.provide base_address real;
+      ]
+    | Some base -> [
+        Ogre.provide bias Int64.(base - real);
+        Ogre.provide base_address base;
+      ]
 
 let provide_entry =
   Ogre.require bias >>= fun bias ->
@@ -172,6 +201,11 @@ let provide_relocations =
     Ogre.provide relocation Int64.(addr + bias) Int64.(dest + bias)
   ]
 
+let provide_relative_relocations =
+  iter_rows LLVM.relative_relocation @@ fun bias addr -> [
+    Ogre.provide relative_relocation Int64.(addr + bias)
+  ]
+
 let provide_name_references =
   iter_rows LLVM.name_reference @@ fun bias (addr, name) -> [
     Ogre.provide external_reference Int64.(addr + bias) name
@@ -377,9 +411,9 @@ let provide_elf_segmentation_and_libraries data =
   provide_elf_segmentation @ [ElfDyn.libraries data;]
 
 (** translates llvm-specific specification into the image specification  *)
-let translate data user_base =
+let translate ?file data user_base =
   Ogre.sequence [
-    provide_base_and_bias user_base;
+    provide_base_and_bias user_base ?file;
     provide_entry;
     Ogre.sequence [
       overload "elf"   @@ provide_elf_segmentation_and_libraries data;
@@ -388,6 +422,7 @@ let translate data user_base =
     ];
     provide_symbols;
     provide_relocations;
+    provide_relative_relocations;
     provide_name_references;
   ]
 
@@ -400,10 +435,20 @@ let pdb_path ~pdb filename =
     else pdb
   else ""
 
-let translate_to_image_spec data base doc =
-  match Ogre.exec (translate data base) doc with
-  | Ok doc -> Ok (Some doc)
-  | Error er -> Error er
+type KB.conflict += Loader_error of Error.t
+
+let () = KB.Conflict.register_printer @@ function
+  | Loader_error err ->
+    Some (Format.asprintf "llvm loader error: %a" Error.pp err)
+  | _ -> None
+
+let liftr = function
+  | Ok x -> KB.return x
+  | Error x -> KB.fail @@ Loader_error x
+
+let translate_to_image_spec data base doc file =
+  let open KB.Syntax in
+  Ogre.exec (translate data base ~file) doc >>= liftr
 
 let load_doc ~pdb filename data =
   try Ok (Primitive.llvm_load data (pdb_path ~pdb filename))
@@ -413,10 +458,10 @@ let load_doc ~pdb filename data =
     | n -> Or_error.errorf "fail with unexpected error code %d" n
 
 let from_data ~base ~pdb filename data =
-  let open Or_error.Monad_infix in
-  load_doc ~pdb filename data >>=
-  Ogre.Doc.from_string >>=
-  translate_to_image_spec data base
+  let open KB.Syntax in
+  liftr (load_doc ~pdb filename data) >>= fun s ->
+  liftr (Ogre.Doc.from_string s) >>= fun doc ->
+  translate_to_image_spec data base doc filename >>| Option.some
 
 let map_file path =
   let fd = Unix.(openfile path [O_RDONLY] 0o400) in
@@ -433,10 +478,11 @@ let map_file path =
 [@@warning "-D"]
 
 let from_file ~base ~pdb path =
-  Or_error.(map_file path >>= from_data ~base ~pdb path)
+  let open KB.Syntax in
+  liftr (map_file path) >>= from_data ~base ~pdb path
 
 let init ?base ?(pdb_path=Sys.getcwd ()) () =
-  Image.register_loader ~name:"llvm" (module struct
+  Image.KB.register_loader ~name:"llvm" (module struct
     let from_file = from_file ~base ~pdb:pdb_path
     let from_data = from_data ~base ~pdb:pdb_path ""
   end);

lib/bap_llvm/llvm_elf_loader.hpp

@@ -232,20 +232,29 @@ void emit_symbol_entries(const ELFObjectFile<T> &obj, ogre_doc &s) {
 
 template <typename T>
 void emit_relocations(const ELFObjectFile<T> &obj, ogre_doc &s) {
+#if LLVM_VERSION_MAJOR >= 12
+    auto rel_reloc = obj.getELFFile().getRelativeRelocationType();
+#else
+    auto rel_reloc = obj.getELFFile()->getRelativeRelocationType();
+#endif
     for (auto sec : obj.sections()) {
         for (auto rel : sec.relocations()) {
             auto sym = rel.getSymbol();
+            uint64_t raddr = prim::relocation_offset(rel);
             if (sym != prim::end_symbols(obj)) {
                 auto typ = prim::symbol_type(*sym);
                 if (typ && (*typ == SymbolRef::ST_Function ||
+                            *typ == SymbolRef::ST_Data ||
                             *typ == SymbolRef::ST_Unknown)) {
-                    uint64_t raddr = prim::relocation_offset(rel);
                     if (auto addr = prim::symbol_address(*sym))
                         if (*addr) s.entry("llvm:relocation") << raddr << *addr;
                     if (auto name = prim::symbol_name(*sym))
                         if (!name->empty())
                             s.entry("llvm:name-reference") << raddr << *name;
                 }
+            } else {
+                auto typ = prim::relocation_type(rel);
+                if (typ == rel_reloc) s.entry("llvm:relative-relocation") << raddr;
             }
         }
     }

lib/bap_llvm/llvm_loader.hpp

@@ -27,6 +27,7 @@ static std::string scheme =
     "(declare llvm:elf-program-header (name str) (off int) (size int))\n"
     "(declare llvm:name-reference (at int) (name str))\n"
     "(declare llvm:relocation (at int) (addr int))\n"
+    "(declare llvm:relative-relocation (at int))\n"
     "(declare llvm:section-entry (name str) (addr int) (size int) (off int))\n"
     "(declare llvm:section-flags (name str) (r bool) (w bool) (x bool))\n"
     "(declare llvm:segment-command-flags (name str) (r bool) (w bool) (x bool))\n"

lib/bap_llvm/llvm_primitives.cpp

@@ -144,6 +144,7 @@ error_or<section_iterator> symbol_section(const ObjectFile &obj, const SymbolRef
 }
 
 uint64_t relocation_offset(const RelocationRef &rel) { return rel.getOffset(); }
+uint64_t relocation_type(const RelocationRef &rel) { return rel.getType(); }
 
 std::vector<RelocationRef> relocations(const SectionRef &sec) {
     auto r = sec.relocations();