allows bypassing checks when storing memory, uses it for relocations

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