(****************************************************************************)
(*                           the diy toolsuite                              *)
(*                                                                          *)
(* Jade Alglave, University College London, UK.                             *)
(* Luc Maranget, INRIA Paris-Rocquencourt, France.                          *)
(*                                                                          *)
(* Copyright 2010-present Institut National de Recherche en Informatique et *)
(* en Automatique and the authors. All rights reserved.                     *)
(*                                                                          *)
(* This software is governed by the CeCILL-B license under French law and   *)
(* abiding by the rules of distribution of free software. You can use,      *)
(* modify and/ or redistribute the software under the terms of the CeCILL-B *)
(* license as circulated by CEA, CNRS and INRIA at the following URL        *)
(* "http://www.cecill.info". We also give a copy in LICENSE.txt.            *)
(****************************************************************************)

(** Operations on events *)

open Printf

module type S = sig

  module A : Arch_herd.S

  module Act : Action.S

  type action = Act.action

  type eiid = int
  type subid = int

(*
  eiid = unique event id
  iiid =
    IdSome id of instruction that generated this event;
    IdInit for init writes
    IdSpurious for spurious events
*)
  type iiid =
    | IdSome of A.inst_instance_id
    | IdInit
    | IdSpurious

  type event = {
      eiid : eiid; subid : subid;
      iiid : iiid;
      action : action;  }

(* Generated by the same instruction *)
val same_instruction : event -> event -> bool
(* And in the exact same way *)
val same_static_event : event -> event -> bool

val same_instance : event -> event -> bool


(* Only basic printing is here *)
  val pp_eiid       : event -> string
  val pp_instance   : event -> string
  val pp_action     : event -> string
  val debug_event : out_channel -> event -> unit
  val debug_event_str : event -> string

(***************************)
(* Procs and program order *)
(***************************)

  val proc_of       : event -> A.proc option
  val same_proc     : event -> event -> bool
  val same_proc_not_init : event -> event -> bool
  val progorder_of  : event -> A.program_order_index option

(* Is e1 before e2 w.r.t. prog order ? Nothing assumed on e1 and e2 *)
  val po_strict : event -> event -> bool
  val po_eq : event -> event -> bool

(************************)
(* Predicates on events *)
(************************)

(* relative to memory *)
  val is_mem_store : event -> bool
  val is_mem_store_init : event -> bool
  val is_spurious : event -> bool
  val is_mem_load : event ->  bool
  val is_additional_mem_load : event ->  bool (* trylock... *)
  val is_mem : event -> bool
(* Instruction fetch *)
  val is_ifetch : event -> bool
(* Page table access *)
  val is_pt : event -> bool
  val is_explicit : event -> bool
  val is_not_explicit : event -> bool
(* Tag memory access *)
  val is_tag : event -> bool
  val is_mem_physical : event -> bool
(* includes additional memory events,  eg lock, unlocks... *)
  val is_additional_mem : event -> bool
(* Specific memory property examination *)
  val is_atomic : event -> bool
  val is_fault : event -> bool
  val to_fault : event -> A.fault option
  val is_amo : event -> bool
  val get_mem_dir : event -> Dir.dirn
  val get_mem_size : event -> MachSize.sz

(* relative to the registers of the given proc *)
  val is_reg_store : event -> A.proc -> bool
  val is_reg_load : event -> A.proc -> bool
  val is_reg : event -> A.proc -> bool

(* Reg events, proc not specified *)
  val is_reg_store_any : event -> bool
  val is_reg_load_any : event -> bool
  val is_reg_any : event -> bool

(* Store/Load to memory or register *)
  val is_store : event -> bool
  val is_load : event -> bool

(* Access events of the same category *)
  val compatible_accesses : event -> event -> bool

(* Barriers *)
  val is_barrier : event -> bool
  val barrier_of : event -> A.barrier option

(*
  val same_barrier_id : event -> event -> bool
*)
  val is_isync : event -> bool

(* Commit *)
  val is_bcc : event -> bool
  val is_pred : event -> bool
  val is_pred_txt : string option -> event -> bool
  val is_commit : event -> bool

(* The "CutOff" effect flags stepping beyond unrolling limit *)
  val is_cutoff : event -> bool
  val as_cutoff : event -> string option

(**************)
(* Event sets *)
(**************)

  val event_compare : event -> event -> int
  val event_equal :  event -> event -> bool

  module OrderedEvent : MySet.OrderedType with type t = event

  module EventSet : MySet.S
  with type elt = event

  type event_set = EventSet.t
  val debug_events : out_channel -> event_set -> unit

  module EventSetSet : MySet.S
  with type elt = event_set

(*************)
(* Event map *)
(*************)

  module EventMap : MyMap.S with type key = event

(************************)
(* Event set restricted *)
(************************)

(* relative to memory *)
  val mem_stores_of : EventSet.t -> EventSet.t
  val mem_stores_init_of : EventSet.t -> EventSet.t
  val mem_loads_of : EventSet.t -> EventSet.t
  val mem_of : EventSet.t -> EventSet.t
  val atomics_of : EventSet.t -> EventSet.t

(* relative to the registers of the given proc *)
  val reg_stores_of : EventSet.t  -> A.proc -> EventSet.t
  val reg_loads_of : EventSet.t -> A.proc -> EventSet.t

(* Proc not checked *)
  val reg_stores : EventSet.t  ->  EventSet.t
  val reg_loads : EventSet.t -> EventSet.t

(* For all locations *)
  val stores_of : EventSet.t -> EventSet.t
  val loads_of :  EventSet.t -> EventSet.t

(* Barriers *)
  val barriers_of : EventSet.t -> EventSet.t

(* Commit *)
  val commits_of :  EventSet.t -> EventSet.t

(***********************)
(* Relations on events *)
(***********************)

  module EventRel : InnerRel.S
  with type elt0 = event
  and module Elts = EventSet

  module EventTransRel : InnerTransRel.S
    with type elt = event
     and module Set = EventSet
     and module Rel = EventRel

  type event_rel = EventRel.t

  val debug_rel : out_channel -> event_rel -> unit

  type event_structure = {
      procs : A.proc list ;
      events : EventSet.t ;                     (* really a set *)
      speculated : EventSet.t ;                 (* really a set *)
      po : EventSet.t * EventRel.t; (* speculated po represented as a forest: roots first + partial order *)
      partial_po : EventTransRel.t;
      intra_causality_data : EventRel.t ;       (* really a partial order relation *)
      intra_causality_control : EventRel.t ;    (* really a partial order relation *)
      intra_causality_order : EventRel.t ; (* Just order *)
      (* If style control inside structure *)
      control : EventRel.t ;
      (* Events that lead to the data port of a W *)
      data_ports : EventSet.t ;
      (* some special output port,i.e. store conditional success as reg write *)
      success_ports : EventSet.t ;
      (* Input to structure, by default minimal iico, or iico_data *)
      input : EventSet.t option ; data_input : EventSet.t option ;
      (* Result of structure, by default maximal iico_data *)
      output : EventSet.t option ;
      (* Control output of structure, by default maximal iico *)
      ctrl_output : EventSet.t option ;
      (* Equivalence classes of events generated by the same memory accesses *)
      sca : EventSetSet.t ;
      (* Original events, before splitted in sub-accesses (mixed-size).
       * NB: not included in events above *)
      mem_accesses : EventSet.t ;
      (* mem_access -> corresponding sca *)
      aligned : (event * EventSet.t) list ;
    }

  val procs_of    : event_structure -> A.proc list
  val locs_of     : event_structure -> A.location list

(* map f over all events in event_structure *)
  val map_event_structure :
      (event -> event) -> event_structure -> event_structure

  val do_speculate :
      event_structure -> event_structure

(* Union of all internal causality relations *)
  val iico        :  event_structure -> EventRel.t

  (*****************************************************************)
  (* Those projection return lists of event sets/relations by proc *)
  (*****************************************************************)

  (* project events by executing proc *)
  val proj_events : event_structure -> event_set list

  (* relation must operate on events of the same proc *)
  val proj_rel : event_structure -> event_rel -> event_rel list
  (* relation must be as before, or one of the related
     events be a mem_store *)
  val proj_proc_view : event_structure -> event_rel -> event_rel list

(********************)
(* Equation solving *)
(********************)

  val undetermined_vars_in_event_structure : event_structure -> A.V.ValueSet.t
  val simplify_vars_in_event : A.V.solution -> event -> event
  val simplify_vars_in_event_structure :
      A.V.solution -> event_structure -> event_structure

(*************************************)
(* Access to sub_components of events *)
(*************************************)
  val value_of : event -> A.V.v option (* Warning: fails on RMW actions *)
  val read_of : event -> A.V.v option
  val written_of : event -> A.V.v option
  val location_of   : event -> A.location option
  val location_reg_of : event -> A.reg option
  val global_loc_of    : event -> A.global_loc option
  val global_index_of : event -> int option
  val virtual_loc_of : event -> string option

(****************************)
(* Convenience on locations *)
(****************************)

  val same_location : event -> event -> bool
  val same_location_with_faults : event -> event -> bool
  val same_value : event -> event -> bool
  val same_low_order_bits : event -> event -> bool
  (*  val is_visible_location : A.location -> bool *)

(********************************)
(* Event structure output ports *)
(********************************)
  val debug_output : out_channel -> event_structure -> unit
  val debug_event_structure : out_channel -> event_structure -> unit

(********************************)
(* Instruction+code composition *)
(********************************)

  val inst_code_comp :
     event_structure -> event_structure -> event_structure

  val inst_code_comp_spec :
     event_structure -> event_structure -> event_structure -> event_structure


(************************)
(* Parallel composition *)
(************************)
  val para_comp : bool (* check disjointness *)
    -> event_structure -> event_structure -> event_structure option

(* Memory events in arguments form one atomic access => build a sca *)
  val para_atomic :
    event_structure -> event_structure -> event_structure option

(* Input in second argument *)
  val para_input_right :
    event_structure -> event_structure -> event_structure option

(* Output in second argument *)
  val para_output_right :
    event_structure -> event_structure -> event_structure option

  (* Partial po sequencing, output in second argument *)
  val para_po_seq_output_right :
    event_structure -> event_structure -> event_structure option

(* Sequence memory events, otherwise parallel composition *)
  val seq_mem :
    event_structure -> event_structure -> event_structure option

(***********************************************)
(* sequential composition, add data dependency *)
(***********************************************)

  val (=*$=) : (* second es entries are minimal evts for iico_data *)
      event_structure -> event_structure -> event_structure option

  val data_input_next : (* input to second structure *)
    event_structure -> event_structure -> event_structure option

  val data_input_union : (* input to both structures *)
    event_structure -> event_structure -> event_structure option

  val data_to_output : (* input to second es output *)
    event_structure -> event_structure -> event_structure option

  val data_to_minimals : (* second es entries are minimal evts all iico *)
      event_structure -> event_structure -> event_structure option

  val data_po_seq : (* same as [=*$=], but sequences po. *)
    event_structure -> event_structure -> event_structure option

(* Identical, keep first event structure data output as output. *)
  val (=$$=) :
      event_structure -> event_structure -> event_structure option

  val data_output_union :
    event_structure -> event_structure -> event_structure option

(* sequential composition, add control dependency *)
  val (=**=) :
     event_structure -> event_structure -> event_structure option

  (* Identical, data input is first argument (usually commit evt) *)
  val bind_control_set_data_input_first :
      event_structure -> event_structure -> event_structure option
  (* Identical, keep second event structure input as input. *)
  val control_input_next :
    event_structure -> event_structure -> event_structure option
  (* Identical, input is union  *)
  val control_input_union :
    event_structure -> event_structure -> event_structure option

