From stdpp Require Import namespaces.
From iris.algebra Require Import excl auth list.
From iris.heap_lang Require Export lifting notation.
From iris.base_logic.lib Require Import invariants.
From iris.program_logic Require Import atomic.
From iris.heap_lang Require Import proofmode atomic_heap.
From iris_examples.logatom.elimination_stack Require spec.
Set Default Proof Using "Type".

Module logatom := elimination_stack.spec.

(** A general HoCAP-style interface for a stack, modeled after the spec in
[hocap/abstract_bag.v].  There are two differences:
- We split [bag_contents] into an authoritative part and a fragment as this
  slightly strnegthens the spec: The logically atomic spec only requires
  [stack_content ∗ stack_content] to derive a contradiction, the abstract bag
  spec requires to get *three* pieces which is only possible when actually
  calling a bag operation.
- We also slightly weaken the spec by adding [make_laterable], which is needed
  because logical atomicity can only capture laterable resources, which is
  needed when implementing e.g. the elimination stack on top of an abstract
  logically atomic heap. *)
Record hocap_stack {Σ} `{!heapG Σ} := AtomicStack {
  (* -- operations -- *)
  new_stack : val;
  push : val;
  pop : val;
  (* -- other data -- *)
  name : Type;
  name_eqdec : EqDecision name;
  name_countable : Countable name;
  (* -- predicates -- *)
  is_stack (N : namespace) (γs : name) (v : val) : iProp Σ;
  stack_content_frag (γs : name) (l : list val) : iProp Σ;
  stack_content_auth (γs : name) (l : list val) : iProp Σ;
  (* -- predicate properties -- *)
  is_stack_persistent N γs v : Persistent (is_stack N γs v);
  stack_content_frag_timeless γs l : Timeless (stack_content_frag γs l);
  stack_content_auth_timeless γs l : Timeless (stack_content_auth γs l);
  stack_content_frag_exclusive γs l1 l2 :
    stack_content_frag γs l1 -∗ stack_content_frag γs l2 -∗ False;
  stack_content_auth_exclusive γs l1 l2 :
    stack_content_auth γs l1 -∗ stack_content_auth γs l2 -∗ False;
  stack_content_agree γs l1 l2 :
    stack_content_frag γs l1 -∗ stack_content_auth γs l2 -∗ ⌜l1 = l2⌝;
  stack_content_update γs l l' :
    stack_content_frag γs l -∗
    stack_content_auth γs l -∗
    |==> stack_content_frag γs l' ∗ stack_content_auth γs l';
  (* -- operation specs -- *)
  new_stack_spec N :
    {{{ True }}} new_stack #() {{{ γs s, RET s; is_stack N γs s ∗ stack_content_frag γs [] }}};
  push_spec N γs s (v : val) (Φ : val → iProp Σ) :
    is_stack N γs s -∗
    make_laterable (∀ l, stack_content_auth γs l ={⊤∖↑N}=∗ stack_content_auth γs (v::l) ∗ Φ #()) -∗
    WP push s v {{ Φ }};
  pop_spec N γs s (Φ : val → iProp Σ) :
    is_stack N γs s -∗
    make_laterable (∀ l, stack_content_auth γs l ={⊤∖↑N}=∗
          match l with [] => stack_content_auth γs [] ∗ Φ NONEV
                | v :: l' => stack_content_auth γs l' ∗ Φ (SOMEV v) end) -∗
    WP pop s {{ Φ }};
}.
Arguments hocap_stack _ {_}.

Existing Instances
  is_stack_persistent stack_content_frag_timeless stack_content_auth_timeless
  name_eqdec name_countable.

(** Show that our way of writing the [pop_spec] is equivalent to what is done in
[concurrent_stack.spec].  IOW, the conjunction-vs-match doesn't matter.  Fixing
the postcondition (the [Q] in [concurrent_stack.spec]) still matters. *)
Section pop_equiv.
  Context `{invG Σ} (T : Type).

  Lemma pop_equiv E (I : list T → iProp Σ) (Φemp : iProp Σ) (Φret : T → iProp Σ) :
    (∀ l, I l ={E}=∗
       match l with [] => I [] ∗ Φemp | v :: l' => I l' ∗ Φret v end)
    ⊣⊢
    (∀ v vs, I (v :: vs) ={E}=∗ Φret v ∗ I vs)
    ∧ (I [] ={E}=∗ Φemp ∗ I []).
  Proof.
    iSplit.
    - iIntros "HΦ". iSplit.
      + iIntros (??) "HI". iMod ("HΦ" with "HI") as "[$ $]". done.
      + iIntros "HI". iMod ("HΦ" with "HI") as "[$ $]". done.
    - iIntros "HΦ" (l) "HI". destruct l; rewrite [(I _ ∗ _)%I]bi.sep_comm; by iApply "HΦ".
  Qed.
End pop_equiv.

