(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Typing rules and a type inference algorithm for RTL. *)

Require Import Coqlib.
Require Import Errors.
Require Import Maps.
Require Import AST.
Require Import Op.
Require Import Registers.
Require Import Globalenvs.
Require Import Values.
Require Import Integers.
Require Import Events.
Require Import RTL.
Require Import Conventions.

(** * The type system *)

(** Like Cminor and all intermediate languages, RTL can be equipped with
  a simple type system that statically guarantees that operations
  and addressing modes are applied to the right number of arguments
  and that the arguments are of the correct types.  The type algebra
  is trivial, consisting of the two types [Tint] (for integers and pointers)
  and [Tfloat] (for floats).

  Additionally, we impose that each pseudo-register has the same type
  throughout the function.  This requirement helps with register allocation,
  enabling each pseudo-register to be mapped to a single hardware register
  or stack location of the correct type.

  Finally, we also check that the successors of instructions
  are valid, i.e. refer to non-empty nodes in the CFG.

  The typing judgement for instructions is of the form [wt_instr f env
  instr], where [f] is the current function (used to type-check
  [Ireturn] instructions) and [env] is a typing environment
  associating types to pseudo-registers.  Since pseudo-registers have
  unique types throughout the function, the typing environment does
  not change during type-checking of individual instructions.  One
  point to note is that we have one polymorphic operator, [Omove],
  which can work over both integers and floats.
*)

Definition regenv := reg -> typ.

Section WT_INSTR.

Variable env: regenv.
Variable funct: function.

Definition valid_successor (s: node) : Prop :=
  exists i, funct.(fn_code)!s = Some i.

Inductive wt_instr : instruction -> Prop :=
  | wt_Inop:
      forall s,
      valid_successor s ->
      wt_instr (Inop s)
  | wt_Iopmove:
      forall r1 r s,
      env r1 = env r ->
      valid_successor s ->
      wt_instr (Iop Omove (r1 :: nil) r s)
  | wt_Iop:
      forall op args res s,
      op <> Omove ->
      (List.map env args, env res) = type_of_operation op ->
      valid_successor s ->
      wt_instr (Iop op args res s)
  | wt_Iload:
      forall chunk addr args dst s,
      List.map env args = type_of_addressing addr ->
      env dst = type_of_chunk chunk ->
      valid_successor s ->
      wt_instr (Iload chunk addr args dst s)
  | wt_Istore:
      forall chunk addr args src s,
      List.map env args = type_of_addressing addr ->
      env src = type_of_chunk chunk ->
      valid_successor s ->
      wt_instr (Istore chunk addr args src s)
  | wt_Icall:
      forall sig ros args res s,
      match ros with inl r => env r = Tint | inr s => True end ->
      List.map env args = sig.(sig_args) ->
      env res = proj_sig_res sig ->
      valid_successor s ->
      wt_instr (Icall sig ros args res s)
  | wt_Itailcall:
      forall sig ros args,
      match ros with inl r => env r = Tint | inr s => True end ->
      sig.(sig_res) = funct.(fn_sig).(sig_res) ->
      List.map env args = sig.(sig_args) ->
      tailcall_possible sig ->
      wt_instr (Itailcall sig ros args)
  | wt_Ibuiltin:
      forall ef args res s,
      List.map env args = (ef_sig ef).(sig_args) ->
      env res = proj_sig_res (ef_sig ef) ->
      arity_ok (ef_sig ef).(sig_args) = true \/ ef_reloads ef = false ->
      valid_successor s ->
      wt_instr (Ibuiltin ef args res s)
  | wt_Icond:
      forall cond args s1 s2,
      List.map env args = type_of_condition cond ->
      valid_successor s1 ->
      valid_successor s2 ->
      wt_instr (Icond cond args s1 s2)
  | wt_Ijumptable:
      forall arg tbl,
      env arg = Tint ->
      (forall s, In s tbl -> valid_successor s) ->
      list_length_z tbl * 4 <= Int.max_unsigned ->
      wt_instr (Ijumptable arg tbl)
  | wt_Ireturn:
      forall optres,
      option_map env optres = funct.(fn_sig).(sig_res) ->
      wt_instr (Ireturn optres).

End WT_INSTR.

(** A function [f] is well-typed w.r.t. a typing environment [env],
   written [wt_function env f], if all instructions are well-typed,
   parameters agree in types with the function signature, and
   parameters are pairwise distinct. *)

Record wt_function (f: function) (env: regenv): Prop :=
  mk_wt_function {
    wt_params:
      List.map env f.(fn_params) = f.(fn_sig).(sig_args);
    wt_norepet:
      list_norepet f.(fn_params);
    wt_instrs:
      forall pc instr,
      f.(fn_code)!pc = Some instr -> wt_instr env f instr;
    wt_entrypoint:
      valid_successor f f.(fn_entrypoint)
}.

Inductive wt_fundef: fundef -> Prop :=
  | wt_fundef_external: forall ef,
      wt_fundef (External ef)
  | wt_function_internal: forall f env,
      wt_function f env ->
      wt_fundef (Internal f).

Definition wt_program (p: program): Prop :=
  forall i f, In (i, Gfun f) (prog_defs p) -> wt_fundef f.

(** * Type inference *)

(** There are several ways to ensure that RTL code is well-typed and
  to obtain the typing environment (type assignment for pseudo-registers)
  needed for register allocation.  One is to start with well-typed Cminor
  code and show type preservation for RTL generation and RTL optimizations.
  Another is to start with untyped RTL and run a type inference algorithm
  that reconstructs the typing environment, determining the type of
  each pseudo-register from its uses in the code.  We follow the second
  approach.

  We delegate the task of determining the type of each pseudo-register
  to an external ``oracle'': a function written in Caml and not
  proved correct.  We verify the returned type environment using
  the following Coq code, which we will prove correct. *)

Parameter infer_type_environment:
  function -> list (node * instruction) -> option regenv.

(** ** Algorithm to check the correctness of a type environment *)

Section TYPECHECKING.

Variable funct: function.
Variable env: regenv.

Definition check_reg (r: reg) (ty: typ): bool :=
  if typ_eq (env r) ty then true else false.

Fixpoint check_regs (rl: list reg) (tyl: list typ) {struct rl}: bool :=
  match rl, tyl with
  | nil, nil => true
  | r1::rs, ty::tys => check_reg r1 ty && check_regs rs tys
  | _, _ => false
  end.

Definition check_op (op: operation) (args: list reg) (res: reg): bool :=
  let (targs, tres) := type_of_operation op in
  check_regs args targs && check_reg res tres.

Definition check_successor (s: node) : bool :=
  match funct.(fn_code)!s with None => false | Some i => true end.

Definition check_instr (i: instruction) : bool :=
  match i with
  | Inop s =>
      check_successor s
  | Iop Omove (arg::nil) res s =>
      if typ_eq (env arg) (env res)
      then check_successor s
      else false
  | Iop Omove args res s =>
      false
  | Iop op args res s =>
      check_op op args res && check_successor s
  | Iload chunk addr args dst s =>
      check_regs args (type_of_addressing addr)
      && check_reg dst (type_of_chunk chunk)
      && check_successor s
  | Istore chunk addr args src s =>
      check_regs args (type_of_addressing addr)
      && check_reg src (type_of_chunk chunk)
      && check_successor s
  | Icall sig ros args res s =>
      match ros with inl r => check_reg r Tint | inr s => true end
      && check_regs args sig.(sig_args)
      && check_reg res (proj_sig_res sig)
      && check_successor s
  | Itailcall sig ros args =>
      match ros with inl r => check_reg r Tint | inr s => true end
      && check_regs args sig.(sig_args)
      && opt_typ_eq sig.(sig_res) funct.(fn_sig).(sig_res)
      && tailcall_is_possible sig
  | Ibuiltin ef args res s =>
      check_regs args (ef_sig ef).(sig_args)
      && check_reg res (proj_sig_res (ef_sig ef))
      && (if ef_reloads ef then arity_ok (ef_sig ef).(sig_args) else true)
      && check_successor s
  | Icond cond args s1 s2 =>
      check_regs args (type_of_condition cond)
      && check_successor s1
      && check_successor s2
  | Ijumptable arg tbl =>
      check_reg arg Tint
      && List.forallb check_successor tbl
      && zle (list_length_z tbl * 4) Int.max_unsigned
  | Ireturn optres =>
      match optres, funct.(fn_sig).(sig_res) with
      | None, None => true
      | Some r, Some t => check_reg r t
      | _, _ => false
      end
  end.

Definition check_params_norepet (params: list reg): bool :=
  if list_norepet_dec Reg.eq params then true else false.

Fixpoint check_instrs (instrs: list (node * instruction)) : bool :=
  match instrs with
  | nil => true
  | (pc, i) :: rem => check_instr i && check_instrs rem
  end.

(** ** Correctness of the type-checking algorithm *)

Ltac elimAndb :=
  match goal with
  | [ H: _ && _ = true |- _ ] =>
      elim (andb_prop _ _ H); clear H; intros; elimAndb
  | _ =>
      idtac
  end.

Lemma check_reg_correct:
  forall r ty, check_reg r ty = true -> env r = ty.
Proof.
  unfold check_reg; intros.
  destruct (typ_eq (env r) ty). auto. discriminate.
Qed.

Lemma check_regs_correct:
  forall rl tyl, check_regs rl tyl = true -> List.map env rl = tyl.
Proof.
  induction rl; destruct tyl; simpl; intros.
  auto. discriminate. discriminate.
  elimAndb.
  rewrite (check_reg_correct _ _ H). rewrite (IHrl tyl H0). auto.
Qed.

Lemma check_op_correct:
  forall op args res,
  check_op op args res = true ->
  (List.map env args, env res) = type_of_operation op.
Proof.
  unfold check_op; intros.
  destruct (type_of_operation op) as [targs tres].
  elimAndb.
  rewrite (check_regs_correct _ _ H).
  rewrite (check_reg_correct _ _ H0).
  auto.
Qed.

Lemma check_successor_correct:
  forall s,
  check_successor s = true -> valid_successor funct s.
Proof.
  intro; unfold check_successor, valid_successor.
  destruct (fn_code funct)!s; intro.
  exists i; auto.
  discriminate.
Qed.

Lemma check_instr_correct:
  forall i, check_instr i = true -> wt_instr env funct i.
Proof.
  unfold check_instr; intros; destruct i; elimAndb.
  (* nop *)
  constructor. apply check_successor_correct; auto.
  (* op *)
  destruct o; elimAndb;
  try (apply wt_Iop; [ congruence
                     | apply check_op_correct; auto
                     | apply check_successor_correct; auto ]).
  destruct l; try discriminate. destruct l; try discriminate.
  destruct (typ_eq (env r0) (env r)); try discriminate.
  apply wt_Iopmove; auto. apply check_successor_correct; auto.
  (* load *)
  constructor. apply check_regs_correct; auto. apply check_reg_correct; auto.
  apply check_successor_correct; auto.
  (* store *)
  constructor. apply check_regs_correct; auto. apply check_reg_correct; auto.
  apply check_successor_correct; auto.
  (* call *)
  constructor.
  destruct s0; auto. apply check_reg_correct; auto.
  apply check_regs_correct; auto.
  apply check_reg_correct; auto.
  apply check_successor_correct; auto.
  (* tailcall *)
  constructor.
  destruct s0; auto. apply check_reg_correct; auto.
  eapply proj_sumbool_true; eauto.
  apply check_regs_correct; auto.
  apply tailcall_is_possible_correct; auto.
  (* builtin *)
  constructor.
  apply check_regs_correct; auto.
  apply check_reg_correct; auto.
  auto.
  destruct (ef_reloads e); auto.
  apply check_successor_correct; auto.
  (* cond *)
  constructor. apply check_regs_correct; auto.
  apply check_successor_correct; auto.
  apply check_successor_correct; auto.
  (* jumptable *)
  constructor. apply check_reg_correct; auto.
  rewrite List.forallb_forall in H1. intros. apply check_successor_correct; auto.
  eapply proj_sumbool_true. eauto.
  (* return *)
  constructor.
  destruct o; simpl; destruct funct.(fn_sig).(sig_res); try discriminate.
  rewrite (check_reg_correct _ _ H); auto.
  auto.
Qed.

Lemma check_instrs_correct:
  forall instrs,
  check_instrs instrs = true ->
  forall pc i, In (pc, i) instrs -> wt_instr env funct i.
Proof.
  induction instrs; simpl; intros.
  elim H0.
  destruct a as [pc' i']. elimAndb.
  elim H0; intro.
  inversion H2; subst pc' i'. apply check_instr_correct; auto.
  eauto.
Qed.

End TYPECHECKING.

(** ** The type inference function **)

Open Scope string_scope.

Definition type_function (f: function): res regenv :=
  let instrs := PTree.elements f.(fn_code) in
  match infer_type_environment f instrs with
  | None => Error (msg "RTL type inference error")
  | Some env =>
      if check_regs env f.(fn_params) f.(fn_sig).(sig_args)
      && check_params_norepet f.(fn_params)
      && check_instrs f env instrs
      && check_successor f f.(fn_entrypoint)
      then OK env
      else Error (msg "RTL type checking error")
  end.

Lemma type_function_correct:
  forall f env,
  type_function f = OK env ->
  wt_function f env.