(* Identical, keep first event structure data output as output. *)
  val (=*$$=) :
      event_structure -> event_structure -> event_structure option

(* similar, additionally avoid some evts in target links *)
  val bind_ctrl_avoid : event_set ->  event_structure -> event_structure -> event_structure option

(* Similar, but if no output in second argument, use first as output *)
  val bind_ctrl_sequence_data :
    event_structure -> event_structure -> event_structure option

  (* Similar, but sequencing partial po *)
  val bind_ctrl_sequence_data_po :
    event_structure -> event_structure -> event_structure option

(***********************)
(* Custom compositions *)
(***********************)

(* Compose three structures s1 s2 and s3 with s1-ctrl+data->s3
     and s2-data->s3 *)
  val bind_ctrldata_data :
    event_structure -> event_structure -> event_structure -> event_structure

(* Sequential composition, add ctrl+data dependency
    keep first event structure output as data and control output. *)
  val bind_ctrldata_first_outputs :
      event_structure -> event_structure -> event_structure option

(* Sequential composition, add ctrl dependency
    keep first event structure output as data and control output. *)
  val bind_ctrl_first_outputs :
      event_structure -> event_structure -> event_structure option

(* Order composition, same as [=*$=] but with order dependencies instead of data. *)
  val bind_order :
      event_structure -> event_structure -> event_structure option

(* exchange composition :
   xch rx ry wx wy ->
      rx -data-> wy, ry -data-> wx
      rx -ctrl-> wx, ry -ctrl-> wy
*)
  val exch :
     event_structure -> event_structure ->
     event_structure -> event_structure ->
     event_structure

  val swp_or_amo :
    bool -> (* Physical memory access *)
    'op option -> (* When None this is a swp, otherwise amo *)
     event_structure -> event_structure ->
     event_structure -> event_structure ->
     event_structure -> event_structure

  val linux_exch :
      event_structure -> event_structure ->
        event_structure -> event_structure ->
          event_structure

  val amo :
      event_structure -> event_structure ->
        event_structure -> event_structure ->
          event_structure

  val linux_cmpexch_ok :  event_structure -> event_structure ->
    event_structure -> event_structure -> event_structure ->
      event_structure

  val linux_cmpexch_no :  event_structure -> event_structure ->
    event_structure -> event_structure

  val linux_add_unless_ok :  event_structure -> event_structure ->
    event_structure -> event_structure -> event_structure -> bool ->
      event_structure

  val linux_add_unless_no :  event_structure -> event_structure ->
    event_structure -> bool -> event_structure

  val riscv_sc :
      bool (* success *) ->
        event_structure -> event_structure -> event_structure ->
          event_structure ->  event_structure ->  event_structure ->
            event_structure

  val aarch64_cas_no :
    bool -> (* Physical memory access *)
    bool -> (* Add an iico_ctrl between the Branch and the Register Write *)
    event_structure -> event_structure -> event_structure ->
    event_structure -> event_structure -> event_structure

  val aarch64_cas_ok :
    bool (* Physical memory access *) -> [`DataFromRRs | `DataFromRx] ->
    event_structure -> event_structure -> event_structure ->
    event_structure ->  event_structure ->  event_structure ->
    event_structure -> event_structure

  val aarch64_cas_ok_morello :
        event_structure -> event_structure -> event_structure ->
          event_structure -> event_structure

(* stu computation :
   stu rD rEA wEA wM ->
      rEA -data-> wEA,
      rEA -data-> wM,
      rD -data-> wM *)
  val stu :
     event_structure -> event_structure ->
     event_structure -> event_structure ->
     event_structure


(* Parallel, for different instructions *)
  val (+|+) :
      event_structure -> event_structure -> event_structure option

  val empty_event_structure   : event_structure
  val is_empty_event_structure : event_structure -> bool

  val from_events: EventSet.t -> event_structure

(* Condition at instruction level *)
  val cond_comp :
      event_structure -> event_structure -> event_structure

end

module type Config = sig
  val debug : Debug_herd.t
  val variant : Variant.t -> bool
end