(** From a HoCAP stack we can directly implement the logically atomic
interface. *)
Section hocap_logatom.
  Context `{!heapG Σ} (stack: hocap_stack Σ).

  Lemma logatom_push N γs s (v : val) :
    stack.(is_stack) N γs s -∗
    <<< ∀ l : list val, stack.(stack_content_frag) γs l >>>
      stack.(push) s v @ ⊤∖↑N
    <<< stack.(stack_content_frag) γs (v::l), RET #() >>>.
  Proof.
    iIntros "Hstack". iIntros (Φ) "HΦ".
    iApply (push_spec with "Hstack").
    iApply (make_laterable_intro with "[] HΦ"). iIntros "!# >HΦ" (l) "Hauth".
    iMod "HΦ" as (l') "[Hfrag [_ Hclose]]".
    iDestruct (stack_content_agree with "Hfrag Hauth") as %->.
    iMod (stack_content_update with "Hfrag Hauth") as "[Hfrag $]".
    iMod ("Hclose" with "Hfrag") as "HΦ". done.
  Qed.

  Lemma logatom_pop N γs (s : val) :
    stack.(is_stack) N γs s -∗
    <<< ∀ l : list val, stack.(stack_content_frag) γs l >>>
      stack.(pop) s @ ⊤∖↑N
    <<< stack.(stack_content_frag) γs (tail l),
        RET match l with [] => NONEV | v :: _ => SOMEV v end >>>.
  Proof.
    iIntros "Hstack". iIntros (Φ) "HΦ".
    iApply (pop_spec with "Hstack").
    iApply (make_laterable_intro with "[] HΦ"). iIntros "!# >HΦ" (l) "Hauth".
    iMod "HΦ" as (l') "[Hfrag [_ Hclose]]".
    iDestruct (stack_content_agree with "Hfrag Hauth") as %->.
    destruct l;
    iMod (stack_content_update with "Hfrag Hauth") as "[Hfrag $]";
    iMod ("Hclose" with "Hfrag") as "HΦ"; done.
  Qed.

  Definition hocap_logatom : logatom.atomic_stack Σ :=
    {| logatom.new_stack_spec := stack.(new_stack_spec);
       logatom.push_spec := logatom_push;
       logatom.pop_spec := logatom_pop;
       logatom.stack_content_exclusive := stack.(stack_content_frag_exclusive) |}.

End hocap_logatom.

(** From a logically atomic stack, we can implement a HoCAP stack by adding an
auth invariant. *)

(** The CMRA & functor we need. *)
Class hocapG Σ := HocapG {
  hocap_stateG :> inG Σ (authR (optionUR $ exclR (listO valO)));
}.
Definition hocapΣ : gFunctors :=
  #[GFunctor (exclR unitO); GFunctor (authR (optionUR $ exclR (listO valO)))].

Instance subG_hocapΣ {Σ} : subG hocapΣ Σ → hocapG Σ.
Proof. solve_inG. Qed.

Section logatom_hocap.
  Context `{!heapG Σ} `{!hocapG Σ} (stack: logatom.atomic_stack Σ).

  Definition hocap_name : Type := stack.(logatom.name) * gname.
  Implicit Types γs : hocap_name.

  Definition hocap_stack_content_auth γs l : iProp Σ := own γs.2 (● Excl' l).
  Definition hocap_stack_content_frag γs l : iProp Σ := own γs.2 (◯ Excl' l).

  Definition hocap_is_stack N γs v : iProp Σ :=
    (stack.(logatom.is_stack) (N .@ "stack") γs.1 v ∗
     inv (N .@ "wrapper") (∃ l, stack.(logatom.stack_content) γs.1 l ∗ hocap_stack_content_auth γs l))%I.

  Lemma hocap_new_stack N :
    {{{ True }}}
      stack.(logatom.new_stack) #()
    {{{ γs s, RET s; hocap_is_stack N γs s ∗ hocap_stack_content_frag γs [] }}}.
  Proof.
    iIntros (Φ) "_ HΦ". iApply wp_fupd. iApply logatom.new_stack_spec; first done.
    iIntros "!>" (γs s) "[Hstack Hcont]".
    iMod (own_alloc (● Excl' [] ⋅ ◯ Excl' [])) as (γw) "[Hs● Hs◯]".
    { apply auth_both_valid. split; done. }
    iApply ("HΦ" $! (γs, γw)). rewrite /hocap_is_stack. iFrame.
    iApply inv_alloc. eauto with iFrame.
  Qed.

  Lemma hocap_push N γs s (v : val) (Φ : val → iProp Σ) :
    hocap_is_stack N γs s -∗
    make_laterable (∀ l, hocap_stack_content_auth γs l ={⊤∖↑N}=∗ hocap_stack_content_auth γs (v::l) ∗ Φ #()) -∗
    WP stack.(logatom.push) s v {{ Φ }}.
  Proof using Type*.
    iIntros "#[Hstack Hwrap] Hupd". awp_apply (logatom.push_spec with "Hstack").
    iInv "Hwrap" as (l) "[>Hcont >H●]".
    iAaccIntro with "Hcont"; first by eauto 10 with iFrame.
    iIntros "Hcont".
    iMod fupd_intro_mask' as "Hclose";
      last iMod (make_laterable_elim with "Hupd H●") as "[H● HΦ]"; first solve_ndisj.
    iMod "Hclose" as "_". iIntros "!>".
    eauto with iFrame.
  Qed.

  Lemma hocap_pop N γs s (Φ : val → iProp Σ) :
    hocap_is_stack N γs s -∗
    make_laterable (∀ l, hocap_stack_content_auth γs l ={⊤∖↑N}=∗
          match l with [] => hocap_stack_content_auth γs [] ∗ Φ NONEV
                | v :: l' => hocap_stack_content_auth γs l' ∗ Φ (SOMEV v) end) -∗
    WP stack.(logatom.pop) s {{ Φ }}.
  Proof using Type*.
    iIntros "#[Hstack Hwrap] Hupd". awp_apply (logatom.pop_spec with "Hstack").
    iInv "Hwrap" as (l) "[>Hcont >H●]".
    iAaccIntro with "Hcont"; first by eauto 10 with iFrame.
    iIntros "Hcont". destruct l.
    - iMod fupd_intro_mask' as "Hclose";
        last iMod (make_laterable_elim with "Hupd H●") as "[H● HΦ]"; first solve_ndisj.
       iMod "Hclose" as "_". iIntros "!>"; eauto with iFrame.
    - iMod fupd_intro_mask' as "Hclose";
        last iMod (make_laterable_elim with "Hupd H●") as "[H● HΦ]"; first solve_ndisj.
       iMod "Hclose" as "_". iIntros "!>"; eauto with iFrame.
  Qed.

  Program Definition logatom_hocap : hocap_stack Σ :=
    {| new_stack_spec := hocap_new_stack;
       push_spec := hocap_push;
       pop_spec := hocap_pop |}.
  Next Obligation.
    iIntros (???) "Hf1 Hf2". iDestruct (own_valid_2 with "Hf1 Hf2") as %[].
  Qed.
  Next Obligation.
    iIntros (???) "Ha1 Ha2". by iDestruct (own_valid_2 with "Ha1 Ha2") as %[].
  Qed.
  Next Obligation.
    iIntros (???) "Hf Ha". iDestruct (own_valid_2 with "Ha Hf") as
      %[->%Excl_included%leibniz_equiv _]%auth_both_valid. done.
  Qed.
  Next Obligation.
    iIntros (???) "Hf Ha". iMod (own_update_2 with "Ha Hf") as "[? ?]".
    { eapply auth_update, option_local_update, (exclusive_local_update _ (Excl _)). done. }
    by iFrame.
  Qed.

End logatom_hocap.


Require Import VST.floyd.proofauto.
Require Import VST.floyd.VSU.
Require Import fastpile.
Require Import spec_stdlib.
Require Import spec_fastpile_concrete.

#[export] Instance FPileConcCompSpecs : compspecs. make_compspecs prog. Defined.

Section FastpileConcrete_VSU.
Variable M: MallocFreeAPD.

Definition crep (s: Z) (p: val) : mpred :=
  EX s':Z, !! (0 <= s /\ 0 <= s' <= Int.max_signed /\
                 (s <= Int.max_signed -> s'=s)) &&
  data_at Ews tpile (Vint (Int.repr s')) p.

Definition cfreeable (p: val) :=
   malloc_token M Ews tpile p.

Lemma crep_local_facts:
  forall s p, crep s p |-- !! isptr p.
Proof.
intros.
unfold crep.
Intros s'.
entailer!.
Qed.

#[export] Hint Resolve crep_local_facts : saturate_local.

Lemma crep_valid_pointer:
  forall s p, crep s p |-- valid_pointer p.
Proof.
 intros.
 unfold crep. Intros s'.
 auto with valid_pointer.
Qed.
#[export] Hint Resolve crep_valid_pointer : valid_pointer.

Definition FASTPILECONC: FastpileConcreteAPD :=
  Build_FastpileConcreteAPD crep crep_local_facts crep_valid_pointer cfreeable.

Definition surely_malloc_spec :=
  DECLARE _surely_malloc
   WITH t:type, gv: globals
   PRE [ size_t ]
       PROP (0 <= sizeof t <= Ptrofs.max_unsigned;
                complete_legal_cosu_type t = true;
                natural_aligned natural_alignment t = true)
       PARAMS (Vptrofs (Ptrofs.repr (sizeof t))) GLOBALS (gv)
       SEP (mem_mgr M gv)
    POST [ tptr tvoid ] EX p:_,
       PROP ()
       LOCAL (temp ret_temp p)
       SEP (mem_mgr M gv; malloc_token M Ews t p * data_at_ Ews t p).

  Definition FastpileConc_ASI: funspecs := FastpileConcreteASI M FASTPILECONC.

  Definition fastpileconc_imported_specs:funspecs := MallocFreeASI M.

  Definition fastpileconc_internal_specs: funspecs := surely_malloc_spec::FastpileConc_ASI.

  Definition FastpileConcVprog: varspecs. mk_varspecs prog. Defined.
  Definition FastpileConcGprog: funspecs := fastpileconc_imported_specs ++ fastpileconc_internal_specs.

Lemma body_Pile_new: semax_body FastpileConcVprog FastpileConcGprog f_Pile_new (Pile_new_spec M FASTPILECONC).
Proof.
start_function.
forward_call (tpile, gv).
split3; simpl; auto; computable.
Intros p.
forward.
forward.
simpl countrep. unfold crep.
simpl count_freeable. unfold cfreeable.
Exists p 0.
entailer!.
Qed.

Lemma body_Pile_add: semax_body FastpileConcVprog FastpileConcGprog f_Pile_add (Pile_add_spec M FASTPILECONC).
Proof.
start_function.
simpl countrep. unfold crep.
Intros s'.
forward.
forward_if (temp _t'1 (if zle 0 n then if zle n (Int.max_signed-s') then Vtrue else Vfalse else Vfalse)).
-
forward.
entailer!.
destruct (zle 0 n); [ | lia].
destruct (zle _ _).
unfold Int.lt. rewrite zlt_false.
reflexivity.
normalize. rep_lia.
unfold Int.lt. rewrite zlt_true.
reflexivity.
normalize.
rep_lia.
-
forward.
entailer!.
-
destruct (zle 0 n); try lia.
forward_if (PROP()LOCAL (temp _pp p)
   SEP(crep (n+s) p; mem_mgr M gv)).
+
if_tac in H3; inv H3.
forward.
unfold crep. Exists (s'+n).
entailer!.
+
forward.
unfold crep.
if_tac in H3; inv H3.
Exists s'. entailer!.
+
forward.
Qed.

Lemma body_Pile_count: semax_body FastpileConcVprog FastpileConcGprog f_Pile_count (Pile_count_spec FASTPILECONC).
Proof.
start_function.
simpl countrep. unfold crep.
Intros s'.
forward.
forward.
simpl countrep. unfold crep.
Exists s' s'.
entailer!.
Qed.

Lemma body_Pile_free: semax_body FastpileConcVprog FastpileConcGprog f_Pile_free (Pile_free_spec M FASTPILECONC).
Proof.
start_function.
simpl countrep. unfold crep.
simpl count_freeable. unfold cfreeable. Intros s'.
assert_PROP (p<>nullval) by entailer!.
forward_call (free_spec_sub M (Tstruct _pile noattr))  (p, gv).
rewrite if_false by auto.
cancel.
forward.
Qed.

(*Same statement and proof as verif_pile. Indeed, the C files have the same code duplication...*)
(*Statement and proof also shared with verif_fastpile.v*)
Lemma body_surely_malloc: semax_body FastpileConcVprog FastpileConcGprog f_surely_malloc surely_malloc_spec.
Proof.
start_function.
forward_call (malloc_spec_sub M t) gv.
Intros p.
if_tac.
{ subst.
  forward_if False.
  - forward_call 1. contradiction.
  - congruence. }
forward_if True.
+ contradiction.
+ forward. entailer!.
+ forward. Exists p. entailer!.
Qed.

  Definition FastpileVSU: @VSU NullExtension.Espec
      nil fastpileconc_imported_specs ltac:(QPprog prog) FastpileConc_ASI emp.
  Proof.
    mkVSU prog fastpileconc_internal_specs.
    + solve_SF_internal body_surely_malloc.
    + solve_SF_internal body_Pile_count.
    + solve_SF_internal body_Pile_add.
    + solve_SF_internal body_Pile_new.
    + solve_SF_internal body_Pile_free.
  Qed.

End FastpileConcrete_VSU.


From stdpp Require Import fin_maps.
From iris_time.heap_lang Require Export notation proofmode.
From iris_time Require Import Reduction.

Implicit Type e : expr.
Implicit Type v : val.
Implicit Type σ : state.
Implicit Type t : list expr.
Implicit Type K : ectx heap_ectx_lang.
Implicit Type m n : nat.

(*
 * Translation with any arbitrary expression for [tick]
 *)

(* “tick” is a typeclass so that it can be made an implicit argument of the
 * translation and be inferred automatically from the context.
   This also make it possible to share notations. *)
Class Tick := tick : val.

Section Translation.

  Context {Htick : Tick}.

  (* Unfortunately, the operational semantics of [match] in our language is
   * ad-hoc somehow, as the rule is:
   *     Case (InjL v) e1 e2  →  e1 v
   * Instead of the more canonical rule:
   *     Case (InjL v) (x1. e1) (x2. e2)  →  e1 [x1 := v]
   * This means that the reduction of a match construct really takes two steps,
   * since we still have to reduce the application; hence, in our time credit
   * model, a match construct will cost two credits.
   * It also means that the “branch” [e1] is not constrained be a λ-abstraction,
   * and can reduce after the reduction of the [match] but before it is applied
   * to [v]!
   * This ad-hoc semantics calls for an ad-hoc definition of the translation in
   * that case because, to observe the simulation lemma, the translation of
   * [Case (InjL v) e1 e2] must reduce to the translation of [e1 v], which is
   * [(tick «e1») «v»]. To do so --which means preserving the weird evaluation
   * order--, we use the helper term below: *)
  Definition tick_case_branch : val :=
    (λ: "f" "x", tick ("f" #()) "x")%V.

  Fixpoint translation (e : expr) : expr :=
    match e with
    (* Base lambda calculus *)
    | Var _           => e
    | Rec f x e       => tick $ Rec f x (translation e)
    | App e1 e2       => (tick $ translation e1) (translation e2)
    | Val v           => Val $ translationV v
    (* Base types and their operations *)
    | UnOp op e       => UnOp op (tick $ translation e)
    | BinOp op e1 e2  => BinOp op (tick $ translation e1) (translation e2)
    | If e0 e1 e2     => If (tick $ translation e0) (translation e1) (translation e2)
    (* Products *)
    | Pair e1 e2      => Pair (tick $ translation e1) (translation e2)
    | Fst e           => Fst (tick $ translation e)
    | Snd e           => Snd (tick $ translation e)
    (* Sums *)
    | InjL e          => InjL (tick $ translation e)
    | InjR e          => InjR (tick $ translation e)
    | Case e0 e1 e2   =>
        Case (tick $ translation e0)
          (tick_case_branch (λ: <>, translation e1))
          (tick_case_branch (λ: <>, translation e2))
    (* Concurrency *)
    | Fork e          => tick $ Fork (translation e)
    (* Heap *)
    | Alloc e         => Alloc (tick $ translation e)
    | Load e          => Load (tick $ translation e)
    | Store e1 e2     => Store (tick $ translation e1) (translation e2)
    | CAS e0 e1 e2    => CAS (tick $ translation e0) (translation e1) (translation e2)
    | FAA e1 e2       => FAA (tick $ translation e1) (translation e2)
    end %E
  with translationV (v : val) : val :=
    match v with
    | RecV f x e    => RecV f x (translation e)
    | LitV _        => v
    | PairV v1 v2   => PairV (translationV v1) (translationV v2)
    | InjLV v       => InjLV (translationV v)
    | InjRV v       => InjRV (translationV v)
    end.

  Definition translationS (σ : state) : state :=
    translationV <$> σ.

  Let tickCtx : ectx_item := AppRCtx tick.

  Definition translationKi (Ki : ectx_item) : ectx_item :=
    match Ki with
    | AppLCtx v2      => AppLCtx (translationV v2)
    | AppRCtx e1      => AppRCtx (tick $ translation e1)
    | UnOpCtx op      => UnOpCtx op
    | BinOpLCtx op v2 => BinOpLCtx op (translationV v2)
    | BinOpRCtx op e1 => BinOpRCtx op (tick $ translation e1)
    | IfCtx e1 e2     => IfCtx (translation e1) (translation e2)
    | PairLCtx v2     => PairLCtx (translationV v2)
    | PairRCtx e1     => PairRCtx (tick $ translation e1)
    | FstCtx          => FstCtx
    | SndCtx          => SndCtx
    | InjLCtx         => InjLCtx
    | InjRCtx         => InjRCtx
    | CaseCtx e1 e2   =>
        CaseCtx
          (tick_case_branch (λ: <>, translation e1))%E
          (tick_case_branch (λ: <>, translation e2))%E
    | AllocCtx        => AllocCtx
    | LoadCtx         => LoadCtx
    | StoreLCtx v2    => StoreLCtx (translationV v2)
    | StoreRCtx e1    => StoreRCtx (tick $ translation e1)
    | CasLCtx v0 v1   => CasLCtx (translationV v0) (translationV v1)
    | CasMCtx e1 v1   => CasMCtx (tick $ translation e1) (translationV v1)
    | CasRCtx e1 e2   => CasRCtx (tick $ translation e1) (translation e2)
    | FaaLCtx v2      => FaaLCtx (translationV v2)
    | FaaRCtx e1      => FaaRCtx (tick $ translation e1)
    end.

  Definition translationKi_aux (Ki : ectx_item) : ectx _ :=
    if ectx_item_is_active Ki then
      [ tickCtx ; translationKi Ki ]
    else
      [ translationKi Ki ].

  Definition translationK (K : ectx heap_ectx_lang) : ectx _ :=
    List.concat (translationKi_aux <$> K).

(*
 * Lemmas about translation
 *)

  Lemma translation_subst x e v :
    translation (subst x v e) = subst x (translationV v) (translation e).
  Proof.
    induction e ;
    unfold subst ; simpl ; fold subst ;
    try case_match ; (* ← this handles the cases of Var and Rec *)
    repeat f_equal ;
    assumption.
  Qed.

  Lemma translation_subst' x e v :
    translation (subst' x v e) = subst' x (translationV v) (translation e).
  Proof.
    destruct x.
    - reflexivity.
    - apply translation_subst.
  Qed.

  Lemma translation_injective :
    ∀ e1 e2,
      translation e1 = translation e2 →
      e1 = e2
  with translationV_injective :
    ∀ v1 v2,
      translationV v1 = translationV v2 →
      v1 = v2.
  Proof.
    destruct e1, e2; try discriminate; intros [=]; subst; f_equal;
      by (apply translation_injective || apply translationV_injective).
    destruct v1, v2; try discriminate; intros [=]; subst; f_equal;
      by (apply translation_injective || apply translationV_injective).
  Qed.

  Lemma translation_fill_item Ki e :
    translation (fill_item Ki e) = fill (translationKi_aux Ki) (translation e).
  Proof.
    destruct Ki ; reflexivity.
  Qed.

  Lemma translation_fill_item_active (ki : ectx_item) v :
    ectx_item_is_active ki →
    translation (fill_item ki v) = fill_item (translationKi ki) (tick (translationV v)).
  Proof.
    rewrite translation_fill_item.
    unfold translationKi_aux ; destruct (ectx_item_is_active ki) ; last contradiction.
    reflexivity.
  Qed.

  Lemma is_active_translationKi ki :
    ectx_item_is_active ki →
    ectx_item_is_active (translationKi ki).
  Proof.
    by destruct ki.
  Qed.

  Lemma translation_fill K e :
    translation (fill K e) = fill (translationK K) (translation e).
  Proof.
    revert e ; induction K ; intros e.
    - done.
    - rewrite /= fill_app - translation_fill_item //.
  Qed.

  Lemma lookup_translationS_None σ l :
    σ !! l = None →
    translationS σ !! l = None.
  Proof.
    intros H. by rewrite lookup_fmap H.
  Qed.

  Lemma lookup_translationS_Some σ l v :
    σ !! l = Some v →
    translationS σ !! l = Some (translationV v).
  Proof.
    intros H. by rewrite lookup_fmap H.
  Qed.

  Lemma lookup_translationS_is_Some σ l :
    is_Some (σ !! l) →
    is_Some (translationS σ !! l).
  Proof.
    destruct 1. eauto using lookup_translationS_Some.
  Qed.

  Lemma lookup_translationS_None_inv σ l :
    translationS σ !! l = None →
    σ !! l = None.
  Proof.
    unfold translationS ; rewrite lookup_fmap.
    destruct (σ !! l) eqn:E ; rewrite E ; first discriminate.
    done.
  Qed.

  Lemma lookup_translationS_Some_inv σ l v' :
    translationS σ !! l = Some v' →
    ∃ v,  σ !! l = Some v  ∧  v' = translationV v.
  Proof.
    rewrite lookup_fmap.
    destruct (σ !! l) eqn:E ; rewrite E ; last discriminate.
    intros ? % Some_inj ; eauto.
  Qed.

  Lemma lookup_translationS_is_Some_inv σ l :
    is_Some (translationS σ !! l) →
    is_Some (σ !! l).
  Proof.
    intros [_ (? & ? & _) % lookup_translationS_Some_inv]. eauto.
  Qed.

  Lemma translationS_insert l v σ :
    translationS (<[l := v]> σ) = <[l := translationV v]> (translationS σ).
  Proof.
    apply fmap_insert.
  Qed.

  Lemma un_op_eval_translation op v v' :
    un_op_eval op v = Some v' →
    un_op_eval op (translationV v) = Some (translationV v').
  Proof.
    intros H.
    destruct op ;
    destruct v ; try discriminate H ;
    simpl ; case_match ; simpl in *;
      try discriminate H;
      try match goal with
          |- context [to_mach_int ?x] => destruct (to_mach_int x); [|discriminate] end;
      try by injection H as <-.
  Qed.

  Local Lemma _eval_EqOp_bool_decide v1 v2 :
    bin_op_eval EqOp v1 v2 = Some $ LitV $ LitBool $ bool_decide (v1 = v2).
  Proof.
    destruct v1, v2 ; try done ;
    simpl ; case_match ; try done ;
    simpl ; case_match ; try done ;
    repeat f_equal ; apply bool_decide_iff ; naive_solver.
  Qed.

  Local Lemma _bool_decide_eq_translationV v1 v2 :
    bool_decide (v1 = v2) = bool_decide (translationV v1 = translationV v2).
  Proof.
    apply bool_decide_iff ; split ; intros H.
    - by rewrite H.
    - by eapply translationV_injective.
  Qed.

  Lemma bin_op_eval_translation op v1 v2 v' :
    bin_op_eval op v1 v2 = Some v' →
    bin_op_eval op (translationV v1) (translationV v2) = Some (translationV v').
  Proof.
    intros H.
    destruct op ; try (
      destruct v1, v2 ; try discriminate H ;
      unfold bin_op_eval in * ;
      do 3 try (case_match ; try discriminate H) ;
      simpl in *;
      try match goal with
          |- context [to_mach_int ?x] => destruct (to_mach_int x); [|discriminate] end;
      by injection H as <-
    ).
    (* Remaining case: op = EqOp *)
    rewrite _eval_EqOp_bool_decide in H ; injection H as <-.
    by rewrite _eval_EqOp_bool_decide - _bool_decide_eq_translationV.
  Qed.

  Lemma un_op_eval_translation_inv op v v' :
    un_op_eval op (translationV v) = Some v' →
    un_op_eval op v = Some v'.
  Proof.
    intros H.
    destruct op ;
    destruct v ; try discriminate H ;
    done.
  Qed.

  Lemma bin_op_eval_translation_inv op v1 v2 v' :
    bin_op_eval op (translationV v1) (translationV v2) = Some v' →
    bin_op_eval op v1 v2 = Some v'.
  Proof.
    intros H.
    destruct op ; try (
      destruct v1, v2 ; try discriminate H ;
      done
    ).
    (* Remaining case: op = EqOp *)
    rewrite -> _eval_EqOp_bool_decide in *. injection H as <-.
    by rewrite - _bool_decide_eq_translationV.
  Qed.

  Lemma translationV_lit lit :
    translationV #lit = #lit.
  Proof.
    done.
  Qed.

  Lemma translationV_lit_inv v lit :
    translationV v = #lit →
    v = #lit.
  Proof.
    destruct v ; try discriminate. done.
  Qed.

  Lemma vals_cas_compare_safe_translationV v1 v2 :
    vals_cas_compare_safe v1 v2 →
    vals_cas_compare_safe (translationV v1) (translationV v2).
  Proof.
    intros [].
    - left. by destruct v1 as [| | |[]|[]].
    - right. by destruct v2 as [| | |[]|[]].
  Qed.
  Lemma vals_cas_compare_safe_translationV_inv v1 v2 :
    vals_cas_compare_safe (translationV v1) (translationV v2) →
    vals_cas_compare_safe v1 v2.
  Proof.
    intros [].
    - left. by destruct v1 as [| | |[]|[]].
    - right. by destruct v2 as [| | |[]|[]].
  Qed.

End Translation.

(*
 * Notations
 *)

Notation "E« e »" := (translation e%E).
Notation "V« v »" := (translationV v%V).
Notation "Ki« ki »" := (translationKi ki).
Notation "K« K »" := (translationK K).
Notation "S« σ »" := (translationS σ%V).
Notation "T« t »" := (translation <$> t%E).

Notation "« e »" := (translation e%E).
Notation "« e »" := (translation e%E) : expr_scope.
Notation "« v »" := (translationV v%V) : val_scope.

(* for some reason, these notations make parsing fail,
 * even if they only regard printing… *)
(*
Notation "« e »" := (translation e%E) (only printing).
Notation "« v »" := (translationV v%V) (only printing).
Notation "« ki »" := (translationKi ki) (only printing).
Notation "« K »" := (translationK K) (only printing).
Notation "« σ »" := (translationS σ%V) (only printing).
Notation "« t »" := (translation <$> t%E) (only printing).
*)

(* FIXME : the way coercions should or should not be included in
   notations so that notations are pretty-printed back is completely
   non-predictible. *)

Notation "'tickrec:' f x y .. z := e" :=
  (tick (Rec f%bind x%bind (tick (Lam y%bind .. (tick (Lam z%bind e%E)) ..))))
  (at level 200, f, x, y, z at level 1, e at level 200,
   format "'[' 'tickrec:'  f  x  y  ..  z  :=  '/  ' e ']'") : expr_scope.

Notation "tickλ: x , e" := (tick (Lam x%bind e%E))
  (at level 200, x at level 1, e at level 200,
   format "'[' 'tickλ:'  x ,  '/  ' e ']'") : expr_scope.
Notation "tickλ: x y .. z , e" :=
  (tick (Lam x%bind (tick (Lam y%bind .. (tick (Lam z%bind e%E)) ..))))
  (at level 200, x, y, z at level 1, e at level 200,
   format "'[' 'tickλ:'  x  y  ..  z ,  '/  ' e ']'") : expr_scope.

Notation "'lettick:' x := e1 'in' e2" :=
  ((tick (App (Val tick) (Lam x%bind e2%E))) e1%E)
  (at level 200, x at level 1, e1, e2 at level 200,
   format "'[' 'lettick:'  x  :=  '[' e1 ']'  'in'  '/' e2 ']'") : expr_scope.

Notation "e1 ;tick; e2" :=
  ((tick (App (Val tick) (Lam BAnon e2%E))) e1%E)
  (at level 100, e2 at level 200,
   format "'[' '[hv' '[' e1 ']'  ;tick;  ']' '/' e2 ']'") : expr_scope.

Notation "'tickmatch:' e0 'with' 'InjL' x1 => e1 | 'InjR' x2 => e2 'end'" :=
  (Case (App (Val tick) e0) (App (Val tick_case_branch) (λ: <>, App (Val tick) (λ: x1, e1))%E)
                            (App (Val tick_case_branch) (λ: <>, App (Val tick) (λ: x2, e2))%E))
  (e0, x1, e1, x2, e2 at level 200,
   format "'[hv' 'tickmatch:'  e0  'with'  '/  ' '[' 'InjL'  x1  =>  '/  ' e1 ']'  '/' '[' |  'InjR'  x2  =>  '/  ' e2 ']'  '/' 'end' ']'") : expr_scope.

(*
  Typeclass instance for the proofmode
 *)

Instance AsRecV_translationV `{Tick} v f x e :
  AsRecV v f x e →
  AsRecV « v » f x « e ».
