(* The intermediate language of our JIT *)
(* Designed to make speculative optimizations easier *)
(* Inspired by CompCert's RTL and Sourir *)
(* At first, input programs have no optimized versions. *)
(* The framestate insertion inserts framestate instructions *)
(* Dynamic Optimizations and Assume Insertion modify a specIR program *)
(* Lowering transforms a specIR program into a lowered one with no framestate *)

Require Export String.
Require Export ZArith.
Require Export Znumtheory.
Require Export List.
Require Export Maps.
Require Export common.
Require Export events.
Require Export values.
Require Export Smallstep.

(** * Syntax  *)
(* Registers *)
Definition reg: Type := positive.

(* Operands are either registers names or integer constants or addresses *)
Inductive op: Type :=
| Reg : reg -> op
| Cst: value -> op.

(* Labels of the Control-Flow Graph *)
Definition label: Type := positive.

(* Operations and Expressions *)
Inductive bin_operation: Type :=
| Plus : bin_operation          (* CompCert's "Plus" notation for smallstep has been renamed "SPlus" *)
| Minus : bin_operation
| Mult : bin_operation
| Gt : bin_operation
| Lt : bin_operation
| Geq : bin_operation
| Leq : bin_operation
| Eq: bin_operation.

Inductive un_operation: Type :=
| UMinus : un_operation
| Neg : un_operation
| Assign : un_operation.

Inductive expr: Type :=
| Binexpr: bin_operation -> op -> op -> expr
| Unexpr: un_operation -> op -> expr.

(* Function names/identifiers *)
Definition fun_id: Type := positive.

(* Assigning multiple expressions to multiple registers for parallel assignment *)
Definition movelist: Type := list (reg * expr).

(* Binding registers to an expression, for deoptimizations *)
Definition varmap: Type := list (reg * expr).

Definition empty_varmap: varmap := nil.

(* Where to go to when deoptimizing *)
Definition deopt_target: Type := fun_id * label.

(* Information to synthesize new stack frames in an Assume instruction *)
Definition synth_frame: Type :=
  deopt_target * reg * varmap.

(* Instructions as a Control Flow Graph *)
Inductive instruction: Type :=
| Nop : option hint -> label -> instruction
(* [Nop oh next] simply goes to the [next] instruction. [oh] may be a hint for the profiler *)
| Op: expr -> reg -> label -> instruction
(* [Op expr reg next] evaluates [expr], puts the result in [reg] and moves to [next] *)
| Move: movelist -> label -> instruction
(* [Move l next] updates the left-hand side of [l] with an evaluation of its right-hand side *)
| Call : fun_id -> list expr -> reg -> label -> instruction
(* [Call f exl retreg next] puts the returned value of [(f exl)] in [retreg] and moves to [next] *)
| IReturn : expr -> instruction
(* [Return expr] evaluates [expr] and returns it *)
| Cond : expr -> label -> label -> instruction
(* [Cond expr iftrue iffalse] evaluates [expr]. If it is 0, move to [iffalse], else to [iftrue] *)
| Store : expr -> expr -> label -> instruction
(* [Store expr1 expr2 next] stores the value of [expr1] in address [expr2] and moves to [next] *)
| Load : expr -> reg -> label -> instruction
(* [Load expr reg next] loads the value at address [expr] puts it in reg [reg], and moves to [next] *)
| Printexpr : expr -> label -> instruction
(* [Printexpr expr next] prints the value of [expr] and moves to [next] *)
| Printstring : string -> label -> instruction
(* [Printstring s next] prints the string [s] then moves to [next] *)
| Framestate : deopt_target -> varmap -> list synth_frame -> label -> instruction
(* [Framestate  (f,l) vm sl next] can either move to [next] or deoptimize to the base version of *)
(* function [f] label [l], reconstructing the original environment with [vm] and [sl] *)
| Assume : list expr -> deopt_target -> varmap -> list synth_frame -> label -> instruction
(* [Assume le (f,l) vm sl next] first evaluates [le]. If all expressions are true then, *)
(* it moves to [next]. Otherwise, we deoptimize to the base version of function [f] label [l] *)
(* with the registers updated with the evaluation of [vm] *)
(* each element of [sl] corresponds to a new stackframe to be synthesized *)
| Fail : string -> instruction.
(* [Fail s] has blocking semantics. The interpreter should fail with the error message s *)

(* Successors of an instruction *)
(* Only inside the specIR program, does not account for deoptimization *)
Definition instr_succ (i:instruction): list label :=
  match i with
  | Nop _ next => next::nil
  | Op _ _ next => next::nil
  | Move _ next => next::nil
  | Call _ _ _ next => next::nil
  | IReturn _ => nil
  | Cond _ next1 next2 => next1::(next2::nil)
  | Store _ _ next => next::nil
  | Load _ _ next => next::nil
  | Printexpr _ next => next::nil
  | Printstring _ next => next::nil
  | Framestate _ _ _ next => next::nil
  | Assume _ _ _ _ next => next::nil
  | Fail _ => nil
  end.

(** * Multi-language Programs  *)

(* Some code for a function is a correspondence between labels and instructions *)
Definition code: Type := PTree.t instruction.

(* A version is some code and an entry point *)
Record version: Type := mk_version {
  ver_code: code;
  ver_entry: label;
}.

(* Defining base versions: no speculative (Framestate & Assume) instructions *)
Inductive is_spec: instruction -> Prop :=
| spec_assume: forall g tgt vm sl next,
    is_spec (Assume g tgt vm sl next)
| spec_framestate: forall tgt vm sl next,
    is_spec (Framestate tgt vm sl next).

Definition base_code (c:code): Prop :=
  forall (pc:label) (i:instruction), c!pc = Some i -> ~ (is_spec i).

Definition base_version (v:version): Prop :=
  base_code (ver_code v).

(* A function contains a baseline version of the code, and may contain a speculative version as well if it has been optimized *)
Record function': Type := mk_function {
  fn_params : list reg;
  fn_base : version;
  fn_opt : option version;
  base_no_spec: base_version fn_base
}.

Definition function: Type := function'.

(* A program is a list of functions, associated with a fun_id, and the main function's id *)
Record program: Type := mk_program {
  prog_main : fun_id;
  prog_funlist : PTree.t function;
}.

(** * Semantics  *)
Definition find_function_list (fid:fun_id) (funlist:PTree.t function): option function :=
  funlist ! fid.

Definition find_function (fid:fun_id) (p:program): option function :=
  find_function_list fid (prog_funlist p).

(* Find a base version given a function id and a program *)
Definition find_base_version (fid:fun_id) (p:program): option version :=
  match (find_function fid p) with
  | None => None
  | Some f => Some (fn_base f)
  end.

(* Find current version in a function *)
Definition current_version (f:function): version :=
  match (fn_opt f) with
  | None => fn_base f
  | Some o => o
  end.

(* Find the current version of a function in a program *)
Definition find_currver (fid:fun_id) (p:program): option version :=
  match (find_function fid p) with
  | None => None
  | Some f => Some (current_version f)
  end.

(* The state of all registers *)
Definition reg_map: Type := PTree.t value.
Definition empty_regmap: reg_map := PTree.empty value.

(* Stackframes *)
(* Return register, calling function, next instruction in calling function, state of the registers in calling function *)
Inductive stackframe: Type :=
| Stackframe : reg -> version -> label -> reg_map -> stackframe.

(* The stack model is simply a list of stack frames *)
(* The top of the stack is the head of the list *)
Definition stack: Type := list stackframe.

(** * Memory Model  *)
(* These are external parameters *)
Parameter mem_state: Type.
Parameter initial_memory: mem_state.
Parameter Load_: mem_state -> value -> option value.
Parameter Store_: mem_state -> value -> value -> option mem_state.

(** * Semantics sates *)
Inductive state: Type :=
| State:
    forall (s:stack)                 (* call stack *)
           (v:version)          (* current version being executed *)
           (pc:label)           (* current label *)
           (rm:reg_map)         (* state of the registers *)
           (ms:mem_state),      (* state of the memory *)
      state
| Final:                        (* go into final state after returning from function main *)
    forall (v:value)
           (ms:mem_state),
      state.

(* Final value if it exists *)
Definition final_value (s:state): option value :=
  match s with
  | State _ _ _ _ _ => None
  | Final v _ => Some v
  end.

(* Initial state of a program *)
Inductive initial_state (p:program): state -> Prop :=
| intro_init_state:
    forall f v
      (FINDF: find_function (prog_main p) p = Some f)
      (NOARGS: fn_params f = nil) (* the main function should have no parameters *)
      (CURRVER: current_version f = v),
      initial_state p (State nil v (ver_entry v) empty_regmap initial_memory).

Inductive final_state (p:program): state -> value -> Prop :=
| intro_final_state:
    forall v ms,
      final_state p (Final v ms) v.

(* Evaluating operands *)
Inductive eval_op : op -> reg_map -> value -> Prop :=
| Eval_const: forall n rm, eval_op (Cst n) rm n
| Eval_reg: forall v r rm
              (GETRM: rm # r = Some v),
    eval_op (Reg r) rm v.

(* Conditions are done on values *)
Definition bool_to_val (b:bool): value :=
  match b with
  | true => Vint 1
  | false => Vint 0
  end.

(* Evaluating Binary operations on values *)
Inductive eval_binop_values: bin_operation -> value -> value -> value -> Prop :=
| Eval_plus : forall v1 v2, eval_binop_values Plus (Vint v1) (Vint v2) (Vint (v1+v2))
| Eval_minus : forall v1 v2, eval_binop_values Minus (Vint v1) (Vint v2) (Vint (v1-v2))
| Eval_mult : forall v1 v2, eval_binop_values Mult (Vint v1) (Vint v2) (Vint (v1*v2))
| Eval_gt : forall v1 v2, eval_binop_values Gt (Vint v1) (Vint v2) (bool_to_val(Z.gtb v1 v2))
| Eval_lt : forall v1 v2, eval_binop_values Lt (Vint v1) (Vint v2) (bool_to_val(Z.ltb v1 v2))
| Eval_geq : forall v1 v2, eval_binop_values Geq (Vint v1) (Vint v2) (bool_to_val(Z.geb v1 v2))
| Eval_leq : forall v1 v2, eval_binop_values Leq (Vint v1) (Vint v2) (bool_to_val(Z.leb v1 v2))
| Eval_eq : forall v1 v2, eval_binop_values Eq (Vint v1) (Vint v2) (bool_to_val(Z.eqb v1 v2)).

(* Evaluating Binary operations *)
Inductive eval_binop: bin_operation -> op -> op -> reg_map -> value -> Prop :=
| Eval_binop:
    forall binop o1 o2 v1 v2 v rm
      (EVALL: eval_op o1 rm v1)
      (EVALR: eval_op o2 rm v2)
      (EVALV: eval_binop_values binop v1 v2 v),
      eval_binop binop o1 o2 rm v.

(* Negation of a value *)
Definition int_neg (i:Z) : Z :=
  match i with
  | 0 => 1
  | _ => 0
  end.

(* Evaluating Unary operations on a value *)
Inductive eval_unop_value: un_operation -> value -> value -> Prop :=
| Eval_uminus: forall v, eval_unop_value UMinus (Vint v) (Vint (-v))
| Eval_neg: forall v, eval_unop_value Neg (Vint v) (Vint (int_neg v))
| Eval_assign: forall v, eval_unop_value Assign v v.

(* Evaluating Unary operations *)
Inductive eval_unop: un_operation -> op -> reg_map -> value -> Prop :=
| Eval_unop: forall unop o rm v vres
    (EVAL: eval_op o rm v)
    (EVALV: eval_unop_value unop v vres),
    eval_unop unop o rm vres.

(* Evaluating expressions *)
Inductive eval_expr: expr -> reg_map -> value -> Prop :=
| expr_binop:
    forall binop o1 o2 rm v
      (EVAL: eval_binop binop o1 o2 rm v),
      eval_expr (Binexpr binop o1 o2) rm v
| expr_unop:
    forall unop o rm v
      (EVAL: eval_unop unop o rm v),
      eval_expr (Unexpr unop o) rm v.

(* Computing the next pc of [Cond op iftrue iffalse] when [op] evaluates to [v] *)
Definition pc_cond (v:value) (iftrue:label) (iffalse:label): label :=
  match v with
  | Vint 0 => iffalse
  | Vint _ => iftrue
  end.

(* Checks if a list of expressions are all true (some Vint != Vint 0) *)
(* Used to verify if the guard of an Assume should pass *)
(* If an evaluation fails,  the list does not evaluate to a boolean *)
Inductive eval_list_expr: list expr -> reg_map -> bool -> Prop :=
| eval_nil:
    forall rm, eval_list_expr nil rm true
| eval_cons_false:
    forall ex le rm
      (EVAL: eval_expr ex rm (Vint 0)),
      eval_list_expr (ex::le) rm false
| eval_cons_true:
    forall ex le rm v res
      (EVALH: eval_expr ex rm (Vint v))
      (TRUE: Zne v 0)                (* v <> 0 *)
      (EVALL: eval_list_expr le rm res),
      eval_list_expr (ex::le) rm res.

(* evaluates a list of operands (arguments) *)
Inductive eval_list: list expr -> reg_map -> list value -> Prop :=
| eval_list_nil:
    forall rm, eval_list nil rm nil
| eval_list_cons:
    forall le rm lv ex v
      (EVALH: eval_expr ex rm v)
      (EVALL: eval_list le rm lv),
      eval_list (ex::le) rm (v::lv).

(* Initialize the register map when calling a function *)
Fixpoint init_regs (valist:list value) (params:list reg): option reg_map :=
  match params with
  | nil => match valist with
           | nil => Some empty_regmap
           | _ => None          (* too many arguments *)
           end
  | par::params' => match valist with
                    | nil => None (* not enough arguments *)
                    | val::valist' => match (init_regs valist' params') with
                                     | None => None
                                     | Some rm => Some (rm # par <- val)
                                     end
                    end
  end.

(* Updates the reg_map [rm] with the bindings of [ml] *)
(* [rmeval] is the original [rm], used to evaluate the operands of [vm] *)
Inductive update_movelist' : movelist -> reg_map -> reg_map -> reg_map -> Prop :=
| eval_ml_nil: forall rm rmeval,
    update_movelist' nil rmeval rm rm
| eval_ml_cons: forall r e ml v rmeval rm rm'
    (EVAL: eval_expr e rmeval v)
    (UPDATE: update_movelist' ml rmeval rm rm'),
    update_movelist' ((r,e)::ml) rmeval rm (rm' # r <- v).

Definition update_movelist (ml:movelist) (rm:reg_map) (rm':reg_map): Prop :=
  update_movelist' ml rm rm rm'.

(** * Deoptimization Semantics  *)
(* Creates a new Register Mapping given a varmap *)
Inductive update_regmap: varmap -> reg_map -> reg_map -> Prop :=
| update_nil: forall rm,
    update_regmap nil rm empty_regmap (* now we construct from the empty regmap *)
| update_cons: forall r e vm v rm rm'
    (EVAL: eval_expr e rm v)
    (UPDATE: update_regmap vm rm rm'),
    update_regmap ((r,e)::vm) rm (rm' # r <- v).

(* [synthesize_frame p rm sl s]: the list [sl] synthesizes the stack [s] under [rm] and [p] *)
Inductive synthesize_frame: program -> reg_map -> list synth_frame -> stack -> Prop :=
| Synth_nil: forall p rm,
    synthesize_frame p rm nil nil
| Synth_cons: forall p s rm sl f l r vm update version
    (UPDATE: update_regmap vm rm update)
    (FINDV: find_base_version f p = Some version)
    (SYNTH: synthesize_frame p rm sl s),
    synthesize_frame p rm (((f,l),r,vm)::sl) ((Stackframe r version l update)::s).

(** * Small-step transition system *)
(* [step p s1 e s2] means that in program [p], state [s1] transitions to [s2] with event [e] *)
(* This is the semantics of lowered programs (no Framestates) *)
Inductive lowered_step: program -> state -> trace -> state -> Prop :=
| exec_Nop:
    forall p s f pc rm ms next oh
      (CODE: (ver_code f)!pc = Some (Nop oh next)),
      lowered_step p (State s f pc rm ms) E0 (State s f next rm ms)
| exec_Op:
    forall p s f pc rm ms expr reg next v
      (CODE: (ver_code f)!pc = Some (Op expr reg next))
      (EVAL: eval_expr expr rm v),
      lowered_step p (State s f pc rm ms) E0 (State s f next (rm # reg <- v) ms)
| exec_Move:
    forall p s f pc rm ms ml next newrm
      (CODE: (ver_code f)!pc = Some (Move ml next))
      (UPDATE: update_movelist ml rm newrm),
      lowered_step p (State s f pc rm ms) E0 (State s f next newrm ms)
| exec_Cond:
    forall p s f pc rm ms expr iftrue iffalse newpc v
      (CODE: (ver_code f)!pc = Some (Cond expr iftrue iffalse))
      (EVAL: eval_expr expr rm v)
      (NEXT: pc_cond v iftrue iffalse = newpc),
      lowered_step p (State s f pc rm ms) E0 (State s f newpc rm ms)
| exec_Call:
    forall p s f pc rm ms fid args retreg next func valist newrm version
      (CODE: (ver_code f)!pc = Some (Call fid args retreg next))
      (FINDF: find_function fid p = Some func)
      (CURRVER: current_version func = version)
      (EVALL: eval_list args rm valist)
      (INIT_REGS: init_regs valist func.(fn_params) = Some newrm),
      lowered_step p (State s f pc rm ms) E0 (State (Stackframe retreg f next rm ::s) version version.(ver_entry) newrm ms)
| exec_Return:
    forall p s fcurr fprev pc next rmcurr rmprev ms retex retval retreg
      (CODE: (ver_code fcurr)!pc = Some (IReturn retex))
      (EVAL: eval_expr retex rmcurr retval),
      lowered_step p (State (Stackframe retreg fprev next rmprev ::s) fcurr pc rmcurr ms) E0
           (State s fprev next (rmprev # retreg <- retval) ms)
| exec_Return_Final:
    forall p f pc rm ms rex retval
      (CODE: (ver_code f)!pc = Some (IReturn rex))
      (EVAL: eval_expr rex rm retval),
      lowered_step p (State nil f pc rm ms) E0 (Final retval ms)
| exec_Printexpr:
    forall p s f pc rm ms expr next printval
      (CODE: (ver_code f)!pc = Some (Printexpr expr next))
      (EVAL: eval_expr expr rm printval),
      lowered_step p (State s f pc rm ms) ((Valprint printval)::E0) (State s f next rm ms)
| exec_Printstring:
    forall p s f pc rm ms str next
      (CODE: (ver_code f)!pc = Some (Printstring str next)),
      lowered_step p (State s f pc rm ms) ((Stringprint str)::E0) (State s f next rm ms)
| exec_Store:
    forall p s f pc rm ms expr1 expr2 next val addr newms
      (CODE: (ver_code f)!pc = Some (Store expr1 expr2 next))
      (EVAL_ST: eval_expr expr1 rm val)
      (EVAL_AD: eval_expr expr2 rm addr)
      (STORE: Store_ ms addr val = Some newms), (* using the Store_ parameter *)
      lowered_step p (State s f pc rm ms) E0 (State s f next rm newms)
| exec_Load:
    forall p s f pc rm ms reg next expr addr val
      (CODE: (ver_code f)!pc = Some (Load expr reg next))
      (EVAL: eval_expr expr rm addr)
      (LOAD: Load_ ms addr = Some val), (* using the Load_ parameter *)
      lowered_step p (State s f pc rm ms) E0 (State s f next (rm # reg <- val) ms)
| exec_Assume_holds:
    forall p s f pc rm ms le tgt vm sl next
      (CODE: (ver_code f)! pc = Some (Assume le tgt vm sl next))
      (ASSUME_TRUE: eval_list_expr le rm true),
      lowered_step p (State s f pc rm ms) E0 (State s f next rm ms)
| exec_Assume_fails:
    forall p s f pc rm ms le fa la vm sl next newver newrm synth
      (CODE: (ver_code f)! pc = Some (Assume le (fa,la) vm sl next))
      (ASSUME_FAILS: (eval_list_expr le rm false)) (* at least one assertion fails *)
      (FINDF: find_base_version fa p = Some newver) (* the version we deoptimize to *)
      (UPDATE: update_regmap vm rm newrm) (* updating the regmap as indicated in the assume *)
      (SYNTH: synthesize_frame p rm sl synth), (* new synthesized stackframes *)
      lowered_step p (State s f pc rm ms) E0 (State (synth++s) newver la newrm ms).

(* Semantics given a lowered program *)
Definition lowered_sem (p:program) : semantics :=
  Semantics_gen lowered_step (initial_state p) (final_state p) p.

(** *  Non-deterministic semantics for speculative code *)
Inductive deopt_conditions : program -> state -> label -> stack -> version -> label -> reg_map -> Prop :=
| deopt_cond:
    forall p s f pc rm ms fa la vm sl next newver newrm synth
      (CODE: (ver_code f)! pc = Some (Framestate (fa,la) vm sl next))
      (FINDF: find_base_version fa p = Some newver) (* the version we deoptimize to *)
      (UPDATE: update_regmap vm rm newrm) (* updating the regmap as indicated in the assume *)
      (SYNTH: synthesize_frame p rm sl synth), (* new synthesized stackframes *)
      deopt_conditions p (State s f pc rm ms) next synth newver la newrm.

(* Non-deterministic semantics for the Framestate *)
Inductive specir_step: program -> state -> trace -> state -> Prop :=
| nd_exec_lowered:
    forall p s t s'
      (STEP: lowered_step p s t s'),
      specir_step p s t s'
| nd_exec_Framestate_go_on:
    forall p s f pc rm ms la next newver newrm synth
      (DEOPT_COND: deopt_conditions p (State s f pc rm ms) next synth newver la newrm),
      specir_step p (State s f pc rm ms) E0 (State s f next rm ms)
| nd_exec_Framestate_deopt:
    forall p s f pc rm ms la next newver newrm synth
      (DEOPT_COND: deopt_conditions p (State s f pc rm ms) next synth newver la newrm),
      specir_step p (State s f pc rm ms) E0 (State (synth++s) newver la newrm ms).

Definition specir_sem (p:program) : semantics :=
  Semantics_gen specir_step (initial_state p) (final_state p) p.

(** *  Loud semantics *)
(* Semantics that explicitly outputs Go_on or Deopt events when going through Framestates *)
(* This make the semantics determinate *)

(* Semantics where the Framestate produce observable events *)
Inductive loud_step: program -> state -> trace -> state -> Prop :=
| loud_exec_lowered:
    forall p s t s'
      (STEP: lowered_step p s t s'),
      loud_step p s t s'
| loud_exec_Framestate_go_on:
    forall p s f pc rm ms la next newver newrm synth
      (DEOPT_COND: deopt_conditions p (State s f pc rm ms) next synth newver la newrm),
      loud_step p (State s f pc rm ms) (Loud_Go_on::nil) (State s f next rm ms)
| loud_exec_Framestate_deopt:
    forall p s f pc rm ms la next newver newrm synth
      (DEOPT_COND: deopt_conditions p (State s f pc rm ms) next synth newver la newrm),
      loud_step p (State s f pc rm ms) (Loud_Deopt::nil) (State (synth++s) newver la newrm ms).

Definition loud_sem (p:program) : semantics :=
  Semantics_gen loud_step (initial_state p) (final_state p) p.

(** * Helper functions  *)
(* Replacing the optimized version of a function *)
Program Definition set_version_function (v:version) (f:function): function :=
  mk_function (fn_params f) (fn_base f) (Some v) _.
Next Obligation.
  apply (base_no_spec f).
Qed.

(* Removes the optimized version *)
Program Definition remove_opt_function (f:function): function :=
  mk_function (fn_params f) (fn_base f) None _.
Next Obligation.
  apply (base_no_spec f).
Qed.

(* Update a fun_list with the new function containing the new version *)
Definition set_version_funlist (fid:fun_id) (v:version) (fl:PTree.t function): PTree.t function :=
  match (fl ! fid) with
  | None => fl
  | Some f => fl # fid <- (set_version_function v f)
  end.

Definition remove_opt_funlist (fid:fun_id) (fl:PTree.t function): PTree.t function :=
  match (fl ! fid) with
  | None => fl
  | Some f => fl # fid <- (remove_opt_function f)
  end.

(* Updates versions in a program. *)
Definition set_version (p:program) (fid:fun_id) (v:version): program :=
  mk_program (prog_main p) (set_version_funlist fid v (prog_funlist p)).

Definition remove_opt (p:program) (fid:fun_id): program :=
  mk_program (prog_main p) (remove_opt_funlist fid (prog_funlist p)).

(* Max positive used in a PTree *)
Fixpoint max_pos' {A:Type} (vl:list (positive * A)): positive :=
  match vl with
  | nil => xH
  | (vid,v)::vl' => Pos.max vid (max_pos' vl')
  end.

Definition max_pos {A:Type} (tree:PTree.t A): positive :=
  max_pos' (PTree.elements tree).

Definition max_label (c:code): label :=
  max_pos c.

(** * Finding fresh labels  *)
(* Finds a label unused in c *)
Definition fresh_label' (c:code) :=
  Pos.succ (max_label c).
(* This simple version is often not good enough *)
(* As the Kildall fixpoint solver is more efficient on programs with sorted labels *)
(* It is often better to insert new instructions at a label that corresponds to its position in the code *)
(* We use this other fresh_label function that tries to insert at a given label *)
(* If it fails (the label is already used), it defaults to fresh_label' *)

(* The number of tries before defaulting to fresh_label' *)
Parameter fuel_fresh: nat.

(* Takes a suggested label *)
Fixpoint fresh_label_fuel (fuel:nat) (sug:label) (c:code): label :=
  match fuel with
  | O => fresh_label' c
  | S fuel' =>
    match (c!sug) with
    | None => sug
    | Some _ => fresh_label_fuel fuel' (Pos.succ sug) c
    end
  end.

Definition fresh_label (sug:label) (c:code): label :=
  fresh_label_fuel fuel_fresh sug c.

(** * Lowered Programs  *)
(* Lowered Programs do not contain the Framestate instruction anymore *)
Inductive is_fs: instruction -> Prop :=
| Is_Fs: forall tgt vm sl next,
    is_fs (Framestate tgt vm sl next).

(* Some lowered code has no Framestate instruction *)
Definition lowered_code (c:code): Prop :=
  forall (pc:label) (i:instruction), c!pc = Some i -> ~ (is_fs i).

Definition lowered_version (v:version): Prop :=
  lowered_code (ver_code v).

Definition lowered_function (f:function): Prop :=
  forall v, fn_opt f = Some v -> lowered_version v.

Definition lowered_program (p:program): Prop :=
  forall fid f, find_function fid p = Some f -> lowered_function f.

(** * Input Programs *)
(* An input program does not have any optimized version *)
Definition input_function (f:function): Prop :=
  (fn_opt f) = None.

Definition input_program (p:program): Prop :=
  forall fid f, find_function fid p = Some f -> input_function f.


From iris.base_logic Require Import invariants.
From iris_ni.logrel Require Import types interp.
From iris_ni.program_logic Require Import dwp heap_lang_lifting.
From iris.proofmode Require Import proofmode.
From iris_ni.proofmode Require Import dwp_tactics.
From iris.heap_lang Require Import lang proofmode.
From iris.algebra Require Import excl.

From iris.heap_lang.lib Require Export spin_lock.

Section proof.
  Context `{!heapDG Σ, !lockG Σ}.

  Variable N : namespace.

  Definition lock_inv (γ : gname) (l1 l2 : loc) (R : iProp Σ) : iProp Σ :=
    (∃ b : bool, l1 ↦ₗ #b ∗ l2 ↦ᵣ #b ∗
       if b then True else own γ (Excl ()) ∗ R)%I.

  Definition is_lock (γ : gname) (lk1 lk2 : val) (R : iProp Σ) : iProp Σ :=
    (∃ l1 l2: loc, ⌜lk1 = #l1⌝ ∧ ⌜lk2 = #l2⌝
        ∧ inv N (lock_inv γ l1 l2 R))%I.

  Definition locked (γ : gname) : iProp Σ := own γ (Excl ()).

  Lemma newlock_spec (R : iProp Σ) Φ :
    R -∗
    (∀ γ lk1 lk2, is_lock γ lk1 lk2 R -∗ Φ lk1 lk2) -∗
    DWP newlock #() & newlock #() : Φ.
  Proof.
    iIntros "R HΦ".
    unlock newlock. dwp_pures=>/=.
    iApply dwp_fupd.
    pose (Ψ1 := (λ v, ∃ l : loc, ⌜v = #l⌝ ∗ l ↦ₗ #false)%I).
    pose (Ψ2 := (λ v, ∃ l : loc, ⌜v = #l⌝ ∗ l ↦ᵣ #false)%I).
    iApply (dwp_atomic_lift_wp Ψ1 Ψ2).
    { rewrite /TWP1. wp_alloc l as "Hl".
      iExists l. eauto with iFrame. }
    { rewrite /TWP2. wp_alloc l as "Hl".
      iExists l. eauto with iFrame. }
    iIntros (? ?). iDestruct 1 as (l1 ->) "Hl1". iDestruct 1 as (l2 ->) "Hl2".
    iNext. iMod (own_alloc (Excl ())) as (γ) "Hγ"; first done.
    iMod (inv_alloc N _ (lock_inv γ l1 l2 R) with "[-HΦ]") as "#Hinv".
    { iIntros "!>". iExists false. by iFrame. }
    iModIntro. iApply ("HΦ" $! γ).
    iExists l1,l2. eauto with iFrame.
  Qed.

  Lemma try_acquire_spec γ lk1 lk2 R Φ :
    is_lock γ lk1 lk2 R -∗
    (∀ b : bool, (if b then locked γ ∗ R else True) -∗ Φ #b #b) -∗
    DWP try_acquire lk1 & try_acquire lk2 : Φ.
  Proof.
    iIntros "#Hlk HΦ". iDestruct "Hlk" as (l1 l2 -> ->) "#Hinv".
    unlock try_acquire. dwp_pures=>/=.
    dwp_bind (CmpXchg _ _ _) (CmpXchg _ _ _).
    iApply dwp_atomic.
    iInv N as (b) "(>Hl1 & >Hl2 & HR)" "Hcl". iModIntro.
    pose (Ψ1 := (λ v, ⌜v = (#b, #(negb b))%V⌝ ∗ l1 ↦ₗ #true)%I).
    pose (Ψ2 := (λ v, ⌜v = (#b, #(negb b))%V⌝ ∗ l2 ↦ᵣ #true)%I).
    iApply (dwp_atomic_lift_wp Ψ1 Ψ2 with "[Hl1] [Hl2] [-]").
    { rewrite /TWP1 /Ψ1. destruct b.
      by wp_cmpxchg_fail; iFrame.
      by wp_cmpxchg_suc; iFrame. }
    { rewrite /TWP2 /Ψ2. destruct b.
      by wp_cmpxchg_fail; iFrame.
      by wp_cmpxchg_suc; iFrame. }
    iIntros (? ?). iDestruct 1 as (->) "Hl1". iDestruct 1 as (->) "Hl2".
    iNext. iMod ("Hcl" with "[-HR HΦ]") as "_".
    { iNext. iExists true. by iFrame. }
    iModIntro. dwp_pures. iApply dwp_value. iModIntro.
    iApply ("HΦ" $! (negb b)).
    by destruct b.
  Qed.

  Lemma acquire_spec γ lk1 lk2 R Φ :
    is_lock γ lk1 lk2 R -∗
    (locked γ -∗ R -∗ Φ #() #()) -∗
    DWP acquire lk1 & acquire lk2 : Φ.
  Proof.
    iIntros "#Hinv HΦ".
    unlock acquire. dwp_pures=>/=. iLöb as "IH".
    dwp_bind (try_acquire _) (try_acquire _).
    iApply (try_acquire_spec with "Hinv"). iIntros ([]).
    - iIntros "[Hlked HR]". dwp_pures.
      iApply dwp_value. by iApply ("HΦ" with "Hlked HR").
    - iIntros "_". dwp_pures=>/=.
      by iApply "IH".
  Qed.

  Lemma release_spec γ lk1 lk2 R Φ :
    is_lock γ lk1 lk2 R -∗
    locked γ -∗
    R -∗
    Φ #() #() -∗
    DWP release lk1 & release lk2 : Φ.
  Proof.
    iIntros "#Hinv Hlked HR HΦ".
    rewrite/release. dwp_pures=>/=.
    iDestruct "Hinv" as (l1 l2 -> ->) "#Hinv".
    pose (Ψ1 := (λ v, ⌜v = #()⌝ ∗ l1 ↦ₗ #false)%I).
    pose (Ψ2 := (λ v, ⌜v = #()⌝ ∗ l2 ↦ᵣ #false)%I).
    iApply dwp_atomic.
    iInv N as (b) "(>Hl1 & >Hl2 & Hb)" "Hcl".
    iApply (dwp_atomic_lift_wp Ψ1 Ψ2 with "[Hl1] [Hl2] [-]").
    { rewrite /TWP1 /Ψ1. wp_store. eauto with iFrame. }
    { rewrite /TWP2 /Ψ2. wp_store. eauto with iFrame. }
    iIntros (? ?). iDestruct 1 as (->) "Hl1". iDestruct 1 as (->) "Hl2".
    iNext. iMod ("Hcl" with "[-HΦ]") as "_".
    { iNext. iExists false. by iFrame. }
    eauto with iFrame.
  Qed.

End proof.

Section semtyping.
  Context `{!heapDG Σ}.

  Lemma newlock_typed ξ :
    ⊢ DWP newlock #() & newlock #() : ⟦ tmutex ⟧ ξ.
  Proof.
    rewrite tmutex_eq.
    unlock newlock. dwp_pures=>/=.
    iApply logrel_alloc. iApply logrel_bool.
  Qed.

  Lemma acquire_typed ξ :
    ⊢ DWP acquire & acquire : ⟦ tarrow tmutex tunit Low ⟧ ξ.
  Proof.
    rewrite tmutex_eq.
    unfold acquire. dwp_pures. iApply dwp_value. iModIntro.
    rewrite interp_eq. iModIntro. iIntros (lk1 lk2) "#Hlk".
    dwp_pures. iLöb as "IH".
    rewrite {5 7}/try_acquire. dwp_pures.
    dwp_bind (CmpXchg _ _ _) (CmpXchg _ _ _).
    rewrite /tmutex (interp_eq (tref _)).
    iDestruct "Hlk" as (l1 l2 -> ->) "Hinv".
    iInv (locsN.@(l1, l2)) as (w1 w2) "(>Hl1 & >Hl2 & >Hw)".
    iDestruct "Hw" as (b b' -> ->) "%".
    assert (b = b') as <- by (destruct ξ; eauto).
    destruct b.
    - pose (Φ1 := (λ v, ⌜v = (#true, #false)%V⌝ ∧ l1 ↦ₗ #true)%I).
      pose (Φ2 := (λ v, ⌜v = (#true, #false)%V⌝ ∧ l2 ↦ᵣ #true)%I).
      iApply (dwp_atomic_lift_wp Φ1 Φ2 with "[Hl1] [Hl2] [-]"); unfold TWP1, TWP2.
      { wp_cmpxchg_fail. unfold Φ1. iFrame. eauto. }
      { wp_cmpxchg_fail. unfold Φ2. iFrame. eauto. }
      iIntros (? ?). iDestruct 1 as "[-> Hl1]". iDestruct 1 as "[-> Hl2]".
      iNext. iModIntro. iSplitL "Hl1 Hl2".
      { iNext. iExists _,_. iFrame. rewrite interp_eq.
        iExists _,_. eauto with iFrame. }
      dwp_pures. iApply "IH".
    - pose (Φ1 := (λ v, ⌜v = (#false, #true)%V⌝ ∧ l1 ↦ₗ #true)%I).
      pose (Φ2 := (λ v, ⌜v = (#false, #true)%V⌝ ∧ l2 ↦ᵣ #true)%I).
      iApply (dwp_atomic_lift_wp Φ1 Φ2 with "[Hl1] [Hl2] [-]"); unfold TWP1, TWP2.
      { wp_cmpxchg_suc. unfold Φ1. iFrame. eauto. }
      { wp_cmpxchg_suc. unfold Φ2. iFrame. eauto. }
      iIntros (? ?). iDestruct 1 as "[-> Hl1]". iDestruct 1 as "[-> Hl2]".
      iNext. iModIntro. iSplitL "Hl1 Hl2".
      { iNext. iExists _,_. iFrame. rewrite interp_eq.
        iExists _,_. eauto with iFrame. }
      dwp_pures. iApply logrel_unit.
  Qed.

  Lemma release_typed ξ :
    ⊢ DWP release & release : ⟦ tarrow tmutex tunit Low ⟧ ξ.
  Proof.
    rewrite tmutex_eq.
    unfold release. dwp_pures. iApply dwp_value. iModIntro.
    rewrite interp_eq. iModIntro. iIntros (lk1 lk2) "#Hlk".
    dwp_pures. iApply logrel_store; eauto.
    - rewrite /tmutex. iApply dwp_value. iApply "Hlk".
    - iApply logrel_bool.
  Qed.

End semtyping.


(*

  Copyright 2016 Luxembourg University
  Copyright 2017 Luxembourg University

  This file is part of Velisarios.

  Velisarios is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  Velisarios is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with Velisarios.  If not, see <http://www.gnu.org/licenses/>.

  Authors: Vincent Rahli
           Ivana Vukotic

*)

Require Export PBFTexecute4.

Section PBFTexecute5.

  Local Open Scope eo.
  Local Open Scope proc.

  Context { pbft_context : PBFTcontext      }.
  Context { pbft_auth    : PBFTauth         }.
  Context { pbft_keys    : PBFTinitial_keys }.
  Context { pbft_hash    : PBFThash         }.

  Lemma next_to_execute_from_before :
    forall (eo : EventOrdering) (ei ej : Event) (i j : Rep) (sti stj : PBFTstate),
      authenticated_messages_were_sent_or_byz_usys eo PBFTsys
      -> PBFTcorrect_keys eo
      -> PBFT_at_most_f_byz2 eo [ei,ej]
      -> loc ei = PBFTreplica i
      -> loc ej = PBFTreplica j
      -> state_sm_before_event (PBFTreplicaSM i) eo ei = Some sti
      -> state_sm_before_event (PBFTreplicaSM j) eo ej = Some stj
      -> next_to_execute sti = next_to_execute stj
      -> sm_state sti = sm_state stj /\ last_reply_state sti = last_reply_state stj.
  Proof.
    introv sendby ckeys atmost eqloc1 eqloc2 eqst1 eqst2 eqnext.
    rewrite <- ite_first_state_sm_on_event_as_before in eqst1.
    rewrite <- ite_first_state_sm_on_event_as_before in eqst2.
    unfold ite_first in *.
    destruct (dec_isFirst ei) as [d1|d1];
      destruct (dec_isFirst ej) as [d2|d2];
      ginv; subst; simpl in *; eauto 3 with pbft.

    - apply state_if_initial_next_to_execute in eqst2; auto; autorewrite with eo; auto.
      repnd; allrw; tcsp.

    - apply state_if_initial_next_to_execute in eqst1; auto; autorewrite with eo; auto.

    - eapply next_to_execute_from in eqst1; try (exact eqst2); auto;
        autorewrite with eo; tcsp; eauto 5 with pbft eo.
  Qed.

  Lemma replies_match :
    forall (eo : EventOrdering) (e1 e2 : Event) v1 v2 ts c j1 j2 r1 r2 a1 a2 i1 i2,
      authenticated_messages_were_sent_or_byz_usys eo PBFTsys
      -> PBFTcorrect_keys eo
      -> PBFT_at_most_f_byz2 eo [e1,e2]
      -> loc e1 = PBFTreplica i1
      -> loc e2 = PBFTreplica i2
      -> In (send_reply (mk_reply v1 ts c j1 r1 a1)) (output_system_on_event_ldata PBFTsys eo e1)
      -> In (send_reply (mk_reply v2 ts c j2 r2 a2)) (output_system_on_event_ldata PBFTsys eo e2)
      -> r1 = r2.
  Proof.
    introv sendbyz ckeys atmost eqloc1 eqloc2 out1 out2.

    pose proof (PBFTnever_stops eo e1 i1) as q.
    pose proof (PBFTnever_stops_on_event eo e1 i1) as h.
    pose proof (PBFTnever_stops eo e2 i2) as w.
    pose proof (PBFTnever_stops_on_event eo e2 i2) as z.
    exrepnd.

    eapply replies_from in out1; eauto.
    eapply replies_from in out2; eauto.
    exrepnd.

    subst.

    match goal with
    | [ H1 : committed_log _ _ = _, H2 : committed_log _ _ = _ |- _ ] =>
      rename H1 into com1; rename H2 into com2; dup com1 as com
    end.

    match goal with
    | [ H1 : find_first_reply _ _ _ = _, H2 : find_first_reply _ _ _ = _ |- _ ] =>
      rename H1 into ffr1; rename H2 into ffr2
    end.

    match goal with
    | [ H1 : find_last_reply_entry_corresponding_to_client _ _ = _,
             H2 : find_last_reply_entry_corresponding_to_client _ _ = _,
                  H3 : find_last_reply_entry_corresponding_to_client _ _ = _,
                       H4 : find_last_reply_entry_corresponding_to_client _ _ = _ |- _ ] =>
      rename H1 into fl1; rename H2 into fl2; rename H3 into fl3; rename H4 into fl4
    end.

    match goal with
    | [ H1 : reply2requests _ _ _ _ _ _ = _, H2 : reply2requests _ _ _ _ _ _ = _ |- _ ] =>
      rename H1 into r2rs1; rename H2 into r2rs2
    end.

    match goal with
    | [ H1 : request2info _ = _, H2 : request2info _ = _ |- _ ] =>
      rename H1 into r2i1; rename H2 into r2i2
    end.

    destruct (SeqNumDeq (next_to_execute st0) (next_to_execute st2)) as [d|d].

    {
      rewrite d in *.

      eapply PBFT_A_1_11_before in com;
        try exact com2; try (exact q0); try (exact w0); auto; eauto 3 with pbft;[].
      apply eq_digests_implies_eq_requests in com; subst.

      rewrite ffr1 in ffr2; ginv.

      pose proof (next_to_execute_from_before eo e1 e2 j1 j2 st2 st0) as u.
      repeat (autodimp u hyp);[].
      repnd.
      rewrite u0 in *.
      rewrite u in *.

      pose proof (next_to_execute_from eo e1 e2 j1 j2 st1 st) as v.
      repeat (autodimp v hyp); try (complete (allrw; tcsp));[].
      repnd.
      try rewrite v0 in *.
      try rewrite v in *.

      eapply matching_reply2requests_implies in r2rs1; try (exact r2rs2).
      repnd; subst.

      rewrite fl1 in *; ginv.
      rewrite fl2 in *; ginv.

      rewrite r2i1 in *; ginv.
      smash_pbft.
    }

    assert (seqnum2nat (next_to_execute st0) <> seqnum2nat (next_to_execute st2)) as d'.
    { intro xx; destruct d.
      destruct (next_to_execute st0), (next_to_execute st2); simpl in *; tcsp. }

    apply not_eq in d'; repndors;[|].

    {
      assert (next_to_execute st <= next_to_execute st2) as lenext by (allrw; simpl; omega).
      applydup next_to_execute_is_greater_than_one in z0; auto;[].

      rewrite <- ite_first_state_sm_on_event_as_before in q0.
      unfold ite_first in *.
      destruct (dec_isFirst e1) as [d1|d1]; ginv; subst; simpl in *;[].
      pose proof (last_reply_state_increases
                    eo (local_pred e1) j1 st2
                    (next_to_execute st)) as u.
      repeat (autodimp u hyp); autorewrite with eo; auto;
        try omega; eauto 3 with pbft;[].
      exrepnd.

      pose proof (next_to_execute_from eo e' e2 j j2 st' st) as v.
      repeat (autodimp v hyp); try (complete (allrw; auto)); eauto 4 with pbft eo;[].
      repnd.
      rewrite v in u0.

      applydup u0 in fl4.
      exrepnd.

      applydup reply2requests_implies_last_reply_state_extends in r2rs2 as ext.
      applydup ext in fl0.
      exrepnd.
      rewrite fl8 in *; ginv.

      assert (ts <= lre_timestamp e4) as lets by omega.

      autodimp fl5 hyp;[apply eq_nats_implies_eq_timestamps; omega|].
      autodimp fl9 hyp;[apply eq_nats_implies_eq_timestamps; omega|].
      autodimp out0 hyp;[apply eq_nats_implies_eq_timestamps; omega|].

      assert (lre_reply e4 = Some r1) as eqr1 by (dest_all x; try omega).

      assert (Some r1 = Some r2) as eqrs by congruence.
      ginv.
    }

    {
      assert (next_to_execute st1 <= next_to_execute st0) as lenext by (allrw; simpl; omega).
      applydup next_to_execute_is_greater_than_one in h0; auto;[].

      rewrite <- ite_first_state_sm_on_event_as_before in w0.
      unfold ite_first in *.
      destruct (dec_isFirst e2) as [d1|d1]; ginv; subst; simpl in *;[].
      pose proof (last_reply_state_increases
                    eo (local_pred e2) j2 st0
                    (next_to_execute st1)) as u.
      repeat (autodimp u hyp); autorewrite with eo; auto; try omega; eauto 3 with pbft eo;[].
      exrepnd.

      pose proof (next_to_execute_from eo e' e1 j j1 st' st1) as v.
      repeat (autodimp v hyp); try (complete (allrw; auto)); eauto 5 with pbft eo;[].
      repnd.
      rewrite v in u0.

      applydup u0 in fl2.
      exrepnd.

      applydup reply2requests_implies_last_reply_state_extends in r2rs1 as ext.
      applydup ext in fl0.
      exrepnd.
      rewrite fl8 in *; ginv.

      assert (ts <= lre_timestamp e0) as lets by omega.

      autodimp fl5 hyp;[apply eq_nats_implies_eq_timestamps; omega|].
      autodimp fl9 hyp;[apply eq_nats_implies_eq_timestamps; omega|].
      autodimp out14 hyp;[apply eq_nats_implies_eq_timestamps; omega|].

      assert (lre_reply e0 = Some r2) as eqr2 by (dest_all x; try omega).

      assert (Some r1 = Some r2) as eqrs by congruence.
      ginv.
    }
  Qed.

End PBFTexecute5.


Require Import Omega.
Require Import Bool.
Require Import RelationClasses.

Require Import sflib.
From Paco Require Import paco.

Require Import Axioms.
Require Import Basic.
Require Import DataStructure.
Require Import DenseOrder.
Require Import Language.

Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.

Set Implicit Arguments.

(** * Thread Steps in the Promising Semantics 2.1 *)

(** This file defines the thread transitions in promising semantics 2.1 (PS2.1). *)

Inductive tau T
          (step: forall (lo: Ordering.LocOrdMap)
                        (e:ThreadEvent.t) (e1 e2:T), Prop) (lo: Ordering.LocOrdMap) (e1 e2:T) : Prop :=
| tau_intro
    e
    (TSTEP: step lo e e1 e2)
    (EVENT: ThreadEvent.get_machine_event e = MachineEvent.silent)
.

Hint Constructors tau.

Inductive union E T (step: forall (lo: Ordering.LocOrdMap) (e:E) (e1 e2:T), Prop) (lo: Ordering.LocOrdMap)
          (e1 e2:T): Prop :=
| union_intro
    e
    (USTEP: step lo e e1 e2)
.
Hint Constructors union.

Module Thread.
  Section Thread.
    Variable (lang:language).

    (** ** Thread State *)
    (** The thread state contains:
        - [state]: thread-local state;
        - [local]: thread view and thread promise set;
        - [sc]: timemap for SC fence;
        - [memory]: memory in PS2.1 *)
    Structure t := mk {
      state: (Language.state lang);
      local: Local.t;
      sc: TimeMap.t;
      memory: Memory.t;
    }.

    (** ** Thread Promise Step *)
    (** It includes promise insert/lower/split, reservation and cancel step.
        The pf label marks whether such step is a promise-free step.
        For cancel step, pf = true. *)
    Inductive promise_step: forall (pf: bool) (e:ThreadEvent.t) (e1 e2:t), Prop :=
    | promise_step_intro
        st lc1 sc1 mem1
        loc from to msg kind
        lc2 mem2 pf
        (LOCAL: Local.promise_step lc1 mem1 loc from to msg lc2 mem2 kind)
        (PF: pf = orb (andb (Memory.op_kind_is_lower_concrete kind) (Message.is_released_none msg))
                      (Memory.op_kind_is_cancel kind))
        :
        promise_step pf (ThreadEvent.promise loc from to msg kind) (mk st lc1 sc1 mem1) (mk st lc2 sc1 mem2)
    .

    (** ** Thread Program Step *)
    (**  thread-local state transition +
         transistion on (thread-view, promises, timemap for SC fence, memory)  *)
    Inductive program_step (e:ThreadEvent.t) (lo: Ordering.LocOrdMap): forall (e1 e2:t), Prop :=
    | program_step_intro
        st1 lc1 sc1 mem1
        st2 lc2 sc2 mem2
        (STATE: (Language.step lang) (ThreadEvent.get_program_event e) st1 st2)
        (LOCAL: Local.program_step e lc1 sc1 mem1 lc2 sc2 mem2 lo):
        program_step e lo (mk st1 lc1 sc1 mem1) (mk st2 lc2 sc2 mem2)
    .
    Hint Constructors program_step.

    (** ** Thread step (thread transition) *)
    (** Thread step in promising semantics contains two types of steps:
        - [step_promise]: promise step;
        - [step_program]: program step that executes the instruction. *)
    Inductive step: forall (lo: Ordering.LocOrdMap) (pf: bool) (e:ThreadEvent.t) (e1 e2:t) , Prop :=
    | step_promise
        e e1 e2 lo pf
        (STEP: promise_step pf e e1 e2):
        step lo pf e e1 e2
    | step_program
        e e1 e2 lo
        (STEP: program_step e lo e1 e2):
        step lo true e e1 e2
    .
    Hint Constructors step.

    Inductive step_allpf (lo: Ordering.LocOrdMap) (e:ThreadEvent.t) (e1 e2:t) : Prop :=
    | step_nopf_intro
        pf (STEP: step lo pf e e1 e2)
    .
    Hint Constructors step_allpf.

    Definition tau_step (lo: Ordering.LocOrdMap):= tau step_allpf lo.
    Hint Unfold tau_step.

    Definition all_step (lo:Ordering.LocOrdMap) := union step_allpf lo.
    Hint Unfold all_step.

    Inductive opt_step: forall (lo: Ordering.LocOrdMap) (e:ThreadEvent.t) (e1 e2:t), Prop :=
    | step_none
        e lo:
        opt_step lo ThreadEvent.silent e e
    | step_some
        pf e e1 e2 lo
        (STEP: step lo pf e e1 e2):
        opt_step lo e e1 e2
    .
    Hint Constructors opt_step.

    Inductive opt_promise_step: forall (lo: Ordering.LocOrdMap) (e:ThreadEvent.t) (e1 e2:t), Prop :=
    | opt_promise_step_none
        lo e1:
        opt_promise_step lo ThreadEvent.silent e1 e1
    | opt_promise_step_some
        pf lo e e1 e2
        (STEP: promise_step pf e e1 e2):
        opt_promise_step lo e e1 e2
    .

    Inductive opt_program_step: forall (lo: Ordering.LocOrdMap) (e:ThreadEvent.t) (e1 e2:t), Prop :=
    | opt_program_step_none
        lo e1:
        opt_program_step lo ThreadEvent.silent e1 e1
    | opt_program_step_some
        lo e e1 e2
        (STEP: program_step e lo e1 e2):
        opt_program_step lo e e1 e2
    .

    Lemma tau_opt_tau
          e1 e2 e3 e lo
          (STEPS: rtc (tau_step lo) e1 e2)
          (STEP: opt_step lo e e2 e3)
          (EVENT: ThreadEvent.get_machine_event e = MachineEvent.silent):
      rtc (tau_step lo) e1 e3.
    Proof.
      induction STEPS.
      - inv STEP; eauto.
      - exploit IHSTEPS; eauto.
    Qed.

    Lemma tau_opt_all
          e1 e2 e3 e lo
          (STEPS: rtc (tau_step lo) e1 e2)
          (STEP: opt_step lo e e2 e3):
      rtc (all_step lo) e1 e3.
    Proof.
      induction STEPS.
      - inv STEP; eauto.
      - exploit IHSTEPS; eauto. i.
        econs 2; eauto.
        inv H. inv TSTEP. econs. econs. eauto.
    Qed.

    (** ** Consistency *)
    (** A thread state is consistent if the thread is able to fulfill
        all its promises when executed in isolation. *)
    Definition consistent (e:t) (lo: Ordering.LocOrdMap): Prop :=
      forall mem1 sc1
        (CAP: Memory.cap (memory e) mem1)
        (SC_MAX: Memory.max_concrete_timemap mem1 sc1),
        exists e2,
          <<STEPS: rtc (tau_step lo) (mk (state e) (local e) sc1 mem1) e2>> /\
          <<PROMISES: (Local.promises (local e2)) = Memory.bot>>.

    (* step_future *)
    Lemma promise_step_future
          pf e e1 e2
          (STEP: promise_step pf e e1 e2)
          (WF1: Local.wf (local e1) (memory e1))
          (SC1: Memory.closed_timemap (sc e1) (memory e1))
          (CLOSED1: Memory.closed (memory e1)):
      <<WF2: Local.wf (local e2) (memory e2)>> /\
      <<SC2: Memory.closed_timemap (sc e2) (memory e2)>> /\
      <<CLOSED2: Memory.closed (memory e2)>> /\
      <<TVIEW_FUTURE: TView.le (Local.tview (local e1)) (Local.tview (local e2))>> /\
      <<SC_FUTURE: TimeMap.le (sc e1) (sc e2)>> /\
      <<MEM_FUTURE: Memory.future (memory e1) (memory e2)>>.
    Proof.
      inv STEP. ss.
      exploit Local.promise_step_future; eauto. i. des.
      splits; eauto. 2: refl.
      eapply Memory.future_closed_timemap; eauto.
    Qed.

    Lemma program_step_future
          lo e e1 e2
          (STEP: program_step lo e e1 e2)
          (WF1: Local.wf (local e1) (memory e1))
          (SC1: Memory.closed_timemap (sc e1) (memory e1))
          (CLOSED1: Memory.closed (memory e1)):
      <<WF2: Local.wf (local e2) (memory e2)>> /\
      <<SC2: Memory.closed_timemap (sc e2) (memory e2)>> /\
      <<CLOSED2: Memory.closed (memory e2)>> /\
      <<TVIEW_FUTURE: TView.le (Local.tview (local e1)) (Local.tview (local e2))>> /\
      <<SC_FUTURE: TimeMap.le (sc e1) (sc e2)>> /\
      <<MEM_FUTURE: Memory.future (memory e1) (memory e2)>>.
    Proof.
      inv STEP. ss. eapply Local.program_step_future; eauto.
    Qed.

    Lemma step_future
          lo pf e e1 e2
          (STEP: step lo pf e e1 e2)
          (WF1: Local.wf (local e1) (memory e1))
          (SC1: Memory.closed_timemap (sc e1) (memory e1))
          (CLOSED1: Memory.closed (memory e1)):
      <<WF2: Local.wf (local e2) (memory e2)>> /\
      <<SC2: Memory.closed_timemap (sc e2) (memory e2)>> /\
      <<CLOSED2: Memory.closed (memory e2)>> /\
      <<TVIEW_FUTURE: TView.le (Local.tview (local e1)) (Local.tview (local e2))>> /\
      <<SC_FUTURE: TimeMap.le (sc e1) (sc e2)>> /\
      <<MEM_FUTURE: Memory.future (memory e1) (memory e2)>>.
    Proof.
      inv STEP.
      - eapply promise_step_future; eauto.
      - eapply program_step_future; eauto.
    Qed.

    Lemma opt_step_future
          lo e e1 e2
          (STEP: opt_step lo e e1 e2)
          (WF1: Local.wf (local e1) (memory e1))
          (SC1: Memory.closed_timemap (sc e1) (memory e1))
          (CLOSED1: Memory.closed (memory e1)):
      <<WF2: Local.wf (local e2) (memory e2)>> /\
      <<SC2: Memory.closed_timemap (sc e2) (memory e2)>> /\
      <<CLOSED2: Memory.closed (memory e2)>> /\
      <<TVIEW_FUTURE: TView.le (Local.tview (local e1)) (Local.tview (local e2))>> /\
      <<SC_FUTURE: TimeMap.le (sc e1) (sc e2)>> /\
      <<MEM_FUTURE: Memory.future (memory e1) (memory e2)>>.
    Proof.
      inv STEP.
      - esplits; eauto; refl.
      - eapply step_future; eauto.
    Qed.

    Lemma rtc_all_step_future
          e1 e2 lo
          (STEP: rtc (all_step lo) e1 e2)
          (WF1: Local.wf (local e1) (memory e1))
          (SC1: Memory.closed_timemap (sc e1) (memory e1))
          (CLOSED1: Memory.closed (memory e1)):
      <<WF2: Local.wf (local e2) (memory e2)>> /\
      <<SC2: Memory.closed_timemap (sc e2) (memory e2)>> /\
      <<CLOSED2: Memory.closed (memory e2)>> /\
      <<TVIEW_FUTURE: TView.le (Local.tview (local e1)) (Local.tview (local e2))>> /\
      <<SC_FUTURE: TimeMap.le (sc e1) (sc e2)>> /\
      <<MEM_FUTURE: Memory.future (memory e1) (memory e2)>>.
    Proof.
      revert WF1. induction STEP.
      - i. splits; ss; refl.
      - i. inv H. inv USTEP.
        exploit step_future; eauto. i. des.
        exploit IHSTEP; eauto. i. des.
        splits; ss; etrans; eauto.
    Qed.

    Lemma rtc_tau_step_future
          e1 e2 lo
          (STEP: rtc (tau_step lo) e1 e2)
          (WF1: Local.wf (local e1) (memory e1))
          (SC1: Memory.closed_timemap (sc e1) (memory e1))
          (CLOSED1: Memory.closed (memory e1)):
      <<WF2: Local.wf (local e2) (memory e2)>> /\
      <<SC2: Memory.closed_timemap (sc e2) (memory e2)>> /\
      <<CLOSED2: Memory.closed (memory e2)>> /\
      <<TVIEW_FUTURE: TView.le (Local.tview (local e1)) (Local.tview (local e2))>> /\
      <<SC_FUTURE: TimeMap.le (sc e1) (sc e2)>> /\
      <<MEM_FUTURE: Memory.future (memory e1) (memory e2)>>.
    Proof.
      eapply rtc_all_step_future; eauto.
      eapply rtc_implies; [|eauto].
      intros.
      inv H; econstructor; eauto.
    Qed.

    (* step_inhabited *)
    Lemma promise_step_inhabited
          pf e e1 e2
          (STEP: promise_step pf e e1 e2)
          (INHABITED1: Memory.inhabited (memory e1)):
      <<INHABITED2: Memory.inhabited (memory e2)>>.
    Proof.
      inv STEP. ss.
      eapply Local.promise_step_inhabited; eauto.
    Qed.

    Lemma program_step_inhabited
          lo e e1 e2
          (STEP: program_step lo e e1 e2)
          (INHABITED1: Memory.inhabited (memory e1)):
      <<INHABITED2: Memory.inhabited (memory e2)>>.
    Proof.
      inv STEP. ss.
      eapply Local.program_step_inhabited; eauto.
    Qed.

    Lemma step_inhabited
          pf lo e e1 e2
          (STEP: step lo pf e e1 e2)
          (INHABITED1: Memory.inhabited (memory e1)):
      <<INHABITED2: Memory.inhabited (memory e2)>>.
    Proof.
      inv STEP.
      - eapply promise_step_inhabited; eauto.
      - eapply program_step_inhabited; eauto.
    Qed.

    Inductive reserve_step (lo: Ordering.LocOrdMap) (e1 e2:t) : Prop :=
    | reserve_step_intro
        loc pf from to
        (STEP: promise_step pf (ThreadEvent.promise loc from to Message.reserve Memory.op_kind_add) e1 e2)
    .
    Hint Constructors reserve_step.

    Inductive cancel_step (lo: Ordering.LocOrdMap) (e1 e2:t): Prop :=
    | cancel_step_intro
        loc pf from to
        (STEP: promise_step pf (ThreadEvent.promise loc from to Message.reserve Memory.op_kind_cancel) e1 e2)
    .
    Hint Constructors cancel_step.

    (** ** Non-atomic Step *)
    (** It corresponds to (NA) in Figure 10 in paper and includes:
        + non-atomic memory read;
        + non-atomic memory write;
        + silent step that does not do memory accesses. *)
    Inductive na_step (lo: Ordering.LocOrdMap) (e1 e2:t) : Prop :=
    | na_plain_read_step_intro
      loc ts v R
      (STEP: program_step (ThreadEvent.read loc ts v R Ordering.plain) lo e1 e2)
    | na_plain_write_step_intro
      loc from to v R
      (STEP: program_step (ThreadEvent.write loc from to v R Ordering.plain) lo e1 e2)
    | na_tau_step_intro
      (STEP: program_step ThreadEvent.silent lo e1 e2)
    .

    (** NA step with location written *)
    (* set of locations written *)
    Definition WriteLoc := IdentSet.t.
    Definition wloc_empty : WriteLoc := IdentSet.empty.

    Lemma wloc_union_empty:
      IdentSet.union IdentSet.empty IdentSet.empty = IdentSet.empty.
    Proof.
      eapply IdentSet.Self.eq_leibniz. ii. split; ii.
      - eapply IdentSet.union_spec in H. des; eauto.
      - eapply IdentSet.union_spec. eauto.
    Qed.

    (* na step with location written *)
    Inductive na_step_wloc: forall (lo: Ordering.LocOrdMap) (wloc: WriteLoc) (e1 e2: t), Prop :=
    | na_read_step_wloc_intro
        lo e1 e2 loc ts v R
        (STEP: program_step (ThreadEvent.read loc ts v R Ordering.plain) lo e1 e2):
        na_step_wloc lo IdentSet.empty e1 e2
    | na_write_step_wloc_intro
        lo e1 e2 loc from to v R
        (STEP: program_step (ThreadEvent.write loc from to v R Ordering.plain) lo e1 e2):
        na_step_wloc lo (IdentSet.singleton loc) e1 e2
    | na_tau_step_wloc_intro
        lo e1 e2
        (STEP: program_step ThreadEvent.silent lo e1 e2):
        na_step_wloc lo IdentSet.empty e1 e2.

    (* na steps with locations writen *)
    Inductive na_steps_wloc: forall (lo: Ordering.LocOrdMap) (wloc: WriteLoc) (e1 e2: t), Prop :=
    | nil_na_steps_wloc
        lo e:
        na_steps_wloc lo IdentSet.empty e e
    | plus_na_steps_wloc
        lo  e1 e2 e3 wloc1 wloc2
        (STEP: na_step_wloc lo wloc1 e1 e2)
        (STEPS: na_steps_wloc lo wloc2 e2 e3):
        na_steps_wloc lo (IdentSet.union wloc1 wloc2) e1 e3.

     (** ** PRC Step *)
    (** It corresponds to (PRC) in Figure 10 in paper.
        In Coq formalization, the promise, reservation and cancel steps are
        all called [promise_step]. *)
    Inductive prc_step (lo: Ordering.LocOrdMap) (e1 e2: t): Prop :=
    | prc_step_intro
        pf loc from to msg kind
        (PRC: promise_step pf (ThreadEvent.promise loc from to msg kind) e1 e2).

    Inductive out_step (lo: Ordering.LocOrdMap) (e: Event.t) (e1 e2: t): Prop :=
    | out_step_intro
      e
      (OUT: program_step (ThreadEvent.syscall e) lo e1 e2)
    .

    Inductive at_read_step (lo: Ordering.LocOrdMap) (e1 e2: t) : Prop :=
    | at_read_step_intro
        loc ts v R o
        (STEP: program_step (ThreadEvent.read loc ts v R o) lo e1 e2)
        (AT: Ordering.le Ordering.relaxed o).

    Inductive at_write_step (lo: Ordering.LocOrdMap) (e1 e2: t) : Prop :=
    | at_write_step_intro
       loc from to v R o
       (STEP: program_step (ThreadEvent.write loc from to v R o) lo e1 e2)
       (AT: Ordering.le Ordering.relaxed o).

    Inductive rmw_step (lo: Ordering.LocOrdMap) (e1 e2: t) : Prop :=
    | rmw_step_intro
        loc from to v1 v2 R1 R2 o1 o2
        (STEP: program_step (ThreadEvent.update loc from to v1 v2 R1 R2 o1 o2) lo e1 e2).

    Inductive fence_step (lo: Ordering.LocOrdMap) (e1 e2: t) : Prop :=
    | fence_step_intro
        o1 o2
        (STEP: program_step (ThreadEvent.fence o1 o2) lo e1 e2).

    (** ** Atomic Step *)
    (** It corresponds to (AT) in Figure 10 in paper. *)
    Inductive at_step (lo: Ordering.LocOrdMap) (e1 e2:t) : Prop :=
    | at_step_intro
        (AT_STEP: at_read_step lo e1 e2 \/ at_write_step lo e1 e2 \/
                  rmw_step lo e1 e2 \/ fence_step lo e1 e2).

    Inductive pf_promise_step (e1 e2: t): Prop :=
    | pf_promise_step_intro
        e
        (PF_STEP: promise_step true e e1 e2).

    Definition atmblk_step (lo: Ordering.LocOrdMap) (e1 e2: t): Prop :=
      exists e' e'',
      <<NA_STEPS: rtc (@na_step lo) e1 e'>> /\
      <<AT_STEP: at_step lo e' e''>> /\
      <<PRC_STEPS: rtc (@prc_step lo) e'' e2>>.

    (** ** Thread Done *)
    (** A thread is done, iff. terminal + promise empty. *)
    Definition is_done (e:t) : Prop :=
      <<TERMINAL: Language.is_terminal lang (state e)>> /\
      <<PROMISES: (Local.promises (local e)) = Memory.bot>>.

    (** ** Thread Abort *)
    (** A thread abort, iff. the next thread-local state does not exist,
        or accessing the atomic location via non-atomic memory accesses,
        or accessing the non-atomic location via atomic memory accesses. *)
    Definition is_abort (e1 :t) (lo: Ordering.LocOrdMap): Prop :=
      <<PROMISES: Local.promise_consistent (local e1)>> /\
      <<ABORT: ~((exists e st2, (Language.step lang) e (state e1) st2) \/
                 Language.is_terminal lang (state e1)) \/
               (exists st2 x o v, ((Language.step lang) (ProgramEvent.read x v o) (state e1) st2
                     \/ (Language.step lang) (ProgramEvent.write x v o) (state e1) st2)
                            /\ ~ Ordering.mem_ord_match o (lo x)) \/
                            (exists st2 x vr vw or ow, (Language.step lang) (ProgramEvent.update x vr vw or ow) (state e1) st2 /\ lo x = Ordering.nonatomic)>>.

    Inductive nprm_step (lo: Ordering.LocOrdMap) (e1 e2: t): Prop :=
    | nprm_step_program_step
        e
        (PROG: program_step e lo e1 e2)
        (TAU: ThreadEvent.get_machine_event e = MachineEvent.silent)
    | nprm_step_pf_step
        e
        (PF: promise_step true e e1 e2).

    Definition consistent_nprm (e:t) (lo: Ordering.LocOrdMap): Prop :=
      forall mem1 sc1
        (CAP: Memory.cap (memory e) mem1)
        (SC_MAX: Memory.max_concrete_timemap mem1 sc1),
        exists e2,
          <<STEPS: rtc (nprm_step lo) (mk (state e) (local e) sc1 mem1) e2>> /\
                   <<PROMISES: (Local.promises (local e2)) = Memory.bot>>.
    Definition not_rsv_ccl_scfence (e: ThreadEvent.t) :=
      match e with
      | ThreadEvent.syscall _ => false
      | ThreadEvent.fence _ Ordering.seqcst => false
      | ThreadEvent.promise _ _ _ _ Memory.op_kind_cancel => false
      | ThreadEvent.promise _ _ _ Message.reserve Memory.op_kind_add => false
      | _ => true
      end.

    End Thread.

  Lemma na_write_on_atomic_loc_is_abort
        lang st lc sc mem lo st' val loc
        (NA_WRITE: Language.step lang (ProgramEvent.write loc val Ordering.plain) st st')
        (AT_LOC: lo loc = Ordering.atomic)
        (PROM_CONS: Local.promise_consistent lc):
    Thread.is_abort (Thread.mk lang st lc sc mem) lo.
  Proof.
    econs; eauto.
    right; ss. left.
    do 4 eexists.
    split; eauto.
    ii.
    rewrite AT_LOC in H. ss.
    des; ss.
  Qed.

  Lemma pf_promise_step_tview_unchange
        lang (e e': Thread.t lang)
        (PF: @Thread.pf_promise_step lang e e'):
    Local.tview (Thread.local e) = Local.tview (Thread.local e').
  Proof.
    inv PF. inv PF_STEP; ss.
    inv LOCAL; ss; eauto.
  Qed.

  Lemma pf_promise_steps_tview_unchange
        lang (e e': Thread.t lang)
        (PF: rtc (@Thread.pf_promise_step lang) e e'):
    Local.tview (Thread.local e) = Local.tview (Thread.local e').
  Proof.
    induction PF; ss; eauto.
    eapply pf_promise_step_tview_unchange in H.
    rewrite <- IHPF. rewrite H. eauto.
  Qed.
End Thread.


Require Import Coq.Lists.List.
Require Import coqutil.Map.Interface coqutil.Map.Properties.
Require Import coqutil.Tactics.Tactics.
Require Import riscv.Spec.Machine.
Require Import riscv.Utility.Monads.
Require Import riscv.Spec.Decode.
Require Import riscv.Utility.Utility.
Require Import riscv.Spec.Primitives.
Require Import riscv.Platform.RiscvMachine.
Require Import riscv.Platform.Run.

Import ListNotations.

Section Sane.

  Context {width: Z} {BW: Bitwidth width} {word: word width} {word_ok: word.ok word}.
  Context {Registers: map.map Register word}.
  Context {mem: map.map word byte}.
  Context {M: Type -> Type}.
  Context {MM: Monad M}.
  Context {RVM: RiscvProgram M word}.
  Context {PRParams: PrimitivesParams M RiscvMachine}.
  Context {mcomp_sat_ok: mcomp_sat_spec PRParams}.

  Lemma mcomp_sat_weaken: forall A initialL m (post1 post2: A -> RiscvMachine -> Prop),
      (forall a mach, post1 a mach -> post2 a mach) ->
      mcomp_sat m initialL post1 ->
      mcomp_sat m initialL post2.
  Proof.
    intros.
    rewrite <- (@right_identity M MM A m).
    eapply spec_Bind.
    eexists. split.
    - exact H0.
    - intros. simpl in *. apply spec_Return. eapply H. assumption.
  Qed.

  Lemma Return_sane: forall {A: Type} (a: A),
      mcomp_sane (Return a).
  Proof.
    unfold mcomp_sane.
    intros. eapply spec_Return in H0.
    split.
    - eauto.
    - eapply (proj1 (spec_Return _ _ _)).
      ssplit.
      + assumption.
      + exists nil. reflexivity.
      + assumption.
  Qed.

  Lemma Bind_sane: forall {A B: Type} (m: M A) (f: A -> M B),
      mcomp_sane m ->
      (forall a, mcomp_sane (f a)) ->
      mcomp_sane (Bind m f).
  Proof.
    intros *.
    intros S1 S2.
    unfold mcomp_sane in *.
    intros.
    eapply (proj2 (spec_Bind _ _ _ _)) in H0.
    destruct H0 as (mid & C1 & C2).
    split.
    - specialize S1 with (1 := H) (2 := C1). destruct S1 as ((a & middle & S1a & S1b) & S1c).
      specialize C2 with (1 := S1a).
      specialize S2 with (1 := S1b) (2 := C2). destruct S2 as ((b & final & S2a) & S2b).
      eauto.
    - eapply spec_Bind.
      exists (fun a middle => (mid a middle /\
                               exists diff1, getLog middle = diff1 ++ getLog st) /\
                              valid_machine middle).
      split.
      + specialize S1 with (1 := H) (2 := C1). destruct S1 as ((a & middle & S1a & S1b) & S1c).
        exact S1c.
      + intros. destruct H0 as ((HM & (diff1 & E1)) & V1).
        specialize C2 with (1 := HM).
        specialize S2 with (1 := V1) (2 := C2). destruct S2 as ((b & final & S2a & S2b) & S2c).
        eapply mcomp_sat_weaken; [|exact S2c].
        simpl. intros. destruct H0 as ((? & (diff2 & E2)) & V2).
        split; [|assumption].
        split; [assumption|].
        rewrite E1 in E2.
        rewrite List.app_assoc in E2.
        eexists. exact E2.
  Qed.

End Sane.


Require Import VST.progs.conclib.
Require Import VST.progs.ghosts.
Require Import VST.progs.incr.

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition acquire_spec := DECLARE _acquire acquire_spec.
Definition release_spec := DECLARE _release release_spec.
Definition makelock_spec := DECLARE _makelock (makelock_spec _).
Definition freelock_spec := DECLARE _freelock (freelock_spec _).
Definition spawn_spec := DECLARE _spawn spawn_spec.
Definition freelock2_spec := DECLARE _freelock2 (freelock2_spec _).
Definition release2_spec := DECLARE _release2 release2_spec.

Definition cptr_lock_inv g1 g2 ctr := EX z : Z, data_at Ews tuint (Vint (Int.repr z)) ctr *
  EX x : Z, EX y : Z, !!(z = x + y) && ghost_var gsh1 x g1 * ghost_var gsh1 y g2.

Definition incr_spec :=
 DECLARE _incr
  WITH sh : share, g1 : gname, g2 : gname, left : bool, n : Z, gv: globals
  PRE [ ]
         PROP  (readable_share sh)
         LOCAL (gvars gv)
         SEP   (lock_inv sh (gv _ctr_lock) (cptr_lock_inv g1 g2 (gv _ctr)); ghost_var gsh2 n (if left then g1 else g2))
  POST [ tvoid ]
         PROP ()
         LOCAL ()
         SEP (lock_inv sh (gv _ctr_lock) (cptr_lock_inv g1 g2 (gv _ctr)); ghost_var gsh2 (n+1) (if left then g1 else g2)).

Definition read_spec :=
 DECLARE _read
  WITH sh : share, g1 : gname, g2 : gname, n1 : Z, n2 : Z, gv: globals
  PRE [ ]
         PROP  (readable_share sh)
         LOCAL (gvars gv)
         SEP   (lock_inv sh (gv _ctr_lock) (cptr_lock_inv g1 g2 (gv _ctr)); ghost_var gsh2 n1 g1; ghost_var gsh2 n2 g2)
  POST [ tuint ]
         PROP ()
         LOCAL (temp ret_temp (Vint (Int.repr (n1 + n2))))
         SEP (lock_inv sh (gv _ctr_lock) (cptr_lock_inv g1 g2 (gv _ctr)); ghost_var gsh2 n1 g1; ghost_var gsh2 n2 g2).

Definition thread_lock_R sh g1 g2 ctr lockc :=
  lock_inv sh lockc (cptr_lock_inv g1 g2 ctr) * ghost_var gsh2 1 g1.

Definition thread_lock_inv sh g1 g2 ctr lockc lockt :=
  selflock (thread_lock_R sh g1 g2 ctr lockc) sh lockt.

Definition thread_func_spec :=
 DECLARE _thread_func
  WITH y : val, x : share * gname * gname * globals
  PRE [ _args OF (tptr tvoid) ]
         let '(sh, g1, g2, gv) := x in
         PROP  (readable_share sh)
         LOCAL (temp _args y; gvars gv)
         SEP   (lock_inv sh (gv _ctr_lock) (cptr_lock_inv g1 g2 (gv _ctr));
                ghost_var gsh2 0 g1;
                lock_inv sh (gv _thread_lock) (thread_lock_inv sh g1 g2 (gv _ctr) (gv _ctr_lock) (gv _thread_lock)))
  POST [ tptr tvoid ]
         PROP ()
         LOCAL ()
         SEP ().

Definition main_spec :=
 DECLARE _main
  WITH gv : globals
  PRE  [] main_pre prog nil gv
  POST [ tint ] main_post prog nil gv.

Definition Gprog : funspecs :=   ltac:(with_library prog [acquire_spec; release_spec; release2_spec; makelock_spec;
  freelock_spec; freelock2_spec; spawn_spec; incr_spec; read_spec; thread_func_spec; main_spec]).

Lemma ctr_inv_exclusive : forall g1 g2 p,
  exclusive_mpred (cptr_lock_inv g1 g2 p).
Proof.
  intros; unfold cptr_lock_inv.
  eapply derives_exclusive, exclusive_sepcon1 with (Q := EX x : Z, EX y : Z, _),
    data_at__exclusive with (sh := Ews)(t := tuint); auto; simpl; try omega.
  Intro z; apply sepcon_derives; [cancel|].
  Intros x y; Exists x y; apply derives_refl.
Qed.
Hint Resolve ctr_inv_exclusive.

Lemma thread_inv_exclusive : forall sh g1 g2 ctr lock lockt,
  exclusive_mpred (thread_lock_inv sh g1 g2 ctr lock lockt).
Proof.
  intros; apply selflock_exclusive.
  unfold thread_lock_R.
  apply exclusive_sepcon1; auto.
Qed.
Hint Resolve thread_inv_exclusive.

Lemma body_incr: semax_body Vprog Gprog f_incr incr_spec.
Proof.
  start_function.
  forward.
  forward_call (gv _ctr_lock, sh, cptr_lock_inv g1 g2 (gv _ctr)).
  unfold cptr_lock_inv at 2; simpl.
  Intros z x y.
  forward.
  forward.
  gather_SEP 2 3 4.
  viewshift_SEP 0 (!!((if left then x else y) = n) && ghost_var Tsh (n+1) (if left then g1 else g2) *
    ghost_var gsh1 (if left then y else x) (if left then g2 else g1)).
  { go_lower.
    destruct left.
    - rewrite (sepcon_comm _ (ghost_var _ _ _)), <- sepcon_assoc.
      erewrite ghost_var_share_join' by eauto.
      Intros; rewrite prop_true_andp by auto; eapply derives_trans, bupd_frame_r; cancel.
      apply ghost_var_update.
    - erewrite ghost_var_share_join' by eauto.
      Intros; rewrite prop_true_andp by auto; eapply derives_trans, bupd_frame_r; cancel.
      apply ghost_var_update. }
  Intros; forward_call (gv _ctr_lock, sh, cptr_lock_inv g1 g2 (gv _ctr)).
  { lock_props.
    unfold cptr_lock_inv; Exists (z + 1).
    erewrite <- ghost_var_share_join by eauto.
    unfold Frame; instantiate (1 := [ghost_var gsh2 (n+1) (if left then g1 else g2)]); simpl.
    destruct left.
    - Exists (n+1) y; entailer!.
    - Exists x (n+1); entailer!. }
  forward.
Qed.

Lemma body_read : semax_body Vprog Gprog f_read read_spec.
Proof.
  start_function.
  forward_call (gv _ctr_lock, sh, cptr_lock_inv g1 g2 (gv _ctr)).
  unfold cptr_lock_inv at 2; simpl.
  Intros z x y.
  forward.
  assert_PROP (x = n1 /\ y = n2) as Heq.
  { gather_SEP 2 4.
    erewrite ghost_var_share_join' by eauto.
    gather_SEP 3 4.
    erewrite ghost_var_share_join' by eauto.
    entailer!. }
  forward_call (gv _ctr_lock, sh, cptr_lock_inv g1 g2 (gv _ctr)).
  { lock_props.
    unfold cptr_lock_inv; Exists z x y; entailer!. }
  destruct Heq; forward.
Qed.

Lemma body_thread_func : semax_body Vprog Gprog f_thread_func thread_func_spec.
Proof.
  start_function.
  Intros.
  forward.
  forward_call (sh, g1, g2, true, 0, gv).
  simpl.
  forward_call ((gv _thread_lock), sh, thread_lock_R sh g1 g2 (gv _ctr) (gv _ctr_lock), thread_lock_inv sh g1 g2 (gv _ctr) (gv _ctr_lock) (gv _thread_lock)).
  { lock_props.
    unfold thread_lock_inv, thread_lock_R.
    rewrite selflock_eq at 2; cancel. }
  forward.
Qed.

Ltac cancel_for_forward_call ::=
  match goal with
  | gv: globals |- _ =>
    repeat
    match goal with
    | x := gv ?i |- context [gv ?i] =>
        change (gv i) with x
    end
  | _ => idtac
  end;
  cancel_for_evar_frame.

Lemma body_main:  semax_body Vprog Gprog f_main main_spec.
Proof.
  start_function.
  set (ctr := gv _ctr); set (lockt := gv _thread_lock); set (lock := gv _ctr_lock).
  forward.
  forward.
  forward.
  ghost_alloc (ghost_var Tsh 0).
  Intro g1.
  ghost_alloc (ghost_var Tsh 0).
  Intro g2.
  forward_call (lock, Ews, cptr_lock_inv g1 g2 ctr).
  forward_call (lock, Ews, cptr_lock_inv g1 g2 ctr).
  { lock_props.
    rewrite <- !(ghost_var_share_join gsh1 gsh2 Tsh) by auto.
    unfold cptr_lock_inv; Exists 0 0 0; entailer!. }
  (* need to split off shares for the locks here *)
  destruct split_Ews as (sh1 & sh2 & ? & ? & Hsh).
  forward_call (lockt, Ews, thread_lock_inv sh1 g1 g2 ctr lock lockt).
  forward_spawn _thread_func nullval (sh1, g1, g2, gv).
  { erewrite <- lock_inv_share_join; try apply Hsh; auto.
    erewrite <- (lock_inv_share_join _ _ Ews); try apply Hsh; auto.
    entailer!. }
  forward_call (sh2, g1, g2, false, 0, gv).
  simpl.
  forward_call (lockt, sh2, thread_lock_inv sh1 g1 g2 ctr lock lockt).
  unfold thread_lock_inv at 2; unfold thread_lock_R.
  rewrite selflock_eq.
  Intros.
  forward_call (sh2, g1, g2, 1, 1, gv).
  (* We've proved that t is 2! *)
  forward_call (lock, sh2, cptr_lock_inv g1 g2 ctr).
  forward_call (lockt, Ews, sh1, thread_lock_R sh1 g1 g2 ctr lock, thread_lock_inv sh1 g1 g2 ctr lock lockt).
  { lock_props.
    unfold thread_lock_inv, thread_lock_R.
    erewrite <- (lock_inv_share_join _ _ Ews); try apply Hsh; auto; cancel. }
  forward_call (lock, Ews, cptr_lock_inv g1 g2 ctr).
  { lock_props.
    erewrite <- (lock_inv_share_join _ _ Ews); try apply Hsh; auto; cancel. }
  forward.
Qed.

Definition extlink := ext_link_prog prog.

Definition Espec := add_funspecs (Concurrent_Espec unit _ extlink) extlink Gprog.
Existing Instance Espec.

Lemma prog_correct:
  semax_prog prog Vprog Gprog.
Proof.
prove_semax_prog.
repeat (apply semax_func_cons_ext_vacuous; [reflexivity | reflexivity | ]).
semax_func_cons_ext.
semax_func_cons_ext.
semax_func_cons_ext.
semax_func_cons_ext.
semax_func_cons_ext.
semax_func_cons_ext.
semax_func_cons_ext.
semax_func_cons body_incr.
semax_func_cons body_read.
semax_func_cons body_thread_func.
semax_func_cons body_main.
Qed.


Require Import PArith Arith.
From hahn Require Import Hahn.
Require Import PromisingLib.
From Promising2 Require Import Configuration TView View Time Event Cell Thread Memory Local.
From imm Require Import Events.
From imm Require Import Execution.
From imm Require Import Execution_eco.
From imm Require Import imm_s_hb.
From imm Require Import imm_s.
From imm Require Import imm_bob imm_s_ppo.
From imm Require Import CombRelations.
From imm Require Import CombRelationsMore.
From imm Require Import ProgToExecution.

From imm Require Import TraversalConfig.
Require Import ExtTraversalConfig.
Require Import ExtTraversal.
Require Import MaxValue.
Require Import ViewRel.
From imm Require Import ViewRelHelpers.
Require Import SimulationRel.
Require Import SimulationPlainStepAux.
Require Import PlainStepBasic.
Require Import SimState.
Require Import SimStateHelper.
Require Import PromiseLTS.
Require Import MemoryAux.
Require Import FtoCoherent.
From imm Require Import AuxRel2.
Require Import ExistsIssueReservedInterval.
Require Import IssueReservedStepHelper.
Require Import MemoryClosedness.
Require Import SimulationRelProperties.
Require Import ReadPlainStepHelper.

Set Implicit Arguments.

Section IssueReservedRelPlainStep.

Variable G : execution.
Variable WF : Wf G.
Variable sc : relation actid.
Variable CON : imm_consistent G sc.

Notation "'E'" := G.(acts_set).
Notation "'sb'" := G.(sb).
Notation "'rf'" := G.(rf).
Notation "'co'" := G.(co).
Notation "'rmw'" := G.(rmw).
Notation "'data'" := G.(data).
Notation "'addr'" := G.(addr).
Notation "'ctrl'" := G.(ctrl).

Notation "'fr'" := G.(fr).
Notation "'coe'" := G.(coe).
Notation "'coi'" := G.(coi).
Notation "'deps'" := G.(deps).
Notation "'rfi'" := G.(rfi).
Notation "'rfe'" := G.(rfe).
Notation "'detour'" := G.(detour).
Notation "'hb'" := G.(hb).
Notation "'sw'" := G.(sw).

Notation "'lab'" := G.(lab).

Notation "'R'" := (fun a => is_true (is_r lab a)).
Notation "'W'" := (fun a => is_true (is_w lab a)).
Notation "'F'" := (fun a => is_true (is_f lab a)).
Notation "'RW'" := (R ∪₁ W).
Notation "'FR'" := (F ∪₁ R).
Notation "'FW'" := (F ∪₁ W).

Notation "'Pln'" := (fun a => is_true (is_only_pln lab a)).
Notation "'Rlx'" := (fun a => is_true (is_rlx lab a)).
Notation "'Rel'" := (fun a => is_true (is_rel lab a)).
Notation "'Acq'" := (fun a => is_true (is_acq lab a)).
Notation "'Acqrel'" := (fun a => is_true (is_acqrel lab a)).
Notation "'Acq/Rel'" := (fun a => is_true (is_ra lab a)).
Notation "'Sc'" := (fun a => is_true (is_sc lab a)).

Notation "'Loc_' l" := (fun x => loc lab x = Some l) (at level 1).
Notation "'W_ex'" := G.(W_ex).
Notation "'W_ex_acq'" := (W_ex ∩₁ (fun a => is_true (is_xacq lab a))).

Lemma issue_rel_reserved_step_no_next PC T (S : actid -> Prop) f_to f_from thread r w smode
      (TID : tid r = thread)
      (REL : Rel w) (RMW : rmw r w)
      (SW : S w)
      (NONEXT : dom_sb_S_rfrmw G (mkETC T S) rfi (eq w) ⊆₁ ∅)

      (TSTEP1 : ext_itrav_step
                 G sc r (mkETC T S)
                 (mkETC (mkTC (covered T ∪₁ eq r) (issued T)) S))
      (TSTEP2 : ext_itrav_step
                  G sc w (mkETC (mkTC (covered T ∪₁ eq r) (issued T)) S)
                  (mkETC
                     (mkTC (covered T ∪₁ eq r) (issued T ∪₁ eq w))
                     (S ∪₁ eq w ∪₁ dom_sb_S_rfrmw G (mkETC T S) rfi (eq w))))

      (TSTEP3 : ext_itrav_step
                  G sc w
                  (mkETC
                     (mkTC (covered T ∪₁ eq r) (issued T ∪₁ eq w))
                     (S ∪₁ eq w ∪₁ dom_sb_S_rfrmw G (mkETC T S) rfi (eq w)))
                  (mkETC
                     (mkTC (covered T ∪₁ eq r ∪₁ eq w) (issued T ∪₁ eq w))
                     (S ∪₁ eq w ∪₁ dom_sb_S_rfrmw G (mkETC T S) rfi (eq w))))

      (SIMREL_THREAD : simrel_thread G sc PC T S f_to f_from thread smode) :

  let T' := mkTC (covered T ∪₁ eq r ∪₁ eq w) (issued T ∪₁ eq w) in
  let S' := S ∪₁ eq w ∪₁ dom_sb_S_rfrmw G (mkETC T S) rfi (eq w) in
  exists f_to' PC',
    ⟪ PCSTEP : (plain_step MachineEvent.silent thread)⁺ PC PC' ⟫ /\
    ⟪ SIMREL_THREAD : simrel_thread G sc PC' T' S' f_to' f_from thread smode ⟫ /\
    ⟪ SIMREL :
        smode = sim_normal -> simrel G sc PC T S f_to f_from ->
        simrel G sc PC' T' S' f_to' f_from ⟫.
Proof using WF CON.
  cdes SIMREL_THREAD. cdes COMMON. cdes LOCAL.

  assert (coherence G) as COH by apply CON.
  assert (wf_sc G sc) as WF_sc by apply CON.
  assert (coh_sc G sc) as COH_sc by apply CON.

  assert (NEXT : next G (covered T) r).
  { eapply ext_itrav_step_cov_next with (T:=mkETC T S); eauto. }

  assert (WTID : thread = tid w).
  { rewrite <- TID. by apply WF.(wf_rmwt). }
  assert (ISS : ~ issued T w).
  { cdes TSTEP2. desf. unfold ecovered, eissued in *; simpls.
    intros HH. apply NCOV. apply COVEQ. clear. basic_solver. }

  assert (S ⊆₁ E ∩₁ W) as SEW.
  { generalize TCCOH.(etc_S_in_E). generalize (reservedW WF TCCOH). clear. basic_solver. }

  assert (sc_per_loc G) as SC_PER_LOC.
  { by apply coherence_sc_per_loc; cdes CON. }
  assert (tc_coherent G sc T) as TCCOHs.
  { apply TCCOH. }

  assert (~ covered T r) as RNCOV.
  { apply NEXT. }

  cdes STATE. rewrite <- TID in *.
  edestruct sim_state_to_events as [ev HH]; eauto.
  desc.

  apply clos_rt_rt1n in ESTEPS.
  eapply (rtc_lang_tau_step_rtc_thread_tau_step
            _ _ _ local PC.(Configuration.sc) PC.(Configuration.memory)) in ESTEPS.

  assert (E r /\ E w) as [RACT WACT].
  { apply (wf_rmwE WF) in RMW.
    apply seq_eqv_l in RMW; destruct RMW as [WW RMW].
    apply seq_eqv_r in RMW; desf. }

  assert (R r /\ W w) as [RREAD WWRITE].
  { apply (wf_rmwD WF) in RMW.
    apply seq_eqv_l in RMW; destruct RMW as [WW RMW].
    apply seq_eqv_r in RMW; desf. }

  assert (exists w', rf w' r) as [w' RF].
  { by cdes CON; eapply Comp; split. }

  assert (exists xrmw locr valr ordr, lab r = Aload xrmw ordr locr valr) as PARAMS; desf.
  { unfold is_r in RREAD.
    destruct (lab r); desf.
      by exists ex; exists l; exists v; exists o. }
  assert (exists xordw locw valw ordw, lab w = Astore xordw ordw locw valw) as WPARAMS; desf.
  { unfold is_w in WWRITE.
    destruct (lab w); desf.
      by exists s; exists l; exists v; exists o. }

  assert (locw = locr) as SAME_PARAMS; subst.
  { apply (wf_rmwl WF) in RMW.
    unfold same_loc, loc in *; desf. }

  assert (COV : coverable G sc T r).
  { apply coverable_add_eq_iff; auto.
    apply covered_in_coverable; [|clear; basic_solver].
    apply TSTEP1. }

  assert (issued T w') as WISS.
  { red in COV. destruct COV as [_ [[COV|COV]|COV]].
    1,3: type_solver.
    eapply COV.
    eexists. apply seq_eqv_r. eauto. }

  assert (S w') as SW'.
  { by apply TCCOH.(etc_I_in_S). }

  assert (~ is_init r) as RNINIT.
  { intros H; apply (init_w WF) in H.
    type_solver. }
  assert (sb r w) as WRSB.
  { apply wf_rmwi in RMW; red in RMW; desf. }

  assert (~ covered T w) as WNCOV.
  { intros H; apply NEXT.
    apply TCCOH in H. apply H.
    exists w. by apply seq_eqv_r; split. }
  assert (~ is_init w) as WNINIT.
  { intros H. apply WNCOV. by apply TCCOH. }

  assert (loc lab r = Some locr) as RLOC.
  { unfold loc. by rewrite PARAMS. }
  assert (val lab r = Some valr) as RVAL.
  { unfold val. by rewrite PARAMS. }

  assert (loc lab w = Some locr) as WLOC.
  { unfold loc. by rewrite WPARAMS. }
  assert (val lab w = Some valw) as WVAL.
  { unfold val. by rewrite WPARAMS. }

  assert (W w') as WPWRITE.
  { apply (wf_rfD WF) in RF. apply seq_eqv_l in RF; desf. }
  assert (E w') as WPACT.
  { apply (wf_rfE WF) in RF. apply seq_eqv_l in RF; desf. }
  assert (loc lab w' = Some locr) as WPLOC.
  { assert (loc lab w' = loc lab r) as HH.
    { by apply (wf_rfl WF). }
    rewrite HH.
      by unfold loc; rewrite PARAMS. }
  assert (val lab w' = Some valr) as WPVAL.
  { assert (val lab w' = val lab r) as HH.
    { by apply wf_rfv. }
    rewrite HH.
      by unfold val; rewrite PARAMS. }

  assert (co w' w) as COWPW.
  { cdes CON.
    eapply rf_rmw_in_co; eauto.
    eexists; eauto. }

  assert (tid w = tid r) as TIDWR.
  { destruct (sb_tid_init WRSB); desf. }

  set (S' := S ∪₁ eq w ∪₁
               dom_sb_S_rfrmw G (mkETC (mkTC (covered T ∪₁ eq r) (issued T)) S) rfi (eq w)).
  assert (S' ⊆₁ E ∩₁ W) as SEW'.
  { unfold S'. rewrite SEW at 1. unionL; auto.
    { generalize WACT WWRITE. clear. basic_solver. }
    rewrite NONEXT. basic_solver. }

  edestruct SIM_MEM as [rel' DOM'].
  { apply WISS. }
  all: eauto.
  simpls. desc.
  clear DOM'1.

  assert ((rf ⨾ rmw) w' w) as RFRMW.
  { exists r; split; auto. }

  (* destruct DOM1 as [WMEM [p_rel]]; eauto. desc. *)
  (* destruct H0; desc. *)
  (* { exfalso. apply NINRMW. exists w'. apply seq_eqv_l; split; auto. } *)
  (* assert (p = w'); subst. *)
  (* { eapply wf_rfrmwf; eauto. } *)
  (* rewrite INMEM0 in P_INMEM. inv P_INMEM. clear P_INMEM. *)
  (* rename p_v into valr. rename p_rel into rel'. *)

  destruct (SAME_RMW w RMW) as [SAME WREPR].
  assert (ev = ProgramEvent.update
                  locr valr valw
                  (Event_imm_promise.rmod ordr)
                  (Event_imm_promise.wmod ordw)) as EV.
  { red in SAME; red in SAME; simpls.
    rewrite PARAMS in *; simpls.
    rewrite WPARAMS in *; simpls.
    destruct ev; desf; vauto. }

  assert (Events.mod lab r = ordr) as RORD.
  { unfold Events.mod. by rewrite PARAMS. }
  assert (Events.mod lab w = ordw) as WORD.
  { unfold Events.mod. by rewrite WPARAMS. }

  edestruct (@read_step_helper G WF sc CON) as [TCCOH' HH]; eauto.
  desc. rewrite <- TIDWR in *.

  assert (tc_coherent G sc (mkTC (covered T ∪₁ eq r) (issued T)))
    as TCCOH1.
  { apply TSTEP1. }

  assert (issuable G sc (mkTC (covered T ∪₁ eq r) (issued T)) w) as WNNISS.
  { eapply issuable_next_w; eauto.
    split; simpls.
    red; split; [split|]; auto.
    { red. intros x [y SBB]. apply seq_eqv_r in SBB. desc. rewrite <- SBB0 in *.
      clear y SBB0.
      destruct (classic (x = r)) as [EQ|NEQ].
      { by right. }
      left.
      edestruct sb_semi_total_r with (x:=w) (y:=x) (z:=r); eauto.
      { apply NEXT. eexists. apply seq_eqv_r. eauto. }
      exfalso. eapply WF.(wf_rmwi); eauto. }
    clear WREPR REPR.
    red; intros [H|H]; [by desf|].
    type_solver. }

  edestruct (fun w1 w2 x z k w3 w4 w5 =>
               @issue_reserved_step_helper_no_next
               G WF sc CON (mkTC (covered T ∪₁ eq r) (issued T)) S
               w1 w2 f_to f_from FCOH
               (Configuration.mk x PC.(Configuration.sc) PC.(Configuration.memory))
               w3 smode w4 w5 (Local.mk z k)
            ) with (w:=w) (valw:=valw) (ordw:=Events.mod lab w)
    as [p_rel H].
  all: simpls.
  2: by apply SIM_PROM0.
  5: by apply PLN_RLX_EQ0.
  all: eauto.
  { ins. rewrite IdentMap.gso in *; eauto. }
  { rewrite IdentMap.gss. eauto. }
  desc. red in H. desc.
  destruct H0 as [H|H]; desc.
  { exfalso. apply NINRMW. exists w'. apply seq_eqv_l. split; eauto. }
  assert (p = w') as PW.
  { eapply wf_rfrmwf; eauto. }
  rewrite PW in *; clear PW.
  simpls.
  assert (p_rel = rel') as PW.
  { rewrite INMEM in P_INMEM. clear -P_INMEM. inv P_INMEM. }
  rewrite PW in *; clear PW.
  (* destruct H1 as [H1|H1]; red in H1; desc. *)
  (* 2: done. *)
  destruct (is_rel lab w) eqn:RELVV; simpls.

  set (f_to' := upd f_to w (Time.middle (f_from w) (f_to w))).
  assert (ISSEQ_TO : forall e : actid, issued T e -> f_to' e = f_to e).
  { ins. unfold f_to'. rewrite updo; auto. by intros HH; subst. }

  set (pe := ThreadEvent.update
               locr (f_from w) (f_to' w) valr valw
               rel' (Some
                       (View.join
                          (View.join
                             (View.join
                                (View.join (TView.cur (Local.tview local))
                                           (View.singleton_ur_if
                                              (Ordering.le
                                                 Ordering.relaxed
                                                 (Event_imm_promise.rmod (Events.mod lab r))) locr
                                              (f_to w')))
                                (if
                                    Ordering.le Ordering.acqrel
                                                (Event_imm_promise.rmod (Events.mod lab r))
                                  then View.unwrap rel'
                                  else View.bot)) (View.unwrap rel'))
                          (View.singleton_ur locr (f_to' w))))
               (Event_imm_promise.rmod ordr) (Event_imm_promise.wmod ordw)).

  assert (Rlx r /\ Rlx w) as [RRLX WRLX].
  { split. all: apply ALLRLX; by split. }

  assert (Ordering.le Ordering.relaxed (Event_imm_promise.rmod ordr)) as RLX_ORDR.
  { unfold is_rlx, mode_le, Events.mod in *; simpls.
    rewrite PARAMS in *.
    destruct ordr; simpls. }
  assert (Ordering.le Ordering.relaxed (Event_imm_promise.wmod ordw)) as RLX_ORDW.
  { unfold is_rlx, mode_le, Events.mod in *; simpls.
    rewrite WPARAMS in *.
    destruct ordw; simpls. }
  assert (Ordering.le Ordering.acqrel (Event_imm_promise.wmod ordw)) as REL_ORDW.
  { unfold is_rel, mode_le, Events.mod in *; simpls.
    rewrite WPARAMS in *.
    destruct ordw; simpls. }
  assert (Ordering.le Ordering.strong_relaxed (Event_imm_promise.wmod ordw)) as SRLX_ORDW.
  { unfold is_rel, mode_le, Events.mod in *; simpls.
    rewrite WPARAMS in *.
    destruct ordw; simpls. }

  assert (f_to w' = f_from w) as FF.
  { rewrite <- ISSEQ_TO; auto.
    apply FCOH0; auto.
    { by do 2 left. }
    clear. basic_solver. }

  assert (forall l to from msg
                 (NEQ  : l <> locr \/ to <> f_to  w)
                 (NEQ' : l <> locr \/ to <> f_to' w),
             Memory.get l to memory_add = Some (from, msg) <->
             Memory.get l to PC.(Configuration.memory) = Some (from, msg))
    as NOTNEWM.
  { ins. erewrite Memory.add_o; eauto.
    rewrite loc_ts_eq_dec_neq; auto.
    erewrite Memory.remove_o; eauto.
    rewrite loc_ts_eq_dec_neq; auto. }

  set (pe_cancel :=
         ThreadEvent.promise
           locr (f_from w) (f_to w) Message.reserve
           Memory.op_kind_cancel).

  assert (f_to w' <> f_to w) as FWNEQ.
  { intros HH.
    eapply f_to_eq with (I:=S) in HH; subst; eauto.
    red. by rewrite WLOC. }
  assert (f_to w' <> f_to' w) as FWNEQ'.
  { rewrite <- ISSEQ_TO; auto.
    intros HH.
    eapply f_to_eq in HH; (try by apply FCOH0); subst; eauto.
    { red. by rewrite WLOC. }
    all: clear -SW'; basic_solver. }

  assert (forall y : actid, covered T y /\ tid y = tid r -> sb y r) as COVNR.
  { intros y [COVY TIDY].
    edestruct same_thread with (x:=r) (y:=y) as [[|SB]|SB]; eauto.
    { apply TCCOH in COVY. apply COVY. }
    { exfalso. apply RNCOV. by subst. }
    exfalso. apply RNCOV. apply TCCOH in COVY.
    apply COVY. eexists. apply seq_eqv_r. eauto. }
  assert (doma (sb ⨾ ⦗eq r⦘) (covered T)) as DOMASBR.
  { red. ins. eapply NEXT. red. eauto. }

  exists f_to'.
  eexists (Configuration.mk _ _ memory_add).
  apply and_assoc. apply pair_app.
  { split.
    { eapply t_trans; apply t_step.
      { set (pe'' := MachineEvent.silent).
        arewrite (pe'' = ThreadEvent.get_machine_event pe_cancel) by simpls.
        econstructor; eauto.
        2: by unfold pe_cancel; desf.
        apply Thread.step_promise.
        constructor.
        2: by simpls.
        econstructor; eauto. }
      set (pe' := MachineEvent.silent).
      arewrite (pe' = ThreadEvent.get_machine_event pe) by simpls.
      eapply plain_step_intro with (lang:=thread_lts (tid w)); eauto.
      { simpls. rewrite IdentMap.gss; eauto. }
      2: by unfold pe; clear; desf.
      apply Thread.step_program.
      constructor.
      { assert (ev = ThreadEvent.get_program_event pe) as EV' by done.
        rewrite EV' in STEP; eauto. }
      unfold pe; eapply Local.step_update.
      { econstructor; eauto.
        { simpls. rewrite <- FF.
          erewrite Memory.remove_o; eauto.
          rewrite loc_ts_eq_dec_neq; eauto. }
        (* TODO: generalize! *)
        assert
          (Time.le (View.rlx (TView.cur (Local.tview local)) locr) (f_from w))
          as PP.
        2: constructor; auto.
        2: by cdes PLN_RLX_EQ; simpls; rewrite EQ_CUR.
        edestruct (max_event_cur) as [a_max]; eauto; desc.
        assert (E a_max) as EA.
        { apply (wf_urrE WF) in CCUR.
          revert CCUR; unfold seq; unfolder; ins; desf.
            by apply CON. }
        assert (issued T a_max) as AISS.
        { assert (A: (urr G sc locr ⨾ ⦗coverable G sc T⦘) a_max r).
            by basic_solver.
            apply (urr_coverable) in A; try done.
            revert A; unfold seq; unfolder; ins; desf. }
        assert (S a_max) as SA by (by apply TCCOH.(etc_I_in_S)).
        rewrite <- FF.
        destruct (classic (a_max = w')) as [|AWNEQ]; [by desf|].
        edestruct (@wf_co_total G WF (Some locr) a_max) as [AWCO|AWCO].
        3: by apply AWNEQ.
        2: basic_solver.
        apply set_interA; split; auto.
        hahn_rewrite (@wf_urrD G sc locr) in CCUR.
        revert CCUR; clear; basic_solver 12.
        { etransitivity; eauto.
          apply Time.le_lteq; left.
          eapply f_to_co_mon; eauto.
          all: generalize SA SW'; clear; basic_solver. }
        exfalso.
        eapply transp_rf_co_urr_irr; eauto.
        exists w'; split.
        { right; red; apply RF. }
        exists a_max; split; eauto. }
      econstructor; eauto.
      { unfold TView.write_released, TView.write_tview. simpls. rewrite RLX_ORDW.
        rewrite REL_ORDW.
        unfold View.singleton_ur_if. rewrite RORD.
        rewrite RLX_ORDR.
        unfold LocFun.add. rewrite Loc.eq_dec_eq.
        rewrite View.join_comm with (lhs:=View.unwrap rel').
        rewrite !View.join_assoc.
        rewrite View.join_comm with (lhs:=View.unwrap rel').
          by rewrite FF. }
      { unfold TView.write_released, TView.read_tview. simpls.
        constructor. unfold View.join. simpls.
        rewrite <- RORD. by rewrite <- FF. }
      simpls. auto. intros HH.
      eapply nonsynch_loc_le with (mem2:=local.(Local.promises)); auto.
      eapply memory_remove_le; eauto. }
    unnw.
    red; splits; red; splits; simpls.
    { apply TSTEP3. }
    { rewrite set_inter_union_r.
      apply set_subset_union_l; split.
      etransitivity; eauto.
      all: clear; basic_solver. }
    { ins. apply WF.(wf_rmwD) in RMW0.
      apply seq_eqv_l in RMW0; destruct RMW0 as [RR RMW0].
      apply seq_eqv_r in RMW0; destruct RMW0 as [RMW0 WW].
      split; intros [[HH|HH]|HH].
      { left; left. erewrite <- RMWCOV; eauto. }
      { subst. right. eapply wf_rmwf; eauto. }
      { subst. clear -WWRITE RR. type_solver. }
      { left; left. erewrite RMWCOV; eauto. }
      { subst. clear -WW RREAD. type_solver. }
      subst. left; right.
      eapply wf_rmw_invf; eauto. }
    { intros e' EE.
      destruct (Ident.eq_dec (tid e') (tid w)) as [EQ|NEQ].
      { rewrite EQ. eexists.
        rewrite IdentMap.gss. eauto. }
      do 2 (rewrite IdentMap.gso; auto). }
    { ins. destruct (Ident.eq_dec thread' (tid w)) as [EQ|NEQ].
      { subst. rewrite IdentMap.gss in TID.
        inversion TID. simpls. }
      eapply PROM_IN_MEM1; eauto.
      do 2 (rewrite IdentMap.gso in TID; auto).
      do 2 (rewrite IdentMap.gso; eauto). }
    { intros NFSC. etransitivity; [by apply SC_COV|].
      clear. basic_solver. }
    { intros QQ l.
      eapply max_value_same_set.
      { by apply SC_REQ1. }
      apply s_tm_n_f_steps.
      { apply TCCOH'. }
      { clear. basic_solver. }
      intros a [[H|H]|H] HH AA.
      { apply HH. by left. }
      { subst. clear -RREAD AA. type_solver. }
      subst. clear -WWRITE AA. type_solver. }
    { eapply Memory.add_closed with (mem1:=memory_cancel); eauto.
      eapply Memory.cancel_closed; eauto. }
    rewrite IdentMap.gss.
    eexists; eexists; eexists; splits; eauto; simpls.
    { erewrite tau_steps_step_same_instrs; eauto. }
    { ins. edestruct PROM_DISJOINT0 as [HH|]; eauto.
      do 2 (rewrite IdentMap.gso in *; eauto). }
    { clear WREPR REPR. rewrite <- FF, <- RORD, <- WORD.
      apply SIM_MEM1. }
    { eapply sim_tview_write_step; eauto.
      3: { rewrite <- FF.
           eapply sim_tview_f_issued with (T:=mkTC (covered T ∪₁ eq r) (issued T)); eauto.
           eapply sim_tview_read_step; eauto. }
      { apply set_subset_union_l; split.
        all: intros x H.
        { apply TCCOH in H; apply H. }
          by desf. }
      { red. ins. left. apply seq_eqv_r in REL0.
        destruct REL0 as [SB [COVY|]]; subst.
        { apply TCCOH in COVY. apply COVY. eexists.
          apply seq_eqv_r. eauto. }
        apply NEXT. eexists. apply seq_eqv_r. eauto. }
      { intros [HH|HH].
        { by apply WNCOV. }
        clear -HH RREAD WWRITE.
        type_solver. }
      { intros y [[COVY|XX] TIDY].
        2: { subst. apply rmw_in_sb; auto. }
        eapply sb_trans.
        2: { apply rmw_in_sb; eauto. }
        edestruct same_thread with (x:=r) (y:=y) as [[SS|SB]|SB]; eauto.
        { apply TCCOH in COVY. apply COVY. }
        { by rewrite TIDY. }
        { by subst. }
        exfalso. apply RNCOV. apply TCCOH in COVY.
        apply COVY. eexists. apply seq_eqv_r. eauto. }
      { intros y z HH. apply seq_eqv_r in HH. destruct HH as [SB HH].
        rewrite <- HH in *. clear z HH.
        destruct (classic (y = r)) as [|NEQ].
        { by right. }
        edestruct sb_semi_total_r with (x:=w) (y:=y) (z:=r) as [AA|AA]; eauto.
        { left. apply NEXT. eexists. apply seq_eqv_r. eauto. }
        exfalso. eapply WF.(wf_rmwi); eauto. }
      { erewrite Memory.add_o; eauto. by rewrite loc_ts_eq_dec_eq. }
      done. }
    { cdes PLN_RLX_EQ.
      unfold TView.write_tview, TView.read_tview; simpls.
      unfold View.singleton_ur_if.
      rewrite RLX_ORDR.
      destruct (Ordering.le Ordering.acqrel (Event_imm_promise.wmod ordw)); simpls.
      red; splits; simpls.
      all: desf; simpls.
      all: try rewrite REL_PLN_RLX0.
      all: try rewrite EQ_CUR.
      all: try rewrite EQ_ACQ.
      1-4: reflexivity.
      all: intros l; unfold LocFun.add.
      all: destruct (Loc.eq_dec l locr) as [|NEQ]; subst.
      2,4: by apply EQ_REL.
      all: unfold View.join; simpls.
      all: rewrite EQ_CUR.
      2: done.
        by rewrite REL_PLN_RLX. }
    { assert (Memory.closed_timemap (TimeMap.singleton locr (f_to' w)) memory_add) as AA.
      { unfold TimeMap.singleton, LocFun.add; red; ins.
        destruct (Loc.eq_dec loc locr); subst; eauto.
        erewrite Memory.add_o; eauto. rewrite loc_ts_eq_dec_eq. eauto. }
      assert (Memory.closed_timemap (TimeMap.singleton locr (f_from w)) memory_add) as BB.
      { unfold TimeMap.singleton, LocFun.add; red; ins.
        destruct (Loc.eq_dec loc locr); subst; eauto.
        rewrite <- FF.
        erewrite Memory.add_o; eauto. rewrite loc_ts_eq_dec_neq; auto.
        erewrite Memory.remove_o; eauto. rewrite loc_ts_eq_dec_neq; auto.
        eauto. }
      assert (forall tmap,
                 Memory.closed_timemap tmap PC.(Configuration.memory) ->
                 Memory.closed_timemap tmap memory_add) as HH.
      { intros tmap HH. red. ins.
        specialize (HH loc). desc.
        exists from, val, released.
        destruct (classic (loc = locr)) as [|]; subst; auto.
        2: by apply NOTNEWM; auto.
        apply NOTNEWM; auto.
        { destruct (classic (tmap locr = f_to w)) as [EQ|]; subst; auto.
          rewrite EQ in HH. exfalso.
          edestruct SIM_RES_MEM with (b:=w) as [OO]; eauto.
          rewrite OO in HH. inv HH. }
        destruct (classic (tmap locr = f_to' w)) as [EQ|]; subst; auto.
        rewrite EQ in HH. exfalso.
        unfold f_to' in HH. rewrite NINMEM in HH. inv HH. }
      unfold TView.write_tview, TView.read_tview; simpls.
      red; splits; simpls.
      all: desf; ins.
      all: repeat (apply Memory.join_closed_timemap); auto.
      all: try by (apply HH; apply MEM_CLOSE).
      all: try by apply Memory.closed_timemap_bot.
      all: unfold LocFun.add; destruct (Loc.eq_dec loc locr); subst; eauto.
      2,4: by (apply HH; apply MEM_CLOSE).
      all: unfold View.join; simpls.
      all: repeat (apply Memory.join_closed_timemap); auto.
      all: try by (apply HH; apply MEM_CLOSE).
        by apply Memory.closed_timemap_bot. }
    red. splits; eauto.
    ins. rewrite (INDEX_RMW w RMW); auto.
    rewrite TIDWR in *.
    apply sim_state_cover_rmw_events; auto. }
  intros [PCSTEP SIMREL_THREAD']; split; auto.
  intros SMODE SIMREL.
  subst. desc. red.
  splits; [by apply SIMREL_THREAD'|].
  simpls. ins.
  destruct (classic (thread = tid w)) as [|TNEQ]; subst.
  { apply SIMREL_THREAD'. }
  set (AA:=TP).
  apply IdentMap.Facts.add_in_iff in AA.
  destruct AA as [AA|AA]; subst; auto.
  { apply SIMREL_THREAD'. }
  apply IdentMap.Facts.add_in_iff in AA.
  destruct AA as [AA|AA]; subst; auto.
  { clear -TNEQ. desf. }
  apply SIMREL in AA. cdes AA.
  eapply simrel_thread_local_step with (thread:=tid w) (PC:=PC) (T:=T) (S:=S); eauto.
  11: { simpls.
        eapply msg_preserved_trans.
        2: by eapply msg_preserved_add; eauto.
        eapply msg_preserved_cancel; eauto. }
  10: { simpls.
        eapply closedness_preserved_trans.
        2: by eapply closedness_preserved_add; eauto.
        eapply closedness_preserved_cancel; eauto. }
  9: by eapply same_other_threads_steps; eauto.
  all: simpls; eauto.
  { erewrite coveredE; eauto.
    clear -RACT WACT. basic_solver. }
  { rewrite issuedE; eauto. generalize WACT. clear. basic_solver. }
  1-5: clear; basic_solver.
  { rewrite dom_sb_S_rfrmw_same_tid; auto. clear. basic_solver. }
  { ins.
    etransitivity; [|by symmetry; apply IdentMap.Facts.add_in_iff].
    split.
    { ins; eauto. right. apply IdentMap.Facts.add_in_iff. eauto. }
    intros [|HH]; subst; auto.
    { apply SIMREL_THREAD; auto. }
    apply IdentMap.Facts.add_in_iff in HH.
    destruct HH as [|HH]; subst; auto.
    apply IdentMap.Facts.in_find_iff. rewrite LLH. clear. desf. }
  { apply IdentMap.Facts.in_find_iff. rewrite LLH0. clear. desf. }
  { eapply sim_prom_f_issued; eauto. }
  { (* TODO: generalize to a lemma? *)
    red. ins. apply SIM_RPROM0 in RES. desc.
    assert (b <> w) as BNW.
    { intros HH; desf. }
    exists b. splits; auto.
    unfold f_to'. rewrite updo; auto. }
  { eapply sim_mem_f_issued; eauto. }
  { ins.
    assert (b <> w) as BNW.
    { intros HH; desf. }
    unfold f_to'. rewrite updo; auto.
    apply SIM_RES_MEM1; auto. }
  eapply sim_tview_f_issued; eauto.
Unshelve.
apply state.
Qed.

End IssueReservedRelPlainStep.