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

(** RTL function inlining: relational specification *)

Require Import Coqlib Wfsimpl Maps Errors Integers.
Require Import AST Linking.
Require Import Op Registers RTL.
Require Import Inlining.

(** ** Soundness of function environments. *)

(** A compile-time function environment is compatible with a whole
  program if the following condition holds. *)

Definition fenv_compat (p: program) (fenv: funenv) : Prop :=
  forall id f,
  fenv!id = Some f -> (prog_defmap p)!id = Some (Gfun (Internal f)).

Lemma funenv_program_compat:
  forall p, fenv_compat p (funenv_program p).
Proof.
  set (P := fun (dm: PTree.t (globdef fundef unit)) (fenv: funenv) =>
              forall id f,
              fenv!id = Some f -> dm!id = Some (Gfun (Internal f))).
  assert (REMOVE: forall dm fenv id g,
             P dm fenv ->
             P (PTree.set id g dm) (PTree.remove id fenv)).
  { unfold P; intros. rewrite PTree.grspec in H0. destruct (PTree.elt_eq id0 id).
    discriminate.
    rewrite PTree.gso; auto.
  }
  assert (ADD: forall dm fenv idg,
             P dm fenv ->
             P (match snd idg with
                  | Some g => PTree.set (fst idg) g dm
                  | _ => PTree.remove (fst idg) dm
                end) (add_globdef fenv idg)).
  { intros dm fenv [id g]; simpl; intros.
    destruct g as [ [ [f|ef] | v] | ] ; auto.
    destruct (should_inline id f); auto.
    red; intros. rewrite ! PTree.gsspec in *.
    destruct (peq id0 id); auto. inv H0; auto.
    unfold P. intros ? ? .
    rewrite ! PTree.grspec.
    destruct (PTree.elt_eq id0 id); auto.
    discriminate.
  }
  assert (REC: forall l dm fenv,
            P dm fenv ->
            P (fold_left (fun x idg =>
                            match snd idg with
                              | Some g => PTree.set (fst idg) g x
                              | None => PTree.remove (fst idg) x
                            end) l dm)
              (fold_left add_globdef l fenv)).
  { induction l; simpl; intros.
  - auto.
  - apply IHl. apply ADD; auto.
  }
  intros. apply REC. red; intros.  rewrite PTree.gempty in H; discriminate.
Qed.

Lemma fenv_compat_linkorder:
  forall cunit prog fenv,
  linkorder cunit prog -> fenv_compat cunit fenv -> fenv_compat prog fenv.
