Require Import LayerDeps.
Require Import Ident.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import RMMHandler.Spec.

Local Open Scope Z_scope.

Section Layer.

  Context `{real_params: RealParams}.

  Section InvDef.

    Record high_level_invariant (adt: RData) :=
      mkInvariants { }.

    Global Instance RMMHandler_ops : CompatDataOps RData :=
      {
        empty_data := empty_adt;
        high_level_invariant := high_level_invariant;
        low_level_invariant := fun (b: block) (d: RData) => True;
        kernel_mode adt := True
      }.

  End InvDef.

  Section InvInit.

    Global Instance RMMHandler_prf : CompatData RData.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

  End InvInit.

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

  Section InvProof.

    Global Instance rmm_handler_inv: PreservesInvariants rmm_handler_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

    Global Instance realm_ns_step_inv: PreservesInvariants realm_ns_step_spec.
    Proof.
      constructor; intros; simpl; eauto.
      constructor.
    Qed.

  End InvProof.

  Section LayerDef.

    Definition RMMHandler_fresh : compatlayer (cdata RData) :=
      _rmm_handler ↦ gensem rmm_handler_spec
        ⊕ _realm_ns_step ↦ gensem realm_ns_step_spec
      .

    Definition RMMHandler_passthrough : compatlayer (cdata RData) :=
      ∅.

    Definition RMMHandler := RMMHandler_fresh ⊕ RMMHandler_passthrough.

  End LayerDef.

End Layer.


(*
Implementation of the Copland Virtual Machine (CVM).

Author:  Adam Petz, ampetz@ku.edu
*)

Require Import Term_Defs Anno_Term_Defs Cvm_Monad.

Require Import List.
Import ListNotations.

(** Monadic CVM implementation (top-level) *)
Fixpoint build_cvm (t:Core_Term): CVM unit :=
  match t with
  | aspc a =>
      e <- do_prim a ;;
      put_ev e
  | attc q t' =>
    e <- get_ev ;;
    e' <- doRemote t' q e ;;
    put_ev e'
  | lseqc t1 t2 =>
      build_cvm t1 ;;
      build_cvm t2
  | bseqc t1 t2 =>
    split_ev ;;
    e <- get_ev ;;
    build_cvm t1 ;;
    e1r <- get_ev ;;
    put_ev e ;;
    build_cvm t2 ;;
    e2r <- get_ev ;;
    join_seq e1r e2r
  | bparc loc t1 t2 =>
    split_ev ;;
    e <- get_ev ;;
    start_par_thread loc t2 e ;;
    build_cvm t1 ;;
    e1r <- get_ev ;;
    e2r <- wait_par_thread loc t2 e ;;
    join_seq e1r e2r
  end.


(* *********************************************************************)
(*                                                                     *)
(*              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.     *)
(*                                                                     *)
(* *********************************************************************)

(** Correctness proof for the [Debugvar] pass. *)

Require Import Coqlib.
Require Import Axioms.
Require Import Maps.
Require Import Iteration.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import Memory.
Require Import Events.
Require Import Globalenvs.
Require Import Smallstep.
Require Import Op.
Require Import Errors.
Require Import Machregs.
Require Import Locations.
Require Import Conventions.
Require Import Linear.
Require Import Debugvar.

(** * Relational characterization of the transformation *)

Inductive match_code: code -> code -> Prop :=
  | match_code_nil:
      match_code nil nil
  | match_code_cons: forall i before after c c',
      match_code c c' ->
      match_code (i :: c) (i :: add_delta_ranges before after c').

Remark diff_same:
  forall s, diff s s = nil.
Proof.
  induction s as [ | [v i] s]; simpl.
  auto.
  rewrite Pos.compare_refl. rewrite dec_eq_true. auto.
Qed.

Remark delta_state_same:
  forall s, delta_state s s = (nil, nil).
Proof.
  destruct s; simpl. rewrite ! diff_same; auto. auto.
Qed.

Lemma transf_code_match:
  forall lm c before, match_code c (transf_code lm before c).
Proof.
  intros lm. fix REC 1. destruct c; intros before; simpl.
- constructor.
- assert (DEFAULT: forall before after,
            match_code (i :: c)
                       (i :: add_delta_ranges before after (transf_code lm after c))).
  { intros. constructor. apply REC. }
  destruct i; auto. destruct c; auto. destruct i; auto.
  set (after := get_label l0 lm).
  set (c1 := Llabel l0 :: add_delta_ranges before after (transf_code lm after c)).
  replace c1 with (add_delta_ranges before before c1).
  constructor. constructor. apply REC.
  unfold add_delta_ranges. rewrite delta_state_same. auto.
Qed.

Inductive match_function: function -> function -> Prop :=
  | match_function_intro: forall f c,
      match_code f.(fn_code) c ->
      match_function f (mkfunction f.(fn_sig) f.(fn_stacksize) c).

Lemma transf_function_match:
  forall f tf, transf_function f = OK tf -> match_function f tf.
Proof.
  unfold transf_function; intros.
  destruct (ana_function f) as [lm|]; inv H.
  constructor. apply transf_code_match.
Qed.

Remark find_label_add_delta_ranges:
  forall lbl c before after, find_label lbl (add_delta_ranges before after c) = find_label lbl c.
Proof.
  intros. unfold add_delta_ranges.
  destruct (delta_state before after) as [killed born].
  induction killed as [ | [v i] l]; simpl; auto.
  induction born as [ | [v i] l]; simpl; auto.
Qed.

Lemma find_label_match_rec:
  forall lbl c' c tc,
  match_code c tc ->
  find_label lbl c = Some c' ->
  exists before after tc', find_label lbl tc = Some (add_delta_ranges before after tc') /\ match_code c' tc'.
Proof.
  induction 1; simpl; intros.
- discriminate.
- destruct (is_label lbl i).
  inv H0. econstructor; econstructor; econstructor; eauto.
  rewrite find_label_add_delta_ranges. auto.
Qed.

Lemma find_label_match:
  forall f tf lbl c,
  match_function f tf ->
  find_label lbl f.(fn_code) = Some c ->
  exists before after tc, find_label lbl tf.(fn_code) = Some (add_delta_ranges before after tc) /\ match_code c tc.
Proof.
  intros. inv H. eapply find_label_match_rec; eauto.
Qed.

(** * Properties of availability sets *)

(** These properties are not used in the semantic preservation proof,
    but establish some confidence in the availability analysis. *)

Definition avail_above (v: ident) (s: avail) : Prop :=
  forall v' i', In (v', i') s -> Plt v v'.

Inductive wf_avail: avail -> Prop :=
  | wf_avail_nil:
      wf_avail nil
  | wf_avail_cons: forall v i s,
     avail_above v s ->
     wf_avail s ->
     wf_avail ((v, i) :: s).

Lemma set_state_1:
  forall v i s, In (v, i) (set_state v i s).
Proof.
  induction s as [ | [v' i'] s]; simpl.
- auto.
- destruct (Pos.compare v v'); simpl; auto.
Qed.

Lemma set_state_2:
  forall v i v' i' s,
  v' <> v -> In (v', i') s -> In (v', i') (set_state v i s).
Proof.
  induction s as [ | [v1 i1] s]; simpl; intros.
- contradiction.
- destruct (Pos.compare_spec v v1); simpl.
+ subst v1. destruct H0. congruence. auto.
+ auto.
+ destruct H0; auto.
Qed.

Lemma set_state_3:
  forall v i v' i' s,
  wf_avail s ->
  In (v', i') (set_state v i s) ->
  (v' = v /\ i' = i) \/ (v' <> v /\ In (v', i') s).
Proof.
  induction 1; simpl; intros.
- intuition congruence.
- destruct (Pos.compare_spec v v0); simpl in H1.
+ subst v0. destruct H1. inv H1; auto. right; split.
  apply sym_not_equal. apply Plt_ne. eapply H; eauto.
  auto.
+ destruct H1. inv H1; auto.
  destruct H1. inv H1. right; split; auto. apply sym_not_equal. apply Plt_ne. auto.
  right; split; auto. apply sym_not_equal. apply Plt_ne. apply Plt_trans with v0; eauto.
+ destruct H1. inv H1. right; split; auto. apply Plt_ne. auto.
  destruct IHwf_avail as [A | [A B]]; auto.
Qed.

Lemma wf_set_state:
  forall v i s, wf_avail s -> wf_avail (set_state v i s).
Proof.
  induction 1; simpl.
- constructor. red; simpl; tauto. constructor.
- destruct (Pos.compare_spec v v0).
+ subst v0. constructor; auto.
+ constructor.
  red; simpl; intros. destruct H2.
  inv H2. auto. apply Plt_trans with v0; eauto.
  constructor; auto.
+ constructor.
  red; intros. exploit set_state_3. eexact H0. eauto. intros [[A B] | [A B]]; subst; eauto.
  auto.
Qed.

Lemma remove_state_1:
  forall v i s, wf_avail s -> ~ In (v, i) (remove_state v s).
Proof.
  induction 1; simpl; red; intros.
- auto.
- destruct (Pos.compare_spec v v0); simpl in *.
+ subst v0. elim (Plt_strict v); eauto.
+ destruct H1. inv H1.  elim (Plt_strict v); eauto.
  elim (Plt_strict v). apply Plt_trans with v0; eauto.
+ destruct H1. inv H1. elim (Plt_strict v); eauto.  tauto.
Qed.

Lemma remove_state_2:
  forall v v' i' s, v' <> v -> In (v', i') s -> In (v', i') (remove_state v s).
Proof.
  induction s as [ | [v1 i1] s]; simpl; intros.
- auto.
- destruct (Pos.compare_spec v v1); simpl.
+ subst v1. destruct H0. congruence. auto.
+ auto.
+ destruct H0; auto.
Qed.

Lemma remove_state_3:
  forall v v' i' s, wf_avail s -> In (v', i') (remove_state v s) -> v' <> v /\ In (v', i') s.
Proof.
  induction 1; simpl; intros.
- contradiction.
- destruct (Pos.compare_spec v v0); simpl in H1.
+ subst v0. split; auto. apply sym_not_equal; apply Plt_ne; eauto.
+ destruct H1. inv H1. split; auto. apply sym_not_equal; apply Plt_ne; eauto.
  split; auto. apply sym_not_equal; apply Plt_ne. apply Plt_trans with v0; eauto.
+ destruct H1. inv H1. split; auto. apply Plt_ne; auto.
  destruct IHwf_avail as [A B] ; auto.
Qed.

Lemma wf_remove_state:
  forall v s, wf_avail s -> wf_avail (remove_state v s).
Proof.
  induction 1; simpl.
- constructor.
- destruct (Pos.compare_spec v v0).
+ auto.
+ constructor; auto.
+ constructor; auto. red; intros.
  exploit remove_state_3. eexact H0. eauto. intros [A B]. eauto.
Qed.

Lemma wf_filter:
  forall pred s, wf_avail s -> wf_avail (List.filter pred s).
Proof.
  induction 1; simpl.
- constructor.
- destruct (pred (v, i)) eqn:P; auto.
  constructor; auto.
  red; intros. apply filter_In in H1. destruct H1. eauto.
Qed.

Lemma join_1:
  forall v i s1, wf_avail s1 -> forall s2, wf_avail s2 ->
  In (v, i) s1 -> In (v, i) s2 -> In (v, i) (join s1 s2).
Proof.
  induction 1; simpl; try tauto; induction 1; simpl; intros I1 I2; auto.
  destruct I1, I2.
- inv H3; inv H4. rewrite Pos.compare_refl. rewrite dec_eq_true; auto with coqlib.
- inv H3.
  assert (L: Plt v1 v) by eauto. apply Pos.compare_gt_iff in L. rewrite L. auto.
- inv H4.
  assert (L: Plt v0 v) by eauto. apply Pos.compare_lt_iff in L. rewrite L. apply IHwf_avail. constructor; auto. auto. auto with coqlib.
- destruct (Pos.compare v0 v1).
+ destruct (eq_debuginfo i0 i1); auto with coqlib.
+ apply IHwf_avail; auto with coqlib. constructor; auto.
+ eauto.
Qed.

Lemma join_2:
  forall v i s1, wf_avail s1 -> forall s2, wf_avail s2 ->
  In (v, i) (join s1 s2) -> In (v, i) s1 /\ In (v, i) s2.
Proof.
  induction 1; simpl; try tauto; induction 1; simpl; intros I; try tauto.
  destruct (Pos.compare_spec v0 v1).
- subst v1. destruct (eq_debuginfo i0 i1).
  + subst i1. destruct I. auto. exploit IHwf_avail; eauto. tauto.
  + exploit IHwf_avail; eauto. tauto.
- exploit (IHwf_avail ((v1, i1) :: s0)); eauto. constructor; auto.
  simpl. tauto.
- exploit IHwf_avail0; eauto. tauto.
Qed.

Lemma wf_join:
  forall s1, wf_avail s1 -> forall s2, wf_avail s2 -> wf_avail (join s1 s2).
Proof.
  induction 1; simpl; induction 1; simpl; try constructor.
  destruct (Pos.compare_spec v v0).
- subst v0. destruct (eq_debuginfo i i0); auto. constructor; auto.
  red; intros. apply join_2 in H3; auto. destruct H3. eauto.
- apply IHwf_avail. constructor; auto.
- apply IHwf_avail0.
Qed.

(** * Semantic preservation *)

Section PRESERVATION.

Variable prog: program.
Variable tprog: program.

Hypothesis TRANSF: transf_program prog = OK tprog.

Let ge := Genv.globalenv prog.
Let tge := Genv.globalenv tprog.

Lemma functions_translated:
  forall v f,
  Genv.find_funct ge v = Some f ->
  exists tf,
  Genv.find_funct tge v = Some tf /\ transf_fundef f = OK tf.
Proof (Genv.find_funct_transf_partial transf_fundef _ TRANSF).

Lemma function_ptr_translated:
  forall v f,
  Genv.find_funct_ptr ge v = Some f ->
  exists tf,
  Genv.find_funct_ptr tge v = Some tf /\ transf_fundef f = OK tf.
Proof (Genv.find_funct_ptr_transf_partial transf_fundef _ TRANSF).

Lemma symbols_preserved:
  forall id,
  Genv.find_symbol tge id = Genv.find_symbol ge id.
Proof (Genv.find_symbol_transf_partial transf_fundef _ TRANSF).

Lemma public_preserved:
  forall id,
  Genv.public_symbol tge id = Genv.public_symbol ge id.
Proof (Genv.public_symbol_transf_partial transf_fundef _ TRANSF).

Lemma varinfo_preserved:
  forall b, Genv.find_var_info tge b = Genv.find_var_info ge b.
Proof (Genv.find_var_info_transf_partial transf_fundef _ TRANSF).

Lemma sig_preserved:
  forall f tf,
  transf_fundef f = OK tf ->
  funsig tf = funsig f.
Proof.
  unfold transf_fundef, transf_partial_fundef; intros.
  destruct f. monadInv H.
  exploit transf_function_match; eauto. intros M; inv M; auto.
  inv H. reflexivity.
Qed.

Lemma find_function_translated:
  forall ros ls f,
  find_function ge ros ls = Some f ->
  exists tf,
  find_function tge ros ls = Some tf /\ transf_fundef f = OK tf.
Proof.
  unfold find_function; intros; destruct ros; simpl.
  apply functions_translated; auto.
  rewrite symbols_preserved. destruct (Genv.find_symbol ge i).
  apply function_ptr_translated; auto.
  congruence.
Qed.

(** Evaluation of the debug annotations introduced by the transformation. *)

Lemma can_eval_safe_arg:
  forall (rs: locset) sp m (a: builtin_arg loc),
  safe_builtin_arg a -> exists v, eval_builtin_arg tge rs sp m a v.
Proof.
  induction a; simpl; intros; try contradiction;
  try (econstructor; now eauto with barg).
  destruct H as [S1 S2].
  destruct (IHa1 S1) as [v1 E1]. destruct (IHa2 S2) as [v2 E2].
  exists (Val.longofwords v1 v2); auto with barg.
Qed.

Lemma eval_add_delta_ranges:
  forall s f sp c rs m before after,
  star step tge (State s f sp (add_delta_ranges before after c) rs m)
             E0 (State s f sp c rs m).
Proof.
  intros. unfold add_delta_ranges.
  destruct (delta_state before after) as [killed born].
  induction killed as [ | [v i] l]; simpl.
- induction born as [ | [v i] l]; simpl.
+ apply star_refl.
+ destruct i as [a SAFE]; simpl.
  exploit can_eval_safe_arg; eauto. intros [v1 E1].
  eapply star_step; eauto.
  econstructor.
  constructor. eexact E1. constructor.
  simpl; constructor.
  simpl; auto.
  traceEq.
- eapply star_step; eauto.
  econstructor.
  constructor.
  simpl; constructor.
  simpl; auto.
  traceEq.
Qed.

(** Matching between program states. *)

Inductive match_stackframes: Linear.stackframe -> Linear.stackframe -> Prop :=
  | match_stackframe_intro:
      forall f sp rs c tf tc before after,
      match_function f tf ->
      match_code c tc ->
      match_stackframes
        (Stackframe f sp rs c)
        (Stackframe tf sp rs (add_delta_ranges before after tc)).

Inductive match_states: Linear.state ->  Linear.state -> Prop :=
  | match_states_instr:
      forall s f sp c rs m tf ts tc
        (STACKS: list_forall2 match_stackframes s ts)
        (TRF: match_function f tf)
        (TRC: match_code c tc),
      match_states (State s f sp c rs m)
                   (State ts tf sp tc rs m)
  | match_states_call:
      forall s f rs m tf ts,
      list_forall2 match_stackframes s ts ->
      transf_fundef f = OK tf ->
      match_states (Callstate s f rs m)
                   (Callstate ts tf rs m)
  | match_states_return:
      forall s rs m ts,
      list_forall2 match_stackframes s ts ->
      match_states (Returnstate s rs m)
                   (Returnstate ts rs m).

Lemma parent_locset_match:
  forall s ts,
  list_forall2 match_stackframes s ts ->
  parent_locset ts = parent_locset s.
Proof.
  induction 1; simpl. auto. inv H; auto.
Qed.

(** The simulation diagram. *)

Theorem transf_step_correct:
  forall s1 t s2, step ge s1 t s2 ->
  forall ts1 (MS: match_states s1 ts1),
  exists ts2, plus step tge ts1 t ts2 /\ match_states s2 ts2.
Proof.
  induction 1; intros ts1 MS; inv MS; try (inv TRC).
- (* getstack *)
  econstructor; split.
  eapply plus_left. constructor; auto. apply eval_add_delta_ranges. traceEq.
  constructor; auto.
- (* setstack *)
  econstructor; split.
  eapply plus_left. constructor; auto. apply eval_add_delta_ranges. traceEq.
  constructor; auto.
- (* op *)
  econstructor; split.
  eapply plus_left.
  econstructor; eauto.
  instantiate (1 := v). rewrite <- H; apply eval_operation_preserved; exact symbols_preserved.
  apply eval_add_delta_ranges. traceEq.
  constructor; auto.
- (* load *)
  econstructor; split.
  eapply plus_left.
  eapply exec_Lload with (a := a).
  rewrite <- H; apply eval_addressing_preserved; exact symbols_preserved.
  eauto. eauto.
  apply eval_add_delta_ranges. traceEq.
  constructor; auto.
- (* store *)
  econstructor; split.
  eapply plus_left.
  eapply exec_Lstore with (a := a).
  rewrite <- H; apply eval_addressing_preserved; exact symbols_preserved.
  eauto. eauto.
  apply eval_add_delta_ranges. traceEq.
  constructor; auto.
- (* call *)
  exploit find_function_translated; eauto. intros (tf' & A & B).
  econstructor; split.
  apply plus_one.
  econstructor. eexact A. symmetry; apply sig_preserved; auto. traceEq.
  constructor; auto. constructor; auto. constructor; auto.
- (* tailcall *)
  exploit find_function_translated; eauto. intros (tf' & A & B).
  exploit parent_locset_match; eauto. intros PLS.
  econstructor; split.
  apply plus_one.
  econstructor. eauto. rewrite PLS. eexact A.
  symmetry; apply sig_preserved; auto.
  inv TRF; eauto. traceEq.
  rewrite PLS. constructor; auto.
- (* builtin *)
  econstructor; split.
  eapply plus_left.
  econstructor; eauto.
  eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved.
  eapply external_call_symbols_preserved. eauto.
  exact symbols_preserved. exact public_preserved. exact varinfo_preserved.
  apply eval_add_delta_ranges. traceEq.
  constructor; auto.
- (* label *)
  econstructor; split.
  eapply plus_left. constructor; auto. apply eval_add_delta_ranges. traceEq.
  constructor; auto.
- (* goto *)
  exploit find_label_match; eauto. intros (before' & after' & tc' & A & B).
  econstructor; split.
  eapply plus_left. constructor; eauto. apply eval_add_delta_ranges; eauto. traceEq.
  constructor; auto.
- (* cond taken *)
  exploit find_label_match; eauto. intros (before' & after' & tc' & A & B).
  econstructor; split.
  eapply plus_left. eapply exec_Lcond_true; eauto. apply eval_add_delta_ranges; eauto. traceEq.
  constructor; auto.
- (* cond not taken *)
  econstructor; split.
  eapply plus_left. eapply exec_Lcond_false; auto. apply eval_add_delta_ranges. traceEq.
  constructor; auto.
- (* jumptable *)
  exploit find_label_match; eauto. intros (before' & after' & tc' & A & B).
  econstructor; split.
  eapply plus_left. econstructor; eauto.
  apply eval_add_delta_ranges. reflexivity. traceEq.
  constructor; auto.
- (* return *)
  econstructor; split.
  apply plus_one.  constructor. inv TRF; eauto. traceEq.
  rewrite (parent_locset_match _ _ STACKS). constructor; auto.
- (* internal function *)
  monadInv H7. rename x into tf.
  assert (MF: match_function f tf) by (apply transf_function_match; auto).
  inversion MF; subst.
  econstructor; split.
  apply plus_one. constructor. simpl; eauto. reflexivity.
  constructor; auto.
- (* external function *)
  monadInv H8. econstructor; split.
  apply plus_one. econstructor; eauto.
  eapply external_call_symbols_preserved'. eauto.
  exact symbols_preserved. exact public_preserved. exact varinfo_preserved.
  constructor; auto.
- (* return *)
  inv H3. inv H1.
  econstructor; split.
  eapply plus_left. econstructor. apply eval_add_delta_ranges. traceEq.
  constructor; auto.
Qed.

Lemma transf_initial_states:
  forall st1, initial_state prog st1 ->
  exists st2, initial_state tprog st2 /\ match_states st1 st2.
Proof.
  intros. inversion H.
  exploit function_ptr_translated; eauto. intros [tf [A B]].
  exists (Callstate nil tf (Locmap.init Vundef) m0); split.
  econstructor; eauto. eapply Genv.init_mem_transf_partial; eauto.
  replace (prog_main tprog) with (prog_main prog).
  rewrite symbols_preserved. eauto.
  symmetry. apply (transform_partial_program_main transf_fundef _ TRANSF).
  rewrite <- H3. apply sig_preserved. auto.
  constructor. constructor. auto.
Qed.

Lemma transf_final_states:
  forall st1 st2 r,
  match_states st1 st2 -> final_state st1 r -> final_state st2 r.
Proof.
  intros. inv H0. inv H. inv H6. econstructor; eauto.
Qed.

Theorem transf_program_correct:
  forward_simulation (semantics prog) (semantics tprog).
Proof.
  eapply forward_simulation_plus.
  eexact public_preserved.
  eexact transf_initial_states.
  eexact transf_final_states.
  eexact transf_step_correct.
Qed.

End PRESERVATION.


From Coq.Unicode Require Import Utf8.

Axiom FunExt :
  ∀ (A : Type) (B : A → Type) (f g : ∀ x, B x), (∀ x, f x = g x) → f = g.

Axiom PropExt : ∀ P Q : Prop, P ↔ Q → P = Q.

Lemma ProofIrrelevance : ∀ P : Prop, ∀ p q : P, p = q.
Proof.
  intros P p q.
  assert (True = P) as HP.
  { apply PropExt; split; auto. }
  revert p q.
  refine (match HP in _ = u return ∀ p q : u, p = q :> u with eq_refl => _ end).
  intros [] []; trivial.
Qed.

Axiom Choice :
  ∀ A B (R : A → B → Prop), (∀ x, ∃ y, R x y) → {f : A → B | ∀ x, R x (f x)}.

Definition epsilon {A : Type} {P : A → Prop} (Hex : ∃ x, P x) : A :=
  proj1_sig (Choice unit A (λ _ x, P x) (λ _, Hex)) tt.

Lemma epsilon_correct {A : Type} (P : A → Prop) (Hex : ∃ x, P x) :
  P (epsilon Hex).
Proof.
  exact (proj2_sig (Choice unit A (λ _ x, P x) (λ _, Hex)) tt).
Qed.

Lemma ExcludedMiddle (P : Prop) : P ∨ ¬ P.
Proof.
  set (PA b := b = true ∨ P).
  set (PB b := b = false ∨ P).
  set (U := sig (λ s, s = PA ∨ s = PB)).
  set (R := (λ u b, proj1_sig u b) : U → bool → Prop).
  assert (∀ u, ∃ b, R u b) as HR.
  { intros u.
    unfold R.
    destruct (proj2_sig u) as [->| ->]; unfold PA, PB; eauto. }
  apply Choice in HR as [f Hf].
  set (A := exist _ _ (or_introl eq_refl) : U); simpl in *.
  set (B := exist _ _ (or_intror eq_refl) : U); simpl in *.
  assert (P ↔ A = B) as HPAB.
  { split.
    - intros HP.
      unfold A, B.
      assert (PA = PB) as ->.
      { unfold PA, PB.
        apply FunExt; intros x; apply PropExt; tauto. }
      rewrite (ProofIrrelevance _ (or_introl eq_refl) (or_intror eq_refl));
        trivial.
    - intros HAB.
      assert (proj1_sig A = proj1_sig B) as HPAB; [rewrite HAB; trivial|].
      simpl in *.
      assert (PA false) as HPAf; [rewrite HPAB; unfold PB; auto; fail|].
      destruct HPAf; [congruence| trivial]. }
  pose proof (Hf A) as HfA.
  pose proof (Hf B) as HfB.
  simpl in *.
  destruct (f A) eqn:Aeq.
  - destruct (f B) eqn:Beq.
    + destruct HfB; [congruence| auto].
    + right. intros HP; apply HPAB in HP. congruence.
  - destruct HfA; [congruence| auto].
Qed.

Lemma NNP_P : ∀ P : Prop, ¬ ¬ P → P.
Proof.
  intros P NNP.
  destruct (ExcludedMiddle P); [trivial; fail|].
  exfalso; apply NNP; trivial.
Qed.

Lemma P_NNP : ∀ P : Prop, P → ¬ ¬ P.
Proof.
  intros P HP HnP; apply HnP; trivial.
Qed.

Lemma contrapositive : ∀ P Q : Prop, (¬ Q → ¬ P) → P → Q.
Proof.
  intros P Q Hcontra HP.
  destruct (ExcludedMiddle Q); [trivial; fail|].
  exfalso; apply Hcontra; trivial.
Qed.

Lemma not_exists_forall_not :
  ∀ (A : Type) (P : A → Prop), ¬ (∃ x, P x) → ∀ x, ¬ P x.
Proof. intros A P Hnex x HP; apply Hnex; eauto. Qed.

Lemma not_forall_exists_not :
  ∀ (A : Type) (P : A → Prop), ¬ (∀ x, P x) → ∃ x, ¬ P x.
Proof.
  intros A P.
  apply contrapositive.
  intros Hnex; apply P_NNP.
  intros x; apply NNP_P; revert x.
  apply not_exists_forall_not; trivial.
Qed.


(*
 * 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.
 *)
(** * Abstract semantics (context-insen + localized) *)

Set Implicit Arguments.

Require Import hpattern vgtac.
Require Import Global UserProofType DStr Syn Global.
Require DomCon SemCon DomInsen.
Require Import SemCommon.

Module Make (Import PInput : PINPUT).

Local Open Scope type.

Include DomInsen.Make PInput.

Section Sem.

Variable g : G.t.

Let pgm : InterCfg.t := G.icfg g.

Let mode : UserInputType.update_mode := UserInputType.Strong.

Variable amap : access_map.

Definition postfix_cmd (cn : InterNode.t) (s : state_t) : Prop :=
  forall cmd (Hcmd : Some cmd = InterCfg.get_cmd pgm cn),
    let m := s (cn, Inputof) in
    let m' := run_only mode g cn cmd m in
    let m'' := s (cn, Outputof) in
    Mem.le m' m''.

Definition postfix_intra_edge (cn : InterNode.t) (s : state_t) : Prop :=
  let p := InterNode.get_pid cn in
  let n := InterNode.get_node cn in
  forall n' cfg
         (Hcfg : InterCfg.PidMap.MapsTo p cfg (InterCfg.cfgs pgm))
         (Hedge : IntraCfg.is_succ cfg n n')
         (Hcn_cond: not (InterCfg.is_call_node pgm cn)),
    Mem.le (s (cn, Outputof)) (s ((p, n'), Inputof)).

Definition postfix_intra_call (cn : InterNode.t) (s : state_t) : Prop :=
  forall callee (Hedge : InterCfg.is_succ pgm cn (callee, IntraNode.Entry))
         retn (Hretn : Some retn = InterCfg.returnof pgm cn),
    let access := get_all_access callee amap in
    let m := s (cn, Outputof) in
    let m' := Mem.subtract access m in
    Mem.le m' (s (retn, Inputof)).

Definition postfix_inter_call (cn : InterNode.t) (s : state_t) : Prop :=
  forall callee (Hedge : InterCfg.is_succ pgm cn (callee, IntraNode.Entry)),
    let access := get_all_access callee amap in
    let m := s (cn, Outputof) in
    let m' := Mem.restrict access m in
    Mem.le m' (s ((callee, IntraNode.Entry), Inputof)).

Definition postfix_inter_ret (cn : InterNode.t)
           (s : state_t) : Prop :=
  forall p (Hp : cn = (p, IntraNode.Exit))
         cn' (Hedge : InterCfg.is_succ pgm cn cn')
         calln (Hret: Some cn' = InterCfg.returnof pgm calln),
    Mem.le (s (cn, Outputof)) (s (cn', Inputof)).

Definition postfix (s : state_t) : Prop :=
  forall (cn : InterNode.t)  ,
    postfix_cmd cn s
    /\ postfix_intra_edge cn s
    /\ postfix_intra_call cn s
    /\ postfix_inter_call cn s
    /\ postfix_inter_ret cn s.

Definition sound_amap_run (s : state_t) :=
  forall cn cmd (Hcmd : Some cmd = InterCfg.get_cmd pgm cn),
    Acc.le
      (Acc.get_acc (run_access mode g cn cmd (s (cn, SemCommon.Inputof))))
      (get_access (InterNode.get_pid cn) amap).

Definition sound_amap_reachable :=
  forall f1 f2 (Hr : InterCfg.reachable pgm f1 f2),
    Acc.le (get_access f2 amap) (get_access f1 amap).

Definition sound_amap (s : state_t) : Prop :=
  sound_amap_run s /\ sound_amap_reachable.

End Sem.

Local Close Scope type.

End Make.


(* Do not edit this file, it was generated automatically *)
(** Heavily annotated for a tutorial introduction. *)

(** First, import the entire Floyd proof automation system, which includes
 ** the VeriC program logic and the MSL theory of separation logic**)
Require Import VST.floyd.proofauto.

(** Import the [reverse.v] file, which is produced by CompCert's clightgen
 ** from reverse.c.   The file reverse.v defines abbreviations for identifiers
 ** (variable names, etc.) of the C program, such as _head, _reverse.
 ** It also defines "prog", which is the entire abstract syntax tree
 ** of the C program *)
Require Import VST.progs64.reverse.

(* The C programming language has a special namespace for struct
** and union identifiers, e.g., "struct foo {...}".  Some type-based operators
** in the program logic need access to an interpretation of this namespace,
** i.e., the meaning of each struct-identifier such as "foo".  The next
** line (which looks identical for any program) builds this
** interpretation, called "CompSpecs" *)
Instance CompSpecs : compspecs. make_compspecs prog. Defined.

(** Calculate the "types-of-global-variables" specification
 ** directly from the program *)
Definition Vprog : varspecs. mk_varspecs prog. Defined.

(** A convenience definition *)
Definition t_struct_list := Tstruct _list noattr.

(** Inductive definition of linked lists *)
Fixpoint listrep (sigma: list val) (x: val) : mpred :=
 match sigma with
 | h::hs =>
    EX y:val,
      data_at Tsh t_struct_list (h,y) x  *  listrep hs y
 | nil =>
    !! (x = nullval) && emp
 end.

Arguments listrep sigma x : simpl never.

(** Whenever you define a new spatial operator, such as
 ** [listrep] here, it's useful to populate two hint databases.
 ** The [saturate_local] hint is a lemma that extracts
 ** pure propositional facts from a spatial fact.
 ** The [valid_pointer] hint is a lemma that extracts a
 ** valid-pointer fact from a spatial lemma.
 **)

Lemma listrep_local_facts:
  forall sigma p,
   listrep sigma p |--
   !! (is_pointer_or_null p /\ (p=nullval <-> sigma=nil)).
Proof.
intros.
revert p; induction sigma;
  unfold listrep; fold listrep; intros; normalize.
apply prop_right; split; simpl; auto. intuition.
entailer!.
split; intro. subst p. destruct H; contradiction. inv H2.
Qed.

Hint Resolve listrep_local_facts : saturate_local.

Lemma listrep_valid_pointer:
  forall sigma p,
   listrep sigma p |-- valid_pointer p.
Proof.
 destruct sigma; unfold listrep; fold listrep;
 intros; normalize.
 auto with valid_pointer.
 apply sepcon_valid_pointer1.
 apply data_at_valid_ptr; auto.
 simpl;  computable.
Qed.

Hint Resolve listrep_valid_pointer : valid_pointer.

(** Specification of the [reverse] function.  It characterizes
 ** the precondition required for calling the function,
 ** and the postcondition guaranteed by the function.
 **)
Definition reverse_spec :=
 DECLARE _reverse
  WITH sigma : list val, p: val
  PRE  [ _p OF (tptr t_struct_list) ]
     PROP ()
     LOCAL (temp _p p)
     SEP (listrep sigma p)
  POST [ (tptr t_struct_list) ]
    EX q:val,
     PROP () LOCAL (temp ret_temp q)
     SEP (listrep(rev sigma) q).

(** The global function spec, characterizing the
 ** preconditions/postconditions of all the functions
 ** that your proved-correct program will call.
 ** Normally you include all the functions here, but
 ** in this tutorial example we include only one. *)
Definition Gprog : funspecs :=
         ltac:(with_library prog [ reverse_spec ]).

(** For each function definition in the C program, prove that the
 ** function-body (in this case, f_reverse) satisfies its specification
 ** (in this case, reverse_spec).
 **)
Lemma body_reverse: semax_body Vprog Gprog
                                    f_reverse reverse_spec.
Proof.
(** The start_function tactic "opens up" a semax_body
 ** proof goal into a Hoare triple. *)
start_function.
(** For each assignment statement, "symbolically execute" it
 ** using the forward tactic *)
forward.  (* w = NULL; *)
forward.  (* v = p; *)
(** To prove a while-loop, you must supply a loop invariant,
 ** in this case (EX s1  PROP(...)LOCAL(...)(SEP(...)).  *)
forward_while
   (EX s1: list val, EX s2 : list val,
    EX w: val, EX v: val,
     PROP (sigma = rev s1 ++ s2)
     LOCAL (temp _w w; temp _v v)
     SEP (listrep s1 w; listrep s2 v)).
(** The forward_while tactic leaves four subgoals,
 ** which we mark with * (the Coq "bullet") *)
* (* Prove that precondition implies loop invariant *)
Exists (@nil val) sigma nullval p.
entailer!.
unfold listrep.
entailer!.
* (* Prove that loop invariant implies typechecking of loop condition *)
entailer!.
* (* Prove that loop body preserves invariant *)
destruct s2 as [ | h r].
 - unfold listrep at 2.
   Intros. subst. contradiction.
 - unfold listrep at 2; fold listrep.
   Intros y.
   forward. (* t = v->tail *)
   forward. (* v->tail = w; *)
   forward. (* w = v; *)
   forward. (* v = t; *)
   (* At end of loop body; reestablish invariant *)
   entailer!.
   Exists (h::s1,r,v,y).
   entailer!.
   + simpl. rewrite app_ass. auto.
   + unfold listrep at 3; fold listrep.
     Exists w. entailer!.
* (* after the loop *)
forward.  (* return w; *)
Exists w; entailer!.
rewrite (proj1 H1) by auto.
unfold listrep at 2; fold listrep.
entailer!.
rewrite <- app_nil_end, rev_involutive.
auto.
Qed.

(** See the file [progs/verif_reverse.v] for an alternate
 ** proof of this function, using a general theory of
 ** list segments.  That file also has proofs of the
 ** sumlist function, the main function, and the
 ** [semax_func] theorem that ties all the functions together
 **)


(**
 * Special handling of ascii and strings for extraction to Haskell.
 *)

Require Coq.extraction.Extraction.

Require Import Ascii.
Require Import String.

(**
 * At the moment, Coq's extraction has no way to add extra import
 * statements to the extracted Haskell code.  You will have to
 * manually add:
 *
 *   import qualified Data.Bits
 *   import qualified Data.Char
 *)

Extract Inductive ascii => "Prelude.Char"
  [ "(\b0 b1 b2 b3 b4 b5 b6 b7 -> Data.Char.chr (
      (if b0 then Data.Bits.shiftL 1 0 else 0) Prelude.+
      (if b1 then Data.Bits.shiftL 1 1 else 0) Prelude.+
      (if b2 then Data.Bits.shiftL 1 2 else 0) Prelude.+
      (if b3 then Data.Bits.shiftL 1 3 else 0) Prelude.+
      (if b4 then Data.Bits.shiftL 1 4 else 0) Prelude.+
      (if b5 then Data.Bits.shiftL 1 5 else 0) Prelude.+
      (if b6 then Data.Bits.shiftL 1 6 else 0) Prelude.+
      (if b7 then Data.Bits.shiftL 1 7 else 0)))" ]
  "(\f a -> f (Data.Bits.testBit (Data.Char.ord a) 0)
              (Data.Bits.testBit (Data.Char.ord a) 1)
              (Data.Bits.testBit (Data.Char.ord a) 2)
              (Data.Bits.testBit (Data.Char.ord a) 3)
              (Data.Bits.testBit (Data.Char.ord a) 4)
              (Data.Bits.testBit (Data.Char.ord a) 5)
              (Data.Bits.testBit (Data.Char.ord a) 6)
              (Data.Bits.testBit (Data.Char.ord a) 7))".
Extract Inlined Constant Ascii.ascii_dec => "(Prelude.==)".

Extract Inductive string => "Prelude.String" [ "([])" "(:)" ].
Extract Inlined Constant String.string_dec => "(Prelude.==)".


From HTTP Require Export
     Tester.
From App Require Export
     Observe.

Definition solver_state := list (var * (N + list N)).

Definition assertN (nx : exp N) (n : N) (s : solver_state)
  : option solver_state :=
  match nx with
  | Exp__Var x =>
    match get x s with
    | Some (inl n0) => if n0 =? n then Some s else None
    | Some (inr ns) => if existsb (N.eqb n) ns
                      then None
                      else Some $ update x (inl n) s
    | None => Some $ put x (inl n) s
    end
  | Exp__Const n0 => if n0 =? n then Some s else None
  | Exp__Nth _ _  => None
  end.

Definition assertNotN (nx : exp N) (n : N) (s : solver_state)
  : option solver_state :=
  match nx with
  | Exp__Var x =>
    match get x s with
    | Some (inl n0) => if n0 =? n then None else Some s
    | Some (inr ns) => Some $ update x (inr (n::ns)) s
    | None => Some $ put x (inr [n]) s
    end
  | Exp__Const n0 => if n0 =? n then None else Some s
  | Exp__Nth _ _ => None
  end.

Definition unifyOrder (s : solver_state) (ox : orderT exp) (o : orderT id)
  : option solver_state :=
  let '((oidx, (bix, bax, six, sax)), (oid, (bi, ba, si, sa))) := (ox, o) in
  if (bax, sax) = (ba, sa)?
  then assertN oidx oid s >>= assertN bix bi >>= assertN six si
  else None.

Definition unifyAccount (s : solver_state) (ax : accountT exp) (a : accountT id)
  : option solver_state :=
  let '((aidx, vx), (aid, v)) := (ax, a) in
  if vx = v? then assertN aidx aid s else None.

Definition unifyList {A : (Type -> Type) -> Type}
           (unifier : solver_state -> A exp -> A id -> option solver_state)
           (lx : list (A exp)) (l : list (A id)) (s : solver_state)
  : option solver_state :=
  if length lx =? length l
  then fold_left (fun os ab => os >>= (fun s => uncurry (unifier s) ab))
                 (zip lx l) (pure s)
  else None.

Fixpoint eval_nth_const {E} `{decideE -< E} `{failureE -< E}
           (n : N) (l : list (exp N))
  : Monads.stateT solver_state (itree E) nat :=
  fun s =>
    match l with
    | [] => ret (s, O)
    | x::l' =>
      let left  s1 := ret (s1, O) in
      let right s2 := '(s3, n') <- eval_nth_const n l' s2;;
                      ret (s3, S n') in
      match assertN x n s, assertNotN x n s with
      | Some s1, Some s2 =>
        b <- trigger Decide;;
        if b : bool then left s1 else right s2
      | Some s1, None => left s1
      | None, Some s2 => right s2
      | None, None => throw "Unsatisfiable"
      end
    end.

Fixpoint find_nth {A} (f : A -> bool) (l : list A) : option nat :=
  if l is a::l'
  then if f a then Some O else S <$> find_nth f l'
  else None.

Definition eval_nth {E} `{decideE -< E} `{failureE -< E}
         (x : exp N) (l : list (exp N))
  : Monads.stateT solver_state (itree E) nat :=
  fun s =>
    if find_nth (exp_eq x) l is Some n
    then ret (s, n)
    else
      match x with
      | Exp__Var x =>
        match get x s with
        | Some (inl n) => eval_nth_const n l s
        | _ => ret (s, length l)
        end
      | Exp__Const n => eval_nth_const n l s
      | _ => throw "Should not happen: eval_nth"
      end.

Definition instantiate_unify {E A} `{failureE -< E} `{decideE -< E}
           (e : unifyE swap_response A)
  : Monads.stateT solver_state (itree E) A :=
  fun s : solver_state =>
    match e with
    | Unify__Fresh =>
      let x : var := fresh_var s in
      ret (put x (inr []) s, Exp__Var x)
    | Unify__Eval v =>
      if v is Exp__Nth n l
      then eval_nth n l s
      else throw "Should not happen: instantiate_unify"
    | Unify__Match rx r =>
      let mismatch := throw $ "Expect " ++ to_string rx
                            ++ " but observed " ++ to_string r
                            ++ " under " ++ to_string s in
      let handle os' := if os' is Some s' then ret (s', tt) else mismatch in
      match rx, r with
      | Response__BadRequest      , Response__BadRequest
      | Response__InsufficientFund, Response__InsufficientFund
      | Response__NotFound        , Response__NotFound => ret (s, tt)
      | Response__ListAccount lx  , Response__ListAccount l =>
        handle $ unifyList (A:=accountT) unifyAccount lx l s
      | Response__ListOrders  lx  , Response__ListOrders  l =>
        handle $ unifyList (A:=orderT) unifyOrder lx l s
      | Response__ListAccount [], Response__ListOrders  []
      | Response__ListOrders  [], Response__ListAccount [] => ret (s, tt)
      | Response__Account ax, Response__Account a => handle $ unifyAccount s ax a
      | Response__Order   ox, Response__Order   o => handle $ unifyOrder   s ox o
      | _, _ => mismatch
      end
    end.

Definition solver' {E F} `{failureE -< E} `{decideE -< E} `{F -< E}
           (m : itree (unifyE swap_response +' F) void)
  : Monads.stateT solver_state (itree E) void :=
  interp
    (fun _ e =>
       match e with
       | (ue|) => instantiate_unify ue
       | (|ee)  => liftState (F:=itree _) (trigger ee)
       end) m.

Definition solver {E F} `{failureE -< E} `{decideE -< E} `{F -< E}
           (m : itree (unifyE swap_response +' F) void) : itree E void :=
  snd <$> solver' m [].

Class Is__stE q r s E `{failureE -< E} `{decideE -< E} `{observeE q r s -< E}.
Notation stE q r s := (failureE +' decideE +' observeE q r s).
Instance stE_Is__stE q r s : Is__stE q r s (stE q r s). Defined.

Definition solve_swap {E}
           `{Is__stE (swap_request id) (swap_response id) (swap_state exp) E}
           : swap_state exp -> itree E void
  := solver ∘ observe_swap.


From iris.algebra Require Import excl.
From iris.proofmode Require Import tactics.
From iris.base_logic.lib Require Export invariants.
From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Export lang.
From iris.heap_lang Require Import proofmode notation.
From iris.prelude Require Import options.

Definition spawn : val :=
  λ: "f",
    let: "c" := ref NONE in
    Fork ("c" <- SOME ("f" #())) ;; "c".
Definition join : val :=
  rec: "join" "c" :=
    match: !"c" with
      SOME "x" => "x"
    | NONE => "join" "c"
    end.

(** The CMRA & functor we need. *)
(* Not bundling heapG, as it may be shared with other users. *)
Class spawnG Σ := SpawnG { spawn_tokG :> inG Σ (exclR unitO) }.
Definition spawnΣ : gFunctors := #[GFunctor (exclR unitO)].

Global Instance subG_spawnΣ {Σ} : subG spawnΣ Σ → spawnG Σ.
Proof. solve_inG. Qed.

(** Now we come to the Iris part of the proof. *)
Section proof.
Context `{!heapG Σ, !spawnG Σ} (N : namespace).

Definition spawn_inv (γ : gname) (l : loc) (Ψ : val → iProp Σ) : iProp Σ :=
  ∃ lv, l ↦ lv ∗ (⌜lv = NONEV⌝ ∨
                  ∃ w, ⌜lv = SOMEV w⌝ ∗ (Ψ w ∨ own γ (Excl ()))).

Definition join_handle (l : loc) (Ψ : val → iProp Σ) : iProp Σ :=
  ∃ γ, own γ (Excl ()) ∗ inv N (spawn_inv γ l Ψ).

Global Instance spawn_inv_ne n γ l :
  Proper (pointwise_relation val (dist n) ==> dist n) (spawn_inv γ l).
Proof. solve_proper. Qed.
Global Instance join_handle_ne n l :
  Proper (pointwise_relation val (dist n) ==> dist n) (join_handle l).
Proof. solve_proper. Qed.

(** The main proofs. *)
Lemma spawn_spec (Ψ : val → iProp Σ) (f : val) :
  {{{ WP f #() {{ Ψ }} }}} spawn f {{{ l, RET #l; join_handle l Ψ }}}.
Proof.
  iIntros (Φ) "Hf HΦ". rewrite /spawn /=. wp_lam.
  wp_alloc l as "Hl".
  iMod (own_alloc (Excl ())) as (γ) "Hγ"; first done.
  iMod (inv_alloc N _ (spawn_inv γ l Ψ) with "[Hl]") as "#?".
  { iNext. iExists NONEV. iFrame; eauto. }
  wp_smart_apply (wp_fork with "[Hf]").
  - iNext. wp_bind (f _). iApply (wp_wand with "Hf"); iIntros (v) "Hv".
    wp_inj. iInv N as (v') "[Hl _]".
    wp_store. iSplitL; last done. iIntros "!> !>". iExists (SOMEV v). iFrame. eauto.
  - wp_pures. iApply "HΦ". rewrite /join_handle. eauto.
Qed.

Lemma join_spec (Ψ : val → iProp Σ) l :
  {{{ join_handle l Ψ }}} join #l {{{ v, RET v; Ψ v }}}.
Proof.
  iIntros (Φ) "H HΦ". iDestruct "H" as (γ) "[Hγ #?]".
  iLöb as "IH". wp_rec. wp_bind (! _)%E. iInv N as (v) "[Hl Hinv]".
  wp_load. iDestruct "Hinv" as "[%|Hinv]"; subst.
  - iModIntro. iSplitL "Hl"; [iNext; iExists _; iFrame; eauto|].
    wp_smart_apply ("IH" with "Hγ [HΦ]"). auto.
  - iDestruct "Hinv" as (v' ->) "[HΨ|Hγ']".
    + iModIntro. iSplitL "Hl Hγ"; [iNext; iExists _; iFrame; eauto|].
      wp_pures. by iApply "HΦ".
    + iDestruct (own_valid_2 with "Hγ Hγ'") as %[].
Qed.
End proof.

Typeclasses Opaque join_handle.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.
Require Import BaremoreHandler.Spec.

Local Open Scope Z_scope.

Section SpecLow.

  Definition smc_mark_nonsecure_spec0 (addr: Z64) (adt: RData) : option RData :=
    match addr with
    | VZ64 _addr =>
      rely is_int64 (3288334336 + 257);
      rely is_int (3288334336 + 257);
      rely is_int64 _addr;
      when adt == set_monitor_call_spec (3288334336 + 257) (VZ64 _addr) adt;
      when adt == el3_sync_lel_spec  adt;
      when' _t'1 == get_monitor_call_ret_spec  adt;
      rely is_int64 _t'1;
      rely is_int _t'1;
      let _ret := _t'1 in
      rely is_int (1 - _ret);
      when adt == assert_cond_spec (1 - _ret) adt;
      Some adt
     end
    .

End SpecLow.


From mathcomp.ssreflect
Require Import ssreflect ssrbool ssrnat eqtype fintype choice ssrfun seq path.

From mathcomp.ssreflect
Require Import tuple.

Set Implicit Arguments.

From Probchain
Require Import BlockChain InvMisc FixedList FixedMap Parameters.

Definition oraclestate_keytype := [eqType of ([eqType of ([eqType of Nonce] * [eqType of Hashed] * [eqType of BlockRecord])] )%type].

Definition OracleState := fixmap  oraclestate_keytype  [eqType of Hashed] oraclestate_size.

Definition oraclestate_new : OracleState := fixmap_empty oraclestate_keytype [eqType of Hashed] oraclestate_size.

Definition oraclestate_find k (m : OracleState) := fixmap_find k m.

Definition oraclestate_put (k: oraclestate_keytype) (v : Hashed) (m: OracleState) : OracleState :=
  fixmap_put k v m.

Canonical oraclestate_of_eqType := Eval hnf in [eqType of (OracleState)].
Canonical oraclestate_of_choiceType := Eval hnf in [choiceType of (OracleState)].
Canonical oraclestate_of_countType := Eval hnf in [countType of (OracleState)].
Canonical oraclestate_of_finType := Eval hnf in [finType of (OracleState)].


Require Import Kami.AllNotations.

Require Import ProcKami.FU.

Section pmp.
  Context {procParams: ProcParams}.
  Variable ty: Kind -> Type.

  Local Open Scope kami_expr.
  Local Open Scope kami_action.

  Local Definition PmpEntryPkt
    := STRUCT_TYPE {
         "cfg" :: PmpCfg ;
         "addr" :: Bit pmp_reg_width
         }.

  Local Definition pmp_entry_read
    (n : nat)
    :  ActionT ty PmpEntryPkt
    := Read entry_cfg
         :  PmpCfg
         <- @^("pmp" ++ natToHexStr n ++ "cfg");
       Read entry_addr
         :  Bit pmp_reg_width
         <- @^("pmpaddr" ++ natToHexStr n);
       Ret
         (STRUCT {
            "cfg" ::= #entry_cfg;
            "addr" ::= #entry_addr
          } : PmpEntryPkt @# ty).

  Local Definition pmp_addr_acc_kind
    := STRUCT_TYPE {
         "any_matched" :: Bool;
         "all_matched" :: Bool
       }.

  Local Definition pmp_entry_acc_kind
    := STRUCT_TYPE {
         "any_on"  :: Bool;
         "addr"    :: PAddr;
         "matched" :: Bool;
         "pmp_cfg" :: PmpCfg
       }.

  Local Definition div_up x y
    := (if Nat.eqb (x mod y) 0
         then x / y
         else S (x / y))%nat.

  Definition checkPmp
    (check : AccessType @# ty)
    (mode : PrivMode @# ty)
    (addr : PAddr @# ty)
    (addr_len : MemRqLgSize @# ty)
    :  ActionT ty Bool
    := (* System [
         DispString _ "[checkPmp] addr: ";
         DispHex addr;
         DispString _ "\n";
         DispString _ "[checkPmp] addr len: ";
         DispHex addr_len;
         DispString _ "\n"
       ]; *)
       LETA result
         :  pmp_entry_acc_kind
         <- fold_left
              (fun (acc_act : ActionT ty pmp_entry_acc_kind) entry_index
                => LETA acc <- acc_act;
(*
                   System [
                     DispString _ "[checkPmp] ==================================================\n";
                     DispString _ ("[checkPmp] checking register: pmp" ++ natToHexStr (S entry_index) ++ "cfg.\n");
                     DispString _ "[checkPmp] acc: ";
                     DispHex #acc;
                     DispString _ "\n"
                   ];
*)
                   LETA entry
                     :  PmpEntryPkt
                     <- pmp_entry_read entry_index;
                   LET tor
                     :  PAddr
                     <- ((ZeroExtendTruncLsb PAddrSz (#entry @% "addr")) << (Const ty (natToWord 2 2)));
(*
                   System [
                     DispString _ "[checkPmp] entry: ";
                     DispHex #entry;
                     DispString _ "\n";
                     DispString _ "[checkPmp] entry addr: ";
                     DispHex (#entry @% "addr");
                     DispString _ "\n";
                     DispString _ "[checkPmp] sign extended entry addr: ";
                     DispHex (#entry @% "addr");
                     DispString _ "\n";
                     DispString _ "[checkPmp] tor: ";
                     DispHex #tor;
                     DispString _ "\n"
                   ];
*)
                   LET mask0
                     :  PAddr
                     <- ((ZeroExtendTruncLsb PAddrSz (#entry @% "addr")) << (Const ty (natToWord 1 1))) .| $1;
                   LET mask
                     :  PAddr
                     <- ~ (#mask0 .&  (~ (#mask0 + $1))) << (Const ty (natToWord 2 2));
(*
                   System [
                     DispString _ "[checkPmp] mask: ";
                     DispHex #mask;
                     DispString _ "\n"
                   ];
*)
                   GatherActions
                     (map
                       (fun index
                         => LET offset
                              :  Bit MemRqSize
                              <- Const ty (natToWord MemRqSize (4 * index)%nat);
                            If #offset < ($1 << addr_len)
                              then
                                LET curr_addr
                                  :  PAddr
                                  <- (addr + (ZeroExtendTruncLsb PAddrSz #offset));
                                LET napot_match
                                  :  Bool
                                  <- ((CABit Bxor [#curr_addr; #tor]) .&  #mask) == $0;
                                LET tor_match
                                  :  Bool
                                  <- (#acc @% "addr" <= #curr_addr) &&  (#curr_addr < #tor);
                                LET matched
                                  :  Bool
                                  <- IF #entry @% "cfg" @% "A" == $1
                                       then #tor_match
                                       else #napot_match;
                                Ret (Valid #matched : Maybe Bool @# ty)
                              else Ret Invalid
                              as result;
                            Ret #result)
                       (seq 0 (div_up Rlen_over_8 4)))
                     as match_results;
                   LET addr_result
                     :  pmp_addr_acc_kind
                     <- STRUCT {
                          "any_matched"
                            ::= (@Kor _ Bool)
                                  (map
                                    (fun result : Maybe Bool @# ty
                                      => result @% "valid" &&  result @% "data")
                                    match_results);
                          "all_matched"
                            ::= CABool And
                                  (map
                                    (fun result : Maybe Bool @# ty
                                      => !(result @% "valid") || result @% "data")
                                    match_results)
                        } : pmp_addr_acc_kind @# ty;
                   LET isOff <- #entry @% "cfg" @% "A" == $0;
                   Ret (STRUCT {
                            "any_on"  ::= ((#acc @% "any_on") || !#isOff) ;
                            "addr"    ::= #tor ;
                            "matched" ::= ((#acc @% "matched") ||
                                           (!#isOff &&  #addr_result @% "all_matched"));
                            "pmp_cfg" ::= (IF #acc @% "matched"
                                           then #acc @% "pmp_cfg"
                                           else #entry @% "cfg") }: pmp_entry_acc_kind @# ty))
              (seq 0 16)
              (Ret (STRUCT {
                 "any_on"  ::= $$false;
                 "addr"    ::= $$(getDefaultConst PAddr);
                 "matched" ::= $$false;
                 "pmp_cfg" ::= $$(getDefaultConst PmpCfg)
               } : pmp_entry_acc_kind @# ty));
(*
    System [
         DispString _ "[checkPmp] ##################################################\n";
         DispString _ "[checkPmp] result: ";
         DispHex #result;
         DispString _ "\n"
       ];
*)
       Ret
         (IF #result @% "matched"
          then
             (mode == $MachineMode &&  !(#result @% "pmp_cfg" @% "L")) ||
             (Switch check Retn Bool With {
               ($VmAccessLoad : AccessType @# ty)
                 ::= #result @% "pmp_cfg" @% "R";
               ($VmAccessSAmo : AccessType @# ty)
                 ::= #result @% "pmp_cfg" @% "R" &&  #result @% "pmp_cfg" @% "W";
               ($VmAccessInst : AccessType @# ty)
                 ::= #result @% "pmp_cfg" @% "X"
             })
           else
             (!(#result @% "any_on") || mode == $MachineMode)).

  Local Close Scope kami_action.
  Local Close Scope kami_expr.

End pmp.