Proof.
  unfold type_function; intros until env.
  set (instrs := PTree.elements f.(fn_code)).
  case (infer_type_environment f instrs).
  intro env'.
  caseEq (check_regs env' f.(fn_params) f.(fn_sig).(sig_args)); intro; simpl; try congruence.
  caseEq (check_params_norepet f.(fn_params)); intro; simpl; try congruence.
  caseEq (check_instrs f env' instrs); intro; simpl; try congruence.
  caseEq (check_successor f (fn_entrypoint f)); intro; simpl; try congruence.
  intro EQ; inversion EQ; subst env'.
  constructor.
  apply check_regs_correct; auto.
  unfold check_params_norepet in H0.
  destruct (list_norepet_dec Reg.eq (fn_params f)). auto. discriminate.
  intros. eapply check_instrs_correct. eauto.
  unfold instrs. apply PTree.elements_correct. eauto.
  apply check_successor_correct. auto.
  congruence.
Qed.

(** * Type preservation during evaluation *)

(** The type system for RTL is not sound in that it does not guarantee
  progress: well-typed instructions such as [Icall] can fail because
  of run-time type tests (such as the equality between callee and caller's
  signatures).  However, the type system guarantees a type preservation
  property: if the execution does not fail because of a failed run-time
  test, the result values and register states match the static
  typing assumptions.  This preservation property will be useful
  later for the proof of semantic equivalence between [Linear] and [Mach].
  Even though we do not need it for [RTL], we show preservation for [RTL]
  here, as a warm-up exercise and because some of the lemmas will be
  useful later. *)

Definition wt_regset (env: regenv) (rs: regset) : Prop :=
  forall r, Val.has_type (rs#r) (env r).

Lemma wt_regset_assign:
  forall env rs v r,
  wt_regset env rs ->
  Val.has_type v (env r) ->
  wt_regset env (rs#r <- v).
Proof.
  intros; red; intros.
  rewrite Regmap.gsspec.
  case (peq r0 r); intro.
  subst r0. assumption.
  apply H.
Qed.

Lemma wt_regset_list:
  forall env rs,
  wt_regset env rs ->
  forall rl, Val.has_type_list (rs##rl) (List.map env rl).
Proof.
  induction rl; simpl.
  auto.
  split. apply H. apply IHrl.
Qed.

Lemma wt_init_regs:
  forall env rl args,
  Val.has_type_list args (List.map env rl) ->
  wt_regset env (init_regs args rl).
Proof.
  induction rl; destruct args; simpl; intuition.
  red; intros. rewrite Regmap.gi. simpl; auto.
  apply wt_regset_assign; auto.
Qed.

Inductive wt_stackframes: list stackframe -> option typ -> Prop :=
  | wt_stackframes_nil:
      wt_stackframes nil (Some Tint)
  | wt_stackframes_cons:
      forall s res f sp pc rs env tyres,
      wt_function f env ->
      wt_regset env rs ->
      env res = match tyres with None => Tint | Some t => t end ->
      wt_stackframes s (sig_res (fn_sig f)) ->
      wt_stackframes (Stackframe res f sp pc rs :: s) tyres.

Inductive wt_state: state -> Prop :=
  | wt_state_intro:
      forall s f sp pc rs m env
        (WT_STK: wt_stackframes s (sig_res (fn_sig f)))
        (WT_FN: wt_function f env)
        (WT_RS: wt_regset env rs),
      wt_state (State s f sp pc rs m)
  | wt_state_call:
      forall s f args m,
      wt_stackframes s (sig_res (funsig f)) ->
      wt_fundef f ->
      Val.has_type_list args (sig_args (funsig f)) ->
      wt_state (Callstate s f args m)
  | wt_state_return:
      forall s v m tyres,
      wt_stackframes s tyres ->
      Val.has_type v (match tyres with None => Tint | Some t => t end) ->
      wt_state (Returnstate s v m).

Section SUBJECT_REDUCTION.

Variable p: program.

Hypothesis wt_p: wt_program p.

Let ge := Genv.globalenv p.

Lemma subject_reduction:
  forall st1 t st2, step ge st1 t st2 ->
  forall (WT: wt_state st1), wt_state st2.
Proof.
  induction 1; intros; inv WT;
  try (generalize (wt_instrs _ _ WT_FN pc _ H);
       intro WT_INSTR;
       inv WT_INSTR).
  (* Inop *)
  econstructor; eauto.
  (* Iop *)
  econstructor; eauto.
  apply wt_regset_assign. auto.
  simpl in H0. inv H0. rewrite <- H3. apply WT_RS.
  econstructor; eauto.
  apply wt_regset_assign. auto.
  replace (env res) with (snd (type_of_operation op)).
  eapply type_of_operation_sound; eauto.
  rewrite <- H6. reflexivity.
  (* Iload *)
  econstructor; eauto.
  apply wt_regset_assign. auto. rewrite H8.
  eapply type_of_chunk_correct; eauto.
  (* Istore *)
  econstructor; eauto.
  (* Icall *)
  assert (wt_fundef fd).
    destruct ros; simpl in H0.
    pattern fd. apply Genv.find_funct_prop with fundef unit p (rs#r).
    exact wt_p. exact H0.
    caseEq (Genv.find_symbol ge i); intros; rewrite H1 in H0.
    pattern fd. apply Genv.find_funct_ptr_prop with fundef unit p b.
    exact wt_p. exact H0.
    discriminate.
  econstructor; eauto.
  econstructor; eauto.
  rewrite <- H7. apply wt_regset_list. auto.
  (* Itailcall *)
  assert (wt_fundef fd).
    destruct ros; simpl in H0.
    pattern fd. apply Genv.find_funct_prop with fundef unit p (rs#r).
    exact wt_p. exact H0.
    caseEq (Genv.find_symbol ge i); intros; rewrite H1 in H0.
    pattern fd. apply Genv.find_funct_ptr_prop with fundef unit p b.
    exact wt_p. exact H0.
    discriminate.
  econstructor; eauto.
  rewrite H6; auto.
  rewrite <- H7. apply wt_regset_list. auto.
  (* Ibuiltin *)
  econstructor; eauto.
  apply wt_regset_assign. auto.
  rewrite H6. eapply external_call_well_typed; eauto.
  (* Icond *)
  econstructor; eauto.
  (* Ijumptable *)
  econstructor; eauto.
  (* Ireturn *)
  econstructor; eauto.
  destruct or; simpl in *.
  rewrite <- H2. apply WT_RS. exact I.
  (* internal function *)
  simpl in *. inv H5. inversion H1; subst.
  econstructor; eauto.
  apply wt_init_regs; auto. rewrite wt_params0; auto.
  (* external function *)
  simpl in *. inv H5.
  econstructor; eauto.
  change (Val.has_type res (proj_sig_res (ef_sig ef))).
  eapply external_call_well_typed; eauto.
  (* return *)
  inv H1. econstructor; eauto.
  apply wt_regset_assign; auto. congruence.
Qed.

End SUBJECT_REDUCTION.


Require Import VST.floyd.proofauto.
Require Import sha.sha.
Require Import sha.SHA256.
Require Import sha.spec_sha.
Require Import sha.sha_lemmas.
Require Import sha.bdo_lemmas.
Local Open Scope logic.

Lemma rearrange_aux:
 forall h f c k l,
 Int.add (Int.add (Int.add (Int.add h f) c) k) l =
Int.add (Int.add (Int.add (Int.add l h) f) c) k.
Proof.
intros.
rewrite <- (Int.add_commut l).
repeat rewrite (Int.add_assoc h).
rewrite <- (Int.add_assoc l).
repeat rewrite (Int.add_assoc (Int.add l h)).
reflexivity.
Qed.

Lemma loop1_aux_lemma1:
  forall i b,
  (0 <= i < Zlength b) ->
  Zlength b <= 16 ->
  upd_Znth i
          (map Vint (sublist 0 i b) ++ list_repeat (Z.to_nat (16 - i)) Vundef)
          (Vint (Znth i b))
  =  map Vint (sublist 0 (i+1) b) ++ list_repeat (Z.to_nat (16 - (i+1))) Vundef.
Proof.
intros.
unfold upd_Znth.
autorewrite with sublist.
rewrite (sublist_split 0 i (i+1)) by omega.
rewrite map_app.
rewrite app_ass.
f_equal.
rewrite (sublist_len_1 i) by omega.
simpl.
autorewrite with sublist.
f_equal. f_equal. f_equal. omega.
Qed.

Definition block_data_order_loop1 :=
 Ssequence
 (Sset _i (Econst_int (Int.repr 0) tint))
   (nth 0 (loops (fn_body f_sha256_block_data_order)) Sskip).

Lemma sha256_block_data_order_loop1_proof:
  forall (Espec : OracleKind) (sh: share)
     (b: list int) ctx (data: val) (regs: list int) gv Xv
     (Hregs: length regs = 8%nat)
     (Hsh: readable_share sh),
     Zlength b = LBLOCKz ->
     semax (func_tycontext f_sha256_block_data_order Vprog Gtot nil)
  (PROP  ()
   LOCAL  (temp _a (Vint (nthi regs 0)); temp _b (Vint (nthi regs 1));
                temp _c (Vint (nthi regs 2)); temp _d (Vint (nthi regs 3));
                temp _e (Vint (nthi regs 4)); temp _f (Vint (nthi regs 5));
                temp _g (Vint (nthi regs 6)); temp _h (Vint (nthi regs 7));
                temp _data data; temp _ctx ctx; temp _in data;
                gvars gv; lvar _X (tarray tuint LBLOCKz) Xv)
   SEP  (data_at_ Tsh (tarray tuint 16) Xv;
           data_block sh (intlist_to_bytelist b) data; K_vector gv))
  block_data_order_loop1
  (normal_ret_assert
    (PROP ()
     LOCAL(temp _ctx ctx; temp _i (Vint (Int.repr LBLOCKz));
                temp _a (Vint (nthi (Round regs (nthi b) (LBLOCKz - 1)) 0));
                temp _b (Vint (nthi (Round regs (nthi b) (LBLOCKz - 1)) 1));
                temp _c (Vint (nthi (Round regs (nthi b) (LBLOCKz - 1)) 2));
                temp _d (Vint (nthi (Round regs (nthi b) (LBLOCKz - 1)) 3));
                temp _e (Vint (nthi (Round regs (nthi b) (LBLOCKz - 1)) 4));
                temp _f (Vint (nthi (Round regs (nthi b) (LBLOCKz - 1)) 5));
                temp _g (Vint (nthi (Round regs (nthi b) (LBLOCKz - 1)) 6));
                temp _h (Vint (nthi (Round regs (nthi b) (LBLOCKz - 1)) 7));
                gvars gv; lvar _X (tarray tuint LBLOCKz) Xv)
     SEP (K_vector gv;
            data_at Tsh (tarray tuint LBLOCKz) (map Vint b) Xv;
            data_block sh (intlist_to_bytelist b) data))).
Proof.
unfold block_data_order_loop1.
intros.
simpl nth.
abbreviate_semax.
assert (LBE := LBLOCKz_eq).
forward_for_simple_bound 16
   (EX i:Z,
    PROP ()
    LOCAL  (temp _ctx ctx;
                 temp _data  (offset_val (i*4) data);
                 temp _a (Vint (nthi (Round regs (nthi b) (i - 1)) 0));
                 temp _b (Vint (nthi (Round regs (nthi b) (i - 1)) 1));
                 temp _c (Vint (nthi (Round regs (nthi b) (i - 1)) 2));
                 temp _d (Vint (nthi (Round regs (nthi b) (i - 1)) 3));
                 temp _e (Vint (nthi (Round regs (nthi b) (i - 1)) 4));
                 temp _f (Vint (nthi (Round regs (nthi b) (i - 1)) 5));
                 temp _g (Vint (nthi (Round regs (nthi b) (i - 1)) 6));
                 temp _h (Vint (nthi (Round regs (nthi b) (i - 1)) 7));
                 lvar _X (tarray tuint LBLOCKz) Xv;
                 gvars gv)
     SEP (K_vector gv;
       data_at Tsh (tarray tuint LBLOCKz)
           (map Vint (sublist 0 i b) ++ list_repeat (Z.to_nat (16-i)) Vundef)
            Xv;
       data_block sh (intlist_to_bytelist b) data)).
* (* precondition of loop entails the loop invariant *)
 rewrite Round_equation. rewrite if_true by (compute; auto).
 entailer!. simpl; cancel.
* (* loop body & loop condition preserves loop invariant *)
assert_PROP (data_block sh (intlist_to_bytelist b) data =
   array_at sh (tarray tuchar (Zlength b * 4)) [] 0 (i * 4)
       (sublist 0 (i * 4) (map Vubyte (intlist_to_bytelist b)))
       data *
   data_at sh (tarray tuchar 4)
        (map Vubyte (sublist (i * 4) ((i + 1) * 4) (intlist_to_bytelist b)))
        (offset_val (i * 4) data) *
   array_at sh (tarray tuchar (Zlength b * 4)) [] (i * 4 + 4)
       (Zlength b * 4)
       (sublist (4 + i * 4) (Zlength b * 4)
          (map Vubyte (intlist_to_bytelist b))) data). {
 entailer!.
 unfold data_block.
 unfold data_at at 1.
   erewrite field_at_Tarray
   by (try reflexivity; auto; autorewrite with sublist; Omega1).
   rewrite (split2_array_at _ _ _ 0 (i*4)) by (autorewrite with sublist; omega).
   rewrite (split2_array_at _ _ _ (i*4) (i*4+4)) by (autorewrite with sublist; omega).
   autorewrite with sublist.
  rewrite <- !sepcon_assoc.
  f_equal. f_equal.
  rewrite Zlength_intlist_to_bytelist in H5.
  rewrite array_at_data_at' by (auto with field_compatible; omega).
  simpl.
  autorewrite with sublist.
  fold (tarray tuchar 4). f_equal.
   rewrite <- sublist_map.
  rewrite Z.add_comm, Z.mul_add_distr_r.
  reflexivity.
 rewrite field_address0_offset by auto with field_compatible.
  f_equal. f_equal. simpl. omega.
 }
forward_call (* l = __builtin_read32_reversed(_data) *)
      (offset_val (i*4) data, sh,
         sublist (i*4) ((i+1)*4) (intlist_to_bytelist b)).
 entailer!.
 rewrite H1; cancel.
 autorewrite with sublist; omega.
gather_SEP 3 0 4.
 match goal with |- context [SEPx (?A::_)] =>
  replace A with (data_block sh (intlist_to_bytelist b) data)
    by (rewrite H1,<- !sepcon_assoc; auto)
 end.
 clear H1.
rewrite <- Znth_big_endian_integer by omega.
forward. (* data := data + 4; *)
rewrite LBE.
forward. (* X[i]=l; *)
simpl.
rewrite loop1_aux_lemma1 by Omega1.
(* 1,506,948 1,110,852 *)
(* 1,506,948 1,134,576 *)
unfold K_vector.
assert (i < Zlength K256)
  by (change (Zlength K256) with 64; omega).
forward.  (* Ki=K256[i]; *)
(* 1,811,028 1,406,332 *)
autorewrite with sublist.
subst POSTCONDITION; unfold abbreviate.
replace (i + 1 - 1)%Z with i by omega.
rewrite (Round_equation _ _ i).
rewrite if_false by omega.
forget (nthi b) as M.
replace (M i) with (W M i)
  by (rewrite W_equation; rewrite if_true by omega; auto).
assert_PROP (isptr data) as H3 by entailer!.
change (data_at Tsh (tarray tuint  (Zlength K256)) (map Vint K256) (gv _K256)) with (K_vector gv).
change (tarray tuint LBLOCKz) with (tarray tuint 16).
match goal with |- semax _ (PROPx _ (LOCALx _ (SEPx ?R))) _ _ =>
  semax_frame [  ] R
end.
clear b H1 H.
forget (nthi K256 i) as k.
forget (W M i) as w.
assert (length (Round regs M (i - 1)) = 8)%nat
  by (apply length_Round; auto).
forget (Round regs M (i - 1)) as regs'.
change 16%nat with LBLOCK.
destruct regs' as [ | a [ | b [ | c [ | d [ | e [ | f [ | g [ | h [ | ]]]]]]]]]; inv H.
forward. (* T1 = l + h + Sigma1(e) + Ch(e,f,g) + Ki; *)
rewrite <- Sigma_1_eq, <- Ch_eq, rearrange_aux.
forward. (* T2 = Sigma0(a) + Maj(a,b,c); *)
 rewrite <- Sigma_0_eq, <- Maj_eq.
unfold nthi; simpl nth.
do 8 forward.
entailer!.
unfold nthi; simpl nth.
split3.
+ f_equal. omega.
+ f_equal.  f_equal.
  rewrite rearrange_aux. rewrite rearrange_aux. auto.
+ f_equal. f_equal.
   rewrite (Int.add_commut (Int.add k _)).
   do 5 rewrite Int.add_assoc.
   f_equal. rewrite (Int.add_commut (Int.add k _)).
   rewrite <- Int.add_assoc. auto.
* (* loop invariant & not test implies postcondition *)
autorewrite with sublist.
entailer!.
Qed.


From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Loc.
From PromisingLib Require Import Language.

From PromisingLib Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import MemoryFacts.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.
Require Import Progress.

Require Import MemoryReorder.
Require Import MemoryMerge.
Require Import FulfillStep.
Require Import PromiseConsistent.

Require Import ReorderTView.

Set Implicit Arguments.

Lemma reorder_read_promise_diff
      loc1 ts1 val1 released1 ord1
      loc2 from2 to2 msg2 kind2
      lc0 mem0
      lc1
      lc2 mem2
      (DIFF: (loc1, ts1) <> (loc2, to2))
      (STEP1: Local.read_step lc0 mem0 loc1 ts1 val1 released1 ord1 lc1)
      (STEP2: Local.promise_step lc1 mem0 loc2 from2 to2 msg2 lc2 mem2 kind2):
  exists lc1',
    <<STEP1: Local.promise_step lc0 mem0 loc2 from2 to2 msg2 lc1' mem2 kind2>> /\
    <<STEP2: Local.read_step lc1' mem2 loc1 ts1 val1 released1 ord1 lc2>>.
Proof.
  inv STEP1. inv STEP2. ss.
  exploit MemoryFacts.promise_get1_diff; eauto. i. des.
  esplits; eauto.
Qed.

Lemma lower_closed_timemap_inv
      tm
      mem1 loc from to msg1 msg2 mem2
      (CLOSED: Memory.closed_timemap tm mem2)
      (LOWER: Memory.lower mem1 loc from to msg1 msg2 mem2):
  Memory.closed_timemap tm mem1.
Proof.
  ii. specialize (CLOSED loc0). des.
  revert CLOSED. erewrite Memory.lower_o; eauto. condtac; ss; eauto.
  des. subst. i. inv CLOSED.
  exploit Memory.lower_get0; eauto. i. des. inv MSG_LE. eauto.
Qed.

Lemma lower_closed_view_inv
      view
      mem1 loc from to msg1 msg2 mem2
      (CLOSED: Memory.closed_view view mem2)
      (LOWER: Memory.lower mem1 loc from to msg1 msg2 mem2):
  Memory.closed_view view mem1.
Proof.
  inv CLOSED. econs; eauto using lower_closed_timemap_inv.
Qed.

Lemma lower_closed_message_inv
      msg
      mem1 loc from to msg1 msg2 mem2
      (CLOSED: Memory.closed_message msg mem2)
      (LOWER: Memory.lower mem1 loc from to msg1 msg2 mem2):
  Memory.closed_message msg mem1.
Proof.
  inv CLOSED; eauto.
  econs. inv CLOSED0; eauto.
  econs. eauto using lower_closed_view_inv.
Qed.

Lemma write_na_lower_closed_message_inv
      msg
      ts promises1 mem1 loc from to val promises2 mem2 msgs kinds kind
      (CLOSED: Memory.closed_message msg mem2)
      (KINDS: List.Forall Memory.op_kind_is_lower kinds)
      (KIND: Memory.op_kind_is_lower kind)
      (WRITE: Memory.write_na ts promises1 mem1 loc from to val promises2 mem2 msgs kinds kind):
  Memory.closed_message msg mem1.
Proof.
  induction WRITE.
  - inv WRITE. inv PROMISE; ss.
    eauto using lower_closed_message_inv.
  - inv KINDS. exploit IHWRITE; eauto. i.
    inv WRITE_EX. inv PROMISE; ss.
    eauto using lower_closed_message_inv.
Qed.

Lemma reorder_memory_write_lower_promise
      promises0 mem0 loc1 from1 to1 msg1 promises1 mem1 kind1
      loc2 from2 to2 msg2 promises2 mem2 kind2
      (LE: Memory.le promises0 mem0)
      (KIND1: Memory.op_kind_is_lower kind1)
      (WRITE: Memory.write promises0 mem0 loc1 from1 to1 msg1 promises1 mem1 kind1)
      (PROMISE: Memory.promise promises1 mem1 loc2 from2 to2 msg2 promises2 mem2 kind2):
  exists promises1' mem1',
    (<<PROMISE: Memory.promise promises0 mem0 loc2 from2 to2 msg2 promises1' mem1' kind2>>) /\
    (<<WRITE: Memory.write promises1' mem1' loc1 from1 to1 msg1 promises2 mem2 kind1>>).
Proof.
  inv WRITE.
  destruct (classic ((loc1, to1) = (loc2, to2))).
  { inv H.
    exploit Memory.promise_get0; try exact PROMISE0.
    { destruct kind1; ss. }
    i. des.
    exploit Memory.remove_get0; eauto. i. des. clear GET.
    inv PROMISE.
    - exploit Memory.add_get0; try exact MEM. i. des. congr.
    - exploit Memory.split_get0; try exact MEM. i. des. congr.
    - exploit Memory.lower_get0; try exact PROMISES. i. des. congr.
    - exploit Memory.remove_get0; try exact PROMISES. i. des. congr.
  }

  hexploit Memory.promise_le; try apply LE; eauto. i. des.
  exploit MemoryReorder.remove_promise; try exact REMOVE; eauto. i. des.
  inv PROMISE0; ss. inv x0; ss.
  { exploit MemoryReorder.lower_add; try exact PROMISES; eauto. i. des.
    exploit MemoryReorder.lower_add; try exact MEM; eauto. i. des.
    esplits; eauto. econs; eauto.
    i. exploit Memory.lower_get1; try exact GET; eauto. i. des. eauto.
  }
  { exploit MemoryReorder.lower_split; try exact PROMISES; eauto. i. des.
    exploit MemoryReorder.lower_split; try exact MEM; eauto. i. des.
    unguard; des; try congr.
    { inv FROM1. inv FROM0. inv PROMISE; ss.
      exploit Memory.remove_get0; eauto. i. des.
      exploit Memory.split_get0; try exact PROMISES1; eauto. i. des.
      congr.
    }
    inv FROM3. inv FROM2.
    esplits; eauto.
  }
  { exploit MemoryReorder.lower_lower; try exact PROMISES; eauto. i.
    exploit MemoryReorder.lower_lower; try exact MEM; eauto. i.
    des; subst; try congr.
    esplits; eauto.
  }
  { exploit MemoryReorder.lower_remove; try exact PROMISES; eauto. i. des.
    exploit MemoryReorder.lower_remove; try exact MEM; eauto. i. des.
    esplits; eauto.
  }
Qed.

Lemma reorder_write_lower_promise
      loc1 from1 to1 val1 releasedm1 released1 ord1 kind1
      loc2 from2 to2 msg2 kind2
      lc0 sc0 mem0
      lc1 sc1 mem1
      lc2 mem2
      (WF0: Local.wf lc0 mem0)
      (KIND1: Memory.op_kind_is_lower kind1)
      (ORD1: Ordering.le ord1 Ordering.relaxed)
      (STEP1: Local.write_step lc0 sc0 mem0 loc1 from1 to1 val1 releasedm1 released1 ord1 lc1 sc1 mem1 kind1)
      (STEP2: Local.promise_step lc1 mem1 loc2 from2 to2 msg2 lc2 mem2 kind2):
  exists lc1' mem1',
    (<<STEP1: Local.promise_step lc0 mem0 loc2 from2 to2 msg2 lc1' mem1' kind2>>) /\
    (<<STEP2: Local.write_step lc1' sc0 mem1' loc1 from1 to1 val1 releasedm1 released1 ord1 lc2 sc1 mem2 kind1>>).
Proof.
  inv STEP1. inv STEP2. ss.
  exploit reorder_memory_write_lower_promise; try apply WF0; eauto. i. des.
  esplits.
  - econs; eauto.
    inv WRITE0. inv PROMISE1; ss.
    eapply lower_closed_message_inv; eauto.
  - econs; eauto. destruct ord1; ss.
Qed.

Lemma reorder_memory_write_na_lower_promise
      ts promises0 mem0 loc1 from1 to1 val1 promises1 mem1 msgs1 kinds1 kind1
      loc2 from2 to2 msg2 promises2 mem2 kind2
      (LE: Memory.le promises0 mem0)
      (KINDS1: List.Forall Memory.op_kind_is_lower kinds1)
      (KIND1: Memory.op_kind_is_lower kind1)
      (WRITE: Memory.write_na ts promises0 mem0 loc1 from1 to1 val1 promises1 mem1 msgs1 kinds1 kind1)
      (PROMISE: Memory.promise promises1 mem1 loc2 from2 to2 msg2 promises2 mem2 kind2):
  exists promises1' mem1',
    (<<PROMISE: Memory.promise promises0 mem0 loc2 from2 to2 msg2 promises1' mem1' kind2>>) /\
    (<<WRITE: Memory.write_na ts promises1' mem1' loc1 from1 to1 val1 promises2 mem2 msgs1 kinds1 kind1>>).
Proof.
  induction WRITE.
  { exploit reorder_memory_write_lower_promise; eauto. i. des.
    esplits; eauto.
  }
  inv KINDS1.
  hexploit Memory.write_le; eauto. i. des.
  exploit IHWRITE; eauto. i. des.
  exploit reorder_memory_write_lower_promise; try exact WRITE_EX; eauto. i. des.
  esplits; eauto.
Qed.

Lemma reorder_write_na_lower_promise
      loc1 from1 to1 val1 ord1 msgs1 kinds1 kind1
      loc2 from2 to2 msg2 kind2
      lc0 sc0 mem0
      lc1 sc1 mem1
      lc2 mem2
      (WF0: Local.wf lc0 mem0)
      (KINDS1: List.Forall Memory.op_kind_is_lower kinds1)
      (KIND1: Memory.op_kind_is_lower kind1)
      (ORD1: Ordering.le ord1 Ordering.relaxed)
      (STEP1: Local.write_na_step lc0 sc0 mem0 loc1 from1 to1 val1 ord1
                                  lc1 sc1 mem1 msgs1 kinds1 kind1)
      (STEP2: Local.promise_step lc1 mem1 loc2 from2 to2 msg2 lc2 mem2 kind2):
  exists lc1' mem1',
    (<<STEP1: Local.promise_step lc0 mem0 loc2 from2 to2 msg2 lc1' mem1' kind2>>) /\
    (<<STEP2: Local.write_na_step lc1' sc0 mem1' loc1 from1 to1 val1 ord1
                                  lc2 sc1 mem2 msgs1 kinds1 kind1>>).
Proof.
  inv STEP1. inv STEP2. ss.
  exploit reorder_memory_write_na_lower_promise; try apply WF0; eauto. i. des.
  esplits.
  - econs; eauto.
    eapply write_na_lower_closed_message_inv; eauto.
  - econs; eauto.
Qed.

Lemma reorder_update_lower_promise_diff
      lc0 sc0 mem0
      loc1 ts1 val1 released1 ord1 lc1
      from2 to2 val2 released2 ord2 lc2 sc2 mem2 kind2
      loc3 from3 to3 msg3 lc3 mem3 kind3
      (DIFF: (loc1, ts1) <> (loc3, to3))
      (WF0: Local.wf lc0 mem0)
      (MEM0: Memory.closed mem0)
      (KIND2: Memory.op_kind_is_lower kind2)
      (ORD2: Ordering.le ord2 Ordering.relaxed)
      (STEP1: Local.read_step lc0 mem0 loc1 ts1 val1 released1 ord1 lc1)
      (STEP2: Local.write_step lc1 sc0 mem0 loc1 from2 to2 val2 released1 released2 ord2 lc2 sc2 mem2 kind2)
      (STEP3: Local.promise_step lc2 mem2 loc3 from3 to3 msg3 lc3 mem3 kind3):
  exists lc1' mem1' lc2',
    (<<STEP1: Local.promise_step lc0 mem0 loc3 from3 to3 msg3 lc1' mem1' kind3>>) /\
    (<<STEP2: Local.read_step lc1' mem1' loc1 ts1 val1 released1 ord1 lc2'>>) /\
    (<<STEP3: Local.write_step lc2' sc0 mem1' loc1 from2 to2 val2 released1 released2 ord2 lc3 sc2 mem3 kind2>>).
Proof.
  exploit Local.read_step_future; eauto. i. des.
  exploit reorder_write_lower_promise; try exact STEP2; eauto. i. des.
  exploit reorder_read_promise_diff; try exact STEP1; eauto. i. des.
  esplits; eauto.
Qed.

Lemma reorder_fence_promise
      ordr1 ordw1
      loc2 from2 to2 msg2
      lc0 sc0 mem0
      lc1 sc1
      lc2 mem2
      kind
      (ORDW1: Ordering.le ordw1 Ordering.relaxed)
      (STEP1: Local.fence_step lc0 sc0 ordr1 ordw1 lc1 sc1)
      (STEP2: Local.promise_step lc1 mem0 loc2 from2 to2 msg2 lc2 mem2 kind):
  exists lc1',
    <<STEP1: Local.promise_step lc0 mem0 loc2 from2 to2 msg2 lc1' mem2 kind>> /\
    <<STEP2: Local.fence_step lc1' sc0 ordr1 ordw1 lc2 sc1>>.
Proof.
  inv STEP1. inv STEP2. ss.
  esplits.
  - econs; eauto.
  - econs; eauto.
    + s. i. destruct ordw1; inv ORDW1; inv H.
    + s. i. destruct ordw1; inv ORDW1; inv H.
Qed.

Lemma reorder_is_racy_promise
      loc1 to1 ord1
      loc2 from2 to2 msg2 kind2
      lc0 mem0
      lc2 mem2
      (WF0: Local.wf lc0 mem0)
      (MEM0: Memory.closed mem0)
      (STEP1: Local.is_racy lc0 mem0 loc1 to1 ord1)
      (STEP2: Local.promise_step lc0 mem0 loc2 from2 to2 msg2 lc2 mem2 kind2):
  <<STEP: Local.is_racy lc2 mem2 loc1 to1 ord1>>.
Proof.
  inv STEP1. inv STEP2.
  exploit Memory.promise_future; try exact PROMISE; try apply WF0; eauto. i. des.
  exploit Memory.future_get1; eauto. i. des.
  econs; eauto; ss.
  - destruct (Memory.get loc1 to1 promises2) as [[]|] eqn:X; ss.
    revert X. inv PROMISE; ss.
    + erewrite Memory.add_o; eauto. condtac; ss; try congr.
      i. des. inv X.
      exploit Memory.add_get0; try exact MEM. i. des. congr.
    + erewrite Memory.split_o; eauto. repeat (condtac; ss); try congr.
      * i. des. inv X.
        exploit Memory.split_get0; try exact MEM. i. des. congr.
      * guardH o. i. des. inv X.
        exploit Memory.split_get0; try exact PROMISES. i. des. congr.
    + erewrite Memory.lower_o; eauto. condtac; ss; try congr.
      i. des. inv X.
      exploit Memory.lower_get0; try exact PROMISES. i. des. congr.
    + erewrite Memory.remove_o; eauto. condtac; ss; try congr.
  - inv MSG_LE; ss.
  - i. exploit MSG2; eauto. i. subst. inv MSG_LE. ss.
Qed.

Lemma reorder_racy_read_promise
      loc1 to1 val1 ord1
      loc2 from2 to2 msg2 kind2
      lc0 mem0
      lc2 mem2
      (WF0: Local.wf lc0 mem0)
      (MEM0: Memory.closed mem0)
      (STEP1: Local.racy_read_step lc0 mem0 loc1 to1 val1 ord1)
      (STEP2: Local.promise_step lc0 mem0 loc2 from2 to2 msg2 lc2 mem2 kind2):
  <<STEP: Local.racy_read_step lc2 mem2 loc1 to1 val1 ord1>>.
Proof.
  inv STEP1.
  exploit reorder_is_racy_promise; eauto.
Qed.

Lemma reorder_racy_write_promise
      loc1 to1 ord1
      loc2 from2 to2 msg2 kind2
      lc0 mem0
      lc2 mem2
      (WF0: Local.wf lc0 mem0)
      (MEM0: Memory.closed mem0)
      (STEP1: Local.racy_write_step lc0 mem0 loc1 to1 ord1)
      (STEP2: Local.promise_step lc0 mem0 loc2 from2 to2 msg2 lc2 mem2 kind2)
      (CONS: Local.promise_consistent lc2):
  <<STEP: Local.racy_write_step lc2 mem2 loc1 to1 ord1>>.
Proof.
  inv STEP1.
  exploit reorder_is_racy_promise; eauto.
Qed.

Lemma reorder_racy_update_promise
      loc1 to1 ord1
      loc2 from2 to2 msg2 kind2
      lc0 mem0
      lc2 mem2
      (WF0: Local.wf lc0 mem0)
      (MEM0: Memory.closed mem0)
      (STEP1: Local.racy_write_step lc0 mem0 loc1 to1 ord1)
      (STEP2: Local.promise_step lc0 mem0 loc2 from2 to2 msg2 lc2 mem2 kind2)
      (CONS: Local.promise_consistent lc2):
  <<STEP: Local.racy_write_step lc2 mem2 loc1 to1 ord1>>.
Proof.
  inv STEP1; eauto.
  exploit reorder_is_racy_promise; eauto.
Qed.


From iris.proofmode Require Import coq_tactics reduction.
From iris.proofmode Require Export tactics.
From iris.program_logic Require Import atomic.
From intensional.heap_lang Require Export tactics lifting.
From intensional Require Import notation.
Import uPred.

Lemma tac_wp_expr_eval `{!heapG Σ} Δ s E Φ e e' :
  (∀ (e'':=e'), e = e'') →
  envs_entails Δ (WP e' @ s; E {{ Φ }}) → envs_entails Δ (WP e @ s; E {{ Φ }}).
Proof. by intros ->. Qed.
Lemma tac_twp_expr_eval `{!heapG Σ} Δ s E Φ e e' :
  (∀ (e'':=e'), e = e'') →
  envs_entails Δ (WP e' @ s; E [{ Φ }]) → envs_entails Δ (WP e @ s; E [{ Φ }]).
Proof. by intros ->. Qed.

Tactic Notation "wp_expr_eval" tactic3(t) :=
  iStartProof;
  lazymatch goal with
  | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
    eapply tac_wp_expr_eval;
      [let x := fresh in intros x; t; unfold x; reflexivity|]
  | |- envs_entails _ (twp ?s ?E ?e ?Q) =>
    eapply tac_twp_expr_eval;
      [let x := fresh in intros x; t; unfold x; reflexivity|]
  | _ => fail "wp_expr_eval: not a 'wp'"
  end.

Lemma tac_wp_pure `{!heapG Σ} Δ Δ' s E K e1 e2 φ n Φ :
  PureExec φ n e1 e2 →
  φ →
  MaybeIntoLaterNEnvs n Δ Δ' →
  envs_entails Δ' (WP (fill K e2) @ s; E {{ Φ }}) →
  envs_entails Δ (WP (fill K e1) @ s; E {{ Φ }}).
Proof.
  rewrite envs_entails_eq=> ??? HΔ'. rewrite into_laterN_env_sound /=.
  rewrite HΔ' -lifting.wp_pure_step_later //.
Qed.
Lemma tac_twp_pure `{!heapG Σ} Δ s E K e1 e2 φ n Φ :
  PureExec φ n e1 e2 →
  φ →
  envs_entails Δ (WP (fill K e2) @ s; E [{ Φ }]) →
  envs_entails Δ (WP (fill K e1) @ s; E [{ Φ }]).
Proof.
  rewrite envs_entails_eq=> ?? ->. rewrite -total_lifting.twp_pure_step //.
Qed.

Lemma tac_wp_value `{!heapG Σ} Δ s E Φ v :
  envs_entails Δ (Φ v) → envs_entails Δ (WP (Val v) @ s; E {{ Φ }}).
Proof. rewrite envs_entails_eq=> ->. by apply wp_value. Qed.
Lemma tac_twp_value `{!heapG Σ} Δ s E Φ v :
  envs_entails Δ (Φ v) → envs_entails Δ (WP (Val v) @ s; E [{ Φ }]).
Proof. rewrite envs_entails_eq=> ->. by apply twp_value. Qed.

Ltac wp_expr_simpl := wp_expr_eval simpl.

Ltac wp_value_head :=
  first [eapply tac_wp_value || eapply tac_twp_value].

Ltac wp_finish :=
  wp_expr_simpl;      (* simplify occurences of subst/fill *)
  try wp_value_head;  (* in case we have reached a value, get rid of the WP *)
  pm_prettify.        (* prettify ▷s caused by [MaybeIntoLaterNEnvs] and
                         λs caused by wp_value *)

Ltac solve_vals_compare_safe :=
  (* The first branch is for when we have [vals_compare_safe] in the context.
     The other two branches are for when either one of the branches reduces to
     [True] or we have it in the context. *)
  fast_done || (left; fast_done) || (right; fast_done).

(** The argument [efoc] can be used to specify the construct that should be
reduced. For example, you can write [wp_pure (EIf _ _ _)], which will search
for an [EIf _ _ _] in the expression, and reduce it.

The use of [open_constr] in this tactic is essential. It will convert all holes
(i.e. [_]s) into evars, that later get unified when an occurences is found
(see [unify e' efoc] in the code below). *)
Tactic Notation "wp_pure" open_constr(efoc) :=
  iStartProof;
  lazymatch goal with
  | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
    let e := eval simpl in e in
    reshape_expr e ltac:(fun K e' =>
      unify e' efoc;
      eapply (tac_wp_pure _ _ _ _ K e');
      [iSolveTC                       (* PureExec *)
      |try solve_vals_compare_safe    (* The pure condition for PureExec -- handles trivial goals, including [vals_compare_safe] *)
      |iSolveTC                       (* IntoLaters *)
      |wp_finish                      (* new goal *)
      ])
    || fail "wp_pure: cannot find" efoc "in" e "or" efoc "is not a redex"
  | |- envs_entails _ (twp ?s ?E ?e ?Q) =>
    let e := eval simpl in e in
    reshape_expr e ltac:(fun K e' =>
      unify e' efoc;
      eapply (tac_twp_pure _ _ _ K e');
      [iSolveTC                       (* PureExec *)
      |try solve_vals_compare_safe    (* The pure condition for PureExec *)
      |wp_finish                      (* new goal *)
      ])
    || fail "wp_pure: cannot find" efoc "in" e "or" efoc "is not a redex"
  | _ => fail "wp_pure: not a 'wp'"
  end.

(* TODO: do this in one go, without [repeat]. *)
Ltac wp_pures :=
  iStartProof;
  repeat (wp_pure _; []). (* The `;[]` makes sure that no side-condition
                             magically spawns. *)

(** Unlike [wp_pures], the tactics [wp_rec] and [wp_lam] should also reduce
lambdas/recs that are hidden behind a definition, i.e. they should use
[AsRecV_recv] as a proper instance instead of a [Hint Extern].

We achieve this by putting [AsRecV_recv] in the current environment so that it
can be used as an instance by the typeclass resolution system. We then perform
the reduction, and finally we clear this new hypothesis. *)
Tactic Notation "wp_rec" :=
  let H := fresh in
  assert (H := AsRecV_recv);
  wp_pure (App _ _);
  clear H.

Tactic Notation "wp_if" := wp_pure (If _ _ _).
Tactic Notation "wp_if_true" := wp_pure (If (LitV (LitBool true)) _ _).
Tactic Notation "wp_if_false" := wp_pure (If (LitV (LitBool false)) _ _).
Tactic Notation "wp_unop" := wp_pure (UnOp _ _).
Tactic Notation "wp_binop" := wp_pure (BinOp _ _ _).
Tactic Notation "wp_op" := wp_unop || wp_binop.
Tactic Notation "wp_lam" := wp_rec.
Tactic Notation "wp_let" := wp_pure (Rec BAnon (BNamed _) _); wp_lam.
Tactic Notation "wp_seq" := wp_pure (Rec BAnon BAnon _); wp_lam.
Tactic Notation "wp_proj" := wp_pure (Fst _) || wp_pure (Snd _).
Tactic Notation "wp_case" := wp_pure (Case _ _ _).
Tactic Notation "wp_match" := wp_case; wp_pure (Rec _ _ _); wp_lam.
Tactic Notation "wp_inj" := wp_pure (InjL _) || wp_pure (InjR _).
Tactic Notation "wp_pair" := wp_pure (Pair _ _).
Tactic Notation "wp_closure" := wp_pure (Rec _ _ _).

Lemma tac_wp_bind `{!heapG Σ} K Δ s E Φ e f :
  f = (λ e, fill K e) → (* as an eta expanded hypothesis so that we can `simpl` it *)
  envs_entails Δ (WP e @ s; E {{ v, WP f (Val v) @ s; E {{ Φ }} }})%I →
  envs_entails Δ (WP fill K e @ s; E {{ Φ }}).
Proof. rewrite envs_entails_eq=> -> ->. by apply: wp_bind. Qed.
Lemma tac_twp_bind `{!heapG Σ} K Δ s E Φ e f :
  f = (λ e, fill K e) → (* as an eta expanded hypothesis so that we can `simpl` it *)
  envs_entails Δ (WP e @ s; E [{ v, WP f (Val v) @ s; E [{ Φ }] }])%I →
  envs_entails Δ (WP fill K e @ s; E [{ Φ }]).
Proof. rewrite envs_entails_eq=> -> ->. by apply: twp_bind. Qed.

Ltac wp_bind_core K :=
  lazymatch eval hnf in K with
  | [] => idtac
  | _ => eapply (tac_wp_bind K); [simpl; reflexivity|reduction.pm_prettify]
  end.
Ltac twp_bind_core K :=
  lazymatch eval hnf in K with
  | [] => idtac
  | _ => eapply (tac_twp_bind K); [simpl; reflexivity|reduction.pm_prettify]
  end.

Tactic Notation "wp_bind" open_constr(efoc) :=
  iStartProof;
  lazymatch goal with
  | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
    reshape_expr e ltac:(fun K e' => unify e' efoc; wp_bind_core K)
    || fail "wp_bind: cannot find" efoc "in" e
  | |- envs_entails _ (twp ?s ?E ?e ?Q) =>
    reshape_expr e ltac:(fun K e' => unify e' efoc; twp_bind_core K)
    || fail "wp_bind: cannot find" efoc "in" e
  | _ => fail "wp_bind: not a 'wp'"
  end.

(** Heap tactics *)
Section heap.
Context `{!heapG Σ}.
Implicit Types P Q : iProp Σ.
Implicit Types Φ : val → iProp Σ.
Implicit Types Δ : envs (uPredI (iResUR Σ)).
Implicit Types v : val.
Implicit Types z : Z.

Lemma tac_wp_alloc Δ Δ' s E j K v Φ :
  MaybeIntoLaterNEnvs 1 Δ Δ' →
  (∀ l,
    match envs_app false (Esnoc Enil j (l ↦ v)) Δ' with
    | Some Δ'' =>
       envs_entails Δ'' (WP fill K (Val $ LitV l) @ s; E {{ Φ }})
    | None => False
    end) →
  envs_entails Δ (WP fill K (Alloc (Val v)) @ s; E {{ Φ }}).
Proof.
  rewrite envs_entails_eq=> ? HΔ.
  rewrite -wp_bind. eapply wand_apply; first exact: wp_alloc.
  rewrite left_id into_laterN_env_sound; apply later_mono, forall_intro=> l.
  specialize (HΔ l).
  destruct (envs_app _ _ _) as [Δ''|] eqn:HΔ'; [ | contradiction ].
  rewrite envs_app_sound //; simpl.
  apply wand_intro_l. by rewrite (sep_elim_l (l ↦ v)%I) right_id wand_elim_r.
Qed.
Lemma tac_twp_alloc Δ s E j K v Φ :
  (∀ l,
    match envs_app false (Esnoc Enil j (l ↦ v)) Δ with
    | Some Δ' =>
       envs_entails Δ' (WP fill K (Val $ LitV $ LitLoc l) @ s; E [{ Φ }])
    | None => False
    end) →
  envs_entails Δ (WP fill K (Alloc (Val v)) @ s; E [{ Φ }]).
Proof.
  rewrite envs_entails_eq=> HΔ.
  rewrite -twp_bind. eapply wand_apply; first exact: twp_alloc.
  rewrite left_id. apply forall_intro=> l.
  specialize (HΔ l).
  destruct (envs_app _ _ _) as [Δ''|] eqn:HΔ'; [ | contradiction ].
  rewrite envs_app_sound //; simpl.
  apply wand_intro_l. by rewrite (sep_elim_l (l ↦ v)%I) right_id wand_elim_r.
Qed.

Lemma tac_wp_load Δ Δ' s E i K l q v Φ :
  MaybeIntoLaterNEnvs 1 Δ Δ' →
  envs_lookup i Δ' = Some (false, l ↦{q} v)%I →
  envs_entails Δ' (WP fill K (Val v) @ s; E {{ Φ }}) →
  envs_entails Δ (WP fill K (Load (LitV l)) @ s; E {{ Φ }}).
Proof.
  rewrite envs_entails_eq=> ???.
  rewrite -wp_bind. eapply wand_apply; first exact: wp_load.
  rewrite into_laterN_env_sound -later_sep envs_lookup_split //; simpl.
  by apply later_mono, sep_mono_r, wand_mono.
Qed.
Lemma tac_twp_load Δ s E i K l q v Φ :
  envs_lookup i Δ = Some (false, l ↦{q} v)%I →
  envs_entails Δ (WP fill K (Val v) @ s; E [{ Φ }]) →
  envs_entails Δ (WP fill K (Load (LitV l)) @ s; E [{ Φ }]).
Proof.
  rewrite envs_entails_eq=> ??.
  rewrite -twp_bind. eapply wand_apply; first exact: twp_load.
  rewrite envs_lookup_split //; simpl.
  by apply sep_mono_r, wand_mono.
Qed.

Lemma tac_wp_store Δ Δ' s E i K l v v' Φ :
  MaybeIntoLaterNEnvs 1 Δ Δ' →
  envs_lookup i Δ' = Some (false, l ↦ v)%I →
  match envs_simple_replace i false (Esnoc Enil i (l ↦ v')) Δ' with
  | Some Δ'' => envs_entails Δ'' (WP fill K (Val $ LitV LitUnit) @ s; E {{ Φ }})
  | None => False
  end →
  envs_entails Δ (WP fill K (Store (LitV l) (Val v')) @ s; E {{ Φ }}).
Proof.
  rewrite envs_entails_eq=> ???.
  destruct (envs_simple_replace _ _ _) as [Δ''|] eqn:HΔ''; [ | contradiction ].
  rewrite -wp_bind. eapply wand_apply; first by eapply wp_store.
  rewrite into_laterN_env_sound -later_sep envs_simple_replace_sound //; simpl.
  rewrite right_id. by apply later_mono, sep_mono_r, wand_mono.
Qed.
Lemma tac_twp_store Δ s E i K l v v' Φ :
  envs_lookup i Δ = Some (false, l ↦ v)%I →
  match envs_simple_replace i false (Esnoc Enil i (l ↦ v')) Δ with
  | Some Δ' => envs_entails Δ' (WP fill K (Val $ LitV LitUnit) @ s; E [{ Φ }])
  | None => False
  end →
  envs_entails Δ (WP fill K (Store (LitV l) v') @ s; E [{ Φ }]).
Proof.
  rewrite envs_entails_eq. intros.
  destruct (envs_simple_replace _ _ _) as [Δ''|] eqn:HΔ''; [ | contradiction ].
  rewrite -twp_bind. eapply wand_apply; first by eapply twp_store.
  rewrite envs_simple_replace_sound //; simpl.
  rewrite right_id. by apply sep_mono_r, wand_mono.
Qed.

Lemma tac_wp_cmpxchg Δ Δ' s E i K l v v1 v2 Φ :
  MaybeIntoLaterNEnvs 1 Δ Δ' →
  envs_lookup i Δ' = Some (false, l ↦ v)%I →
  vals_compare_safe v v1 →
  match envs_simple_replace i false (Esnoc Enil i (l ↦ v2)) Δ' with
  | Some Δ'' =>
     v = v1 →
     envs_entails Δ'' (WP fill K (Val $ PairV v (LitV $ LitBool true)) @ s; E {{ Φ }})
  | None => False
  end →
  (v ≠ v1 →
   envs_entails Δ' (WP fill K (Val $ PairV v (LitV $ LitBool false)) @ s; E {{ Φ }})) →
  envs_entails Δ (WP fill K (CmpXchg (LitV l) (Val v1) (Val v2)) @ s; E {{ Φ }}).
Proof.
  rewrite envs_entails_eq=> ??? Hsuc Hfail.
  destruct (envs_simple_replace _ _ _ _) as [Δ''|] eqn:HΔ''; [ | contradiction ].
  destruct (decide (v = v1)) as [Heq|Hne].
  - rewrite -wp_bind. eapply wand_apply.
    { eapply wp_cmpxchg_suc; eauto. }
    rewrite into_laterN_env_sound -later_sep /= {1}envs_simple_replace_sound //; simpl.
    apply later_mono, sep_mono_r. rewrite right_id. apply wand_mono; auto.
  - rewrite -wp_bind. eapply wand_apply.
    { eapply wp_cmpxchg_fail; eauto. }
    rewrite into_laterN_env_sound -later_sep /= {1}envs_lookup_split //; simpl.
    apply later_mono, sep_mono_r. apply wand_mono; auto.
Qed.
Lemma tac_twp_cmpxchg Δ s E i K l v v1 v2 Φ :
  envs_lookup i Δ = Some (false, l ↦ v)%I →
  vals_compare_safe v v1 →
  match envs_simple_replace i false (Esnoc Enil i (l ↦ v2)) Δ with
  | Some Δ' =>
     v = v1 →
     envs_entails Δ' (WP fill K (Val $ PairV v (LitV $ LitBool true)) @ s; E [{ Φ }])
  | None => False
  end →
  (v ≠ v1 →
   envs_entails Δ (WP fill K (Val $ PairV v (LitV $ LitBool false)) @ s; E [{ Φ }])) →
  envs_entails Δ (WP fill K (CmpXchg (LitV l) v1 v2) @ s; E [{ Φ }]).
Proof.
  rewrite envs_entails_eq=> ?? Hsuc Hfail.
  destruct (envs_simple_replace _ _ _ _) as [Δ''|] eqn:HΔ''; [ | contradiction ].
  destruct (decide (v = v1)) as [Heq|Hne].
  - rewrite -twp_bind. eapply wand_apply.
    { eapply twp_cmpxchg_suc; eauto. }
    rewrite /= {1}envs_simple_replace_sound //; simpl.
    apply sep_mono_r. rewrite right_id. apply wand_mono; auto.
  - rewrite -twp_bind. eapply wand_apply.
    { eapply twp_cmpxchg_fail; eauto. }
    rewrite /= {1}envs_lookup_split //; simpl.
    apply sep_mono_r. apply wand_mono; auto.
Qed.

Lemma tac_wp_cmpxchg_fail Δ Δ' s E i K l q v v1 v2 Φ :
  MaybeIntoLaterNEnvs 1 Δ Δ' →
  envs_lookup i Δ' = Some (false, l ↦{q} v)%I →
  v ≠ v1 → vals_compare_safe v v1 →
  envs_entails Δ' (WP fill K (Val $ PairV v (LitV $ LitBool false)) @ s; E {{ Φ }}) →
  envs_entails Δ (WP fill K (CmpXchg (LitV l) v1 v2) @ s; E {{ Φ }}).
Proof.
  rewrite envs_entails_eq=> ?????.
  rewrite -wp_bind. eapply wand_apply; first exact: wp_cmpxchg_fail.
  rewrite into_laterN_env_sound -later_sep envs_lookup_split //; simpl.
  by apply later_mono, sep_mono_r, wand_mono.
Qed.
Lemma tac_twp_cmpxchg_fail Δ s E i K l q v v1 v2 Φ :
  envs_lookup i Δ = Some (false, l ↦{q} v)%I →
  v ≠ v1 → vals_compare_safe v v1 →
  envs_entails Δ (WP fill K (Val $ PairV v (LitV $ LitBool false)) @ s; E [{ Φ }]) →
  envs_entails Δ (WP fill K (CmpXchg (LitV l) v1 v2) @ s; E [{ Φ }]).
Proof.
  rewrite envs_entails_eq. intros. rewrite -twp_bind.
  eapply wand_apply; first exact: twp_cmpxchg_fail.
  rewrite envs_lookup_split //=. by do 2 f_equiv.
Qed.

Lemma tac_wp_cmpxchg_suc Δ Δ' s E i K l v v1 v2 Φ :
  MaybeIntoLaterNEnvs 1 Δ Δ' →
  envs_lookup i Δ' = Some (false, l ↦ v)%I →
  v = v1 → vals_compare_safe v v1 →
  match envs_simple_replace i false (Esnoc Enil i (l ↦ v2)) Δ' with
  | Some Δ'' =>
     envs_entails Δ'' (WP fill K (Val $ PairV v (LitV $ LitBool true)) @ s; E {{ Φ }})
  | None => False
  end →
  envs_entails Δ (WP fill K (CmpXchg (LitV l) v1 v2) @ s; E {{ Φ }}).
Proof.
  rewrite envs_entails_eq=> ?????; subst.
  destruct (envs_simple_replace _ _ _) as [Δ''|] eqn:HΔ''; [ | contradiction ].
  rewrite -wp_bind. eapply wand_apply.
  { eapply wp_cmpxchg_suc; eauto. }
  rewrite into_laterN_env_sound -later_sep envs_simple_replace_sound //; simpl.
  rewrite right_id. by apply later_mono, sep_mono_r, wand_mono.
Qed.
Lemma tac_twp_cmpxchg_suc Δ s E i K l v v1 v2 Φ :
  envs_lookup i Δ = Some (false, l ↦ v)%I →
  v = v1 → vals_compare_safe v v1 →
  match envs_simple_replace i false (Esnoc Enil i (l ↦ v2)) Δ with
  | Some Δ' =>
     envs_entails Δ' (WP fill K (Val $ PairV v (LitV $ LitBool true)) @ s; E [{ Φ }])
  | None => False
  end →
  envs_entails Δ (WP fill K (CmpXchg (LitV l) v1 v2) @ s; E [{ Φ }]).
Proof.
  rewrite envs_entails_eq=>????; subst.
  destruct (envs_simple_replace _ _ _) as [Δ''|] eqn:HΔ''; [ | contradiction ].
  rewrite -twp_bind. eapply wand_apply.
  { eapply twp_cmpxchg_suc; eauto. }
  rewrite envs_simple_replace_sound //; simpl.
  rewrite right_id. by apply sep_mono_r, wand_mono.
Qed.

Lemma tac_wp_faa Δ Δ' s E i K l z1 z2 Φ :
  MaybeIntoLaterNEnvs 1 Δ Δ' →
  envs_lookup i Δ' = Some (false, l ↦ LitV z1)%I →
  match envs_simple_replace i false (Esnoc Enil i (l ↦ LitV (LitInt (z1 + z2)))) Δ' with
  | Some Δ'' => envs_entails Δ'' (WP fill K (Val $ LitV z1) @ s; E {{ Φ }})
  | None => False
  end →
  envs_entails Δ (WP fill K (FAA (LitV l) (LitV z2)) @ s; E {{ Φ }}).
Proof.
  rewrite envs_entails_eq=> ???.
  destruct (envs_simple_replace _ _ _) as [Δ''|] eqn:HΔ''; [ | contradiction ].
  rewrite -wp_bind. eapply wand_apply; first exact: (wp_faa _ _ _ z1 z2).
  rewrite into_laterN_env_sound -later_sep envs_simple_replace_sound //; simpl.
  rewrite right_id. by apply later_mono, sep_mono_r, wand_mono.
Qed.
Lemma tac_twp_faa Δ s E i K l z1 z2 Φ :
  envs_lookup i Δ = Some (false, l ↦ LitV z1)%I →
  match envs_simple_replace i false (Esnoc Enil i (l ↦ LitV (LitInt (z1 + z2)))) Δ with
  | Some Δ' => envs_entails Δ' (WP fill K (Val $ LitV z1) @ s; E [{ Φ }])
  | None => False
  end →
  envs_entails Δ (WP fill K (FAA (LitV l) (LitV z2)) @ s; E [{ Φ }]).
Proof.
  rewrite envs_entails_eq=> ??.
  destruct (envs_simple_replace _ _ _) as [Δ'|] eqn:HΔ'; [ | contradiction ].
  rewrite -twp_bind. eapply wand_apply; first exact: (twp_faa _ _ _ z1 z2).
  rewrite envs_simple_replace_sound //; simpl.
  rewrite right_id. by apply sep_mono_r, wand_mono.
Qed.
End heap.

(** Evaluate [lem] to a hypothesis [H] that can be applied, and then run
[wp_bind K; tac H] for every possible evaluation context.  [tac] can do
[iApplyHyp H] to actually apply the hypothesis.  TC resolution of [lem] premises
happens *after* [tac H] got executed. *)
Tactic Notation "wp_apply_core" open_constr(lem) tactic3(tac) :=
  wp_pures;
  iPoseProofCore lem as false (fun H =>
    lazymatch goal with
    | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
      reshape_expr e ltac:(fun K e' =>
        wp_bind_core K; tac H) ||
      lazymatch iTypeOf H with
      | Some (_,?P) => fail "wp_apply: cannot apply" P
      end
    | |- envs_entails _ (twp ?s ?E ?e ?Q) =>
      reshape_expr e ltac:(fun K e' =>
        twp_bind_core K; tac H) ||
      lazymatch iTypeOf H with
      | Some (_,?P) => fail "wp_apply: cannot apply" P
      end
    | _ => fail "wp_apply: not a 'wp'"
    end).
Tactic Notation "wp_apply" open_constr(lem) :=
  wp_apply_core lem (fun H => iApplyHyp H; try iNext; try wp_expr_simpl).
(** Tactic tailored for atomic triples: the first, simple one just runs
[iAuIntro] on the goal, as atomic triples always have an atomic update as their
premise.  The second one additionaly does some framing: it gets rid of [Hs] from
the context, which is intended to be the non-laterable assertions that iAuIntro
would choke on.  You get them all back in the continuation of the atomic
operation. *)
Tactic Notation "awp_apply" open_constr(lem) :=
  wp_apply_core lem (fun H => iApplyHyp H);
  last iAuIntro.
Tactic Notation "awp_apply" open_constr(lem) "without" constr(Hs) :=
  wp_apply_core lem (fun H => iApply wp_frame_wand_l; iSplitL Hs; [iAccu|iApplyHyp H]);
  last iAuIntro.

Tactic Notation "wp_alloc" ident(l) "as" constr(H) :=
  let Htmp := iFresh in
  let finish _ :=
    first [intros l | fail 1 "wp_alloc:" l "not fresh"];
    pm_reduce;
    lazymatch goal with
    | |- False => fail 1 "wp_alloc:" H "not fresh"
    | _ => iDestructHyp Htmp as H; wp_finish
    end in
  wp_pures;
  (** The code first tries to use allocation lemma for a single reference,
     ie, [tac_wp_alloc] (respectively, [tac_twp_alloc]).
     If that fails, it tries to use the lemma [tac_wp_allocN]
     (respectively, [tac_twp_allocN]) for allocating an array.
     Notice that we could have used the array allocation lemma also for single
     references. However, that would produce the resource l ↦∗ [v] instead of
     l ↦ v for single references. These are logically equivalent assertions
     but are not equal. *)
  lazymatch goal with
  | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
    let process_single _ :=
        first
          [reshape_expr e ltac:(fun K e' => eapply (tac_wp_alloc _ _ _ _ Htmp K))
          |fail 1 "wp_alloc: cannot find 'Alloc' in" e];
        [iSolveTC
        |finish ()]
    in (process_single ())
  | |- envs_entails _ (twp ?s ?E ?e ?Q) =>
    let process_single _ :=
        first
          [reshape_expr e ltac:(fun K e' => eapply (tac_twp_alloc _ _ _ Htmp K))
          |fail 1 "wp_alloc: cannot find 'Alloc' in" e];
        finish ()
    in (process_single ())
  | _ => fail "wp_alloc: not a 'wp'"
  end.

Tactic Notation "wp_alloc" ident(l) :=
  wp_alloc l as "?".

Tactic Notation "wp_load" :=
  let solve_mapsto _ :=
    let l := match goal with |- _ = Some (_, (?l ↦{_} _)%I) => l end in
    iAssumptionCore || fail "wp_load: cannot find" l "↦ ?" in
  wp_pures;
  lazymatch goal with
  | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
    first
      [reshape_expr e ltac:(fun K e' => eapply (tac_wp_load _ _ _ _ _ K))
      |fail 1 "wp_load: cannot find 'Load' in" e];
    [iSolveTC
    |solve_mapsto ()
    |wp_finish]
  | |- envs_entails _ (twp ?s ?E ?e ?Q) =>
    first
      [reshape_expr e ltac:(fun K e' => eapply (tac_twp_load _ _ _ _ K))
      |fail 1 "wp_load: cannot find 'Load' in" e];
    [solve_mapsto ()
    |wp_finish]
  | _ => fail "wp_load: not a 'wp'"
  end.

Tactic Notation "wp_store" :=
  let solve_mapsto _ :=
    let l := match goal with |- _ = Some (_, (?l ↦{_} _)%I) => l end in
    iAssumptionCore || fail "wp_store: cannot find" l "↦ ?" in
  wp_pures;
  lazymatch goal with
  | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
    first
      [reshape_expr e ltac:(fun K e' => eapply (tac_wp_store _ _ _ _ _ K))
      |fail 1 "wp_store: cannot find 'Store' in" e];
    [iSolveTC
    |solve_mapsto ()
    |pm_reduce; first [wp_seq|wp_finish]]
  | |- envs_entails _ (twp ?s ?E ?e ?Q) =>
    first
      [reshape_expr e ltac:(fun K e' => eapply (tac_twp_store _ _ _ _ K))
      |fail 1 "wp_store: cannot find 'Store' in" e];
    [solve_mapsto ()
    |pm_reduce; first [wp_seq|wp_finish]]
  | _ => fail "wp_store: not a 'wp'"
  end.

Tactic Notation "wp_cmpxchg" "as" simple_intropattern(H1) "|" simple_intropattern(H2) :=
  let solve_mapsto _ :=
    let l := match goal with |- _ = Some (_, (?l ↦{_} _)%I) => l end in
    iAssumptionCore || fail "wp_cmpxchg: cannot find" l "↦ ?" in
  wp_pures;
  lazymatch goal with
  | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
    first
      [reshape_expr e ltac:(fun K e' => eapply (tac_wp_cmpxchg _ _ _ _ _ K))
      |fail 1 "wp_cmpxchg: cannot find 'CmpXchg' in" e];
    [iSolveTC
    |solve_mapsto ()
    |try solve_vals_compare_safe
    |pm_reduce; intros H1; wp_finish
    |intros H2; wp_finish]
  | |- envs_entails _ (twp ?E ?e ?Q) =>
    first
      [reshape_expr e ltac:(fun K e' => eapply (tac_twp_cmpxchg _ _ _ _ K))
      |fail 1 "wp_cmpxchg: cannot find 'CmpXchg' in" e];
    [solve_mapsto ()
    |try solve_vals_compare_safe
    |pm_reduce; intros H1; wp_finish
    |intros H2; wp_finish]
  | _ => fail "wp_cmpxchg: not a 'wp'"
  end.

Tactic Notation "wp_cmpxchg_fail" :=
  let solve_mapsto _ :=
    let l := match goal with |- _ = Some (_, (?l ↦{_} _)%I) => l end in
    iAssumptionCore || fail "wp_cmpxchg_fail: cannot find" l "↦ ?" in
  wp_pures;
  lazymatch goal with
  | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
    first
      [reshape_expr e ltac:(fun K e' => eapply (tac_wp_cmpxchg_fail _ _ _ _ _ K))
      |fail 1 "wp_cmpxchg_fail: cannot find 'CmpXchg' in" e];
    [iSolveTC
    |solve_mapsto ()
    |try (simpl; congruence) (* value inequality *)
    |try solve_vals_compare_safe
    |wp_finish]
  | |- envs_entails _ (twp ?s ?E ?e ?Q) =>
    first
      [reshape_expr e ltac:(fun K e' => eapply (tac_twp_cmpxchg_fail _ _ _ _ K))
      |fail 1 "wp_cmpxchg_fail: cannot find 'CmpXchg' in" e];
    [solve_mapsto ()
    |try (simpl; congruence) (* value inequality *)
    |try solve_vals_compare_safe
    |wp_finish]
  | _ => fail "wp_cmpxchg_fail: not a 'wp'"
  end.

Tactic Notation "wp_cmpxchg_suc" :=
  let solve_mapsto _ :=
    let l := match goal with |- _ = Some (_, (?l ↦{_} _)%I) => l end in
    iAssumptionCore || fail "wp_cmpxchg_suc: cannot find" l "↦ ?" in
  wp_pures;
  lazymatch goal with
  | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
    first
      [reshape_expr e ltac:(fun K e' => eapply (tac_wp_cmpxchg_suc _ _ _ _ _ K))
      |fail 1 "wp_cmpxchg_suc: cannot find 'CmpXchg' in" e];
    [iSolveTC
    |solve_mapsto ()
    |try (simpl; congruence) (* value equality *)
    |try solve_vals_compare_safe
    |pm_reduce; wp_finish]
  | |- envs_entails _ (twp ?s ?E ?e ?Q) =>
    first
      [reshape_expr e ltac:(fun K e' => eapply (tac_twp_cmpxchg_suc _ _ _ _ K))
      |fail 1 "wp_cmpxchg_suc: cannot find 'CmpXchg' in" e];
    [solve_mapsto ()
    |try (simpl; congruence) (* value equality *)
    |try solve_vals_compare_safe
    |pm_reduce; wp_finish]
  | _ => fail "wp_cmpxchg_suc: not a 'wp'"
  end.

Tactic Notation "wp_faa" :=
  let solve_mapsto _ :=
    let l := match goal with |- _ = Some (_, (?l ↦{_} _)%I) => l end in
    iAssumptionCore || fail "wp_faa: cannot find" l "↦ ?" in
  wp_pures;
  lazymatch goal with
  | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
    first
      [reshape_expr e ltac:(fun K e' => eapply (tac_wp_faa _ _ _ _ _ K))
      |fail 1 "wp_faa: cannot find 'FAA' in" e];
    [iSolveTC
    |solve_mapsto ()
    |pm_reduce; wp_finish]
  | |- envs_entails _ (twp ?s ?E ?e ?Q) =>
    first
      [reshape_expr e ltac:(fun K e' => eapply (tac_twp_faa _ _ _ _ K))
      |fail 1 "wp_faa: cannot find 'FAA' in" e];
    [solve_mapsto ()
    |pm_reduce; wp_finish]
  | _ => fail "wp_faa: not a 'wp'"
  end.


Require Import VST.floyd.proofauto.
Require Import hmacdrbg.HMAC_DRBG_algorithms.
Require Import hmacdrbg.HMAC_DRBG_common_lemmas.
Require Import hmacdrbg.spec_hmac_drbg.

Lemma ReseedRes: forall X r v, @return_value_relate_result X r (Vint v) -> Int.eq v (Int.repr (-20864)) = false.
Proof. intros.
  unfold return_value_relate_result in H.
  destruct r. inversion H; reflexivity.
  destruct e; inversion H; try reflexivity.
  apply Int.eq_false. eapply ENT_GenErrAx.
Qed.

Lemma hmac_interp_empty d r: hmac_interp d r |-- md_empty r.
Proof.
destruct d; simpl. auto.
eapply derives_trans. apply md_relate_full. apply md_full_empty.
apply md_full_empty.
Qed.

Lemma instantiate256_reseed d s pr_flag rc ri (ZLc'256F : (Zlength d >? 256) = false):
      instantiate_function_256 s pr_flag  d =
      mbedtls_HMAC256_DRBG_reseed_function s (HMAC256DRBGabs initial_key initial_value rc 48 pr_flag ri) d.
Proof. intros.
  unfold instantiate_function_256; simpl.
  rewrite ZLc'256F, andb_negb_r.
  assert (MaxString': Zlength d >? max_personalization_string_length = false).
  { apply Zgt_is_gt_bool_f. apply Zgt_is_gt_bool_f in ZLc'256F.
    unfold max_personalization_string_length. omega. }
  rewrite MaxString' in *; trivial.
Qed.


Require Import ch2o.prelude.base.
Require Import ch2o.prelude.option.
Require Import Coq.Lists.List.
Require Import Coq.Program.Equality.
Require Import Coq.Strings.String.

Require Import common.
Require Import Ast.
Require Import Store.
Require Import Entities.

Open Scope string_scope.

Section step.
Context (P: program).

Inductive step : heap * list frame * expr -> heap * list frame * expr -> Prop :=
| step_hole : forall χ χ' φ φ' σ e e' ectx,
    step (χ, φ::σ, e) (χ', φ'::σ, e') ->
    step (χ, φ::σ, fill_hole ectx e) (χ', φ'::σ, fill_hole ectx e')

| step_seq : forall χ σ t e,
    step (χ, σ, expr_seq (expr_temp t) e)
         (χ, σ, e)

| step_recover : forall χ σ t,
    step (χ, σ, expr_recover (expr_temp t))
         (χ, σ, (expr_temp t))

| step_local : forall χ φ σ t φ' x,
    not (t ∈ φ) ->
    φ' = <[t := φ !!! x]> φ ->
    step (χ, φ::σ, expr_local x)
         (χ, φ'::σ, expr_temp t)

| step_asn_local : forall χ φ φ' σ t t' x,
    not (t' ∈ φ) ->
    φ' = <[t' := φ !!! x]>(<[x := φ !!! t]>φ) ->
    step (χ, φ::σ, expr_assign_local x (expr_temp t))
         (χ, φ'::σ, expr_temp t')

| step_field : forall χ φ φ' σ t t' f ω,
    not (t' ∈ φ) ->
    v_addr ω = φ !!! t ->
    φ' = <[t' := χ !!! (ω, f)]> φ ->
    step (χ, φ::σ, expr_field (expr_temp t) f)
         (χ, φ'::σ, expr_temp t')

| step_asn_field : forall χ χ' φ φ' σ t t' t'' f ω,
    not (t'' ∈ φ) ->
    v_addr ω = φ !!! t ->
    φ' = <[t'' := χ !!! (ω, f)]>φ ->
    χ' = <[(ω, f) := φ !!! t']>χ ->

    step (χ, φ::σ, expr_assign_field (expr_temp t) f (expr_temp t'))
           (χ', φ'::σ, expr_temp t'')

| step_sync : forall χ φ φ' φ'' σ ectx t m e xs ts ω,
    v_addr ω = φ !!! t ->
    Some (xs, e) = (obj <- χ !! ω; lookup_Mr P obj.(name) m) ->

    φ'' = {|
      method := m;
      locals := <[* xs := map (φ !!!) ts ]>(<["this" := v_addr ω]>empty);
      hole := expr_hole_id
    |} ->

    φ' = {|
      method := φ.(method);
      locals := φ.(locals);
      hole := ectx
    |} ->

    step (χ, φ :: σ, fill_hole ectx (expr_call (expr_temp t) m (list_expr_temps ts)))
         (χ, φ'' :: φ' :: σ, e)

| step_ctor : forall χ χ' ω φ φ' φ'' σ ectx kt k e fs xs ts,
    not (ω ∈ heap_dom χ) ->
    Some fs = lookup_Fs P kt ->
    Some (xs, e) = lookup_Mr P kt k ->

    χ' = <[ω := {| name := kt; fields := <[* fs := v_null ]>empty |}]>χ ->

    φ'' = {|
      method := k;
      locals := <[* xs := map (φ !!!) ts ]>(<["this" := v_addr ω]>empty);
      hole := expr_hole_id
    |} ->

    φ' = {|
      method := φ.(method);
      locals := φ.(locals);
      hole := ectx
    |} ->

    step (χ, φ :: σ, fill_hole ectx (expr_ctor kt k (list_expr_temps ts)))
         (χ', φ'' :: φ' :: σ, e)

| step_return : forall χ φ φ' φ'' t t' σ,
    not (t' ∈ φ) ->
    φ'' = {|
        method := φ.(method);
        locals := <[t' := φ' !!! t]>φ.(locals);
        hole := expr_hole_id;
    |} ->
    step (χ, φ' :: φ :: σ, expr_temp t)
         (χ, φ'' :: σ, fill_hole φ.(hole) (expr_temp t'))

| step_null : forall χ φ φ' σ t,
    not (t ∈ φ) ->
    φ' = <[t := v_null]>φ ->
    step (χ, φ::σ, expr_null)
         (χ, φ'::σ, expr_temp t)

| step_field_null : forall χ φ σ t f,
    v_null = φ !!! t ->

    step (χ, φ::σ, expr_field (expr_temp t) f)
         (χ, φ::σ, expr_temp t)

| step_asn_field_null : forall χ φ σ t t' f,
    v_null = φ !!! t ->

    step (χ, φ::σ, expr_assign_field (expr_temp t) f (expr_temp t'))
         (χ, φ::σ, expr_temp t)

| step_call_null : forall χ φ σ t n ts,
    v_null = φ !!! t ->

    step (χ, φ::σ, expr_call (expr_temp t) n (list_expr_temps ts))
         (χ, φ::σ, expr_temp t)
.

End step.


(*
 * Copyright (c) 2017-present,
 * Programming Research Laboratory (ROPAS), Seoul National University, Korea
 * This software is distributed under the term of the BSD-3 clause license.
 *)
(** * Concrete Domain *)

Set Implicit Arguments.

Require Import ZArith OrderedTypeEx.
Require Import Monad vgtac VocabA Syn DFSetAVL DFMapAVL InterCfg DLat
        DUnit DNat DZ DStr DList DSum DMap DProd DPow Global.
Require DMem.
Require Import SemCommon.

Local Open Scope type.

Module Step <: KEY := Nat.

(** CallId is a step number on the call node, which is used to
distinguish function calls in concrete semantics. *)

Module CallId <: KEY := Step.

Module Proc <: KEY := DStr.
Module GVar <: KEY := DStr.
Module LVar <: KEY := ProdKey3 CallId Proc DStr.
Module Var <: KEY := SumKey2 GVar LVar.

Module ExtAllocsite <: KEY := SumKey2 Unit Proc.
Module Allocsite <: KEY := SumKey2 InterNode ExtAllocsite.
Module OSS <: KEY := ProdKey3 DZ DZ DZ.
Module Region <: KEY := ProdKey3 Step Allocsite OSS.
Module VarRegion <: KEY := SumKey2 Var Region.

Module Field <: KEY := DStr.
Module Fields <: KEY := ListKey Field.

Module Loc <: KEY := ProdKey2 VarRegion Fields.

Definition val_t := Z.t + Loc.t + Proc.t.

(** Auxiliary alias functions for value *)

Definition val_of_z (z : Z) : val_t := inl (inl z).
Definition val_of_loc (l : Loc.t) : val_t := inl (inr l).
Definition val_of_proc (p : Proc.t) : val_t := inr p.

Definition loc_of_gvar (x : vid_t) (fs : Fields.t) : Loc.t :=
  (VarRegion.Inl (Var.Inl x), fs).
Definition loc_of_lvar (cid : CallId.t) (p : Proc.t) (x : vid_t) (fs : Fields.t)
: Loc.t :=
  (VarRegion.Inl (Var.Inr (cid, p, x)), fs).
Definition loc_of_alloc (step : Step.t) (alloc : Allocsite.t) (oss : OSS.t)
  (fs : Fields.t) : Loc.t :=
  (VarRegion.Inr (step, alloc, oss), fs).

Module M := FMapAVL'.Make Loc.
Definition mem_t := M.t val_t.

(** Stack is a list of call stack information, which is a product of
callee, (optional) return location, and caller's CallId for
restorations of CallId on return statements.  *)

Definition stack1 : Type := Proc.t * option Loc.t * CallId.t.

Definition stack_t : Type := list stack1.

Definition callee_t := option Proc.t.

(** intra_node_state_t represents CallId (call node's step numbers to
distinguish local variables), an optional and temporary callee name
after call statements, memory, and stack. *)

Definition intra_node_state_t := CallId.t * callee_t * mem_t * stack_t.

Definition call_nodes_t := list InterNode.t.

Definition inter_node_state_t :=
  InterNode.t * Step.t * call_nodes_t * intra_node_state_t.

Definition state_t := mem_pos * inter_node_state_t.

Inductive not_appear_stack f : stack_t -> Prop :=
| not_appear_nil : not_appear_stack f nil
| not_appear_cons :
    forall s (Hs : not_appear_stack f s) f' (Hf' : ~ Proc.eq f f') opt_loc cid,
      not_appear_stack f ((f', opt_loc, cid) :: s).

Inductive appear_once_stack f : stack_t -> Prop :=
| appear_once_nil :
    forall s (Hs : not_appear_stack f s) f' (Hf' : Proc.eq f f') opt_loc cid,
      appear_once_stack f ((f', opt_loc, cid) :: s)
| appear_once_cons :
    forall s (Hs : appear_once_stack f s) f' (Hf' : ~ Proc.eq f f') opt_loc cid,
      appear_once_stack f ((f', opt_loc, cid) :: s).

Definition wf_non_rec_stack g :=
  forall f stk (Hf : Global.G.is_rec f g = false), appear_once_stack f stk.

Local Close Scope type.


(* This file is an automatic translation, the licence of the source can be found here: *)
(* https://github.com/herd/herdtools7/blob/master/LICENSE.txt *)
(* Translation of model Model *)
From Coq Require Import Relations Ensembles String.
From RelationAlgebra Require Import lattice prop monoid rel kat.
From Catincoq.lib Require Import Cat proprel.
Section Model.
Variable c : candidate.
Definition events := events c.
Definition R := R c.
Definition W := W c.
Definition IW := IW c.
Definition FW := FW c.
Definition B := B c.
Definition RMW := RMW c.
Definition F := F c.
Definition rf := rf c.
Definition po := po c.
Definition int := int c.
Definition ext := ext c.
Definition loc := loc c.
Definition addr := addr c.
Definition data := data c.
Definition ctrl := ctrl c.
Definition amo := amo c.
Definition rmw := rmw c.
Definition unknown_set := unknown_set c.
Definition unknown_relation := unknown_relation c.
Definition M := R ⊔ W.
Definition emptyset : set events := empty.
Definition classes_loc : set events -> Ensemble (Ensemble events) := partition loc.
Definition X := unknown_set "X".
Definition tag2events := unknown_relation "tag2events".
Definition emptyset_0 : set events := domain 0.
Definition partition := classes_loc.
Definition tag2instrs := tag2events.
Definition po_loc := po ⊓ loc.
Definition rfe := rf ⊓ ext.
Definition rfi := rf ⊓ int.
Definition co0 := loc ⊓ ([IW] ⋅ top ⋅ [(W ⊓ !IW)] ⊔ [(W ⊓ !FW)] ⋅ top ⋅ [FW]).
Definition toid (s : set events) : relation events := [s].
Definition fencerel (B : set events) := (po ⊓ [top] ⋅ top ⋅ [B]) ⋅ po.
Definition ctrlcfence (CFENCE : set events) := (ctrl ⊓ [top] ⋅ top ⋅ [CFENCE]) ⋅ po.
Definition imply (A : relation events) (B : relation events) := !A ⊔ B.
Definition nodetour (R1 : relation events) (R2 : relation events) (R3 : relation events) := R1 ⊓ !(R2 ⋅ R3).
Definition singlestep (R : relation events) := nodetour R R R.
(* Definition of map already included in the prelude *)
Definition LKW := (*failed: try LKW with emptyset_0*) emptyset_0.
Definition A := ((*successful: try X with emptyset_0*) X) ⊔ ((*failed: try A with emptyset_0*) emptyset_0).
Definition P := M ⊓ !A.
Definition WW r := r ⊓ [W] ⋅ top ⋅ [W].
Definition WR r := r ⊓ [W] ⋅ top ⋅ [R].
Definition RW r := r ⊓ [R] ⋅ top ⋅ [W].
Definition RR r := r ⊓ [R] ⋅ top ⋅ [R].
Definition RM r := r ⊓ [R] ⋅ top ⋅ [M].
Definition MR r := r ⊓ [M] ⋅ top ⋅ [R].
Definition WM r := r ⊓ [W] ⋅ top ⋅ [M].
Definition MW r := r ⊓ [M] ⋅ top ⋅ [W].
Definition MM r := r ⊓ [M] ⋅ top ⋅ [M].
Definition AA r := r ⊓ [A] ⋅ top ⋅ [A].
Definition AP r := r ⊓ [A] ⋅ top ⋅ [P].
Definition PA r := r ⊓ [P] ⋅ top ⋅ [A].
Definition PP r := r ⊓ [P] ⋅ top ⋅ [P].
Definition AM r := r ⊓ [A] ⋅ top ⋅ [M].
Definition MA r := r ⊓ [M] ⋅ top ⋅ [A].
Definition noid r : relation events := r ⊓ !id.
Definition atom := [A].
Definition obsco := WW po_loc ⊔ (rf ⋅ RW po_loc ⊔ (noid (WR po_loc ⋅ rf°) ⊔ noid (rf ⋅ (RR po_loc ⋅ rf°)))).
Definition cobase := obsco ⊔ co0.
Definition uniproc := acyclic cobase.
Definition co := cobase^+.
Definition fr := noid (rf° ⋅ co).
Definition coi := co ⊓ int.
Definition fri := fr ⊓ int.
Definition coe := co ⊓ !coi.
Definition fre := fr ⊓ !fri.
Definition dd := addr ⊔ data.
Definition rdw := po_loc ⊓ fre ⋅ rfe.
Definition detour := po_loc ⊓ coe ⋅ rfe.
Definition addrpo := addr ⋅ po.
Definition dmb_st : relation events := (*failed: try fencerel DMB.ST with 0*) 0.
Definition dsb_st : relation events := (*failed: try fencerel DSB.ST with 0*) 0.
Definition dmb : relation events := (*failed: try fencerel DMB with 0*) 0.
Definition dsb : relation events := (*failed: try fencerel DSB with 0*) 0.
Definition isb : relation events := (*failed: try fencerel ISB with 0*) 0.
Definition ctrlisb : relation events := (*failed: try ctrlcfence ISB with 0*) 0.
Definition sync : relation events := (*failed: try fencerel SYNC with 0*) 0.
Definition lwsync : relation events := (*failed: try fencerel LWSYNC with 0*) 0.
Definition eieio : relation events := (*failed: try fencerel EIEIO with 0*) 0.
Definition isync : relation events := (*failed: try fencerel ISYNC with 0*) 0.
Definition ctrlisync : relation events := (*failed: try ctrlcfence ISYNC with 0*) 0.
Definition ci0 := ctrlisync ⊔ (ctrlisb ⊔ detour).
Definition ii0 := dd ⊔ (rfi ⊔ rdw).
Definition cc0 := dd ⊔ (po_loc ⊔ (ctrl ⊔ addrpo)).
Definition ic0 : relation events := 0.
Inductive ci : relation _ := ci_c : incl (ci0 ⊔ (ci ⋅ ii ⊔ cc ⋅ ci)) ci
     with ii : relation _ := ii_c : incl (ii0 ⊔ (ci ⊔ (ic ⋅ ci ⊔ ii ⋅ ii))) ii
     with cc : relation _ := cc_c : incl (cc0 ⊔ (ci ⊔ (ci ⋅ ic ⊔ cc ⋅ cc))) cc
     with ic : relation _ := ic_c : incl (ic0 ⊔ (ii ⊔ (cc ⊔ (ic ⋅ cc ⊔ ii ⋅ ic)))) ic.
Section scheme.
Variables ci' ii' cc' ic' : relation events.
Variable Hci' : incl (ci0 ⊔ (ci' ⋅ ii' ⊔ cc' ⋅ ci')) ci'.
Variable Hii' : incl (ii0 ⊔ (ci' ⊔ (ic' ⋅ ci' ⊔ ii' ⋅ ii'))) ii'.
Variable Hcc' : incl (cc0 ⊔ (ci' ⊔ (ci' ⋅ ic' ⊔ cc' ⋅ cc'))) cc'.
Variable Hic' : incl (ic0 ⊔ (ii' ⊔ (cc' ⊔ (ic' ⋅ cc' ⊔ ii' ⋅ ic')))) ic'.

  Fixpoint ci_ind' x y (r : ci x y) : ci' x y
      with ii_ind' x y (r : ii x y) : ii' x y
      with cc_ind' x y (r : cc x y) : cc' x y
      with ic_ind' x y (r : ic x y) : ic' x y.
  Proof.
    destruct r as [x y r]; apply Hci'.
    destruct r as [r | r]; [ left | right ].
     exact r.
     destruct r as [r | r]; [ left | right ].
      destruct r as [x_y r1 r2]; exists x_y.
       apply ci_ind'; exact r1.
       apply ii_ind'; exact r2.
      destruct r as [x_y r1 r2]; exists x_y.
       apply cc_ind'; exact r1.
       apply ci_ind'; exact r2.
    destruct r as [x y r]; apply Hii'.
    destruct r as [r | r]; [ left | right ].
     exact r.
     destruct r as [r | r]; [ left | right ].
      apply ci_ind'; exact r.
      destruct r as [r | r]; [ left | right ].
       destruct r as [x_y r1 r2]; exists x_y.
        apply ic_ind'; exact r1.
        apply ci_ind'; exact r2.
       destruct r as [x_y r1 r2]; exists x_y.
        apply ii_ind'; exact r1.
        apply ii_ind'; exact r2.
    destruct r as [x y r]; apply Hcc'.
    destruct r as [r | r]; [ left | right ].
     exact r.
     destruct r as [r | r]; [ left | right ].
      apply ci_ind'; exact r.
      destruct r as [r | r]; [ left | right ].
       destruct r as [x_y r1 r2]; exists x_y.
        apply ci_ind'; exact r1.
        apply ic_ind'; exact r2.
       destruct r as [x_y r1 r2]; exists x_y.
        apply cc_ind'; exact r1.
        apply cc_ind'; exact r2.
    destruct r as [x y r]; apply Hic'.
    destruct r as [r | r]; [ left | right ].
     exact r.
     destruct r as [r | r]; [ left | right ].
      apply ii_ind'; exact r.
      destruct r as [r | r]; [ left | right ].
       apply cc_ind'; exact r.
       destruct r as [r | r]; [ left | right ].
        destruct r as [x_y r1 r2]; exists x_y.
         apply ic_ind'; exact r1.
         apply cc_ind'; exact r2.
        destruct r as [x_y r1 r2]; exists x_y.
         apply ii_ind'; exact r1.
         apply ic_ind'; exact r2.
  Qed.
End scheme.
Definition ppo := let ppoR := ii ⊓ [R] ⋅ top ⋅ [R] in let ppoW := ic ⊓ [R] ⋅ top ⋅ [W] in ppoR ⊔ ppoW.
Definition lwsync_0 := RM lwsync ⊔ WW lwsync.
Definition eieio_0 := WW eieio.
Definition dmb_st_0 := WW dmb_st.
Definition dsb_st_0 := WW dsb_st.
Definition strong := sync ⊔ (dmb ⊔ (dsb ⊔ (dmb_st_0 ⊔ dsb_st_0))).
Definition light := lwsync_0 ⊔ eieio_0.
Definition fence := strong ⊔ light.
Definition hb := ppo ⊔ (fence ⊔ rfe).
Definition thinair := acyclic hb.
Definition hbstar := hb^*.
Definition propbase := (fence ⊔ rfe ⋅ fence) ⋅ hbstar.
Definition chapo := rfe ⊔ (fre ⊔ (coe ⊔ (fre ⋅ rfe ⊔ coe ⋅ rfe))).
Definition prop := propbase ⊓ [W] ⋅ top ⋅ [W] ⊔ (chapo ⊔ 1) ⋅ (propbase^* ⋅ (strong ⋅ hbstar)).
Definition propagation := acyclic (co ⊔ prop).
Definition observation := irreflexive (fre ⋅ (prop ⋅ hbstar)).
Definition xx := po ⊓ [X] ⋅ top ⋅ [X].
Definition scXX := acyclic (co ⊔ xx).
Definition witness_conditions := True.
Definition model_conditions := uniproc /\ (thinair /\ (propagation /\ (observation /\ scXX))).
End Model.

Hint Unfold events R W IW FW B RMW F rf po int ext loc addr data ctrl amo rmw unknown_set unknown_relation M emptyset classes_loc X tag2events emptyset_0 partition tag2instrs po_loc rfe rfi co0 toid fencerel ctrlcfence imply nodetour singlestep LKW A P WW WR RW RR RM MR WM MW MM AA AP PA PP AM MA noid atom obsco cobase uniproc co fr coi fri coe fre dd rdw detour addrpo dmb_st dsb_st dmb dsb isb ctrlisb sync lwsync eieio isync ctrlisync ci0 ii0 cc0 ic0 ppo lwsync_0 eieio_0 dmb_st_0 dsb_st_0 strong light fence hb thinair hbstar propbase chapo prop propagation observation xx scXX witness_conditions model_conditions : cat.

Definition valid (c : candidate) := model_conditions c.

(* End of translation of model Model *)


Require Import List Ascii.
Require Import Ynot.
Require Import IO Net FS.
Require Import RSep.

Open Local Scope hprop_scope.
Open Local Scope stsepi_scope.
Open Local Scope char_scope.

Set Implicit Arguments.

Inductive trace (local remote : Net.SockAddr)
  (fd : File (BoundSocketModel local remote) (R :: W :: nil)) : IO.Trace -> Prop :=
| NilCorrect : trace fd nil
| ConsCorrect : forall request reply past, trace fd past -> secure fd ->
  trace fd
      (WroteString stdout reply ++ ReadLine fd reply ++
        Flush fd :: WroteString fd request ++ ReadLine FS.stdin request ++ past).

Lemma proj_inv : forall (T1 T2 : Type) (a b : T1) (c d : T2),
  (a,c) = (b,d) -> a = b /\ c = d.
  intros; inversion H; auto.
Qed.

Definition iter_post (local remote : Net.SockAddr) (req rep : list ascii)
  (fd : File (BoundSocketModel local remote) (R :: W :: nil)) (tr : Trace) :=
  WroteString stdout rep ++ ReadLine fd rep ++ Flush fd :: WroteString fd req ++ ReadLine stdin req ++ tr.

Definition iter : forall (local remote : Net.SockAddr)
  (fd : File (BoundSocketModel local remote) (R :: W :: nil)) (tr : [Trace]),
  STsep (tr ~~ IO.traced tr * [secure fd] * handle FS.stdin * handle FS.stdout * handle fd)
        (fun tr':[Trace] => tr ~~ tr' ~~ Exists req :@ list ascii, Exists rep :@ list ascii,
          [tr' = WroteString stdout rep ++ ReadLine fd rep ++ Flush fd :: WroteString fd req ++ ReadLine stdin req] *
          traced (iter_post req rep fd tr) * [secure fd] * handle FS.stdin * handle FS.stdout * handle fd).
  refine (fun local remote fd tr =>
    ln <- readline FS.stdin FS.ro_readable tr <@> _ ;
    writeline fd ln rw_writeable (tr ~~~ ReadLine stdin ln ++ tr) <@> _ ;;
    flush fd (tr ~~~ WroteString fd ln ++ ReadLine stdin ln ++ tr) rw_writeable <@> _;;
    reply <- readline fd rw_readable (tr ~~~ Flush fd :: WroteString fd ln ++ ReadLine stdin ln ++ tr) <@> _ ;
    writeline FS.stdout reply FS.wo_writeable (tr ~~~ ReadLine fd reply ++ Flush fd :: WroteString fd ln ++ ReadLine stdin ln ++ tr) <@> _;;
    {{Return (tr ~~~ WroteString FS.stdout reply ++ ReadLine fd reply ++ Flush fd :: WroteString fd ln ++ ReadLine stdin ln)}});
  rsep fail auto; sep fail auto.
Qed.

Theorem list_no_cycle' : forall (T : Type) (l1 l2 : list T),
  l2 <> nil -> l2 ++ l1 <> l1.
  intros; pose (@list_no_cycle T l1 l2); unfold not in *; auto.
Qed.

Lemma list_fix : forall T (x y z : list T) a,
  (a :: x ++ y) ++ z = a :: x ++ y ++ z.
  intros. simpl. rewrite app_ass. auto.
Qed.

Definition client : forall (local remote : Net.SockAddr) (tr : [Trace]),
  STsep (tr ~~ IO.traced nil * handle FS.stdin * handle FS.stdout)
        (fun _:unit => tr ~~ Exists v :@ Trace, IO.traced v * handle FS.stdin * handle FS.stdout).
  refine (fun local remote tr =>
    skt <- SSL.bindSocket local remote <@> _ ;

    xxx <- IO.forever
             (fun t:Trace => [trace skt t] * handle skt * [secure skt] * handle FS.stdin * handle FS.stdout)
             (fun t:[Trace] =>
               {{ iter skt t <@> _ }})
             [nil] ;
    close skt;;
    {{Return tt}}); try unfold iter_post.
  solve [ rsep fail auto ].
  solve [ rsep fail auto ].
  solve [ intros; inhabiter; unpack_conc; canceler; sep fail auto ]. (** rsep doesn't have good enough support for re-packing **)
  sep fail auto. repeat rewrite app_ass.  rewrite list_fix. sep fail ltac:(econstructor; auto).
  solve [ rsep fail ltac:(auto; econstructor) ].
  solve [ rsep fail auto ].
  solve [ destruct xxx ].
  solve [ rsep fail auto ].
  solve [ rsep fail auto ].
  solve [ destruct xxx ].
Qed.


(** * Initialization *)

(** Evalution of concurrent statements during the initialization phase
    of the simulation.

    The initialization phase is composed of the evaluation of the
    first part of reset blocks followed by a stabilization phase. *)

Require Import common.GlobalTypes.
Require Import common.NatSet.

Require Import hvhdl.Environment.
Require Import hvhdl.AbstractSyntax.
Require Import hvhdl.SSEvaluation.
Require Import hvhdl.PortMapEvaluation.
Require Import hvhdl.Stabilization.
Require Import hvhdl.SemanticalDomains.
Require Import hvhdl.Petri.
Require Import hvhdl.HVhdlTypes.
Require Import hvhdl.CSEvaluation.

Include HVhdlCsNotations.

(** Relational definition of the initialization phase. *)

Inductive Init (D__s : IdMap design) (Δ : ElDesign) (σ : DState) (cstmt : cs) (σ0 : DState) : Prop :=
| Init_ :
    forall σ',

      (* * Premises * *)

      (* Executes the first part of reset blocks.  *)
      VConc D__s Δ σ init cstmt σ' ->

      (* Stabilization phase.  *)
      Stabilize D__s Δ σ' cstmt σ0 ->

      (* * Conclusion * *)
      Init D__s Δ σ cstmt σ0.

#[export] Hint Constructors Init : hvhdl.


(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
Require Import Coqlib.
Require Import Maps.
Require Import ASTExtra.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import Memory.
Require Import Events.
Require Import Stacklayout.
Require Import Globalenvs.
Require Import AsmX.
Require Import Smallstep.
Require Import AuxStateDataType.
Require Import Constant.
Require Import GlobIdent.
Require Import FlatMemory.
Require Import CommonTactic.
Require Import AuxLemma.
Require Import RealParams.
Require Import PrimSemantics.
Require Import LAsm.
Require Import XOmega.

Require Import compcert.cfrontend.Ctypes.
Require Import Conventions.
Require Import liblayers.logic.PTreeModules.
Require Import liblayers.logic.LayerLogicImpl.
Require Import liblayers.compat.CompatLayers.

Require Import AbstractDataType.
Require Import Soundness.
Require Import TSysCall.
Require Import I64Layer.
Require Import LoadStoreSem2.

Require Import SecurityCommon.
Require Import ProofIrrelevance.
Require Import MakeProgram.

Require Import SecurityInv1.
Require Import SecurityInv2.

(* This file combines the invariants established in SecurityInv1.v and SecurityInv2.v.
   It defines two invariants secure_inv and secure_inv' which will be assumed by the
   main security lemmas. We prove that both of these invariants are preserved by each
   step of tsyscall, but only the first one holds on the initial state. See below
   for further discussion, as well as Section 3 of the paper. *)

Section WITHMEM.

  Local Open Scope Z_scope.

  Context `{real_params: RealParams}.

  Context `{Hstencil: Stencil}.
  Context `{Hmem: Mem.MemoryModel}.
  Context `{Hmwd: UseMemWithData mem}.

  Local Instance : ExternalCallsOps (mwd (cdata RData)) :=
    CompatExternalCalls.compatlayer_extcall_ops tsyscall_layer.
  Local Instance : LayerConfigurationOps := compatlayer_configuration_ops tsyscall_layer.

  Section WITHIMPL.

    Context `{make_program_ops: !MakeProgramOps function Ctypes.type fundef unit}.
    Context `{make_program_prf: !MakeProgram function Ctypes.type fundef unit}.

    Variables (s : stencil) (M : module) (ge : genv) (b : block).
    Hypothesis (Hmake : make_globalenv s M tsyscall_layer = OK ge).
    Hypothesis (Hpsu : Genv.find_symbol ge proc_start_user = Some b).

    Section SECURE_INV.

      (* secure_inv and secure_inv', the two invariants defined in this file. Note
         that all fields of these invariants come from either SecurityInv1.v or
         SecurityInv2.v. *)

      Record secure_inv id d :=
        {
          sec_high_inv: high_level_invariant d;
          sec_ihost_inv: ihost d = true;
          sec_RA_startuser_inv: RA_startuser b d;
          sec_single_mapped_inv: single_mapped (LAT d) (nps d) id;
          sec_unshared_inv: unshared (LAT d) (nps d) id
        }.

      (* secure_inv' is the part of the invariant that does not hold on the initial
         state. Our security theorem only applies to configurations of mCertiKOS that
         set things up to make this invariant hold. At some point, it might be nice to
         to design a particular family of configurations and prove that all members
         of this family correctly establish the invariant.

         Note that the assumption here is only that the mCertiKOS configuration
         spawns the observer process (if the observer process were never spawned, then
         it would be meaningless to reason about its security), and that the initial
         kernel process 0 eventually switches to a different user mode process
         without placing itself on the ready queue (meaning that process 0 will never
         be scheduled again).

         Paper Reference: Section 3 *)
      Record secure_inv' id rs d :=
        {
          sec_used: cused (ZMap.get id (AC d)) = true;
          sec_usermode: usermode b rs d
        }.

      (* proof that secure_inv holds on the initial state *)

      Lemma secure_inv_init :
        forall id, secure_inv id init_adt.
      Proof.
        intro id; constructor.
        - apply empty_data_high_level_invariant.
        - auto.
        - intros ? ? Hcon; simpl in Hcon; zmap_simpl; inv Hcon.
        - intros ? ? ? ? ? Hcon; simpl in Hcon; zmap_simpl; inv Hcon.
        - simpl; intros ? ? Hcon; inv Hcon.
          zmap_simpl; inv H0.
      Qed.

      (* proofs that the two invariants are preserved by each step *)

      Lemma secure_inv_preserved :
        forall id rs rs' (m m' : mem) (d d' : cdata RData) t,
          LAsm.step ge (State rs (m,d)) t (State rs' (m',d')) ->
          secure_inv id d -> secure_inv id d'.
      Proof.
        intros id rs rs' m m' d d' t Hstep Hinv.
        destruct Hinv; constructor.
        - eapply step_inv1; eauto.
        - eapply ihost_inv; eauto.
        - eapply RA_startuser_inv; eauto.
        - eapply step_inv1; eauto.
        - eapply step_inv1; eauto.
      Qed.

      Lemma secure_inv'_preserved :
        forall id rs rs' (m m' : mem) (d d' : cdata RData) t,
          LAsm.step ge (State rs (m,d)) t (State rs' (m',d')) ->
          secure_inv id d -> secure_inv' id rs d -> secure_inv' id rs' d'.
      Proof.
        intros id rs rs' m m' d d' t Hstep Hinv Hinv'.
        destruct Hinv; destruct Hinv'; constructor.
        - eapply step_inv1; eauto.
        - eapply usermode_inv; eauto.
      Qed.

    End SECURE_INV.

  End WITHIMPL.

End WITHMEM.