Require Import CertiGraph.unionfind.env_unionfind.
Require Import CertiGraph.graph.graph_model.
Require Import CertiGraph.graph.path_lemmas.
Require Import CertiGraph.graph.subgraph2.
Require Import CertiGraph.graph.graph_relation.
Require Import CertiGraph.graph.reachable_computable.
Require Import CertiGraph.msl_application.Graph.
Require Import CertiGraph.msl_application.UnionFindGraph.
Require Import CertiGraph.msl_application.GList.
Require Import CertiGraph.msl_application.GList_UnionFind.
Require Import CertiGraph.floyd_ext.share.
Require Import CertiGraph.unionfind.spatial_graph_glist.

Local Coercion UFGraph_LGraph: UFGraph >-> LGraph.
Local Coercion LGraph_SGraph: LGraph >-> SGraph.
Local Identity Coercion ULGraph_LGraph: LGraph >-> UnionFindGraph.LGraph.
Local Identity Coercion LGraph_LabeledGraph: UnionFindGraph.LGraph >-> LabeledGraph.
Local Identity Coercion SGraph_PointwiseGraph: SGraph >-> PointwiseGraph.
Local Coercion pg_lg: LabeledGraph >-> PreGraph.

Notation vertices_at sh P g:= (@vertices_at _ _ _ _ _ mpred (@SGP pSGG_VST nat unit (sSGG_VST sh)) (SGA_VST sh) P g).
Notation whole_graph sh g := (vertices_at sh (vvalid g) g).
Notation graph sh x g := (@reachable_vertices_at _ _ _ _ _ _ _ _ _ _ (@SGP pSGG_VST nat unit (sSGG_VST sh)) _ x g).
Notation UFGraph := (@UFGraph pSGG_VST).
Existing Instances maGraph finGraph liGraph RGF.

Definition mallocN_spec :=
 DECLARE _mallocN
  WITH sh: wshare, n:Z
  PRE [tint]
     PROP (0 <= n <= Int.max_signed)
     PARAMS (Vint (Int.repr n))
     GLOBALS ()
     SEP ()
  POST [ tptr tvoid ]
     EX v: addr,
     PROP ()
     LOCAL (temp ret_temp (pointer_val_val v))
     SEP (data_at sh node_type (pointer_val_val null, (Vint (Int.repr 0)))
              (pointer_val_val v)).

