enables intermachine communication

lib/bap_primus/bap_primus.mli

@@ -575,6 +575,26 @@ module Std : sig
                                and type 'a t := 'a state
 
 
+        (** Local state of other machines.
+
+            This module gives access to the state of other
+            machines. It is possible both to pry into others state and
+            even to change their state to enable full intermachine
+            communication. Use this module with care!
+
+            @since 2.2.0 *)
+        module Other : sig
+
+          (** [get machine state] returns the local [state] of the [machine].  *)
+          val get : id -> 'a state -> 'a t
+
+          (** [put machine state] sets the local [state] of the [machine].  *)
+          val put : id -> 'a state -> 'a -> unit t
+
+          (** [update machine state ~f] maps the local [state] of the [machine].  *)
+          val update : id -> 'a state -> f:('a -> 'a) -> unit t
+        end
+
         (** [raise exn] raises the machine exception [exn], intiating
             an abonormal control flow *)
         val raise : exn -> 'a t
@@ -2361,15 +2381,30 @@ module Std : sig
       end
     end
 
-    (** Evaluation environment.
+    (** The evaluation environment.
+
+        The environment binds variables to values and value
+        generators.
 
-        The Environment binds variables to values.*)
+        A variable is {i bound} if it was either bound to a value with
+        [set] or to a value generator with [add]. A variable is
+        {i unset} if it is bound but not bound to a value.
+
+        A variable is {i undefined} if it is not bound. Accessing an
+        undefined variable raises the [Undefined_var]
+        exception. Accessing an unset variable triggers the
+        [generated] observation and the variable becomes bound to the
+        generated value.
+    *)
     module Env : sig
 
       (** A variable is undefined, if it was never [add]ed to the
           environment.  *)
       type exn += Undefined_var of var
 
+
+      (** occurs when an unset variable is read. The generated value
+          is bound to the variable.  *)
       val generated : (var * value) observation
 
       (** [Env = Make(Machine)]  *)
@@ -2381,28 +2416,32 @@ module Std : sig
         (** [set var value] binds a variable [var] to the given [value].  *)
         val set : var -> value -> unit Machine.t
 
-
-        (** [add var generator] adds a variable [var] to the
-            environment. If a variable is read before it was defined
+        (** [add var generator] adds the variable [var] to the
+            environment. If the variable is read before it was bound
             with the [set] operation, then a value produces by the
-            generator will be automatically associated with the
+            [generator] will be automatically bound with the
             variable and returned. *)
         val add : var -> Generator.t -> unit Machine.t
 
 
-        (** [del v] deletes the variable [v] from the environment.
+        (** [del v] unsets the variable [v].
 
-            The variable [v] will no longer be bound.
+            The variable [v] is no longer bound to a value.
         *)
         val del : var -> unit Machine.t
 
 
         (** [has v] evaluates to [true] if [v] is bound.
-
             @since 2.1.0
         *)
         val has : var -> bool Machine.t
 
+        (** [is_set v] evaluates to [true] if [v] is bound to a value.
+
+            @since 2.2.0
+        *)
+        val is_set : var -> bool Machine.t
+
         (** [all] is a sequence of all variables defined in the
             environment. Note, the word _defined_ doesn't mean
             initialized.   *)

lib/bap_primus/bap_primus_env.ml

@@ -121,6 +121,10 @@ module Make(Machine : Machine) = struct
           Machine.Observation.make on_generated (var,x) >>| fun () ->
           x
 
+  let is_set var =
+    Machine.Local.get state >>| fun t ->
+    Map.mem t.values var
+
   let has var =
     Machine.Local.get state >>| fun t ->
     Map.mem t.values var || Map.mem t.random var

lib/bap_primus/bap_primus_env.mli

@@ -14,4 +14,5 @@ module Make(Machine : Machine) : sig
   val del : var -> unit Machine.t
   val has : var -> bool Machine.t
   val all : var seq Machine.t
+  val is_set : var -> bool Machine.t
 end

lib/bap_primus/bap_primus_machine.ml

@@ -108,13 +108,16 @@ module Make(M : Monad.S) = struct
   (* lifts state monad to the outer monad *)
   let lifts x = CM.lift (C.lift x)
 
-  let with_global_context (f : (unit -> 'a t)) =
+  let with_context cid (f : (unit -> 'a t)) =
     lifts (SM.current ())       >>= fun id ->
-    lifts (SM.switch SM.global) >>= fun () ->
+    lifts (SM.switch cid) >>= fun () ->
     f ()                >>= fun r  ->
     lifts (SM.switch id)        >>| fun () ->
     r
 
+  let with_global_context (f : (unit -> 'a t)) =
+    with_context SM.global f
+
   let get_local () : _ t = lifts (SM.gets @@ fun s -> s.local)
   let get_global () : _ t = with_global_context @@ fun () ->
     lifts (SM.gets @@ fun s -> s.global)
@@ -189,39 +192,43 @@ module Make(M : Monad.S) = struct
         f (fun x -> k x)
   end
 
-  module Make_state(S : sig
-      val get : unit -> State.Bag.t t
-      val set : State.Bag.t -> unit t
-      val typ : string
-    end) = struct
-    type 'a m = 'a t
-    let get state =
-      S.get () >>= fun states ->
-      State.Bag.with_state states state
-        ~ready:return
-        ~create:(fun make ->
-            lifts (SM.get ()) >>= fun {proj} ->
-            return (make proj))
-
-    let put state x =
-      S.get () >>= fun states ->
-      S.set (State.Bag.set states state x)
-
-    let update data ~f =
-      get data >>= fun s -> put data (f s)
+  let make_get get state =
+    get () >>= fun states ->
+    State.Bag.with_state states state
+      ~ready:return
+      ~create:(fun make ->
+          lifts (SM.get ()) >>= fun {proj} ->
+          return (make proj))
+
+  let make_put get set state x =
+    get () >>= fun states ->
+    set (State.Bag.set states state x)
+
+  let make_update get put data ~f =
+    get data >>= fun s -> put data (f s)
+
+
+  module Local = struct
+    let get s = make_get get_local s
+    let put s = make_put get_local set_local s
+    let update s = make_update get put s
   end
 
-  module Local = Make_state(struct
-      let typ = "local"
-      let get = get_local
-      let set = set_local
-    end)
+  module Other = struct
+    let get_other pid state = with_context pid @@
+      fun () -> get_local state
+    let put_other pid state = with_context pid @@ fun () ->
+      set_local state
+    let get pid = make_get (get_other pid)
+    let put pid = make_put (get_other pid) (put_other pid)
+    let update pid = make_update (get pid) (put pid)
+  end
 
-  module Global = Make_state(struct
-      let typ = "global"
-      let get = get_global
-      let set = set_global
-    end)
+  module Global = struct
+    let get s = make_get get_global s
+    let put s = make_put get_global set_global s
+    let update s = make_update get put s
+  end
 
   let put proj = with_global_context @@ fun () ->
     lifts @@ SM.update @@ fun s -> {s with proj}

lib/bap_primus/bap_primus_types.ml

@@ -70,9 +70,16 @@ module type Machine = sig
                                      (exit_status * project) m effect
   module Local  : State with type 'a m := 'a t
                          and type 'a t := 'a state
+
   module Global : State with type 'a m := 'a t
                          and type 'a t := 'a state
 
+  module Other : sig
+    val get : id -> 'a state -> 'a t
+    val put : id -> 'a state -> 'a -> unit t
+    val update : id -> 'a state -> f:('a -> 'a) -> unit t
+  end
+
   val raise : exn -> 'a t
   val catch : 'a t -> (exn -> 'a t) -> 'a t