From 620e6409c070fa9174cd543bdf33bdae07e01c85 Mon Sep 17 00:00:00 2001 From: ivg Date: Fri, 20 Nov 2020 12:00:39 -0500 Subject: [PATCH] enables intermachine communication This PR adds a new interface, `Machine.Other`, that enables access to the local state of other machines. It is possible both to pry into others local state and even change it. So is it carefuly. This PR is a step towards the solution of the #1076 issue. More will come. --- lib/bap_primus/bap_primus.mli | 57 ++++++++++++++++++---- lib/bap_primus/bap_primus_env.ml | 4 ++ lib/bap_primus/bap_primus_env.mli | 1 + lib/bap_primus/bap_primus_machine.ml | 71 +++++++++++++++------------- lib/bap_primus/bap_primus_types.ml | 7 +++ 5 files changed, 99 insertions(+), 41 deletions(-) diff --git a/lib/bap_primus/bap_primus.mli b/lib/bap_primus/bap_primus.mli index 1f6146098..c483c986a 100644 --- a/lib/bap_primus/bap_primus.mli +++ b/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. *) diff --git a/lib/bap_primus/bap_primus_env.ml b/lib/bap_primus/bap_primus_env.ml index 5ab3a5f17..e3dd38af7 100644 --- a/lib/bap_primus/bap_primus_env.ml +++ b/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 diff --git a/lib/bap_primus/bap_primus_env.mli b/lib/bap_primus/bap_primus_env.mli index 49b55b6b2..ed690633f 100644 --- a/lib/bap_primus/bap_primus_env.mli +++ b/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 diff --git a/lib/bap_primus/bap_primus_machine.ml b/lib/bap_primus/bap_primus_machine.ml index d0e82c3a1..c9b94e905 100644 --- a/lib/bap_primus/bap_primus_machine.ml +++ b/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} diff --git a/lib/bap_primus/bap_primus_types.ml b/lib/bap_primus/bap_primus_types.ml index 8b84cf82a..7995fb063 100644 --- a/lib/bap_primus/bap_primus_types.ml +++ b/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