module Make  (C:Config) (AI:Arch_herd.S) (Act:Action.S with module A = AI) :
    (S with module A = AI and module Act = Act) =
  struct

    module Act = Act
    module A = AI
    module V = AI.V

    let dbg = C.debug.Debug_herd.monad
    let do_deps = C.variant Variant.Deps
    let memtag = C.variant Variant.MemTag
    let kvm = C.variant Variant.VMSA
    let is_branching = kvm && not (C.variant Variant.NoPteBranch)
    let is_po_partial = A.arch = `ASL
    type eiid = int
    type subid = int

    type action = Act.action

    type iiid =
      | IdSome of A.inst_instance_id
      | IdInit
      | IdSpurious


    type event = {
        eiid : eiid; subid : subid;
        iiid : iiid;
        action : action;  }

    let same_instruction e1 e2 =
      match e1.iiid,e2.iiid with
      | ((IdInit|IdSpurious),_)
      | (_,(IdInit|IdSpurious)) -> false
      | IdSome i1,IdSome i2 -> A.same_instruction i1 i2

    let same_static_event e1 e2 =
      Misc.int_eq e1.subid e2.subid && same_instruction e1 e2

    let same_instance e1 e2 =
      match e1.iiid,e2.iiid with
      | ((IdInit|IdSpurious),_) | (_,(IdInit|IdSpurious)) -> false
      | IdSome i1,IdSome i2 -> A.inst_instance_compare i1 i2 = 0


    let pp_eiid e =
      if e.eiid < 26 then
        String.make 1 (Char.chr (Char.code 'a' + e.eiid))
      else "ev"^string_of_int e.eiid

    let  pp_instance e =
      match e.iiid with
      | IdInit -> sprintf "init(%s)" (pp_eiid e)
      | IdSpurious -> sprintf "spurious(%s)" (pp_eiid e)
      | IdSome i -> sprintf "%i:%i" i.A.proc i.A.program_order_index

    let pp_action e = Act.pp_action e.action

    let debug_event chan e =
      fprintf chan
        "(eeid=%s action=%s)" (pp_eiid e) (pp_action e)
    let debug_event_str e =
      sprintf
        "(eeid=%s action=%s)" (pp_eiid e) (pp_action e)

(* Utility functions to pick out components *)
    let value_of e = Act.value_of e.action
    let read_of e = Act.read_of e.action
    let written_of e = Act.written_of e.action
    let location_of e = Act.location_of e.action

    let  location_reg_of e = match location_of e with
    | Some (A.Location_reg (_,r)) -> Some r
    | _ -> None

    let  global_loc_of e = match location_of e with
    | Some (A.Location_global a) -> Some a
    | _ -> None

    let global_index_of e =  match global_loc_of e with
      | Some (V.Val (Constant.Symbolic sym)) ->
         Constant.get_index sym
      | _-> None

    let virtual_loc_of e = match global_loc_of e with
    | Some (A.V.Val c) -> Constant.as_virtual c
    | None|Some (A.V.Var _) -> None

(* Visible locations *)
(*
    let is_visible_location  = function
      | A.Location_global _ -> true
      | A.Location_reg _ -> false
*)
    let same_location e1 e2 = match location_of e1,location_of e2 with
    | (None,_)|(_,None) -> false
    | Some loc1,Some loc2 -> A.location_compare loc1 loc2 = 0

    let same_location_with_faults e1 e2 = match location_of e1,location_of e2 with
    | (None,_)|(_,None) -> false
    | Some loc1,Some loc2 ->
        if Act.is_fault e1.action || Act.is_fault e2.action then
          A.same_base_virt loc1 loc2
        else  A.location_compare loc1 loc2 = 0

    let same_value e1 e2 = match value_of e1, value_of e2 with
    | Some v1,Some v2 -> V.compare v1 v2 = 0
    | _,_ -> false

    let same_low_order_bits e1 e2 =
      match global_index_of e1,global_index_of e2 with
      | (None,_)|(_,None) -> false
      | Some i1,Some i2 -> Misc.int_eq i1 i2

    let proc_of e = match e.iiid with
    | IdSome {A.proc=p;_} -> Some p
    | IdSpurious|IdInit -> None

    let same_proc e1 e2 = match proc_of e1, proc_of e2 with
    | Some p1,Some p2 -> Misc.int_eq p1 p2
    | (None,Some _)|(Some _,None) -> false
    | None,None -> true

    let same_proc_not_init e1 e2 = match proc_of e1, proc_of e2 with
    | Some p1,Some p2 -> Misc.int_eq p1 p2
    | (None,Some _)|(Some _,None)
    | None,None -> false

    let progorder_of e = match e.iiid with
    | IdSome i -> Some i.A.program_order_index
    | IdInit|IdSpurious -> None


(************************)
(* Predicates on events *)
(************************)

    let po_strict e1 e2 =
      proc_of e1 = proc_of e2 && progorder_of e1 < progorder_of e2

    let po_eq e1 e2 =
      proc_of e1 = proc_of e2 && progorder_of e1 = progorder_of e2

(* relative to memory *)
    let is_mem_store e = Act.is_mem_store e.action

    let is_mem_store_init e = match e.iiid with
    | IdInit -> true
    | IdSpurious|IdSome _ -> false

    let is_spurious e = match e.iiid with
    | IdSpurious -> true
    | IdInit|IdSome _ -> false


    let is_mem_load e = Act.is_mem_load e.action
    let is_additional_mem_load e = Act.is_additional_mem_load e.action
    let is_mem e = Act.is_mem e.action
    let is_ifetch e = Act.is_ifetch e.action

    let is_pt e = match Act.location_of e.action with
      | Some (A.Location_global (V.Val c)) -> Constant.is_pt c
      | _ -> false
    let is_explicit e = Act.is_explicit e.action
    let is_not_explicit e = Act.is_not_explicit e.action
    let is_tag e = Act.is_tag e.action
    let is_mem_physical e =
      let open Constant in
      match Act.location_of e.action with
      | Some (A.Location_global (V.Val (Symbolic (Physical _)))) -> true
      | _ -> false
    let is_additional_mem e = Act.is_additional_mem e.action
    let is_atomic e = Act.is_atomic e.action
    let is_fault e = Act.is_fault e.action
    let to_fault e = Act.to_fault e.action
    let is_amo e = match e.iiid with
    | IdSome {A.inst=i; _} when A.is_amo i -> Act.is_mem_store e.action
    | _ -> false
    let get_mem_dir e = Act.get_mem_dir e.action
    let get_mem_size e = Act.get_mem_size e.action

(* relative to the registers of the given proc *)
    let is_reg_store e (p:int) = Act.is_reg_store e.action p
    let is_reg_load e (p:int) = Act.is_reg_load e.action p
    let is_reg e (p:int) = Act.is_reg e.action p

(* Store/Load anywhere *)
    let is_store e = Act.is_store e.action
    let is_load e = Act.is_load e.action
    let is_reg_any e = Act.is_reg_any e.action
    let is_reg_store_any e = Act.is_reg_store_any e.action
    let is_reg_load_any e = Act.is_reg_load_any e.action

(* Compatible events ie accesses of the same category *)
    let compatible_accesses e1 e2 =
      Act.compatible_accesses e1.action e2.action

(* Barriers *)
    let is_barrier e = Act.is_barrier e.action
    let barrier_of e = Act.barrier_of e.action
(*
  let same_barrier_id e1 e2 =
  Act.same_barrier_id e1.action e2.action
 *)
    let is_isync e = Act.is_isync e.action

(* Commits *)
    let is_bcc e = Act.is_bcc e.action
    let is_pred e = Act.is_pred e.action
    let is_pred_txt cond e = Act.is_pred ~cond e.action
    let is_commit e = Act.is_commit e.action

(*  Unrolling control *)
    let is_cutoff e = Act.is_cutoff e.action
    and as_cutoff e = Act.as_cutoff e.action

(******************************)
(* Build structures of events *)
(******************************)

    let event_compare e1 e2 = Misc.int_compare e1.eiid e2.eiid
    let event_equal e1 e2 = Misc.int_eq e1.eiid e2.eiid

    module OrderedEvent = struct
      type t = event
      let compare = event_compare
    end


    module EventSet = MySet.Make(OrderedEvent)
    type event_set = EventSet.t

    let debug_events chan es =
      fprintf chan "{" ;
      EventSet.pp chan ", " debug_event es ;
      fprintf chan "}" ;
      ()

    module EventSetSet = MySet.Make(EventSet)

(* relative to memory *)
    let mem_stores_of = EventSet.filter is_mem_store
    let mem_stores_init_of = EventSet.filter is_mem_store_init
    let mem_loads_of es = EventSet.filter is_mem_load es
    let mem_of es = EventSet.filter is_mem es
    let atomics_of es = EventSet.filter is_atomic es

(* relative to the registers of the given proc *)
    let reg_stores_of es p =
      EventSet.filter (fun e -> is_reg_store e p) es
    let reg_loads_of es p =
      EventSet.filter (fun e -> is_reg_load e p) es

(* Everywhere *)
    let reg_stores es = EventSet.filter is_reg_store_any es
    let reg_loads es =  EventSet.filter is_reg_load_any es
    let stores_of es = EventSet.filter is_store es
    let loads_of es = EventSet.filter is_load es

(* Barriers *)
    let barriers_of es =  EventSet.filter is_barrier es

(* Commits *)
    let commits_of es =  EventSet.filter is_commit es

    module EventMap = MyMap.Make(OrderedEvent)

(*************)
(* Relations *)
(*************)

    module EventRel = InnerRel.Make(OrderedEvent)
    type event_rel = EventRel.t

    module EventTransRel = InnerTransRel.Make(OrderedEvent)

    let debug_event_in_rel chan e = fprintf chan "%s" (pp_eiid e)

    let debug_rel chan r =
      EventRel.pp chan ","
        (fun chan (e1,e2) -> fprintf chan "%a -> %a"
            debug_event_in_rel e1 debug_event_in_rel e2)
        r

    let debug_trans_rel chan tag r =
      let open EventTransRel in
      if not (EventTransRel.is_empty r) then
        fprintf chan "%s\n\t\ti=%a\n\t\to=%a\n\t\tr=%a\n" tag
          debug_events r.input
          debug_events r.output
          debug_rel  r.rel

    type event_structure = {
        procs : A.proc list ; (* will prove convenient *)
        events : EventSet.t ;        (* really a set *)
        speculated : EventSet.t ;        (* really a set *)
        po : EventSet.t * EventRel.t;
        partial_po: EventTransRel.t;
        intra_causality_data : EventRel.t ;   (* really a (partial order) relation *)
        intra_causality_control : EventRel.t ;(* really a (partial order) relation *)
      intra_causality_order : EventRel.t ; (* Just order *)
        control : EventRel.t ;
        data_ports : EventSet.t ; success_ports : EventSet.t ;
        input : EventSet.t option ;
        data_input : EventSet.t option ;
        output : EventSet.t option ;
        ctrl_output : EventSet.t option ;
        sca : EventSetSet.t ;
        mem_accesses : EventSet.t ;
        aligned : (event * EventSet.t) list ;
      }

    let procs_of es = es.procs

    let locs_of es = EventSet.fold (fun e k -> match location_of e with Some l -> l::k | None -> k) es.events []

    let map_aligned f = List.map (fun (e,es) -> f e,EventSet.map f es)

    let map_event_structure f es =
      let map_rel = EventRel.map_nodes f
      and map_set = EventSet.map f in
      { procs = es.procs ;
        events = map_set es.events ;
        speculated = map_set es.speculated ;
        po = begin let r,e = es.po in (map_set r, map_rel e) end;
        partial_po = EventTransRel.map_nodes f es.partial_po ;
        intra_causality_data = map_rel  es.intra_causality_data ;
        intra_causality_control = map_rel es.intra_causality_control ;
        intra_causality_order = map_rel es.intra_causality_order ;
        control = map_rel es.control ;
        data_ports = map_set es.data_ports ;
        success_ports = map_set es.success_ports ;
        input = Misc.app_opt map_set es.input ;
        data_input = Misc.app_opt map_set es.data_input ;
        output = Misc.app_opt map_set es.output ;
        ctrl_output = Misc.app_opt map_set es.ctrl_output ;
        sca = EventSetSet.map map_set es.sca ;
        mem_accesses = map_set es.mem_accesses ;
        aligned = map_aligned f es.aligned;
      }

    let do_speculate es =
      let s = es.events in
      {es with speculated = s}

    let iico es =
      EventRel.union3
        es.intra_causality_data
        es.intra_causality_control
        es.intra_causality_order

    let empty =
      { procs = [] ; events = EventSet.empty ;
        speculated = EventSet.empty ;
        po = (EventSet.empty,EventRel.empty);
        partial_po = EventTransRel.empty;
        intra_causality_data = EventRel.empty ;
        intra_causality_control = EventRel.empty ;
        intra_causality_order = EventRel.empty ;
        control = EventRel.empty ;
        data_ports = EventSet.empty ; success_ports = EventSet.empty ;
        input = None; data_input = None;
        output = None ; ctrl_output = None ;
        sca = EventSetSet.empty ;
        mem_accesses = EventSet.empty ;
        aligned = [];
      }

    let is_empty_event_structure es =
      Misc.nilp es.procs &&
      EventSet.is_empty es.events &&
      EventRel.is_empty es.intra_causality_data &&
      EventRel.is_empty es.intra_causality_control &&
      EventRel.is_empty es.intra_causality_order &&
      EventRel.is_empty es.control &&
      EventSet.is_empty es.data_ports &&
      EventSet.is_empty es.success_ports &&
      Misc.is_none es.input &&
      Misc.is_none es.output &&
      Misc.is_none es.ctrl_output

(****************************)
(* Projection of event set *)
(****************************)

    module Proj(S:MySet.S) = struct

      let rec add_env p e = function
        | [] -> assert false
        | (q,es as c)::env ->
            if Misc.int_eq p q then
              (q, S.add e es)::env
            else
              c::add_env p e env

      let proj procs_of ps es =
        let env = List.map (fun p -> p,S.empty) ps in
        let env =
          S.fold
            (fun e ->
              List.fold_right
                (fun p env -> add_env p  e env)
                (procs_of e))
            es env in
        List.map (fun (_p,es) -> es) env
    end

    module ProjSet = Proj(EventSet)

    let proj_events es =
      ProjSet.proj
        (fun e -> match proc_of e with
        | Some p -> [p]
        | None -> []) (procs_of es) es.events

    module ProjRel = Proj(EventRel)

    let proc_of_pair (e1,e2) =
      let p1 = proc_of e1 and p2 = proc_of e2 in
      match p1,p2 with
      | Some p1,Some p2 ->
          if Misc.int_eq p1 p2 then [p1]
          else []
      | _,_ -> []

    let proj_rel es rel =
      ProjRel.proj proc_of_pair (procs_of es) rel

    let proj_proc_view es rel =
      let proc_of (e1,e2) =
        let p1 = proc_of e1 and p2 = proc_of e2 in
        match p1,p2 with
        | Some p1, Some p2 ->
            if Misc.int_eq p1 p2 then [p1]
            else if is_mem_store e1 then [p2]
            else if is_mem_store e2 then [p1]
            else [] (* Can occur for X86CC -> no projected relation *)
        | None,Some p2 ->
            if is_mem_store e1 then [p2] else []
        | Some p1,None ->
            if is_mem_store e2 then [p1] else []
        | None,None -> [] in
      ProjRel.proj proc_of (procs_of es) rel

    let undetermined_vars_in_event e =
      Act.undetermined_vars_in_action e.action

    let undetermined_vars_in_event_structure es =
      EventSet.fold
        (fun e k -> V.ValueSet.union (undetermined_vars_in_event e) k)
        es.events V.ValueSet.empty

    let simplify_vars_in_event soln e =
      {e with action = Act.simplify_vars_in_action soln e.action}

    let simplify_vars_in_event_structure soln es =
      if V.Solution.is_empty soln then es
      else map_event_structure (simplify_vars_in_event soln) es

(********************************)
(* Event structure manipulation *)
(********************************)

(* Input *)

    let min_evts evts r =
      EventRel.fold
        (fun (_,e) k -> EventSet.remove e k)
        r evts

    let minimals es =
      match es.input with
      | None ->
         min_evts es.events  (iico es)
      | Some evts -> evts

    let minimals_no_spurious es =
      EventSet.filter
        (fun e -> not (is_spurious e))
        (minimals es)


    let minimals_avoid aset es =
      match es.input with
      | None ->
         Printf.eprintf "Minimal avoid, input is none\n%!" ;
         let intra_causality =
           let r = iico es in
           EventRel.filter (fun (e,_) -> not (EventSet.mem e aset)) r in
         min_evts (EventSet.diff es.events aset) intra_causality
      | Some es ->
         Printf.eprintf "Minimal avoid, input is {%a}\n%!" debug_events es;
         Warn.warn_always "minimal_avoid with explicit input" ;
         EventSet.diff es aset

    let minimals_data es =
      match es.data_input with
      | None -> min_evts es.events es.intra_causality_data
      | Some evts -> evts

    let minimals_data_no_spurious es =
      EventSet.filter
        (fun e -> not (is_spurious e))
        (minimals_data es)

(* Ouput *)

    let max_evts evts r =
      EventRel.fold
        (fun (e,_) k -> EventSet.remove e k)
        r evts

    let maximals es = max_evts es.events (iico es)

    let maximals_data es = max_evts es.events es.intra_causality_data

    let get_output es = match es.output with
    | None -> maximals_data es
    | Some o -> o

    let get_dinput es = match es.input with
      | None -> minimals es
      | Some es -> es

    let debug_opt chan (v,f,es) = match v with
      | None -> fprintf chan "-{%a}" debug_events (f es)
      | Some es -> debug_events chan es

    let debug_output chan es =
      fprintf chan "(i=%a, o=%a)"
        debug_opt (es.input,get_dinput,es)
        debug_opt (es.output,get_output,es)

    let debug_event_structure chan es =
      fprintf chan "(\n" ;
      fprintf chan "\tevents: %a\n" debug_events es.events ;
      fprintf chan "\tinput: %a\n" debug_opt (es.input,get_dinput,es) ;
      fprintf chan "\toutput: %a\n" debug_opt (es.output,get_output,es) ;
      fprintf chan "\tiico_data: %a\n" debug_rel es.intra_causality_data ;
      fprintf chan "\tiico_ctrl: %a\n" debug_rel es.intra_causality_control ;
      let _,rel = es.po in
      if not (EventRel.is_empty rel) then
        fprintf chan "\tpo: %a\n" debug_rel rel;
      debug_trans_rel chan "\tpartial_po: " es.partial_po;
      fprintf chan ")\n"

    let get_ctrl_output es = match es.ctrl_output with
    | None -> maximals es
    | Some o -> o

    let get_ctrl_output_commits es =
      EventSet.filter is_commit (get_ctrl_output es)

(**********************************)
(* Add together event structures  *)
(**********************************)

(* Checking events sets are disjoint, disabled *)
    let check_disjoint do_it es1 es2 =
      (*assert (EventSet.disjoint es1.events es2.events) ;*)
      Some (do_it es1 es2)

(************************)
(* Parallel composition *)
(************************)

    let do_union_output access default es1 es2 =
      match access es1,access es2 with
    | Some o1, Some o2 -> Some (EventSet.union o1 o2)
    | None,None -> None
    | None,Some o2 ->
        Some (EventSet.union (default es1) o2)
    | Some o1,None ->
        Some (EventSet.union o1 (default es2))

    let union_output =
      do_union_output (fun es -> es.output) maximals_data

    and union_ctrl_output =
      do_union_output (fun es -> es.ctrl_output) maximals

    let debug_opt dbg chan = function
      | None -> fprintf chan "None"
      | Some e -> dbg chan e

    let do_union_input = do_union_output

    let get_input es = es.input

    let union_input = do_union_input get_input minimals

    let get_data_input es = es.data_input

    let union_data_input = do_union_input get_data_input minimals_data

(*******************************)
(* (Data-)Output in sequencing *)
(*******************************)

(* data-sequencing *)
    let sequence_data_output es1 es2 =
      if dbg then eprintf "Seq %a %a ->" debug_output es1 debug_output es2 ;
      let r =  match es1.output,es2.output with
      | __,(Some _ as out) -> out
      | None,None -> None
      | Some out,None ->
          (* Tricky case, when get_output is empty,
             None would mean loosing the explicit output
             and re-including maximal elts *)
          let out2 = get_output es2 in
          if EventSet.is_empty out2 then Some out
          else Some out2 in
      if dbg then eprintf " %a\n" (debug_opt debug_events) r ;
      r

(* Control sequencing, in all circonstances es1 output must be discarded *)
    let sequence_control_output _es1 es2 = Some (get_output es2)

(*******************************)
(* Ctrl_output in sequencing   *)
(*******************************)

    let sequence_data_ctrl_output es1 es2 =
      match es1.ctrl_output,es2.ctrl_output with
      | __,(Some _ as out) -> out
      | None,None -> None
      | Some out,None ->
         let out2 = get_output es2 in
         if EventSet.is_empty out2 then Some out
         else Some out2

    (* Sequential composition *)

    let seq_partial_po =
      if not is_po_partial then fun _ _ -> EventTransRel.empty
      else fun es1 es2 ->
        if EventSet.is_empty es1.events then es2.partial_po
        else if EventSet.is_empty es2.events then es1.partial_po
        else EventTransRel.seq es1.partial_po es2.partial_po

    let inst_code_comp (*poi*) es1 es2 =
      { procs = [] ;
        events = EventSet.union es1.events es2.events;
        speculated = EventSet.union es1.speculated es2.speculated;
        po =
        begin
          if do_deps then
            let r1 = es1.events in
            if EventSet.is_empty r1 then es2.po
            else
              let r2,e2 = es2.po in
              (r1, EventRel.union (EventRel.cartesian r1 r2) e2)
          else es2.po
        end ;
        partial_po = seq_partial_po es1 es2;
        intra_causality_data = EventRel.union
          es1.intra_causality_data es2.intra_causality_data ;
        intra_causality_control = EventRel.union
          es1.intra_causality_control  es2.intra_causality_control ;
        intra_causality_order = EventRel.union
          es1.intra_causality_order  es2.intra_causality_order ;
        control = EventRel.union es1.control es2.control;
        data_ports = EventSet.union es1.data_ports es2.data_ports;
        success_ports = EventSet.union es1.success_ports es2.success_ports;
        input = es1.input ;  data_input = es1.data_input ;
        output = es2.output; ctrl_output = es2.ctrl_output ;
        sca = EventSetSet.union es1.sca es2.sca;
        mem_accesses = EventSet.union es1.mem_accesses es2.mem_accesses;
        aligned = es1.aligned @ es2.aligned;
      }

(* Function inst_code_comp_spec builds pod node with two branches, left and right,
   It is important that left and right output are single, have increasing ids
   and are immediate successors or the pod. *)

    let inst_code_comp_spec es1 es2 es3 =
      let outs = get_output es1 in
      begin match EventSet.as_singleton (EventSet.filter is_bcc es1.events) with
      | Some pod ->
          let succs = EventRel.succs es1.intra_causality_data pod in
          if not (EventSet.equal succs outs) then
            Warn.fatal "Reject complex dependance in inst_code_comp_spec"
      | None -> Warn.fatal "No single pod in inst_comp_code_comp_spec"
      end ;
      match EventSet.elements outs with
      | [lo;ro;] ->
          let lo,ro = if EventSet.mem ro es1.speculated then lo,ro else ro,lo in
          { procs = [] ;
            events = EventSet.union3 es1.events es2.events es3.events;
            speculated =
            EventSet.union3 es1.speculated es2.speculated es3.events;
            po =
            begin
              assert do_deps ;
              let r1 = EventSet.diff es1.events outs in
              let r1l = EventSet.add lo r1
              and r1r = EventSet.add ro r1 in
              let r2,e2 = es2.po
              and r3,e3 = es3.po in
              r1,
              EventRel.union
                (EventRel.union (EventRel.cartesian r1l r2) e2)
                (EventRel.union (EventRel.cartesian r1r r3) e3)
            end ;
            partial_po = seq_partial_po es1 es2;
            intra_causality_data =
            EventRel.union3
              es1.intra_causality_data
              es2.intra_causality_data
              es3.intra_causality_data;
            intra_causality_control =
            EventRel.union3
              es1.intra_causality_control
              es2.intra_causality_control
              es3.intra_causality_control;
            intra_causality_order =
            EventRel.union3
              es1.intra_causality_order
              es2.intra_causality_order
              es3.intra_causality_order;
            control = EventRel.union3 es1.control es2.control es3.control;
            data_ports =
            EventSet.union3 es1.data_ports es2.data_ports es3.data_ports;
            success_ports =
            EventSet.union3
              es1.success_ports es2.success_ports es3.success_ports;
            input = None; data_input = None ;
            output = None; ctrl_output = None ;
            sca = EventSetSet.union3 es1.sca es2.sca es3.sca;
            mem_accesses =
            EventSet.union3 es1.mem_accesses es2.mem_accesses es3.mem_accesses;
            aligned = es1.aligned @ es2.aligned @ es3.aligned ;
          }
      | _ -> Warn.fatal "Event.inst_code_comp_spec called in wrong context"

(* Two utilities *)
    let po_union =
      if do_deps then
        fun es1 es2 ->
          let r1,e1 = es1.po and r2,e2 = es2.po in
          (EventSet.union r1 r2, EventRel.union e1 e2)
      else fun es _ -> es.po

    let partial_po_union =
      if is_po_partial then fun es1 es2 ->
        EventTransRel.union es1.partial_po es2.partial_po
      else fun _ _ -> EventTransRel.empty

    let speculated_union =
      if do_deps then
        fun es1 es2 ->
          EventSet.union es1.speculated es2.speculated;
      else
        fun es _ -> es.speculated

(* Standard union of two structures, specific fields to be completed *)
    let union es1 es2 =
      { procs = [];
        events = EventSet.union es1.events es2.events ;
        speculated = speculated_union es1 es2 ;
        po = po_union es1 es2 ;
        partial_po = partial_po_union es1 es2 ;
        intra_causality_data =
          EventRel.union
            es1.intra_causality_data
            es2.intra_causality_data ;
        intra_causality_control =
          EventRel.union
            es1.intra_causality_control
            es2.intra_causality_control ;
        intra_causality_order =
          EventRel.union
            es1.intra_causality_order
            es2.intra_causality_order ;
        control =
          EventRel.union es1.control es2.control ;
        data_ports =
          EventSet.union es1.data_ports es2.data_ports ;
        success_ports =
          EventSet.union es1.success_ports es2.success_ports ;
       input = None ; data_input = None ;
       output = None; ctrl_output = None ;
       sca = EventSetSet.union es1.sca es2.sca ;
       mem_accesses = EventSet.union es1.mem_accesses es2.mem_accesses ;
       aligned = es1.aligned @ es2.aligned ;
      }

(* Parallel composition *)

    let do_para_comp es1 es2 =
      let r = union es1 es2 in
      { r with
        input = union_input es1 es2 ;
        data_input = union_data_input es1 es2 ;
        output = union_output es1 es2 ;
        ctrl_output = union_ctrl_output es1 es2 ;
      }

    let para_comp check =
      if check then check_disjoint do_para_comp
      else fun es1 es2 -> Some (do_para_comp es1 es2)

    let para_atomic es1 es2 =
      let m1 = EventSet.filter is_mem es1.events
      and m2 = EventSet.filter is_mem es2.events in
      Misc.app_opt
        (fun r ->
          { r with sca = EventSetSet.add (EventSet.union m1 m2) r.sca; })
        (para_comp true es1 es2)

    let do_force get mk es =
      match get es with
      | None -> Some (mk es)
      | Some _ as i -> i

    let force_input tag es1 es2 =
      let o = do_force get_input minimals es2 in
      if dbg then
        Printf.eprintf "ForceInput%s %a(%a) %a(%a) -> %a\n%!"
          tag
          (debug_opt debug_events) es1.input
          debug_events es1.events
          (debug_opt debug_events) es2.input
          debug_events es2.events
          (debug_opt debug_events) o ;
      o

    and force_data_input = do_force get_data_input minimals_data

(* Parallel composition, input on second monad argument *)

    let para_input_right es1 es2 =
       let r = union es1 es2 in
       let r =
         { r with
           input = force_input "ParaRight" es1 es2;
           data_input = force_data_input es2;
           output = union_output es1 es2 ;
           ctrl_output = union_ctrl_output es1 es2 ;
         } in
       Some r

(* Parallel composition, do not include first monad argument in output *)
    let para_output_right es1 es2 =
      let r = union es1 es2 in
      let r =
        { r with
          input = union_input es1 es2 ;
          data_input = union_data_input es1 es2 ;
          output = Some (get_output es2);
          ctrl_output = union_ctrl_output es1 es2;
        } in
      Some r

    let para_po_seq_output_right es1 es2 =
      let r = union es1 es2 in
      let r =
        { r with
          input = union_input es1 es2 ;
          data_input = union_data_input es1 es2 ;
          output = Some (get_output es2);
          ctrl_output = union_ctrl_output es1 es2;
          partial_po = seq_partial_po es1 es2;
        }
      in
      Some r

(* parallel composition with memory event sequencing *)
    let seq_mem es1 es2 =
      let r = do_para_comp es1 es2 in
      let r =
        { r with
          intra_causality_order =
            EventRel.union r.intra_causality_order
              (EventRel.cartesian
                 (EventSet.filter is_mem es1.events)
                 (EventSet.filter is_mem es2.events)) ;
        } in
      Some r

(* Composition with intra_causality_data from first to second *)
    let do_seq_input access es1 es2 =
      if is_empty_event_structure  es1 then access es2
      else access es1

    let seq_input es1 es2 =
      let o = do_seq_input get_input es1 es2 in
      if dbg then
        Printf.eprintf "SeqInput %a(%a) %a(%a) -> %a\n%!"
          (debug_opt debug_events) es1.input
          debug_events es1.events
          (debug_opt debug_events) es2.input
          debug_events es2.events
          (debug_opt debug_events) o ;
      o
    and seq_data_input = do_seq_input  get_data_input

    let data_comp mini_loc mkOut es1 es2 =
      let r = union es1 es2 in
      { r with
        intra_causality_data =
        EventRel.filter
          (* Found that reviewing code, check by assert... *)
          (fun (e1,e2) ->
            let b = e1 != e2 in
            if not b then
              eprintf "Warning: get rid of event %a\n%!" debug_event e1 ;
            b)
          (EventRel.union
             r.intra_causality_data
             (EventRel.cartesian (get_output es1) (mini_loc es2))) ;
        input = seq_input es1 es2 ;
        data_input = seq_data_input es1 es2 ;
        output = mkOut es1 es2 ;
        ctrl_output = sequence_data_ctrl_output es1 es2 ;
      }

    let (=*$=) =
      check_disjoint (data_comp minimals_data sequence_data_output)

    let data_po_seq es1 es2 =
      let r = data_comp minimals sequence_data_output es1 es2 in
      Some
        { r with
          partial_po = seq_partial_po es1 es2;
        }

    let data_input_next es1 es2 =
      let r = data_comp minimals_data sequence_data_output es1 es2  in
      Some
        { r with
          input = force_input "Next" es1 es2;
          data_input = force_data_input es2;
        }

    let do_union_input_seq access default es1 es2 =
      if is_empty_event_structure es1 then access es2
      else if is_empty_event_structure es2 then access es1
      else Some (EventSet.union (default es1) (default es2))

    let union_input_seq = do_union_input_seq get_input minimals
    and union_data_input_seq = do_union_input_seq get_data_input minimals_data

    let data_input_union es1 es2 =
      let r =
        data_comp
          (fun es -> min_evts es.events (iico es))
          sequence_data_output es1 es2  in
      let r =
        { r with
          input = union_input_seq es1 es2 ;
          data_input = union_data_input_seq es1 es2 ;
        } in
      if dbg then
        eprintf "data_input_union %a %a -> %a\n"
          debug_output es1
          debug_output es2
          debug_output r ;
      Some r

    let data_to_minimals =
      check_disjoint (data_comp minimals sequence_data_output)

    let data_to_output es1 es2 =
      let r =
        data_comp
          get_output
          sequence_data_output es1 es2 in
      let r =
        { r with
          input = union_input_seq es1 es2 ;
          data_input = union_data_input_seq es1 es2 ;
        } in
      Some r

    let (=$$=) =
      let out es1 es2 =
        let out = get_output es1 in
        if dbg then
          eprintf "SeqFirst %a %a -> %a\n"
            debug_output es1 debug_output es2 debug_events out ;
        Some out in
      check_disjoint (data_comp minimals_data out)

    let data_output_union es1 es2 =
      let r = data_comp minimals sequence_data_output es1 es2 in
      Some
        { r with
          output = union_output es1 es2 ;
        }

(* Composition with intra_causality_control from first to second *)

    let control_comp  maxi_loc mini_loc mkOut es1 es2 =
      let r = union es1 es2 in
      { r with
        intra_causality_control =
          EventRel.union
            r.intra_causality_control
            (EventRel.cartesian (maxi_loc es1) (mini_loc es2)) ;
        input = seq_input es1 es2 ;
        data_input = seq_data_input es1 es2 ;
        output = mkOut es1 es2;
        ctrl_output = sequence_data_ctrl_output es1 es2;
      }

(* Standard *)
    let (=**=) =
      check_disjoint
        (control_comp get_ctrl_output minimals sequence_control_output)

(* Variant: data input restricted to first argument *)
    let bind_control_set_data_input_first es1 es2 =
      let r =
        control_comp
          get_ctrl_output minimals sequence_control_output
          es1 es2 in
      Some { r with data_input = force_data_input es1; }

    (* Variant that sets input on second argument *)
    let control_input_next es1 es2 =
      let r =
        control_comp
          get_ctrl_output minimals sequence_control_output
          es1 es2  in
      Some
        { r with
          input = force_input "Next" es1 es2;
          data_input = force_data_input es2;
        }

    let control_input_union es1 es2 =
      if dbg then
        eprintf "Control_input_union %a %a\n%!"
          debug_output es1
          debug_output es2 ;
      let r =
        control_comp get_ctrl_output minimals sequence_control_output
          es1 es2  in
      Some
        { r with
          input = union_input  es1 es2;
          data_input = union_data_input es1 es2;
        }

(* Variant that set output on first argumet *)
    let (=*$$=) =
      let out es1 es2 =
        let out = get_output es1 in
        if dbg then
          eprintf "CtrlFirst %a %a -> %a\n"  debug_output es1 debug_output es2 debug_events out ;
        Some out in
      check_disjoint (control_comp get_ctrl_output minimals out)

(* Variant that removes some es2 input from iico_ctrl targets *)
    let bind_ctrl_avoid aset es1 es2 =
      Some
        (control_comp maximals (minimals_avoid aset)
           sequence_control_output es1 es2)

    let bind_ctrl_sequence_data =
      check_disjoint (control_comp get_ctrl_output minimals sequence_data_output)

    let bind_ctrl_sequence_data_po es1 es2 =
      let r =
        control_comp get_ctrl_output minimals sequence_data_output es1 es2
      in
      Some { r with partial_po = seq_partial_po es1 es2 }

    let partial_po_union3 =
      if is_po_partial then fun es1 es2 es3 ->
        EventTransRel.union3 es1.partial_po es2.partial_po es3.partial_po
      else fun _ _ _ -> EventTransRel.empty

    let partial_po_union4 =
      if is_po_partial then fun es1 es2 es3 es4 ->
        EventTransRel.union4 es1.partial_po es2.partial_po es3.partial_po
          es4.partial_po
      else fun _ _ _ _ -> EventTransRel.empty

    let partial_po_union5 =
      if is_po_partial then fun es1 es2 es3 es4 es5 ->
        EventTransRel.union5 es1.partial_po es2.partial_po es3.partial_po
          es4.partial_po es5.partial_po
      else fun _ _ _ _ _ -> EventTransRel.empty

    let partial_po_union6 =
      if is_po_partial then fun es1 es2 es3 es4 es5 es6 ->
        EventTransRel.union6 es1.partial_po es2.partial_po es3.partial_po
          es4.partial_po es5.partial_po es6.partial_po
      else fun _ _ _ _ _ _ -> EventTransRel.empty

    let partial_po_unions =
      if is_po_partial then fun li ->
        List.map (fun es -> es.partial_po) li |> EventTransRel.unions
      else fun _ -> EventTransRel.empty

    let po_union4 =
      if do_deps then
        fun es1 es2 es3 es4 ->
          let r1,e1 = es1.po and r2,e2 = es2.po
          and r3,e3 = es3.po and r4,e4 = es4.po in
          (EventSet.union4 r1 r2 r3 r4, EventRel.union4 e1 e2 e3 e4)
      else fun es _ _ _ -> es.po

    let po_union3 =
      if do_deps then
        fun es1 es2 es3 ->
          let r1,e1 = es1.po and r2,e2 = es2.po and r3,e3 = es3.po in
          (EventSet.union3 r1 r2 r3, EventRel.union3 e1 e2 e3)
      else
        fun es _ _ -> es.po

    let union3 es1 es2 es3 =
      { procs = [];
        events = EventSet.union3 es1.events es2.events es3.events;
        speculated =
          begin
            if do_deps then
              EventSet.union3 es1.speculated es2.speculated es3.speculated
            else es1.speculated
          end;
        po = po_union3 es1 es2 es3;
        partial_po = partial_po_union3 es1 es2 es3;
       intra_causality_data =
         EventRel.union3
           es1.intra_causality_data
           es2.intra_causality_data
           es3.intra_causality_data;
       intra_causality_control =
         EventRel.union3
           es1.intra_causality_control
           es2.intra_causality_control
           es3.intra_causality_control;
       intra_causality_order =
         EventRel.union3
           es1.intra_causality_order
           es2.intra_causality_order
           es3.intra_causality_order;
       control =
         EventRel.union3 es1.control es2.control es3.control;
       data_ports =
         EventSet.union3 es1.data_ports es2.data_ports es3.data_ports;
       success_ports =
         EventSet.union3
           es1.success_ports es2.success_ports es3.success_ports;
       input = None ; data_input = None ;
       output = None; ctrl_output = None ;
       sca = EventSetSet.union3 es1.sca es2.sca es3.sca;
       mem_accesses =
         EventSet.union3
           es1.mem_accesses
           es2.mem_accesses
           es3.mem_accesses;
       aligned = es1.aligned @ es2.aligned @ es3.aligned;
      }

(*  Build es1 -ctrl+data-> es3 <-data- es2 monad.
    Notice the contrast in output definition of es1 and es2
    (maximals_commits vs. get_output) *)

    let bind_ctrldata_data es1 es2 es3 =
      let input_es3 = minimals es3 in
      let r = union3 es1 es2 es3 in
      { r with
        intra_causality_data =
          EventRel.union r.intra_causality_data
            (EventRel.cartesian
               (EventSet.union (get_output es1) (get_output es2)) input_es3);
        intra_causality_control =
          EventRel.union
            r.intra_causality_control
            (EventRel.cartesian (get_ctrl_output_commits es1) input_es3);
        input = union_input es1 es2;
        data_input = union_data_input es1 es2;
        output = sequence_data_output es2 es3;
       }

(* Control+data composition, both output stay in first structure *)
    let bind_ctrldata_first_outputs es1 es2 =
      let data_out1 = get_output es1
      and ctrl_out1 = get_ctrl_output_commits es1 in
      let r = union es1 es2 in
      let r =
        { r with
          intra_causality_data =
            EventRel.union
              r.intra_causality_data
              (EventRel.cartesian data_out1 (minimals_data_no_spurious es2)) ;
          intra_causality_control =
            EventRel.union
              r.intra_causality_control
              (EventRel.cartesian ctrl_out1 (minimals_no_spurious es2)) ;
          input = seq_input es1 es2 ;
          data_input = seq_data_input es1 es2 ;
          output = Some data_out1 ;
          ctrl_output = Some ctrl_out1 ;
        } in
      Some r

(* Control composition, both output stay in first structure *)
    let bind_ctrl_first_outputs es1 es2 =
      let data_out1 = get_output es1
      and ctrl_out1 = get_ctrl_output_commits es1 in
      let r = union es1 es2 in
      let r =
        { r with
          intra_causality_control =
            EventRel.union
              r.intra_causality_control
              (EventRel.cartesian ctrl_out1 es2.events) ;
          input = seq_input es1 es2 ;
          data_input = seq_data_input es1 es2 ;
          output = Some data_out1 ;
          ctrl_output = Some ctrl_out1 ;
        } in
      Some r

    (* Order composition. *)
    let bind_order es1 es2 =
      let r = union es1 es2 in
      let intra_causality_order =
        EventRel.union r.intra_causality_order
          (EventRel.cartesian (get_output es1) (minimals es2))
      in
      Some { r with intra_causality_order }

(* Multi composition for exchange *)

(* rsX/wsX are from/to the same location *)

    let exch_comp rs1 rs2 ws1 ws2 =
      { procs = [] ;
        events = EventSet.union4 rs1.events rs2.events ws1.events ws2.events;
        speculated =
        if do_deps then
          EventSet.union4
            rs1.speculated rs2.speculated
            ws1.speculated ws2.speculated
        else
          rs1.speculated;
        po = po_union4 rs1 rs2 ws1 ws2;
        partial_po = partial_po_union4 rs1 rs2 ws1 ws2;
        intra_causality_data =
        EventRel.union3
          (EventRel.union4
             rs1.intra_causality_data rs2.intra_causality_data
             ws1.intra_causality_data ws2.intra_causality_data)
           (EventRel.cartesian (maximals rs1) (minimals ws2))
           (EventRel.cartesian (maximals rs2) (minimals ws1));
        intra_causality_control =
        EventRel.union3
          (EventRel.union4
             rs1.intra_causality_control rs2.intra_causality_control
             ws1.intra_causality_control ws2.intra_causality_control)
           (EventRel.cartesian (maximals rs1) (minimals ws1))
           (EventRel.cartesian (maximals rs2) (minimals ws2));
       intra_causality_order =
           EventRel.union4
             rs1.intra_causality_order rs2.intra_causality_order
             ws1.intra_causality_order ws2.intra_causality_order;
        control =
        EventRel.union4 rs1.control rs2.control ws1.control ws2.control;
        data_ports =
        EventSet.union4 rs1.data_ports rs2.data_ports ws1.data_ports ws2.data_ports;
        success_ports =
          EventSet.union4 rs1.success_ports rs2.success_ports ws1.success_ports ws2.success_ports;
        input =  None ; data_input = None ;
        output = None; ctrl_output = None ;
        sca = EventSetSet.union4 rs1.sca rs2.sca ws1.sca ws2.sca;
        mem_accesses =
        EventSet.union4
          rs1.mem_accesses rs2.mem_accesses
          ws1.mem_accesses ws2.mem_accesses ;
        aligned = rs1.aligned @ rs2.aligned @ ws1.aligned @ ws2.aligned ;
      }

    let po_union5 es1 es2 es3 es4 es5 =
      let r1,e1 = es1.po and r2,e2 = es2.po and r3,e3 = es3.po
      and r4,e4 = es4.po and r5,e5 = es5.po in
      (EventSet.union5 r1 r2 r3 r4 r5, EventRel.union5 e1 e2 e3 e4 e5)

(* Notice
  If swp then add ctrl dependency from rmem to wmem,
  else (amo) add data dependency
  If physical and branching add dependencies *)

    let swp_or_amo physical op rloc rmem rreg wmem wreg =
      let is_amo = Misc.is_some op in
      let outrmem = maximals rmem
      and outrreg = maximals rreg
      and inwmem = minimals wmem
      and inwreg = minimals wreg
      and inrmem = minimals rmem in
      let inmem = EventSet.union inrmem inwmem in
      let mem2mem = EventRel.cartesian outrmem inwmem in
      { procs = [] ;
        events = EventSet.union5
          rloc.events rmem.events rreg.events wmem.events wreg.events;
        speculated =
        if do_deps then
          EventSet.union5
            rloc.speculated rmem.speculated rreg.speculated
            wmem.speculated wreg.speculated
        else
          rloc.speculated;
        po = po_union5 rloc rmem rreg wmem wreg;
        partial_po = partial_po_union5 rloc rmem rreg wmem wreg;
        intra_causality_data =
        EventRel.unions
          [EventRel.union5
             rloc.intra_causality_data
             rmem.intra_causality_data rreg.intra_causality_data
             wmem.intra_causality_data wreg.intra_causality_data ;
           EventRel.cartesian outrmem inwreg;
           if is_amo then mem2mem else EventRel.empty;
           EventRel.cartesian outrreg inwmem;
           EventRel.cartesian (get_output rloc) inmem];
        intra_causality_control =
        EventRel.unions
          [EventRel.unions
             [rloc.intra_causality_control;
              rmem.intra_causality_control;rreg.intra_causality_control;
              wmem.intra_causality_control;wreg.intra_causality_control;];
           if memtag || (physical && is_branching) then
 (* Notice similarity with data composition.  *)
             EventRel.cartesian
               (get_ctrl_output_commits rloc)
               (EventSet.union inmem inwreg)
           else EventRel.empty;];
        intra_causality_order =
        EventRel.union
          (EventRel.union5
             rloc.intra_causality_order rmem.intra_causality_order
             rreg.intra_causality_order wmem.intra_causality_order
             wreg.intra_causality_control)
          (if is_amo then EventRel.empty else mem2mem);
        control =
        EventRel.union5 rloc.control rmem.control rreg.control wmem.control wreg.control;
        data_ports =
        EventSet.union5
          rloc.data_ports
          rmem.data_ports rreg.data_ports wmem.data_ports wreg.data_ports;
        success_ports =
        EventSet.union5
          rloc.success_ports
          rmem.success_ports rreg.success_ports wmem.success_ports wreg.success_ports;
        input = None; data_input = None;
        output = None; ctrl_output = None ;
        sca = EventSetSet.union5 rloc.sca rmem.sca rreg.sca wmem.sca wreg.sca;
        mem_accesses =
        EventSet.union5
          rloc.mem_accesses
          rmem.mem_accesses rreg.mem_accesses
          wmem.mem_accesses wreg.mem_accesses ;
        aligned =
          rloc.aligned @ rmem.aligned @ rreg.aligned @ wmem.aligned
          @ wreg.aligned ;
      }

(* disjointness is awful *)

    let exch rx ry wx wy =
      if
        EventSet.disjoint rx.events ry.events &&
        EventSet.disjoint rx.events wx.events &&
        EventSet.disjoint rx.events wy.events &&
        EventSet.disjoint ry.events wx.events &&
        EventSet.disjoint ry.events wy.events &&
        EventSet.disjoint wx.events wy.events
      then
        exch_comp rx ry wx wy
      else
        assert false

    let linux_exch re rloc rmem wmem =
      let input_wmem = minimals wmem in
      let output_rloc = maximals rloc in
      { procs = [];
        events =
        EventSet.union4 re.events rloc.events rmem.events wmem.events;
        speculated =
        if do_deps then
          EventSet.union4
            re.speculated rloc.speculated rmem.speculated wmem.speculated
        else
          re.speculated;
        po = po_union4 re rloc rmem wmem;
        partial_po = partial_po_union4 re rloc rmem wmem;
        intra_causality_data =
        EventRel.unions
          [EventRel.union4
             re.intra_causality_data rloc.intra_causality_data
             rmem.intra_causality_data wmem.intra_causality_data;
           EventRel.cartesian (maximals re) input_wmem;
           EventRel.cartesian output_rloc input_wmem;
           EventRel.cartesian output_rloc (minimals rmem);];
        intra_causality_control =
        EventRel.union
          (EventRel.union4
             re.intra_causality_control rloc.intra_causality_control
             rmem.intra_causality_control wmem.intra_causality_control)
          (EventRel.cartesian (maximals rmem) (minimals wmem));
        intra_causality_order =
          EventRel.union4
            re.intra_causality_order rloc.intra_causality_order
            rmem.intra_causality_order wmem.intra_causality_order;
        control =
        EventRel.union4
          re.control rloc.control rmem.control wmem.control;
        data_ports =
        EventSet.union4
          re.data_ports rloc.data_ports rmem.data_ports wmem.data_ports;
        success_ports =
        EventSet.union4
          re.success_ports rloc.success_ports rmem.success_ports wmem.success_ports;
        input = None; data_input = None;
        output = Some (get_output rmem); ctrl_output = None ;
        sca = EventSetSet.union4 re.sca rloc.sca rmem.sca wmem.sca;
        mem_accesses =
        EventSet.union4
          re.mem_accesses rloc.mem_accesses rmem.mem_accesses wmem.mem_accesses;
        aligned = re.aligned @ rloc.aligned @ rmem.aligned @ wmem.aligned ;
      }

    let amo re rloc rmem wmem =
      let input_wmem = minimals wmem in
      let output_rloc = maximals rloc in
      { procs = [];
        events =
        EventSet.union4 re.events rloc.events rmem.events wmem.events;
        speculated =
        if do_deps then
          EventSet.union4
            re.speculated rloc.speculated rmem.speculated wmem.speculated
        else
          re.speculated;
        po = po_union4 re rloc rmem wmem;
        partial_po = partial_po_union4 re rloc rmem wmem;
        intra_causality_data =
        EventRel.unions
          [EventRel.union4
             re.intra_causality_data rloc.intra_causality_data
             rmem.intra_causality_data wmem.intra_causality_data;
           EventRel.cartesian (maximals rmem) input_wmem;
           EventRel.cartesian (maximals re) input_wmem;
           EventRel.cartesian output_rloc input_wmem;
           EventRel.cartesian output_rloc (minimals rmem);];
        intra_causality_control =
          EventRel.union4
            re.intra_causality_control rloc.intra_causality_control
            rmem.intra_causality_control wmem.intra_causality_control;
        intra_causality_order =
          EventRel.union4
            re.intra_causality_order rloc.intra_causality_order
            rmem.intra_causality_order wmem.intra_causality_order;
        control =
        EventRel.union4
          re.control rloc.control rmem.control wmem.control;
        data_ports =
        EventSet.union4
          re.data_ports rloc.data_ports rmem.data_ports wmem.data_ports;
        success_ports =
        EventSet.union4
          re.success_ports rloc.success_ports rmem.success_ports wmem.success_ports;
        input = None; data_input = None;
        output = Some (get_output rmem); ctrl_output = None ;
        sca = EventSetSet.union4 re.sca rloc.sca rmem.sca wmem.sca;
        mem_accesses =
        EventSet.union4
          re.mem_accesses rloc.mem_accesses rmem.mem_accesses wmem.mem_accesses;
        aligned = re.aligned @ rloc.aligned @ rmem.aligned @ wmem.aligned ;
    }


(************************************)
(* Compare exchange, really complex *)
(************************************)

(* Success *)
    let linux_cmpexch_ok rloc rold rnew rmem wmem =
      let input_wmem = minimals wmem in
      let input_rmem = minimals rmem in
      let output_rloc = maximals rloc in
      { procs = [];
        events =
        EventSet.union5 rloc.events rold.events rnew.events
          rmem.events wmem.events;
        speculated =
        if do_deps then
          EventSet.union5
            rloc.speculated rold.speculated rnew.speculated
            rmem.speculated wmem.speculated
        else
          rloc.speculated;
        po = po_union5 rloc rold rnew rmem wmem;
        partial_po = partial_po_union5 rloc rold rnew rmem wmem;
        intra_causality_data =
        EventRel.unions
          [EventRel.union5
             rloc.intra_causality_data rold.intra_causality_data
             rnew.intra_causality_data
             rmem.intra_causality_data wmem.intra_causality_data;
           EventRel.cartesian (maximals rnew) input_wmem;
           EventRel.cartesian output_rloc input_wmem;
           EventRel.cartesian output_rloc input_rmem;];
        intra_causality_control =
        EventRel.unions
          [EventRel.union5
             rloc.intra_causality_control rold.intra_causality_control
             rnew.intra_causality_control
             rmem.intra_causality_control wmem.intra_causality_control;
           EventRel.cartesian (maximals rold) input_wmem;
           EventRel.cartesian (maximals rmem) input_wmem;];
        intra_causality_order =
          EventRel.union5
            rloc.intra_causality_order rold.intra_causality_order
            rnew.intra_causality_order
            rmem.intra_causality_order wmem.intra_causality_order;
        control=
        EventRel.union5 rloc.control rold.control rnew.control
          rmem.control wmem.control;
        data_ports=
        EventSet.union5 rloc.data_ports rold.data_ports rnew.data_ports
          rmem.data_ports wmem.data_ports;
        input = None; data_input = None;
        output=Some (get_output rmem); ctrl_output = None ;
        success_ports=
        EventSet.union5 rloc.success_ports rold.success_ports rnew.success_ports
          rmem.success_ports wmem.success_ports;
        sca = EventSetSet.union5 rloc.sca rold.sca rnew.sca rmem.sca wmem.sca;
        mem_accesses=
        EventSet.union5 rloc.mem_accesses rold.mem_accesses rnew.mem_accesses
          rmem.mem_accesses wmem.mem_accesses;
        aligned =
          rloc.aligned @ rold.aligned @ rnew.aligned
          @ rmem.aligned @ wmem.aligned ;
      }

(* Failure, a phantom write event that would iico_control depens
   upon rold may be an idea... Without it rold has no impact out evt_struct
   outcome... As another illustration of something lacking the cmpxchg introduces no
   new iico_control edge. *)

    let linux_cmpexch_no rloc rold rmem =
      let input_rmem = minimals rmem in
      let output_rloc = maximals rloc in
      { procs = [];
        events =
        EventSet.union3 rloc.events rold.events rmem.events;
        speculated =
        if do_deps then
          EventSet.union3 rloc.speculated rold.speculated rmem.speculated
        else
          rloc.speculated;
        po = po_union3 rloc rold rmem;
        partial_po = partial_po_union3 rloc rold rmem;
        intra_causality_data =
        EventRel.unions
          [EventRel.union3
             rloc.intra_causality_data rold.intra_causality_data
             rmem.intra_causality_data;
           EventRel.cartesian output_rloc input_rmem;];
        intra_causality_control =
          EventRel.union3
            rloc.intra_causality_control rold.intra_causality_control
            rmem.intra_causality_control;
        intra_causality_order =
          EventRel.union3
            rloc.intra_causality_order rold.intra_causality_order
            rmem.intra_causality_order;
        control=
        EventRel.union3 rloc.control rold.control rmem.control;
        data_ports=
        EventSet.union3 rloc.data_ports rold.data_ports rmem.data_ports;
        success_ports=
          EventSet.union3
            rloc.success_ports rold.success_ports rmem.success_ports;
        input=None; data_input=None;
        output=Some (get_output rmem); ctrl_output = None ;
        sca = EventSetSet.union3 rloc.sca rold.sca rmem.sca;
        mem_accesses=
        EventSet.union3 rloc.mem_accesses rold.mem_accesses rmem.mem_accesses;
        aligned = rloc.aligned @ rold.aligned @ rmem.aligned ;
      }

(**************)
(* Add unless *)
(**************)

    let linux_add_unless_ok loc a u rmem wmem retbool =
      let out_loc = maximals loc
      and in_rmem = minimals rmem
      and in_wmem = minimals wmem in
      { procs = [];
        events = EventSet.union5 loc.events a.events u.events rmem.events wmem.events;
        speculated =
        if do_deps then
          EventSet.union5
            loc.speculated a.speculated u.speculated
            rmem.speculated wmem.speculated
        else
          loc.speculated;
        po = po_union5 loc a u rmem wmem;
        partial_po = partial_po_union5 loc a u rmem wmem;
        intra_causality_data =
        EventRel.unions
          [EventRel.union5
             loc.intra_causality_data a.intra_causality_data
             u.intra_causality_data
             rmem.intra_causality_data wmem.intra_causality_data;
           EventRel.cartesian out_loc in_wmem;
           EventRel.cartesian out_loc in_rmem;
           EventRel.cartesian (maximals a) in_wmem;
           EventRel.cartesian (maximals rmem) in_wmem;];
        intra_causality_control =
        EventRel.unions
          [EventRel.union5
             loc.intra_causality_control a.intra_causality_control
             u.intra_causality_control
             rmem.intra_causality_control wmem.intra_causality_control;
           EventRel.cartesian (maximals u) in_wmem;];
        intra_causality_order =
          EventRel.union5
            loc.intra_causality_order a.intra_causality_order
            u.intra_causality_order
            rmem.intra_causality_order wmem.intra_causality_order;
        control =
        EventRel.union5
          loc.control a.control u.control rmem.control wmem.control;
        data_ports =
        EventSet.union5
          loc.data_ports a.data_ports u.data_ports
          rmem.data_ports wmem.data_ports;
        success_ports =
        EventSet.union5
          loc.success_ports a.success_ports u.success_ports
          rmem.success_ports wmem.success_ports;
        input=None; data_input=None;
        output =
        Some
          (if retbool then
             EventSet.union (get_output rmem) (get_output u)
           else get_output rmem);
        ctrl_output = None ;
        sca = EventSetSet.union5 loc.sca a.sca u.sca rmem.sca wmem.sca;
        mem_accesses =
        EventSet.union5
          loc.mem_accesses a.mem_accesses u.mem_accesses
          rmem.mem_accesses wmem.mem_accesses;
         aligned =
           loc.aligned @ a.aligned @ u.aligned @ rmem.aligned @ wmem.aligned ;
      }

    let linux_add_unless_no loc u rmem retbool =
      let out_loc = maximals loc
      and in_rmem = minimals rmem in
      { procs = [];
        events =
        EventSet.union3 loc.events u.events rmem.events;
        speculated =
        if do_deps then
          EventSet.union3 loc.speculated u.speculated rmem.speculated
        else
          loc.speculated;
        po = po_union3 loc u rmem;
        partial_po = partial_po_union3 loc u rmem;
        intra_causality_data =
        EventRel.unions
          [loc.intra_causality_data; u.intra_causality_data;
           rmem.intra_causality_data;
           EventRel.cartesian out_loc in_rmem;];
        intra_causality_control =
        EventRel.union3
          loc.intra_causality_control u.intra_causality_control
          rmem.intra_causality_control;
        intra_causality_order =
        EventRel.union3
          loc.intra_causality_order u.intra_causality_order
          rmem.intra_causality_order;
        control =
        EventRel.union3 loc.control u.control rmem.control;
        data_ports =
        EventSet.union3 loc.data_ports u.data_ports rmem.data_ports;
        success_ports =
        EventSet.union3 loc.success_ports u.success_ports rmem.success_ports;
        input=None; data_input=None;
        output =
        Some
          (if retbool then EventSet.union (get_output rmem) (get_output u) else get_output rmem);
        ctrl_output = None ;
        sca = EventSetSet.union3 loc.sca u.sca rmem.sca ;
        mem_accesses =
        EventSet.union3 loc.mem_accesses u.mem_accesses rmem.mem_accesses;
        aligned = loc.aligned @ u.aligned @ rmem.aligned ;
      }

    let po_union6 =
      if do_deps then
        fun es1 es2 es3 es4 es5 es6 ->
          let r1,e1 = es1.po and r2,e2 = es2.po and r3,e3 = es3.po
          and r4,e4 = es4.po and r5,e5 = es5.po and r6,e6 = es6.po in
          let r =
            EventSet.union
              (EventSet.union3 r1 r2 r3) (EventSet.union3 r4 r5 r6)
          and e =
            EventRel.union
              (EventRel.union3 e1 e2 e3) (EventRel.union3 e4 e5 e6) in
          r,e
      else
        fun es _ _ _ _ _ -> es.po

    let po_unions =
      if do_deps then
        List.fold_left
          (fun (roots, edges) evt_st ->
             let r,e = evt_st.po in
             EventSet.union r roots,EventRel.union e edges)
          (EventSet.empty,EventRel.empty)
      else
        function | hd::_ -> hd.po | [] -> assert false

(* RISCV Store conditional *)
    let get_switch v = Variant.get_switch A.arch v C.variant

    let riscv_sc success resa data addr wres wresult wmem =
      let dep_on_write = get_switch Variant.SwitchDepScWrite
      and dep_sc_result = get_switch Variant.SwitchDepScResult in
      let in_wmem = minimals wmem
      and out_wmem = maximals wmem
      and in_wres = minimals wres
      and in_wresult = minimals wresult
      and out_data = maximals data
      and out_resa = maximals resa in
      { procs = [];
        events =
        EventSet.union
          (EventSet.union3 resa.events data.events addr.events)
          (EventSet.union3 wres.events wresult.events wmem.events);
        speculated =
        if do_deps then
          EventSet.union
            (EventSet.union3 resa.speculated data.speculated addr.speculated)
            (EventSet.union3 wres.speculated wresult.speculated wmem.speculated)
        else
          resa.speculated;
        po = po_union6 resa data addr wres wresult wmem;
        partial_po = partial_po_union6 resa data addr wres wresult wmem;
        intra_causality_data =
        EventRel.unions
          [EventRel.union3 resa.intra_causality_data
             data.intra_causality_data addr.intra_causality_data;
           EventRel.union3 wres.intra_causality_data
             wresult.intra_causality_data wmem.intra_causality_data;
           EventRel.cartesian
             (get_output addr)
             (EventSet.union in_wmem
                (if (C.variant Variant.FullScDepend || success) && dep_sc_result
                then in_wresult else EventSet.empty));
           EventRel.cartesian out_data
             (if C.variant Variant.Success || not (C.variant Variant.FullScDepend) then in_wmem else
             EventSet.union in_wresult in_wmem); ];
        intra_causality_control =
          EventRel.union5
            (EventRel.cartesian out_resa in_wres)
            (EventRel.cartesian
               (EventSet.union
                  out_resa
                  (if is_branching then get_ctrl_output_commits addr
                   else get_ctrl_output addr))
               in_wmem)
            (if dep_on_write then EventRel.cartesian out_wmem in_wresult
             else EventRel.empty)
            (EventRel.union3 resa.intra_causality_control
               data.intra_causality_control addr.intra_causality_control)
            (EventRel.union3 wres.intra_causality_control
               wresult.intra_causality_control wmem.control);
        intra_causality_order =
          EventRel.union6
            resa.intra_causality_order
            data.intra_causality_order
            addr.intra_causality_order
            wres.intra_causality_order
            wresult.intra_causality_order
            wmem.intra_causality_order;
        control =
        EventRel.union
          (EventRel.union3 resa.control data.control addr.control)
          (EventRel.union3 wres.control wresult.control wmem.control);
        data_ports =
        EventSet.union
          (EventSet.union3 resa.data_ports data.data_ports addr.data_ports)
          (EventSet.union3 wres.data_ports wresult.data_ports wmem.data_ports);
        success_ports =
        EventSet.union
          (EventSet.union3 resa.success_ports data.success_ports addr.success_ports)
          (EventSet.union3 wres.success_ports wresult.success_ports wmem.success_ports);
        input=None; data_input=None;
        output = Some (EventSet.union (get_output wresult) (get_output wres));
        ctrl_output = None ;
        sca =
        EventSetSet.union
          (EventSetSet.union3 resa.sca data.sca addr.sca)
          (EventSetSet.union3 wres.sca wresult.sca wmem.sca);
        mem_accesses =
        EventSet.union
          (EventSet.union3 resa.mem_accesses data.mem_accesses addr.mem_accesses)
          (EventSet.union3 wres.mem_accesses wresult.mem_accesses wmem.mem_accesses);
        aligned =
          resa.aligned @ data.aligned @ addr.aligned
          @ wres.aligned @ wresult.aligned @ wmem.aligned ;}

(* AArch64 CAS, failure *)
    let aarch64_cas_no is_phy add_ctrl rn rs wrs rm br =
      let input_wrs = minimals wrs
      and input_rm = minimals rm
      and input_br = minimals br in
      { procs = [] ;
        events =
        EventSet.union5
          rn.events rs.events wrs.events rm.events br.events;
        speculated =
        if do_deps then
          EventSet.union5
            rn.speculated rs.speculated wrs.speculated rm.speculated br.speculated
        else rn.speculated;
        po = po_union5 rn rs wrs rm br;
        partial_po = partial_po_union5 rn rs wrs rm br;
        intra_causality_data =
        EventRel.union
          (EventRel.union5
             rn.intra_causality_data
             rs.intra_causality_data
             wrs.intra_causality_data
             rm.intra_causality_data
             br.intra_causality_data)
          (EventRel.union4
             (EventRel.cartesian (get_output rn) input_rm) (* D1 *)
             (EventRel.cartesian (get_output rm) input_wrs)    (* Df1 *)
             (EventRel.cartesian (get_output rm) input_br)
             (EventRel.cartesian (get_output rs) input_br)
          );
        intra_causality_control =
          (if is_branching && is_phy then
             EventRel.union
               (EventRel.cartesian (get_ctrl_output_commits rn) input_rm)
           else Misc.identity)
          ((if add_ctrl then
             EventRel.union
               (EventRel.cartesian (get_output br) input_wrs)
            else Misc.identity)
          (EventRel.union5
             rn.intra_causality_control rs.intra_causality_control
             wrs.intra_causality_control rm.intra_causality_control
             br.intra_causality_control)) ;
        intra_causality_order =
          EventRel.union5
            rn.intra_causality_order rs.intra_causality_order
            wrs.intra_causality_order rm.intra_causality_order
            br.intra_causality_order;
        control =
        EventRel.union5 rn.control rs.control rm.control wrs.control br.control;
        data_ports =
        EventSet.union5
          rn.data_ports rs.data_ports
          wrs.data_ports rm.data_ports br.data_ports;
        success_ports =
        EventSet.union5
          rn.success_ports rs.success_ports
          wrs.success_ports rm.success_ports br.success_ports;
        sca =
        EventSetSet.union5
          rn.sca rs.sca wrs.sca rm.sca br.sca;
        mem_accesses =
        EventSet.union5
          rn.mem_accesses rs.mem_accesses
          wrs.mem_accesses rm.mem_accesses br.mem_accesses;
        input=None; data_input=None;
        output = Some (maximals wrs);
        ctrl_output = None ;
        aligned = rn.aligned @ rs.aligned @ wrs.aligned @ rm.aligned @ br.aligned;
      }

(* AArch64 CAS, success *)
    let aarch64_cas_ok is_phy prov_data rn rs rt wrs rm wm br =
      let input_wrs = minimals wrs
      and input_rm = minimals rm
      and input_wm = minimals wm
      and input_br = minimals br in
      { procs = [] ;
        events =
        EventSet.unions
          [rn.events; rs.events; rt.events;
           wrs.events; rm.events; br.events; wm.events];
        speculated =
        if do_deps then
          EventSet.unions
            [rn.speculated; rs.speculated; rt.speculated;
             wrs.speculated; rm.speculated; br.speculated; wm.speculated]
        else
          rn.speculated;
        po = po_unions [rn; rs; rt; wrs; rm; br; wm];
        partial_po = partial_po_unions [rn; rs; rt; wrs; rm; br; wm];
        intra_causality_data =
        EventRel.union
          (EventRel.unions
             [rn.intra_causality_data;
                rs.intra_causality_data;
                rt.intra_causality_data;
                wrs.intra_causality_data;
                rm.intra_causality_data;
                br.intra_causality_data;
                wm.intra_causality_data])
          (let output_rn = get_output rn
           and output_prov_data = match prov_data with
             | `DataFromRRs -> get_output rs
             | `DataFromRx -> get_output rm
           in
           EventRel.unions
             [(EventRel.cartesian output_rn input_rm);          (* D1 *)
              (EventRel.cartesian output_rn input_wm);          (* Ds2 *)
              (EventRel.cartesian (get_output rt) input_wm);    (* Ds3 *)
              (EventRel.cartesian output_prov_data input_wrs);
              (EventRel.cartesian (get_output rs) input_br);
              (EventRel.cartesian (get_output rm) input_br);]
          );
        intra_causality_control =
        EventRel.union
          (EventRel.unions
             [rn.intra_causality_control;
              rs.intra_causality_control;
              rt.intra_causality_control;
              wrs.intra_causality_control;
              rm.intra_causality_control;
              br.intra_causality_control;
              wm.intra_causality_control])
          (let output_br = get_ctrl_output br in
           EventRel.union4
             (if is_branching && is_phy then
                EventRel.cartesian (get_ctrl_output_commits rn)
                  (EventSet.union input_rm input_wm)
              else EventRel.empty)
             (match prov_data with
              | `DataFromRRs -> EventRel.cartesian output_br input_wrs
              | `DataFromRx -> EventRel.empty)
             (EventRel.cartesian output_br input_wm)   (* Cs1 *)
             (EventRel.cartesian output_br input_wm)); (* Cs2 *)
        intra_causality_order =
          EventRel.unions
             [rn.intra_causality_order; rs.intra_causality_order;
              rt.intra_causality_order; wrs.intra_causality_order;
              rm.intra_causality_order; br.intra_causality_order;
              wm.intra_causality_order];
        control =
        (EventRel.unions
           [rn.control; rs.control; rt.control;
            wrs.control; rm.control; br.control; wm.control]);
        data_ports =
        (EventSet.unions
           [rn.data_ports; rs.data_ports; rt.data_ports;
            wrs.data_ports; rm.data_ports; br.data_ports; wm.data_ports]);
        success_ports =
        (EventSet.unions
           [rn.success_ports; rs.success_ports; rt.success_ports;
            wrs.success_ports; rm.success_ports; br.success_ports;
            wm.success_ports]);
        sca =
        (EventSetSet.unions
           [rn.sca; rs.sca; rt.sca;
           wrs.sca; rm.sca; br.sca; wm.sca]);
        mem_accesses =
        (EventSet.unions
           [rn.mem_accesses; rs.mem_accesses; rt.mem_accesses;
            wrs.mem_accesses; rm.mem_accesses; br.mem_accesses; wm.mem_accesses]);
        input=None; data_input=None;
        output = Some (maximals wrs); ctrl_output = None ;
        aligned =
          rn.aligned @ rs.aligned @ rt.aligned @ wrs.aligned
          @ rm.aligned @ br.aligned @ wm.aligned ;
      }

(* Temporary morello variation of CAS *)
    let aarch64_cas_ok_morello rn rt rm wm =
      let input_rm = minimals rm
      and input_wm = minimals wm in
      { procs = [] ;
        events =
        EventSet.union4
          rn.events rt.events rm.events wm.events ;
        speculated =
        if do_deps then
          EventSet.union4
            rn.speculated rt.speculated rm.speculated wm.speculated
        else
          rn.speculated;
        po = po_union4 rn rt rm wm;
        partial_po = partial_po_union4 rn rt rm wm;
        intra_causality_data =
        EventRel.union
          (EventRel.union4
             rn.intra_causality_data
             rt.intra_causality_data
             rm.intra_causality_data
             wm.intra_causality_data)
          (let output_rn = get_output rn in
           EventRel.union3
             (EventRel.cartesian output_rn input_rm)
             (EventRel.cartesian output_rn input_wm)
             (EventRel.cartesian (get_output rt) input_wm));
        intra_causality_control =
        EventRel.union
          (EventRel.union4
             rn.intra_causality_control
             rt.intra_causality_control
             rm.intra_causality_control
             wm.intra_causality_control)
          (EventRel.cartesian (get_ctrl_output rm) input_wm);
        intra_causality_order =
          EventRel.union4
             rn.intra_causality_order rt.intra_causality_order
             rm.intra_causality_order wm.intra_causality_order;
        control =
        (EventRel.union4
           rn.control rt.control rm.control wm.control);
        data_ports =
        (EventSet.union4
           rn.data_ports rt.data_ports rm.data_ports wm.data_ports);
        success_ports =
        (EventSet.union4
           rn.success_ports rt.success_ports rm.success_ports wm.success_ports);
        sca =
        (EventSetSet.union4
           rn.sca rt.sca rm.sca wm.sca);
        mem_accesses =
        (EventSet.union4
           rn.mem_accesses rt.mem_accesses rm.mem_accesses wm.mem_accesses);
        input=None; data_input=None;
        output = None; ctrl_output = None ;
        aligned = rn.aligned @ rt.aligned @ rm.aligned @ wm.aligned ;
      }

(* Store update composition, read data, read EA, write EA and  write Mem *)

(* Dijointness not checked..., useless *)
    let stu rD rEA wEA wM =
      assert
        (EventRel.is_empty rD.intra_causality_control &&
         EventRel.is_empty rEA.intra_causality_control &&
         EventRel.is_empty wEA.intra_causality_control &&
         EventRel.is_empty wM.intra_causality_control) ;
      { procs = [] ;
        events = EventSet.union4 rD.events rEA.events wEA.events wM.events;
        speculated =
        if do_deps then
          EventSet.union4
            rD.speculated rEA.speculated wEA.speculated wM.speculated
        else
          rD.speculated;
        po = po_union4 rD rEA wEA wM;
        partial_po = partial_po_union4 rD rEA wEA wM;
        intra_causality_data = begin
          let drD = rD.intra_causality_data
          and drEA = rEA.intra_causality_data
          and dwEA = wEA.intra_causality_data
          and dwM = wM.intra_causality_data in
          EventRel.unions
            [EventRel.unions [drD; drEA; dwEA; dwM;];
             EventRel.cartesian (get_output rEA) (minimals wEA);
             EventRel.cartesian
               (EventSet.union (get_output rEA) (get_output rD)) (minimals wM);]
        end ;
        intra_causality_control = EventRel.empty;
        intra_causality_order = EventRel.empty;
        control =
        EventRel.union4 rD.control rEA.control wEA.control wM.control ;
        data_ports =
        EventSet.union4
          rD.data_ports rEA.data_ports wEA.data_ports wM.data_ports ;
        success_ports =
        EventSet.union4
          rD.success_ports rEA.success_ports
          wEA.success_ports wM.success_ports ;
        input=None; data_input=None;
        output = None; ctrl_output = None ;
        sca = EventSetSet.union4 rD.sca rEA.sca wEA.sca wM.sca;
        mem_accesses =
        EventSet.union4
          rD.mem_accesses rEA.mem_accesses wEA.mem_accesses wM.mem_accesses ;
        aligned = rD.aligned @ rEA.aligned @ wEA.aligned @ wM.aligned ;
      }

(*************************************************************)
(* Add together event structures from different instructions *)
(*************************************************************)

    let different_ins i1 i2 =  match i1,i2 with
    | IdSome i1,IdSome i2 -> A.inst_instance_compare i1 i2 <> 0
    | ((IdInit|IdSpurious),IdSome _)
    | (IdSome _,(IdInit|IdSpurious))
    | ((IdInit|IdSpurious),(IdInit|IdSpurious)) -> true

    let disjoint_iiis es1 es2 =
      EventSet.for_all
        (fun e1 ->
          EventSet.for_all
            (fun e2 -> different_ins e1.iiid e2.iiid)
            es2.events)
        es1.events

    let check_both do_it es1 es2 =
      if
        not
          (EventSet.disjoint es1.events es2.events &&
           disjoint_iiis es1 es2)
      then assert false
      else Some (do_it es1 es2)

(* Parallel composition *)
    let (+|+) = check_both do_para_comp


    let empty_event_structure = empty

(* Instruction control *)

    let cond_comp es1 es2 =
      let r = do_para_comp es1 es2 in
      let control = EventRel.cartesian es1.events es2.events in
      { r with control =  EventRel.union control r.control; }

    (* Build from events - without any form of iico. *)
    let from_events events =
      let partial_po =
        if is_po_partial then EventTransRel.from_nodes events
        else EventTransRel.empty
      in
      { empty with events ; partial_po }
  end
