(* begin hide *)
Require Import Psatz.

From Coq Require Import
     Lists.List
     Strings.String
     Morphisms
     ZArith
     Setoid
     RelationClasses.

From ITree Require Import
     Basics.Category
     Basics.HeterogeneousRelations
     Basics.Monad
     ITree
     ITreeMonad
     ITreeFacts
     Events.StateFacts
     Events.MapDefault
     Events.MapDefaultFacts
     Events.State.

Import ITreeNotations.

From ExtLib Require Import
     Core.RelDec
     Structures.Monad
     Structures.Maps
     Programming.Show
     Data.Map.FMapAList.

Import ListNotations.
Open Scope string_scope.

Import CatNotations.
Local Open Scope cat_scope.
Local Open Scope itree_scope.

From ITreeTutorial Require Import Fin Asm AsmCombinators Utils_tutorial.

(* end hide *)

(* optimizations ------------------------------------------------------------ *)

(** A (simple) optimization is just a function from asm units to asm units. *)

Definition optimization {A B} := asm A B -> asm A B.

(** An optimization is correct if it yields an equivalent computation.

    - Note that eq_asm requires that resulting register environment and
      the resulting heap must be equivalent, so this formulation of
      correctness does not permit the elimination of local variables or
      differences in the state.  Those optimizations would require
      more contextual information.
*)

(** We define an appropriate notion of equivalence on these state components.
    This will be useful for defining optimizations at the [Asm] level. *)

Definition EQ_registers (d:value) (regs1 regs2 : registers) : Prop :=
  @eq_map _ _ _ _ d regs1 regs2.

Global Instance EQ_registers_refl {d} : Reflexive (EQ_registers d).
unfold EQ_registers. typeclasses eauto.
Qed.

Global Instance EQ_registers_sym {d} : Symmetric (EQ_registers d).
unfold EQ_registers. typeclasses eauto.
Qed.

Global Instance EQ_registers_trans {d} : Transitive (EQ_registers d).
unfold EQ_registers. typeclasses eauto.
Qed.

Global Instance EQ_registers_eqv {d} : Equivalence (EQ_registers d).
constructor; typeclasses eauto.
Qed.

Definition EQ_memory (mem1 mem2 : memory) : Prop :=
  @eq_map _ _ _ _ 0 mem1 mem2.

Global Instance EQ_memory_refl : Reflexive (EQ_memory).
unfold EQ_memory. typeclasses eauto.
Qed.

Global Instance EQ_memory_sym : Symmetric (EQ_memory).
unfold EQ_memory. typeclasses eauto.
Qed.

Global Instance EQ_memory_trans : Transitive (EQ_memory).
unfold EQ_memory. typeclasses eauto.
Qed.

Global Instance EQ_memory_eqv : Equivalence (EQ_memory).
constructor; typeclasses eauto.
Qed.

Definition rel_asm {B} : memory * (registers * B) -> memory * (registers * B) -> Prop :=
  prod_rel EQ_memory (prod_rel (EQ_registers 0) eq).

Global Hint Unfold rel_asm: core.

(** The definition [interp_asm] also induces a notion of equivalence (open)
    _asm_ programs, which is just the equivalence of the ktree category *)
Definition eq_asm_denotations_EQ {E A B} (t1 t2 : Kleisli (itree (Reg +' Memory +' E)) A B) : Prop :=
  forall a mem1 mem2 regs1 regs2,
    EQ_memory mem1 mem2 ->
    EQ_registers 0 regs1 regs2 ->
    (eutt rel_asm)
      (interp_asm (t1 a) mem1 regs1)
      (interp_asm (t2 a) mem2 regs2).

Definition eq_asm_EQ {E} `{Exit -< E} {A B} (p1 p2 : asm A B) : Prop :=
  eq_asm_denotations_EQ (E := E) (denote_asm p1) (denote_asm p2).

Definition optimization_correct {E} `{Exit -< E} A B (opt:optimization) : Prop :=
  forall (p : asm A B),
    eq_asm_EQ (E := E) p (opt p).

Definition EQ_asm {E A} (f g : memory -> registers -> itree E (memory * (registers * A))) : Prop :=
  forall mem1 mem2 regs1 regs2,
    EQ_memory mem1 mem2 ->
    EQ_registers 0 regs1 regs2 ->
    eutt (@rel_asm A) (f mem1 regs1) (g mem2 regs2).

Infix "≡" := EQ_asm (at level 70).

Lemma interp_asm_ret_tt {E} : forall (t : itree (Reg +' Memory +' E) unit),
    (interp_asm t) ≡ (interp_asm (t ;; Ret tt)).
Proof.
  intros t mem1 mem2 regs1 regs2 H1 H2.
  rewrite interp_asm_bind.
  rewrite <- bind_ret_r at 1.
  apply (@eutt_clo_bind _ _ _ _ _ _ rel_asm).
  { unfold interp_asm.
    unfold rel_asm.
    eapply interp_map_proper; try typeclasses eauto; auto.
    eapply interp_map_proper; try typeclasses eauto; auto.
    reflexivity.
  }
  intros.
  destruct H as [J1 [J2 J3]]; subst.
  unfold interp_asm.
  unfold interp_map.
  destruct u2 as [? [? []]].
  rewrite interp_ret.
  do 2 rewrite interp_state_ret.
  apply eqit_Ret. auto.
Qed.

Lemma interp_asm_ret {E A} (x:A) mem reg :
  interp_asm (Ret x) mem reg ≈ (Ret (mem, (reg, x)) : itree E _).
Proof.
  unfold interp_asm, interp_map.
  rewrite interp_ret.
  repeat rewrite interp_state_ret.
  reflexivity.
Qed.

Global Instance rel_asm_eqv :
  forall A, Equivalence (@rel_asm A).
Proof.
  intros.
  unfold rel_asm. eapply prod_rel_eqv; try typeclasses eauto.
Qed.

Lemma interp_asm_GetReg {E A} f r mem reg :
  @eutt E _ _ (@rel_asm A)
       (interp_asm (val <- trigger (GetReg r) ;; f val) mem reg)
       ((interp_asm (f (lookup_default r 0 reg))) mem reg).
Proof.
  unfold interp_asm, interp_map.
  rewrite interp_bind.
  setoid_rewrite interp_trigger.
  repeat rewrite interp_state_bind. cbn.
  unfold subevent, resum, ReSum_inl, resum, ReSum_id, id_.
  unfold Id_IFun.
  unfold CategoryOps.cat, Cat_Handler, Handler.cat. cbn.
  unfold lookup_def.
  unfold embed, Embeddable_forall, embed, Embeddable_itree.
  unfold trigger. rewrite interp_vis. setoid_rewrite interp_ret.
  unfold subevent, resum.
  repeat rewrite interp_state_bind.
  repeat setoid_rewrite interp_state_ret.
  unfold inl_, Inl_sum1_Handler, Handler.inl_, Handler.htrigger.
  rewrite interp_state_trigger_eqit. cbn.
  rewrite !bind_ret_l, !tau_eutt.
  rewrite interp_state_ret.
  rewrite !bind_ret_l, !tau_eutt.
  rewrite !interp_state_ret; cbn.
  rewrite bind_ret_l; cbn.
  reflexivity.
Qed.

Lemma interp_asm_SetReg {E A} f r v mem reg :
  @eutt E _ _ (@rel_asm A)
       (interp_asm (trigger (SetReg r v) ;; f) mem reg)
       ((interp_asm f) mem (Maps.add r v reg)).
Proof.
  unfold interp_asm, interp_map.
  rewrite interp_bind.
  unfold trigger.
  rewrite interp_vis.
  unfold subevent, resum, ReSum_inl, resum, ReSum_id, id_. cbn.
  setoid_rewrite interp_ret.
  rewrite bind_bind.
  setoid_rewrite tau_eutt.
  setoid_rewrite bind_ret_l.
  repeat rewrite interp_state_bind.
  unfold Id_IFun.
  unfold CategoryOps.cat, Cat_Handler, Handler.cat. cbn.
  unfold inl_, Inl_sum1_Handler, Handler.inl_, Handler.htrigger.
  unfold insert.
  setoid_rewrite interp_trigger.
  repeat rewrite interp_state_trigger_eqit.  cbn.
  rewrite bind_ret_l, tau_eutt.
  setoid_rewrite interp_state_ret.
  rewrite bind_ret_l. cbn.
  reflexivity.
Qed.

Lemma interp_asm_Load {E A} f a mem reg :
  @eutt E _ _ (@rel_asm A)
       (interp_asm (val <- trigger (Load a) ;; f val) mem reg)
       ((interp_asm (f (lookup_default a 0 mem))) mem reg).
Proof.
  unfold interp_asm, interp_map.
  rewrite interp_bind.
  rewrite interp_trigger.
  unfold subevent, resum, ReSum_inr, resum, ReSum_inl, resum, ReSum_id, id_. cbn.
  repeat rewrite interp_state_bind.
  unfold Id_IFun.
  unfold CategoryOps.cat, Cat_Handler, Handler.cat. cbn.
  unfold CategoryOps.cat, Cat_Handler, Handler.cat. cbn.
  unfold inl_, Inl_sum1_Handler, Handler.inl_, Handler.htrigger.
  unfold inr_, Inr_sum1_Handler, Handler.inr_, Handler.htrigger.
  unfold lookup_def.
  repeat (setoid_rewrite interp_trigger; rewrite tau_eutt).
  repeat rewrite interp_state_trigger_eqit.
  cbn. unfold pure_state, embed, Embeddable_forall, embed, Embeddable_itree, trigger.
  do 2 rewrite interp_vis, bind_vis.
  rewrite interp_state_vis. cbn. rewrite bind_vis, interp_state_vis. cbn.
  rewrite !bind_ret_l, !tau_eutt. rewrite !interp_ret, !interp_state_ret.
  rewrite bind_ret_l; cbn.
  reflexivity.
Qed.

Lemma interp_asm_Store {E A} f a v mem reg :
  @eutt E _ _ (@rel_asm A)
       (interp_asm (trigger (Store a v) ;; f) mem reg)
       ((interp_asm f) (Maps.add a v mem) reg).
Proof.
  unfold interp_asm, interp_map.
  rewrite interp_bind.
  rewrite interp_trigger.
  unfold subevent, resum, ReSum_inr, resum, ReSum_inl, resum, ReSum_id, id_. cbn.
  repeat rewrite interp_state_bind.
  unfold Id_IFun.
  unfold CategoryOps.cat, Cat_Handler, Handler.cat. cbn.
  unfold CategoryOps.cat, Cat_Handler, Handler.cat. cbn.
  unfold inl_, Inl_sum1_Handler, Handler.inl_, Handler.htrigger.
  unfold inr_, Inr_sum1_Handler, Handler.inr_, Handler.htrigger.
  unfold insert, embed, Embeddable_forall, embed, Embeddable_itree.
  rewrite interp_trigger.
  setoid_rewrite interp_trigger.
  rewrite interp_state_trigger_eqit. cbn.
  cbn. unfold pure_state, embed, Embeddable_forall, embed, Embeddable_itree, trigger.
  rewrite bind_vis, interp_state_vis. cbn. rewrite !bind_ret_l, !tau_eutt.
  rewrite interp_state_ret, bind_ret_l; cbn.
  reflexivity.
Qed.

Lemma interp_state_iter' {E F } S (f : E ~> Monads.stateT S (itree F)) {I A}
      (t  : I -> itree E (I + A))
  : forall i, state_eq (State.interp_state f (ITree.iter t i))
                       (Basics.iter (fun i => State.interp_state f (t i)) i).
Proof.
  eapply interp_state_iter.
  intros i.
  red. reflexivity.
Qed.

(* peephole optimizations --------------------------------------------------- *)

(** A (simple) peephole optmization transforms one instruction into a
   (possibly empty) list of equivalent instructions. *)
Definition peephole_optimization := instr -> list instr.

(** We lift peephole optimizations to _asm_ pointwise through the structures. *)
Fixpoint peephole_optimize_block {lbl} (ph : peephole_optimization) (b:block lbl) : block lbl :=
  match b with
  | bbi i k => blk_append (ph i) (peephole_optimize_block ph k)
  | bbb l => bbb l
  end.