Proof.
  intros; red; intros. apply H0 in H1.
  destruct (prog_defmap_linkorder _ _ _ _ H H1) as (gd' & P & Q).
  inv Q. inv H3. auto.
Qed.

(** ** Properties of shifting *)

Lemma shiftpos_eq: forall x y, Zpos (shiftpos x y) = (Zpos x + Zpos y) - 1.
Proof.
  intros. unfold shiftpos. zify.  try rewrite Pos2Z.inj_sub. auto.
  zify. omega.
Qed.

Lemma shiftpos_inj:
  forall x y n, shiftpos x n = shiftpos y n -> x = y.
Proof.
  intros.
  assert (Zpos (shiftpos x n) = Zpos (shiftpos y n)) by congruence.
  rewrite ! shiftpos_eq in H0.
  assert (Z.pos x = Z.pos y) by omega.
  congruence.
Qed.

Lemma shiftpos_diff:
  forall x y n, x <> y -> shiftpos x n <> shiftpos y n.
Proof.
  intros; red; intros. elim H. eapply shiftpos_inj; eauto.
Qed.

Lemma shiftpos_above:
  forall x n, Ple n (shiftpos x n).
Proof.
  intros. unfold Ple; zify. rewrite shiftpos_eq. xomega.
Qed.

Lemma shiftpos_not_below:
  forall x n, Plt (shiftpos x n) n -> False.
Proof.
  intros. generalize (shiftpos_above x n). xomega.
Qed.

Lemma shiftpos_below:
  forall x n, Plt (shiftpos x n) (Pplus x n).
Proof.
  intros. unfold Plt; zify. rewrite shiftpos_eq. omega.
Qed.

Lemma shiftpos_le:
  forall x y n, Ple x y -> Ple (shiftpos x n) (shiftpos y n).
Proof.
  intros. unfold Ple in *; zify. rewrite ! shiftpos_eq. omega.
Qed.

(** ** Working with the state monad *)

Remark bind_inversion:
  forall (A B: Type) (f: mon A) (g: A -> mon B)
         (y: B) (s1 s3: state) (i: sincr s1 s3),
  bind f g s1 = R y s3 i ->
  exists x, exists s2, exists i1, exists i2,
  f s1 = R x s2 i1 /\ g x s2 = R y s3 i2.
Proof.
  unfold bind; intros. destruct (f s1). exists x; exists s'; exists I.
  destruct (g x s'). inv H. exists I0; auto.
Qed.

Ltac monadInv1 H :=
  match type of H with
  | (R _ _ _ = R _ _ _) =>
      inversion H; clear H; try subst
  | (ret _ _ = R _ _ _) =>
      inversion H; clear H; try subst
  | (bind ?F ?G ?S = R ?X ?S' ?I) =>
      let x := fresh "x" in (
      let s := fresh "s" in (
      let i1 := fresh "INCR" in (
      let i2 := fresh "INCR" in (
      let EQ1 := fresh "EQ" in (
      let EQ2 := fresh "EQ" in (
      destruct (bind_inversion _ _ F G X S S' I H) as [x [s [i1 [i2 [EQ1 EQ2]]]]];
      clear H;
      try (monadInv1 EQ2)))))))
  end.

Ltac monadInv H :=
  match type of H with
  | (ret _ _ = R _ _ _) => monadInv1 H
  | (bind ?F ?G ?S = R ?X ?S' ?I) => monadInv1 H
  | (?F _ _ _ _ _ _ _ _ = R _ _ _) =>
      ((progress simpl in H) || unfold F in H); monadInv1 H
  | (?F _ _ _ _ _ _ _ = R _ _ _) =>
      ((progress simpl in H) || unfold F in H); monadInv1 H
  | (?F _ _ _ _ _ _ = R _ _ _) =>
      ((progress simpl in H) || unfold F in H); monadInv1 H
  | (?F _ _ _ _ _ = R _ _ _) =>
      ((progress simpl in H) || unfold F in H); monadInv1 H
  | (?F _ _ _ _ = R _ _ _) =>
      ((progress simpl in H) || unfold F in H); monadInv1 H
  | (?F _ _ _ = R _ _ _) =>
      ((progress simpl in H) || unfold F in H); monadInv1 H
  | (?F _ _ = R _ _ _) =>
      ((progress simpl in H) || unfold F in H); monadInv1 H
  | (?F _ = R _ _ _) =>
      ((progress simpl in H) || unfold F in H); monadInv1 H
  end.

Fixpoint mlist_iter2 {A B: Type} (f: A -> B -> mon unit) (l: list (A*B)): mon unit :=
  match l with
  | nil => ret tt
  | (x,y) :: l' => do z <- f x y; mlist_iter2 f l'
  end.

Remark mlist_iter2_fold:
  forall (A B: Type) (f: A -> B -> mon unit) l s,
  exists i,
  mlist_iter2 f l s =
  R tt (fold_left (fun a p => match f (fst p) (snd p) a with R _ s2 _ => s2 end) l s) i.
Proof.
  induction l; simpl; intros.
  exists (sincr_refl s); auto.
  destruct a as [x y]. unfold bind. simpl. destruct (f x y s) as [xx s1 i1].
  destruct (IHl s1) as [i2 EQ]. rewrite EQ. econstructor; eauto.
Qed.

Lemma ptree_mfold_spec:
  forall (A: Type) (f: positive -> A -> mon unit) t s x s' i,
  ptree_mfold f t s = R x s' i ->
  exists i', mlist_iter2 f (PTree.elements t) s = R tt s' i'.
Proof.
  intros.
  destruct (mlist_iter2_fold _ _ f (PTree.elements t) s) as [i' EQ].
  unfold ptree_mfold in H. inv H. rewrite PTree.fold_spec.
  econstructor. eexact EQ.
Qed.

(** ** Relational specification of the translation of moves *)

Inductive tr_moves (c: code) : node -> list reg -> list reg -> node -> Prop :=
  | tr_moves_cons: forall pc1 src srcs dst dsts pc2 pc3,
      tr_moves c pc1 srcs dsts pc2 ->
      c!pc2 = Some(Iop Omove (src :: nil) dst pc3) ->
      tr_moves c pc1 (src :: srcs) (dst :: dsts) pc3
  | tr_moves_nil: forall srcs dsts pc,
      srcs = nil \/ dsts = nil ->
      tr_moves c pc srcs dsts pc.

Lemma add_moves_unchanged:
  forall srcs dsts pc2 s pc1 s' i pc,
  add_moves srcs dsts pc2 s = R pc1 s' i ->
  Plt pc s.(st_nextnode) \/ Ple s'.(st_nextnode) pc ->
  s'.(st_code)!pc = s.(st_code)!pc.
Proof.
  induction srcs; simpl; intros.
  monadInv H. auto.
  destruct dsts; monadInv H. auto.
  transitivity (st_code s0)!pc. eapply IHsrcs; eauto. monadInv EQ; simpl. xomega.
  monadInv EQ; simpl. apply PTree.gso.
  inversion INCR0; simpl in *. xomega.
Qed.

Lemma add_moves_spec:
  forall srcs dsts pc2 s pc1 s' i c,
  add_moves srcs dsts pc2 s = R pc1 s' i ->
  (forall pc, Ple s.(st_nextnode) pc -> Plt pc s'.(st_nextnode) -> c!pc = s'.(st_code)!pc) ->
  tr_moves c pc1 srcs dsts pc2.
Proof.
  induction srcs; simpl; intros.
  monadInv H. apply tr_moves_nil; auto.
  destruct dsts; monadInv H. apply tr_moves_nil; auto.
  apply tr_moves_cons with x. eapply IHsrcs; eauto.
  intros. inversion INCR. apply H0; xomega.
  monadInv EQ.
  rewrite H0. erewrite add_moves_unchanged; eauto.
  simpl. apply PTree.gss.
  simpl. xomega.
  xomega.
  inversion INCR; inversion INCR0; simpl in *; xomega.
Qed.

(** ** Relational specification of CFG expansion *)

Section INLINING_SPEC.

Variable fenv: funenv.

Definition context_below (ctx1 ctx2: context): Prop :=
  Ple (Pplus ctx1.(dreg) ctx1.(mreg)) ctx2.(dreg).

Definition context_stack_call (ctx1 ctx2: context): Prop :=
  ctx1.(mstk) >= 0 /\ ctx1.(dstk) + ctx1.(mstk) <= ctx2.(dstk).

Definition context_stack_tailcall (ctx1: context) (f: function) (ctx2: context) : Prop :=
  ctx2.(dstk) = align ctx1.(dstk) (min_alignment f.(fn_stacksize)).

Section INLINING_BODY_SPEC.

Variable stacksize: Z.

Inductive tr_instr: context -> node -> instruction -> code -> Prop :=
  | tr_nop: forall ctx pc c s,
      c!(spc ctx pc) = Some (Inop (spc ctx s)) ->
      tr_instr ctx pc (Inop s) c
  | tr_op: forall ctx pc c op args res s,
      Ple res ctx.(mreg) ->
      c!(spc ctx pc) = Some (Iop (sop ctx op) (sregs ctx args) (sreg ctx res) (spc ctx s)) ->
      tr_instr ctx pc (Iop op args res s) c
  | tr_load: forall ctx pc c chunk addr args res s,
      Ple res ctx.(mreg) ->
      c!(spc ctx pc) = Some (Iload chunk (saddr ctx addr) (sregs ctx args) (sreg ctx res) (spc ctx s)) ->
      tr_instr ctx pc (Iload chunk addr args res s) c
  | tr_store: forall ctx pc c chunk addr args src s,
      c!(spc ctx pc) = Some (Istore chunk (saddr ctx addr) (sregs ctx args) (sreg ctx src) (spc ctx s)) ->
      tr_instr ctx pc (Istore chunk addr args src s) c
  | tr_call: forall ctx pc c sg ros args res s,
      Ple res ctx.(mreg) ->
      c!(spc ctx pc) = Some (Icall sg (sros ctx ros) (sregs ctx args) (sreg ctx res) (spc ctx s)) ->
      tr_instr ctx pc (Icall sg ros args res s) c
  | tr_call_inlined:forall ctx pc sg id args res s c f pc1 ctx',
      Ple res ctx.(mreg) ->
      fenv!id = Some f ->
      c!(spc ctx pc) = Some(Inop pc1) ->
      tr_moves c pc1 (sregs ctx args) (sregs ctx' f.(fn_params)) (spc ctx' f.(fn_entrypoint)) ->
      tr_funbody ctx' f c ->
      ctx'.(retinfo) = Some(spc ctx s, sreg ctx res) ->
      context_below ctx ctx' ->
      context_stack_call ctx ctx' ->
      tr_instr ctx pc (Icall sg (inr _ id) args res s) c
  | tr_tailcall: forall ctx pc c sg ros args,
      c!(spc ctx pc) = Some (Itailcall sg (sros ctx ros) (sregs ctx args)) ->
      ctx.(retinfo) = None ->
      tr_instr ctx pc (Itailcall sg ros args) c
  | tr_tailcall_call: forall ctx pc c sg ros args res s,
      c!(spc ctx pc) = Some (Icall sg (sros ctx ros) (sregs ctx args) res s) ->
      ctx.(retinfo) = Some(s, res) ->
      tr_instr ctx pc (Itailcall sg ros args) c
  | tr_tailcall_inlined: forall ctx pc sg id args c f pc1 ctx',
      fenv!id = Some f ->
      c!(spc ctx pc) = Some(Inop pc1) ->
      tr_moves c pc1 (sregs ctx args) (sregs ctx' f.(fn_params)) (spc ctx' f.(fn_entrypoint)) ->
      tr_funbody ctx' f c ->
      ctx'.(retinfo) = ctx.(retinfo) ->
      context_below ctx ctx' ->
      context_stack_tailcall ctx f ctx' ->
      tr_instr ctx pc (Itailcall sg (inr _ id) args) c
  | tr_builtin: forall ctx pc c ef args res s,
      match res with BR r => Ple r ctx.(mreg) | _ => True end ->
      c!(spc ctx pc) = Some (Ibuiltin ef (map (sbuiltinarg ctx) args) (sbuiltinres ctx res) (spc ctx s)) ->
      tr_instr ctx pc (Ibuiltin ef args res s) c
  | tr_cond: forall ctx pc cond args s1 s2 c,
      c!(spc ctx pc) = Some (Icond cond (sregs ctx args) (spc ctx s1) (spc ctx s2)) ->
      tr_instr ctx pc (Icond cond args s1 s2) c
  | tr_jumptable: forall ctx pc r tbl c,
      c!(spc ctx pc) = Some (Ijumptable (sreg ctx r) (List.map (spc ctx) tbl)) ->
      tr_instr ctx pc (Ijumptable r tbl) c
  | tr_return: forall ctx pc or c,
      c!(spc ctx pc) = Some (Ireturn (option_map (sreg ctx) or)) ->
      ctx.(retinfo) = None ->
      tr_instr ctx pc (Ireturn or) c
  | tr_return_inlined: forall ctx pc or c rinfo,
      c!(spc ctx pc) = Some (inline_return ctx or rinfo) ->
      ctx.(retinfo) = Some rinfo ->
      tr_instr ctx pc (Ireturn or) c

with tr_funbody: context -> function -> code -> Prop :=
  | tr_funbody_intro: forall ctx f c,
      (forall r, In r f.(fn_params) -> Ple r ctx.(mreg)) ->
      (forall pc i, f.(fn_code)!pc = Some i -> tr_instr ctx pc i c) ->
      ctx.(mstk) = Zmax f.(fn_stacksize) 0 ->
      (min_alignment f.(fn_stacksize) | ctx.(dstk)) ->
      ctx.(dstk) >= 0 -> ctx.(dstk) + ctx.(mstk) <= stacksize ->
      tr_funbody ctx f c.

Definition fenv_agree (fe: funenv) : Prop :=
  forall id f, fe!id = Some f -> fenv!id = Some f.

Section EXPAND_INSTR.

Variable fe: funenv.
Hypothesis FE: fenv_agree fe.

Variable rec: forall fe', (size_fenv fe' < size_fenv fe)%nat -> context -> function -> mon unit.

Hypothesis rec_unchanged:
  forall fe' (L: (size_fenv fe' < size_fenv fe)%nat) ctx f s x s' i pc,
  rec fe' L ctx f s = R x s' i ->
  Ple ctx.(dpc) s.(st_nextnode) ->
  Plt pc ctx.(dpc) ->
  s'.(st_code)!pc = s.(st_code)!pc.

Remark set_instr_other:
  forall pc instr s x s' i pc',
  set_instr pc instr s = R x s' i ->
  pc' <> pc ->
  s'.(st_code)!pc' = s.(st_code)!pc'.
Proof.
  intros. monadInv H; simpl. apply PTree.gso; auto.
Qed.

Remark set_instr_same:
  forall pc instr s x s' i c,
  set_instr pc instr s = R x s' i ->
  c!(pc) = s'.(st_code)!pc ->
  c!(pc) = Some instr.
Proof.
  intros. rewrite H0. monadInv H; simpl. apply PTree.gss.
Qed.

Lemma expand_instr_unchanged:
  forall ctx pc instr s x s' i pc',
  expand_instr fe rec ctx pc instr s = R x s' i ->
  Ple ctx.(dpc) s.(st_nextnode) ->
  Plt pc' s.(st_nextnode) ->
  pc' <> spc ctx pc ->
  s'.(st_code)!pc' = s.(st_code)!pc'.
Proof.
  generalize set_instr_other; intros A.
  intros. unfold expand_instr in H; destruct instr; eauto.
(* call *)
  destruct (can_inline fe s1). eauto.
  monadInv H. unfold inline_function in EQ. monadInv EQ.
  transitivity (s2.(st_code)!pc'). eauto.
  transitivity (s5.(st_code)!pc'). eapply add_moves_unchanged; eauto.
    left. inversion INCR5. inversion INCR3. monadInv EQ1; simpl in *. xomega.
  transitivity (s4.(st_code)!pc'). eapply rec_unchanged; eauto.
    simpl. monadInv EQ; simpl. monadInv EQ1; simpl. xomega.
    simpl. monadInv EQ1; simpl. auto.
  monadInv EQ; simpl. monadInv EQ1; simpl. auto.
(* tailcall *)
  destruct (can_inline fe s1).
  destruct (retinfo ctx) as [[rpc rreg]|]; eauto.
  monadInv H. unfold inline_tail_function in EQ. monadInv EQ.
  transitivity (s2.(st_code)!pc'). eauto.
  transitivity (s5.(st_code)!pc'). eapply add_moves_unchanged; eauto.
    left. inversion INCR5. inversion INCR3. monadInv EQ1; simpl in *. xomega.
  transitivity (s4.(st_code)!pc'). eapply rec_unchanged; eauto.
    simpl. monadInv EQ; simpl. monadInv EQ1; simpl. xomega.
    simpl. monadInv EQ1; simpl. auto.
  monadInv EQ; simpl. monadInv EQ1; simpl. auto.
(* return *)
  destruct (retinfo ctx) as [[rpc rreg]|]; eauto.
Qed.

Lemma iter_expand_instr_unchanged:
  forall ctx pc l s x s' i,
  mlist_iter2 (expand_instr fe rec ctx) l s = R x s' i ->
  Ple ctx.(dpc) s.(st_nextnode) ->
  Plt pc s.(st_nextnode) ->
  ~In pc (List.map (spc ctx) (List.map (@fst _ _) l)) ->
  list_norepet (List.map (@fst _ _) l) ->
  s'.(st_code)!pc = s.(st_code)!pc.
Proof.
  induction l; simpl; intros.
  (* base case *)
  monadInv H. auto.
  (* inductive case *)
  destruct a as [pc1 instr1]; simpl in *.
  monadInv H. inv H3.
  transitivity ((st_code s0)!pc).
  eapply IHl; eauto. destruct INCR; xomega. destruct INCR; xomega.
  eapply expand_instr_unchanged; eauto.
Qed.

Lemma expand_cfg_rec_unchanged:
  forall ctx f s x s' i pc,
  expand_cfg_rec fe rec ctx f s = R x s' i ->
  Ple ctx.(dpc) s.(st_nextnode) ->
  Plt pc ctx.(dpc) ->
  s'.(st_code)!pc = s.(st_code)!pc.
Proof.
  intros. unfold expand_cfg_rec in H. monadInv H. inversion EQ.
  transitivity ((st_code s0)!pc).
  exploit ptree_mfold_spec; eauto. intros [INCR' ITER].
  eapply iter_expand_instr_unchanged; eauto.
    subst s0; auto.
    subst s0; simpl. xomega.
    red; intros. exploit list_in_map_inv; eauto. intros [pc1 [A B]].
    subst pc. unfold spc in H1. eapply shiftpos_not_below; eauto.
    apply PTree.elements_keys_norepet.
  subst s0; auto.
Qed.

Hypothesis rec_spec:
  forall fe' (L: (size_fenv fe' < size_fenv fe)%nat) ctx f s x s' i c,
  rec fe' L ctx f s = R x s' i ->
  fenv_agree fe' ->
  Ple (ctx.(dpc) + max_pc_function f) s.(st_nextnode) ->
  ctx.(mreg) = max_reg_function f ->
  Ple (Pplus ctx.(dreg) ctx.(mreg)) s.(st_nextreg) ->
  ctx.(mstk) >= 0 ->
  ctx.(mstk) = Zmax (fn_stacksize f) 0 ->
  (min_alignment (fn_stacksize f) | ctx.(dstk)) ->
  ctx.(dstk) >= 0 ->
  s'.(st_stksize) <= stacksize ->
  (forall pc, Ple ctx.(dpc) pc -> Plt pc s'.(st_nextnode) -> c!pc = s'.(st_code)!pc) ->
  tr_funbody ctx f c.

Remark min_alignment_pos:
  forall sz, min_alignment sz > 0.
Proof.
  intros; unfold min_alignment.
  destruct (zle sz 1). omega. destruct (zle sz 2). omega. destruct (zle sz 4); omega.
Qed.

Ltac inv_incr :=
  match goal with
  | [ H: sincr _ _ |- _ ] => destruct H; inv_incr
  | _ => idtac
  end.

Lemma expand_instr_spec:
  forall ctx pc instr s x s' i c,
  expand_instr fe rec ctx pc instr s = R x s' i ->
  (forall r, instr_defs instr = Some r -> Ple r ctx.(mreg)) ->
  Plt (spc ctx pc) s.(st_nextnode) ->
  Ple (ctx.(dreg) + ctx.(mreg)) s.(st_nextreg) ->
  ctx.(mstk) >= 0 -> ctx.(dstk) >= 0 ->
  s'.(st_stksize) <= stacksize ->
  (forall pc', Ple s.(st_nextnode) pc' -> Plt pc' s'.(st_nextnode) -> c!pc' = s'.(st_code)!pc') ->
  c!(spc ctx pc) = s'.(st_code)!(spc ctx pc) ->
  tr_instr ctx pc instr c.
Proof.
  intros until c; intros EXP DEFS OPC OREG STK1 STK2 STK3 S1 S2.
  generalize set_instr_same; intros BASE.
  unfold expand_instr in EXP; destruct instr; simpl in DEFS;
  try (econstructor; eauto; fail).
(* call *)
  destruct (can_inline fe s1) as [|id f P Q].
  (* not inlined *)
  eapply tr_call; eauto.
  (* inlined *)
  subst s1.
  monadInv EXP. unfold inline_function in EQ; monadInv EQ.
  set (ctx' := callcontext ctx x1 x2 (max_reg_function f) (fn_stacksize f) n r).
  inversion EQ0; inversion EQ1; inversion EQ. inv_incr.
  apply tr_call_inlined with (pc1 := x0) (ctx' := ctx') (f := f); auto.
  eapply BASE; eauto.
  eapply add_moves_spec; eauto.
    intros. rewrite S1. eapply set_instr_other; eauto. unfold node; xomega.
    xomega. xomega.
  eapply rec_spec; eauto.
    red; intros. rewrite PTree.grspec in H. destruct (PTree.elt_eq id0 id); try discriminate. auto.
    simpl. subst s2; simpl in *; xomega.
    simpl. subst s3; simpl in *; xomega.
    simpl. xomega.
    simpl. apply align_divides. apply min_alignment_pos.
    assert (dstk ctx + mstk ctx <= dstk ctx'). simpl. apply align_le. apply min_alignment_pos. omega.
    omega.
    intros. simpl in H. rewrite S1.
    transitivity (s1.(st_code)!pc0). eapply set_instr_other; eauto. unfold node in *; xomega.
    eapply add_moves_unchanged; eauto. unfold node in *; xomega. xomega.
  red; simpl. subst s2; simpl in *. xomega.
  red; simpl. split. auto. apply align_le. apply min_alignment_pos.
(* tailcall *)
  destruct (can_inline fe s1) as [|id f P Q].
  (* not inlined *)
  destruct (retinfo ctx) as [[rpc rreg] | ] eqn:?.
  (* turned into a call *)
  eapply tr_tailcall_call; eauto.
  (* preserved *)
  eapply tr_tailcall; eauto.
  (* inlined *)
  subst s1.
  monadInv EXP. unfold inline_function in EQ; monadInv EQ.
  set (ctx' := tailcontext ctx x1 x2 (max_reg_function f) (fn_stacksize f)) in *.
  inversion EQ0; inversion EQ1; inversion EQ. inv_incr.
  apply tr_tailcall_inlined with (pc1 := x0) (ctx' := ctx') (f := f); auto.
  eapply BASE; eauto.
  eapply add_moves_spec; eauto.
    intros. rewrite S1. eapply set_instr_other; eauto. unfold node; xomega. xomega. xomega.
  eapply rec_spec; eauto.
    red; intros. rewrite PTree.grspec in H. destruct (PTree.elt_eq id0 id); try discriminate. auto.
    simpl. subst s3; simpl in *. subst s2; simpl in *. xomega.
    simpl. subst s3; simpl in *; xomega.
    simpl. xomega.
    simpl. apply align_divides. apply min_alignment_pos.
    assert (dstk ctx <= dstk ctx'). simpl. apply align_le. apply min_alignment_pos. omega.
    omega.
    intros. simpl in H. rewrite S1.
    transitivity (s1.(st_code))!pc0. eapply set_instr_other; eauto. unfold node in *; xomega.
    eapply add_moves_unchanged; eauto. unfold node in *; xomega. xomega.
  red; simpl.
subst s2; simpl in *; xomega.
  red; auto.
(* builtin *)
  eapply tr_builtin; eauto. destruct b; eauto.
(* return *)
  destruct (retinfo ctx) as [[rpc rreg] | ] eqn:?.
  (* inlined *)
  eapply tr_return_inlined; eauto.
  (* unchanged *)
  eapply tr_return; eauto.
Qed.

Lemma iter_expand_instr_spec:
  forall ctx l s x s' i c,
  mlist_iter2 (expand_instr fe rec ctx) l s = R x s' i ->
  list_norepet (List.map (@fst _ _) l) ->
  (forall pc instr r, In (pc, instr) l -> instr_defs instr = Some r -> Ple r ctx.(mreg)) ->
  (forall pc instr, In (pc, instr) l -> Plt (spc ctx pc) s.(st_nextnode)) ->
  Ple (ctx.(dreg) + ctx.(mreg)) s.(st_nextreg) ->
  ctx.(mstk) >= 0 -> ctx.(dstk) >= 0 ->
  s'.(st_stksize) <= stacksize ->
  (forall pc', Ple s.(st_nextnode) pc' -> Plt pc' s'.(st_nextnode) -> c!pc' = s'.(st_code)!pc') ->
  (forall pc instr, In (pc, instr) l -> c!(spc ctx pc) = s'.(st_code)!(spc ctx pc)) ->
  forall pc instr, In (pc, instr) l -> tr_instr ctx pc instr c.
Proof.
  induction l; simpl; intros.
  (* base case *)
  contradiction.
  (* inductive case *)
  destruct a as [pc1 instr1]; simpl in *. inv H0. monadInv H. inv_incr.
  assert (A: Ple ctx.(dpc) s0.(st_nextnode)).
    assert (B: Plt (spc ctx pc) (st_nextnode s)) by eauto.
    unfold spc in B. generalize (shiftpos_above pc (dpc ctx)). xomega.
  destruct H9. inv H.
  (* same pc *)
  eapply expand_instr_spec; eauto.
  omega.
  intros.
    transitivity ((st_code s')!pc').
    apply H7. auto. xomega.
    eapply iter_expand_instr_unchanged; eauto.
    red; intros. rewrite list_map_compose in H9. exploit list_in_map_inv; eauto.
    intros [[pc0 instr0] [P Q]]. simpl in P.
    assert (Plt (spc ctx pc0) (st_nextnode s)) by eauto. xomega.
  transitivity ((st_code s')!(spc ctx pc)).
    eapply H8; eauto.
    eapply iter_expand_instr_unchanged; eauto.
    assert (Plt (spc ctx pc) (st_nextnode s)) by eauto. xomega.
    red; intros. rewrite list_map_compose in H. exploit list_in_map_inv; eauto.
    intros [[pc0 instr0] [P Q]]. simpl in P.
    assert (pc = pc0) by (eapply shiftpos_inj; eauto). subst pc0.
    elim H12. change pc with (fst (pc, instr0)). apply List.in_map; auto.
  (* older pc *)
  inv_incr. eapply IHl; eauto.
  intros. eapply Plt_le_trans. eapply H2. right; eauto. xomega.
  intros; eapply Ple_trans; eauto.
  intros. apply H7; auto. xomega.
Qed.

Lemma expand_cfg_rec_spec:
  forall ctx f s x s' i c,
  expand_cfg_rec fe rec ctx f s = R x s' i ->
  Ple (ctx.(dpc) + max_pc_function f) s.(st_nextnode) ->
  ctx.(mreg) = max_reg_function f ->
  Ple (ctx.(dreg) + ctx.(mreg)) s.(st_nextreg) ->
  ctx.(mstk) >= 0 ->
  ctx.(mstk) = Zmax (fn_stacksize f) 0 ->
  (min_alignment (fn_stacksize f) | ctx.(dstk)) ->
  ctx.(dstk) >= 0 ->
  s'.(st_stksize) <= stacksize ->
  (forall pc', Ple ctx.(dpc) pc' -> Plt pc' s'.(st_nextnode) -> c!pc' = s'.(st_code)!pc') ->
  tr_funbody ctx f c.
Proof.
  intros. unfold expand_cfg_rec in H. monadInv H. inversion EQ.
  constructor.
  intros. rewrite H1. eapply max_reg_function_params; eauto.
  intros. exploit ptree_mfold_spec; eauto. intros [INCR' ITER].
  eapply iter_expand_instr_spec; eauto.
    apply PTree.elements_keys_norepet.
    intros. rewrite H1. eapply max_reg_function_def with (i := instr); eauto.
    eapply PTree.elements_complete; eauto.
  intros.
    assert (Ple pc0 (max_pc_function f)).
      eapply max_pc_function_sound. eapply PTree.elements_complete; eauto.
      eapply Plt_le_trans. apply shiftpos_below. subst s0; simpl; xomega.
  subst s0; simpl; auto.
  intros. apply H8; auto. subst s0; simpl in H11; xomega.
  intros. apply H8. apply shiftpos_above.
  assert (Ple pc0 (max_pc_function f)).
    eapply max_pc_function_sound. eapply PTree.elements_complete; eauto.
  eapply Plt_le_trans. apply shiftpos_below. inversion i; xomega.
  apply PTree.elements_correct; auto.
  auto. auto. auto.
  inversion INCR0. subst s0; simpl in STKSIZE; xomega.
Qed.

End EXPAND_INSTR.

Lemma expand_cfg_unchanged:
  forall fe ctx f s x s' i pc,
  expand_cfg fe ctx f s = R x s' i ->
  Ple ctx.(dpc) s.(st_nextnode) ->
  Plt pc ctx.(dpc) ->
  s'.(st_code)!pc = s.(st_code)!pc.
Proof.
  intros fe0; pattern fe0. apply well_founded_ind with (R := ltof _ size_fenv).
  apply well_founded_ltof.
  intros. unfold expand_cfg in H0. rewrite unroll_Fixm in H0.
  eapply expand_cfg_rec_unchanged; eauto. assumption.
Qed.

Lemma expand_cfg_spec:
  forall fe ctx f s x s' i c,
  expand_cfg fe ctx f s = R x s' i ->
  fenv_agree fe ->
  Ple (ctx.(dpc) + max_pc_function f) s.(st_nextnode) ->
  ctx.(mreg) = max_reg_function f ->
  Ple (ctx.(dreg) + ctx.(mreg)) s.(st_nextreg) ->
  ctx.(mstk) >= 0 ->
  ctx.(mstk) = Zmax (fn_stacksize f) 0 ->
  (min_alignment (fn_stacksize f) | ctx.(dstk)) ->
  ctx.(dstk) >= 0 ->
  s'.(st_stksize) <= stacksize ->
  (forall pc', Ple ctx.(dpc) pc' -> Plt pc' s'.(st_nextnode) -> c!pc' = s'.(st_code)!pc') ->
  tr_funbody ctx f c.
Proof.
  intros fe0; pattern fe0. apply well_founded_ind with (R := ltof _ size_fenv).
  apply well_founded_ltof.
  intros. unfold expand_cfg in H0. rewrite unroll_Fixm in H0.
  eapply expand_cfg_rec_spec; eauto.
  simpl. intros. eapply expand_cfg_unchanged; eauto. assumption.
Qed.

End INLINING_BODY_SPEC.

End INLINING_SPEC.

(** ** Relational specification of the translation of a function *)

Inductive tr_function: program -> function -> function -> Prop :=
  | tr_function_intro: forall p fenv f f' ctx,
      fenv_compat p fenv ->
      tr_funbody fenv f'.(fn_stacksize) ctx f f'.(fn_code) ->
      ctx.(dstk) = 0 ->
      ctx.(retinfo) = None ->
      f'.(fn_sig) = f.(fn_sig) ->
      f'.(fn_params) = sregs ctx f.(fn_params) ->
      f'.(fn_entrypoint) = spc ctx f.(fn_entrypoint) ->
      0 <= fn_stacksize f' < Ptrofs.max_unsigned ->
      tr_function p f f'.

Lemma tr_function_linkorder:
  forall cunit prog f f',
  linkorder cunit prog ->
  tr_function cunit f f' ->
  tr_function prog f f'.
Proof.
  intros. inv H0. econstructor; eauto. eapply fenv_compat_linkorder; eauto.
Qed.

Lemma transf_function_spec:
  forall cunit f f',
  transf_function (funenv_program cunit) f = OK f' ->
  tr_function cunit f f'.
Proof.
  intros. unfold transf_function in H.
  set (fenv := funenv_program cunit) in *.
  destruct (expand_function fenv f initstate) as [ctx s i] eqn:?.
  destruct (zlt (st_stksize s) Ptrofs.max_unsigned); inv H.
  monadInv Heqr. set (ctx := initcontext x x0 (max_reg_function f) (fn_stacksize f)) in *.
Opaque initstate.
  destruct INCR3. inversion EQ1. inversion EQ.
  apply tr_function_intro with fenv ctx; auto.
  apply funenv_program_compat.
  eapply expand_cfg_spec with (fe := fenv); eauto.
    red; auto.
    unfold ctx; rewrite <- H1; rewrite <- H2; rewrite <- H3; simpl. xomega.
    unfold ctx; rewrite <- H0; rewrite <- H1; simpl. xomega.
    simpl. xomega.
    simpl. apply Zdivide_0.
    simpl. omega.
  simpl. omega.
  simpl. split; auto. destruct INCR2. destruct INCR1. destruct INCR0. destruct INCR.
  simpl. change 0 with (st_stksize initstate). omega.
Qed.


Require Export ExtrOcamlBasic ExtrOcamlNatInt ExtrOcamlString ExtrOcamlZInt.

(* Work around the fact that Decimal declares a type "int" *)
Extract Inductive nat => "OCamlNativeInt.t" [ "0" "Pervasives.succ" ]
 "(fun fO fS n -> if n=0 then fO () else fS (n-1))".

Extract Inductive prod => "(*)"  [ "(,)" ].

Extract Constant Coq.Init.Nat.ltb => "(<)".
Extract Constant Coq.Init.Nat.leb => "(<=)".

(* ExtrOCamlNatInt uses Pervasives.max, which is slow *)
Extract Constant Nat.sub =>
  "fun (x: OCamlNativeInt.t) (y: OCamlNativeInt.t) ->
if x <= y then 0 else (x - y)".

(** A few additional tweaks *)

Require Import Fiat.Common.String_as_OT.
Require Import Coq.Structures.OrderedTypeEx.

Extraction Inline negb.
Extract Inductive Bool.reflect => bool [ true false ].

Extract Constant Coq.Strings.String.string_dec  => "(=)".
Extract Constant String_as_OT.eq_dec  => "(=)".
Extract Constant Nat_as_OT.eq_dec => "(=)".

Extract Constant String_as_OT.compare => "fun a b -> let comp = compare a b in
                                          if comp = 0 then EQ else if comp < 0 then LT else GT".
Extract Constant Nat_as_OT.compare    => "fun (a: int) (b: int) -> let comp = compare a b in
                                          if comp = 0 then EQ else if comp < 0 then LT else GT".
Extract Constant String_as_OT.string_compare => "fun a b -> let comp = compare a b in
                                                 if comp = 0 then Eq else if comp < 0 then Lt else Gt".

(** * Inline a few functions *)
Require Import
        Fiat.Narcissus.BinLib.AlignedDecodeMonad
        Fiat.Narcissus.BinLib.AlignedEncodeMonad.
Extraction Inline fst snd Basics.compose.
Extraction Inline Projection_AlignedEncodeM.
Extraction Inline GetCurrentByte SetCurrentByte.
Extraction Inline BindAlignedDecodeM ReturnAlignedDecodeM ThrowAlignedDecodeM.
Extraction Inline AppendAlignedEncodeM ReturnAlignedEncodeM ThrowAlignedEncodeM.
Extraction Inline Common.If_Opt_Then_Else AlignedByteString.LetIn.

(** * Extract words as int64
      (Only works for words with length < 64) *)

Require Import Word.
Require Import BinLib.AlignWord.

Extract Inductive word =>
"Int64Word.t"
  ["(Int64Word.w0)" "Int64Word.ws"]
  "Int64Word.destruct".

Extract Inlined Constant Core.char => "Int64Word.t".

Extract Inlined Constant whd => "Int64Word.whd".
Extract Inlined Constant wtl => "Int64Word.wtl".
Extract Inlined Constant zext => "Int64Word.zext".
Extract Inlined Constant wplus => "Int64Word.wplus".
Extract Inlined Constant wmult => "Int64Word.wmult".
Extract Inlined Constant wminus => "Int64Word.wminus".
Extract Inlined Constant weq => "Int64Word.weq".
Extract Inlined Constant weqb => "Int64Word.weqb".
Extract Inlined Constant wlt => "Int64Word.wlt".
Extract Inlined Constant wlt_dec => "Int64Word.wlt_dec".
Extract Inlined Constant wand => "Int64Word.wand".
Extract Inlined Constant wor => "Int64Word.wor".
Extract Inlined Constant wnot => "Int64Word.wnot".
Extract Inlined Constant wneg => "Int64Word.wneg".
Extract Inlined Constant wordToNat => "Int64Word.wordToNat".
Extract Inlined Constant natToWord => "Int64Word.natToWord".
Extract Inlined Constant wordToN => "Int64Word.wordToN".
Extract Inlined Constant NToWord => "Int64Word.nToWord".
Extract Inlined Constant wzero => "Int64Word.wzero".
Extract Inlined Constant wzero' => "Int64Word.wzero'".
Extract Inlined Constant wones => "Int64Word.wones".

Extract Inlined Constant WordOpt.word_split_hd => "Int64Word.word_split_hd".
Extract Inlined Constant WordOpt.word_split_tl => "Int64Word.word_split_tl".
Extract Inlined Constant split1' => "Int64Word.split1'".
Extract Inlined Constant split2' => "Int64Word.split2'".
Extract Inlined Constant split1 => "Int64Word.split1".
Extract Inlined Constant split2 => "Int64Word.split2".
Extract Inlined Constant WordOpt.SW_word => "Int64Word.SW_word".
Extract Inlined Constant combine => "Int64Word.combine".
Extract Inlined Constant Core.append_word => "Int64Word.append".

Extract Inlined Constant PeanoNat.Nat.div => "(/)".

Definition word_split_hd_test := WordOpt.word_split_hd (natToWord 5 30).
Definition word_split_tl_test := wordToNat (WordOpt.word_split_tl (natToWord 5 30)).
Definition alignword_split1'_test := wordToNat (AlignWord.split1' 2 3 (natToWord 5 30)).
Definition alignword_split2'_test := wordToNat (AlignWord.split2' 2 3 (natToWord 5 30)).
Definition split1_test := wordToNat (split1 3 2 (natToWord 5 30)).
Definition split2_test := wordToNat (split2 3 2 (natToWord 5 30)).
Definition combine_test := wordToNat (combine (natToWord 5 30) (natToWord 7 14)).
Definition append_word_test := wordToNat (Core.append_word (@natToWord 8 5) (@natToWord 12 126)).

(** * Special case of internet checksum *)
Require Import Narcissus.Formats.InternetChecksum.
Extract Constant InternetChecksum.OneC_plus => "Int64Word.onec_plus".

(** Efficient bytestrings *)

Extract Inductive Fin.t =>
"ArrayVector.idx_t"
  ["ArrayVector.zero" "ArrayVector.succ"]
  "ArrayVector.destruct_idx".

Extract Inlined Constant Fin.L => "(fun _ n p -> p)".
Extract Inlined Constant Fin.R => "(fun _ n p -> n + p)".
Extract Inlined Constant Fin.eqb => "(fun _ _ n p -> n = p)".

(* Extract Inductive Vector.t => *)
(* "StackVector.t" *)
(*   ["StackVector.empty ()" "StackVector.cons"] *)
(*   "StackVector.destruct". *)

(* Extract Inductive VectorDef.t => *)
(* "StackVector.t" *)
(*   ["StackVector.empty ()" "StackVector.cons"] *)
(*   "StackVector.destruct". *)

(* Extract Inlined Constant Vector.nth => "StackVector.nth". *)
(* Extract Inlined Constant VectorDef.nth => "StackVector.nth". *)
(* Extract Inlined Constant AlignedDecodeMonad.Vector_nth_opt => "StackVector.nth_opt". *)
(* Extract Inlined Constant EnumOpt.word_indexed => "StackVector.index". *)

(* CPC clean up CstructBytestring.ml to remove unneeded stuff *)

Require Import Fiat.Narcissus.BinLib.AlignedByteString.
Require Import Fiat.Narcissus.BinLib.AlignedByteBuffer.
Extract Constant ByteBuffer.t => "CstructBytestring.storage_t".
Extract Inlined Constant ByteBuffer.t => "CstructBytestring.storage_t".
Extract Inlined Constant ByteBuffer.nil => "CstructBytestring.nil".
Extract Inlined Constant ByteBuffer.cons => "CstructBytestring.cons".
Extract Inlined Constant ByteBuffer.hd => "CstructBytestring.hd".
Extract Inlined Constant ByteBuffer.tl => "CstructBytestring.tl".
Extract Inlined Constant ByteBuffer.to_list => "CstructBytestring.to_list".
Extract Inlined Constant ByteBuffer.of_list => "CstructBytestring.of_list".
Extract Inlined Constant ByteBuffer.of_vector => "CstructBytestring.of_vector".
Extract Inlined Constant ByteBuffer.to_vector => "CstructBytestring.to_vector".
Extract Inlined Constant ByteBuffer.fold_left => "CstructBytestring.fold_left".
Extract Inlined Constant ByteBuffer.append => "CstructBytestring.append".
Extract Inlined Constant ByteBuffer.drop => "CstructBytestring.drop".
Extract Inlined Constant nth_opt => "CstructBytestring.nth_opt".
Extract Inlined Constant set_nth' => "CstructBytestring.set_nth".
Extract Inlined Constant initialize_Aligned_ByteString => "CstructBytestring.create".
Extract Inlined Constant InternetChecksum.ByteBuffer_checksum_bound => "CstructBytestring.checksum_bound".
Extract Inlined Constant AlignedByteBuffer.buffer_blit_buffer => "CstructBytestring.blit_buffer".
Extract Constant AlignedByteBuffer.bytebuffer_of_bytebuffer_range =>
  "(fun sz from len v ->
    let b = CstructBytestring.slice_range sz from len v in
    ExistT (CstructBytestring.length b, b))".


From iVM Require Export StateRel.
Require Import Coq.Logic.ProofIrrelevance.

Unset Suggest Proof Using.

(** We leave these assumptions abstract in order improve proof search.
    In Concete.v we have shown that they hold in our standard model. *)
Declare Instance MP1: MachineParams1.
Declare Instance MP2: MachineParams2.
Include CoreRel.

(** ** Basic monotonicity *)

(** Additional assumptions *)
Declare Instance RM X (RX: Rel X) : Rel (M X).
Declare Instance PM : SMonadPropR State M (RM:=RM).

Proposition bind_propr'
            {X Y} {RX: Rel X} {RY: Rel Y}
            {mx mx': M X} (Hmx: mx ⊑ mx')
            {f f': X -> M Y} (Hf: f ⊑ f') : mx >>= f ⊑ mx' >>= f'.
Proof.
  exact (bind_propr State M RX RY mx mx' Hmx f f' Hf).
Qed.

Ltac crush0 :=
  match goal with
  | [ |- ret _ ⊑ ret _ ] => unshelve eapply ret_propr; [apply PM|]
  | [|- err ⊑ _] => unshelve eapply err_least, PM
  | [ |- get ⊑ get ] => unshelve eapply get_propr, PM
  | [ |- put _ ⊑ put _ ] => unshelve eapply put_propr; [apply PM|]

  | [|- ?x ⊑ ?x] => try reflexivity;
                  unshelve eapply propR;
                  match goal with [|- PropR x] => fail end

  | [H : rel eq_relation ?x ?y |- _] => cbv in H; first [subst x|subst y]

  | [|- rel (option_relation _) None _] => exact I
  | [H: rel (option_relation _) (Some _) None |- _] => destruct H
  | [x: _ * _ |- _] => destruct x; simpl fst; simpl snd
  | [H: rel (prod_relation _ _) _ _ |- _] => destruct H

  | [|- rel (fun_relation _ _) ?a _] =>
    match type of a with
    | State -> _ =>
      let x := fresh "s" in
      let y := fresh "t" in
      let Hxy := fresh "Hst" in
      intros x y Hxy
    | Image _ -> _ =>
      let x := fresh "i" in
      let y := fresh "j" in
      let Hxy := fresh "Hij" in
      intros x y Hxy
    | Memory -> _ => (* TODO: Merge with next case *)
      let x := fresh "f" in
      let y := fresh "g" in
      let Hxy := fresh "Hfg" in
      intros x y Hxy
    | (_ -> _) -> _ =>
      let x := fresh "f" in
      let y := fresh "g" in
      let Hxy := fresh "Hfg" in
      intros x y Hxy
    | _ -> _ =>
      let x := fresh "x" in
      let y := fresh "y" in
      let Hxy := fresh "Hxy" in
      intros x y Hxy
    end

  | [|- match ?H with left _ => _ | right _ => _ end ⊑ _] =>
    let HL := fresh "HL" in
    let HR := fresh "HR" in
    destruct H as [HL|HR]

  | [|- _ ⊑ match ?H with left _ => _ | right _ => _ end] =>
    let HL := fresh "HL" in
    let HR := fresh "HR" in
    destruct H as [HL|HR]

  | [|- (match ?H with left _ => _ | right _ => _ end) >>= _ ⊑ _] =>
    let HL := fresh "HL" in
    let HR := fresh "HR" in
    destruct H as [HL|HR];
    [ repeat rewrite ret_bind
    | repeat rewrite err_bind ]

  | [|- _ ⊑ (match ?H with left _ => _ | right _ => _ end) >>= _] =>
    let HL := fresh "HL" in
    let HR := fresh "HR" in
    destruct H as [HL|HR];
    [ repeat rewrite ret_bind
    | repeat rewrite err_bind ]

  | [|- match ?H with Some _ => _ | None => _ end ⊑ _] =>
    let u := fresh "u" in
    let Hu := fresh "Hu" in
    destruct H as [u|] eqn:Hu

  | [|- _ ⊑ match ?H with Some _ => _ | None => _ end] =>
    let v := fresh "v" in
    let Hv := fresh "Hv" in
    destruct H as [v|] eqn:Hv

  | [|- rel memory_relation _ _] =>
    let a := fresh "a" in
    let Ha := fresh "Ha" in
    intros a Ha

  | [ |- (_ >>= _) >>= _ ⊑ _ ] => setoid_rewrite bind_assoc
  | [ |- _ ⊑ (_ >>= _) >>= _ ] => setoid_rewrite bind_assoc
  | [ |- _ >>= _ ⊑ _ >>= _ ] => apply bind_propr'

  | _ => exact eq_refl
  | _ => progress unfold PropR
  end.

(** TODO: Useful? *)
Instance assume_propr P {DP: Decidable P} : PropR (assume P).
Proof.
  repeat crush0.
Qed.

(** *** Get *)

Local Ltac get_tactic :=
  rewrite get_spec; simpl; repeat crush0;
  match goal with [ H: _ ⊑ _ |- _ ] => srel_destruct H end;
  try assumption.

Instance getMem_propr : PropR (get' MEM).
Proof. get_tactic. apply Hst_mem. Qed.

Instance getImg_propr : PropR (get' OUT_IMAGE).
Proof. get_tactic. Qed.

Instance getByt_propr: PropR (get' OUT_BYTES).
Proof. get_tactic. Qed.

Instance getChr_propr: PropR (get' OUT_CHARS).
Proof. get_tactic. Qed.

Instance getSnd_propr: PropR (get' OUT_SOUND).
Proof. get_tactic. Qed.

Instance getLog_propr: PropR (get' LOG).
Proof. get_tactic. Qed.

Instance getInp_propr: PropR (get' INP).
Proof. get_tactic. Qed.

Instance getPc_propr: PropR (get' PC).
Proof. get_tactic. Qed.

Instance getSp_propr: PropR (get' SP).
Proof. get_tactic. Qed.

(** *** Put *)

Local Ltac put_tactic :=
  rewrite put_spec; simpl; repeat crush0;
  match goal with [ H: _ ⊑ _ |- _ ] => srel_destruct H end;
  repeat split;
  unfold lens_relation;
  repeat (lens_rewrite1 || simpl);
  reflexivity || assumption.

Instance putMem_propr : PropR (put' MEM).
Proof. put_tactic. Qed.

Instance putImg_propr : PropR (put' OUT_IMAGE).
Proof. put_tactic. Qed.

Instance putByt_propr: PropR (put' OUT_BYTES).
Proof. put_tactic. Qed.

Instance putChr_propr: PropR (put' OUT_CHARS).
Proof. put_tactic. Qed.

Instance putSnd_propr: PropR (put' OUT_SOUND).
Proof. put_tactic. Qed.

Instance putLog_propr: PropR (put' LOG).
Proof. put_tactic. Qed.

Instance putInp_propr: PropR (put' INP).
Proof. put_tactic. Qed.

Instance putPc_propr: PropR (put' PC).
Proof. put_tactic. Qed.

Instance putSp_propr: PropR (put' SP).
Proof. put_tactic. Qed.

(** *** Crush *)

Ltac crush1 :=
  match goal with
  | [|- put' MEM _ ⊑ put' MEM _] => unshelve eapply putMem_propr
  | [|- put' OUT_IMAGE _ ⊑ put' OUT_IMAGE _] => unshelve eapply putImg_propr
  | [|- put' OUT_BYTES _ ⊑ put' OUT_BYTES _] => unshelve eapply putByt_propr
  | [|- put' OUT_CHARS _ ⊑ put' OUT_CHARS _] => unshelve eapply putChr_propr
  | [|- put' OUT_SOUND _ ⊑ put' OUT_SOUND _] => unshelve eapply putSnd_propr
  | [|- put' LOG _ ⊑ put' LOG _] => unshelve eapply putLog_propr
  | [|- put' INP _ ⊑ put' INP _] => unshelve eapply putInp_propr
  | [|- put' PC _ ⊑ put' PC _] => unshelve eapply putPc_propr
  | [|- put' SP _ ⊑ put' SP _] => unshelve eapply putSp_propr

  | _ => crush0
  end.

Ltac crush := repeat crush1.

Instance pointwise_propr {X Y} (f: X -> Y) {RY: Rel Y} (H: forall x, PropR (f x)) : PropR f.
Proof. crush. Qed.

(** In other words, there is no less of generality instatiating
arguments for which the relation is simply [eq]. On the contrary, this
improves proof search. *)

(** ** Monotone operations *)

Instance extr_propr {X} {RX: Rel X} : PropR (extr (X:=X)).
Proof.
  rewrite extr_spec.
  crush.
  exact Hxy.
Qed.

Instance load_propr a : PropR (load a).
Proof.
  rewrite load_spec.
  crush.
  apply extr_propr, Hfg.
Qed.

Instance loadMany_propr n a : PropR (loadMany n a).
Proof.
  revert a; induction n; intros a; simp loadMany; crush.
Qed.

Instance next_propr n : PropR (next n).
Proof. induction n; simp next; crush. Qed.

Instance store_propr a o : PropR (store a o).
Proof.
  rewrite store_spec.
  crush.
  apply Hfg.
Qed.

Instance storeMany_propr a lst : PropR (storeMany a lst).
Proof.
  revert a.
  induction lst as [|x r IH]; intros a;
    simp storeMany; crush.
Qed.

Instance push_propr u : PropR (push u).
Proof.
  rewrite push_spec.
  crush.
Qed.

Instance pushManyR_propr u : PropR (pushManyR u).
Proof.
  induction u; simp pushManyR; crush.
Qed.

Instance pushMany_propr u : PropR (pushMany u).
Proof. rewrite pushMany_spec. crush. Qed.

Instance pop_propr : PropR pop.
Proof.
  rewrite pop_spec. crush.
Qed.

Instance popMany_propr n : PropR (popMany n).
Proof.
  induction n; simp popMany; crush.
Qed.

Instance pop64_propr: PropR pop64.
Proof. unfold pop64. crush. Qed.

Instance pushZ_propr z: PropR (pushZ z).
Proof. unfold pushZ. crush. Qed.

Instance storeZ_propr n a z : PropR (storeZ n a z).
Proof. unfold storeZ. crush. Qed.

Local Open Scope N.

Instance setPixel_propr x y c : PropR (setPixel x y c).
Proof.
  rewrite setPixel_spec. unfold updatePixel.
  crush;
    destruct Hij as [Hw [Hh Hi]];
    [ | congruence | congruence ].
  exists Hw. exists Hh. intros x' Hx' y' Hy'. simpl.
  destruct (decide (x' = x /\ y' = y)).
  - reflexivity.
  - exact (Hi x' Hx' y' Hy').
Qed.

Instance readPixel_propr x y : PropR (readPixel x y).
Proof. rewrite readPixel_spec. crush. Qed.

Lemma image_complete_lemma
      {i i': Image (option OutputColor)}
      (Hi: i ⊑ i') (Hc: image_complete i) : i = i'.
Proof.
  destruct i as [w h p].
  destruct i' as [w' h' p'].
  destruct Hi as [Hw [Hh Hp]].
  simpl in *. subst w'. subst h'.
  apply f_equal.
  extensionality x. extensionality Hx.
  extensionality y. extensionality Hy.
  specialize (Hp x Hx y Hy). simpl in Hp.
  specialize (Hc x Hx y Hy). simpl in Hc.
  rewrite <- (some_extract Hc) in *.
  destruct (p' x Hx y Hy) as [c'|].
  - unfold rel in Hp.
    destruct (extract Hc) as [[r g] b].
    destruct c' as [[r' g'] b'].
    cbn in Hp.
    destruct Hp as [[Hr Hg] Hb].
    crush.
  - crush.
Qed.

Instance newFrame_propr w h r: PropR (newFrame w h r).
Proof.
  rewrite newFrame_spec, extractImage_spec.
  crush; destruct (image_complete_lemma Hij HL).
  - destruct (proof_irrelevance _ HL HL0). reflexivity.
  - contradict HR. exact HL.
Qed.

Close Scope N.

(** ** Monotone steps *)

#[global] Instance oneStep_propr : PropR oneStep.
Proof.
  unfold oneStep. crush.
  destruct (y: Z) eqn:Hy;
    [ crush; reflexivity | | simp oneStep'; crush].

  (* Is there a more elegant way to do this. *)
  unfold oneStep'.
  repeat (match goal with
            [|- context [match _ with xI _ => _ | xO _ => _ | xH => _ end]] =>
            destruct p end).
  all:
    try rewrite putByte_spec;
    try rewrite putChar_spec;
    try rewrite addSample_spec;
    try rewrite readFrame_spec;
    crush.
Qed.

#[global] Instance nSteps_propr n : PropR (nSteps n).
Proof.
  induction n; simp nSteps; unfold chain; crush.
  destruct y; crush.
Qed.


Require Import ZArith.
Require Import String.
Require Import Flocq.Appli.Fappli_IEEE_bits.

Require Import v1.NeutronTactics.
Require Import v1.Multi.
Require Import v1.FloatAux.

Require Import epics.SpecTypes.
Require epics.Opcodes.
Require epics.SpecDenote.
Require epics.SpecRecords.
Require epics.Records.
Require epics.Types.
Require epics.Termination.
Require epics.Wf.
Require floatabs.AbsInt.
Require floatabs.Generate.
Require floatabs.Records.
Require validate.Validate.

(* Make the extracted code a little nicer. *)
Require Import ExtrHaskellBasic.
Require Import ExtrHaskellNatInteger.
Require Import ExtrHaskellNatNum.
Require Import ExtrHaskellZInteger.
Require Import ExtrHaskellZNum.

Definition typecheck_database dbp :=
    let dbt := epics.Opcodes.database_program_type dbp in
    epics.Wf.check_wfm_database dbt dbp.

(* fix references through a module alias *)
Extract Inductive floatabs.Generate.Abs.record_abs =>
    "Record_abs" [
        "RaCalc"
        "RaCalcOut"
        "RaStrCalcOut"
        "RaArrayCalcOut"
        "RaFanout"
        "RaAnalogIn"
        "RaAnalogOut"
        "RaBinaryIn"
        "RaBinaryOut"
        "RaMBBO"
        "RaStringIn"
        "RaStringOut"
        "RaLongIn"
        "RaLongOut"
        "RaDFanout"
        "RaSeq"
        "RaWaveform"
        "RaSubarray"
        "RaAsyn"
    ].

Extract Inductive floatabs.AbsInt.Abs.calc_abs =>
    "Calc_abs" [
        "CalcAbs"
    ].

Extract Inductive floatabs.AbsInt.Abs.calc_out_abs =>
    "Calc_out_abs" [
        "CalcOutAbs"
    ].

Extract Inlined Constant Peano_dec.eq_nat_dec =>
    "((Prelude.==) :: Prelude.Integer -> Prelude.Integer -> Prelude.Bool)".

Extraction Language Haskell.
Extraction "Query2.hs"
    epics.SpecRecords.record
    epics.SpecRecords.record_config
    epics.SpecRecords.record_state
    epics.SpecOpcodes.record_program

    epics.SpecRecords.database
    epics.SpecRecords.database_config
    epics.SpecRecords.database_state
    epics.SpecOpcodes.database_program

    epics.SpecDenote.compile_database
    typecheck_database

    (* floatabs *)
    floatabs.Generate.float_abs_init
    floatabs.Generate.float_abs_update
    floatabs.Generate.float_abs_truncate
    floatabs.Generate.float_abs_apply_overrides
    floatabs.AbsInt.float_abs_check
    floatabs.Records.float_abs_read_field   (* used for printing *)
    floatabs.Records.record_abs_type

    (* termination / cycle check *)
    epics.Termination.check_database_time
    epics.Termination.check_database_time_with_fuel

    (* trace validator *)
    validate.Validate.validate_trace
    validate.Validate.validate_trace_multi_record
    validate.Validate.validate_trace_event_loop

    (* utility functions *)
    b64_opp b64_plus b64_minus b64_mult b64_div b64_sqrt
    b64_of_bits bits_of_b64
    LONG_MAX
    default_array
    epics.Records.default_record

    (*
    (* types *)
    value in_link out_link fwd_link

    (* functions *)
    init_state run_state enqueue_event
    field_read field_write
    multi_rep multi_get multi_set
    default_array
    LONG_MAX

    compile_dbp
    FloatAbsInt.float_abs_init
    FloatAbsInt.float_abs_update
    FloatAbsInt.float_abs_check
    *)
    .


(** This module proves that the stream transducer semantics defined in
module [Streams] is safe (cf. Theorem 3.2 in the paper). *)

From Coq Require Import Program.Equality Omega.
From SimplyRatt Require Export Streams FundamentalProperty.

From SimplyRatt Require Import Tactics.

Import ListNotations.

(** This is part (i) of Theorem 3.2 in the paper. *)
Theorem causality1 A B k t :
  vtype A ->
  ctx_empty ⊢ t ∶ Box (Arrow (Str A) (Str B)) ->
  trrel A B k (app (unbox t) (adv (ref thel)),heap_empty).
Proof.
  intros VTA Ty. constructor; eauto using closed_heap_empty, typed_closed, heap_empty_fresh.
  intros v w V W.
  assert (ctx_lock ctx_empty ⊢ unbox t ∶ Arrow (Str A) (Str B)) as Ty' by eauto.
  eapply fund_prop with (g:= nil) (Hs := (str_heapseq A k))
                        (s := store_lock (Some (heap_single thel (v ∷ ref thel)))
                                         (heap_single thel (w ∷ ref thel)))
    in Ty';eauto. rewrite sub_empty_app in Ty' by auto. eapply trel_app;
  eauto using typed_closed. eapply trel_adv. auto using mapsto_heap_cons.
  apply vrel_trel. autorewrite with vrel. eexists. split. reflexivity. simpl.
  autorewrite with vrel. do 2 eexists. split. reflexivity. split.
  rewrite vtype_tsubst by auto. eauto using vtype_vrel.
  eapply vrel_mono; try eapply thel_vrel;eauto.
  eapply crel_lock;eauto using str_heapseq_closed.
  eauto using str_heapseq_closed.
  constructor;  eauto using vtype_vrel_closed,closed_heap_alloc, closed_heap_empty.
Qed.

(** This is part (ii) of Theorem 3.2 in the paper. *)
Theorem causality2 A B k s v :
  vtype A -> isvalue v -> ctx_empty ⊢ v ∶ A ->
  trrel A B (S k) s -> exists v' s', tred s v v' s' /\ trrel A B k s'.
Proof.
  intros VTA V Ty TR. inversion TR;subst.
  apply typing_vtype with (Hs:=[]) (s:=store_bot) in Ty; eauto.
  pose (vtype_inhab _ VTA) as W. destruct W as (w&W).
  assert (exists (v' : term) (s : store),
  {t, (store_lock (Some (heap_cons h thel (v ∷ ref thel))) (heap_single thel (w ∷ ref thel)))}⇓ {v', s} /\
  vrel Str (B) (str_heapseq (A) (S k)) s v') as Red.
  eapply H1 with (v:=v); try eassumption;eauto using tick_le_refl,str_heapseq_closed.
  constructor; eauto using vtype_vrel_closed,closed_heap_alloc,closed_heap_empty.

  destruct Red as (v'& s&R&VR).

  pose (red_extensive _ _ _ _ R) as SL. dependent destruction SL.
  eapply red_not_later with (u:=unit) in R; eauto using heap_dom_cons'.
  rewrite heap_cons_eq in R.
  autorewrite with vrel in VR. simpl in VR. destruct VR as (v'' & E & VR). subst.
  autorewrite with vrel in VR. simpl in VR. destruct VR as (v1 & v2 & E & VR). subst.

  do 2 eexists. split. econstructor. apply R. constructor.
  - assert (heap_mapsto thel (w ∷ ref thel) h2') by eauto using mapsto_heap_cons.
    assert (closed_term (w ∷ ref thel)) by eauto using vtype_vrel_closed.
    assert (closed_heap (heap_cons h2' thel unit)). apply red_closed in R;eauto.
    destruct R as [C1 C2]. inversion C2. auto.
    constructor;eauto using closed_heap_empty,closed_heap_alloc,vtype_vrel_closed.
    eauto using closed_heap_cons_rev.
  - destruct VR; eauto using vrel_delay_closed.
  - intros.

    assert (exists (v' : term) (s : store),
               {t, (store_lock (Some (heap_cons h thel (v ∷ ref thel))) (heap_single thel (v0 ∷ ref thel)))}⇓ {v', s} /\
               vrel Str (B) (str_heapseq (A) (S k)) s v') as Red2.

    eapply H1 with (v:=v) (w:=v0); try eassumption;eauto using tick_le_refl,str_heapseq_closed.
  constructor; eauto using vtype_vrel_closed,closed_heap_alloc,closed_heap_empty.

  destruct Red2 as (v'& s&R'&VR').

  pose (red_extensive _ _ _ _ R') as SL. dependent destruction SL.
  eapply red_not_later with (u:=unit) in R'; eauto using heap_dom_cons'.
  rewrite heap_cons_eq in R'.

  pose (red_determ _ _ _ _ _ _ R R') as D. destruct D as [E D]. subst.
  dependent destruction D.

  autorewrite with vrel in VR'. simpl in VR'. destruct VR' as (v'' & E & VR'). subst.
  autorewrite with vrel in VR'. simpl in VR'. destruct VR' as (v1' & v2' & E' & VR1 & VR2). subst.
  dependent destruction E.
  autorewrite with vrel in VR2.  autodest. simpl in H11.
  assert (heap_cons h2' thel (v0 ∷ ref thel) = h2'0) as HR by
        (eapply heap_overwrite; eauto using mapsto_heap_cons).
  rewrite HR.
  dependent destruction H9. eapply trel_adv;eauto.
  eapply H10. constructor. eauto using vtype_vrel_closed. assumption.
Qed.


From elpi Require Import elpi.
From Nominal Require Import Atom.

Elpi Db atom.sort.db lp:{{
%  kind atom type.
%  type atom id -> atom.

  pred atom-sort o:id.

  :name "atom.fail"
  atom-sort _ :- coq.error "NOMINAL-ERROR: No atom-sort defined.".
}}.

(* Define new atomic name *)
Elpi Command declare_name.
Elpi Accumulate Db atom.sort.db.
Elpi Accumulate declare_name lp:{{
  main [str X] :-
    coq.elpi.accumulate _ "atom.sort.db" (clause _ (before "atom.fail") (atom-sort X)),
    coq.notation.add-abbreviation X 0 {{ Atom.t }} ff _.
%    coq.say "ANA new name".

  main _ :- coq.say "Usage: declare_name [name]".
}}.
Elpi Typecheck.

Elpi declare_name Name.

Elpi Command Nominal.
Elpi Accumulate lp:{{

  pred indt-change-name i:indt-decl, o:indt-decl.
  indt-change-name (inductive A B C D) (inductive AR B C D) :- AR is A ^ "_raw".

  main [indt-decl I] :- coq.say I.

  main _ :- coq.error "Not an inductive type.".
}}.
Elpi Typecheck.
Elpi Export Nominal.

Nominal Inductive lam : Set :=
| Var : Name -> lam
| App : lam -> lam -> lam
| Abs : Name -> lam -> lam.
Print lam_ind.

Print lam_rect.

Definition lapps (P : lam → Type) (f0 : ∀ l : lam, P l → ∀ l0 : lam, P l0 → P (App l l0))
  l0 (F1: P l0) l1 (F2: P l1) := f0 l0 F1 l1 F2.

Definition F := λ (P : lam → Type) (f : ∀ t : Name, P (Var t))
  (f0 : ∀ l : lam, P l → ∀ l0 : lam, P l0 → P (App l l0))
  (f1 : ∀ (t : Name) (l : lam), P l → P (Abs t l)),
  fix F (l : lam) : P l :=
    match l as l0 return (P l0) with
    | Var t => f t
    | App l0 l1 => lapps P f0 l0 (F l0) l1 (F l1)
    | Abs t l0 => f1 t l0 (F l0)
    end.
Print F.

Elpi Command declare_constructor.
Elpi Db constructor.db lp:{{
  kind arity type.
  kind data type.

}}.

Elpi declare_name.
Elpi declare_name Name.
Check Name.

Elpi declare_name.

Inductive Arity :=
| ar_unit: Arity
| ar_name: Name -> Arity
| ar_data: Data -> Arity
| ar_pair: Arity -> Arity -> Arity
| ar_bind: Name -> Arity -> Arity.

Elpi Command declare_constructor.
Elpi Accumulate lp:{{
  main [str Name, str Arity, str, Result]
}}

Open Scope string_scope.

Definition Name: Set := string.
Definition Data: Set := string.

Inductive Arity :=
| ar_unit: Arity
| ar_name: Name -> Arity
| ar_data: Data -> Arity
| ar_pair: Arity -> Arity -> Arity
| ar_bind: Name -> Arity -> Arity.

Declare Scope signature.
Delimit Scope signature with sig.

Notation "⟨ a ⟩ b" := (ar_bind a b)%sig (at level 60).
Notation "a *' b" := (ar_pair a b)%sig (at level 65).

Record Constructor : Set :=
  mK { name: Name; arity: Arity; result: Data}.

Notation "N : a ->c d" := (mK N%string a d%string) (at level 70).

Definition V: Constructor := mK "V" (ar_name "v") "t".
Check ("V" : (ar_name "v") ->c "t").

Record Σ: Set :=
  {ΣA: Name; ΣD: list Data; ΣC: list Constructor}.

Require Import MetaCoq.Template.All.
Require Import MetaCoq.Template.Pretty.
Import MonadNotation.

Open Scope string_scope.
MetaCoq Run (tmQuoteInductive "nat" >>= tmPrint).

Inductive TΣ : Set :=
|


(******************************************************************************)
(* PipeCheck: Specifying and Verifying Microarchitectural                     *)
(* Enforcement of Memory Consistency Models                                   *)
(*                                                                            *)
(* Copyright (c) 2014 Daniel Lustig, Princeton University                     *)
(* All rights reserved.                                                       *)
(*                                                                            *)
(* This library is free software; you can redistribute it and/or              *)
(* modify it under the terms of the GNU Lesser General Public                 *)
(* License as published by the Free Software Foundation; either               *)
(* version 2.1 of the License, or (at your option) any later version.         *)
(*                                                                            *)
(* This library is distributed in the hope that it will be useful,            *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU          *)
(* Lesser General Public License for more details.                            *)
(*                                                                            *)
(* You should have received a copy of the GNU Lesser General Public           *)
(* License along with this library; if not, write to the Free Software        *)
(* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  *)
(* USA                                                                        *)
(******************************************************************************)

Require Import List.
Import ListNotations.
Require Import util2.
Require Import Ascii.
Require Import String.

(* ** GraphTree

A [GraphTree] is a data structure which is used to represent a set of
  graphs that are mostly similar, but with a few small differences.  For
  example, suppose we want to represent two graphs: one which adds an edge e1
  to a graph G, and another which adds a different edge e2 to G.  Rather than
  representing these as {G + e1, G + e2}, a [GraphTree] would represent them
  as G + {e1 or e2}.

  The motivation for a [GraphTree] is to more easily represent the case in
  which, for example, a litmus test outcome may be observable in any one of
  a number of possible graphs, some of which will generally look very similar.
  *)
Inductive GraphTree (A : Type) : Type :=
  | GraphTreeOr   : list (GraphTree A) -> GraphTree A
  | GraphTreeAnd  : list (GraphTree A) -> GraphTree A
  | GraphTreeLeaf : string -> list (A * A * string) -> GraphTree A.

Open Scope string_scope.
Open Scope list_scope.

Definition GraphTreeEmptyLeaf {A : Type} := GraphTreeLeaf A "" [].

(** The [DNFOfTree] of a [GraphTree] is an explicit list of the graphs
  represented by the tree, i.e., no longer in the compacted [GraphTree]
  format. *)
Fixpoint DNFOfTree {A : Type}
  (t : GraphTree A)
  : list (string * list (A * A * string)) :=
  let joinGraphs {A : Type}
    (a b : string * list (A * A * string))
    : string * list (A * A * string) :=
    let (an, al) := a in
    let (bn, bl) := b in
    (append an bn, al ++ bl)
  in
  match t with
  | GraphTreeOr l =>
    fold_left (app (A:=_)) (map DNFOfTree l) []
  | GraphTreeAnd l =>
    let l' := map DNFOfTree l in
    map (fun x => fold_left joinGraphs x ("", [])) (CartesianProduct l')
  | GraphTreeLeaf n g => [(n, g)]
  end.

(** [GraphTreeSimplify] tries to represent a [GraphTree] in a simpler but
  equivalent form.  It does not guarantee minimality. *)
Fixpoint GraphTreeSimplify {A : Type}
  (g : GraphTree A)
  : GraphTree A :=
  match g with
  | GraphTreeOr    [x] => GraphTreeSimplify x
  | GraphTreeOr     l  => GraphTreeOr _ (map GraphTreeSimplify l)
  | GraphTreeAnd   [x] => GraphTreeSimplify x
  | GraphTreeAnd    l  => GraphTreeAnd _ (map GraphTreeSimplify l)
  | _ => g
  end.

Lemma SimplifiedDNF {A : Type} : forall (g : GraphTree A),
  DNFOfTree (GraphTreeSimplify g) = DNFOfTree g.
Proof.
(* TODO: http://adam.chlipala.net/cpdt/html/InductiveTypes.html *)
Abort.

(** [TreeOfDNF] converts a list of graphs into [GraphTree] representation. *)
Definition TreeOfDNF {A : Type}
  (l : list (string * list (A * A * string)))
  : GraphTree A :=
  let f x := GraphTreeLeaf _ (fst x) (snd x) in
  GraphTreeSimplify (GraphTreeOr _ (map f l)).

Lemma fold1 {A : Type} : forall l (x : list A),
  fold_left (app (A:=_)) l x = x ++ fold_left (app (A:=_)) l [].
Proof.
  intros l.  induction l.
    intros x.  simpl.  rewrite app_nil_r.  auto.
  intros x.  simpl.  rewrite IHl.  symmetry.  rewrite IHl.
  rewrite app_assoc.  auto.
Qed.

Lemma fold2 {A : Type} : forall l (xh : A) (xt : list A),
  fold_left (app (A:=_)) l (xh::xt) = xh :: fold_left (app (A:=_)) l xt.
Proof.
Admitted.

Lemma DNFIdempotent {A : Type} :
  forall x,
  forall (l : list (string * list (A * A * string))),
  In x l -> In x (DNFOfTree (TreeOfDNF l)).
Proof.
  intros x.  induction l as [|lh lt].
    auto.
  intros Hx.  destruct Hx as [Hx|Hx].
    rewrite Hx in *; clear Hx.
    unfold TreeOfDNF.  unfold map.  unfold GraphTreeSimplify.  simpl.
    destruct lt.
      simpl.  left.  destruct x; auto.
    simpl.  rewrite fold1.  left.  destruct x; auto.
  apply IHlt in Hx.  clear IHlt.

  destruct lt.
    inversion Hx.
  simpl.  rewrite fold2.  right.
  destruct lt as [|lth ltt].
    simpl in *.  auto.
  simpl in *.  auto.
Qed.

Module TreeExample.

Example e1 :
  DNFOfTree
  (GraphTreeAnd _ [
    GraphTreeLeaf _ "A" [(1, 2, "a")];
    GraphTreeLeaf _ "B" [(3, 4, "b")]
  ])
  = [("AB", [(1, 2, "a"); (3, 4, "b")])].
Proof.
cbv.  auto.
Qed.

Example e2 :
  DNFOfTree
  (GraphTreeAnd _ [
    GraphTreeLeaf _ "A" [(1, 2, "a")];
    GraphTreeOr _ [
      GraphTreeLeaf _ "B" [(3, 4, "b")];
      GraphTreeLeaf _ "C" [(5, 6, "c")]
    ]
  ])
  = [("AB", [(1, 2, "a"); (3, 4, "b")]); ("AC", [(1, 2, "a"); (5, 6, "c")])].
Proof.
cbv.  auto.
Qed.

Example e3 :
  DNFOfTree
  (GraphTreeAnd _ [
    GraphTreeLeaf _ "A" [(1, 2, "a")];
    GraphTreeLeaf _ "B" [(7, 8, "d")];
    GraphTreeOr _ [
      GraphTreeLeaf _ "C" [(3, 4, "b")];
      GraphTreeLeaf _ "D" [(5, 6, "c")]
    ]
  ])
  = [("ABC", [(1, 2, "a"); (7, 8, "d"); (3, 4, "b")]);
     ("ABD", [(1, 2, "a"); (7, 8, "d"); (5, 6, "c")])].
Proof.
cbv.  auto.
Qed.

Example e4 :
  DNFOfTree
  (GraphTreeAnd _ [
    GraphTreeLeaf _ "A" [(1, 2, "a")];
    GraphTreeAnd _ [
      GraphTreeEmptyLeaf;
      GraphTreeLeaf _ "B" [(3, 4, "b")]
    ]
  ])
  = [("AB", [(1, 2, "a"); (3, 4, "b")])].
Proof.
cbv.  auto.
Qed.

Example e5 :
  DNFOfTree
  (GraphTreeAnd _ [
    GraphTreeLeaf _ "A" [(1, 2, "a")];
    GraphTreeOr _ []
  ])
  = [].
Proof.
unfold DNFOfTree.  unfold map.
cbv.  auto.
Qed.

End TreeExample.

Definition DNFStringOfTree' {A : Type}
  (print_node : A -> string)
  (e : A * A * string)
  : string :=
  let (sd, label) := e in
  let (s, d) := sd in
  fold_left append [": "; print_node s; "-"; label; "->"; print_node d; " "] "".

Fixpoint DNFStringOfTree {A : Type}
  (print_node : A -> string)
  (t : GraphTree A)
  : string :=
  let f_fold a b := append b (append "-" a) in
  match t with
  | GraphTreeOr l =>
    append "Or(" (append (fold_left f_fold (map (DNFStringOfTree print_node) l) "") ")")
  | GraphTreeAnd l =>
    append "And(" (append (fold_left f_fold (map (DNFStringOfTree print_node) l) "") ")")
  | GraphTreeLeaf n l => fold_left append (map (DNFStringOfTree' print_node) l) n
  end.

Close Scope string_scope.

Fixpoint GraphTreeMap {A B : Type}
  (f : A -> B)
  (g : GraphTree A)
  : GraphTree B :=
  match g with
  | GraphTreeAnd    l => GraphTreeAnd  _ (map (GraphTreeMap f) l)
  | GraphTreeOr     l => GraphTreeOr   _ (map (GraphTreeMap f) l)
  | GraphTreeLeaf n l =>
    let f' x := (f (fst (fst x)), f (snd (fst x)), snd x) in
    GraphTreeLeaf _ n (map f' l)
  end.

Fixpoint GraphTreeMapPair {A B : Type}
  (f : A * A * string -> B * B * string)
  (g : GraphTree A)
  : GraphTree B :=
  match g with
  | GraphTreeAnd    l => GraphTreeAnd  _ (map (GraphTreeMapPair f) l)
  | GraphTreeOr     l => GraphTreeOr   _ (map (GraphTreeMapPair f) l)
  | GraphTreeLeaf n l =>
    GraphTreeLeaf _ n (map f l)
  end.


From stdpp Require Import fin_maps gmap.
From iris.bi.lib Require Import fractional.
From iris.proofmode Require Import tactics.
From iris.base_logic.lib Require Import saved_prop gen_heap.
From aneris.prelude Require Import collect.
From aneris.lib Require Import gen_heap_light.
From aneris.aneris_lang Require Export aneris_lang network resources.
From aneris.algebra Require Import disj_gsets.

From RecordUpdate Require Import RecordSet.
Set Default Proof Using "Type".

Import uPred.
Import RecordSetNotations.

Definition messages_history := prod message_soup message_soup.

Definition messages_history_map := gmap socket_address_group messages_history.

Implicit Types mhm : messages_history_map.
Implicit Types rt : messages_history.

(* The set of all received messages *)
Definition messages_received mhm := collect (λ _ rt, rt.1) mhm.

Lemma elem_of_messages_received mhm :
  ∀ m, m ∈ messages_received mhm ↔
       ∃ sa rt, mhm !! sa = Some rt ∧ m ∈ rt.1.
Proof. by apply elem_of_collect; eauto. Qed.

(* The set of all transmitted messages *)
Definition messages_sent mhm := collect (λ _ rt, rt.2) mhm.

Lemma elem_of_messages_sent mhm :
  ∀ m, m ∈ messages_sent mhm ↔
       ∃ sa rt, mhm !! sa = Some rt ∧ m ∈ rt.2.
Proof. by apply elem_of_collect; eauto. Qed.

(** Definitions for the message history *)
Definition messages_received_sent mhm : messages_history :=
  (messages_received mhm, messages_sent mhm).

(* [m] has been received *)
Definition message_received m mhm := m ∈ (messages_received mhm).

Lemma gset_to_gmap_singleton (v: message_soup * message_soup)
      (a : socket_address) : gset_to_gmap v {[ a ]} = {[a := v]}.
Proof.
  assert ({[a]} = {[a]} ∪ (∅: gset socket_address)) as -> by by set_solver.
  by rewrite (gset_to_gmap_union_singleton v a ∅) gset_to_gmap_empty.
Qed.

Lemma messages_received_init B :
  messages_received (gset_to_gmap (∅, ∅) B) = ∅.
Proof.
  rewrite /messages_received.
  apply collect_empty_f.
  intros ? [].
  rewrite lookup_gset_to_gmap_Some.
  by intros [? [=]].
Qed.

Lemma messages_sent_init B :
  messages_sent (gset_to_gmap (∅, ∅) B) = ∅.
Proof.
  rewrite /messages_sent.
  apply collect_empty_f.
  intros ? [].
  rewrite lookup_gset_to_gmap_Some.
  by intros [? [=]].
Qed.

Lemma messages_received_sent_init B :
  messages_received_sent (gset_to_gmap (∅, ∅) B) = (∅, ∅).
Proof.
  rewrite /messages_received_sent. f_equal.
  - apply messages_received_init.
  - apply messages_sent_init.
Qed.

Lemma messages_sent_insert a R T mhm :
  messages_sent (<[a:=(R, T)]> mhm) = T ∪ messages_sent (delete a mhm).
Proof.
  rewrite /messages_sent.
  apply collect_insert.
Qed.

Lemma message_received_insert a msg R T mhm :
  message_received msg (<[a:=(R, T)]> mhm) ↔
  msg ∈ R ∨ message_received msg (delete a mhm).
Proof.
  rewrite /message_received /messages_received.
  rewrite collect_insert //= elem_of_union //.
Qed.

Lemma messages_received_insert  a R T mhm :
  messages_received (<[a:=(R, T)]> mhm) = R ∪ messages_received (delete a mhm).
Proof.
  rewrite /messages_received.
  apply collect_insert.
Qed.

Lemma messages_sent_split a R T mhm :
  mhm !! a = Some (R, T) →
  messages_sent mhm =
  T ∪ messages_sent (delete a mhm).
Proof.
  intros.
  assert (mhm = <[a := (R,T)]>mhm) as Heq by by rewrite insert_id.
  rewrite {1} Heq.
  apply collect_insert.
Qed.

(* The messages in the logical map mhm, that tracks received and transmitted
   messages, have coherent addresses. *)
Definition messages_addresses_coh mhm :=
  all_disjoint (dom mhm) ∧
  set_Forall (λ x, x ≠ ∅) (dom mhm) ∧
  ∀ sag R T, mhm !! sag = Some (R, T) →
             (∀ m, m ∈ R → m_destination m ∈ sag) ∧
             (∀ m, m ∈ T → m_sender m ∈ sag).

Definition messages_received_from_sent_coh mhm :=
  messages_received mhm ⊆ messages_sent mhm.

Definition messages_received_from_sent_coh_aux mhm :=
  ∀ rt sag m,
  m_destination m ∈ sag →
  mhm !! sag = Some rt →
  m ∈ rt.1 →
  ∃ rt' sag', m_sender m ∈ sag' →
              mhm !! sag' = Some rt' ∧ m ∈ rt'.2.

Lemma messages_received_from_sent_corrolary_coh mhm :
  messages_addresses_coh mhm →
  messages_received_from_sent_coh mhm →
  messages_received_from_sent_coh_aux mhm.
Proof.
  intros (Hdisj & Hne & Hacoh) Hrcoh.
  intros rt sag m Hsag Hrt Hm.
  assert (m ∈ (messages_received mhm)) as Hmr.
  { by apply elem_of_collect; eauto. }
  apply Hrcoh, elem_of_collect in Hmr as (sa & rt' & Hrt' & Hmt).
  assert (mhm !! sa = Some (rt'.1, rt'.2)) as Hgas by by destruct rt'.
  specialize (Hacoh sa rt'.1  rt'.2 Hgas) as (Hc1 & Hc2).
  specialize (Hc2 m Hmt). set_solver.
Qed.

Lemma messages_sent_dijsoint sag R T mhm :
  mhm !! sag = Some (R, T) →
  messages_addresses_coh mhm →
  T ## messages_sent (delete sag mhm).
Proof.
  intros Hsag (Hdisj & Hne & Hmcoh).
  apply elem_of_disjoint.
  intros m HmT Hms.
  apply elem_of_collect in Hms as (sag' & (R',T') & Hsag' & Ht).
  simplify_map_eq.
  destruct (Hmcoh sag R T Hsag) as (HR & HT).
  specialize (HT m HmT).
  assert (sag ≠ sag') as Hineq.
  { destruct (decide (sag = sag')); [ | done ].
    subst. by rewrite lookup_delete in Hsag'. }
  rewrite lookup_delete_ne in Hsag'; last by set_solver.
  assert (sag ## sag') as Hdisj'.
  { assert (sag ∈ (dom mhm)) as Hin.
    { apply elem_of_dom. eexists _. apply Hsag. }
    assert (sag' ∈ (dom mhm)) as Hin'.
    { apply elem_of_dom. eexists _. apply Hsag'. }
    destruct (Hdisj sag sag' Hin Hin') as [H | H]; done. }
  destruct (Hmcoh sag' R' T' Hsag') as (_ & HT').
  specialize (HT' m Ht).
  set_solver.
Qed.

Lemma messages_received_in mh sag m R T :
  messages_addresses_coh mh →
  mh !! sag = Some (R,T) →
  m_destination m ∈ sag →
  message_received m mh →
  m ∈ R.
Proof.
  intros [Hdisj [Hne Hmhcoh]] Hmh Hin Hrecv.
  pose proof (Hmhcoh sag R T Hmh) as [Hdest Hsrc].
  apply elem_of_messages_received in Hrecv.
  destruct Hrecv as (sa & rt & Hlookup & Hin').
  destruct rt as [R' T'].
  pose proof (Hmhcoh sa R' T' Hlookup) as [Hdest' _].
  specialize (Hdest' m Hin').
  assert (sa = sag) as ->.
  { eapply elem_of_all_disjoint_eq; eauto.
    apply elem_of_dom. eexists _. set_solver.
    apply elem_of_dom. eexists _. set_solver. }
  simpl in *.
  rewrite Hlookup in Hmh.
  set_solver.
Qed.

Lemma message_received_delete m mh sag1 sag2 :
  messages_addresses_coh mh →
  m_destination m ∈ sag1 →
  sag1 ∈ dom mh →
  sag2 ∈ dom mh →
  sag1 ≠ sag2 →
  message_received m mh →
  message_received m (delete sag2 mh).
Proof.
  rewrite /message_received.
  rewrite !elem_of_messages_received.
  intros (Hdisj & Hne & Hcoh) Hdest Hsag1 Hsag2 Hrecv
         [sag [[R T] [Hlookup Hin]]].
  assert (sag = sag1) as ->.
  { eapply elem_of_all_disjoint_eq; eauto.
    apply elem_of_dom. eexists _. set_solver.
    eapply Hcoh. eauto. eauto. }
  eexists sag1, (R,T).
  rewrite lookup_delete_ne; last done.
  auto.
Qed.


(** * Coq Framework for security policies and proof of concept application - Guide *)
(** 6.858 Project by Anders Kaseorg, Jason Gross, and Peng Wang *)
(** ** Trusted Code *)
(** *** The Framework Definitions *)
Require FunctionApp.
(** *** The Encryption Algorithm *)
Require AES GCM AESGCM.
(** *** The Encryption/Decryption Boxes *)
Require TrustedEncryptBox TrustedDecryptBox EncryptionInterface.
(** *** The Tick Box (Timing Side-Channel Avoidance Box) *)
Require TrustedTickBox.
(** *** The Server Box that puts together the encryption, decryption, and tick boxes *)
Require TrustedServerSyncBox.
(** *** The top-level wiring diagram *)
Require ExamplePwMgrWithSSB ExamplePwMgrWithSSBFull.
(** *** The trusted OCaml shims *)
(** We trust [ExamplePwMgrWithSSBFullRuntime.ml] and [Runtime.ml] *)

(** ** Semi-trusted Code *)
(** *** Display of warnings *)
(** We don't leak any information if we hide warnings from the user,
    but it's not a completely innocuous operation either. *)
Require PwMgrWarningBox.

(** ** Untrusted Code *)
(** *** Proven-correct Serialization and Deserialization *)
(** Waaaay too much code here. *)
Require PrefixSerializableDefinitions PrefixSerializable.
Require TrustedTickBoxPrefixSerializable.
(** *** Proven-correct [FMapInterface] that is also mergable and (de)serializable *)
Require SerializableMergableFMapInterface SerializableMergableFMapImplementation.
(** *** UI Code *)
Require PwMgrUI.
(** *** HTTPS Code *)
Require PwMgrNet.


(* Copyright (c) 2012-2015, Robbert Krebbers. *)
(* This file is distributed under the terms of the BSD license. *)
Require Import Qcanon.
Require Export base orders separation_instances.
Local Open Scope Qc_scope.

(**
Concrete permissions are built from more primitive combinators:
- [lockable]: [Locked] describes that the object has been locked due to
  a sequenced write, and [Unlocked] means that it is not locked
- [counter] is to account for tokens to keep track of parts of the memory
  that are addresseble.
*)
Definition perm := (lockable (counter Qcanon.Qc) + Qcanon.Qc)%type.
#[global] Instance perm_sep_ops : SeparationOps perm := _.
#[global] Instance perm_sep : Separation perm := _.
Typeclasses Opaque perm.
Global Hint Extern 0 (Separation _) => apply (_ : Separation perm): core.

Definition perm_readonly : perm := inr 1.
Definition perm_full : perm := inl (LUnlocked (Counter 0 1)).
Definition perm_token : perm := inl (LUnlocked (Counter (-1) ∅)).

Inductive pkind :=
  Writable | Readable | Locked | Existing.
#[global] Instance pkind_dec (k1 k2 : pkind) : Decision (k1 = k2).
Proof. solve_decision. Defined.
#[global] Instance pkind_subseteq : SubsetEq pkind := λ k1 k2,
  match k1, k2 with
  | _, Writable => True
  | (Existing | Readable), Readable => True
  | Existing, Existing => True
  | (Existing | Locked), Locked => True
  | _, _ => False
  end.
#[global] Instance pkind_subseteq_dec : ∀ k1 k2 : pkind, Decision (k1 ⊆ k2).
Proof. intros [] []; apply _. Defined.
#[global] Instance: PartialOrder (@subseteq pkind _).
Proof. by repeat split; repeat intros []. Qed.
#[global] Instance option_pkind_subseteq : SubsetEq (option pkind) := λ k1 k2,
  match k1, k2 with
  | Some k1, Some k2 => k1 ⊆ k2 | None, _ => True | Some _, None => False
  end.
#[global] Instance option_pkind_subseteq_dec : ∀ k1 k2 : option pkind, Decision (k1 ⊆ k2).
Proof. intros [] []; apply _. Defined.
#[global] Instance: PartialOrder (@subseteq (option pkind) _).
Proof. by repeat split; repeat intros []; try destruct p; try destruct p0; try destruct p1. Qed.

Definition perm_kind (γ : perm) : option pkind :=
  match γ with
  | inl (LUnlocked (Counter x' y')) =>
     if decide (y' = ∅) then
       if decide (x' = 0) then None else Some Existing
     else if decide (y' = 1) then Some Writable else Some Readable
  | inl (LLocked _) => Some Locked
  | inr x' => Some Readable
  end.
Definition perm_locked (γ : perm) : bool :=
  match γ with inl (LLocked _) => true | _ => false end.
Definition perm_lock (γ : perm) : perm :=
  match γ with inl (LUnlocked x') => inl (LLocked x') | _ => γ end.
Definition perm_unlock (γ : perm) : perm :=
  match γ with inl (LLocked x') => inl (LUnlocked x') | _ => γ end.

Inductive perm_kind_view : perm → option pkind → Prop :=
  | perm_kind_None : perm_kind_view (inl (LUnlocked (Counter ∅ 0))) None
  | perm_kind_Locked x' : perm_kind_view (inl (LLocked x')) (Some Locked)
  | perm_kind_Existing x' :
     x' ≠ 0 → perm_kind_view (inl (LUnlocked (Counter x' ∅))) (Some Existing)
  | perm_kind_Readable x' y' :
     y' ≠ ∅ → y' ≠ 1 →
     perm_kind_view (inl (LUnlocked (Counter x' y'))) (Some Readable)
  | perm_kind_Writable x' :
     perm_kind_view (inl (LUnlocked (Counter x' 1))) (Some Writable)
  | perm_kind_Writable' x' :
     x' ≠ 0 → perm_kind_view (inl (LUnlocked (Counter x' 1))) (Some Writable)
  | perm_kind_ro_Readable x' : perm_kind_view (inr x') (Some Readable).
Lemma perm_kind_spec γ : perm_kind_view γ (perm_kind γ).
Proof.
  destruct γ as [[[]|[]]|]; simpl; repeat case_decide;
    intuition; simplify_equality'; constructor; auto.
Qed.
Arguments perm_kind _ : simpl never.

Lemma perm_full_valid : sep_valid perm_full.
Proof. done. Qed.
Lemma perm_full_mapped : ¬sep_unmapped perm_full.
Proof. by apply (bool_decide_unpack _). Qed.
Lemma perm_full_unshared : sep_unshared perm_full.
Proof. by apply (bool_decide_unpack _). Qed.
Lemma perm_subseteq_full γ1 γ2 : γ1 = perm_full → γ1 ⊆ γ2 → γ2 = perm_full.
Proof.
  intros ->; destruct γ2 as [[[??]|[c x]]|?];
    repeat sep_unfold; unfold perm_full; intuition; simplify_equality.
  assert (x = 1) as -> by eauto using Qcle_antisym.
  by assert (c = 0) as -> by eauto using Qcle_antisym.
Qed.
Lemma perm_readonly_valid : sep_valid perm_readonly.
Proof. done. Qed.
Lemma perm_readonly_mapped : ¬sep_unmapped perm_readonly.
Proof. by apply (bool_decide_unpack _). Qed.
Lemma perm_token_valid : sep_valid perm_token.
Proof. done. Qed.
Lemma perm_locked_mapped γ : perm_locked γ = true → ¬sep_unmapped γ.
Proof. destruct γ as [[[]|]|[]]; repeat sep_unfold; naive_solver. Qed.
Lemma perm_Readable_locked γ :
  Some Readable ⊆ perm_kind γ → perm_locked γ = false.
Proof. by destruct (perm_kind_spec γ). Qed.
Lemma perm_locked_lock γ :
  Some Writable ⊆ perm_kind γ → perm_locked (perm_lock γ) = true.
Proof. by destruct (perm_kind_spec γ). Qed.
Lemma perm_locked_unlock γ : perm_locked (perm_unlock γ) = false.
Proof. by destruct γ as [[]|[]]. Qed.
Lemma perm_lock_valid γ :
  sep_valid γ → Some Writable ⊆ perm_kind γ → sep_valid (perm_lock γ).
Proof. destruct (perm_kind_spec γ); repeat sep_unfold; intuition. Qed.
Lemma perm_lock_empty γ : perm_lock γ = ∅ → γ = ∅.
Proof. by destruct γ as [[]|?]. Qed.
Lemma perm_lock_unmapped γ :
  Some Writable ⊆ perm_kind γ → sep_unmapped γ → sep_unmapped (perm_lock γ).
Proof. destruct (perm_kind_spec γ); repeat sep_unfold; naive_solver. Qed.
Lemma perm_lock_mapped γ : sep_unmapped (perm_lock γ) → sep_unmapped γ.
Proof. destruct γ as [[]|[]]; repeat sep_unfold; intuition. Qed.
Lemma perm_lock_unshared γ : sep_unshared γ → sep_unshared (perm_lock γ).
Proof. destruct γ as [[]|[]]; repeat sep_unfold; intuition. Qed.
Lemma perm_unlock_lock γ :
  sep_valid γ → Some Writable ⊆ perm_kind γ → perm_unlock (perm_lock γ) = γ.
Proof. by destruct (perm_kind_spec γ). Qed.
Lemma perm_unlock_unlock γ : perm_unlock (perm_unlock γ) = perm_unlock γ.
Proof. by destruct γ as [[]|]. Qed.
Lemma perm_unlock_valid γ : sep_valid γ → sep_valid (perm_unlock γ).
Proof. destruct γ as [[[]|[]]|]; repeat sep_unfold; naive_solver. Qed.
Lemma perm_unlock_empty γ : sep_valid γ → perm_unlock γ = ∅ → γ = ∅.
Proof. destruct γ as [[]|?]; repeat sep_unfold; naive_solver. Qed.
Lemma perm_unlock_unmapped γ : sep_unmapped γ → sep_unmapped (perm_unlock γ).
Proof. destruct γ as [[[]|[]]|]; repeat sep_unfold; intuition. Qed.
Lemma perm_unlock_mapped γ :
  sep_valid γ → sep_unmapped (perm_unlock γ) → sep_unmapped γ.
Proof. destruct γ as [[[]|[]]|[]]; repeat sep_unfold; naive_solver. Qed.
Lemma perm_unlock_unshared γ : sep_unshared γ → sep_unshared (perm_unlock γ).
Proof. destruct γ as [[]|[]]; repeat sep_unfold; intuition. Qed.
Lemma perm_unlock_shared γ :
  sep_valid γ → sep_unshared (perm_unlock γ) → sep_unshared γ.
Proof. destruct γ as [[]|[]]; repeat sep_unfold; intuition. Qed.
Lemma perm_unshared γ :
  sep_valid γ → Some Locked ⊆ perm_kind γ → sep_unshared γ.
Proof. destruct (perm_kind_spec γ); repeat sep_unfold; intuition. Qed.
Lemma perm_mapped γ : Some Readable ⊆ perm_kind γ → ¬sep_unmapped γ.
Proof. destruct (perm_kind_spec γ); repeat sep_unfold; naive_solver. Qed.
Lemma perm_unmapped γ :
  sep_valid γ → perm_kind γ = Some Existing → sep_unmapped γ.
Proof. destruct (perm_kind_spec γ); repeat sep_unfold; naive_solver. Qed.
Lemma perm_None_unmapped γ : sep_valid γ → perm_kind γ = None → sep_unmapped γ.
Proof. destruct (perm_kind_spec γ); repeat sep_unfold; naive_solver. Qed.
Lemma perm_token_subseteq γ :
  sep_valid γ → Some Writable ⊆ perm_kind γ → perm_token ⊂ γ.
Proof.
  assert (∀ x', x' - 0 = 0 → x' = 0).
  { intros x'. change (x' - 0) with (x' + 0). by rewrite Qcplus_0_r. }
  rewrite strict_spec_alt. unfold perm_token.
  destruct (perm_kind_spec γ); repeat sep_unfold; (split; [|intro]);
    simplify_equality'; intuition; exfalso; auto.
Qed.
Lemma perm_splittable γ :
  sep_valid γ → Some Readable ⊆ perm_kind γ → sep_splittable γ.
Proof. destruct (perm_kind_spec γ); repeat sep_unfold; intuition. Qed.
Lemma perm_splittable_existing γ :
  sep_valid γ → perm_kind γ = Some Existing → sep_splittable γ.
Proof. by destruct (perm_kind_spec γ); repeat sep_unfold. Qed.

Lemma perm_kind_full : perm_kind perm_full = Some Writable.
Proof. done. Qed.
Lemma perm_kind_lock γ :
  Some Writable ⊆ perm_kind γ → perm_kind (perm_lock γ) = Some Locked.
Proof. by destruct (perm_kind_spec γ). Qed.
Lemma perm_kind_half γ :
  sep_valid γ → perm_kind (½ γ) =
    match perm_kind γ with
    | Some Writable => Some Readable | _ => perm_kind γ
    end.
Proof.
  assert (∀ x', x' * /2 = 0 → x' = 0).
  { intros. by apply Qcmult_integral_l with (/2); rewrite 1?Qcmult_comm. }
  assert (∀ x', x' * /2 = 1 → x' ≤ 1 → False).
  { intros x'. rewrite (Qcmult_le_mono_pos_r _ _ (/2)) by done.
    by intros -> []. }
  repeat sep_unfold; destruct (perm_kind_spec γ); unfold perm_kind; simpl;
    intros; by rewrite ?decide_False by intuition eauto.
Qed.
Lemma perm_kind_token : perm_kind perm_token = Some Existing.
Proof. done. Qed.
Lemma perm_kind_difference_token γ :
  perm_token ⊂ γ → perm_kind (γ ∖ perm_token) = perm_kind γ.
Proof.
  rewrite strict_spec_alt.
  destruct (perm_kind_spec γ) as [| |y| | |y|]; repeat sep_unfold;
    unfold perm_kind; simpl; intros [? Hneq]; auto.
  * assert (¬0 ≤ -1) by (by intros []); intuition.
  * assert (y ≤ -1 → y ≤ 0) by (by intros; transitivity (-1)).
    assert (y + 1 ≠ 0).
    { change 0 with (-1 + 1); rewrite (inj_iff (λ x, x + 1)); contradict Hneq.
      symmetry. unfold perm_token; repeat f_equal; intuition. }
    by rewrite decide_False by done.
  * by change (-0) with 0; rewrite Qcplus_0_r, !decide_False by done.
Qed.
Lemma perm_kind_subseteq γ1 γ2 : γ1 ⊆ γ2 → perm_kind γ1 ⊆ perm_kind γ2.
Proof.
  destruct γ1 as [[[x1 y1]|[x1 y1]]|x1], γ2 as [[[x2 y2]|[x2 y2]]|x2];
    unfold perm_kind; repeat sep_unfold;
    repeat case_decide; naive_solver eauto using Qcle_antisym.
Qed.
Lemma perm_lock_disjoint γ1 γ2 :
  Some Writable ⊆ perm_kind γ1 → γ1 ## γ2 → perm_lock γ1 ## γ2.
Proof.
  assert (¬2 ≤ 1) by (by intros []).
  assert (∀ x, 0 ≤ x → 1 + x ≤ 1 → x = 0).
  { intros x ? Hx. apply (Qcplus_le_mono_l x 0 1) in Hx.
    auto using Qcle_antisym. }
  destruct (perm_kind_spec γ1), γ2 as [[[x2 y2]|[x2 y2]]|];
    repeat sep_unfold; intuition; simplify_equality'; try done.
  * assert (y2 = 0) as -> by auto.
    rewrite (Qcplus_le_mono_r _ _ x2), Qcplus_0_l. eauto using Qcle_trans.
  * assert (y2 = 0) as -> by auto.
    rewrite (Qcplus_le_mono_r _ _ x2), Qcplus_0_l. eauto using Qcle_trans.
Qed.
Lemma perm_lock_union γ1 γ2 : perm_lock (γ1 ∪ γ2) = perm_lock γ1 ∪ γ2.
Proof. by destruct γ1 as [[]|], γ2 as [[]|]. Qed.
Lemma perm_unlock_disjoint γ1 γ2 : γ1 ## γ2 → perm_unlock γ1 ## γ2.
Proof. destruct γ1 as [[]|], γ2 as [[]|]; repeat sep_unfold; naive_solver. Qed.
Lemma perm_unlock_union γ1 γ2 :
  γ1 ## γ2 → perm_locked γ1 → perm_unlock (γ1 ∪ γ2) = perm_unlock γ1 ∪ γ2.
Proof. by destruct γ1 as [[]|], γ2 as [[]|]. Qed.
Lemma perm_disjoint_full γ : perm_full ## γ → γ = ∅.
Proof.
  destruct γ as [[[x y]|[x y]]|];
    repeat sep_unfold; intuition; simplify_equality'.
  assert (y = 0) as ->.
  { apply Qcle_antisym; auto. by apply (Qcplus_le_mono_l y 0 1). }
  repeat f_equal; apply Qcle_antisym; auto; rewrite <-(Qcplus_0_l x); auto.
Qed.


Require Export Coq.Program.Basics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Coq.Program.Combinators.
Require Export ZArith.
Require Export Lists.List.
Require Export Ascii.
Require Export Strings.String.
Require Import Coq.Strings.Byte.

Require Import depoolContract.Lib.HexNotations.
Import HexNotations.

Module DePoolConsts.

Local Open Scope solidity_scope_hex.
Local Open Scope solidity_scope_dec.

Local Notation "a 'e' b" := ( (a * 10^b)%Z )(at level 60, right associativity) .
Local Notation "'0.09' '*' 'ton'" := (90000000%Z).
Local Notation "'0.5' '*' 'ton'" := (500000000%Z).

Definition ton := 1000000000%Z .
Definition milliton := 1000%Z .
Definition minutes := 60%Z .

Definition Errors_ι_IS_NOT_OWNER := 101%Z .
Definition Errors_ι_IS_NOT_PROXY := 107%Z .
Definition Errors_ι_IS_EXT_MSG := 108%Z .
Definition Errors_ι_IS_NOT_VALIDATOR := 113%Z .
Definition Errors_ι_DEPOOL_IS_CLOSED := 114%Z .
Definition Errors_ι_NO_SUCH_PARTICIPANT := 116%Z .
Definition Errors_ι_IS_NOT_DEPOOL := 120%Z .
Definition Errors_ι_INVALID_ROUND_STEP := 125%Z .
Definition Errors_ι_INVALID_QUERY_ID := 126%Z .
Definition Errors_ι_IS_NOT_ELECTOR := 127%Z .
Definition Errors_ι_BAD_STAKES := 129%Z .
Definition Errors_ι_CONSTRUCTOR_NO_PUBKEY := 130%Z .
Definition Errors_ι_VALIDATOR_IS_NOT_STD := 133%Z .
Definition Errors_ι_BAD_PART_REWARD := 138%Z .
Definition Errors_ι_BAD_PROXY_CODE := 141%Z .
Definition Errors_ι_NOT_WORKCHAIN0 := 142%Z .
Definition Errors_ι_NEW_VALIDATOR_FRACTION_MUST_BE_GREATER_THAN_OLD := 143%Z .
Definition Errors_ι_FRACTION_MUST_NOT_BE_ZERO := 144%Z .
Definition Errors_ι_BAD_BALANCE_THRESHOLD := 145%Z .
Definition Errors_ι_BAD_ACCOUNT_BALANCE := 146%Z .
Definition InternalErrors_ι_ERROR507 := 507%Z .
Definition InternalErrors_ι_ERROR508 := 508%Z .
Definition InternalErrors_ι_ERROR509 := 509%Z .
Definition InternalErrors_ι_ERROR511 := 511%Z .
Definition InternalErrors_ι_ERROR513 := 513%Z .
Definition InternalErrors_ι_ERROR516 := 516%Z .
Definition InternalErrors_ι_ERROR517 := 517%Z .
Definition InternalErrors_ι_ERROR518 := 518%Z .
Definition InternalErrors_ι_ERROR519 := 519%Z .
Definition InternalErrors_ι_ERROR521 := 521%Z .
Definition InternalErrors_ι_ERROR522 := 522%Z .
Definition InternalErrors_ι_ERROR523 := 523%Z .
Definition InternalErrors_ι_ERROR524 := 524%Z .
Definition InternalErrors_ι_ERROR525 := 525%Z .
Definition InternalErrors_ι_ERROR526 := 526%Z .
Definition InternalErrors_ι_ERROR527 := 527%Z .
Definition InternalErrors_ι_ERROR528 := 528%Z .
Definition DePoolLib_ι_PROXY_FEE := (0.09 * ton )%Z .
Definition DePoolLib_ι_MIN_PROXY_BALANCE := (1 * ton )%Z .
Definition DePoolLib_ι_PROXY_CONSTRUCTOR_FEE := (1 * ton )%Z .
Definition DePoolLib_ι_DEPOOL_CONSTRUCTOR_FEE := (1 * ton )%Z .
Definition DePoolLib_ι_ELECTOR_FEE := (1 * ton )%Z .
Definition DePoolLib_ι_MAX_UINT64 := "FFFFFFFFFFFFFFFF" .
Definition DePoolLib_ι_MAX_TIME := "FFFFFFFF" .
Definition DePoolLib_ι_ELECTOR_UNFREEZE_LAG := (1 * minutes )%Z .
Definition DePool_ι_STAKE_FEE := (0.5 * ton )%Z .
Definition DePool_ι_RET_OR_REINV_FEE := (50 * milliton )%Z .
Definition DePool_ι_MAX_MSGS_PER_TR := 25%Z .
Definition DePool_ι_MAX_QTY_OF_OUT_ACTIONS := 250%Z .
Definition DePool_ι_VALUE_FOR_SELF_CALL := (1 * ton )%Z .
Definition DePool_ι_PROXY_CODE_HASH := "481d7f583b458a1672ee602f66e8aa8d2f99d3cd9ece2eaa20e25c7ddf4c7f4a".
Definition DePool_ι_STATUS_SUCCESS := 0%Z .
Definition DePool_ι_STATUS_STAKE_TOO_SMALL := 1%Z .
Definition DePool_ι_STATUS_DEPOOL_CLOSED := 3%Z .
Definition DePool_ι_STATUS_NO_PARTICIPANT := 6%Z .
Definition DePool_ι_STATUS_PARTICIPANT_ALREADY_HAS_VESTING := 9%Z .
Definition DePool_ι_STATUS_WITHDRAWAL_PERIOD_GREATER_TOTAL_PERIOD := 10%Z .
Definition DePool_ι_STATUS_TOTAL_PERIOD_MORE_18YEARS := 11%Z .
Definition DePool_ι_STATUS_WITHDRAWAL_PERIOD_IS_ZERO := 12%Z .
Definition DePool_ι_STATUS_TOTAL_PERIOD_IS_NOT_DIVISIBLE_BY_WITHDRAWAL_PERIOD := 13%Z .
Definition DePool_ι_STATUS_REMAINING_STAKE_LESS_THAN_MINIMAL := 16%Z .
Definition DePool_ι_STATUS_PARTICIPANT_ALREADY_HAS_LOCK := 17%Z .
Definition DePool_ι_STATUS_TRANSFER_AMOUNT_IS_TOO_BIG := 18%Z .
Definition DePool_ι_STATUS_TRANSFER_SELF := 19%Z .
Definition DePool_ι_STATUS_TRANSFER_TO_OR_FROM_VALIDATOR := 20%Z .
Definition DePool_ι_STATUS_FEE_TOO_SMALL := 21%Z .
Definition DePool_ι_STATUS_INVALID_ADDRESS := 22%Z .
Definition DePool_ι_STATUS_INVALID_BENEFICIARY := 23%Z .
Definition DePool_ι_STATUS_NO_ELECTION_ROUND := 24%Z .
Definition DePool_ι_STATUS_INVALID_ELECTION_ID := 25%Z .
Definition DePool_ι_CRITICAL_THRESHOLD := (10 * ton )%Z .
Definition DePoolHelper_ι_TICKTOCK_FEE := 1 e 9 .
Definition DePoolHelper_ι__timerRate := 400000%Z .
Definition DePoolHelper_ι__fwdFee := 1000000%Z .
Definition DePoolHelper_ι__epsilon := 1 e 9 .
Definition DePoolProxyContract_ι_ERROR_IS_NOT_DEPOOL := 102%Z .
Definition DePoolProxyContract_ι_ERROR_BAD_BALANCE := 103%Z .

End DePoolConsts.