Proof. by intros ->. Qed.

(*
 * Simplification tactic
 *)

(* simpl and cbn do not work well with mutual fixpoints... *)
Ltac simpl_trans :=
  cbn [translation translationV]; fold translation translationV.

(*
 * (Partial) Inverse translation
 *)

Section InvTranslation.

  Fixpoint invtranslation (e : expr) : expr :=
    match e with
    (* Concurrency -- This pattern has to appear before the pattern of
      App, since it conflicts with it. *)
    | App tick (Fork e)          => Fork (invtranslation e)
    (* Base lambda calculus *)
    | Var _                      => e
    | App tick (Rec f x e)       => Rec f x (invtranslation e)
    | App (App tick e1) e2       => (invtranslation e1) (invtranslation e2)
    | Val v                      => Val (invtranslationV v)
    (* Base types and their operations *)
    | UnOp op (App tick e)       => UnOp op (invtranslation e)
    | BinOp op (App tick e1) e2  => BinOp op (invtranslation e1) (invtranslation e2)
    | If (App tick e0) e1 e2     => If (invtranslation e0) (invtranslation e1) (invtranslation e2)
    (* Products *)
    | Pair (App tick e1) e2      => Pair (invtranslation e1) (invtranslation e2)
    | Fst (App tick e)           => Fst (invtranslation e)
    | Snd (App tick e)           => Snd (invtranslation e)
    (* Sums *)
    | InjL (App tick e)          => InjL (invtranslation e)
    | InjR (App tick e)          => InjR (invtranslation e)
    | Case (App tick e0) (App tickaux1 (Rec BAnon BAnon e1)) (App tickaux2 (Rec BAnon BAnon e2)) =>
        Case (invtranslation e0) (invtranslation e1) (invtranslation e2)
    (* Heap *)
    | Alloc (App tick e)         => Alloc (invtranslation e)
    | Load (App tick e)          => Load (invtranslation e)
    | Store (App tick e1) e2     => Store (invtranslation e1) (invtranslation e2)
    | CAS (App tick e0) e1 e2    => CAS (invtranslation e0) (invtranslation e1) (invtranslation e2)
    | FAA (App tick e1) e2       => FAA (invtranslation e1) (invtranslation e2)
    | _ => #42
    end %E
  with invtranslationV v :=
    match v with
    | RecV f x e    => RecV f x (invtranslation e)
    | LitV _        => v
    | PairV v1 v2   => PairV (invtranslationV v1) (invtranslationV v2)
    | InjLV v       => InjLV (invtranslationV v)
    | InjRV v       => InjRV (invtranslationV v)
    end.

  Lemma invtranslation_translation {Htick : Tick} e :
    invtranslation (translation e) = e
  with invtranslationV_translationV {Htick : Tick} v :
    invtranslationV (translationV v) = v.
  Proof.
    - specialize (invtranslation_translation Htick).
      specialize (invtranslationV_translationV Htick).
      destruct e;
        try by rewrite /= ?invtranslation_translation ?invtranslationV_translationV.
      (* Handle the App case by hand. *)
      { simpl. rewrite !invtranslation_translation. case_match=>//.
          by destruct e2. by destruct e2. }

    - specialize (invtranslation_translation Htick).
      specialize (invtranslationV_translationV Htick).
      destruct v;
        try by rewrite /= ?invtranslation_translation ?invtranslationV_translationV.
  Qed.