Definition peephole_optimize_bks {A B} (ph : peephole_optimization) (bs : A -> block B) :=
  fun (a:A) => peephole_optimize_block ph (bs a).

Definition peephole_optimize_asm {A B} (ph : peephole_optimization) (p : asm A B) : asm A B :=
  Build_asm A B (p.(internal)) (peephole_optimize_bks ph (p.(code))).

(* peephole correctness ----------------------------------------------------- *)

Section Correctness.

  (** A peephole optimizer is correct if it replaces an instruction with
    a semantically equivalent sequence of instructions. *)
Definition ph_correct (ph : peephole_optimization) :=
  forall E (i:instr),
    @eq_asm_denotations_EQ E unit _ (fun _ => denote_instr i) (fun _ => denote_list (ph i)).

Lemma ph_blk_append_correct {E} {HasExit : Exit -< E} :
  forall (ph : peephole_optimization) (H : ph_correct ph)
    lbl1 lbl2 b1 b2 i,
    (@eq_asm_denotations_EQ E (fin lbl1) (fin lbl2) (fun _ => denote_bk b1) (fun _ => denote_bk b2)) ->
    (@eq_asm_denotations_EQ E (fin lbl1) (fin lbl2)
                         (fun _ => denote_instr i ;; denote_bk b1)
                         (fun _ => denote_bk (blk_append (ph i) b2))).
  Proof.
    intros ph H lbl1 lbl2 b1 b2 i HP.
    unfold eq_asm_denotations_EQ.
    intros a mem1 mem2 regs1 regs2 EQ_mem EQ_reg.
    rewrite denote_blk_append.
    unfold ph_correct in H.
    unfold eq_asm_denotations_EQ in H.
    specialize H with (i:=i).
    pose proof (H E tt) as H2.
    do 2 rewrite interp_asm_bind.
    eapply eutt_clo_bind.
    apply H2; auto.
    intros.
    destruct H0 as [J1 [J2 J3]].
    destruct u1 as [? [? []]], u2 as [? [? []]]. cbn in *.
    apply HP; auto.
  Qed.

Lemma peephole_block_correct {E} {HasExit : Exit -< E} :
  forall (ph : peephole_optimization)
    (H : ph_correct ph)
    (lbl1 lbl2 : nat)
    (b : block (fin lbl2)),
    @eq_asm_denotations_EQ E (fin lbl1) (fin lbl2)
                        (fun _ => denote_bk b)
                        (fun _ => denote_bk (peephole_optimize_block ph b)).
Proof.
  intros ph H lbl1 lbl2 b.
  induction b.
  - simpl.
    unfold eq_asm_denotations_EQ.
    intros.
    eapply ph_blk_append_correct; try assumption. exact IHb. assumption.
  - unfold eq_asm_denotations_EQ.
    intros.
    destruct b; simpl.
    + unfold interp_asm.
      rewrite interp_ret.
      unfold interp_map.
      repeat rewrite interp_state_ret.
      apply eqit_Ret. constructor; auto; constructor; auto.
    + setoid_rewrite interp_asm_GetReg.
      rewrite H1.
      unfold value in *.
      remember (lookup_default r 0 regs2) as x.
      destruct x.
      repeat rewrite interp_asm_ret.
      apply eqit_Ret. constructor; auto.
      repeat rewrite interp_asm_ret.
      apply eqit_Ret. constructor; auto.
    + unfold interp_asm, interp_map.
      unfold id_, Id_Handler, Handler.id_.
      unfold exit.
      rewrite interp_vis.
      cbn. rewrite interp_state_bind.
      unfold CategoryOps.cat, Cat_Handler, Handler.cat, inr_, Inr_sum1_Handler, Handler.inr_, Handler.htrigger.
      setoid_rewrite interp_trigger.
      unfold inr_.
      rewrite interp_trigger.
      rewrite interp_state_trigger_eqit.
      rewrite interp_state_bind.
      cbn. unfold pure_state.
      rewrite bind_vis, interp_state_vis. cbn.
      repeat rewrite bind_vis.
      rewrite interp_state_bind.
      rewrite interp_state_trigger_eqit. cbn.
      rewrite !bind_vis, interp_state_vis. cbn.
      rewrite bind_vis.
      apply eqit_Vis; intros [].
Qed.

Lemma peephole_optimization_correct {E} {HasExit : Exit -< E}
  : forall A B (ph : peephole_optimization) (H : ph_correct ph),
      optimization_correct (E := E) A B (peephole_optimize_asm ph).
