allows bypassing checks when storing memory, uses it for relocations (#1567)

When we perform relocations on object files, we do the linker work not
the loader, therefore we do not need to check if the memory is
writable or even loadable. The easiest option is to extend the Primus
memory interface with primitives that perform writing without any
checks.

Author: ivg

lib/bap_primus/bap_primus.mli

@@ -2573,7 +2573,7 @@ module Std : sig
         val get : addr -> value Machine.t
 
 
-        (** [set a x] stores the byte [x] at the address [a].
+        (** [set a x] stores [x] at the address [a].
 
             raises the [Pagefault] machine exception if [a] is not mapped,
             or not writable.
@@ -2584,6 +2584,19 @@ module Std : sig
         val set : addr -> value -> unit Machine.t
 
 
+        (** [set_never_fail a x] stores [x] at [a] bypassing any
+            checks.
+
+            Forcefully stores [x] at the address [a] without any
+            sanity checks, i.e., doesn't check if the memory is mapped or
+            is it writable.
+
+            Precondition: the size of the address and the size of the
+            datum match with the current [memory] sizes.
+
+            @since 2.6.0 *)
+        val set_never_fail : addr -> value -> unit Machine.t
+
         (** [del p] removes the value associated with the pointer [p].  *)
         val del : addr -> unit Machine.t
 
@@ -2597,10 +2610,25 @@ module Std : sig
 
             Same as [Value.of_word x >>= set a].
 
-            Precondition: [Value.bitwidth x = 8].
-        *)
+            Precondition: the size of the address and the size of the
+            datum match with the current [memory] sizes. *)
         val store : addr -> word -> unit Machine.t
 
+        (** [store_never_fail a x] stores [x] at [a] bypassing any
+            checks.
+
+            Forcefully stores [x] at the address [a] without any
+            sanity checks, i.e., doesn't check if the memory is mapped or
+            is it writable.
+
+            Same as [Value.of_word x >>= set_never_fail a].
+
+            Precondition: the size of the address and the size of the
+            datum match with the current [memory] sizes.
+
+            @since 2.6.0 *)
+        val store_never_fail : addr -> word -> unit Machine.t
+
         (** [add_text mem] maps a memory chunk [mem] as executable and
             readonly segment of machine memory.*)
         val add_text : mem -> unit Machine.t

lib/bap_primus/bap_primus_memory.ml

@@ -271,19 +271,19 @@ module Make(Machine : Machine) = struct
           Generate.word g (Generator.width g) >>=
           remembered {values; layers} addr
 
-  let set_value s addr value = {
+  let set_value addr value s = {
     s with
     values = Map.set s.values ~key:addr ~data:value
   }
 
   let write addr value s =
     if Map.mem s.values addr
-    then Machine.return @@ set_value s addr value
+    then Machine.return @@ set_value addr value s
     else match find_layer addr s.layers with
       | None -> pagefault addr
       | Some {perms={readonly=true}} -> pagefault addr
       | Some _ ->
-        Machine.return @@ set_value s addr value
+        Machine.return @@ set_value addr value s
 
   let add_layer layer t = {t with layers = layer :: t.layers}
   let (++) = add_layer
@@ -336,12 +336,20 @@ module Make(Machine : Machine) = struct
     write addr value >>=
     put_curr
 
+  let set_never_fail addr value =
+    get_curr >>|
+    set_value addr value >>=
+    put_curr
+
+
   let del addr = update @@ fun s -> {
       s with values = Map.remove s.values addr
     }
 
   let load addr = get addr >>| Value.to_word
   let store addr value = Value.of_word value >>= set addr
+  let store_never_fail addr value =
+    Value.of_word value >>= set_never_fail addr
 
   let is_mapped addr =
     get_curr >>| is_mapped addr

lib/bap_primus/bap_primus_memory.mli

@@ -26,9 +26,12 @@ module Make(Machine : Machine) : sig
 
   val load  : addr -> word Machine.t
   val store : addr -> word -> unit Machine.t
+  val store_never_fail : addr -> word -> unit Machine.t
 
   val get : addr -> value Machine.t
   val set : addr -> value -> unit Machine.t
+  val set_never_fail : addr -> value -> unit Machine.t
+
   val del : addr -> unit Machine.t
 
   val add_text : mem -> unit Machine.t

plugins/primus_loader/primus_loader_basic.ml

@@ -133,10 +133,11 @@ module Make(Param : Param)(Machine : Primus.Machine.S)  = struct
     Project.libraries proj |> List.map ~f:Project.Library.memory |>
     Machine.List.fold ~init ~f:(fun init m -> one_memmap m ~init)
 
-  let save_word endian word ptr =
+  let save_word ?(force=false) endian word ptr =
+    let store = if force then Mem.store_never_fail else Mem.store in
     Word.enum_bytes word endian |>
     Machine.Seq.fold ~init:ptr ~f:(fun ptr byte ->
-        Mem.store ptr byte >>| fun () ->
+        store ptr byte >>| fun () ->
         Word.succ ptr)
 
   let read_word endian ptr =
@@ -176,8 +177,9 @@ module Make(Param : Param)(Machine : Primus.Machine.S)  = struct
   let fixup_one_reloc endian width (fixup, addr) =
     let fixup = Addr.of_int64 ~width fixup in
     let addr = Word.of_int64 ~width addr in
-    info "writing %a for relocation %a" Word.pp addr Addr.pp fixup;
-    save_word endian addr fixup >>| ignore
+    debug "writing %a for relocation %a" Word.pp addr Addr.pp fixup;
+    Machine.ignore_m @@
+    save_word ~force:true endian addr fixup
 
   let fixup_relocs_of_doc target doc =
     let endian = endian_of_target target in
@@ -279,21 +281,21 @@ module Make(Param : Param)(Machine : Primus.Machine.S)  = struct
     Machine.Seq.iter ~f:(fun (name,addr) -> set_word name addr)
 
   let init () =
-    info "setting up stack";
+    debug "setting up stack";
     setup_stack () >>= fun () ->
-    info "setting up main frame";
+    debug "setting up main frame";
     setup_main_frame () >>= fun () ->
-    info "loading segments";
+    debug "loading segments";
     load_segments () >>= fun e1 ->
-    info "mapping segments";
+    debug "mapping segments";
     map_segments () >>= fun e2 ->
-    info "fixing up relocations";
+    debug "fixing up relocations";
     fixup_relocs () >>= fun () ->
-    info "setting up registers";
+    debug "setting up registers";
     let endp = Addr.max e1 e2 in
     set_word "posix:endp" endp >>= fun () ->
     set_word "posix:brk"  endp >>= fun () ->
     setup_registers () >>= fun () ->
-    info "initializing names";
+    debug "initializing names";
     init_names ()
 end