End InvTranslation.

(*
 * Characterizing expressions that are left invariant by translation
 *)

Section ClosureFree.

  Fixpoint closure_free (v : val) : bool :=
    match v with
    | RecV _ _ _ => false
    | LitV _ => true
    | PairV v1 v2 => closure_free v1 && closure_free v2
    | InjLV v1 => closure_free v1
    | InjRV v1 => closure_free v1
    end.

  Lemma closure_free_is_translationV_invariant {Htick : Tick} v :
    closure_free v →
    translationV v = v.
  Proof.
    intros ?.
    induction v as
      [ (* LitV *) lit
      | (* RecV *) f x e1
      | (* PairV *) v1 IH1 v2 IH2
      | (* InjLV *) v1 IH1
      | (* InjRV *) v1 IH1
      ] ; cbn in *.
    - done.
    - contradiction.
    - rewrite IH1 ?IH2; naive_solver.
    - rewrite IH1 ; naive_solver.
    - rewrite IH1 ; naive_solver.
  Qed.

  Lemma closure_free_is_invtranslationV_invariant v :
    closure_free v →
    invtranslationV v = v.
  Proof.
    intros ?.
    induction v as
      [ (* LitV *) lit
      | (* RecV *) f x e1
      | (* PairV *) v1 IH1 v2 IH2
      | (* InjLV *) v1 IH1
      | (* InjRV *) v1 IH1
      ] ; cbn.
    - done.
    - contradiction.
    - rewrite -> IH1, IH2 ; naive_solver.
    - rewrite IH1 ; naive_solver.
    - rewrite IH1 ; naive_solver.
  Qed.

  Lemma closure_free_translationV {Htick : Tick} v :
    closure_free v →
    closure_free (translationV v).
  Proof.
    intros Hv. by rewrite (closure_free_is_translationV_invariant v Hv).
  Qed.

  Lemma closure_free_invtranslationV v :
    closure_free v →
    closure_free (invtranslationV v).
  Proof.
    intros Hv. by rewrite (closure_free_is_invtranslationV_invariant v Hv).
  Qed.

  Lemma closure_free_translationV_iff  {Htick : Tick} v :
    closure_free v  ↔  closure_free (translationV v).
  Proof.
    split.
    - apply closure_free_translationV.
    - intros H % closure_free_invtranslationV. by rewrite invtranslationV_translationV in H.
  Qed.

  Lemma closure_free_predicate (φ : val → Prop) :
    (∀ (v : val), φ v → closure_free v) →
    ∀ (v : val),
      φ v → φ (invtranslationV v).
  Proof.
    intros Hφ v H.
    by specialize (Hφ _ H) as -> % closure_free_is_invtranslationV_invariant.
  Qed.

End ClosureFree.

(*
 *  Proofmode wp_* tactics.
 *)

(* wp_tick is a stub to be redefined for each particular definition of
   the tick function. *)
Ltac wp_tick := idtac.

Ltac wp_tick_closure := wp_closure; wp_tick.
Ltac wp_tick_pair := wp_tick; wp_pair.
Ltac wp_tick_inj := wp_tick; wp_inj.

Ltac wp_tick_rec := wp_tick ; wp_rec; simpl_trans.
Ltac wp_tick_lam := wp_tick_rec.
Ltac wp_tick_let := wp_tick_closure; wp_tick_lam.
Ltac wp_tick_seq := wp_tick_let.
Ltac wp_tick_op := wp_tick ; wp_op.
Ltac wp_tick_if := wp_tick ; wp_if.
Ltac wp_tick_match :=
  wp_tick; wp_match; (wp_let || wp_seq); wp_lam;
  wp_closure; wp_tick; wp_tick; wp_lam.
Ltac wp_tick_proj := wp_tick ; wp_proj.
Ltac wp_tick_alloc loc := wp_tick ; wp_alloc loc.
Ltac wp_tick_load := wp_tick ; wp_load.
Ltac wp_tick_store := wp_tick ; wp_store.