Definition find_spec :=
 DECLARE _find
  WITH sh: wshare, g: UFGraph, x: pointer_val
  PRE [tptr (Tstruct _Node noattr)]
          PROP  (vvalid g x)
          PARAMS (pointer_val_val x)
          GLOBALS ()
          SEP   (whole_graph sh g)
  POST [ tptr (Tstruct _Node noattr) ]
        EX g': UFGraph, EX rt : pointer_val,
        PROP (uf_equiv g g' /\ uf_root g' x rt)
        LOCAL (temp ret_temp (pointer_val_val rt))
        SEP (whole_graph sh g').

Definition unionS_spec :=
 DECLARE _unionS
  WITH sh: wshare, g: UFGraph, x: pointer_val, y: pointer_val
  PRE [tptr (Tstruct _Node noattr), tptr (Tstruct _Node noattr)]
          PROP  (vvalid g x; vvalid g y)
          PARAMS (pointer_val_val x; pointer_val_val y)
          GLOBALS ()
          SEP   (whole_graph sh g)
  POST [ Tvoid ]
        EX g': UFGraph,
        PROP (uf_union g x y g')
        LOCAL()
        SEP (whole_graph sh g').

Definition makeSet_spec :=
  DECLARE _makeSet
  WITH sh: wshare, g: UFGraph
    PRE []
      PROP ()
      PARAMS ()
      GLOBALS ()
      SEP (whole_graph sh g)
    POST [tptr (Tstruct _Node noattr)]
      EX g': UFGraph, EX rt: pointer_val,
      PROP (~ vvalid g rt ; vvalid g' rt ; is_partial_graph g g')
      LOCAL (temp ret_temp (pointer_val_val rt))
      SEP (whole_graph sh g').

Definition Gprog : funspecs := ltac:(with_library prog [mallocN_spec; makeSet_spec; find_spec; unionS_spec]).

Lemma body_makeSet: semax_body Vprog Gprog f_makeSet makeSet_spec.
Proof.
  start_function.
  forward_call (sh, 8).
  - rep_lia.
  - Intros x.
    assert_PROP (x <> null) as x_not_null by (entailer !; destruct H0 as [? _]; apply H0).
    assert_PROP (~ vvalid g x) by (entailer; apply (@vertices_at_sepcon_unique_1x _ _ _ _ SGBA_VST _ _ (SGA_VST sh) (SGAvs_VST sh) g x (vvalid g) (O, null))).
    forward. forward. forward.
    Exists (make_set_Graph O tt tt x g x_not_null H). Exists x. entailer!.
    + split; simpl; [right | apply is_partial_make_set_pregraph]; auto.
    + assert (Coqlib.Prop_join (vvalid g) (eq x) (vvalid (make_set_Graph 0%nat tt tt x g x_not_null H))). {
        simpl; hnf; split; intros; [unfold graph_gen.addValidFunc | subst a]; intuition.
      } assert (vgamma (make_set_Graph O tt tt x g x_not_null H) x = (O, x)). {
        unfold vgamma, UnionFindGraph.vgamma. simpl. f_equal.
        - destruct (SGBA_VE x x); [| hnf in c; unfold Equivalence.equiv in c; exfalso]; auto.
        - unfold graph_gen.updateEdgeFunc. destruct (EquivDec.equiv_dec (x, tt) (x, tt)). 2: compute in c; exfalso; auto. destruct (SGBA_VE null null); auto.
          hnf in c. unfold Equivalence.equiv in c. exfalso; auto.
      } rewrite <- (vertices_at_sepcon_1x (make_set_Graph 0%nat tt tt x g x_not_null H) x (vvalid g) _ (O, x)); auto. apply sepcon_derives. 1: apply derives_refl.
      assert (vertices_at sh (vvalid g) g = vertices_at sh (vvalid g) (make_set_Graph O tt tt x g x_not_null H)). {
        apply vertices_at_vertices_identical. simpl. hnf. intros. destruct a as [y ?]. unfold Morphisms_ext.app_sig. simpl.
        unfold UnionFindGraph.vgamma. simpl. unfold graph_gen.updateEdgeFunc. f_equal.
        - destruct (SGBA_VE y x); [hnf in e; subst y; exfalso |]; auto.
        - destruct (EquivDec.equiv_dec (x, tt) (y, tt)); auto. hnf in e. inversion e. subst y. exfalso; auto.
      } rewrite <- H5. apply derives_refl.
Qed.

Lemma false_Cne_eq: forall x y, typed_false tint (force_val (sem_cmp_pp Cne (pointer_val_val x) (pointer_val_val y))) -> x = y.
Proof.
  intros. hnf in H. destruct x, y; inversion H; auto. simpl in H. clear H1. unfold sem_cmp_pp in H. simpl in H. destruct (eq_block b b0).
  - destruct (Ptrofs.eq i i0) eqn:? .
    + pose proof (Ptrofs.eq_spec i i0). rewrite Heqb1 in H0. subst; auto.
    + simpl in H. inversion H.
  - simpl in H. inversion H.
Qed.

Lemma true_Cne_neq: forall x y, typed_true tint (force_val (sem_cmp_pp Cne (pointer_val_val x) (pointer_val_val y))) -> x <> y.
Proof.
  intros. hnf in H. destruct x, y; inversion H; [|intro; inversion H0..]. simpl in H. clear H1. unfold sem_cmp_pp in H. simpl in H. destruct (eq_block b b0).
  - destruct (Ptrofs.eq i i0) eqn:? .
    + simpl in H. inversion H.
    + subst b0. pose proof (Ptrofs.eq_spec i i0). rewrite Heqb1 in H0. intro; apply H0. inversion H1. reflexivity.
  - intro. inversion H0. auto.
Qed.

Lemma graph_local_facts: forall sh x (g: UFGraph), vvalid g x -> whole_graph sh g |-- valid_pointer (pointer_val_val x).
Proof.
  intros. eapply derives_trans; [apply (@vertices_at_ramif_1_stable _ _ _ _ SGBA_VST _ _ (SGA_VST sh) g (vvalid g) x (vgamma g x)); auto |].
  simpl vertex_at at 1. unfold binode. entailer!.
Qed.

Lemma body_find: semax_body Vprog Gprog f_find find_spec.
Proof.
  start_function.
  remember (vgamma g x) as rpa eqn:?H. destruct rpa as [r pa].
  (* p = x -> parent; *)
  localize [data_at sh node_type (vgamma2cdata (vgamma g x)) (pointer_val_val x)]. rewrite <- H0. simpl vgamma2cdata.
  forward. 1: entailer!; destruct pa; simpl; auto.
  unlocalize [whole_graph sh g].
  1: rewrite <- H0; simpl vgamma2cdata; apply (@vertices_at_ramif_1_stable _ _ _ _ SGBA_VST _ _ (SGA_VST sh) g (vvalid g) x (r, pa)); auto.
  assert (H_PARENT_Valid: vvalid g pa) by (eapply valid_parent; eauto).
  (* if (p != x) { *)
  forward_if
    (EX g': UFGraph, EX rt : pointer_val,
     PROP (uf_equiv g g' /\ uf_root g' x rt)
     LOCAL (temp _p (pointer_val_val rt); temp _x (pointer_val_val x))
     SEP (whole_graph sh g')).
  - apply denote_tc_test_eq_split; apply graph_local_facts; auto.
  - (* p0 = find(p); *)
    forward_call (sh, g, pa). Intros vret. destruct vret as [g' root]. simpl fst in *. simpl snd in *. Opaque pointer_val_val. forward. Transparent pointer_val_val.
    pose proof (true_Cne_neq _ _ H1).
    assert (weak_valid g' root) by (right; destruct H3; apply reachable_foot_valid in H3; auto).
    assert (vvalid g' x) by (destruct H2 as [? _]; rewrite <- H2; apply H).
    assert (~ reachable g' root x) by (apply (uf_equiv_not_reachable g g' x r pa root); auto).
    assert (vertices_at sh (vvalid (Graph_gen_redirect_parent g' x root H5 H6 H7)) (Graph_gen_redirect_parent g' x root H5 H6 H7) =
            vertices_at sh (vvalid g') (Graph_gen_redirect_parent g' x root H5 H6 H7)). {
      apply vertices_at_Same_set. unfold Ensembles.Same_set, Ensembles.Included, Ensembles.In. simpl. intuition. }
    remember (vgamma g' x) as rpa eqn:?H. destruct rpa as [r' pa']. symmetry in H9.
    localize [data_at sh node_type (Vint (Int.repr (Z.of_nat r')), pointer_val_val pa') (pointer_val_val x)].
    forward. unlocalize [whole_graph sh (Graph_gen_redirect_parent g' x root H5 H6 H7)].
    + rewrite H8. apply (@graph_gen_redirect_parent_ramify _ (sSGG_VST sh)); auto. destruct H3.
      apply reachable_foot_valid in H3. intro. subst root. apply (valid_not_null g' null H3). simpl. auto.
    + Exists (Graph_gen_redirect_parent g' x root H5 H6 H7) root. rewrite H8. entailer!. split.
      * apply (graph_gen_redirect_parent_equiv g g' x r pa); auto.
      * simpl. apply (uf_root_gen_dst_same g' (liGraph g') x x root); auto. 2: apply reachable_refl; auto.
        rewrite <- (uf_equiv_root_the_same g g' x root); auto.
        apply (uf_root_edge _ (liGraph g) _ pa); [| apply (vgamma_not_dst g x r pa) | rewrite (uf_equiv_root_the_same g g')]; auto.
  - forward. Exists g x. entailer!. apply false_Cne_eq in H1. subst pa. split; [|split]; auto.
    + apply (uf_equiv_refl _  (liGraph g)).
    + apply uf_root_vgamma with (n := r); auto.
  - Intros g' rt. forward. Exists g' rt. entailer!.
Qed.

(* Print Assumptions body_find. *)

Lemma true_Ceq_eq: forall x y, typed_true tint (force_val (sem_cmp_pp Ceq (pointer_val_val x) (pointer_val_val y))) -> x = y.
Proof.
  intros. hnf in H. destruct x, y; inversion H; auto. simpl in H. clear H1. unfold sem_cmp_pp in H. simpl in H. destruct (eq_block b b0).
  - destruct (Ptrofs.eq i i0) eqn:? .
    + pose proof (Ptrofs.eq_spec i i0). rewrite Heqb1 in H0. subst. reflexivity.
    + simpl in H. inversion H.
  - simpl in H. inversion H.
Qed.

Lemma false_Ceq_neq: forall x y, typed_false tint (force_val (sem_cmp_pp Ceq (pointer_val_val x) (pointer_val_val y))) -> x <> y.
Proof.
  intros. hnf in H. destruct x, y; inversion H; [|intro; inversion H0..]. simpl in H. clear H1. unfold sem_cmp_pp in H. simpl in H. destruct (eq_block b b0).
  - destruct (Ptrofs.eq i i0) eqn:? .
    + simpl in H. inversion H.
    + pose proof (Ptrofs.eq_spec i i0). rewrite Heqb1 in H0. intro. apply H0. inversion H1. reflexivity.
  - intro. apply n. inversion H0; reflexivity.
Qed.

Lemma body_unionS: semax_body Vprog Gprog f_unionS unionS_spec.
Proof.
  start_function.
  forward_call (sh, g, x). Intros vret. destruct vret as [g1 x_root]. simpl fst in *. simpl snd in *.
  assert (vvalid g1 y) by (destruct H1 as [? _]; rewrite <- H1; apply H0).
  forward_call (sh, g1, y). Intros vret. destruct vret as [g2 y_root]. simpl fst in *. simpl snd in *.
  assert (H_VALID_XROOT: vvalid g2 x_root) by (destruct H4 as [? _]; rewrite <- H4; destruct H2; apply reachable_foot_valid in H2; apply H2).
  assert (H_VALID_YROOT: vvalid g2 y_root) by (destruct H5; apply reachable_foot_valid in H5; apply H5).
  assert (H_XROOT_NOT_NULL: x_root <> null) by (intro; subst x_root; apply (valid_not_null g2 null H_VALID_XROOT); simpl; auto).
  assert (H_YROOT_NOT_NULL: y_root <> null) by (intro; subst y_root; apply (valid_not_null g2 null H_VALID_YROOT); simpl; auto).
  forward_if_tac
    (PROP (x_root <> y_root)
     LOCAL (temp _yRoot (pointer_val_val y_root); temp _xRoot (pointer_val_val x_root);
     temp _x (pointer_val_val x); temp _y (pointer_val_val y))
     SEP (vertices_at sh (vvalid g2) g2)).
  - apply denote_tc_test_eq_split; apply graph_local_facts; auto.
  - forward. Exists g2. entailer !. apply true_Ceq_eq in H6. subst y_root. apply (the_same_root_union g g1 g2 x y x_root); auto.
  - forward. apply false_Ceq_neq in H6. entailer!.
  - Intros. (* xRank = xRoot -> rank; *)
    remember (vgamma g2 x_root) as rpa eqn:?H. destruct rpa as [rankXRoot paXRoot]. symmetry in H7.
    localize [data_at sh node_type (vgamma2cdata (vgamma g2 x_root)) (pointer_val_val x_root)].
    rewrite H7. simpl vgamma2cdata. forward.
    unlocalize [whole_graph sh g2].
    1: rewrite H7; simpl; apply (@vertices_at_ramif_1_stable _ _ _ _ SGBA_VST _ _ (SGA_VST sh) g2 (vvalid g2) x_root (rankXRoot, paXRoot)); auto.
    (* yRank = yRoot -> rank; *)
    remember (vgamma g2 y_root) as rpa eqn:?H. destruct rpa as [rankYRoot paYRoot]. symmetry in H8.
    localize [data_at sh node_type (vgamma2cdata (vgamma g2 y_root)) (pointer_val_val y_root)].
    rewrite H8. simpl vgamma2cdata. forward.
    unlocalize [whole_graph sh g2].
    1: rewrite H8; simpl; apply (@vertices_at_ramif_1_stable _ _ _ _ SGBA_VST _ _ (SGA_VST sh) g2 (vvalid g2) y_root (rankYRoot, paYRoot)); auto.
    forward_if
      (EX g': UFGraph,
       PROP (uf_union g x y g')
       LOCAL (temp _xRank (Vint (Int.repr (Z.of_nat rankXRoot))); temp _yRank (Vint (Int.repr (Z.of_nat rankYRoot)));
              temp _xRoot (pointer_val_val x_root); temp _yRoot (pointer_val_val y_root);
              temp _x (pointer_val_val x); temp _y (pointer_val_val y))
       SEP (whole_graph sh g')).
    + assert (weak_valid g2 y_root) by (right; auto). rename H_VALID_XROOT into H11.
      assert (~ reachable g2 y_root x_root) by (intro; destruct H5; specialize (H13 _ H12); auto).
      assert (vertices_at sh (vvalid (Graph_gen_redirect_parent g2 x_root y_root H10 H11 H12)) (Graph_gen_redirect_parent g2 x_root y_root H10 H11 H12) =
          vertices_at sh (vvalid g2) (Graph_gen_redirect_parent g2 x_root y_root H10 H11 H12)). {
        apply vertices_at_Same_set. unfold Ensembles.Same_set, Ensembles.Included, Ensembles.In. simpl. intuition. }
      (* xRoot -> parent = yRoot; *)
      localize [data_at sh node_type (vgamma2cdata (vgamma g2 x_root)) (pointer_val_val x_root)].
      rewrite H7. simpl vgamma2cdata. forward. unlocalize [whole_graph sh (Graph_gen_redirect_parent g2 x_root y_root H10 H11 H12)].
      1: rewrite H7; simpl vgamma2cdata; rewrite H13; apply (@graph_gen_redirect_parent_ramify _ (sSGG_VST sh)); auto.
      Exists (Graph_gen_redirect_parent g2 x_root y_root H10 H11 H12). rewrite H13. entailer!. apply (diff_root_union_1 g g1 g2 x y x_root y_root); auto.
    + assert (weak_valid g2 x_root) by (right; auto). rename H_VALID_YROOT into H11.
      assert (~ reachable g2 x_root y_root) by (intro; rewrite (uf_equiv_root_the_same g1 g2) in H2; auto; destruct H2; specialize (H13 _ H12); auto).
      assert (vertices_at sh (vvalid (Graph_gen_redirect_parent g2 y_root x_root H10 H11 H12)) (Graph_gen_redirect_parent g2 y_root x_root H10 H11 H12) =
              vertices_at sh (vvalid g2) (Graph_gen_redirect_parent g2 y_root x_root H10 H11 H12)). {
        apply vertices_at_Same_set. unfold Ensembles.Same_set, Ensembles.Included, Ensembles.In. simpl. intuition. }
      forward_if
      (EX g': UFGraph,
       PROP (uf_union g x y g')
       LOCAL (temp _xRank (Vint (Int.repr (Z.of_nat rankXRoot))); temp _yRank (Vint (Int.repr (Z.of_nat rankYRoot)));
              temp _xRoot (pointer_val_val x_root); temp _yRoot (pointer_val_val y_root);
              temp _x (pointer_val_val x); temp _y (pointer_val_val y))
       SEP (whole_graph sh g')).
      * (* yRoot -> parent = xRoot; *)
        localize [data_at sh node_type (vgamma2cdata (vgamma g2 y_root)) (pointer_val_val y_root)].
        rewrite H8. simpl vgamma2cdata. forward. unlocalize [whole_graph sh (Graph_gen_redirect_parent g2 y_root x_root H10 H11 H12)].
        1: rewrite H8; simpl vgamma2cdata; rewrite H13; apply (@graph_gen_redirect_parent_ramify _ (sSGG_VST sh)); auto.
        Exists (Graph_gen_redirect_parent g2 y_root x_root H10 H11 H12). rewrite H13. entailer!. apply (diff_root_union_2 g g1 g2 x y x_root y_root); auto.
      * (* yRoot -> parent = xRoot; *)
        localize [data_at sh node_type (vgamma2cdata (vgamma g2 y_root)) (pointer_val_val y_root)].
        rewrite H8. simpl vgamma2cdata. forward. unlocalize [whole_graph sh (Graph_gen_redirect_parent g2 y_root x_root H10 H11 H12)].
        1: rewrite H8; simpl vgamma2cdata; rewrite H13; apply (@graph_gen_redirect_parent_ramify _ (sSGG_VST sh)); auto.
        set (g3 := (Graph_gen_redirect_parent g2 y_root x_root H10 H11 H12)).
        assert (uf_union g x y g3) by (subst g3; simpl; apply (diff_root_union_2 g g1 g2 x y x_root y_root); auto).
        (* xRoot -> rank = xRank + 1; *)
        localize [data_at sh node_type (vgamma2cdata (vgamma g2 x_root)) (pointer_val_val x_root)].
        rewrite H7. simpl vgamma2cdata. forward.
        rewrite add_repr. replace (Z.of_nat rankXRoot + 1) with (Z.of_nat (rankXRoot + 1)) by (rewrite Nat2Z.inj_add; simpl; auto).
        unlocalize [whole_graph sh (Graph_vgen g3 x_root (rankXRoot + 1)%nat)].
        -- assert (vertices_at sh (vvalid (Graph_vgen g3 x_root (rankXRoot + 1)%nat)) (Graph_vgen g3 x_root (rankXRoot + 1)%nat) =
                   vertices_at sh (vvalid g3) (Graph_vgen g3 x_root (rankXRoot + 1)%nat)). {
             apply vertices_at_Same_set. unfold Ensembles.Same_set, Ensembles.Included, Ensembles.In. simpl. intuition.
           } rewrite H16. clear H16. rewrite H7. simpl vgamma2cdata. apply (@graph_vgen_ramify _ (sSGG_VST sh)).
           ++ subst g3. simpl. auto.
           ++ subst g3. remember (Graph_gen_redirect_parent g2 y_root x_root H10 H11 H12) as g3.
              apply (graph_gen_redirect_parent_vgamma _ _ _ rankXRoot paXRoot) in Heqg3; auto. intros. inversion H16; auto.
        -- Exists (Graph_vgen g3 x_root (rankXRoot + 1)%nat). entailer!.
    + Intros g3. Exists g3. entailer!.
Qed. (* 4.207 secs *)


From ITree Require Import ITree.
From compcert Require Import Maps AST Values Memory Globalenvs Ctypes.
From compcert Require Coqlib Clight Clightdefs.
From Paco Require Import paco.

Require Import Arith ZArith Bool.
Require Import String List Lia.

Require Import sflib.
Require Import Axioms StdlibExt IntegersExt ITreeTac.

Require Import SysSem.
Require Import IPModel DiscreteTimeModel IntByteModel.
Require Import OSNodes.

Require Import ProgSem CProgEventSem.
Require Import ProgSim CProgSimLemmas.
Require Import RTSysEnv MWITree.
Require Import NWSysModel.
Require Import SyncSysModel.

Require Import config_prm main_prm SystemProgs.
Require Import VerifProgBase.
Require Import VerifMainUtil VerifFetchMsgs.

Import Clight Clightdefs.
Import ITreeNotations.

Set Nested Proofs Allowed.

Local Transparent Archi.ptr64.
Local Opaque Int64.max_unsigned Int.max_unsigned.
Local Opaque Genv.globalenv.
Local Opaque Z.of_nat.

Local Opaque idx_fch idx_get_inb.

Arguments DELTA: simpl never.

Section INIT_MSG_STORE.
  Context `{SystemEnv}.
  (* Context `{CProgSysEvent}. *)
  Variable cprog: Clight.program.

  Let prog: Prog.t := prog_of_clight cprog.
  Let ge := Clight.globalenv cprog.
  Variable tid: nat.
  Hypothesis RANGE_TID: (tid < num_tasks)%nat.
  Context `{genv_props ge (main_gvar_ilist tid)
                       main_gfun_ilist main_cenv_ilist}.
  (* Notation progE := (OSModel.osE +' OSNodes.tlimE +' extcallE). *)

  Variable r: nat -> itree progE unit -> Prog.state prog -> Prop.
  (* Let GVB_IDXS_MAIN := gvb_idxs_main. *)

  (* Lemma fold_mentry_sz' *)
  (*   : Z.of_nat (S max_msg_size) = mentry_sz. *)
  (* Proof. *)
  (*   unfold mentry_sz. nia. *)
  (* Qed. *)

  Inductive init_inbox_loop_inv
            (itr_i: itree progE unit)
            (inb0: MWITree.inbox_t)
            b pofsv m_i (* i_max *)
            (i: nat) (itr: itree progE unit)
            (le: PTree.t val) (m: mem): Prop :=
    InitInboxLoopInv
      ments_p ments_n
      (MEM_CONSTS: mem_consts ge m tid)
      (* (OFFSET: pofsv = Ptrofs.unsigned pofs) *)
      (MENTS_PREV: iForall (Mem_msg_entry m b pofsv)
                           0 ments_p)
      (MENTS_PREV_INIT:
         MWITree.reset_inbox (firstn i inb0) = ments_p)
      (MENTS_NEXT_EQ: skipn i inb0 = ments_n)
      (MENTS_NEXT: iForall (Mem_msg_entry m b pofsv)
                           i ments_n)
      (ITREE_INVAR: itr = itr_i)
      (MENTS_RANGE_PERM: Mem.range_perm m b pofsv
                                        (pofsv + inb_sz)
                                        Cur Writable)
      (UNCH: mem_unchanged_except
               (fun b' ofs' =>
                  b' = b /\
                  (pofsv <= ofs' < pofsv + inb_sz)%Z)
               m_i m)
      (LENV_EQUIV: lenv_equiv
                     le [(_inb, Vptr b (Ptrofs.repr pofsv));
                        (_i, Vint (IntNat.of_nat i))])
  .

  Definition idx_iinb: nat := num_tasks * 10 + 10.

  Lemma firstn_snoc_nth_error A
        (l: list A) (a: A) n
        (NTH: nth_error l n = Some a)
    : firstn (S n) l = snoc (firstn n l) a.
  Proof.
    unfold snoc.
    depgen n.
    induction l as [| h t IH]; i; ss.
    { destruct n; ss. }
    destruct n as [| n']; ss.
    { inv NTH. ss. }

    hexploit IH; eauto.
    intro EXP_IH. rewrite EXP_IH. ss.
  Qed.

  Lemma sim_init_inbox
        (b_mst: block)
        idx itr k m
        (* pofs *) pofsv inb
        (CALL_CONT: is_call_cont k)
        (MEM_CONSTS: mem_consts ge m tid)
        (* (POFSV: pofsv = Ptrofs.unsigned pofs) *)
        (POFSV_BOUND: (0 <= pofsv <= inb_sz + 4)%Z)
        (FSYMB_MST : Genv.find_symbol ge _mstore = Some b_mst)
        (MEM_INBOX: Mem_inbox m b_mst pofsv inb)
        (AFT: forall m' inb'
                (RESET_INB: inb' = MWITree.reset_inbox inb)
                (MEM_CONSTS: mem_consts ge m' tid)
                (MEM_INBOX: Mem_inbox m' b_mst pofsv inb')
                (MEM_UNCH: mem_unchanged_except
                             (fun b ofs' =>
                                b = b_mst /\
                                pofsv <= ofs' <
                                pofsv + inb_sz)%Z
                             m m'),
            paco3 (_sim_itree prog) r idx
                  itr (Clight.Returnstate Vundef k m'))
    : paco3 (_sim_itree prog) r (idx_iinb + idx)
            itr
            (Clight.Callstate
               (Internal (main_prm.f_init_inbox
                            (Z.of_nat max_num_tasks)))
               [Vptr b_mst (Ptrofs.repr pofsv)] k m).
  Proof.
    (* pose (pofsv' := pofsv). subst pofsv. *)
    (* fold pofsv' in AFT. fold pofsv' in MEM_INBOX. *)
    (* rename pofsv' into pofsv. *)

    start_func.
    { econs. }

    unfold idx_iinb.
    fw. clear STEP_ENTRY.
    fw. fw.
    { econs. eval_comput. ss. }
    upd_lenv.
    fw.
    (* loop *)
    (* replace 6%Z with (Z.of_nat 6%nat) by ss. *)
    (* fold_for_loop _i . *)

    hexploit (in_gvar_ids _NUM_TASKS); [sIn|].
    intros (b_nt & FSYMB_NT).
    pose proof range_num_tasks as RANGE_NT.
    rr in MEM_INBOX.

    eapply simple_for_loop
      with (idx_each:= 10) (idx0:= 0)
           (i_max := num_tasks)
           (loop_inv := init_inbox_loop_inv
                          itr inb b_mst pofsv m).
    { econs; eauto; ss.
      - econs.
      - apply MEM_INBOX.
      - eapply MEM_INBOX.
      - rr. apply Mem.unchanged_on_refl.
    }
    (* { apply LENV_EQUIV. } *)
    { range_stac. }
    { nia. }
    { (* body *)
      clear le LENV_EQUIV.
      clear MEM_CONSTS.
      i. unfold for_loop_stmt. ss.
      inv LINV. des.

      (* make range props of i in advance *)
      (* assert (RANGE_I_Z: (0 <= Z.of_nat i <= 6)%Z) by nia. *)
      (* assert (RANGE_I_INT: (Int.min_signed <= Z.of_nat i <= Int.max_signed)%Z). *)
      (* { split. *)
      (*   - pose proof Int.min_signed_neg. nia. *)
      (*   - etransitivity; try apply RANGE_I_Z. ss. } *)
      (* assert (RANGE_I_UINT: (0 <= Z.of_nat i <= Int.max_unsigned)%Z). *)
      (* { split; try apply RANGE_I_Z. *)
      (*   etransitivity; try apply RANGE_I_Z. ss. } *)
      (* assert (RANGE_I_POFS: (0 <= Z.of_nat i <= Ptrofs.max_unsigned)%Z). *)
      (* { split; try apply RANGE_I_Z. *)
      (*   etransitivity; try apply RANGE_I_Z. ss. } *)

      assert (WITHIN_INBOX_SZ: (0 < mentry_nsz * i + 1 <= inb_nsz)%nat).
      { split; [nia|].
        apply within_inb_nsz2.
        - nia.
        - unfold mentry_nsz. nia.
      }

      (* guardH RANGE_I_Z. guardH RANGE_I_INT. *)
      (* guardH RANGE_I_UINT. guardH RANGE_I_POFS. *)

      fw. fw. fw.
      { econs.
        - eval_comput.
          rewrite FSYMB_NT.
          erewrite mem_consts_num_tasks by eauto.
          repr_tac.
          rewrite <- Nat2Z_inj_ltb. reflexivity.
        - instantiate (1:= true).
          s.
          destruct (Nat.ltb_spec i num_tasks); ss. nia.
      }
      ss.

      fw.
      assert (exists inb_x,
                 <<INB_X: nth_error inb i = Some inb_x>> /\
                 <<SKIPN_RW: skipn i inb = inb_x :: skipn (S i) inb>>).
      { hexploit (nth_error_Some2 _ inb i).
        { nia. }
        i. des.
        esplits; eauto.
        apply nth_error_split in NTH_EX. des. clarify.
        rewrite skipn_app_exact by ss.
        rewrite rw_cons_app. rewrite app_assoc.
        rewrite skipn_app_exact.
        2: { rewrite app_length. ss. nia. }
        ss.
      }
      des.
      (* destruct inb_x as [rcv_x bs_x]. *)
      rewrite SKIPN_RW in MENTS_NEXT. clear SKIPN_RW.
      inv MENTS_NEXT.

      match goal with
      | H: Mem_msg_entry _ _ _ _ _ |- _ =>
           (* , *)
           (* H': _ = skipn i inb |- _ => *)
        rename H into MENT_CUR (* ; rename H' into INB_SKIPN *)
      end.

      (* make mem beforehand *)
      assert (MEM_STORE: exists m2,
                 Mem.store Mint8signed m1 b_mst
                           (pofsv + (Z.of_nat (mentry_nsz * i)))
                           (Vint Int.zero) = Some m2).
      { apply inhabited_sig_to_exists.
        econs.
        (* unfold mentry_sz. *)
        apply Mem.valid_access_store.
        r. split; ss.
        - ii.
          eapply MENTS_RANGE_PERM. nia.
        - apply Z.divide_1_l.
      }
      des.
      pose proof ptr_range_mstore as PTR_RANGE_MSTORE.
      pose proof range_mentry_nsz as RANGE_MENTRY_NSZ.

      fw.
      { econs.
        - eval_comput. s. fold_cenv.
          erewrite (in_cenv_ilist _msg_entry_t) by sIn.
          rewrite Ptrofs.add_zero.
          rewrite Ptrofs.add_zero.
          repr_tac1.
          simpl co_sizeof.
          (* replace (Z.of_nat (S max_msg_size)) with mentry_sz. *)
          (* 2: { unfold mentry_sz. nia. } *)
          repr_tac1. repr_tac1.
          rewrite <- Nat2Z.inj_mul.
          reflexivity.
        - eval_comput. eauto.
        - ss.
        - eval_comput.
          repr_tac1.
          replace (Int.sign_ext 8 (Int.repr 0)) with Int.zero by ss.
          eauto.
      }

      fw.
      { econs; eauto. }
      fw.
      { econs.
        eval_comput.
        repr_tac.
        replace (Z.of_nat i + 1)%Z with (Z.of_nat (S i)) by nia.
        reflexivity.
      }
      upd_lenv.

      fw.
      fold_for_loop _i.

      eapply (sim_itree_red_idx prog) with (idx_small:= idx1 - 10).
      { nia. }

      eapply SIM_NEXT.
      (* { apply LENV_EQUIV. } *)
      { econs; eauto.
        - eapply mem_consts_unch_diffblk; eauto.
          2: { instantiate (1:= b_mst).
               i. eapply global_addresses_distinct'; eauto.
               ss. des; clarify. }
          eapply Mem.unchanged_on_implies.
          { eapply store_unchanged_on'; eauto. }
          unfold mem_range. ss.
          ii. des; clarify.
        - erewrite firstn_snoc_nth_error; eauto.
          unfold snoc.
          unfold MWITree.reset_inbox in *.
          rewrite map_app.
          eapply iForall_app; eauto.
          + eapply iForall_Mem_msg_entry_unch; eauto.
            eapply Mem.unchanged_on_implies; eauto.
            { eapply store_unchanged_on'; eauto. }
            unfold mem_range. ss.
            rewrite map_length.
            rewrite firstn_length_le by nia.
            ii. des; ss. nia.

          + ss. rewrite map_length.
            rewrite firstn_length_le by nia.
            econs; ss.
            2: { econs. }

            r in MENT_CUR.
            eapply Mem.loadbytes_store_same in MEM_STORE.
            ss.

            (* (* replace mentry_esz with (1 + Z.of_nat msg_size)%Z. *) *)
            (* (* 2: { unfold mentry_ensz. nia. } *) *)

            (* unfold mentry_to_bytes. s. *)
            (* rewrite rw_cons_app. *)

            (* apply Mem.loadbytes_concat; [ | | nia | nia]. *)
            (* * eapply Mem.loadbytes_store_same in MEM_STORE. ss. *)
            (* * erewrite Mem.loadbytes_store_other; eauto. *)
            (*   2: { do 3 right. ss. nia. } *)
            (*   replace mentry_esz with (1 + Z.of_nat msg_size)%Z *)
            (*     in MENT_CUR. *)
            (*   2: { unfold mentry_ensz. nia. } *)

            (*   unfold mentry_to_bytes in MENT_CUR. *)
            (*   apply Mem_loadbytes_split' in MENT_CUR; [|nia..]. *)
            (*   ss. destruct MENT_CUR. *)
            (*   eauto. *)
        - eapply iForall_Mem_msg_entry_unch; eauto.
          eapply Mem.unchanged_on_implies; eauto.
          { eapply store_unchanged_on'; eauto. }
          unfold mem_range. ss.
          (* rewrite map_length. *)
          (* rewrite firstn_length_le by nia. *)
          ii. des; ss. nia.
        - ii. eapply Mem.perm_store_1; eauto.
        - eapply Mem.unchanged_on_trans.
          2: {
            eapply Mem.store_unchanged_on; eauto.
            i. intro C. apply C.
            split; ss.
            nia.
          }
          ss.
      }
    }

    i. ss.
    clear dependent le. clear MEM_CONSTS.
    inv LINV_END. des.

    fw. fw. fw.
    { econs.
      - eval_comput.
        rewrite FSYMB_NT.
        erewrite mem_consts_num_tasks by eauto.
        repr_tac.
        rewrite Z.ltb_irrefl. ss.
      - ss.
    }
    rewrite Int.eq_true. ss.

    fw. fw. fw.
    eapply (sim_itree_red_idx prog) with (idx_small := idx).
    { nia. }

    eapply AFT; eauto.
    rewrite firstn_all2 in MENTS_PREV.
    { r. esplits; eauto.
      unfold MWITree.reset_inbox.
      rewrite map_length. ss. }
    { nia. }
  Qed.

  Definition idx_swinb := idx_iinb + 20.

  Lemma sim_switch_inbox
        m0 k itr idx_ret
        cf ofsc ofsn
        inbc inbn
        (CALL_CONT: is_call_cont k)
        (MEM_CONSTS: mem_consts ge m0 tid)
        (MEM_MSTORE: mem_mstore ge m0 cf ofsc ofsn inbc inbn)
        (SIM_RET:
           forall m' cf' inbn' ofsc' ofsn'
             (* (INBN_EQV': inbox_equiv *)
             (*               MWITree.init_inbox inbn_t') *)
             (* (INBN_INIT': Forall (fun x => fst x = false) inbn') *)
             (RESET_INBC: inbn' = MWITree.reset_inbox inbc)
             (MEM_MSTORE: mem_mstore ge m' cf' ofsc' ofsn'
                                     inbn inbn')
             (UNCH: mem_changed_gvar_id ge _mstore m0 m')
           ,
             paco3 (_sim_itree prog) r idx_ret
                   itr
                   (Returnstate Vundef k m'))
    : paco3 (_sim_itree prog) r (idx_swinb + idx_ret)
            itr (Callstate (Internal f_switch_inbox)
                           [] k m0).
  Proof.
    start_func.
    { econs. }

    unfold idx_swinb.
    fw. clear STEP_ENTRY.
    fw.

    hexploit (in_gvar_ids _mstore); [sIn|].
    destruct 1 as [b_mst FSYMB_MST].
    specialize (MEM_MSTORE _ FSYMB_MST).

    fw.
    { econs. eval_comput.
      rewrite FSYMB_MST. s.
      rewrite Ptrofs.add_zero_l.
      rewrite Ptrofs.unsigned_repr by ss.
      apply MEM_MSTORE.
    }
    upd_lenv.

    fw. fw. fw.
    { hexploit (in_gfun_ilist _init_inbox); [sIn|]. i. des.
      econs; eauto; ss.
      - eval_comput.
        rewrite FDEF_SYMB. ss.
      - eval_comput.
        rewrite FSYMB_MST. s.
        fold_cenv.
        erewrite (in_cenv_ilist _inbox_t) by sIn.
        s. rewrite Ptrofs.add_zero_l.
        pose proof ptr_range_inb_sz.
        repr_tac0; cycle 1.
        { nia. }
        { desf; ss. }
        repr_tac0; cycle 1.
        { ss. }
        { desf; ss.
          - unfold Int.one.
            rewrite Int.signed_repr by ss.
            nia.
          - unfold Int.zero.
            rewrite Int.signed_repr by ss.
            nia.
        }
        replace (inb_sz * Int.signed (if cf then Int.one else Int.zero))%Z with
            (Z.of_nat (if cf then inb_nsz else 0)).
        2: {
          unfold Int.one, Int.zero.
          destruct cf; ss.
          - rewrite Int.signed_repr by ss. nia.
          - rewrite Int.signed_repr by ss. nia.
        }
        reflexivity.
    }

    eapply (sim_itree_red_idx prog) with (idx_small:= idx_iinb + (idx_ret + 12)).
    { nia. }
    eapply sim_init_inbox with (inb:= inbc); eauto; ss.
    { destruct cf; nia. }
    { inv MEM_MSTORE.
      destruct cf; ss.  }

    clear MEM_CONSTS.
    i. clarify.
    rename m' into m1.

    fw. fw.
    inv MEM_MSTORE.

    assert (STORE_CF: exists m2,
               Mem.store Mint32 m1 b_mst 0 (Vint (Int.repr (if cf then 0%Z else 1%Z))) = Some m2).
    { apply inhabited_sig_to_exists.
      econs.
      apply Mem.valid_access_store.
      rr. split; ss.
      - ii. eapply Mem.perm_unchanged_on; eauto.
        ss. nia.
      - solve_divide.
    }
    des.

    fw.
    { econs.
      - eval_comput.
        rewrite FSYMB_MST. s.
        rewrite Ptrofs.add_zero_l. reflexivity.
      - eval_comput.
        instantiate (1:= Vint (Int.repr (if cf then 0%Z else 1%Z))).
        destruct cf; ss.
      - ss.
      - eval_comput.
        eauto.
    }
    fw.
    apply (sim_itree_red_idx prog) with (idx_small:= idx_ret).
    { nia. }

    assert (MEM_UNCH_TOT:
              mem_unchanged_except
                (fun b ofs =>
                   b = b_mst /\
                   ((0 <= ofs < 4) \/
                    (if cf then
                       (4 + Z.of_nat inb_nsz <= ofs <
                        4 + Z.of_nat (inb_nsz + inb_nsz))
                     else
                       (4 <= ofs < 4 + Z.of_nat inb_nsz))))%Z
                m0 m2).
    { eapply Mem.unchanged_on_trans.
      - eapply Mem.unchanged_on_implies; eauto.
        ii. des; ss. clarify.
        desf; nia.
      - eapply Mem.unchanged_on_implies; eauto.
        { eapply store_unchanged_on'; eauto. }
        unfold mem_range.
        ii. ss.
        destruct cf; nia.
    }

    eapply SIM_RET; eauto.
    { econs; eauto.
      - instantiate (1:= negb cf).
        ss. clarify.
        erewrite Mem.load_store_same; eauto.
        destruct cf; ss.
      - ii.
        eapply Mem.perm_store_1; eauto.
        eapply Mem.perm_unchanged_on; eauto.
        { ss. ii. des; ss. clarify.
          destruct cf; nia. }
        ss. clarify.
        apply mem_mst_curflag_writable. eauto.
      - ss. clarify.
        destruct cf; ss.
        + eapply Mem_inbox_unch; eauto.
          eapply Mem.unchanged_on_implies; eauto.
          ii. ss. nia.
        + eapply Mem_inbox_unch; eauto.
          eapply Mem.unchanged_on_implies; eauto.
          ii. ss. nia.
        (*   eapply Mem.unchanged_on_trans. *)
        (*   { eapply Mem.unchanged_on_implies; eauto. *)
        (*     ss. ii. des; clarify. nia. } *)
        (*   { eapply Mem.unchanged_on_implies; eauto. *)
        (*     { eapply store_unchanged_on'; eauto. } *)
        (*     ss. unfold mem_range. *)
        (*     ii. des; clarify. nia. } *)
        (* + eapply Mem_inbox_unch; eauto. *)
        (*   eapply Mem.unchanged_on_trans. *)
        (*   { eapply Mem.unchanged_on_implies; eauto. *)
        (*     ss. ii. des; clarify. nia. } *)
        (*   { eapply Mem.unchanged_on_implies; eauto. *)
        (*     { eapply store_unchanged_on'; eauto. } *)
        (*     ss. unfold mem_range. *)
        (*     ii. des; clarify. nia. } *)
      - ss. clarify.
        destruct cf; ss.
        + eapply Mem_inbox_unch; eauto.
          eapply Mem.unchanged_on_implies; eauto.
          { eapply store_unchanged_on'; eauto. }
          ss. unfold mem_range.
          ii. des; clarify. nia.
        + eapply Mem_inbox_unch; eauto.
          eapply Mem.unchanged_on_implies; eauto.
          { eapply store_unchanged_on'; eauto. }
          ss. unfold mem_range.
          ii. des; clarify. nia.
    }

    r. i. ss. clarify.
    eapply Mem.unchanged_on_implies; eauto.
    ss. ii. ss. des; ss.
  Qed.

End INIT_MSG_STORE.

Section RUN_TASK.
  (* Context `{SystemEnv}. *)
  Context `{SimApp}.

  (* Variable cprog: Clight.program. *)
  Variable txs rxs: nat.

  Let prog: Prog.t := prog_of_clight cprog.
  Let ge := globalenv cprog.
  Notation progE := (OSModel.osE +' obsE).

  Context `{genv_props
              ge (main_gvar_ilist tid ++ app_gvar_ilist)
              (main_gfun_ilist ++ app_gfun_ilist)
              (main_cenv_ilist ++ app_cenv_ilist)}.

  (* For global variable invariants *)
  Let gprops_main
    : genv_props ge (main_gvar_ilist tid)
                 main_gfun_ilist main_cenv_ilist.
  Proof.
    eapply genv_props_incl; eauto;
      apply incl_appl; ss.
  Qed.

  Variable r: nat -> itree progE unit -> Prog.state prog -> Prop.

  (* Variable kp: Clight.cont. *)
  (* Variable idx_fin: nat. *)
  (* Hypothesis KP: *)
  (*   is_call_cont kp /\ *)
  (*   forall m, paco3 (_sim_itree prog) r idx_fin *)
  (*              (Ret tt) *)
  (*              (Returnstate Vundef kp m). *)

  Let tid_sign_ext_noeff:
    Int.sign_ext 8 (IntNat.of_nat tid) =
    IntNat.of_nat tid.
  Proof.
    assert (IntRange.sint8 tid).
    { pose proof range_tid.
      pose proof range_num_tasks.
      range_stac. }

    unfold IntNat.of_nat.
    rewrite sign_ext_byte_range by ss.
    ss.
  Qed.

  Inductive main_loop_inv
            (itr: itree progE unit)
            (le: PTree.t val) (m: mem): Prop :=
    MainLoopInv
      ast sytm sytm_dmy mcont_dmy
      cflg ofsc ofsn
      inbc inbn (* sh *)
      (* inbc_t inbn_t *)
      v_dmy
      (RANGE_SYTM: (0 < Z.of_nat (sytm + 2 * period) <= Int64.max_unsigned)%Z)
      (LENV_EQUIV: lenv_equiv le [(_cur_base_time, Vlong (IntNat.of_nat64 sytm));
                                 (_pprd, Vlong (IntNat.of_nat64 period));
                                 (_dlt, Vlong (Int64.repr (Z.of_nat DELTA)));
                                 (_maxt, Vlong (Int64.repr MAX_TIME_Z));
                                 (_t'1, v_dmy)])

      (MEM_NB: (Genv.genv_next ge <= Mem.nextblock m)%positive)

      (ITREE: itr =
              MWITree.main_loop
                tid app_mod MWITree.ltb_max_time
                txs rxs (inbc, inbn)
                ast sytm)

      (MEM_SBUF : mem_sbuf ge m sytm_dmy tid mcont_dmy)
      (MEM_CONSTS : mem_consts ge m tid)
      (MEM_MSTORE : mem_mstore ge m cflg ofsc ofsn inbc inbn)
      (MEM_SH : mem_sh ge m (repeat false num_tasks))
      (MEM_TXS : mem_txs ge m txs)
      (MEM_RXS : mem_rxs ge m rxs)
      (INV_APP: inv_app ge ast m)
      (* (INBC_EQV: inbox_equiv inbc_s inbc_t) *)
      (* (INBN_EQV: inbox_equiv inbn_s inbn_t) *)
  .

  (* TODO *)

  Let eval_loop_cond
      le m tm
      (RANGE_TM: IntRange.uint64 tm)
      (LE_CBT : le ! _cur_base_time =
                Some (Vlong (IntNat.of_nat64 tm)))
      (LE_MAXT: le ! _maxt =
                Some (Vlong (Int64.repr
                               (Int64.max_unsigned -
                                10 * Z.of_nat period))))
    : eval_expr_c (globalenv cprog) empty_env le m
                  (Ebinop Cop.Olt (Etempvar _cur_base_time tulong)
                          (Etempvar _maxt tulong) tint) =
      Some (Vint (if tm <? MAX_TIME
                  then Int.one else Int.zero)).
  Proof.
    ss. rewrite LE_CBT. rewrite LE_MAXT.
    eval_comput.
    repr_tac.

    pose proof period_mul_10_lt_max.
    unfold Int64.ltu.
    rewrite Int64.unsigned_repr.
    2: { range_stac. }

    rewrite Z.mul_comm.
    fold MAX_TIME_Z.
    rewrite <- max_time_to_z.

    unfold IntNat.of_nat64.
    rewrite Int64.unsigned_repr by ss.

    match goal with
    | |- context[Coqlib.zlt ?a ?b] =>
      destruct (Coqlib.zlt a b)
    end.
    - destruct (Nat.ltb_spec tm MAX_TIME); ss.
      nia.
    - destruct (Nat.ltb_spec tm MAX_TIME); ss.
      nia.
  Qed.

  (* Let eval_loop_cond *)
  (*       le m v sytm *)
  (*       _cur_base_time *)
  (*       b_pprd *)
  (*       (RANGE_SYTM: (0 < Z.of_nat (sytm + 2 * pals_period) <= Int64.max_unsigned)%Z) *)
  (*       (LENV_EQUIV: le ! _cur_base_time = *)
  (*                    Some (Vlong (IntNat.of_nat64 sytm))) *)
  (*       (FSYMB_PPRD : Genv.find_symbol ge _PALS_PERIOD = Some b_pprd) *)
  (*       (LOAD_PPRD : Mem.load Mint64 m b_pprd 0 = *)
  (*                    Some (Vlong (IntNat.of_nat64 pals_period))) *)
  (*       (VAL: v = if (Z.of_nat sytm <? Int64.max_unsigned - *)
  (*                                      5 * Z.of_nat pals_period)%Z *)
  (*                 then Vtrue else Vfalse) *)
  (*   : eval_expr_c *)
  (*       (globalenv cprog) empty_env le m *)
  (*       (Ebinop Cop.Olt (Etempvar _cur_base_time tulong) *)
  (*               (Ebinop Cop.Osub (Econst_long (Int64.repr (-1)) tulong) *)
  (*                       (Ebinop Cop.Omul (Econst_int (Int.repr 5) tint) (Evar _PALS_PERIOD tulong) tulong) tulong) tint) = *)
  (*     Some v. *)
  (* Proof. *)
  (*   assert (0 <= Z.of_nat sytm <= Int64.max_unsigned)%Z by nia. *)
  (*   ss. *)
  (*   rewrite LENV_EQUIV. *)
  (*   rewrite FSYMB_PPRD. cbn. *)
  (*   rewrite Ptrofs.unsigned_zero. *)
  (*   rewrite LOAD_PPRD. *)
  (*   replace (IntNat.of_nat64 sytm) with (Int64.repr (Z.of_nat sytm)) by ss. *)
  (*   rewrite eval_max_time; eauto. *)

  (*   unfold Int64.ltu. *)
  (*   rewrite Int64.unsigned_repr by ss. *)
  (*   rewrite Int64.unsigned_repr. *)
  (*   2: { pose proof period_mul_10_lt_max. nia. } *)
  (*   match goal with *)
  (*   | |- context[Coqlib.zlt ?a ?b] => *)
  (*     destruct (Z.ltb_spec a b) *)
  (*   end. *)
  (*   - desf. *)
  (*   - desf. nia. *)
  (* Qed. *)

  Definition idx_run: nat := 30.

  Lemma sim_run_task
        sytm m_i (* ast *) kp idx_fin
        sytm_dmy mcont
        ofsc ofsn
        (CALL_CONT: is_call_cont kp)
        (MEM_NB: (Genv.genv_next ge <= Mem.nextblock m_i)%positive)
        (* (INV_APP: inv_app ge ast m_i) *)
        (RANGE_SYTM: (0 < Z.of_nat (sytm + 2 * period) <=
                      Int64.max_unsigned)%Z)
        (RANGE_TXS: IntRange.sint txs)
        (RANGE_RXS: IntRange.sint rxs)
        (MEM_CONSTS: mem_consts ge m_i tid)
        (MEM_SBUF: mem_sbuf ge m_i sytm_dmy tid mcont)
        (MEM_MSTORE: mem_mstore ge m_i false ofsc ofsn
                                MWITree.init_inbox
                                MWITree.init_inbox)
        (MEM_SH: mem_sh ge m_i (repeat false num_tasks))
        (MEM_TXS: mem_txs ge m_i txs)
        (MEM_RXS: mem_rxs ge m_i rxs)
        (INV_APP: inv_app ge (AppMod.init_abst_state app_mod) m_i)
        (SIM_RET:
           forall m_f
             (* (UNCH: Mem.unchanged_on (fun _ _ => True) m_i m_f) *)
           ,
             paco3 (_sim_itree prog) r idx_fin
                   (Ret tt)
                   (Clight.Returnstate Vundef kp m_f))
    : (* exists idx_rt: nat, *)
      paco3 (_sim_itree prog) r (idx_run + idx_fin)
            (MWITree.run_task
               tid app_mod txs rxs sytm)
            (Clight.Callstate
               (Internal main_prm.f_run_task)
               [Vlong (IntNat.of_nat64 sytm)] kp m_i)
  .
  Proof.
    guardH RANGE_SYTM.
    unfold idx_run.
    rewrite plus_comm.

    (* remember m_i as m1 eqn:MEM_EQ. *)
    (* guardH MEM_EQ. *)

    start_func.
    { econs. }
    ss.
    fw. clear STEP_ENTRY.

    hexploit (in_gvar_ids _send_buf); [sIn|].
    intros [b_sbuf FSYMB_SBUF].
    hexploit (in_gvar_ids _mstore); [sIn|].
    intros [b_mst FSYMB_MST].

    hexploit (in_gvar_ids _PALS_PERIOD); [sIn|].
    intros (b_pprd & FSYMB_PPRD).
    hexploit (in_gvar_ids _MAX_CSKEW); [sIn|].
    intros (b_sk & FSYMB_SK).
    hexploit (in_gvar_ids _MAX_NWDELAY); [sIn|].
    intros (b_nd & FSYMB_ND).

    fw. fw.
    { econs.
      eval_comput.
      rewrite FSYMB_PPRD.
      erewrite mem_consts_pals_period; eauto.
    }
    upd_lenv.

    pose proof max_clock_skew_range as RANGE_SK.
    pose proof max_nw_delay_range as RANGE_ND.
    pose proof period_cond as PRD_COND.
    pose proof period_mul_10_lt_max as PRD_LT.

    fw. fw. fw.
    { econs. eval_comput.
      rewrite FSYMB_SK, FSYMB_ND.
      erewrite mem_consts_max_cskew; eauto.
      erewrite mem_consts_max_nwdelay; eauto.
      eval_comput.
      repr_tac.
      replace 2%Z with (Z.of_nat 2) by ss.
      rewrite <- Nat2Z.inj_mul.
      rewrite <- Nat2Z.inj_add.
      fold DELTA.
      reflexivity.
    }
    assert (DELTA_LT: DELTA < period).
    { unfold DELTA. nia. }
    upd_lenv.

    fw. fw. fw.
    { econs. eval_comput.
      rewrite FSYMB_PPRD.
      erewrite mem_consts_pals_period by eauto.
      repr_tac.

      rewrite eval_max_time.
      reflexivity.
    }
    upd_lenv.
    fw.

    (* Swhile *)
    eapply (sim_itree_red_idx prog) with
        (idx_small:= idx_fin + 15 + 5).
    { nia. }

    match goal with
    | |- context[Swhile ?e ?s] =>
      pose (while_cond_expr := e);
        pose (loop_body_stmt := s)
    end.

    eapply sim_while with (linv := main_loop_inv).
    { econs; eauto.
      - rewrite max_time_to_z in LENV_EQUIV. ss.
      - unfold MWITree.run_task. eauto.
    }
    { clear dependent m_i. clear dependent le.
      clear ofsc ofsn sytm_dmy sytm RANGE_SYTM.
      i. inv LINV.

      hexploit mem_consts_pals_period; eauto.
      intro LOAD_PPRD.

      esplits; ss.
      - rewrite LENV_EQUIV. ss.
        rewrite LENV_EQUIV. ss.
      - ss.
        rewrite bool_val_of_bool.

        unfold Int64.ltu.
        rewrite Int64.unsigned_repr.
        2: { unfold MAX_TIME_Z. nia. }
        unfold IntNat.of_nat64.
        rewrite Int64.unsigned_repr.
        2: { pose proof period_mul_10_lt_max. nia. }
        instantiate (1:= (sytm <? MAX_TIME)).
        rewrite <- max_time_to_z.
        destruct (Nat.ltb_spec sytm MAX_TIME);
          destruct (Coqlib.zlt (Z.of_nat sytm)
                               (Z.of_nat MAX_TIME)); ss; nia.
    }
    { (* loop body *)
      clear dependent m_i. clear dependent le.
      clear dependent sytm.
      clear ofsc ofsn sytm_dmy.
      i. inv LOOP_INV.
      renames m_c le_c into m1 le.

      fold loop_body_stmt in CIH.
      fold while_cond_expr in EVAL_EXPR, COND_TRUE, CIH.
      fold while_cond_expr.

      assert (UINT64_SYTM: IntRange.uint64 sytm).
      { rr. nia. }

      assert (SYTM_LT_MAX: sytm < MAX_TIME).
      { subst while_cond_expr. ss.
        erewrite eval_loop_cond in EVAL_EXPR; eauto; cycle 1.
        { rewrite LENV_EQUIV. ss. }
        { rewrite LENV_EQUIV.
          rewrite Z.mul_comm.
          fold MAX_TIME_Z. ss. }
        destruct (Nat.ltb_spec sytm MAX_TIME); ss.
        exfalso. clarify.
      }

      assert (RANGE_NSYTM: (Z.of_nat (sytm + period * 3)
                            <= Int64.max_unsigned)%Z).
      { unfold MAX_TIME in SYTM_LT_MAX. ss. nia. }

      (* seq *)
      fw.

      assert (MEM_STORE: exists m2,
                 Mem.store Mint64 m1 b_sbuf 0
                           (Vlong (IntNat.of_nat64 (sytm + period))) = Some m2 /\
                 mem_sbuf ge m2 (sytm + period) tid mcont_dmy).
      { specialize (MEM_SBUF _ FSYMB_SBUF).
        inv MEM_SBUF.

        assert (exists m', Mem.store Mint64 m1 b_sbuf 0
                                (Vlong (IntNat.of_nat64 (sytm + period))) = Some m').
        { apply inhabited_sig_to_exists.
          econs.
          apply Mem.valid_access_store.
          rr. split; ss.
          - ii. eapply mem_sbuf_writable.
            unfold pld_size. nia.
          - solve_divide.
        }
        des.
        esplits; eauto.
        ii. ss. clarify.
        econs.
        - change 8%Z with (size_chunk Mint64).
          erewrite Mem.loadbytes_store_same; eauto. ss.
        - erewrite Mem.load_store_other; eauto.
          right. right. ss.
        - erewrite Mem.loadbytes_store_other; eauto.
          right. right. right. ss.
        - ii. eapply Mem.perm_store_1; eauto.
      }
      clear MEM_SBUF.
      destruct MEM_STORE as (m2 & MEM_STORE & MEM_SBUF).

      fw.
      { econs.
        - eval_comput.
          rewrite FSYMB_SBUF. s.
          unfold Ptrofs.zero.
          repr_tac. s. reflexivity.
        - eval_comput. repr_tac.
          rewrite <- Nat2Z.inj_add. reflexivity.
        - ss.
        - ss.
          eval_comput.
          eauto.
      }

      assert (MEM_CHB: mem_changed_block b_sbuf m1 m2).
      { eapply Mem.store_unchanged_on; eauto. }

      eapply mem_consts_unch_diffblk in MEM_CONSTS; cycle 1; eauto.
      { i. ss.
        eapply (global_addresses_distinct' ge); eauto.
        des; clarify. }
      eapply mem_txs_unch_diffblk in MEM_TXS; cycle 1; eauto.
      { eapply global_addresses_distinct' with (id:= _send_buf); eauto; ss. }
      eapply mem_rxs_unch_diffblk in MEM_RXS; cycle 1; eauto.
      { eapply global_addresses_distinct' with (id:=_send_buf); eauto; ss. }
      eapply mem_mstore_unch_diffblk in MEM_MSTORE; cycle 1; eauto.
      { eapply global_addresses_distinct' with (id:=_send_buf); eauto; ss. }
      eapply mem_sh_unch_diffblk in MEM_SH; cycle 1; eauto.
      { eapply global_addresses_distinct' with (id:=_send_buf); eauto; ss. }

      eapply inv_app_unch_diffblk in INV_APP; cycle 1; eauto.
      { sIn. }
      assert (MEM_NB': (Genv.genv_next ge <= Mem.nextblock m2)%positive).
      { apply Mem.unchanged_on_nextblock in MEM_CHB.
        unfold Coqlib.Ple in MEM_CHB.
        ss. nia. }
      clear dependent m1. renames m2 MEM_NB' into m1 MEM_NB.

      (* skip *)
      fw. fw. fw.
      { hexploit (in_gfun_ilist _pals_wait_timer).
        { sIn. }
        i. des.
        econs; ss.
        - eval_comput.
          rewrite FDEF_SYMB. ss.
        - eval_comput. reflexivity.
        - eauto.
        - ss.
      }

      (* wait_timer *)
      pfold. econs 3; ss.
      { econs; eauto.
        - ss.
          econs; eauto.
          eapply CProgOSEC_WaitTimer with (tm:=sytm); ss.
        - ss. }
      { rewrite MWITree.unfold_main_loop.
        replace (MWITree.ltb_max_time sytm) with true.
        2: { unfold MWITree.ltb_max_time.
             destruct (Nat.ltb_spec sytm MAX_TIME); ss.
             nia. }
        unfold MWITree.loop_body.
        simpl_itree_goal.
        econs 1.
      }
      { simpl_itree_goal. ss. }

      intros retz pst_ret (* POSTCOND_SETT *) AFT_EVT.
      exists (idx_fch + (idx_get_inb + idx_job + idx_fin + 40 +
                    (idx_rst_sh + (idx_swinb + 20)))).
      left. simpl_itree_goal.

      inv AFT_EVT.
      inv CPROG_AFTER_EVENT; ss.
      symmetry in EVENT. inv EVENT. existT_elim.
      unf_resum. subst.
      inv OS_ESTEP. existT_elim. clarify.
      rename m' into m1.

      hexploit (in_gvar_ids _rxs); [sIn|].
      intros (b_rxs & FSYMB_RXS).

      fw. fw. fw. fw.
      { hexploit (in_gfun_ilist _fetch_msgs); eauto.
        { sIn. }
        i. des.

        econs; ss.
        - eval_comput.
          rewrite FDEF_SYMB. ss.
        - eval_comput.
          rewrite FSYMB_RXS.
          erewrite mem_skt_id; eauto.
        - eauto.
        - eauto.
      }

      (* callstate *)
      (* ss. *)
      (* eapply (sim_itree_red_idx prog) with *)
      (*         (idx_small:= (idx_fch + (idx_fin + idx_job + 30) + 50). *)
      (* { nia. } *)

      eapply sim_fetch_msgs; ss; eauto.
      { eapply range_tid. }
      clear inbc inbn MEM_MSTORE.
      intros m2 inbc inbn. i.

      assert (MEM_CHB: mem_changed_block b_mst m1 m2).
      { eapply Mem.unchanged_on_implies; eauto. }

      eapply mem_consts_unch_diffblk in MEM_CONSTS; cycle 1; eauto.
      { i. eapply global_addresses_distinct'; eauto.
        ss. des; clarify. }
      eapply mem_txs_unch_diffblk in MEM_TXS; cycle 1; eauto.
      { i. eapply global_addresses_distinct'; eauto. ss. }
      eapply mem_rxs_unch_diffblk in MEM_RXS; cycle 1; eauto.
      { i. eapply global_addresses_distinct'; eauto. ss. }
      eapply mem_sbuf_unch_diffblk in MEM_SBUF; cycle 1; eauto.
      { i. eapply global_addresses_distinct'; eauto. ss. }
      eapply mem_sh_unch_diffblk in MEM_SH; cycle 1; eauto.
      { i. eapply global_addresses_distinct'; eauto. ss. }
      eapply inv_app_unch_diffblk in INV_APP; cycle 1; eauto.
      { sIn. }
      assert (MEM_NB': (Genv.genv_next ge <= Mem.nextblock m2)%positive).
      { apply Mem.unchanged_on_nextblock in MEM_CHB.
        unfold Coqlib.Ple in MEM_CHB. ss. nia. }
      clear dependent m1. renames m2 MEM_NB' into m1 MEM_NB.

      simpl_itree_goal.
      fw. fw. fw. fw. fw.
      { hexploit (in_gfun_ilist _get_cur_inbox); eauto.
        { sIn. }
        i. des.
        econs; ss.
        - eval_comput. rewrite FDEF_SYMB. ss.
        - eval_comput. eauto.
        - eauto.
        - ss.
      }

      red_idx (idx_get_inb + (idx_job + idx_rst_sh + idx_swinb + 50)).

      eapply sim_get_cur_inbox; eauto; ss.
      { apply range_tid. }
      intros b_mst' FSYMB_MST'.
      ss. clarify. rename FSYMB_MST' into FSYMB_MST.

      fw. upd_lenv.
      fw.
      (* call job *)
      fw.
      { hexploit (in_gfun_ilist _job).
        { cut (In (_job, Internal job_func) app_gfun_ilist).
          { i. sIn. }
          apply job_func_in_app_gfun_ilist.
        }
        i. des.

        econs; ss.
        - eval_comput.
          rewrite FDEF_SYMB. ss.
        - eval_comput. reflexivity.
        - eauto.
        - ss. apply job_func_type.
      }

      red_idx ((idx_rst_sh + (idx_swinb + 30)) + idx_job).
      eapply (sim_job_func r' ); eauto; ss.
      { range_stac. }

      unfold VerifProgBase.ge. fold ge.
      clear MEM_SH MEM_SBUF INV_APP. i.

      eapply mem_consts_unch in MEM_CONSTS; cycle 1; eauto.
      { eapply Mem.unchanged_on_implies; eauto.
        i. eapply blocks_of_ge_incl; eauto.
        rr. unfold main_const_ids. ss. i.
        des; sIn.
      }
      eapply mem_mstore_unch in MEM_MSTORE; cycle 1; eauto.
      { eapply Mem.unchanged_on_implies; eauto.
        i. r. esplits; eauto. sIn. }
      eapply mem_txs_unch in MEM_TXS; cycle 1; eauto.
      { eapply Mem.unchanged_on_implies; eauto.
        i. r. esplits; eauto. sIn. }
      eapply mem_rxs_unch in MEM_RXS; cycle 1; eauto.
      { eapply Mem.unchanged_on_implies; eauto.
        i. r. esplits; eauto. sIn. }
      assert (MEM_NB': (Genv.genv_next ge <= Mem.nextblock m')%positive).
      { apply Mem.unchanged_on_nextblock in UNCH_MAIN.
        unfold Coqlib.Ple in *. ss. nia. }
      clear dependent m1.
      renames m' INV_APP' MEM_NB' into m1 INV_APP MEM_NB.

      fw. fw. fw. fw.
      { econs. eval_comput.
        repr_tac. rewrite <- Nat2Z.inj_add.
        reflexivity. }
      upd_lenv.
      simpl_itree_goal.

      (* fw. fw. fw. *)
      (* { hexploit (in_gfun_ilist _pals_set_timelimit); [sIn|]. *)
      (*   i. des. *)

      (*   econs; ss. *)
      (*   - eval_comput. rewrite FDEF_SYMB. ss. *)
      (*   - eval_comput. *)
      (*     repr_tac. *)
      (*     rewrite <- Nat2Z.inj_add. *)
      (*     rewrite <- Nat2Z.inj_sub by nia. *)
      (*     eauto. *)
      (*   - eauto. *)
      (*   - ss. *)
      (* } *)

      (* pfold. econs 3; ss. *)
      (* { econs; eauto. *)
      (*   - ss. *)
      (*     econs 2; try reflexivity. *)
      (*     range_stac. *)
      (*   - ss. } *)
      (* { econs. } *)
      (* { replace (sytm + period + (period - DELTA)) with *)
      (*       (sytm + period + period - DELTA) by nia. *)
      (*   simpl_itree_goal. *)
      (*   ss. } *)

      (* intros [] pst_r AFT_EVT. *)
      (* inv AFT_EVT. ss. *)
      (* inv CPROG_AFTER_EVENT; ss. *)
      (* clarify. ss. existT_elim. subst. *)
      (* simpl_itree_goal. *)
      (* rename m' into m1. *)

      (* exists (idx_rst_sh + (idx_swinb + 20)). left. *)

      fw. fw. fw.
      { hexploit (in_gfun_ilist _reset_send_hist); [sIn|].
        i. des.
        econs; ss.
        - eval_comput. rewrite FDEF_SYMB. ss.
        - eval_comput. ss.
        - eauto.
        - ss.
      }

      eapply sim_reset_send_hist; try eapply range_tid; eauto; ss.
      clear sh' MEM_CONSTS MEM_SH. i.

      hexploit (in_gvar_ids _send_hist); [sIn|].
      intros (b_sh & FSYMB_SH). ss.

      assert (MEM_CHB: mem_changed_block b_sh m1 m').
      { apply MEM_UNCH. ss. }
      clear MEM_UNCH.

      eapply mem_txs_unch_diffblk in MEM_TXS; cycle 1; eauto.
      { i. eapply global_addresses_distinct'; eauto. ss. }
      eapply mem_rxs_unch_diffblk in MEM_RXS; cycle 1; eauto.
      { i. eapply global_addresses_distinct'; eauto. ss. }
      eapply mem_sbuf_unch_diffblk in MEM_SBUF; cycle 1; eauto.
      { i. eapply global_addresses_distinct'; eauto. ss. }
      eapply mem_mstore_unch_diffblk in MEM_MSTORE; cycle 1; eauto.
      { i. eapply global_addresses_distinct'; eauto. ss. }

      eapply inv_app_unch_diffblk in INV_APP; cycle 1; eauto.
      { sIn. }
      assert (MEM_NB': (Genv.genv_next ge <= Mem.nextblock m')%positive).
      { apply Mem.unchanged_on_nextblock in MEM_CHB.
        unfold Coqlib.Ple in MEM_CHB. ss. nia. }
      clear dependent m1. renames m' MEM_NB' into m1 MEM_NB.

      fw. fw. fw.
      { hexploit (in_gfun_ilist _switch_inbox); [sIn|].
        i. des.
        econs; ss.
        - eval_comput. rewrite FDEF_SYMB. ss.
        - eval_comput. ss.
        - eauto.
        - ss.
      }

      eapply sim_switch_inbox; eauto; ss.
      { eapply range_tid. }
      rename ofsc into ofsc_p.
      clear cflg ofsn MEM_MSTORE.
      intros m' cflg inbn_t' ofsc ofsn. i.

      assert (MEM_CHB: mem_changed_block b_mst m1 m').
      { apply UNCH. ss. }
      clear UNCH.

      eapply mem_consts_unch_diffblk in MEM_CONSTS; cycle 1; eauto.
      { i. eapply global_addresses_distinct'; eauto.
        ss. des; clarify. }
      eapply mem_txs_unch_diffblk in MEM_TXS; cycle 1; eauto.
      { i. eapply global_addresses_distinct'; eauto. ss. }
      eapply mem_rxs_unch_diffblk in MEM_RXS; cycle 1; eauto.
      { i. eapply global_addresses_distinct'; eauto. ss. }
      eapply mem_sbuf_unch_diffblk in MEM_SBUF; cycle 1; eauto.
      { i. eapply global_addresses_distinct'; eauto. ss. }
      eapply mem_sh_unch_diffblk in MEM_SH; cycle 1; eauto.
      { i. eapply global_addresses_distinct'; eauto. ss. }
      eapply inv_app_unch_diffblk in INV_APP; cycle 1; eauto.
      { sIn. }
      assert (MEM_NB': (Genv.genv_next ge <= Mem.nextblock m')%positive).
      { apply Mem.unchanged_on_nextblock in MEM_CHB.
        unfold Coqlib.Ple in MEM_CHB. ss. nia. }
      clear dependent m1. renames m' MEM_NB' into m1 MEM_NB.

      (* ret *)
      fw. fw_tau (S (idx_fin + 25)).
      { econs. eauto. }

      red_idx (S (idx_fin + 15 + 5)).
      fw_r.
      rewrite Nat.sub_0_r.
      eapply CIH.
      subst inbn_t'.
      econs; try eapply LENV_EQUIV; eauto.
      - range_stac.
      - subst. ss.
    }

    i.
    fw.
    red_idx idx_fin.

    clear sytm RANGE_SYTM LENV_EQUIV MEM_SBUF MEM_CONSTS
          MEM_TXS MEM_RXS INV_APP.
    clear ofsc ofsn sytm_dmy MEM_MSTORE.
    inv LOOP_INV.

    ss. erewrite eval_loop_cond in EVAL_EXPR; cycle 2.
    { rewrite LENV_EQUIV. ss. }
    { rewrite Z.mul_comm.
      rewrite LENV_EQUIV. ss. }
    2: { range_stac. }

    unfold MWITree.ltb_max_time.
    rewrite MWITree.unfold_main_loop.
    destruct (Nat.ltb_spec sytm MAX_TIME); clarify.

    eapply paco3_mon.
    eapply SIM_RET. eauto.
  Qed.

End RUN_TASK.


(*
 * Copyright (c) 2020 BedRock Systems, Inc.
 * This software is distributed under the terms of the BedRock Open-Source License.
 * See the LICENSE-BedRock file in the repository root for details.
 *)

(** The "operational" style definitions about C++ values. *)
From Coq Require Import Strings.Ascii.
Require Import stdpp.gmap.

From bedrock.prelude Require Import base addr option numbers.

From bedrock.lang.cpp.arith Require Import operator builtins.
Require Import bedrock.lang.cpp.ast.
From bedrock.lang.cpp.semantics Require Export types sub_module genv ptrs.

#[local] Close Scope nat_scope.
#[local] Open Scope Z_scope.
Implicit Types (σ : genv).

(* TODO: improve our axiomatic support for raw values - including "shattering"
   non-raw values into their constituent raw pieces - to enable deriving
   [tptsto_ptr_congP_transport] from [tptsto_raw_ptr_congP_transport].
 *)
Module Type RAW_BYTES.
  (** * Raw bytes
      Raw bytes represent the low-level view of data.
      [raw_byte] abstracts over the internal structure of this low-level view of data.
      E.g. in the [simple_pred] model, [raw_byte] would be instantiated with [runtime_val].

      [raw_int_byte] is a raw byte that is a concrete integer values (i.e. not a
      pointer fragment or poison).
   *)
  Parameter raw_byte : Set.
  Parameter raw_byte_eq_dec : EqDecision raw_byte.
  #[global] Existing Instance raw_byte_eq_dec.

  Axiom raw_int_byte : N -> raw_byte.

  (* TODO: refine our treatment of `raw_bytes` s.t. we respect
      the size constraints imposed by the physical hardware.

      The following might help but will likely require other
      axioms which reflect boundedness or round-trip properties.

    Parameter of_raw_byte : raw_byte -> N.
    Axiom inj_of_raw_byte : Inj (=) (=) of_raw_byte.
    #[global] Existing Instance inj_of_raw_byte.
  *)
End RAW_BYTES.

Module Type VAL_MIXIN (Import P : PTRS) (Import R : RAW_BYTES).
  (** * Values
      Primitive abstract C++ runtime values come in two flavors.
      - pointers (also used for references)
      - integers (used for everything else)
      Aggregates are not represented directly, but only by talking about
      primitive subobjects.

      There is also a distinguished undefined element [Vundef] that
      models uninitialized values <https://eel.is/c++draft/basic.indet>.
      Operations on [Vundef] are all undefined behavior.
      [Vraw] (a raw byte) represents the low-level bytewise view of data.
      See [logic/layout.v] for more axioms about it.
  *)
  Variant val : Set :=
  | Vint (_ : Z)
  | Vchar (_ : N)
    (* ^ value used for non-integral character types, e.g.
         [char], [wchar], etc, but *not* [unsigned char] and [signed char]

         The values here are *always* unsigned. When arithmetic is performed
         the semantics will convert the unsigned value into the appropriate
         equivalent on the target platform based on the signedness of the type.
     *)
  | Vptr (_ : ptr)
  | Vraw (_ : raw_byte)
  | Vundef
  .
  #[global] Notation Vref := Vptr (only parsing).

  (* TODO Maybe this should be removed *)
  #[global] Coercion Vint : Z >-> val.

  Definition val_dec : forall a b : val, {a = b} + {a <> b}.
  Proof. solve_decision. Defined.
  #[global] Instance val_eq_dec : EqDecision val := val_dec.
  #[global] Instance val_inhabited : Inhabited val := populate (Vint 0).

  (** ** Notation wrappers for [val] *)
  Definition Vbool (b : bool) : val :=
    Vint (if b then 1 else 0).
  Definition Vnat (b : nat) : val :=
    Vint (Z.of_nat b).
  Definition Vn (b : N) : val :=
    Vint (Z.of_N b).
  Notation Vz := Vint (only parsing).

  (** we use [Vundef] as our value of type [void] *)
  Definition Vvoid := Vundef.

  (** [is_raw v] holds when [v] is a raw value. *)
  Definition is_raw (v : val) : bool :=
    match v with
    | Vraw _ => true
    | _ => false
    end.

  Definition is_true (v : val) : option bool :=
    match v with
    | Vint v => Some (bool_decide (v <> 0))
    | Vptr p => Some (bool_decide (p <> nullptr))
    | Vchar n => Some (bool_decide (n <> 0%N))
    | Vundef | Vraw _ => None
    end.
  #[global] Arguments is_true !_.

  (* An error used to say that [is_true] failed on the value [v] *)
  Record is_true_None (v : val) : Prop := {}.

  Theorem is_true_int : forall i,
      is_true (Vint i) = Some (bool_decide (i <> 0)).
  Proof. reflexivity. Qed.

  Lemma Vptr_inj p1 p2 : Vptr p1 = Vptr p2 -> p1 = p2.
  Proof. by move=> []. Qed.
  Lemma Vint_inj a b : Vint a = Vint b -> a = b.
  Proof. by move=> []. Qed.
  Lemma Vchar_inj a b : Vchar a = Vchar b -> a = b.
  Proof. by move=> []. Qed.
  Lemma Vbool_inj a b : Vbool a = Vbool b -> a = b.
  Proof. by move: a b =>[] [] /Vint_inj. Qed.

  #[global] Instance Vptr_Inj : Inj (=) (=) Vptr := Vptr_inj.
  #[global] Instance Vint_Inj : Inj (=) (=) Vint := Vint_inj.
  #[global] Instance Vchar_Inj : Inj (=) (=) Vchar := Vchar_inj.
  #[global] Instance Vbool_Inj : Inj (=) (=) Vbool := Vbool_inj.

  Definition N_to_char (t : char_type.t) (z : N) : val :=
    Vchar $ trimN (char_type.bitsN t) z.

  (* the default value for a type.
  * this is used to initialize primitives if you do, e.g.
  *   [int x{};]
  *)
  Fixpoint get_default (t : type) : option val :=
    match t with
    | Tpointer _ => Some (Vptr nullptr)
    | Tnum _ _ => Some (Vint 0%Z)
    | Tbool => Some (Vbool false)
    | Tnullptr => Some (Vptr nullptr)
    | Tqualified _ t => get_default t
    | _ => None
    end.
End VAL_MIXIN.

Module Type RAW_BYTES_VAL
       (Import P : PTRS) (Import R : RAW_BYTES)
       (Import V : VAL_MIXIN P R).
  (** [raw_bytes_of_val σ ty v rs] states that the value [v] of type
      [ty] is represented by the raw bytes in [rs]. What this means
      depends on the type [ty]. *)
  Parameter raw_bytes_of_val : genv -> type -> val -> list raw_byte -> Prop.

  Axiom raw_bytes_of_val_Proper : Proper (genv_leq ==> eq ==> eq ==> eq ==> iff) raw_bytes_of_val.
  #[global] Existing Instance raw_bytes_of_val_Proper.

  Axiom raw_bytes_of_val_unique_encoding : forall {σ ty v rs rs'},
      raw_bytes_of_val σ ty v rs -> raw_bytes_of_val σ ty v rs' -> rs = rs'.

  Axiom raw_bytes_of_val_int_unique_val : forall {σ sz sgn z z' rs},
      raw_bytes_of_val σ (Tnum sz sgn) (Vint z) rs ->
      raw_bytes_of_val σ (Tnum sz sgn) (Vint z') rs ->
      z = z'.

  Axiom raw_bytes_of_val_sizeof : forall {σ ty v rs},
      raw_bytes_of_val σ ty v rs -> size_of σ ty = Some (N.of_nat $ length rs).

  (* TODO Maybe add?
    Axiom raw_bytes_of_val_int : forall σ sz z rs,
        raw_bytes_of_val σ (Tnum sz Unsigned) (Vint z) rs <->
        exists l,
          (_Z_from_bytes (genv_byte_order σ) Unsigned l = z) /\
          rs = raw_int_byte <$> l.
  *)

  Module FieldOrBase.
    (* type for representing direct subobjects
       *Always* qualify this name, e.g. [FieldOrBase.t]
     *)
    Variant t : Set :=
    | Field (f : ident)
    | Base (_ : globname).

    #[global] Instance t_eq_dec : EqDecision t := ltac:(solve_decision).
    #[global,program] Instance t_countable : Countable t :=
      { encode x := encode match x with
                      | Field a => inl a
                      | Base b => inr b
                      end
      ; decode x := (fun x => match x with
                           | inl a => Field a
                           | inr b => Base b
                           end) <$> decode x
      }.
    Next Obligation.
      by destruct x; rewrite /= decode_encode/=.
    Qed.

  End FieldOrBase.

  (** [raw_bytes_of_struct σ cls rss rs] states that the struct
      consisting of fields of the raw bytes [rss] is represented by the
      raw bytes in [rs].

      [rs] should agree with [rss] on the offsets of the fields.
      This is captured by [raw_offsets].

      It might be possible to make some assumptions about the
      parts of [rs] that represent padding based on the ABI. *)
  Parameter raw_bytes_of_struct :
    genv -> globname -> gmap FieldOrBase.t (list raw_byte) -> list raw_byte -> Prop.

  (** TODO: introduction rules for [raw_bytes_of_struct] *)

  (** *** Elimination rules for [raw_bytes_of_struct] *)

  (** The size of the raw bytes of an object is the size of the object *)
  Axiom raw_bytes_of_struct_wf_size : forall σ cls flds rs,
    raw_bytes_of_struct σ cls flds rs ->
    Some (length rs) = N.to_nat <$> (size_of σ (Tnamed cls)).

  (** The raw bytes in each field is the size of the field *)
  Axiom raw_bytes_of_struct_wf_field : forall σ cls flds rs,
    raw_bytes_of_struct σ cls flds rs ->
    (forall m mty,
    type_of_field cls m = Some mty ->
    exists bytes, flds !! FieldOrBase.Field m = Some bytes /\
    Some (length bytes) = N.to_nat <$> (size_of σ mty)).

  (** The raw bytes in each base is the size of the base *)
  Axiom raw_bytes_of_struct_wf_base : forall σ cls flds rs base bytes,
    raw_bytes_of_struct σ cls flds rs ->
    flds !! FieldOrBase.Base base = Some bytes ->
    Some (length bytes) = N.to_nat <$> (size_of σ $ Tnamed base).

  (** The bytes at the offset are the ones that are referenced by the field *)
  Axiom raw_bytes_of_struct_offset : forall σ cls flds rs m bytes off,
    raw_bytes_of_struct σ cls flds rs ->
    flds !! FieldOrBase.Field m = Some bytes ->
    offset_of σ cls m = Some off ->
    firstn (length bytes) (skipn (Z.to_nat off) rs) = bytes.

End RAW_BYTES_VAL.

Module Type RAW_BYTES_MIXIN
       (Import P : PTRS) (Import R : RAW_BYTES)
       (Import V : VAL_MIXIN P R)
       (Import RD : RAW_BYTES_VAL P R V).

  Inductive val_related : genv -> type -> val -> val -> Prop :=
  | Veq_refl σ ty v: val_related σ ty v v
  | Vqual σ t ty v1 v2:
      val_related σ ty v1 v2 ->
      val_related σ (Tqualified t ty) v1 v2
  | Vraw_uint8 σ raw z
      (Hraw : raw_bytes_of_val σ Tu8 (Vint z) [raw]) :
      val_related σ Tu8 (Vraw raw) (Vint z)
  | Vuint8_raw σ z raw
      (Hraw : raw_bytes_of_val σ Tu8 (Vint z) [raw]) :
      val_related σ Tu8 (Vint z) (Vraw raw).

  Lemma val_related_qual :
    forall σ t ty v1 v2,
      val_related σ ty v1 v2 ->
      val_related σ (Tqualified t ty) v1 v2.
  Proof. intros; by constructor. Qed.

  #[global] Instance val_related_reflexive σ ty : Reflexive (val_related σ ty).
  Proof. constructor. Qed.

  #[global] Instance val_related_symmetric σ ty : Symmetric (val_related σ ty).
  Proof.
    rewrite /Symmetric; intros * Hval_related;
      induction Hval_related; subst; by constructor.
  Qed.

  #[global] Instance val_related_transitive σ ty : Transitive (val_related σ ty).
  Proof.
    rewrite /Transitive; intros * Hval_related1;
      induction Hval_related1; intros * Hval_related2.
    - by auto.
    - constructor; apply IHHval_related1;
        inversion Hval_related2; subst;
        by [constructor | auto].
    - inversion Hval_related2 as [ | | | ??? Hraw' ]; subst.
      + by constructor.
      + pose proof (raw_bytes_of_val_unique_encoding Hraw Hraw') as [= ->].
        by constructor.
    - inversion Hval_related2 as [ | | ??? Hraw' | ]; subst.
      + by constructor.
      + pose proof (raw_bytes_of_val_int_unique_val Hraw Hraw') as ->.
        by constructor.
  Qed.

  #[global] Instance val_related_Proper : Proper (genv_leq ==> eq ==> eq ==> eq ==> iff) val_related.
  Proof.
    repeat red; intros ?? Heq **; subst; split; intros Hval;
      induction Hval; subst; constructor; auto;
      by [rewrite -> Heq in Hraw | rewrite <- Heq in Hraw].
  Qed.

  Lemma raw_bytes_of_val_uint_length : forall σ v rs sz sgn,
      raw_bytes_of_val σ (Tnum sz sgn) v rs ->
      length rs = bytesNat sz.
  Proof.
    intros * Hraw_bytes_of_val%raw_bytes_of_val_sizeof.
    inversion Hraw_bytes_of_val as [Hsz]. clear Hraw_bytes_of_val.
    by apply N_of_nat_inj in Hsz.
  Qed.
End RAW_BYTES_MIXIN.

Module Type HAS_TYPE (Import P : PTRS) (Import R : RAW_BYTES) (Import V : VAL_MIXIN P R).
  (** typedness of values
      note that only primitives fit into this, there is no [val] representation
      of aggregates, except through [Vptr p] with [p] pointing to the contents.
  *)

  (**
  [has_type v ty] is an approximation in [Prop] of "[v] is an initialized value
  of type [t]." This implies:
  - if [ty <> Tvoid], then [v <> Vundef] <--
    ^---- TODO: <https://gitlab.com/bedrocksystems/cpp2v-core/-/issues/319>
  - if [ty = Tvoid], then [v = Vundef].
  - if [ty = Tnullptr], then [v = Vptr nullptr].
  - if [ty = Tnum sz sgn], then [v] fits the appropriate bounds (see
    [has_int_type']).
  - if [ty] is a type of pointers/aggregates, we only ensure that [v = Vptr p].
    + NOTE: We require that - for a type [Tnamed nm] - the name resolves to some
      [GlobDecl] other than [Gtype] in a given [σ : genv].
  - if [ty] is a type of references, we ensure that [v = Vref p] and
    that [p <> nullptr]; [Vref] is an alias for [Vptr]
  - if [ty] is a type of arrays, we ensure that [v = Vptr p] and
    that [p <> nullptr].
    *)
  Parameter has_type : forall {σ : genv}, val -> type -> Prop.

  #[global]
  Declare Instance has_type_mono : Proper (genv_leq ==> eq ==> eq ==> Basics.impl) (@has_type).

  #[global]
  Instance has_type_proper : Proper (genv_eq ==> eq ==> eq ==> iff) (@has_type).
  Proof.
    compute; split; apply has_type_mono; eauto; tauto.
  Qed.

  Section with_genv.
    Context {σ : genv}.

    Axiom has_type_pointer : forall v ty,
        has_type v (Tpointer ty) -> exists p, v = Vptr p.
    Axiom has_type_nullptr : forall v,
        has_type v Tnullptr <-> v = Vptr nullptr.
    Axiom has_type_ref : forall v ty,
        has_type v (Tref ty) -> exists p, v = Vref p /\ p <> nullptr.
    Axiom has_type_rv_ref : forall v ty,
        has_type v (Trv_ref ty) -> exists p, v = Vref p /\ p <> nullptr.
    Axiom has_type_array : forall v ty n,
        has_type v (Tarray ty n) -> exists p, v = Vptr p /\ p <> nullptr.
    Axiom has_type_function : forall v cc rty args,
        has_type v (Tfunction (cc:=cc) rty args) -> exists p, v = Vptr p /\ p <> nullptr.

    Axiom has_type_char : forall ct v,
        (exists n, v = Vchar n /\ 0 <= n < 2^(char_type.bitsN ct))%N <-> has_type v (Tchar_ ct).

    Axiom has_type_void : forall v,
        has_type v Tvoid -> v = Vundef.

    Axiom has_nullptr_type : forall ty,
        has_type (Vptr nullptr) (Tpointer ty).

    Axiom has_type_bool : forall v,
        has_type v Tbool <-> exists b, v = Vbool b.

    (* NOTE: even if an enumeration's underlying type is `unsigned int` (which contains
       raw values), raw values are not well typed at the enumeration type. *)
    Axiom has_type_enum : forall v nm,
        has_type v (Tenum nm) <->
        exists tu ty ls,
          tu ⊧ σ /\ tu !! nm = Some (Genum ty ls) /\
          (~is_raw v) /\ has_type v (drop_qualifiers ty).

    (** Note in the case of [Tuchar], the value [v] could be a
        raw value. *)
    Axiom has_int_type' : forall sz sgn v,
        has_type v (Tnum sz sgn) <->
          (exists z, v = Vint z /\ bound sz sgn z) \/
          (exists r, v = Vraw r /\ Tnum sz sgn = Tuchar).

    Axiom has_type_qual_iff : forall t q x,
        has_type x t <-> has_type x (Tqualified q t).

  End with_genv.

End HAS_TYPE.

Module Type HAS_TYPE_MIXIN (Import P : PTRS) (Import R : RAW_BYTES) (Import V : VAL_MIXIN P R)
    (Import HT : HAS_TYPE P R V).
  Section with_env.
    Context {σ : genv}.

    Lemma has_bool_type : forall z,
      0 <= z < 2 <-> has_type (Vint z) Tbool.
    Proof.
      intros z. rewrite has_type_bool. split=>Hz.
      - destruct (decide (z = 0)); simplify_eq; first by exists false.
        destruct (decide (z = 1)); simplify_eq; first by exists true. lia.
      - unfold Vbool in Hz. destruct Hz as [b Hb].
        destruct b; simplify_eq; lia.
    Qed.

    Lemma has_int_type : forall sz (sgn : signed) z,
        bound sz sgn z <-> has_type (Vint z) (Tnum sz sgn).
    Proof. move => *. rewrite has_int_type'. naive_solver. Qed.

    Lemma has_type_char' (n : N) ct : (0 <= n < 2 ^ char_type.bitsN ct)%N <-> has_type (Vchar n) (Tchar_ ct).
    Proof. rewrite -has_type_char. naive_solver. Qed.

    Lemma has_type_char_255 (n : N) ct : (0 <= n < 256)%N -> has_type (Vchar n) (Tchar_ ct).
    Proof. intros. rewrite -has_type_char'. destruct ct; simpl; lia. Qed.

    Lemma has_type_char_0 ct :  has_type (Vchar 0) (Tchar_ ct).
    Proof. intros. apply has_type_char_255. lia. Qed.

    Lemma has_type_drop_qualifiers
      : forall v ty, has_type v ty <-> has_type v (drop_qualifiers ty).
    Proof.
      induction ty; simpl; eauto.
      by rewrite -has_type_qual_iff -IHty.
    Qed.

    (* TODO fix naming convention *)
    Lemma has_type_qual  t q x :
        has_type x (drop_qualifiers t) ->
        has_type x (Tqualified q t).
    Proof.
      intros. by apply has_type_drop_qualifiers.
    Qed.

    Section has_type.
      Lemma has_type_bswap8:
        forall v,
          has_type (Vint (bswap8 v)) Tu8.
      Proof. intros *; apply has_int_type; red; generalize (bswap8_bounded v); simpl; lia. Qed.

      Lemma has_type_bswap16:
        forall v,
          has_type (Vint (bswap16 v)) Tu16.
      Proof. intros *; apply has_int_type; red; generalize (bswap16_bounded v); simpl; lia. Qed.

      Lemma has_type_bswap32:
        forall v,
          has_type (Vint (bswap32 v)) Tu32.
      Proof. intros *; apply has_int_type; red; generalize (bswap32_bounded v); simpl; lia. Qed.

      Lemma has_type_bswap64:
        forall v,
          has_type (Vint (bswap64 v)) Tu64.
      Proof. intros *; apply has_int_type; red; generalize (bswap64_bounded v); simpl; lia. Qed.

      Lemma has_type_bswap128:
        forall v,
          has_type (Vint (bswap128 v)) Tu128.
      Proof. intros *; apply has_int_type; red; generalize (bswap128_bounded v); simpl; lia. Qed.
    End has_type.

    Lemma has_type_bswap:
      forall sz v,
        has_type (Vint (bswap sz v)) (Tnum sz Unsigned).
    Proof.
      intros *; destruct sz;
        eauto using
              has_type_bswap8,
              has_type_bswap16,
              has_type_bswap32,
              has_type_bswap64,
              has_type_bswap128.
    Qed.

  End with_env.

  #[global] Hint Resolve has_type_qual : has_type.
  #[global] Hint Resolve has_type_bswap : has_type.

  Arguments Z.add _ _ : simpl never.
  Arguments Z.sub _ _ : simpl never.
  Arguments Z.mul _ _ : simpl never.
  Arguments Z.pow _ _ : simpl never.
  Arguments Z.opp _ : simpl never.
  Arguments Z.pow_pos _ _ : simpl never.

End HAS_TYPE_MIXIN.

(* Collect all the axioms. *)
Module Type VALUES_DEFS (P : PTRS_INTF) := RAW_BYTES <+ VAL_MIXIN P <+ RAW_BYTES_VAL P <+ HAS_TYPE P.
(* Plug mixins. *)
Module Type VALUES_INTF_FUNCTOR (P : PTRS_INTF) := VALUES_DEFS P <+ RAW_BYTES_MIXIN P <+ HAS_TYPE_MIXIN P.

Declare Module Export PTRS_INTF_AXIOM : PTRS_INTF.

(* Interface for other modules. *)
Module Export VALUES_INTF_AXIOM <: VALUES_INTF_FUNCTOR PTRS_INTF_AXIOM.
  Include VALUES_INTF_FUNCTOR PTRS_INTF_AXIOM.
End VALUES_INTF_AXIOM.


Require Import String.
(*Require Import Sail_impl_base*)
Require Import Sail.Instr_kinds.
Require Import Sail.Values.
Require bbv.Word.
Import ListNotations.
Local Open Scope Z.

Definition register_name := string.
Definition address := list bitU.

Inductive monad regval a e :=
  | Done : a -> monad regval a e
  (* Read a number of bytes from memory, returned in little endian order,
     with or without a tag.  The first nat specifies the address, the second
     the number of bytes. *)
  | Read_mem : read_kind -> nat -> nat -> (list memory_byte -> monad regval a e) -> monad regval a e
  | Read_memt : read_kind -> nat -> nat -> ((list memory_byte * bitU) -> monad regval a e) -> monad regval a e
  (* Tell the system a write is imminent, at the given address and with the
     given size. *)
  | Write_ea : write_kind -> nat -> nat -> monad regval a e -> monad regval a e
  (* Request the result : store-exclusive *)
  | Excl_res : (bool -> monad regval a e) -> monad regval a e
  (* Request to write a memory value of the given size at the given address,
     with or without a tag. *)
  | Write_mem : write_kind -> nat -> nat -> list memory_byte -> (bool -> monad regval a e) -> monad regval a e
  | Write_memt : write_kind -> nat -> nat -> list memory_byte -> bitU -> (bool -> monad regval a e) -> monad regval a e
  (* Tell the system to dynamically recalculate dependency footprint *)
  | Footprint : monad regval a e -> monad regval a e
  (* Request a memory barrier *)
  | Barrier : barrier_kind -> monad regval a e -> monad regval a e
  (* Request to read register, will track dependency when mode.track_values *)
  | Read_reg : register_name -> (regval -> monad regval a e) -> monad regval a e
  (* Request to write register *)
  | Write_reg : register_name -> regval -> monad regval a e -> monad regval a e
  (* Request to choose a Boolean, e.g. to resolve an undefined bit. The string
     argument may be used to provide information to the system about what the
     Boolean is going to be used for. *)
  | Choose : string -> (bool -> monad regval a e) -> monad regval a e
  (* Print debugging or tracing information *)
  | Print : string -> monad regval a e -> monad regval a e
  (*Result of a failed assert with possible error message to report*)
  | Fail : string -> monad regval a e
  (* Exception of type e *)
  | Exception : e -> monad regval a e.

Arguments Done [_ _ _].
Arguments Read_mem [_ _ _].
Arguments Read_memt [_ _ _].
Arguments Write_ea [_ _ _].
Arguments Excl_res [_ _ _].
Arguments Write_mem [_ _ _].
Arguments Write_memt [_ _ _].
Arguments Footprint [_ _ _].
Arguments Barrier [_ _ _].
Arguments Read_reg [_ _ _].
Arguments Write_reg [_ _ _].
Arguments Choose [_ _ _].
Arguments Print [_ _ _].
Arguments Fail [_ _ _].
Arguments Exception [_ _ _].

Inductive event {regval} :=
  | E_read_mem : read_kind -> nat -> nat -> list memory_byte -> event
  | E_read_memt : read_kind -> nat -> nat -> (list memory_byte * bitU) -> event
  | E_write_mem : write_kind -> nat -> nat -> list memory_byte -> bool -> event
  | E_write_memt : write_kind -> nat -> nat -> list memory_byte -> bitU -> bool -> event
  | E_write_ea : write_kind -> nat -> nat -> event
  | E_excl_res : bool -> event
  | E_barrier : barrier_kind -> event
  | E_footprint : event
  | E_read_reg : register_name -> regval -> event
  | E_write_reg : register_name -> regval -> event
  | E_choose : string -> bool -> event
  | E_print : string -> event.
Arguments event : clear implicits.

Definition trace regval := list (event regval).

(*val return : forall rv a e. a -> monad rv a e*)
Definition returnm {rv A E} (a : A) : monad rv A E := Done a.

(*val bind : forall rv a b e. monad rv a e -> (a -> monad rv b e) -> monad rv b e*)
Fixpoint bind {rv A B E} (m : monad rv A E) (f : A -> monad rv B E) := match m with
  | Done a => f a
  | Read_mem rk a sz k =>       Read_mem rk a sz       (fun v => bind (k v) f)
  | Read_memt rk a sz k =>      Read_memt rk a sz      (fun v => bind (k v) f)
  | Write_mem wk a sz v k =>    Write_mem wk a sz v    (fun v => bind (k v) f)
  | Write_memt wk a sz v t k => Write_memt wk a sz v t (fun v => bind (k v) f)
  | Read_reg descr k =>         Read_reg descr         (fun v => bind (k v) f)
  | Excl_res k =>               Excl_res               (fun v => bind (k v) f)
  | Choose descr k =>           Choose descr           (fun v => bind (k v) f)
  | Write_ea wk a sz k =>       Write_ea wk a sz       (bind k f)
  | Footprint k =>              Footprint              (bind k f)
  | Barrier bk k =>             Barrier bk             (bind k f)
  | Write_reg r v k =>          Write_reg r v          (bind k f)
  | Print msg k =>              Print msg              (bind k f)
  | Fail descr =>               Fail descr
  | Exception e =>              Exception e
end.

Notation "m >>= f" := (bind m f) (at level 50, left associativity).
(*val (>>) : forall rv b e. monad rv unit e -> monad rv b e -> monad rv b e*)
Definition bind0 {rv A E} (m : monad rv unit E) (n : monad rv A E) :=
  m >>= fun (_ : unit) => n.
Notation "m >> n" := (bind0 m n) (at level 50, left associativity).

(*val exit : forall rv a e. unit -> monad rv a e*)
Definition exit {rv A E} (_ : unit) : monad rv A E := Fail "exit".

(*val choose_bool : forall 'rv 'e. string -> monad 'rv bool 'e*)
Definition choose_bool {rv E} descr : monad rv bool E := Choose descr returnm.

(*val undefined_bool : forall 'rv 'e. unit -> monad 'rv bool 'e*)
Definition undefined_bool {rv e} (_:unit) : monad rv bool e := choose_bool "undefined_bool".

Definition undefined_unit {rv e} (_:unit) : monad rv unit e := returnm tt.

(*val assert_exp : forall rv e. bool -> string -> monad rv unit e*)
Definition assert_exp {rv E} (exp :bool) msg : monad rv unit E :=
 if exp then Done tt else Fail msg.

Definition assert_exp' {rv E} (exp :bool) msg : monad rv (exp = true) E :=
 if exp return monad rv (exp = true) E then Done eq_refl else Fail msg.
Definition bindH {rv A P E} (m : monad rv P E) (n : monad rv A E) :=
  m >>= fun (H : P) => n.
Notation "m >>> n" := (bindH m n) (at level 50, left associativity).

(*val throw : forall rv a e. e -> monad rv a e*)
Definition throw {rv A E} e : monad rv A E := Exception e.

(*val try_catch : forall rv a e1 e2. monad rv a e1 -> (e1 -> monad rv a e2) -> monad rv a e2*)
Fixpoint try_catch {rv A E1 E2} (m : monad rv A E1) (h : E1 -> monad rv A E2) := match m with
  | Done a =>                   Done a
  | Read_mem rk a sz k =>       Read_mem rk a sz       (fun v => try_catch (k v) h)
  | Read_memt rk a sz k =>      Read_memt rk a sz      (fun v => try_catch (k v) h)
  | Write_mem wk a sz v k =>    Write_mem wk a sz v    (fun v => try_catch (k v) h)
  | Write_memt wk a sz v t k => Write_memt wk a sz v t (fun v => try_catch (k v) h)
  | Read_reg descr k =>         Read_reg descr         (fun v => try_catch (k v) h)
  | Excl_res k =>               Excl_res               (fun v => try_catch (k v) h)
  | Choose descr k =>           Choose descr           (fun v => try_catch (k v) h)
  | Write_ea wk a sz k =>       Write_ea wk a sz       (try_catch k h)
  | Footprint k =>              Footprint              (try_catch k h)
  | Barrier bk k =>             Barrier bk             (try_catch k h)
  | Write_reg r v k =>          Write_reg r v          (try_catch k h)
  | Print msg k =>              Print msg              (try_catch k h)
  | Fail descr =>               Fail descr
  | Exception e =>              h e
end.

(* For early return, we abuse exceptions by throwing and catching
   the return value. The exception type is "either r e", where "inr e"
   represents a proper exception and "inl r" an early return : value "r". *)
Definition monadR rv a r e := monad rv a (sum r e).

(*val early_return : forall rv a r e. r -> monadR rv a r e*)
Definition early_return {rv A R E} (r : R) : monadR rv A R E := throw (inl r).

(*val catch_early_return : forall rv a e. monadR rv a a e -> monad rv a e*)
Definition catch_early_return {rv A E} (m : monadR rv A A E) :=
  try_catch m
    (fun r => match r with
      | inl a => returnm a
      | inr e => throw e
     end).

(* Lift to monad with early return by wrapping exceptions *)
(*val liftR : forall rv a r e. monad rv a e -> monadR rv a r e*)
Definition liftR {rv A R E} (m : monad rv A E) : monadR rv A R E :=
 try_catch m (fun e => throw (inr e)).

(* Catch exceptions in the presence : early returns *)
(*val try_catchR : forall rv a r e1 e2. monadR rv a r e1 -> (e1 -> monadR rv a r e2) ->  monadR rv a r e2*)
Definition try_catchR {rv A R E1 E2} (m : monadR rv A R E1) (h : E1 -> monadR rv A R E2) :=
  try_catch m
    (fun r => match r with
      | inl r => throw (inl r)
      | inr e => h e
     end).

(*val maybe_fail : forall 'rv 'a 'e. string -> maybe 'a -> monad 'rv 'a 'e*)
Definition maybe_fail {rv A E} msg (x : option A) : monad rv A E :=
match x with
  | Some a => returnm a
  | None => Fail msg
end.

(*val read_memt_bytes : forall 'rv 'a 'b 'e. Bitvector 'a, Bitvector 'b => read_kind -> 'a -> integer -> monad 'rv (list memory_byte * bitU) 'e*)
Definition read_memt_bytes {rv A E} rk (addr : mword A) sz : monad rv (list memory_byte * bitU) E :=
  Read_memt rk (Word.wordToNat (get_word addr)) (Z.to_nat sz) returnm.

(*val read_memt : forall 'rv 'a 'b 'e. Bitvector 'a, Bitvector 'b => read_kind -> 'a -> integer -> monad 'rv ('b * bitU) 'e*)
Definition read_memt {rv A B E} `{ArithFact (B >=? 0)} rk (addr : mword A) sz : monad rv (mword B * bitU) E :=
  bind
    (read_memt_bytes rk addr sz)
    (fun '(bytes, tag) =>
       match of_bits (bits_of_mem_bytes bytes) with
       | Some v => returnm (v, tag)
       | None => Fail "bits_of_mem_bytes"
       end).

(*val read_mem_bytes : forall 'rv 'a 'b 'e. Bitvector 'a, Bitvector 'b => read_kind -> 'a -> integer -> monad 'rv (list memory_byte) 'e*)
Definition read_mem_bytes {rv A E} rk (addr : mword A) sz : monad rv (list memory_byte) E :=
  Read_mem rk (Word.wordToNat (get_word addr)) (Z.to_nat sz) returnm.

(*val read_mem : forall 'rv 'a 'b 'e. Bitvector 'a, Bitvector 'b => read_kind -> 'a -> integer -> monad 'rv 'b 'e*)
Definition read_mem {rv A B E} `{ArithFact (B >=? 0)} rk (addrsz : Z) (addr : mword A) sz : monad rv (mword B) E :=
  bind
    (read_mem_bytes rk addr sz)
    (fun bytes =>
       maybe_fail "bits_of_mem_bytes" (of_bits (bits_of_mem_bytes bytes))).

(*val excl_result : forall rv e. unit -> monad rv bool e*)
Definition excl_result {rv e} (_:unit) : monad rv bool e :=
  let k successful := (returnm successful) in
  Excl_res k.

Definition write_mem_ea {rv a E} wk (addrsz : Z) (addr: mword a) sz : monad rv unit E :=
 Write_ea wk (Word.wordToNat (get_word addr)) (Z.to_nat sz) (Done tt).

(*val write_mem : forall 'rv 'a 'b 'e. Bitvector 'a, Bitvector 'b =>
  write_kind -> integer -> 'a -> integer -> 'b -> monad 'rv bool 'e*)
Definition write_mem {rv a b E} wk (addrsz : Z) (addr : mword a) sz (v : mword b) : monad rv bool E :=
  match (mem_bytes_of_bits v, Word.wordToNat (get_word addr)) with
    | (Some v, addr) =>
       Write_mem wk addr (Z.to_nat sz) v returnm
    | _ => Fail "write_mem"
  end.

(*val write_memt : forall 'rv 'a 'b 'e. Bitvector 'a, Bitvector 'b =>
  write_kind -> 'a -> integer -> 'b -> bitU -> monad 'rv bool 'e*)
Definition write_memt {rv a b E} wk (addr : mword a) sz (v : mword b) tag : monad rv bool E :=
  match (mem_bytes_of_bits v, Word.wordToNat (get_word addr)) with
    | (Some v, addr) =>
       Write_memt wk addr (Z.to_nat sz) v tag returnm
    | _ => Fail "write_mem"
  end.

Definition read_reg {s rv a e} (reg : register_ref s rv a) : monad rv a e :=
  let k v :=
    match reg.(of_regval) v with
      | Some v => Done v
      | None => Fail "read_reg: unrecognised value"
    end
  in
  Read_reg reg.(name) k.

(* TODO
val read_reg_range : forall 's 'r 'rv 'a 'e. Bitvector 'a => register_ref 's 'rv 'r -> integer -> integer -> monad 'rv 'a 'e
let read_reg_range reg i j =
  read_reg_aux of_bits (external_reg_slice reg (nat_of_int i,nat_of_int j))

let read_reg_bit reg i =
  read_reg_aux (fun v -> v) (external_reg_slice reg (nat_of_int i,nat_of_int i)) >>= fun v ->
  return (extract_only_element v)

let read_reg_field reg regfield =
  read_reg_aux (external_reg_field_whole reg regfield)

let read_reg_bitfield reg regfield =
  read_reg_aux (external_reg_field_whole reg regfield) >>= fun v ->
  return (extract_only_element v)*)

Definition reg_deref {s rv a e} := @read_reg s rv a e.

(*Parameter write_reg : forall {s rv a e}, register_ref s rv a -> a -> monad rv unit e.*)
Definition write_reg {s rv a e} (reg : register_ref s rv a) (v : a) : monad rv unit e :=
 Write_reg reg.(name) (reg.(regval_of) v) (Done tt).

(* TODO
let write_reg reg v =
  write_reg_aux (external_reg_whole reg) v
let write_reg_range reg i j v =
  write_reg_aux (external_reg_slice reg (nat_of_int i,nat_of_int j)) v
let write_reg_pos reg i v =
  let iN = nat_of_int i in
  write_reg_aux (external_reg_slice reg (iN,iN)) [v]
let write_reg_bit = write_reg_pos
let write_reg_field reg regfield v =
  write_reg_aux (external_reg_field_whole reg regfield.field_name) v
let write_reg_field_bit reg regfield bit =
  write_reg_aux (external_reg_field_whole reg regfield.field_name)
                (Vector [bit] 0 (is_inc_of_reg reg))
let write_reg_field_range reg regfield i j v =
  write_reg_aux (external_reg_field_slice reg regfield.field_name (nat_of_int i,nat_of_int j)) v
let write_reg_field_pos reg regfield i v =
  write_reg_field_range reg regfield i i [v]
let write_reg_field_bit = write_reg_field_pos*)

(*val barrier : forall rv e. barrier_kind -> monad rv unit e*)
Definition barrier {rv e} bk : monad rv unit e := Barrier bk (Done tt).

(*val footprint : forall rv e. unit -> monad rv unit e*)
Definition footprint {rv e} (_ : unit) : monad rv unit e := Footprint (Done tt).

(* Event traces *)

Local Open Scope bool_scope.

(*val emitEvent : forall 'regval 'a 'e. Eq 'regval => monad 'regval 'a 'e -> event 'regval -> maybe (monad 'regval 'a 'e)*)
Definition emitEvent {Regval A E} `{forall (x y : Regval), Decidable (x = y)} (m : monad Regval A E) (e : event Regval) : option (monad Regval A E) :=
 match (e, m) with
  | (E_read_mem rk a sz v, Read_mem rk' a' sz' k) =>
     if read_kind_beq rk' rk && Nat.eqb a' a && Nat.eqb sz' sz then Some (k v) else None
  | (E_read_memt rk a sz vt, Read_memt rk' a' sz' k) =>
     if read_kind_beq rk' rk && Nat.eqb a' a && Nat.eqb sz' sz then Some (k vt) else None
  | (E_write_mem wk a sz v r, Write_mem wk' a' sz' v' k) =>
     if write_kind_beq wk' wk && Nat.eqb a' a && Nat.eqb sz' sz && generic_eq v' v then Some (k r) else None
  | (E_write_memt wk a sz v tag r, Write_memt wk' a' sz' v' tag' k) =>
     if write_kind_beq wk' wk && Nat.eqb a' a && Nat.eqb sz' sz && generic_eq v' v && generic_eq tag' tag then Some (k r) else None
  | (E_read_reg r v, Read_reg r' k) =>
     if generic_eq r' r then Some (k v) else None
  | (E_write_reg r v, Write_reg r' v' k) =>
     if generic_eq r' r && generic_eq v' v then Some k else None
  | (E_write_ea wk a sz, Write_ea wk' a' sz' k) =>
     if write_kind_beq wk' wk && Nat.eqb a' a && Nat.eqb sz' sz then Some k else None
  | (E_barrier bk, Barrier bk' k) =>
     if barrier_kind_beq bk' bk then Some k else None
  | (E_print m, Print m' k) =>
     if generic_eq m' m then Some k else None
  | (E_excl_res v, Excl_res k) => Some (k v)
  | (E_choose descr v, Choose descr' k) => if generic_eq descr' descr then Some (k v) else None
  | (E_footprint, Footprint k) => Some k
  | _ => None
end.

Definition option_bind {A B : Type} (a : option A) (f : A -> option B) : option B :=
match a with
| Some x => f x
| None => None
end.

(*val runTrace : forall 'regval 'a 'e. Eq 'regval => trace 'regval -> monad 'regval 'a 'e -> maybe (monad 'regval 'a 'e)*)
Fixpoint runTrace {Regval A E} `{forall (x y : Regval), Decidable (x = y)} (t : trace Regval) (m : monad Regval A E) : option (monad Regval A E) :=
match t with
  | [] => Some m
  | e :: t' => option_bind (emitEvent m e) (runTrace t')
end.

(*val final : forall 'regval 'a 'e. monad 'regval 'a 'e -> bool*)
Definition final {Regval A E} (m : monad Regval A E) : bool :=
match m with
  | Done _ => true
  | Fail _ => true
  | Exception _ => true
  | _ => false
end.

(*val hasTrace : forall 'regval 'a 'e. Eq 'regval => trace 'regval -> monad 'regval 'a 'e -> bool*)
Definition hasTrace {Regval A E} `{forall (x y : Regval), Decidable (x = y)} (t : trace Regval) (m : monad Regval A E) : bool :=
match runTrace t m with
  | Some m => final m
  | None => false
end.

(*val hasException : forall 'regval 'a 'e. Eq 'regval => trace 'regval -> monad 'regval 'a 'e -> bool*)
Definition hasException {Regval A E} `{forall (x y : Regval), Decidable (x = y)} (t : trace Regval) (m : monad Regval A E) :=
match runTrace t m with
  | Some (Exception _) => true
  | _ => false
end.

(*val hasFailure : forall 'regval 'a 'e. Eq 'regval => trace 'regval -> monad 'regval 'a 'e -> bool*)
Definition hasFailure {Regval A E} `{forall (x y : Regval), Decidable (x = y)} (t : trace Regval) (m : monad Regval A E) :=
match runTrace t m with
  | Some (Fail _) => true
  | _ => false
end.


Require Import Rupicola.Lib.Api.

Record  cell {width: Z} {BW: Bitwidth width} {word: word.word width} := { data : word }.
Section with_parameters.
  Context {width: Z} {BW: Bitwidth width} {word: word.word width} {mem: map.map word Byte.byte}.
  Context {locals: map.map String.string word}.
  Context {env: map.map String.string (list String.string * list String.string * Syntax.cmd)}.
  Context {ext_spec: bedrock2.Semantics.ExtSpec}.
  Context {wordok : word.ok word} {mapok : map.ok mem}.
  Context {localsok : map.ok locals}.
  Context {envok : map.ok env}.
  Context {ext_spec_ok : Semantics.ext_spec.ok ext_spec}.
  Local Notation cell := (@cell width BW word).

  Definition cell_value (addr: word) (c: cell)
    : mem -> Prop :=
    scalar addr c.(data).

  Definition get c := c.(data).
  Definition put v := {| data := v |}.
  (* No reference to the original cell: Rupicola decides which one to modify
     based on the target of the call:
       let/n c := put x in …
             ^ .......^.... this gets mutated
                      ^ ... with this value *)

  Lemma compile_get : forall {tr mem locals functions} (c: cell),
    let v := get c in
    forall {P} {pred: P v -> predicate} {k: nlet_eq_k P v} {k_impl}
      R c_ptr c_expr var,

      sep (cell_value c_ptr c) R mem ->
      WeakestPrecondition.dexpr mem locals c_expr c_ptr ->

      (let v := v in
       <{ Trace := tr;
          Memory := mem;
          Locals := map.put locals var v;
          Functions := functions }>
       k_impl
       <{ pred (k v eq_refl) }>) ->
      <{ Trace := tr;
         Memory := mem;
         Locals := locals;
         Functions := functions }>
      cmd.seq (cmd.set var (expr.load access_size.word c_expr))
              k_impl
      <{ pred (nlet_eq [var] v k) }>.
  Proof.
    repeat straightline.
    exists (get c); split; repeat straightline; eauto.
    eapply WeakestPrecondition_dexpr_expr; eauto.
    eexists; split; [ | reflexivity ].
    eauto using load_word_of_sep.
  Qed.

  Lemma compile_put : forall {tr mem locals functions} x,
    let v := put x in
    forall {P} {pred: P v -> predicate} {k: nlet_eq_k P v} {k_impl}
      R c_ptr _c c_var x_expr,

      WeakestPrecondition.dexpr mem locals x_expr x ->
      map.get locals c_var = Some c_ptr ->
      sep (cell_value c_ptr _c) R mem -> (* See FAQ on parameter order *)

      (let v := v in
       forall m,
         sep (cell_value c_ptr v) R m ->
         (<{ Trace := tr;
             Memory := m;
             Locals := locals;
             Functions := functions }>
          k_impl
          <{ pred (k v eq_refl) }>)) ->
      <{ Trace := tr;
         Memory := mem;
         Locals := locals;
         Functions := functions }>
      cmd.seq (cmd.store access_size.word (expr.var c_var) x_expr)
              k_impl
      <{ pred (nlet_eq [c_var] v k) }>.
  Proof.
    unfold cell_value; repeat straightline.
    exists c_ptr; split; eexists; split; eauto.
    repeat straightline. eauto.
  Qed.

  #[global] Program Instance SimpleAllocable_cell : Allocable cell_value :=
    {| size_in_bytes := Memory.bytes_per_word width;
       size_in_bytes_mod := Z_mod_same_full _;
       P_to_bytes := _;
       P_from_bytes := _ |}.
  Next Obligation.
    apply (P_to_bytes (Allocable := Allocable_scalar)).
  Qed.
  Next Obligation.
    intros m H.
    edestruct (P_from_bytes (Allocable := Allocable_scalar) _ _ H).
    exists {| data := x |}. assumption.
  Qed.
End with_parameters.

#[export] Hint Extern 1 => simple eapply compile_get; shelve : compiler.
#[export] Hint Extern 1 => simple eapply compile_put; shelve : compiler.