Proof.
  intros A B ph H.
  unfold optimization_correct.
  intros p.
  unfold eq_asm, eq_asm_denotations, denote_asm.
  intros a mem1 mem2 regs1 regs2 H1 H2.
  unfold interp_asm, interp_map.
  repeat setoid_rewrite interp_bind.
  repeat rewrite interp_state_bind.
  apply (@eutt_clo_bind _ _ _ _ _ _ rel_asm).

  { apply (@eutt_clo_bind _ _ _ _ _ _ rel_asm).
    -  unfold inr_, Inr_Kleisli, lift_ktree_.
       unfold ret, Monad_itree.
       repeat rewrite interp_ret.
       repeat rewrite interp_state_ret.
       apply eqit_Ret. constructor; auto.
    -  intros. destruct H0 as [J1 [J2 J3]].
       subst. cbn.
       unfold CategorySub.from_bif, FromBifunctor_ktree_fin.
       repeat rewrite interp_ret.
       repeat rewrite interp_state_ret.
       apply eqit_Ret.
       constructor; cbn; auto. constructor; cbn; auto.
       rewrite J3. reflexivity. }

  intros.
  destruct H0 as [J1 [J2 J3]]; subst.
  simpl in *.
  unfold denote_bks.
  unfold iter, CategorySub.Iter_sub.
  repeat rewrite interp_iter.
  unfold iter, Iter_Kleisli.
  cbn.
  assert (JJ := @interp_state_iter').
  red in JJ.
  unfold Basics.iter, MonadIter_stateT0, Basics.iter, MonadIter_itree in *.
  cbn in *.
  repeat rewrite JJ.

  eapply eutt_iter' with (RI := rel_asm); cbn; auto.
  intros j1 j2 [K1 [K2 ->]]; cbn.
  rewrite !interp_bind, !interp_state_bind, !bind_bind. (* Slow! *)

  apply (@eutt_clo_bind _ _ _ _ _ _ rel_asm);
    [|intros ? ? [? [? ->]]]; cbn.
  { refine (peephole_block_correct _ _ _ _ _ _ _ _ _ _ _ _); eauto. }

  unfold CategorySub.to_bif, ToBifunctor_ktree_fin.
  apply (@eutt_clo_bind _ _ _ _ _ _ rel_asm);
    [|intros ? ? [? [? ->]]]; cbn.
  {
    rewrite bind_ret_l.
    unfold case_, Case_sum1, Case_Kleisli, case_sum.
    unfold CategoryOps.cat, CategorySub.Cat_sub, CategoryOps.cat, Cat_Kleisli.
    unfold inl_, CategorySub.Inl_sub, inl_, Inl_Kleisli, lift_ktree_.
    unfold inr_, CategorySub.Inr_sub, inr_, Inr_Kleisli, lift_ktree_.
    unfold id_, CategorySub.Id_sub, id_, Id_Kleisli, lift_ktree_.
    cbn.
    unfold CategorySub.from_bif, FromBifunctor_ktree_fin.
    destruct split_fin_sum.
    all: rewrite !bind_ret_l, interp_ret, !interp_state_ret.
    all: apply eqit_Ret; auto; constructor; auto.
    all : constructor; auto.
  }

  rewrite interp_ret, !interp_state_ret, !bind_ret_l.
  rewrite !interp_state_ret, !bind_ret_l; cbn.
  apply eqit_Ret.
  destruct split_fin_sum; auto; constructor; auto.
  all : econstructor; auto.
  all : constructor; auto.
Qed.

(* concrete optimizations --------------------------------------------------- *)

Definition simple (i:instr) : list instr :=
  match i with
  | Imov dest (Oreg src) =>
    if Nat.eqb dest src then [] else [i]
  | _ => [i]
  end.

(* SAZ: Belongs in the utilities? (but depends on EQ_registers)
   EQ_Registers is now just an alias for eq_map, so this can be moved to MapDefaultFacts.
*)
Lemma EQ_registers_add:
  forall (r : reg) (d:value) (regs1 regs2 : registers),
    EQ_registers d regs1 regs2 ->
    EQ_registers d (alist_add r (lookup_default r d regs1) regs1) regs2.
Proof.
  intros r d regs1 regs2 H.
  unfold EQ_registers.
  unfold eq_map.
  intros.
  unfold lookup_default at 1, lookup, Map_alist.
  destruct (Nat.eq_dec k r).
  - subst. rewrite In_add_eq.
    apply H.
  - unfold lookup_default, lookup, Map_alist.
    rewrite alist_find_neq; auto.
    apply H.
Qed.

Lemma simple_correct : ph_correct simple.
Proof.
  unfold ph_correct.
  intros E i.
  unfold eq_asm_denotations_EQ.
  intros.
  destruct i; simpl; try apply interp_asm_ret_tt; auto; try reflexivity.

  destruct src.
  + simpl. rewrite !bind_ret_l.
    apply interp_asm_ret_tt; auto; try reflexivity.

  + simpl.
    destruct (Nat.eq_dec dest r).
    * subst.
      rewrite Nat.eqb_refl.
      simpl.
      rewrite interp_asm_ret.
      rewrite interp_asm_GetReg.

      unfold trigger.
      unfold interp_asm, interp_map.
      rewrite interp_vis.
      cbn.
      repeat rewrite interp_state_bind.
      unfold CategoryOps.cat, Cat_Handler, Handler.cat. simpl.
      unfold inl_, Inl_sum1_Handler, Handler.inl_, Handler.htrigger.
      unfold insert.
      unfold embed, Embeddable_itree, Embeddable_forall, inl_, embed.
      rewrite interp_trigger.
      rewrite interp_state_trigger_eqit.
      cbn.
      rewrite bind_ret_l, tau_eutt.
      rewrite interp_state_ret, bind_ret_l, interp_ret. cbn.
      rewrite tau_eutt, 2 interp_state_ret.
      apply eqit_Ret.
      constructor; auto; constructor; auto.
      cbn; auto using EQ_registers_add.
    * apply Nat.eqb_neq in n.
      rewrite n.
      apply interp_asm_ret_tt; auto.
Qed.

End Correctness.


From iris.base_logic Require Import lib.invariants.
From iris.algebra Require Import cmra auth list agree csum excl.
Require Import SegmentQueue.lib.concurrent_linked_list.infinite_array.sqsegment_impl.
Require Import SegmentQueue.lib.concurrent_linked_list.segment_spec.
From SegmentQueue.util Require Import local_updates cmra count_matching everything.

Section infinite_array_segment_proof.

Context `{heapG Σ}.

Variable segment_size: positive.
Variable pointer_shift: positive.
Variable pointer_shift_bound:
  Pos.to_nat segment_size < 2 ^ Pos.to_nat pointer_shift.

Notation cell_algebra := (csumR (agreeR unitO) (* cell is cancelled *)
                                (exclR unitO)) (* cancellation permit exists *).

Record immutableValues :=
  ImmutableValues {
      segmentId: nat;
      segmentNextLocation: loc;
      segmentPrevLocation: loc;
      segmentCleanedAndPointersLocation: loc;
      segmentDataLocation: loc;
    }.

Inductive cellState := cellAlive
                     | cellCancelled.

Canonical Structure immutableValuesO := leibnizO immutableValues.

Notation segment_algebra :=
  (prodR
     (authUR (listUR (optionUR cell_algebra))) (* Cells *)
     (optionUR (agreeR immutableValuesO) (* Immutable contents of the segment *)
  )).

Class iSegmentG Σ := ISegmentG { iarray_inG :> inG Σ segment_algebra }.
Definition iSegmentΣ : gFunctors := #[GFunctor segment_algebra].
Instance subG_iSegmentΣ : subG iSegmentΣ Σ -> iSegmentG Σ.
Proof. solve_inG. Qed.
Context `{iSegmentG Σ}.

Notation iProp := (iProp Σ).

Let segment_size_nat := Pos.to_nat segment_size.

Definition cell_algebra_from_state (state: cellState): cell_algebra :=
  if state then Cinr (Excl ()) else Cinl (to_agree ()).

Definition algebra_from_list
           (values: immutableValues)
           (state: list cellState): segment_algebra :=
  (● ((fun (v: cellState) => Some (cell_algebra_from_state v)) <$> state),
   Some (to_agree values)).

Definition cell_is_cancelled γ id :=
  own γ (◯ {[ id := Some (cell_algebra_from_state cellCancelled) ]}, ε).

Global Instance cell_is_cancelled_persistent γ id:
  Persistent (cell_is_cancelled γ id).
Proof. apply _. Qed.

Definition cell_cancellation_handle γ id :=
  own γ (◯ {[ id := Some (cell_algebra_from_state cellAlive) ]}, ε).

Theorem cell_cancellation_handle_exclusive γ id:
  cell_cancellation_handle γ id -∗ cell_cancellation_handle γ id -∗ False.
Proof.
  iIntros "H1 H2".
  iDestruct (own_valid_2 with "H1 H2") as %HValid. exfalso. move: HValid.
  rewrite -pair_op. case=> /=.
  rewrite -auth_frag_op auth_frag_valid list_singletonM_op list_singletonM_valid//.
Qed.

Theorem cell_with_handle_not_cancelled γ id:
  cell_is_cancelled γ id -∗ cell_cancellation_handle γ id -∗ False.
  iIntros "H1 H2".
  iDestruct (own_valid_2 with "H1 H2") as %HValid. exfalso. move: HValid.
  rewrite -pair_op. case=> /=.
  rewrite -auth_frag_op auth_frag_valid list_singletonM_op list_singletonM_valid//.
Qed.

Lemma auth_cancel_cell values state γ id:
  cell_cancellation_handle γ id -∗
  own γ (algebra_from_list values state) ==∗
  own γ (algebra_from_list values (<[ id := cellCancelled ]> state)) ∗
  cell_is_cancelled γ id.
Proof.
  iIntros "HHandle Hγ".
  iMod (own_update_2 with "Hγ HHandle") as "[$ $]"; last done.
  apply prod_update; simpl; last done.
  apply auth_update, list_lookup_local_update=> i.
  rewrite list_fmap_insert.
  destruct (lt_eq_lt_dec i id) as [[HLt| ->]|HGt].
  - rewrite !list_lookup_singletonM_lt; try lia.
    rewrite list_lookup_insert_ne //; last lia.
  - rewrite !list_lookup_singletonM list_lookup_fmap.
    destruct (decide (id < length state)%nat) as [HLt|HGe].
    * rewrite list_lookup_insert; last by rewrite fmap_length.
      apply lookup_lt_is_Some in HLt.
      destruct HLt as [x ->]. simpl.
      apply option_local_update, option_local_update.
      rewrite /cell_algebra_from_state.
      destruct x.
      + apply replace_local_update; [apply _|done].
      + apply local_update_valid. intros _ _.
        case; first by intros HContra; inversion HContra.
        rewrite csum_included.
        case; first done.
        by case; intros (? & ? & ? & ? & ?).
    * apply local_update_valid.
      intros _ _.
      rewrite !lookup_ge_None_2; last lia.
      2: by rewrite insert_length fmap_length; lia.
      simpl.
      case; first by intros HContra; inversion HContra.
      intros HContra. by apply included_None in HContra.
  - rewrite !list_lookup_singletonM_gt; try lia.
    rewrite list_lookup_insert_ne //; last lia.
Qed.

Instance uniqueValue_fmap E: FMap (@uniqueValue Σ E).
Proof.
  intros A B f HUnique.
  eapply UniqueValue with
      (has_value := (fun γ v => ∃ v', has_value HUnique γ v' ∗ ⌜f v' = v⌝)%I);
    try apply _.
  iIntros (γ value1 value2) "H1 H2".
  iDestruct "H1" as (values1) "[H1 %]".
  iDestruct "H2" as (values2) "[H2 %]".
  iDestruct (has_value_agrees with "H1 H2") as "<-".
  by simplify_eq.
Defined.

Theorem immutableValues_uniqueValue: @uniqueValue Σ gname immutableValues.
Proof.
  eapply UniqueValue with
      (has_value := (fun γ values => own γ (ε, Some (to_agree values)))%I);
    try apply _.
  iIntros (γ v1 v2) "H1 H2".
  iDestruct (own_valid_2 with "H1 H2") as %[_ HValid]%pair_valid.
  iPureIntro. move: HValid; simpl. rewrite -Some_op Some_valid.
  intros HAgree. apply agree_op_invL' in HAgree. by inversion HAgree.
Defined.

Definition prev_uniqueValue :=
  segmentPrevLocation <$> immutableValues_uniqueValue.

Definition next_uniqueValue :=
  segmentNextLocation <$> immutableValues_uniqueValue.

Definition cleanedAndPointers_uniqueValue :=
  segmentCleanedAndPointersLocation <$> immutableValues_uniqueValue.

Definition id_uniqueValue :=
  segmentId <$> immutableValues_uniqueValue.

Definition dataLocation_uniqueValue :=
  segmentDataLocation <$> immutableValues_uniqueValue.

Variable (N: namespace).

Variable (cell_is_owned: nat -> iProp).

Definition segment_invariant (γ: gname) (values: immutableValues): iProp :=
  [∗ list] i ∈ seq 0 segment_size_nat,
  (cell_is_owned (segmentId values * segment_size_nat + i) ∨
   (segmentDataLocation values +ₗ i) ↦ NONEV ∗ cell_cancellation_handle γ i)%I.

Definition is_node γ (node: val): iProp :=
  ∃ (ℓ: loc), ⌜node = #ℓ⌝ ∧
              ∃ (values: immutableValues),
                inv N (segment_invariant γ values) ∗
                own γ (ε, Some (to_agree values)) ∗
                inv_heap_inv ∗
                ℓ ↦□ (fun v => v = (#(segmentId values),
                                    #(segmentCleanedAndPointersLocation values),
                                    #(segmentPrevLocation values),
                                    #(segmentNextLocation values),
                                    #(segmentDataLocation values))%V).

Global Instance is_node_persistent γ node: Persistent (is_node γ node).
Proof. apply _. Qed.

Theorem getPrevLoc_spec γ node:
  {{{ is_node γ node }}}
    getPrevLoc SQSegmentListNode node
  {{{ pℓ, RET #pℓ; has_value prev_uniqueValue γ pℓ }}}.
Proof.
  iIntros (Φ) "#HNode HΦ".
  iDestruct "HNode" as (ℓ -> values) "#(HInv & HValues & #HHeapInv & HLoc)".
  wp_lam. wp_bind (! _)%E.
  iMod (inv_mapsto_acc with "HHeapInv HLoc") as (?) "(-> & Hℓ & HℓRestore)";
    first done.
  wp_load. iMod ("HℓRestore" with "Hℓ") as "_". iModIntro. wp_pures.
  iApply "HΦ". iExists _. by iFrame "HValues".
Qed.

Theorem getNextLoc_spec γ node:
  {{{ is_node γ node }}}
    getNextLoc SQSegmentListNode node
  {{{ nℓ, RET #nℓ; has_value next_uniqueValue γ nℓ }}}.
Proof.
  iIntros (Φ) "#HNode HΦ".
  iDestruct "HNode" as (ℓ -> values) "#(HInv & HValues & #HHeapInv & HLoc)".
  wp_lam. wp_bind (! _)%E.
  iMod (inv_mapsto_acc with "HHeapInv HLoc") as (?) "(-> & Hℓ & HℓRestore)";
    first done.
  wp_load. iMod ("HℓRestore" with "Hℓ") as "_". iModIntro. wp_pures.
  iApply "HΦ". iExists _. by iFrame "HValues".
Qed.

Let impl := (SQSegment segment_size pointer_shift).

Theorem getCleanedAndPointersLoc_spec γ node:
  {{{ is_node γ node }}}
    getCleanedAndPointersLoc impl node
  {{{ cℓ, RET #cℓ; has_value cleanedAndPointers_uniqueValue γ cℓ }}}.
Proof.
  iIntros (Φ) "#HNode HΦ".
  iDestruct "HNode" as (ℓ -> values) "#(HInv & HValues & #HHeapInv & HLoc)".
  wp_lam. wp_bind (! _)%E.
  iMod (inv_mapsto_acc with "HHeapInv HLoc") as (?) "(-> & Hℓ & HℓRestore)";
    first done.
  wp_load. iMod ("HℓRestore" with "Hℓ") as "_". iModIntro. wp_pures.
  iApply "HΦ". iExists _. by iFrame "HValues".
Qed.

Theorem getId_spec γ node:
  {{{ is_node γ node }}}
    getId impl node
  {{{ id, RET #id; has_value id_uniqueValue γ id }}}.
Proof.
  iIntros (Φ) "#HNode HΦ".
  iDestruct "HNode" as (ℓ -> values) "#(HInv & HValues & #HHeapInv & HLoc)".
  wp_lam. wp_bind (! _)%E.
  iMod (inv_mapsto_acc with "HHeapInv HLoc") as (?) "(-> & Hℓ & HℓRestore)";
    first done.
  wp_load. iMod ("HℓRestore" with "Hℓ") as "_". iModIntro. wp_pures.
  iApply "HΦ". iExists _. by iFrame "HValues".
Qed.

Theorem node_unboxed γ node:
  is_node γ node -∗ ⌜val_is_unboxed node⌝.
Proof. iIntros "#HNode". by iDestruct "HNode" as (ℓ ->) "_". Qed.

Theorem node_induces_id γ γ' node id id':
  has_value id_uniqueValue γ id -∗
  has_value id_uniqueValue γ' id' -∗
  is_node γ  node -∗
  is_node γ' node ==∗
  ⌜id = id'⌝.
Proof.
  iIntros "HId HId' HNode HNode'".
  iDestruct "HNode" as (ℓ -> values) "#(HInv & HValues & #HHeapInv & HLoc)".
  iDestruct "HNode'" as (ℓ' HEq values') "#(HInv' & HValues' & #HHeapInv' & HLoc')".
  iDestruct "HId" as (?) "[HId <-]". iDestruct "HId'" as (?) "[HId' <-]".
  iDestruct (has_value_agrees with "HId HValues") as "->".
  iDestruct (has_value_agrees with "HId' HValues'") as "->".
  iDestruct (own_valid_2 with "HLoc HLoc'") as %HH.
  iPureIntro. move: HH.
  simplify_eq.
  rewrite -auth_frag_op auth_frag_valid.
  rewrite gmap.singleton_op gmap.singleton_valid pair_valid.
  case=>_/=HH.
  apply (@agree_op_inv' (option val -d> PropO)) in HH.
  specialize (HH (Some (#(segmentId values),
                        #(segmentCleanedAndPointersLocation values),
                        #(segmentPrevLocation values),
                        #(segmentNextLocation values),
                        #(segmentDataLocation values)))%V).
  simpl in *. inversion HH as [HH1 _]. specialize (HH1 eq_refl).
  destruct values; destruct values'; simpl in *. by simplify_eq.
Qed.

Instance cellStateDecidable (v v': cellState): Decision (v = v').
Proof. case v; case v'; by constructor. Defined.

Definition segment_content γ alive_slots: iProp :=
  ∃ values state,
    ⌜count_matching (fun v => v = cellAlive) state = alive_slots ∧
    length state = segment_size_nat⌝ ∧
    own γ (algebra_from_list values state).

Theorem cancel_cell γ id alive_slots:
  cell_cancellation_handle γ id -∗
  segment_content γ alive_slots ==∗
  cell_is_cancelled γ id ∗ ∃ alive_slots',
      ⌜alive_slots = S alive_slots'⌝ ∧ segment_content γ alive_slots'.
Proof.
  iIntros "HHandle HContent".
  iDestruct "HContent" as (values state [HCount HLength]) "Hγ".
  iAssert (⌜state !! id = Some cellAlive⌝)%I as %HLookup.
  {
    rewrite /algebra_from_list.
    iDestruct (own_valid_2 with "Hγ HHandle") as
        %[[(seg & HLookup & HIncluded)%list_singletonM_included
                                      _]%auth_both_valid _]%pair_valid.
    iPureIntro.
    rewrite map_lookup in HLookup.
    destruct (state !! id) as [state'|] eqn:HLookup'; last done.
    simpl in *. simplify_eq.
    destruct state'; first done.
    move: HIncluded=> /=. rewrite Some_included. case.
      + intros HContra. inversion HContra.
      + rewrite csum_included. case; first done.
        case; by intros (? & ? & ? & ? & ?).
  }
  destruct alive_slots as [|alive_slots'].
  { exfalso. move: HCount HLookup. clear. move: id.
    induction state as [|x xs]; first done. simpl.
    destruct x; simpl; first done. by case. }
  iMod (auth_cancel_cell with "HHandle Hγ") as "[Hγ $]".
  iExists alive_slots'. iSplitR; first done.
  iExists _, _. iFrame "Hγ". iPureIntro.
  rewrite insert_length; split; last done.
  rewrite list_insert_alter. erewrite count_matching_alter; last done.
  rewrite HCount /=. lia.
Qed.

Theorem newSegment_spec (id: nat) (prev: val) (pointers: nat):
  {{{ inv_heap_inv }}}
    newSegment impl #id prev #pointers
    {{{ γ node pℓ nℓ cℓ, RET node;
        is_node γ node
        ∗ segment_content γ (maxSlots impl)
        ∗ has_value id_uniqueValue γ id
        ∗ has_value cleanedAndPointers_uniqueValue γ cℓ
        ∗ has_value prev_uniqueValue γ pℓ
        ∗ has_value next_uniqueValue γ nℓ
        ∗ pℓ ↦ prev ∗ nℓ ↦ NONEV ∗ cℓ ↦ #(pointers ≪ pointerShift impl)
    }}}.
Proof.
  iIntros (Φ) "#HInv HΦ". wp_lam. wp_pures.
  wp_alloc dℓ as "Hdℓ"; first lia. wp_alloc nℓ as "Hnℓ".
  wp_alloc pℓ as "Hpℓ". wp_alloc cℓ as "Hcℓ".
  rewrite -wp_fupd.
  wp_alloc ℓ as "Hℓ".
  pose values := {|
      segmentId := id;
      segmentNextLocation := nℓ;
      segmentPrevLocation := pℓ;
      segmentCleanedAndPointersLocation := cℓ;
      segmentDataLocation := dℓ;
    |}.
  iMod (own_alloc (
            algebra_from_list values (replicate segment_size_nat cellAlive) ⋅
            (ε, Some (to_agree values)) ⋅
            (◯ replicate segment_size_nat
               (Some (cell_algebra_from_state cellAlive)), ε)))
    as (γ) "[[H● #HValues] HCancellation]".
  {
    rewrite /algebra_from_list -!pair_op /= pair_valid.
    split.
    - apply auth_both_valid. rewrite fmap_replicate.
      split; first done.
      apply list_lookup_valid=> i.
      destruct (_ !! i) eqn:E; last done.
      apply lookup_replicate in E. by destruct E as [-> _].
    - apply Some_valid. rewrite agree_idemp. done.
  }
  iApply "HΦ".
  replace (Z.pos pointer_shift) with (Z.of_nat (pointerShift impl));
    last by rewrite /impl /=; lia.
  iFrame "Hpℓ Hnℓ Hcℓ".
  iSplitL "Hℓ HCancellation Hdℓ"; last iSplitL "H●".
  - iExists _. iSplitR; first done. iExists values.
    iFrame "HInv HValues".
    iMod (make_inv_mapsto with "HInv Hℓ") as "Hℓ'"; first done;
      last iDestruct (inv_mapsto_own_inv with "Hℓ'") as "$"; first done.
    iMod (inv_alloc N _ (segment_invariant γ values) with "[-]") as "$";
      last done.
    rewrite /segment_invariant /segment_size_nat Z2Nat.inj_pos /array.
    iAssert ([∗ list] i ∈ seq 0 (Pos.to_nat segment_size),
             cell_cancellation_handle γ i)%I
      with "[HCancellation]" as "HCancellation".
    {
      rewrite /cell_cancellation_handle.
      iClear "HInv HValues".
      remember (Pos.to_nat segment_size) as n. clear.
      remember (Some _) as state. clear.
      replace (replicate _ _) with (replicate 0 ε ++ replicate n state);
        last done.
      remember 0 as start. clear.
      iInduction n as [|n'] "IH" forall (start); first done.
      simpl.
      assert ((replicate start ε ++ state :: replicate n' state)
                ≡ (replicate (S start) ε ++ replicate n' state) ⋅
                {[ start := state ]}) as ->.
      {
        replace (S start) with (start + 1) by lia.
        rewrite replicate_plus /= -app_assoc /=.
        apply list_equiv_lookup=> i. rewrite list_lookup_op.
        destruct (lt_eq_lt_dec i start) as [[HLt| ->]|HGt].
        - rewrite list_lookup_singletonM_lt; last lia.
          rewrite !lookup_app_l; try rewrite replicate_length //.
          by rewrite lookup_replicate_2; last lia.
        - rewrite list_lookup_singletonM.
          rewrite !lookup_app_r; try rewrite replicate_length //.
          rewrite Nat.sub_diag /=. rewrite -Some_op ucmra_unit_left_id //.
        - rewrite list_lookup_singletonM_gt; last lia.
          rewrite !lookup_app_r replicate_length; try lia.
          rewrite ucmra_unit_right_id.
          destruct (i - start) eqn:E; first lia. done.
      }
      rewrite auth_frag_op pair_op_1 own_op.
      iDestruct "HCancellation" as "[HCancellation $]".
      iApply ("IH" with "HCancellation").
    }
    assert (([∗ list] i ↦ v ∈ seq 0 (Pos.to_nat segment_size),
             (dℓ +ₗ i) ↦ InjLV #())%I ≡
            ([∗ list] i↦v ∈ replicate (Pos.to_nat segment_size) (InjLV #()),
              (dℓ +ₗ i) ↦ v)%I) as <-.
    {
      apply big_opL_gen_proper_2. done. by apply _.
      intros k.
      destruct (seq _ _ !! k) eqn:E.
      - apply lookup_seq in E. destruct E as [-> Hk].
        by rewrite lookup_replicate_2; last lia.
      - apply lookup_ge_None in E. rewrite seq_length in E.
        rewrite lookup_ge_None_2 // replicate_length. lia.
    }
    iCombine "Hdℓ" "HCancellation" as "H".
    rewrite -big_sepL_sep.
    iApply (big_sepL_mono with "H").
    intros ? ? HEq. apply lookup_seq in HEq. destruct HEq as [-> Hk].
    iIntros "[Hdℓ HCancHandle]". iRight. iFrame.
  - rewrite /segment_content. iExists values, _. iFrame "H●".
    iPureIntro. rewrite /impl /segment_size_nat /=.
    rewrite replicate_length; split; last done.
    remember (Pos.to_nat _) as listLen. clear.
    induction listLen; first done. rewrite /= IHlistLen //.
  - repeat iSplitR; iExists _; iFrame "HValues"; done.
Qed.

Lemma max_slots_bound: (0 < maxSlots impl < 2 ^ pointerShift impl)%nat.
Proof. rewrite /impl /=. split; first lia; last done. Qed.

End infinite_array_segment_proof.

Section segment_specs.

Variable (segment_size pointer_shift: positive).
Variable (limit: Pos.to_nat segment_size < 2 ^ Pos.to_nat pointer_shift).
Variable (N: namespace).

Definition node_linkedListNode `{!heapG Σ} `{!iSegmentG Σ}:
  linkedListNodeSpec Σ (base (SQSegment segment_size pointer_shift)) :=
  {| segment_spec.getPrevLoc_spec := getPrevLoc_spec segment_size N;
     segment_spec.getNextLoc_spec := getNextLoc_spec segment_size N;
     segment_spec.linkedListNode_unboxed := node_unboxed segment_size N;
     segment_spec.is_linkedListNode_persistent :=
       is_node_persistent segment_size N;
  |}.

Canonical Structure node_segment `{!heapG Σ}
          `{!iSegmentG Σ}: segmentSpec Σ (SQSegment segment_size pointer_shift)
  := {|
  segment_spec.linkedListNode_base := node_linkedListNode;
  segment_spec.getId_spec :=
    getId_spec segment_size pointer_shift N;
  segment_spec.getCleanedAndPointersLoc_spec :=
    getCleanedAndPointersLoc_spec segment_size pointer_shift N;
  segment_spec.newSegment_spec :=
    newSegment_spec segment_size pointer_shift N;
  segment_spec.max_slots_bound :=
    max_slots_bound segment_size pointer_shift limit;
  segment_spec.node_induces_id :=
    node_induces_id segment_size N;
  |}.

End segment_specs.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D E Eprime T Eprimeprime Cprime Dprime R Y : Universe, ((wd_ C D /\ (wd_ A B /\ (wd_ A C /\ (wd_ A D /\ (wd_ Eprime A /\ (wd_ A T /\ (wd_ Eprimeprime T /\ (wd_ D Eprimeprime /\ (wd_ C Eprimeprime /\ (wd_ A Eprimeprime /\ (wd_ Dprime B /\ (wd_ Cprime B /\ (wd_ A Y /\ (wd_ A R /\ (wd_ R Cprime /\ (wd_ Cprime Dprime /\ (wd_ Eprimeprime B /\ (wd_ B C /\ (wd_ B D /\ (wd_ D Dprime /\ (wd_ C Cprime /\ (wd_ A Dprime /\ (wd_ A Cprime /\ (wd_ R Dprime /\ (wd_ A E /\ (wd_ Cprime D /\ (wd_ D Eprime /\ (wd_ Dprime C /\ (col_ C D E /\ (col_ T A B /\ (col_ T C D /\ (col_ B D Dprime /\ (col_ B C Cprime /\ (col_ D Eprimeprime C /\ (col_ R Cprime Dprime /\ (col_ A Eprimeprime Eprime /\ (col_ A Y R /\ (col_ A Y A /\ (col_ A Eprimeprime R /\ col_ A R A))))))))))))))))))))))))))))))))))))))) -> col_ A Y Eprimeprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall P Q A B C Aprime Cprime T BB : Universe, ((wd_ P Q /\ (wd_ P Aprime /\ (wd_ P B /\ (wd_ P Cprime /\ (wd_ A Aprime /\ (wd_ A C /\ (wd_ A B /\ (wd_ C Cprime /\ (wd_ Aprime Cprime /\ (wd_ Cprime T /\ (wd_ T B /\ (wd_ Cprime B /\ (wd_ Aprime T /\ (wd_ Aprime B /\ (wd_ Q A /\ (wd_ P A /\ (wd_ T P /\ (wd_ C P /\ (wd_ T A /\ (wd_ Cprime A /\ (wd_ T C /\ (wd_ B C /\ (wd_ Q T /\ (col_ P Q Aprime /\ (col_ P Q B /\ (col_ P Q Cprime /\ (col_ BB T B /\ (col_ Aprime BB Cprime /\ col_ A B C)))))))))))))))))))))))))))) -> col_ Aprime Cprime B)).
Proof.
  time tac.
Qed.

End FOFProblem.


(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
(* *********************************************************************)
(*                                                                     *)
(*              Layers of PM: PQueueIntro                              *)
(*                                                                     *)
(*          Provide abstraction of thread queue                        *)
(*                                                                     *)
(*          Ronghui Gu <ronghui.gu@yale.edu>                           *)
(*          Yu Guo <yu.guo@yale.edu>                                   *)
(*                                                                     *)
(*          Yale Flint Group                                           *)
(*                                                                     *)
(* *********************************************************************)

(** This file defines the abstract data and the primitives for the PQueueIntro layer,
which will introduce abstraction of kernel context*)
Require Import Coqlib.
Require Import Maps.
Require Import ASTExtra.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import Memory.
Require Import Events.
Require Import Stacklayout.
Require Import Globalenvs.
Require Import AsmX.
Require Import Smallstep.
Require Import AuxStateDataType.
Require Import Constant.
Require Import GlobIdent.
Require Import FlatMemory.
Require Import CommonTactic.
Require Import AuxLemma.
Require Import RealParams.
Require Import PrimSemantics.
Require Import LAsm.
Require Import LoadStoreSem2.
Require Import XOmega.

Require Import liblayers.logic.PTreeModules.
Require Import liblayers.logic.LayerLogicImpl.
Require Import liblayers.compat.CompatLayers.
Require Import liblayers.compat.CompatGenSem.

Require Import CalRealPTPool.
Require Import CalRealPT.
Require Import CalRealIDPDE.
Require Import CalRealInitPTE.
Require Import CalRealSMSPool.
Require Import CalRealProcModule.

Require Import INVLemmaMemory.
Require Import INVLemmaThread.

Require Import AbstractDataType.

Require Export PThreadInit.

(** * Abstract Data and Primitives at this layer*)

Section WITHMEM.

  Local Open Scope Z_scope.

  Context `{real_params: RealParams}.

  (** **Definition of the raw data at MPTBit layer*)
  (*Record RData :=
    mkRData {
        HP: flatmem; (**r we model the memory from 1G to 3G as heap*)
        ti: trapinfo; (**r abstract of CR2, stores the address where page fault happens*)
        pe: bool; (**r abstract of CR0, indicates whether the paging is enabled or not*)
        ikern: bool; (**r pure logic flag, shows whether it's in kernel mode or not*)
        ihost: bool; (**r logic flag, shows whether it's in the host mode or not*)
        AT: ATable; (**r allocation table*)
        nps: Z; (**r number of the pages*)
        PT: Z; (**r the current page table index*)
        ptpool: PTPool; (**r page table pool*)
        ipt: bool; (**r pure logic flag, shows whether it's using the kernel's page table*)
        pb : PTBitMap; (**r [page table bit map], indicating which page table has been used*)

        kctxt: KContextPool; (**r kernel context pool*)
        tcb: TCBPool; (*r thread control blocks pool*)
        tdq: TDQueuePool (**r thread queue pool*)
      }.*)

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

  (** * Proofs that the primitives satisfies the invariants at this layer *)
  Section INV.

    Global Instance set_head_inv: PreservesInvariants set_head_spec.
    Proof.
      preserves_invariants_simpl low_level_invariant high_level_invariant; auto 2.
    Qed.

    Global Instance set_tail_inv: PreservesInvariants set_tail_spec.
    Proof.
      preserves_invariants_simpl low_level_invariant high_level_invariant; auto 2.
    Qed.

    Global Instance tdq_init_inv: PreservesInvariants tdq_init_spec.
    Proof.
      preserves_invariants_simpl low_level_invariant high_level_invariant; auto 2.
    Qed.

  End INV.

  (** * Layer Definition *)
  Definition pqueueintro_fresh : compatlayer (cdata RData) :=
    get_head ↦ gensem get_head_spec
             ⊕ get_tail ↦ gensem get_tail_spec
             ⊕ set_head ↦ gensem set_head_spec
             ⊕ set_tail ↦ gensem set_tail_spec
             ⊕ tdq_init ↦ gensem tdq_init_spec.

  Definition pqueueintro_passthrough : compatlayer (cdata RData) :=
    fload ↦ gensem fload_spec
          ⊕ fstore ↦ gensem fstore_spec
          ⊕ flatmem_copy ↦ gensem flatmem_copy_spec
          ⊕ vmxinfo_get ↦ gensem vmxinfo_get_spec
          ⊕ device_output ↦ gensem device_output_spec
          ⊕ pfree ↦ gensem pfree_spec
          ⊕ set_pt ↦ gensem setPT_spec
          ⊕ pt_read ↦ gensem ptRead_spec
          ⊕ pt_resv ↦ gensem ptResv_spec
          ⊕ kctxt_new ↦ dnew_compatsem ObjThread.kctxt_new_spec
          (*⊕ pt_free ↦ gensem pt_free_spec*)
          ⊕ shared_mem_status ↦ gensem shared_mem_status_spec
          ⊕ offer_shared_mem ↦ gensem offer_shared_mem_spec
          ⊕ get_state ↦ gensem get_state_spec
          ⊕ get_prev ↦ gensem get_prev_spec
          ⊕ get_next ↦ gensem get_next_spec
          ⊕ set_state ↦ gensem set_state_spec
          ⊕ set_prev ↦ gensem set_prev_spec
          ⊕ set_next ↦ gensem set_next_spec
          ⊕ pt_in ↦ primcall_general_compatsem' ptin_spec (prim_ident:= pt_in)
          ⊕ pt_out ↦ primcall_general_compatsem' ptout_spec (prim_ident:= pt_out)
          ⊕ clear_cr2 ↦ gensem clearCR2_spec
          ⊕ container_get_nchildren ↦ gensem container_get_nchildren_spec
          ⊕ container_get_quota ↦ gensem container_get_quota_spec
          ⊕ container_get_usage ↦ gensem container_get_usage_spec
          ⊕ container_can_consume ↦ gensem container_can_consume_spec
          ⊕ container_alloc ↦ gensem alloc_spec
          ⊕ trap_in ↦ primcall_general_compatsem trapin_spec
          ⊕ trap_out ↦ primcall_general_compatsem trapout_spec
          ⊕ host_in ↦ primcall_general_compatsem hostin_spec
          ⊕ host_out ↦ primcall_general_compatsem hostout_spec
          ⊕ trap_get ↦ primcall_trap_info_get_compatsem trap_info_get_spec
          ⊕ trap_set ↦ primcall_trap_info_ret_compatsem trap_info_ret_spec
          ⊕ kctxt_switch ↦ primcall_kctxt_switch_compatsem kctxt_switch_spec
          ⊕ accessors ↦ {| exec_load := (@exec_loadex _ _ Hmwd);
                           exec_store := (@exec_storeex _ _ Hmwd) |}
          ⊕ thread_init ↦ gensem thread_init_spec.

  Definition pqueueintro : compatlayer (cdata RData) := pqueueintro_fresh ⊕ pqueueintro_passthrough.

  (*Definition pqueueintro_impl : compatlayer (cdata RData) :=
    thread_init ↦ gensem thread_init_spec
      ⊕ tdq_init ↦ gensem tdq_init_spec
      ⊕ set_prev ↦ gensem set_prev_spec
      ⊕ set_next ↦ gensem set_next_spec
      ⊕ get_head ↦ gensem get_head_spec
      ⊕ get_tail ↦ gensem get_tail_spec
      ⊕ get_prev ↦ gensem get_prev_spec
      ⊕ get_next ↦ gensem get_next_spec
      ⊕ set_head ↦ gensem set_head_spec
      ⊕ set_tail ↦ gensem set_tail_spec.

  Definition pqueueintro_rest : compatlayer (cdata RData) :=
    palloc ↦ gensem palloc_spec
      ⊕ pfree ↦ gensem pfree_spec
      ⊕ set_pt ↦ gensem setPT_spec
      ⊕ pt_read ↦ gensem ptRead_spec
      ⊕ pt_resv ↦ gensem ptResv_spec
      ⊕ pt_in ↦ primcall_general_compatsem' (prim_generic:= ptin_spec) (prim_ident:= pt_in)
      ⊕ pt_out ↦ primcall_general_compatsem' (prim_generic:= ptout_spec) (prim_ident:= pt_out)
      ⊕ trap_in ↦ primcall_general_compatsem (prim_generic:= trapin_spec)
      ⊕ trap_out ↦ primcall_general_compatsem (prim_generic:= trapout_spec)
      ⊕ host_in ↦ primcall_general_compatsem (prim_generic:= hostin_spec)
      ⊕ host_out ↦ primcall_general_compatsem (prim_generic:= hostout_spec)
      ⊕ trap_get ↦ primcall_trap_info_get_compatsem (trap_info_get:= trap_info_get_spec)
      ⊕ trap_set ↦ primcall_trap_info_ret_compatsem (trap_info_ret:= trap_info_ret_spec)
      ⊕ kctxt_switch ↦ primcall_kctxt_switch_compatsem (kctxt_switch:= kctxt_switch_spec)
      ⊕ kctxt_new ↦ dnew_compatsem (dnew := kctxt_new_spec)
      ⊕ get_state ↦ gensem get_state_spec
      ⊕ set_state ↦ gensem set_state_spec
      ⊕ thread_free ↦ gensem thread_free_spec
      ⊕ accessors ↦ {| exec_load := @exec_loadex; exec_store := @exec_storeex |}.

  Lemma pqueueintro_impl_eq : pqueueintro ≡ pqueueintro_impl ⊕ pqueueintro_rest.
  Proof. reflexivity. Qed.

  Definition semantics := LAsm.Lsemantics pqueueintro.*)

End WITHMEM.

Section WITHPARAM.

  Context `{real_params: RealParams}.

  Local Open Scope Z_scope.

  Section Impl.

    (** primitve: enqueue*)
    Function enqueue_spec (n i: Z) (adt: RData): option RData :=
      match (ikern adt, pg adt, ihost adt, ipt adt) with
        | (true, true, true, true) =>
          if Queue_arg n i then
            match (ZMap.get n (tdq adt), ZMap.get i (tcb adt))  with
              | (TDQValid h t, TCBValid st _ _) =>
                if zeq t num_proc then
                  Some adt {tcb: ZMap.set i (TCBValid st num_proc num_proc) (tcb adt)}
                       {tdq: ZMap.set n (TDQValid i i) (tdq adt)}
                else
                  if zle_lt 0 t num_proc then
                    match (ZMap.get t (tcb adt)) with
                      | TCBValid st' prev' _ =>
                        let tcb':= ZMap.set t (TCBValid st' prev' i) (tcb adt) in
                        Some adt {tcb: ZMap.set i (TCBValid st t num_proc) tcb'}
                             {tdq: ZMap.set n (TDQValid h i) (tdq adt)}
                      | _ => None
                    end
                  else None
              | _ => None
            end
          else None
        | _ => None
      end.

    (** primitve: dequeue*)
    Function dequeue_spec (n: Z) (adt: RData): option (RData* Z) :=
      match (ikern adt, pg adt, ihost adt, ipt adt) with
        | (true, true, true, true) =>
          if zle_le 0 n num_chan then
              match (ZMap.get n (tdq adt)) with
                | TDQValid h t =>
                  if zeq h num_proc then
                    Some (adt, num_proc)
                  else
                    if zle_lt 0 h num_proc then
                      match (ZMap.get h (tcb adt)) with
                        | TCBValid st _ next =>
                          if zeq next num_proc then
                            Some (adt {tdq: ZMap.set n (TDQValid num_proc num_proc) (tdq adt)}, h)
                            else
                              match (ZMap.get next (tcb adt)) with
                                | TCBValid st' _ next' =>
                                  Some (adt {tcb: ZMap.set next (TCBValid st' num_proc next') (tcb adt)}
                                            {tdq: ZMap.set n (TDQValid next t) (tdq adt)} , h)
                                | _ => None
                              end
                        | _ => None
                      end
                    else None
                | _ => None
              end
          else None
        | _ => None
      end.

    (** primitive: initialize the allocation table, set up the paging mechanism, and initialize the page table pool*)
    Function tdqueue_init_spec (mbi_adr:Z) (abd: RData): option RData :=
      match thread_init_spec mbi_adr abd  with
        | Some adt =>
          Some adt {tdq: real_tdq (tdq adt)}
        | _ => None
      end.

  End Impl.

End WITHPARAM.


(* Written by Sosuke Moriguchi (chiguri), Kwansei Gakuin University *)

(** * Functor from Network Topology with Protocol Setting to a CCN protocol on the network complying content managements. *)

Require Import List.
Import ListNotations.

Require CCNTopology.
Require CCNContentManagement.

Module CCN_Protocol_CM (N : CCNContentManagement.CCN_Content_Management).
Import N.
Export OldProtocol.
Import Topology.

(** Exists ForwardInterest or not *)
Fixpoint In_ForwardInterest (v : Node) (c : Content_Name) (es : list Event) : bool :=
match es with
| nil => false
| ForwardInterest v' c' :: es' =>
    match Node_eq_dec v v' with
    | left _ => match Content_Name_eq_dec c c' with
                | left _ => true
                | right _ => In_ForwardInterest v c es'
                end
    | right _ => In_ForwardInterest v c es'
    end
| StoreData v' c' _ :: es' =>
    match Node_eq_dec v v' with
    | left _ => match Content_Name_eq_dec c c' with
                | left _ => false
                | right _ => In_ForwardInterest v c es'
                end
    | right _ => In_ForwardInterest v c es'
    end
| _ :: es' => In_ForwardInterest v c es'
end.

(** Exists Request or not *)
Fixpoint In_Request (v : Node) (c : Content_Name) (es : list Event) : bool :=
match es with
| nil => false
| Request v' c' :: es' =>
    match Node_eq_dec v v' with
    | left _ => match Content_Name_eq_dec c c' with
                | left _ => true
                | right _ => In_Request v c es'
                end
    | right _ => In_Request v c es'
    end
| StoreData v' c' _ :: es' =>
    match Node_eq_dec v v' with
    | left _ => match Content_Name_eq_dec c c' with
                | left _ => false
                | right _ => In_Request v c es'
                end
    | right _ => In_Request v c es'
    end
| _ :: es' => In_Request v c es'
end.

(** Definition of behaviors of the CCN protocol *)
Inductive CCNprotocol : list Event -> list Packet -> Prop :=
| ccn_init : CCNprotocol nil nil
| ccn_request : forall (v : Node) (c : Content_Name) (es : list Event) (ps ps' : list Packet),
   CCNprotocol es ps ->
    CMF v c es = None ->
    ps' = Broadcast_Interest v c ++ ps ->
    CCNprotocol (Request v c :: es) ps'
| ccn_forward_interest : forall (v v' : Node) (c : Content_Name) (es : list Event) (ps1 ps2 ps' : list Packet),
   CCNprotocol es (ps1 ++ Interest v v' c :: ps2) ->
    CMF v' c es = None ->
    PIT_list v' c es = nil ->
    FIB_list v' c <> nil ->
    ps' = FIB_Interest v' c ++ ps1 ++ ps2 ->
    CCNprotocol (ForwardInterest v' c :: AddPIT v' v c :: es) ps'
| ccn_add_pit : forall (v v' : Node) (c : Content_Name) (es : list Event) (ps1 ps2 ps' : list Packet),
   CCNprotocol es (ps1 ++ Interest v v' c :: ps2) ->
    CMF v' c es = None ->
    PIT_list v' c es <> nil ->
    ~ In v (PIT_list v' c es) ->
    FIB_list v' c <> nil ->
    ps' = ps1 ++ ps2 ->
    CCNprotocol (AddPIT v' v c :: es) ps'
| ccn_drop_interest_fib : forall (v v' : Node) (c : Content_Name) (es : list Event) (ps1 ps2 ps' : list Packet),
   CCNprotocol es (ps1 ++ Interest v v' c :: ps2) ->
    CMF v' c es = None ->
    FIB_list v' c = nil ->
    ps' = ps1 ++ ps2 ->
    CCNprotocol es ps'
| ccn_drop_interest_pit : forall (v v' : Node) (c : Content_Name) (es : list Event) (ps1 ps2 ps' : list Packet),
   CCNprotocol es (ps1 ++ Interest v v' c :: ps2) ->
    CMF v' c es = None ->
    In v (PIT_list v' c es) ->
    ps' = ps1 ++ ps2 ->
    CCNprotocol es ps'
| ccn_reply_data : forall (v v' : Node) (c : Content_Name) (C : Content c) (es : list Event) (ps1 ps2 ps' : list Packet),
   CCNprotocol es (ps1 ++ Interest v v' c :: ps2) ->
    CMF v' c es = Some C ->
    ps' = Data v' v c C :: ps1 ++ ps2 ->
    CCNprotocol (ReplyData v' c :: es) ps'
| ccn_store_data : forall (v v' : Node) (c : Content_Name) (C : Content c) (es : list Event) (ps1 ps2 ps' : list Packet),
   CCNprotocol es (ps1 ++ Data v v' c C :: ps2) ->
    CMF v' c es = None ->
    In_Request v' c es = true ->
    PIT_list v' c es = nil ->
    ps' = ps1 ++ ps2 ->
    CCNprotocol (StoreData v' c C :: es) ps'
| ccn_forward_data : forall (v v' : Node) (c : Content_Name) (C : Content c) (es : list Event) (ps1 ps2 ps' : list Packet),
   CCNprotocol es (ps1 ++ Data v v' c C :: ps2) ->
    CMF v' c es = None ->
    In_Request v' c es = false ->
    PIT_list v' c es <> nil ->
    ps' = (PIT_Data v' c C es) ++ ps1 ++ ps2 ->
    CCNprotocol (StoreData v' c C :: ForwardData v' c :: es) ps'
| ccn_store_forward : forall (v v' : Node) (c : Content_Name) (C : Content c) (es : list Event) (ps1 ps2 ps' : list Packet),
   CCNprotocol es (ps1 ++ Data v v' c C :: ps2) ->
    CMF v' c es = None ->
    In_Request v' c es = true ->
    PIT_list v' c es <> nil ->
    ps' = (PIT_Data v' c C es) ++ ps1 ++ ps2 ->
    CCNprotocol (StoreData v' c C :: ForwardData v' c :: es) ps'
| ccn_drop_data : forall (v v' : Node) (c : Content_Name) (C : Content c) (es : list Event) (ps1 ps2 ps' : list Packet),
   CCNprotocol es (ps1 ++ Data v v' c C :: ps2) ->
    In_Request v' c es = false ->
    PIT_list v' c es = nil ->
    ps' = ps1 ++ ps2 ->
    CCNprotocol es ps'.

End CCN_Protocol_CM.


From Mtac2 Require Import Base Datatypes List MTele MTeleMatch MTeleMatchDef MFixDef Sorts tactics.Tactics.
Require Import Strings.String.
Import Sorts.
Import Mtac2.lib.List.ListNotations.
Import ProdNotations.
Import Tactics.T.
Import M.
Import M.notations.

Set Universe Polymorphism.
Unset Universe Minimization ToSet.

Local Inductive msigT {A} (P : A -> Type) : Type := | mexistT x : P x -> msigT P.
Local Notation "'{$'  x .. y  &  P }" := (msigT (fun x => .. (msigT (fun y => P)) .. )) (x binder, y binder).
Local Definition mprojT1 {A} {P} : @msigT A P -> A := fun '(mexistT _ x _) => x.
Local Definition mprojT2 {A} {P} : forall s : @msigT A P, P (mprojT1 s) := fun '(mexistT _ _ p) => p.

Local Inductive TTele : Type :=
| ttbase (X : Type) : TTele
| tttele {X} : (X -> TTele) -> TTele.
Fixpoint TTele_ty (M : Type -> Type) t :=
  match t with
  | ttbase X => M X
  | tttele F => forall x, TTele_ty M (F x)
  end.

Local Fixpoint TTele_bind {X} {t} : (X -> TTele_ty M t) -> (TTele_ty M.t t) :=
  match t with
  | ttbase X => M.bind (M.evar _)
  | tttele F => fun f (t : _) => @TTele_bind X (F t) (fun x : X => f x t)
  end
.

Local Fixpoint func_of (l : mlist Prop) :=
  match l with
  | mnil => True
  | mcons T l => prod T (func_of l)
end.

Local Notation "x -*> y" := (prod (func_of x) y) (only parsing, at level 91).

Local Notation tty := (TTele_ty (fun T => msigT (fun l => M (l -*> T)))).

Local Fixpoint TTele_bind' {X : Prop} (x : X) {t} : (TTele_ty (fun T => msigT (fun l => X -> M (l -*> T))) t) -> (tty t) :=
  match t with
  | ttbase B => fun '(mexistT _ l f) => mexistT _ (X :m: l) (
                  H <- M.evar X;
                  '(goals, R) <- f H;
                  M.ret ((H,goals), R))
  | tttele F => fun f t =>
                  TTele_bind' x (f t)
  end
.

Definition lift_lemma : forall (A : Prop), A ->
      M (msigT tty) :=
  let m := (mTele (fun (A : Prop) => (mTele (fun (a:A) => mBase)))) in
  @mfix' m
         (fun A (a:A) => msigT tty)
        (fun rec (A : Prop) =>
           let m (A : Prop) := mTele (fun a:A => mBase) in
           mtmmatch'
             _ m (fun A a => msigT tty) A
             [m:
              (mtptele (fun B:Prop => mtptele (fun (C:Prop) => (mtpbase ( m:=fun A:Prop => A -> M _)) _ (
              fun (f : B -> C) =>
                M.nu (FreshFrom A) mNone (fun b : B =>
                               '(mexistT _ t X) <- rec C (f b);
                               match t as t return tty t -> M (_) with
                               | tttele _ =>
                                 fun _ =>
                                   M.failwith "Lemma to be lifted has dependent quantifiers after non-dependent ones. This is not supported."
                               | ttbase P => fun f =>
                                               let '(mexistT _ l f) := f in
                                               f' <- M.abs_fun b f;
                                               f' <- M.coerce f';
                                               let T' := reduce (RedWhd RedAll)
                                                                (TTele_bind' b (t0:=ttbase _) (mexistT _ l f')) in
                                          M.ret (mexistT tty (ttbase P) T')
                               end X
                     )
              ) UniMatchNoRed)))%mtpattern
             |
             (mtptele (fun B:Type => mtptele (fun (C:B -> Prop) => (mtpbase ( m:=fun A:Prop => A -> M _)) _ (
              fun (f : forall b:B, C b) =>
                M.nu (FreshFrom A) mNone (fun b : B =>
                               '(mexistT _ t X) <- rec _ (f b);
                               t' <- M.abs_fun b t;
                               X <- M.coerce X;
                               X' <- M.abs_fun (P:=fun b => tty (t' b)) b X;
                               M.ret (mexistT tty (tttele t') (fun x => X' x))
                     )
              ) UniMatchNoRed)))%mtpattern
              |
              (mtpbase ( m:=fun A:Prop => A -> M _) A
                       (fun a:A =>
                          M.ret (mexistT tty (ttbase A) (mexistT _ mnil (M.ret (I,a))))
                       )
                       UniCoq
              )%mtpattern
             ]%with_mtpattern
        )
.

Local Fixpoint TTele_App {P1} {t} (P2 : forall T (H : P1 T), Type) : TTele_ty P1 t -> Type :=
  match t with
  | ttbase P => fun x => P2 _ x
  | tttele F => fun g => forall x, TTele_App P2 (g x)
  end.

Local Fixpoint TTele_app {P1} {t} P2 (f : forall T PT, P2 T PT) : forall tt, TTele_App (P1:=P1) (t:=t) P2 tt :=
match t with
| ttbase T => fun tt : P1 T => f _ _
| tttele F => fun (tt : forall t, TTele_ty P1 (F t)) t => @TTele_app _ (F t) _ f (tt t)
end.

Definition do_def n {A:Prop} (a:A) :=
  '(mexistT _ t f) <- lift_lemma A (a);
  (* let f := reduce (RedStrong [rl: RedBeta; RedZeta; RedFix; RedMatch; RedDeltaOnly [rl: Dyn (@M.type_of); Dyn (@TTele_ty)] ]) (f) in *)
  let x := reduce (RedStrong [rl: RedFix; RedMatch; RedBeta; RedDeltaOnly [rl: Dyn (@TTele_app)]]) (TTele_app (fun T PT => let '(mexistT _ l _) := PT in M (l -*> T))
                                                (fun T PT => let '(mexistT _ l X) := PT in
                                                             X
                                                ) f) in
  let T := reduce (RedStrong [rl: RedBeta; RedZeta; RedFix; RedMatch;
                           RedDeltaOnly [rl: Dyn (@M.type_of); Dyn (@TTele_ty); Dyn (@TTele_App); Dyn (@TTele_app); Dyn (@func_of)] ]) (M.type_of x) in
               @M.declare dok_Definition n false T x;; M.ret tt.

(** We use a synonim to prod to emulate typed goals. The idea *)
(*     is that at the left we have the hypotheses, and at the right *)
(*     the goal type. A goal H1, ..., Hn |- G is then written *)
(*     (H1 * ... * Hn) =m> G *)

(*     A lemma lifted to this type will produce an element of type G given *)
(*     promises (evars) for H1, ..., Hn. *)
(* *)

Definition myprod := prod.
Arguments myprod _%type _%type.

Notation "T1 '|m-' G" := (myprod T1 G)
  (at level 98, no associativity,
   format "T1  |m-  G") : type_scope.

(** composes on the left of the arrow *)
Definition compl {A} {B} (f: M (A |m- B)) (g : M A) : M B :=
  '(a, b) <- f;
  a' <- g;
  mif unify a a' UniCoq then
    ret b
  else failwith "nope".

(** composes a product *)
Definition compi {A} {B} (g : M A) (h : M B) : M (A * B) :=
  g >>= fun xg=> h >>= fun xh => ret (xg, xh).

(** Solves goal A provided tactic t *)
Definition Mby' {A} (t: tactic) : M A :=
  e <- evar A;
  l <- t (Goal Typeₛ e);
  l' <- T.filter_goals l;
  match l' with mnil => ret e | _ => failwith "couldn't solve" end.

Mtac Do New Exception NotAProp.
Definition Muse {A} (t: tactic) : M A :=
  mtry
    P <- evar Prop;
    of <- unify_univ P A UniMatchNoRed;
    match of with
    | mSome f => e <- M.evar P;
                 t (Goal Propₛ e);;
                 let e := reduce (RedOneStep [rl: RedBeta]) (f e) in
                 ret e
    | mNone => raise NotAProp
    end
  with | NotAProp =>
    e <- evar A;
    t (Goal Typeₛ e);;
    ret e
  end.

Definition is_prod T :=
  mmatch T with
  | [? A B] (A * B)%type => ret true
  | _ => ret false
  end.

Definition dest_pair {T} (x:T) : M (dyn * dyn) :=
  mmatch Dyn x with
  | [? A B a b] @Dyn (A*B) (a, b) => ret (Dyn a, Dyn b)
  end.

(** Given an element with type of the form (A1 * ... * An), *)
(*     it generates a goal for each unsolved variable in the pair. *)
Program Definition to_goals : forall {A}, A -> M (mlist (unit *m goal)) :=
  mfix2 to_goals (A: Type) (a: A) : M _ :=
  mif is_evar a then ret [m: (m: tt, Goal Typeₛ a)]
  else
    mif is_prod A then
      '(d1, d2) <- dest_pair a;
      dcase d1 as x in
      dcase d2 as y in
      t1s <- to_goals _ x;
      t2s <- to_goals _ y;
      ret (t1s +m+ t2s)
    else
      ret [m:].

(** From a typed tactic with type A |m- B, it generates an untyped one *)
Definition to_tactic {A B} (f: M (A |m- B)) : tactic := fun g=>
  gT <- goal_type g;
  mif unify gT B UniCoq then
    '(a, b) <- f;
    al <- to_goals a;
    ls <- T.filter_goals al;
    T.exact b g;;
    ret ls
  else
    failwith "nope".

Definition pass := evar.
Arguments pass {_}.

Import Strings.Ascii.
Local Open Scope string.

Definition doTT {A:Prop} (x:A) :=
  s <- pretty_print x;
  let s :=
      match String.get 0 s with
      | Some "@"%char => String.substring 1 (String.length s -1) s
      | _ => s
      end  ++ "T" in
  print s;;
  do_def s x.


Require Import Lia.
Require Import Bool.
Require Import RelationClasses.

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

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

From PromisingLib Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import Global.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.
Require Import BoolMap.
Require Import Promises.

Require Import OrdStep.

Set Implicit Arguments.

(** L-SC machine **)
Module SCLocal.
  Section SCLocal.
    Variable L: Loc.t -> bool.

    Definition non_maximal (lc: Local.t) (mem: Memory.t) (loc: Loc.t): Prop :=
      exists to from msg,
        (<<GET: Memory.get loc to mem = Some (from, msg)>>) /\
        (<<NRESERVE: msg <> Message.reserve>>) /\
        (<<TS: Time.lt ((TView.cur (Local.tview lc)).(View.rlx) loc) to>>)
    .

    Inductive read_step (lc1:Local.t) (gl1:Global.t) (loc:Loc.t) (to:Time.t) (val:Const.t) (released:option View.t) (ord:Ordering.t) (lc2:Local.t): Prop :=
    | read_step_intro
        ord'
        (ORD: ord' = if L loc then Ordering.join ord Ordering.acqrel else ord)
        (STEP: Local.read_step lc1 gl1 loc to val released ord' lc2)
        (MAXIMAL: forall (LOC: L loc)
                         from' to' val' released' na
                         (GET: Memory.get loc to' gl1.(Global.memory) = Some (from', Message.message val' released' na)),
            Time.le to' to)
    .
    Hint Constructors read_step: core.

    Inductive write_step (lc1:Local.t) (gl1:Global.t)
              (loc:Loc.t) (from to:Time.t)
              (val:Const.t) (releasedm released:option View.t) (ord:Ordering.t)
              (lc2:Local.t) (gl2:Global.t): Prop :=
    | write_step_intro
        ord'
        (ORD: ord' = if L loc then Ordering.join ord Ordering.acqrel else ord)
        (STEP: Local.write_step lc1 gl1 loc from to val releasedm released ord' lc2 gl2)
        (MAXIMAL: forall (LOC: L loc)
                         from' to' val' released' na
                         (GET: Memory.get loc to' gl1.(Global.memory) = Some (from', Message.message val' released' na)),
            Time.lt to' to)
    .
    Hint Constructors write_step: core.

    Variant program_step:
      forall (e: ThreadEvent.t) (lc1: Local.t) (gl1: Global.t) (lc2: Local.t) (gl2: Global.t), Prop :=
      | program_step_silent
          lc1 gl1:
        program_step ThreadEvent.silent lc1 gl1 lc1 gl1
      | program_step_read
          lc1 gl1
          loc to val released ord lc2
          (LOCAL: read_step lc1 gl1 loc to val released ord lc2):
        program_step (ThreadEvent.read loc to val released ord) lc1 gl1 lc2 gl1
      | program_step_write
          lc1 gl1
          loc from to val released ord lc2 gl2
          (LOCAL: write_step lc1 gl1 loc from to val None released ord lc2 gl2):
        program_step (ThreadEvent.write loc from to val released ord) lc1 gl1 lc2 gl2
      | program_step_update
          lc1 gl1
          loc ordr ordw
          tsr valr releasedr releasedw lc2
          tsw valw lc3 gl3
          (LOCAL1: read_step lc1 gl1 loc tsr valr releasedr ordr lc2)
          (LOCAL2: write_step lc2 gl1 loc tsr tsw valw releasedr releasedw ordw lc3 gl3):
        program_step (ThreadEvent.update loc tsr tsw valr valw releasedr releasedw ordr ordw)
                     lc1 gl1 lc3 gl3
      | program_step_fence
          lc1 gl1
          ordr ordw lc2 gl2
          (LOCAL: Local.fence_step lc1 gl1 ordr ordw lc2 gl2):
        program_step (ThreadEvent.fence ordr ordw) lc1 gl1 lc2 gl2
      | program_step_syscall
          lc1 gl1
          e lc2 gl2
          (LOCAL: Local.fence_step lc1 gl1 Ordering.seqcst Ordering.seqcst lc2 gl2):
        program_step (ThreadEvent.syscall e) lc1 gl1 lc2 gl2
      | program_step_failure
          lc1 gl1
          (LOCAL: Local.failure_step lc1):
        program_step ThreadEvent.failure lc1 gl1 lc1 gl1
      | program_step_racy_read
          lc1 gl1
          loc to val ord
          (LOCAL: Local.racy_read_step lc1 gl1 loc to val ord):
        program_step (ThreadEvent.racy_read loc to val ord) lc1 gl1 lc1 gl1
      | program_step_racy_write
          lc1 gl1
          loc to val ord
          (LOCAL: Local.racy_write_step lc1 gl1 loc to ord):
        program_step (ThreadEvent.racy_write loc to val ord) lc1 gl1 lc1 gl1
      | program_step_racy_update
          lc1 gl1
          loc to valr valw ordr ordw
          (LOCAL: Local.racy_update_step lc1 gl1 loc to ordr ordw):
        program_step (ThreadEvent.racy_update loc to valr valw ordr ordw) lc1 gl1 lc1 gl1
    .

    (* step_future *)

    Lemma program_step_future
          e lc1 gl1 lc2 gl2
          (STEP: program_step e lc1 gl1 lc2 gl2)
          (WF1: Local.wf lc1 gl1)
          (GL1: Global.wf gl1):
      <<WF2: Local.wf lc2 gl2>> /\
      <<GL2: Global.wf gl2>> /\
      <<TVIEW_FUTURE: TView.le lc1.(Local.tview) lc2.(Local.tview)>> /\
      <<GL_FUTURE: Global.future gl1 gl2>>.
    Proof.
      inv STEP.
      - esplits; eauto; try refl.
      - inv LOCAL.
        exploit Local.read_step_future; eauto. i. des.
        esplits; eauto; try refl.
      - inv LOCAL.
        exploit Local.write_step_future; eauto; try by econs.
        { ss. eapply Time.bot_spec. }
        i. des.
        esplits; eauto; try refl.
      - inv LOCAL1. inv LOCAL2.
        exploit Local.read_step_future; eauto. i. des.
        exploit Local.write_step_future; eauto; try by econs.
        { etrans; eauto. inv STEP0. inv WRITE. inv ADD. left. auto. }
        i. des.
        esplits; eauto. etrans; eauto.
      - exploit Local.fence_step_future; eauto.
      - exploit Local.fence_step_future; eauto.
      - esplits; eauto; try refl.
      - esplits; eauto; try refl.
      - esplits; eauto; try refl.
      - esplits; eauto; try refl.
    Qed.

    (* step_disjoint *)

    Lemma program_step_disjoint
          e lc1 gl1 lc2 gl2 lc
          (STEP: program_step e lc1 gl1 lc2 gl2)
          (WF1: Local.wf lc1 gl1)
          (GL1: Global.wf gl1)
          (DISJOINT1: Local.disjoint lc1 lc)
          (WF: Local.wf lc gl1):
      <<DISJOINT2: Local.disjoint lc2 lc>> /\
      <<WF: Local.wf lc gl2>>.
    Proof.
      inv STEP.
      - esplits; eauto.
      - inv LOCAL. exploit Local.read_step_disjoint; eauto.
      - inv LOCAL. exploit Local.write_step_disjoint; eauto.
      - inv LOCAL1. inv LOCAL2.
        exploit Local.read_step_future; eauto. i. des.
        exploit Local.read_step_disjoint; eauto. i. des.
        exploit Local.write_step_disjoint; eauto.
      - exploit Local.fence_step_disjoint; eauto.
      - exploit Local.fence_step_disjoint; eauto.
      - esplits; eauto.
      - esplits; eauto.
      - esplits; eauto.
      - esplits; eauto.
    Qed.

    Lemma program_step_promises
          e lc1 gl1 lc2 gl2
          (STEP: program_step e lc1 gl1 lc2 gl2):
      BoolMap.le (Local.promises lc2) (Local.promises lc1) /\
      BoolMap.le (Global.promises gl2) (Global.promises gl1).
    Proof.
      inv STEP; ss; try by (inv LOCAL; ss).
      - inv LOCAL. inv STEP. ss.
      - inv LOCAL. inv STEP. inv FULFILL; ss.
        split; eauto using BoolMap.remove_le.
      - inv LOCAL1. inv LOCAL2. inv STEP. inv STEP0. inv FULFILL; ss.
        split; eauto using BoolMap.remove_le.
    Qed.

    Lemma program_step_promises_minus
          e lc1 gl1 lc2 gl2
          (STEP: program_step e lc1 gl1 lc2 gl2):
      BoolMap.minus (Global.promises gl1) (Local.promises lc1) =
      BoolMap.minus (Global.promises gl2) (Local.promises lc2).
    Proof.
      inv STEP; ss; try by (inv LOCAL; ss).
      - inv LOCAL. inv STEP. ss.
      - inv LOCAL. inv STEP. ss.
        eapply Promises.fulfill_minus; eauto.
      - inv LOCAL1. inv LOCAL2. inv STEP. inv STEP0. ss.
        eapply Promises.fulfill_minus; eauto.
    Qed.

    Lemma program_step_promises_bot
          e lc1 gl1 lc2 gl2
          (STEP: program_step e lc1 gl1 lc2 gl2)
          (PROMISES: Local.promises lc1 = BoolMap.bot):
      Local.promises lc2 = BoolMap.bot.
    Proof.
      inv STEP; try inv LOCAL; ss; try inv STEP; ss.
      - inv FULFILL; ss.
        exploit BoolMap.remove_get0; try exact REMOVE. i. des.
        rewrite PROMISES in *. ss.
      - inv LOCAL1. inv LOCAL2. inv STEP. inv STEP0. ss.
        inv FULFILL; ss.
        exploit BoolMap.remove_get0; try exact REMOVE. i. des.
        rewrite PROMISES in *. ss.
    Qed.

    Lemma program_step_gpromises_bot
          e lc1 gl1 lc2 gl2
          (STEP: program_step e lc1 gl1 lc2 gl2)
          (PROMISES: Global.promises gl1 = BoolMap.bot):
      Global.promises gl2 = BoolMap.bot.
    Proof.
      inv STEP; try inv LOCAL; ss; try inv STEP; ss.
      - inv FULFILL; ss.
        exploit BoolMap.remove_get0; try exact GREMOVE. i. des.
        rewrite PROMISES in *. ss.
      - inv LOCAL1. inv LOCAL2. inv STEP. inv STEP0. ss.
        inv FULFILL; ss.
        exploit BoolMap.remove_get0; try exact GREMOVE. i. des.
        rewrite PROMISES in *. ss.
    Qed.

    Lemma program_step_reserves
          e lc1 gl1 lc2 gl2
          (STEP: program_step e lc1 gl1 lc2 gl2):
      Local.reserves lc2 = Local.reserves lc1.
    Proof.
      inv STEP; try inv LOCAL; ss; try inv STEP; ss.
      inv LOCAL1. inv LOCAL2. inv STEP. inv STEP0. ss.
    Qed.
  End SCLocal.
End SCLocal.

Module SCThread.
  Section SCThread.
    Variable lang: language.
    Variable L: Loc.t -> bool.

    Inductive step (e:ThreadEvent.t): forall (e1 e2:Thread.t lang), Prop :=
    | step_intro
        st1 lc1 gl1
        st2 lc2 gl2
        (STATE: (Language.step lang) (ThreadEvent.get_program_event e) st1 st2)
        (LOCAL: SCLocal.program_step L e lc1 gl1 lc2 gl2):
        step e (Thread.mk lang st1 lc1 gl1) (Thread.mk lang st2 lc2 gl2)
    .
    Hint Constructors step: core.

    Definition all_step := union step.
    Hint Unfold all_step: core.

    (* future *)

    Lemma step_future
          e e1 e2
          (STEP: step e e1 e2)
          (LC_WF1: Local.wf (Thread.local e1) (Thread.global e1))
          (GL_WF1: Global.wf (Thread.global e1)):
      <<LC_WF2: Local.wf (Thread.local e2) (Thread.global e2)>> /\
      <<GL_WF2: Global.wf (Thread.global e2)>> /\
      <<TVIEW_FUTURE: TView.le (Local.tview (Thread.local e1)) (Local.tview (Thread.local e2))>> /\
      <<GL_FUTURE: Global.future (Thread.global e1) (Thread.global e2)>>.
    Proof.
      inv STEP. ss. eapply SCLocal.program_step_future; eauto.
    Qed.

    Lemma rtc_all_step_future
          e1 e2
          (STEPS: rtc all_step e1 e2)
          (LC_WF1: Local.wf (Thread.local e1) (Thread.global e1))
          (GL_WF1: Global.wf (Thread.global e1)):
      <<LC_WF2: Local.wf (Thread.local e2) (Thread.global e2)>> /\
      <<GL_WF2: Global.wf (Thread.global e2)>> /\
      <<TVIEW_FUTURE: TView.le (Local.tview (Thread.local e1)) (Local.tview (Thread.local e2))>> /\
      <<GL_FUTURE: Global.future (Thread.global e1) (Thread.global e2)>>.
    Proof.
      revert LC_WF1 GL_WF1. induction STEPS; i.
      - esplits; eauto; refl.
      - inv H. inv USTEP. exploit step_future; eauto. i. des.
        exploit IHSTEPS; eauto. i. des.
        esplits; eauto; etrans; eauto.
    Qed.

    (* disjoint *)

    Lemma step_disjoint
          e e1 e2 lc
          (STEP: step e e1 e2)
          (LC_WF1: Local.wf (Thread.local e1) (Thread.global e1))
          (GL_WF1: Global.wf (Thread.global e1))
          (DISJOINT1: Local.disjoint (Thread.local e1) lc)
          (LC_WF: Local.wf lc (Thread.global e1)):
      <<DISJOINT2: Local.disjoint (Thread.local e2) lc>> /\
      <<LC_WF: Local.wf lc (Thread.global e2)>>.
    Proof.
      inv STEP.
      eapply SCLocal.program_step_disjoint; eauto.
    Qed.

    (* promises *)

    Lemma step_promises
          e th1 th2
          (STEP: step e th1 th2):
      BoolMap.le (Local.promises (Thread.local th2)) (Local.promises (Thread.local th1)) /\
      BoolMap.le (Global.promises (Thread.global th2)) (Global.promises (Thread.global th1)).
    Proof.
      inv STEP. s.
      eapply SCLocal.program_step_promises; eauto.
    Qed.

    Lemma step_promises_minus
          e th1 th2
          (STEP: step e th1 th2):
      BoolMap.minus (Global.promises (Thread.global th1)) (Local.promises (Thread.local th1)) =
      BoolMap.minus (Global.promises (Thread.global th2)) (Local.promises (Thread.local th2)).
    Proof.
      inv STEP; s.
      eapply SCLocal.program_step_promises_minus; eauto.
    Qed.
  End SCThread.
End SCThread.

Module SCConfiguration.
  Section SCConfiguration.
    Variable L: Loc.t -> bool.

    Variant estep: forall (e: ThreadEvent.t) (tid: Ident.t) (c1 c2: Configuration.t), Prop :=
    | estep_intro
        e tid c1 lang st1 lc1 st2 lc2 gl2
        (TID: IdentMap.find tid (Configuration.threads c1) = Some (existT _ lang st1, lc1))
        (STEP: SCThread.step L e
                             (Thread.mk _ st1 lc1 (Configuration.global c1))
                             (Thread.mk _ st2 lc2 gl2)):
      estep e tid c1 (Configuration.mk (IdentMap.add tid (existT _ _ st2, lc2) (Configuration.threads c1)) gl2)
    .
    Hint Constructors estep: core.

    Variant step: forall (e: MachineEvent.t) (tid: Ident.t) (c1 c2: Configuration.t), Prop :=
    | step_instro
        e tid c1 c2
        (STEP: estep e tid c1 c2):
        step (ThreadEvent.get_machine_event_pf e) tid c1 c2
    .
    Hint Constructors step: core.

    Variant all_step (c1 c2: Configuration.t): Prop :=
    | all_step_intro
        e tid
        (STEP: estep e tid c1 c2)
    .
    Hint Constructors all_step: core.

    Lemma estep_future
          e tid c1 c2
          (STEP: estep e tid c1 c2)
          (WF1: Configuration.wf c1):
      <<WF2: Configuration.wf c2>> /\
      <<GL_FUTURE: Global.future (Configuration.global c1) (Configuration.global c2)>>.
    Proof.
      inv WF1. inv WF. inv STEP; s.
      exploit THREADS; ss; eauto. i.
      exploit SCThread.step_future; eauto. s. i. des.
      splits; eauto.
      econs; ss. econs.
      - i. Configuration.simplify.
        + exploit THREADS; try apply TH1; eauto. i. des.
          exploit SCThread.step_disjoint; eauto. s. i. des.
          symmetry. auto.
        + exploit THREADS; try apply TH2; eauto. i. des.
          exploit SCThread.step_disjoint; eauto. i. des.
          auto.
        + eapply DISJOINT; [|eauto|eauto]. auto.
      - i. Configuration.simplify.
        exploit THREADS; try apply TH; eauto. i.
        exploit SCThread.step_disjoint; eauto. s. i. des.
        auto.
      - i. destruct (Local.promises lc2 loc) eqn:LGET.
        + exists tid, lang, st2, lc2. splits; ss.
          rewrite IdentMap.Facts.add_o. condtac; ss.
        + exploit SCThread.step_promises_minus; try exact STEP0. s. i.
          eapply equal_f in x1.
          revert x1. unfold BoolMap.minus. rewrite GET, LGET. s. i.
          destruct (Global.promises (Configuration.global c1) loc) eqn:GET1; ss.
          destruct (Local.promises lc1 loc) eqn:LGET1; ss.
          exploit PROMISES; eauto. i. des.
          exists tid0, lang0, st, lc. splits; ss.
          rewrite IdentMap.Facts.add_o. condtac; ss. subst. congr.
    Qed.

    Lemma step_future
          e tid c1 c2
          (STEP: step e tid c1 c2)
          (WF1: Configuration.wf c1):
      <<WF2: Configuration.wf c2>> /\
      <<GL_FUTURE: Global.future (Configuration.global c1) (Configuration.global c2)>>.
    Proof.
      inv STEP. eauto using estep_future.
    Qed.

    Lemma all_step_future
          c1 c2
          (STEP: all_step c1 c2)
          (WF1: Configuration.wf c1):
      <<WF2: Configuration.wf c2>> /\
      <<GL_FUTURE: Global.future (Configuration.global c1) (Configuration.global c2)>>.
    Proof.
      inv STEP. eapply step_future; eauto.
    Qed.

    Lemma rtc_all_step_future
          c1 c2
          (STEPS: rtc all_step c1 c2)
          (WF1: Configuration.wf c1):
      <<WF2: Configuration.wf c2>> /\
      <<GL_FUTURE: Global.future (Configuration.global c1) (Configuration.global c2)>>.
    Proof.
      revert WF1. induction STEPS; i.
      { splits; auto. refl. }
      { hexploit all_step_future; eauto.
        i. des. hexploit IHSTEPS; eauto. i. des. splits; eauto. etrans; eauto.
      }
    Qed.
  End SCConfiguration.
End SCConfiguration.

Definition is_accessing (e:ProgramEvent.t): option Loc.t :=
  match e with
  | ProgramEvent.read loc _ _ => Some loc
  | ProgramEvent.write loc _ _ => Some loc
  | ProgramEvent.update loc _ _ _ _ => Some loc
  | _ => None
  end.

(** L-SC race **)
Module SCRace.
  Section SCRace.
    Variable L: Loc.t -> bool.

    Definition race lang (th: Thread.t lang): Prop :=
      exists e st' loc,
        (<<STEP: Language.step _ e (Thread.state th) st'>>) /\
        (<<ACCESS: is_accessing e = (Some loc)>>) /\
        (<<LOC: L loc>>) /\
        (<<MAXIMAL: SCLocal.non_maximal th.(Thread.local) th.(Thread.global).(Global.memory) loc>>).

    Definition race_steps (c: Configuration.t) (tid: Ident.t): Prop :=
      exists lang st1 lc1,
        (<<TID: IdentMap.find tid (Configuration.threads c) = Some (existT _ lang st1, lc1)>>) /\
        (<<SCRACE: race (Thread.mk _ st1 lc1 c.(Configuration.global))>>).

    Definition racefree (c: Configuration.t): Prop :=
      forall tid c2
             (STEPS: rtc (SCConfiguration.all_step L) c c2),
        ~ race_steps c2 tid.

    Definition racefree_syn (syn: Threads.syntax): Prop :=
      racefree (Configuration.init syn).

    Lemma step_racefree
          e tid c1 c2
          (RACEFREE: racefree c1)
          (STEP: SCConfiguration.step L e tid c1 c2):
      racefree c2.
    Proof.
      ii. eapply RACEFREE; cycle 1; eauto.
      econs 2; eauto. inv STEP. econs; eauto.
    Qed.
  End SCRace.
End SCRace.