(** STG in COQ by Maciej Piróg, University of Wrocław, 2010 *)

(** This library contains the definition of the argument-accumulating
semantics and proof of its equivalence with the STG natural semantics. *)

Require Export Heaps.
Require Export Sem01.
Require Import Arith.Max.
Require Import Arith.Gt.
Require Import Wf_nat.

(** * Argument Accumulating Semantics *)

Reserved Notation "($ a $ b $ e ↓↓ c $ d $ f )"
  (at level 70, no associativity).

Inductive AAS : heapA -> expr -> vars -> heapA -> expr -> vars -> Prop :=

| A_Con : forall Gamma C pi,
  ($ Gamma $ Constr C pi $ nil ↓↓ Gamma $ Constr C pi $ nil)

| A_Accum : forall Gamma Delta p pm qn w rs,
  pm <> nil ->
  ($ Gamma $ App p nil $ pm ++ qn ↓↓ Delta $ w $ rs) ->
  ($ Gamma $ App p pm  $ qn ↓↓ Delta $ w $ rs)

| A_App1 : forall Gamma p pn m e,
  Gamma p = Some (Lf_n m e) ->
  m > length pn ->
  ($ Gamma $ App p nil $ pn ↓↓ Gamma $ App p nil $ pn)

| A_App2_5 : forall Gamma Delta m e p pn w rs,
  Gamma p = Some (Lf_n m e) ->
  m <= length pn ->
  ($ Gamma $ e~[zip_var_list m (firstn m pn)] $ skipn m pn
    ↓↓ Delta $ w $ rs) ->
  ($ Gamma $ App p nil $ pn ↓↓ Delta $ w $ rs)

| A_App4 : forall Gamma Delta e p C qs,
  Gamma p = Some (Lf_u e) ->
  ($ Gamma $ e $ nil ↓↓ Delta $ Constr C qs $ nil) ->
  ($ Gamma $ App p nil $ nil
    ↓↓ setA Delta p (Lf_n 0 (Constr C qs)) $ Constr C qs $ nil)

| A_App5 : forall Gamma Delta Theta p pn q qk e f n w rs,
  Gamma p = Some (Lf_u e) ->
  Delta q = Some (Lf_n n f) ->
  length qk < n ->
  ($ Gamma $ e $ nil ↓↓ Delta $ App q nil $ qk) ->
  ($ setA Delta p (Lf_n (n - length qk) (f~[zip_var_list n qk])) $
    App q nil $ qk ++ pn ↓↓ Theta $ w $ rs) ->
  ($Gamma $ App p nil $ pn ↓↓ Theta $ w $ rs)

| A_Let : forall Gamma Delta lfs e w ats rs ss,
  length ats = length lfs ->
  are_atoms ats ->
  (forall a : var, In a ats -> Gamma a = None) ->
  ($ allocA Gamma ats
      (map (subst_lf (zip_var_list (length lfs) ats)) lfs)
    $ e~[zip_var_list (length lfs) ats] $ rs
    ↓↓ Delta $ w $ ss) ->
  ($ Gamma $ Letrec lfs e $ rs ↓↓ Delta $ w $ ss)

| A_Case_of : forall Gamma Delta Theta b e e0 als w c c0 ps rs qs,
  length ps = b ->
  select_case als c = Some (Alt c0 b e0) ->
  ($ Gamma $ e $ nil ↓↓ Delta $ Constr c ps $ nil) ->
  ($ Delta $ e0~[zip_var_list b ps] $ qs ↓↓ Theta $ w $ rs) ->
  ($ Gamma $ Case e als $ qs ↓↓ Theta $ w $ rs)

where "($ a $ b $ e ↓↓ c $ d $ f )" := (AAS a b e c d f).

Hint Resolve A_Con A_Accum A_App1 A_App2_5 A_App4 A_App5 A_Let A_Case_of.

(** * Completeness *)

Proposition app_accum_right :
forall Gamma Delta p pm qn w rs,
  ($ Gamma $ App p nil $ pm ++ qn ↓↓ Delta $ w $ rs) ->
  ($ Gamma $ App p pm  $ qn ↓↓ Delta $ w $ rs).
Proof.
induction pm; isa.
constructor; intuition; try discriminate.
Qed.

Hint Resolve app_accum_right.

Proposition app_accum_left :
forall Gamma Delta p pm qn w rs,
  ($ Gamma $ App p pm  $ qn ↓↓ Delta $ w $ rs) ->
  ($ Gamma $ App p nil $ pm ++ qn ↓↓ Delta $ w $ rs).
Proof.
intros.
inversion H; isa; subst; intuition.
Qed.

Hint Resolve app_accum_left.

Proposition app_accum :
forall Gamma Delta p pm qn w rs,
  ($ Gamma $ App p nil $ pm ++ qn ↓↓ Delta $ w $ rs) <->
  ($ Gamma $ App p pm  $ qn ↓↓ Delta $ w $ rs).
Proof.
intros; split; auto.
Qed.

Proposition AAS_complete :
forall Xi Psi a b, ($ Xi $ a ↓ Psi $ b) ->
forall Omega c Cs Ds, ($ Psi $ b $ Ds ↓↓ Omega $ c $ Cs) ->
  ($ Xi $ a $ Ds ↓↓ Omega $ c $ Cs).
Proof with intuition; auto with arith; eauto.
intros Xi Psi a b ast.
induction ast; intros Omega cc Cs Ds astast; isa; subst...
(* Case App2 *)
apply IHast in astast.
remember_destruct pn;
[ rewrite <- X in *
| rewrite -> X in *;
    apply A_Accum; try intuition; try rewrite H1 in X; try discriminate ];
eapply A_App2_5...
simpl; rewrite app_length; omega.
rewrite firstn_length_app.
rewrite skipn_length_app...
(* Case App3 *)
apply -> app_accum.
eapply A_App2_5...
rewrite app_length...
rewrite skipn_app...
rewrite firstn_app...
apply IHast1.
apply -> app_accum.
rewrite <- app_ass...
(* Case App4 *)
inversion astast; subst...
(* Case App5 *)
apply app_accum_right.
eapply A_App5; eauto.
apply IHast1.
apply app_accum_right.
rewrite <- app_nil_end.
eapply A_App1...
rewrite <- app_ass...
Qed.

Lemma app_value_heap :
forall Delta e Xi x xs b,
  ($ Delta $ e ↓ Xi $ b) ->
  b = App x xs ->
  exists f, exists m, Xi x = Some (Lf Dont_update m f) /\ m > length xs.
Proof with isa.
intros.
induction H; try discriminate...
inversion H0; subst.
exists e.
exists m...
Qed.

Proposition AAS_complete2 :
forall Xi a,
  (forall x xs, ($ emptyA $ a ↓ Xi $ App x xs) -> ($ emptyA $ a $ nil ↓↓ Xi $ App x nil $ xs))
  /\
  (forall C xs, ($ emptyA $ a ↓ Xi $ Constr C xs) -> ($ emptyA $ a $ nil ↓↓ Xi $ Constr C xs $ nil)).
Proof with isa.
intros.
split.
(* left *)
intros.
apply AAS_complete with (Psi := Xi) (b := App x xs) (Omega := Xi)
  (c := App x nil) (Cs := xs) (Ds := nil) in H...
apply app_value_heap with (x := x) (xs := xs) in H...
destruct H as [f [m []]].
destruct xs.
  (* nil *)
eapply A_App1; eauto.
  (* cons *)
apply A_Accum.
discriminate.
rewrite <- app_nil_end.
eapply A_App1; eauto.
(* right *)
intros.
apply AAS_complete with (Psi := Xi) (b := Constr C xs) (Omega := Xi)
  (c := Constr C xs) (Cs := nil) (Ds := nil) in H...
Qed.

(** * Soundness *)

Proposition AAS_value :
forall Xi Omega Pn Rs b d,
  ($ Xi $ b $ Pn ↓↓ Omega $ d $ Rs) ->
  ((exists c, exists ps, d = Constr c ps /\ Rs = nil))
  \/ (exists p, exists ps, d = App p ps).
Proof.
intros.
induction H; eauto.
Qed.

Reserved Notation "($ a $ b $ e ↓↓ c $ d $ f ^^ n )"
  (at level 70, no associativity).

Inductive AASN : heapA -> expr -> vars -> heapA -> expr -> vars ->
  nat -> Prop :=

| A_ConN : forall Gamma C pi,
  ($ Gamma $ Constr C pi $ nil ↓↓ Gamma $ Constr C pi $ nil ^^ 0)

| A_AccumN : forall Gamma Delta p pm qn w rs N,
  pm <> nil ->
  ($ Gamma $ App p nil $ pm ++ qn ↓↓ Delta $ w $ rs ^^ N) ->
  ($ Gamma $ App p pm  $ qn ↓↓ Delta $ w $ rs ^^ S N)

| A_App1N : forall Gamma p pn m e,
  Gamma p = Some (Lf_n m e) ->
  m > length pn ->
  ($ Gamma $ App p nil $ pn ↓↓ Gamma $ App p nil $ pn ^^ 0)

| A_App2_5N : forall Gamma Delta m e p pn w rs N,
  Gamma p = Some (Lf_n m e) ->
  m <= length pn ->
  ($ Gamma $ e~[zip_var_list m (firstn m pn)] $ skipn m pn
    ↓↓ Delta $ w $ rs ^^ N) ->
  ($ Gamma $ App p nil $ pn ↓↓ Delta $ w $ rs ^^ S N)

| A_App4N : forall Gamma Delta e p C qs N,
  Gamma p = Some (Lf_u e) ->
  ($ Gamma $ e $ nil ↓↓ Delta $ Constr C qs $ nil ^^ N) ->
  ($ Gamma $ App p nil $ nil
    ↓↓ setA Delta p (Lf_n 0 (Constr C qs)) $ Constr C qs $ nil ^^ S N)

| A_App5N : forall Gamma Delta Theta p pn q qk e f n w rs M N,
  Gamma p = Some (Lf_u e) ->
  Delta q = Some (Lf_n n f) ->
  length qk < n ->
  ($ Gamma $ e $ nil ↓↓ Delta $ App q nil $ qk ^^ N) ->
  ($ setA Delta p (Lf_n (n - length qk) (f~[zip_var_list n qk])) $
    App q nil $ qk ++ pn ↓↓ Theta $ w $ rs ^^ M) ->
  ($ Gamma $ App p nil $ pn ↓↓ Theta $ w $ rs ^^ S (max M N))

| A_LetN : forall Gamma Delta lfs e w ats rs ss N,
  length ats = length lfs ->
  are_atoms ats ->
  (forall a : var, In a ats -> Gamma a = None) ->
  ($ allocA Gamma ats
      (map (subst_lf (zip_var_list (length lfs) ats)) lfs)
    $ e~[zip_var_list (length lfs) ats] $ rs
    ↓↓ Delta $ w $ ss ^^ N) ->
  ($ Gamma $ Letrec lfs e $ rs ↓↓ Delta $ w $ ss ^^ S N)

| A_Case_ofN : forall Gamma Delta Theta b e e0 als w c c0 ps rs qs N M,
  length ps = b ->
  select_case als c = Some (Alt c0 b e0) ->
  ($ Gamma $ e $ nil ↓↓ Delta $ Constr c ps $ nil ^^ N) ->
  ($ Delta $ e0~[zip_var_list b ps] $ qs ↓↓ Theta $ w $ rs ^^ M) ->
  ($ Gamma $ Case e als $ qs ↓↓ Theta $ w $ rs ^^ S (max M N))

where "($ a $ b $ e ↓↓ c $ d $ f ^^ n )" := (AASN a b e c d f n ).

Ltac caseA x := case x; isa.

Lemma aasn_complete :
forall Gamma e ps Delta w qs,
  ($ Gamma $ e $ ps ↓↓ Delta $ w $ qs) ->
  exists N, ($ Gamma $ e $ ps ↓↓ Delta $ w $ qs ^^ N).
Proof with eauto.
intros.
induction H.
exists 0; constructor.
caseA IHAAS; exists (S x); constructor...
exists 0; econstructor...
caseA IHAAS; exists (S x); eapply A_App2_5N...
caseA IHAAS; exists (S x); eapply A_App4N...
caseA IHAAS1; caseA IHAAS2; exists (S (max x0 x)); eapply A_App5N...
caseA IHAAS; exists (S x); eapply A_LetN...
caseA IHAAS1; caseA IHAAS2; exists (S (max x0 x)); eapply A_Case_ofN...
Qed.

Lemma aasn_sound :
forall Gamma e ps Delta w qs N,
  ($ Gamma $ e $ ps ↓↓ Delta $ w $ qs ^^ N) ->
  ($ Gamma $ e $ ps ↓↓ Delta $ w $ qs).
Proof.
intros.
induction H; eauto.
Qed.

Proposition AAS_split :
forall N (Xi Psi Omega : heapA) (b c d : expr) (Rs Pt Ptn Qs : vars),
  ($ Xi $ b $ Pt ++ Ptn ↓↓ Omega $ d $ Rs ^^ N) ->
  exists Psi, exists c, exists Qs, exists N0, exists N1,
  ($ Xi $ b $ Pt ↓↓ Psi $ c $ Qs ^^ N0) /\
  ($ Psi $ c $ Qs ++ Ptn ↓↓ Omega $ d $ Rs ^^ N1) /\
  N0 <= N /\ N1 <= N.
Proof with try split; try omega; simpl; auto.
intro N.
induction N using lt_wf_ind; isa.
destruct N;
  inversion H0; subst;
  try (rewrite <- plus_n_Sm in *; discriminate).
(* Case *)
rewrite <- H4 in *.
exists Omega.
exists (Constr C pi).
exists nil.
exists 0.
exists 0.
symmetry in H4.
apply app_eq_nil in H4.
inversion_clear H4...
rewrite H1...
split...
rewrite H2...
(* Case *)
exists Omega.
exists (App p nil).
exists Pt.
exists 0.
exists 0...
eapply A_App1N; eauto.
rewrite app_length in H2...
(* Case *)
dupl_apply Xi H; auto.
destruct H1 as [x [x0 [x1 [x2 [x3 [H H1]]]]]].
destruct H1 as [H1 []].
exists x.
exists x0.
exists x1.
exists (S x2).
exists x3.
split.
apply A_AccumN...
apply H.
split...
apply H1...
rewrite app_ass...
(* Case *)
caseA (le_lt_dec m (length Pt)).
  (* m <= length Pt *)
rewrite firstn_app in *...
rewrite skipn_app in *...
dupl_apply H10 H...
destruct H1 as [x [x0 [x1 [x2 [x3 [H H1]]]]]].
destruct H1 as [H1 []].
apply A_App2_5N with (p := p) in H...
exists x.
exists x0.
exists x1.
exists (S x2).
exists x3.
split...
  (* length Pt < m *)
exists Xi.
exists (App p nil).
exists Pt.
exists 0.
exists (S N).
split.
eapply A_App1N; eauto.
split; intuition.
(* Case *)
symmetry in H1.
apply app_eq_nil in H1.
inversion_clear H1.
subst.
simpl in H0.
exists (setA Delta p (Lf_n 0 (Constr C qs))).
exists (Constr C qs).
exists nil.
exists (S N).
exists 0.
split...
simpl.
apply A_ConN.
intuition.
(* Case *)
rewrite <- app_ass in H12.
dupl_apply H12 H...
destruct H1 as [x [x0 [x1 [x2 [x3 [H H1]]]]]].
destruct H1 as [H1 []].
exists x.
exists x0.
exists x1.
exists (S (max x2 N0)).
exists x3.
split.
eapply A_App5N.
apply H2.
apply H3.
apply H4.
apply H5.
apply H.
split.
apply H1.
split.
apply le_n_S.
destruct (max_dec x2 N0); apply max_c_inv_to_le; auto.
  eapply le_trans.
  apply H7.
  eapply le_trans.
  eapply le_max_l.
  apply le_n_Sn.
    eapply le_lt_trans.
    apply le_max_l.
    apply lt_n_Sn.
(* Case Let *)
dupl_apply H11 H...
destruct H1 as [x [x0 [x1 [x2 [x3 [H H1]]]]]].
destruct H1 as [H1 []].
exists x.
exists x0.
exists x1.
exists (S x2).
exists x3.
split.
eapply A_LetN.
eauto.
auto.
eauto.
eauto.
split...
(* Case Case *)
dupl_apply H11 H...
destruct H1 as [x [x0 [x1 [x2 [x3 [H H1]]]]]].
destruct H1 as [H1 []].
exists x.
exists x0.
exists x1.
exists (S (max x2 N0)).
exists x3.
split.
eapply A_Case_ofN.
instantiate (2 := ps); eauto.
instantiate (1 := e0).
instantiate (1 := c1).
instantiate (1 := c0).
rewrite <- plus_n_O...
apply H4.
rewrite <- plus_n_O...
split.
apply H1.
split.
apply le_n_S.
apply max_c_inv_to_le; isa.
apply le_trans with (m := M)...
rewrite max_SS.
apply le_trans with (m := S M)...
auto with arith.
auto with arith.
Qed.

Fixpoint join_expr (Ds : list atom) (e : expr) {struct e} :
  expr :=
match e with
| App v vs => App v (vs ++ map Atom Ds)
| Constr c vs => Constr c vs
| Letrec dfs f => Letrec dfs (join_expr Ds f)
| Case e als => Case e (map (join_alt Ds) als)
end
with join_alt (Ds : list atom) (a : alt)
  {struct a} : alt :=
match a with
| Alt c b f => Alt c b (join_expr Ds f)
end.

Notation " e >< d " := (join_expr d e) (at level 70).
Notation " e ><' d " := (join_alt d e) (at level 70).

Proposition join_nil :
forall (e : expr), e >< nil = e.
Proof with isa.
induction e using expr_ind2 with
  (P1 := fun (lf : lambda_form) => True)
  (P2 := fun (al : alt) => al ><' nil = al)...
rewrite <- app_nil_end...
rewrite IHe...
f_equal; induction als; isa; f_equal...
rewrite IHe...
Qed.

Lemma closed_AAS_atoms :
forall N Xi Omega e f ps ds,
  (forall s lf, Xi s = Some lf -> closed_lf 0 lf) ->
  closed_expr 0 e ->
  ($ Xi $ e $ ps ↓↓ Omega $ f $ ds ^^ N) -> are_atoms ps ->
  are_atoms ds /\ closed_expr 0 f /\
  (forall s lf, Omega s = Some lf -> closed_lf 0 lf).
Proof with isa; eauto.
intro NN.
intros Xi Omega e f ps ds H J X A.
induction X...
(* Case *)
dupl J.
apply atoms_closed_app in J.
inversion_clear J...
(* Case *)
apply IHX...
eapply open_inv_to_closed.
  apply atoms_firstn...
  rewrite firstn_length.
  auto with arith.
apply H with (s := p).
apply H0.
  unfold are_atoms in *.
  intros.
  intuition.
  apply A.
  eapply In_skipn.
  apply H2.
(* Case *)
assert (closed_lf 0 (Lf_u e))...
inversion H1; subst...
ecase IHX...
destruct H4.
split...
split...
unfold setA in *.
destruct eq_var_dec...
inversion H6.
constructor...
(* Case *)
assert (closed_expr 0 e).
  apply H in H0; inversion H0; subst...
case IHX1...
unfold are_atoms; isa; contradiction.
destruct H5.
apply IHX2...
unfold setA in *.
destruct eq_var_dec...
inversion H7.
constructor...
eapply open_inv_to_closed0.
apply H4.
intuition.
case H6 with (s := q) (lf := Lf_n n f)...
(* Case *)
inversion J; subst...
case IHX...
destruct (In_dec eq_var_dec s ats).
  (* in *)
apply allocA_in in H3; auto.
apply in_map_iff in H3.
destruct H3.
rename x into lf0.
destruct H3.
assert (closed_lf (length lfs) lf0).
  apply H5; auto.
subst.
destruct lf0.
inversion_clear H7.
constructor; simpl.
fold map_expr.
rewrite <- H0 in *.
eapply open_inv_to_closed2...
rewrite map_length...
  (* not in *)
rewrite allocA_nin in H3; auto.
eapply H; auto.
apply H3.
apply open_inv_to_closed1...
(* Case *)
inversion J; subst.
assert (closed_expr 0 e).
  apply H4.
case IHX1...
unfold are_atoms; isa; contradiction.
destruct H3.
apply IHX2...
eapply open_inv_to_closed...
apply atoms_closed_constr in H3...
instantiate (1 := Update).
constructor...
assert (XX : closed_by_alt nil 0 (Alt c0 (length ps) e0))...
  apply H5.
  eapply In_select_case.
  apply H1.
inversion XX; subst...
Qed.

Lemma join_open :
forall Ds xs e, (e >< Ds)~[xs] = (e~[xs] >< Ds).
Proof with isa; intuition.
intros Ds xs.
assert (forall e n,
   map_expr (subst_var xs) n (e >< Ds) =
  (map_expr (subst_var xs) n  e >< Ds)).
  intro e.
  induction e using expr_ind2 with
  (P1 := fun (lf : lambda_form) => True)
  (P2 := fun (al : alt) => forall n,
     map_alt (subst_var xs) n (al ><' Ds) =
    (map_alt (subst_var xs) n  al ><' Ds))...
  (* Case App *)
  f_equal.
  induction vs...
  induction Ds...
  f_equal...
  f_equal...
  (* Case Letrec *)
  f_equal...
  (* Case Case *)
  f_equal.
  induction als...
  f_equal...
  (* Case Alt *)
  f_equal...
intro.
apply H with (n := 0).
Qed.

Lemma AAS_value_lemma :
forall Xi Omega b c ps qs N,
  ($ Xi $ b $ ps ↓↓ Omega $ c $ qs ^^ N) -> is_value c.
Proof with isa.
intros.
induction H...
Qed.

Proposition AAS_sound :
forall (N : nat) Xi Omega b c Ds Cs,
  (forall s lf, Xi s = Some lf -> closed_lf 0 lf) ->
  closed_expr 0 b ->
  ($ Xi $ b $ map Atom Ds ↓↓ Omega $ c $ map Atom Cs ^^ N) ->
  ($ Xi $ b >< Ds ↓ Omega $ c >< Cs).
Proof with intros; auto with arith.
intro N.
induction N using lt_wf_ind; isa.
destruct N;
  inversion H2; subst;
  try (rewrite <- plus_n_Sm in *; discriminate).
(* Case *)
isa.
(* Case *)
inversion H2; subst.
apply atoms_map_injection in H6.
subst.
eapply App1; simpl.
apply H8.
apply H12.
(* Case *)
dupl H11.
apply closed_AAS_atoms in H3...
destruct H3.
destruct H5.
dupl H1.
apply closed_0_args in H1.
apply atoms_exists in H1.
destruct H1.
rewrite H1 in *.
simpl.
rewrite <- map_app in *.
apply H in H11...
apply H0 with (s := s)...
eapply closed_rem_args; apply H7.
apply H0 with (s := s)...
eapply closed_rem_args; apply H1.
apply closed_0_args in H1.
apply atoms_app...
unfold are_atoms...
apply in_map_iff in H5.
destruct H5.
destruct H5.
unfold is_atom.
destruct a...
discriminate.
(* Case *)
caseA (le_lt_dec (length Ds) m).
  (* subcase eq *)
eapply App2.
apply H4.
rewrite map_length in *.
apply le_antisym...
assert (QQ : forall xs, e~[xs] = (e~[xs] >< nil)).
  intro.
  symmetry.
  apply join_nil.
rewrite QQ.
eapply H.
Focus 4.
rewrite firstn_length_eq_id in H12.
rewrite skipn_length_eq_nil in H12.
simpl.
apply H12.
rewrite map_length in *.
apply le_antisym...
rewrite map_length in *.
apply le_antisym...
omega.
auto.
eapply open_inv_to_closed.
apply atoms_map_atom.
rewrite map_length in *.
apply le_antisym...
instantiate (1 := Dont_update).
apply H0 with (s := p)...
  (* subcase lt *)
assert (m < length Ds)...
replace (skipn m (map Atom Ds)) with (nil ++ skipn m (map Atom Ds))
  in H12...
apply AAS_split in H12; (try exact nil)...
destruct H12.
destruct H6.
destruct H6.
destruct H6.
destruct H6.
destruct H6.
destruct H7.
destruct H8.
dupl H6.
apply closed_AAS_atoms in H10; auto.
Focus 2.
eapply open_inv_to_closed.
  rewrite firstn_map.
  apply atoms_map_atom.
  erewrite <- map_length in l.
  apply firstn_lt_length.
  apply l.
instantiate (1 := Dont_update).
apply H0 with (s := p)...
destruct H10.
destruct H11.
apply atoms_exists in H10.
destruct H10.
rewrite H10 in H6.
replace (nil (A := var)) with (map Atom nil) in H6...
dupl H6.
apply H in H6...
rewrite skipn_map in H7.
rewrite H10 in H7.
rewrite <- map_app in H7.
dupl H7.
rename H14 into HHH.
apply H in H7...
assert (is_value x0).
  eapply AAS_value_lemma; eauto.
inversion H14.
  subst.
simpl in *.
eapply App3.
apply H4.
rewrite map_length...
rewrite join_nil in H6; apply H6.
rewrite app_ass; rewrite skipn_map; rewrite <- map_app; auto.
  subst.
inversion HHH; subst.
apply skipn_lt_length_nil in H3.
rewrite map_app in H18.
assert (XX : map Atom x4 = nil).
  symmetry in H18.
  apply app_eq_nil in H18.
  destruct H18.
  auto.
rewrite XX in H18.
simpl in H18.
assert (nil = skipn m Ds).
  induction (skipn m Ds).
intuition.
simpl in *; discriminate.
intuition.
apply H12 with (s := s)...
apply H0 with (s := s)...
eapply open_inv_to_closed.
rewrite firstn_map.
apply atoms_map_atom.
rewrite firstn_lt_length...
rewrite map_length...
instantiate (1 := Dont_update).
apply H0 with (s := p)...
unfold are_atoms.
intuition.
inversion H11.
(* Case *)
simpl.
rewrite <- H3.
eapply App4.
apply H10.
rewrite <- join_nil.
rewrite <- join_nil with (e := e).
eapply H.
instantiate (1 := N).
omega.
apply H0.
rewrite <- empty_subst.
assert (QQ : forall m, zip_var_list m nil = nil).
  intros.
  simpl...
rewrite <- QQ with (m := 0).
eapply open_inv_to_closed...
apply atoms_nil.
instantiate (1 := Update).
apply H0 with (s := p)...
auto.
(* Case *)
dupl H7.
apply closed_AAS_atoms in H3.
destruct H3.
apply atoms_exists in H3.
destruct H3.
rewrite H3 in *.
rewrite <- map_app in H14.
apply H in H14.
assert (nil = map Atom nil).
  isa.
rewrite H9 in H7.
apply H in H7.
eapply App5.
apply H4.
apply H5.
apply H6.
  rewrite join_nil in H7.
  simpl in *.
apply H7.
  simpl.
  rewrite <- map_app.
apply H14.
auto with arith.
auto.
rewrite <- empty_subst.
assert (QQ : forall m, zip_var_list m nil = nil).
  intros.
  simpl...
rewrite <- QQ with (m := 0).
eapply open_inv_to_closed...
apply atoms_nil.
eapply H0.
apply H4.
auto with arith.
destruct H8.
isa.
destruct (eq_var_dec p s).
subst.
rewrite setA_eq in H10.
inversion H10.
constructor.
simpl.
eapply open_inv_to_closed0.
apply atoms_map_atom.
intuition.
instantiate (1 := Dont_update).
eapply H9.
apply H5.
rewrite setA_neq in H10.
eapply H9; apply H10.
auto.
tauto.
trivial.
rewrite <- empty_subst.
assert (QQ : forall m, zip_var_list m nil = nil).
  intros.
  simpl...
rewrite <- QQ with (m := 0).
eapply open_inv_to_closed...
apply atoms_nil.
eapply H0.
apply H4.
unfold are_atoms...
contradiction.
(* Case *)
eapply Let.
apply H4.
apply H5.
apply H6.
fold join_expr.
rewrite join_open.
eapply H.
instantiate (1 := N).
omega.
isa.
destruct (In_dec eq_var_dec s ats).
  (* subcase in *)
apply allocA_in in H3; auto.
apply in_map_iff in H3.
destruct H3.
rename x into lf0.
destruct H3.
assert (closed_lf (length lfs) lf0).
  inversion H1.
  subst.
  simpl in *.
  apply H10; auto.
subst.
destruct lf0.
inversion_clear H8.
constructor.
simpl.
fold map_expr.
rewrite <- H4 in *.
eapply open_inv_to_closed2...
rewrite map_length.
auto.
  (* subcase not in *)
rewrite allocA_nin in H3.
eapply H0.
apply H3.
apply n.
inversion H1; subst; isa.
apply open_inv_to_closed1; isa.
apply H13.
(* Case *)
dupl H6.
rename H3 into AAA.
apply closed_AAS_atoms in AAA...
assert (nil = map Atom nil).
  isa.
rewrite H3 in H6.
apply H in H6.
apply H in H13.
simpl in *.
eapply Case_of.
Focus 3.
rewrite join_nil in H6.
apply H6.
Focus 3.
instantiate (1 := e0 >< Ds).
instantiate (1 := length ps).
inversion H1; subst.
clear H3.
assert (In (Alt c1 (length ps) e0) als).
  eapply In_select_case.
  apply H5.
assert (closed_alt 0 (Alt c1 (length ps) e0)).
  apply H9...
inversion H4; subst; simpl in *.
assert (QWE : forall e Ds ps, closed_expr (length ps) e ->
  (e >< Ds)~[zip_var_list (length ps) ps] =
  ((e~[zip_var_list (length ps) ps]) >< Ds)).
  intros.
  apply join_open.
rewrite QWE...
auto.
instantiate (1 := c1).
clear H6 H1 H2 H13 AAA.
induction als.
simpl in *.
discriminate H5.
destruct a.
destruct (eq_nat_dec c0 c2).
subst.
simpl in H5 |- *.
destruct eq_nat_dec.
f_equal.
inversion H5.
subst.
f_equal.
destruct n...
simpl in H5 |- *.
destruct (eq_nat_dec c0 c2) in H5 |- *.
subst.
destruct n...
apply IHals.
apply H5.
auto with arith.
tauto.
intuition.
inversion H1; subst.
assert (In (Alt c1 (length ps) e0) als).
  eapply In_select_case.
  apply H5.
assert (BBB : closed_alt 0 (Alt c1 (length ps) e0)).
  apply H12.
  auto.
inversion BBB; subst.
simpl in *.
apply open_inv_to_closed1...
apply atoms_closed_constr in H8...
auto with arith.
trivial.
inversion H1...
apply H0 with (s := s)...
inversion H1...
unfold are_atoms.
intuition.
inversion H3.
Qed.

Proposition AAS_sound2 :
forall b c Omega Cs,
  closed_expr 0 b ->
  ($ emptyA $ b $ nil ↓↓ Omega $ c $ map Atom Cs) ->
  ($ emptyA $ b ↓ Omega $ c >< Cs).
Proof with isa.
intros.
assert (BNIL : (b >< nil) = b).
  apply join_nil.
rewrite <- BNIL.
dupl H0.
apply aasn_complete in H0.
destruct H0.
apply AAS_sound with (N := x)...
unfold emptyA in H1; discriminate.
Qed.


Require Import erasure.
Require Import NonSpecPureStep.
Require Import eraseRollbackIdempotent.
Require Import IndependenceCommon.
Require Import SpecImpliesNonSpec.
Require Import progStepWF.

(*H; T ->+ H'; T'*)
Inductive pstepPlus : pHeap -> pPool -> pHeap -> pPool -> Prop :=
|stepPlus' : forall H H' H'' T T'' t t',
              pstep H T t (pOK H' T t') ->
              pmultistep H' (pUnion T t') (Some(H'', T'')) ->
              pstepPlus H (pUnion T t) H'' T''.

Theorem AddUnion : forall A T t, Add A T t = Union A T (Single A t).
reflexivity.
Qed.

Theorem raw_lookupEraseCommitEmpty : forall x H,
                                   raw_heap_lookup x H = Some(sempty COMMIT) ->
                                   raw_heap_lookup x (raw_eraseHeap H) = Some pempty.
Proof.
  induction H; intros.
  {inv H. }
  {simpl in *. destruct a. destruct (beq_nat x i) eqn:eq.
   {inv H0. simpl. rewrite eq. auto. }
   {destruct i0. destruct s; eauto. simpl. rewrite eq. auto.
    destruct s; auto. destruct s0; simpl; rewrite eq; auto. }
  }
Qed.

Theorem lookupEraseCommitEmpty : forall x H,
                                   heap_lookup x H = Some(sempty COMMIT) ->
                                   heap_lookup x (eraseHeap H) = Some pempty.
Proof.
  intros. destruct H. simpl. eapply raw_lookupEraseCommitEmpty; eauto.
Qed.

Theorem raw_eraseCommitWrite : forall x H ds TID N,
                             raw_heap_lookup x H = Some (sempty COMMIT) ->
                             raw_eraseHeap (raw_replace x (sfull COMMIT ds COMMIT TID N) H) =
                             raw_replace x (pfull (eraseTerm N)) (raw_eraseHeap H).
Proof.
  induction H; intros.
  {inv H. }
  {simpl in *. destruct a. destruct (beq_nat x i) eqn:eq.
   {inv H0. simpl. rewrite eq. auto. }
   {simpl. erewrite IHlist; eauto. destruct i0. destruct s; auto.
    simpl. rewrite eq. auto. destruct s; auto. destruct s0; simpl; rewrite eq.
    auto. auto. }
  }
Qed.

Theorem eraseCommitWrite : forall x H ds TID N,
                             heap_lookup x H = Some (sempty COMMIT) ->
                             eraseHeap (replace x (sfull COMMIT ds COMMIT TID N) H) =
                             replace x (pfull (eraseTerm N)) (eraseHeap H).
Proof.
  intros. destruct H. simpl. apply rawHeapsEq. eapply raw_eraseCommitWrite; eauto.
Qed.

Theorem unspecEmpty : forall tid s2 M s1,
                        unspecPool(tSingleton(tid,locked s1, s2, M)) =
                        Empty_set thread. auto. Qed.

Theorem raw_lookupEraseNoneNone : forall x H,
                                raw_heap_lookup x H = None ->
                                raw_heap_lookup x (raw_eraseHeap H) = None.
Proof.
  induction H; intros.
  {auto. }
  {simpl in *. destruct a. destruct (beq_nat x i) eqn:eq.
   {inv H0. }
   {destruct i0. destruct s; auto. simpl. rewrite eq; auto.
    destruct s; auto. destruct s0; simpl; rewrite eq; auto. }
  }
Qed.

Theorem lookupEraseNoneNone : forall x H,
                                heap_lookup x H = None ->
                                heap_lookup x (eraseHeap H) = None.
Proof.
  intros. destruct H. simpl. eapply raw_lookupEraseNoneNone; eauto.
Qed.

Theorem prog_specImpliesNonSpec : forall H H' T t t',
                               prog_step H T t (OK H' T t') -> wellFormed H (tUnion T t) ->
                               exists PH' T', pstepPlus (eraseHeap H) (erasePool (tUnion T t)) PH' T' /\
                                               eraseHeap H' = PH' /\ erasePool (tUnion T t') = T'.
Proof.
  intros. inv H0.
  {exists (eraseHeap H'). econstructor. split; auto. repeat rewrite eraseUnionComm.
   simpl. apply simBasicStep in H6. econstructor. eapply PBasicStep. eauto.
   constructor. }
  {apply rollbackIdempotent in H7. invertHyp. copy d.
   erewrite <- decomposeErase in H3; eauto. econstructor. econstructor. split.
   unfoldTac. rewrite AddUnion. rewrite Union_associative. rewrite eraseUnionComm.
   econstructor. eapply PPut. simpl in *. copy H3. apply pdecomposeEq in H3.
   rewrite H3 in H7. rewrite eraseFill; eauto. eapply lookupEraseSpecFull; eauto.
   auto. constructor. split. rewrite H2. eapply eraseCommitWrite; eauto.
   unfoldTac. rewrite AddUnion. rewrite Union_associative. rewrite eraseUnionComm.
   simpl. rewrite eraseFill; eauto. repeat rewrite eraseUnionComm. rewrite H0.
   auto. }
  {inv H1. unfoldTac. rewrite coupleUnion in H0.
   repeat rewrite unspecUnionComm in H0. econstructor. econstructor. split; auto.
   rewrite coupleUnion. repeat rewrite eraseUnionComm. rewrite eraseEmptySpec.
   unfold pUnion. rewrite union_empty_r. repeat rewrite Union_associative in H0.
   econstructor. eapply pSpecRun. copy p. erewrite <- decomposeErase in H; eauto.
   simpl. auto. copy p. apply decomposeWF in H. rewrite eraseCtxtWF in H.
   simpl in H. copy p. rewrite <- decomposeErase in H1; eauto. simpl in H1.
   destructLast s1.
   {simpl. rewrite eraseFill. unfoldTac. rewrite UnionSwap in H0.
    rewrite Union_associative in H0. rewrite UnionSwap in H0.
    rewrite spec_multi_unused in H0. eapply simSpecJoinSteps; eauto. simpl in *.
    eassumption. }
   {unfoldTac. rewrite UnionSwap in H0. rewrite Union_associative in H0.
    rewrite UnionSwap in H0. rewrite spec_multi_unused in H0. invertHyp.
    rewrite wrapDistributeApp. destruct x.
    {simpl (wrapActs [rAct x t E0 d] N1 E (specRun (ret N1) N0)(decomposeWF t0 E (specRun (ret N1) N0) p)).
     erewrite eraseLastAct; eauto. eauto. rewrite eraseFill.
     eapply simSpecJoinSteps';[idtac|eauto|simpl in *; eauto]. constructor. }
    {simpl (wrapActs [wAct x t E0 M0 d] N1 E (specRun (ret N1) N0)(decomposeWF t0 E (specRun (ret N1) N0) p)).
     erewrite eraseLastAct; eauto. rewrite eraseFill.
     eapply simSpecJoinSteps';[idtac|eauto|simpl in *; eauto]. constructor. }
    {simpl (wrapActs [nAct t E0 d i] N1 E (specRun (ret N1) N0)(decomposeWF t0 E (specRun (ret N1) N0) p)).
     erewrite eraseLastAct; eauto. rewrite eraseFill.
     eapply simSpecJoinSteps'; [idtac|eauto|simpl in *; eauto]. constructor. }
    {simpl (wrapActs [fAct t E0 M0 d n] N1 E (specRun (ret N1) N0)(decomposeWF t0 E (specRun (ret N1) N0) p)).
     erewrite eraseLastAct; eauto. rewrite eraseFill.
     eapply simSpecJoinSteps';[idtac|eauto|simpl in *; eauto]. constructor. }
    {simpl (wrapActs [srAct t E0 M0 N d] N1 E (specRun (ret N1) N0)(decomposeWF t0 E (specRun (ret N1) N0) p)).
     erewrite eraseLastAct; eauto. rewrite eraseFill.
     eapply simSpecJoinSteps'; [idtac|eauto|simpl in *; eauto]. constructor. }
   }
  }
  {apply rollbackIdempotent in H10. invertHyp.
   erewrite <- decomposeErase in H4; eauto. econstructor. econstructor. split.
   unfoldTac. rewrite Union_associative. rewrite coupleUnion.
   repeat rewrite eraseUnionComm. simpl. econstructor. eapply pSpecRunRaise.
   simpl in *; eauto. constructor. split. auto. unfoldTac. rewrite AddUnion.
   rewrite Union_associative. repeat rewrite eraseUnionComm. simpl.
   repeat rewrite AddUnion in H0. rewrite Union_commutative in H0. simpl in H0.
   rewrite Union_commutative in H0. simpl in H0. rewrite H0.
   rewrite eraseFill; eauto. }
  {exists (eraseHeap H). econstructor. split. Focus 2. split; auto.
   erewrite eraseHeapDependentRead. auto. eauto. inv H1. eraseTrmTac s1' M.
   rewrite eraseUnionComm. erewrite eraseLastAct; eauto. econstructor.
   eapply PGet; eauto. eapply lookupEraseCommitFull; eauto. copy d.
   erewrite <- decomposeErase in H0; eauto. rewrite unspecUnionComm in H2.
   erewrite unspecLastActPool in H2. Focus 2. constructor.
   eapply specStepRead in H2; eauto. invertHyp. eapply simPureSteps in H0; eauto.
   rewrite eraseFill in H0. simpl in H0. rewrite eraseUnionComm.
   erewrite eraseEraseTrm; eauto. eapply unspecHeapLookupFull; eauto. }
  {exists (replace x (pfull (eraseTerm M'')) (eraseHeap H)). econstructor. split.
   Focus 2. split; eauto. erewrite eraseHeapCommitWrite; eauto. inv H1.
   repeat rewrite eraseUnionComm. erewrite eraseLastAct. Focus 2. constructor.
   rewrite unspecUnionComm in H2. erewrite unspecLastActPool in H2. Focus 2.
   constructor. eraseTrmTac s1' M. erewrite eraseEraseTrm; eauto.
   eapply specStepWrite in H2; eauto. invertHyp. eapply simPureSteps in H0; eauto.
   rewrite eraseFill in H0. simpl in H0. econstructor. eapply PPut; eauto. copy d.
   erewrite <- decomposeErase in H2; eauto. simpl. auto.
   eapply lookupEraseSpecFull; eauto. eassumption.
   eapply lookupUnspecSpecFullEmpty; eauto. }
  {inv H1. assert(heap_lookup i (eraseHeap H) = None).
   eapply lookupEraseSpecNone; eauto. exists (Heap.extend i pempty (eraseHeap H) H0).
   econstructor. split. Focus 2. split; eauto. eapply eraseHeapCommitNewFull; eauto.
   repeat rewrite eraseUnionComm. erewrite eraseLastAct. Focus 2. constructor.
   econstructor. eapply PNew with(x:=i)(p:=H0); eauto. copy d.
   erewrite <- decomposeErase in H1; eauto. rewrite unspecUnionComm in H2.
   erewrite unspecLastActPool in H2. Focus 2. constructor. eraseTrmTac s1' M.
   eapply specStepNewFull in H2; eauto. invertHyp. eapply simPureSteps in H1; eauto.
   rewrite eraseFill in H1. erewrite eraseEraseTrm; eauto.
   eapply lookupUnspecSpecNone; eauto. }
  {inv H1. assert(heap_lookup i (eraseHeap H) = None).
   eapply lookupEraseSpecNoneEmpty; eauto.
   exists (Heap.extend i pempty (eraseHeap H) H0). econstructor. split. Focus 2.
   split;eauto. eapply eraseHeapCommitNewEmpty; eauto. repeat rewrite eraseUnionComm.
   erewrite eraseLastAct. Focus 2. constructor. econstructor.
   eapply PNew with (x:=i)(p:=H0); eauto. copy d.
   erewrite <- decomposeErase in H1; eauto. eraseTrmTac s1' M.
   erewrite eraseEraseTrm; eauto. rewrite unspecUnionComm in H2.
   erewrite unspecLastActPool in H2. Focus 2. constructor.
   eapply specStepNewEmpty in H2; eauto. invertHyp.
   eapply simPureSteps in H1; eauto. rewrite eraseFill in H1. eassumption.
   eapply lookupUnspecSpecEmptyNone; eauto. }
  {exists (eraseHeap H'). econstructor. split; auto. inv H1.
   unfoldTac. rewrite coupleUnion. repeat rewrite eraseUnionComm. rewrite eraseEmpty.
   unfold pUnion. rewrite union_empty_r. erewrite eraseLastAct. Focus 2. constructor.
   econstructor. eapply pFork. copy d. erewrite <- decomposeErase in H; eauto.
   simpl. auto. rewrite coupleUnion in H0. repeat rewrite unspecUnionComm in H0.
   rewrite unspecEmpty in H0. erewrite unspecLastActPool in H0. Focus 2. constructor.
   unfoldTac. rewrite union_empty_r in H0. rewrite <- coupleUnion in H0.
   eapply specStepFork in H0; eauto. invertHyp. rewrite eraseUnspecHeapIdem in H1.
   rewrite <- H1. eraseTrmTac s1' M. eraseTrmTac s1'' N. unfoldTac.
   repeat rewrite coupleUnion in H. repeat rewrite Union_associative in H.
   repeat rewrite coupleUnion. rewrite eraseUnionComm.
   repeat erewrite eraseEraseTrm;eauto. unfold pUnion. repeat rewrite <- coupleUnion.
   copy H. eapply simPureStepsCouple' with(H'':=eraseHeap x)(PT:=erasePool T)
    (N:=pfill (eraseCtxt E)(pret punit)) in H; eauto. unfold pCouple. rewrite couple_swap.
   eapply pmulti_trans. eassumption. rewrite UnionSwap in H0. rewrite <- Union_associative in H0.
   rewrite UnionSwap in H0. rewrite Union_associative in H0.
   eapply simPureStepsCouple in H0; eauto. rewrite eraseFill in H0; eauto.
   unfold pCouple in *. rewrite couple_swap in H0. eauto. }
  {exists (eraseHeap H'). econstructor. split; auto. inv H1. unfoldTac.
   rewrite coupleUnion in *. repeat rewrite unspecUnionComm in H0.
   rewrite unspecEmpty in H0. unfoldTac. rewrite union_empty_r in H0.
   repeat rewrite eraseUnionComm. rewrite eraseEmpty. erewrite eraseLastAct. Focus 2.
   constructor. unfold pUnion. rewrite union_empty_r. econstructor.
   eapply pSpec. copy d. rewrite <- decomposeErase in H; eauto. simpl. auto.
   rewrite <- coupleUnion in H0. erewrite unspecLastActPool in H0. Focus 2. constructor.
   eapply specStepSpec in H0; eauto. invertHyp. eraseTrmTac s1' M'. rewrite coupleUnion.
   rewrite eraseUnionComm. erewrite eraseEraseTrm; eauto. simpl. unfoldTac.
   flipCouplesIn H.  repeat rewrite coupleUnion in H. repeat rewrite Union_associative in H.
   eapply simPureSteps in H; eauto. rewrite eraseFill in H. eassumption. }
Qed.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Sebastien Hinderer, 2004-02-09

general definitions and results about relations on terms
*)

Set Implicit Arguments.

From CoLoR Require Import SN ASubstitution ATerm RelUtil AContext LogicUtil
     VecUtil NaryFunction.
From Coq Require Import List.

Section S.

  Variable Sig : Signature.

  Notation term := (term Sig).

(***********************************************************************)
(** basic definitions *)

  Section basic.

    Variable R : relation term.

    Definition preserve_vars := forall t u, R t u -> incl (vars u) (vars t).

    Definition substitution_closed :=
      forall t1 t2 s, R t1 t2 -> R (sub s t1) (sub s t2).

    Definition context_closed :=
      forall t1 t2 c, R t1 t2 -> R (fill c t1) (fill c t2).

    Definition rewrite_ordering := substitution_closed /\ context_closed.

    Definition reduction_ordering := WF R /\ rewrite_ordering.

  End basic.

  Record Rewrite_ordering : Type := mkRewrite_ordering {
    rew_ord_rel :> relation term;
    rew_ord_subs : substitution_closed rew_ord_rel;
    rew_ord_cont : context_closed rew_ord_rel
  }.

(***********************************************************************)
(** closure by substitution *)

  Lemma substitution_closed_rtc : forall R,
    substitution_closed R -> substitution_closed (R #).

  Proof.
    intros R h t u s. induction 1. apply rt_step. apply h. hyp.
    apply rt_refl. apply rt_trans with (sub s y); hyp.
  Qed.

  Lemma substitution_closed_transp : forall R,
    substitution_closed R -> substitution_closed (transp R).

  Proof.
    intros R hR t u s. unfold transp. apply hR.
  Qed.

(***********************************************************************)
(** closure by context *)

  Lemma context_closed_rtc : forall R, context_closed R -> context_closed (R #).

  Proof.
    intros R h t u c. induction 1. apply rt_step. apply h. hyp.
    apply rt_refl. apply rt_trans with (fill c y); hyp.
  Qed.

  Lemma context_closed_tc : forall R, context_closed R -> context_closed (R !).

  Proof.
    intros R h t u c. induction 1. apply t_step. apply h. hyp.
    apply t_trans with (fill c y); hyp.
  Qed.

  Lemma context_closed_comp : forall R S,
    context_closed R -> context_closed S -> context_closed (R @ S).

  Proof.
    intros R S hR hS t v c [u [h1 h2]]. exists (fill c u). split.
    apply hR. hyp. apply hS. hyp.
  Qed.

  Lemma context_closed_fun : forall R, context_closed R ->
    forall f i v1 t u j v2 (e : i+S j=arity f),
      R t u -> R (Fun f (Vcast (Vapp v1 (Vcons t v2)) e))
                 (Fun f (Vcast (Vapp v1 (Vcons u v2)) e)).

  Proof.
    intros. set (c := Cont f e v1 Hole v2). change (R (fill c t) (fill c u)).
    apply H. hyp.
  Qed.

  Lemma Vmonotone_context_closed : forall R,
    (forall f : Sig, Vmonotone (Fun f) R R) <-> context_closed R.

  Proof.
    split; intro.
    unfold context_closed. induction c; simpl; intros. hyp. apply H. auto.
    unfold Vmonotone, Vmonotone_i, RelUtil.monotone. intros.
    set (c := Cont f H0 vi Hole vj). change (R (fill c x) (fill c y)).
    apply H. hyp.
  Qed.

(***********************************************************************)
(** reduction pair *)

  Section reduction_pair.

    Variables R E : relation term.

    Definition reduction_pair :=
      reduction_ordering R /\ absorbs_left R E /\ rewrite_ordering E.

  End reduction_pair.

(*FIXME: defined as weak_reduction_pair + something*)
  Record Reduction_pair : Type := mkReduction_pair {
    rp_succ : relation term;
    rp_succ_eq : relation term;
    rp_subs : substitution_closed rp_succ;
    rp_subs_eq : substitution_closed rp_succ_eq;
    rp_cont : context_closed rp_succ;
    rp_cont_eq : context_closed rp_succ_eq;
    rp_absorb : absorbs_left rp_succ rp_succ_eq;
    rp_succ_wf : WF rp_succ
  }.

(***********************************************************************)
(** weak reduction pair *)

  Section weak_reduction_pair.

    Variables R E : relation term.

    Definition weak_context_closed :=
      forall t1 t2 c, R t1 t2 -> E (fill c t1) (fill c t2).

    Definition weak_rewrite_ordering :=
      substitution_closed R /\ weak_context_closed.

    Definition weak_reduction_ordering := WF R /\ weak_rewrite_ordering.

    Definition weak_reduction_pair :=
      weak_reduction_ordering /\ absorbs_left R E /\ rewrite_ordering E.

  End weak_reduction_pair.

  Record Weak_reduction_pair : Type := mkWeak_reduction_pair {
    wp_succ : relation term;
    wp_succ_eq : relation term;
    wp_subs : substitution_closed wp_succ;
    wp_subs_eq : substitution_closed wp_succ_eq;
    wp_cont_eq : context_closed wp_succ_eq;
    wp_absorb : absorbs_left wp_succ wp_succ_eq;
    wp_succ_wf : WF wp_succ
  }.

(***********************************************************************)
(** reflexive closure *)

  Section clos_refl.

    Variable R : relation term.

    Notation E := (R %).

    Lemma rc_context_closed :
      weak_context_closed R E -> context_closed E.

    Proof.
      intro. unfold context_closed. intros. unfold clos_refl, union in H0.
      decomp H0. subst t2. unfold clos_refl, union. auto. apply H. hyp.
    Qed.

    Lemma rc_substitution_closed :
      substitution_closed R -> substitution_closed E.

    Proof.
      intro. unfold substitution_closed, clos_refl, union. intros. decomp H0.
      subst t2. auto. right. apply H. hyp.
    Qed.

    Lemma rc_rewrite_ordering :
      weak_rewrite_ordering R E -> rewrite_ordering E.

    Proof.
      intros (Hsubs,Hcont). split. apply rc_substitution_closed. hyp.
      apply rc_context_closed. hyp.
    Qed.

  End clos_refl.

(***********************************************************************)
(** when R is the strict part of E *)

  Section strict.

    Variables (E : relation term) (E_trans : transitive E).

    Notation R := (strict_part E).

    Lemma absorb_strict : absorbs_left R E.

    Proof.
      unfold absorbs_left, inclusion, RelUtil.compose, strict_part.
      intros; split; decomp H. eapply E_trans. apply H1. hyp.
      unfold not; intro. ded (E_trans H H1). contr.
    Qed.

  End strict.

(***********************************************************************)
(** subterm relation *)

  Lemma substitution_closed_subterm_eq : substitution_closed (@subterm_eq Sig).

  Proof.
    intros t u s h. destruct h as [C h]. subst. rewrite sub_fill.
    exists (subc s C). refl.
  Qed.

  Lemma substitution_closed_subterm : substitution_closed (@subterm Sig).

  Proof.
    intros t u s h. destruct h as [C h]. destruct h as [C0 h]. subst.
    rewrite sub_fill.
    exists (subc s C). split; try refl. destruct C. simpl. auto. discr.
  Qed.

End S.


Section General_Definitions.

  Definition approx := (env * (term * list term))%type.

  Fixpoint app_list (args : list term) : term -> term :=
    fun t =>
    match args with
    | nil => t
    | hd :: tl => app_list tl (App t hd)
    end.

End General_Definitions.

Section Beta_Reduction.

  Inductive beta : env -> term -> term -> Prop :=
      beta_intro :
        forall (e : env) (M N T : term), beta e (App (Abs T M) N) (subst N M).

  Hint Resolve beta_intro: pts.

  Lemma beta_rule : Basic_rule.
apply Build_Basic_rule with beta.
red in |- *.
simple induction 1; simpl in |- *; intros.
rewrite distr_lift_subst; auto with arith pts.

red in |- *.
simple induction 1; simpl in |- *; intros.
rewrite distr_subst; auto with arith pts.

red in |- *; intros.
elim H; auto with arith pts.
Defined.

  Lemma sort_beta_norm : forall (e : env) (s : sort), normal beta e (Srt s).
red in |- *; red in |- *; intros.
inversion_clear H.
Qed.

  Lemma prod_beta_norm :
   forall (e : env) (A B : term), normal beta e (Prod A B).
red in |- *; red in |- *; intros.
inversion_clear H.
Qed.

End Beta_Reduction.

  Hint Resolve beta_intro: pts.

Section Delta_Reduction.

  Inductive delta : env -> term -> term -> Prop :=
      delta_intro :
        forall (e : env) (n : nat) (d T : term),
        item (Def d T) e n -> delta e (Ref n) (lift (S n) d).

  Lemma delta_rule : Basic_rule.
apply Build_Basic_rule with delta.
red in |- *.
simple induction 1; simpl in |- *; intros.
elim (le_gt_dec k n); intros.
unfold lift in |- *.
rewrite simpl_lift_rec; simpl in |- *; auto with arith pts.
change (delta f (Ref (S n)) (lift (S (S n)) d)) in |- *.
apply delta_intro with T; auto with arith pts.
apply ins_item_ge with (1 := H1); auto with arith pts.

unfold lift in |- *.
replace k with (S n + (k - S n)); auto with arith pts.
elim permute_lift_rec with d 1 (k - S n) (S n) 0; auto with arith pts.
change (delta f (Ref n) (lift (S n) (lift_rec 1 d (k - S n)))) in |- *.
apply delta_intro with (lift_rec 1 T (k - S n)).
change (item (lift_decl 1 (Def d T) (k - S n)) f n) in |- *.
apply ins_item_lt with (1 := H1); auto with arith pts.

red in |- *.
simple induction 1; simpl in |- *; intros.
elim (lt_eq_lt_dec n0 n); intros.
red in |- *.
elim a.
generalize H0.
clear H0.
case n; simpl in |- *; intros.
inversion_clear a0.

rewrite simpl_subst; auto with arith pts.
apply rt_step.
apply delta_intro with T.
apply nth_sub_sup with (1 := H1); auto with arith pts.

intro.
rewrite b.
rewrite simpl_subst.
rewrite b in H1.
generalize H1.
rewrite nth_sub_eq with (1 := H1) (2 := H0).
intro.
elim sub_decl_eq_def with (1 := H2).
auto with arith pts.

auto with arith pts.

red in |- *; apply rt_step.
replace n0 with (S n + (n0 - S n)); auto with arith pts.
unfold lift in |- *.
elim commut_lift_subst_rec with d s (S n) (n0 - S n) 0; auto with arith pts.
change (delta f (Ref n) (lift (S n) (subst_rec s d (n0 - S n)))) in |- *.
apply delta_intro with (subst_rec s T (n0 - S n)).
change (item (subst_decl s (Def d T) (n0 - S n)) f n) in |- *.
apply nth_sub_inf with (1 := H1); auto with arith pts.

red in |- *; intros.
inversion_clear H.
elim red_item with R' n (Def d T) e f; intros; auto with arith pts.
apply delta_intro with T; auto with arith pts.

elim item_trunc with decl n e (Def d T); intros; auto with arith pts.
elim H with x0; intros; auto with arith pts.
inversion_clear H3.
generalize H6.
inversion_clear H5; intros.
apply delta_intro with U; auto with arith pts.
Defined.

  Lemma delta_reduce :
   forall (n : nat) (e : env),
   {def : term | delta e (Ref n) def} +
   {(forall x : term, ~ delta e (Ref n) x)}.
(*Realizer [n:nat][e:env]Cases (list_item ? e n) of
             (inleft (Ax T)) => (inright term)
           | (inleft (Def d T)) => (inleft term (lift (S n) d))
           | _ => (inright term)
           end.
*)
intros.
case (list_item e n); [ intros ([T| d T], is_dcl) | intros ].
right; red in |- *; intros.
inversion_clear H.
absurd (Ax T = Def d T0).
discriminate.

apply fun_item with e n; auto with arith pts.

left; exists (lift (S n) d).
apply delta_intro with T; auto with arith pts.

right; red in |- *; intros.
inversion_clear H.
elim n0 with (Def d T); auto with arith pts.
Qed.

  Lemma sort_delta_norm : forall (e : env) (s : sort), normal delta e (Srt s).
red in |- *; red in |- *; intros.
inversion_clear H.
Qed.

  Lemma prod_delta_norm :
   forall (e : env) (A B : term), normal delta e (Prod A B).
red in |- *; red in |- *; intros.
inversion_clear H.
Qed.

End Delta_Reduction.


From ITree Require Import
     Basics
     Subevent
     Indexed.Sum.

From Coq Require Import
     Fin
     Lia
     Vector
     String.

From ExtLib Require Import
     RelDec
     Maps
     FMapAList
     Reducible
     Traversable
     Monads
     Option.

From Coinduction Require Import
     coinduction rel tactics.

From CTree Require Import
     CTree
     Interp
     State
     Eq
     SBisim.

From DSL Require Import
     System
     Network
     Utils
     Vectors.

From Equations Require Import Equations.

Import MonadNotation.
Local Open Scope monad_scope.
Local Open Scope string_scope.
Local Open Scope vector_scope.

Set Implicit Arguments.
Set Strict Implicit.
Set Asymmetric Patterns.

Module Examples.
  Module Network := Network(DistrSystem).
  Import Network DistrSystem.

  (** Some uids *)
  Program Definition alice : uid 2 := @of_nat_lt 0 2 _.
  Program Definition bob : uid 2 := @of_nat_lt 1 2 _.

  (** Some programs *)
  Definition example_alice :=
    a <- load "a";;
    send {| principal := bob; payload := default a 0 |};;
    a' <- recv;;
    store "b" (payload a').

  Definition example_bob: ctree (Storage +' Net 2) unit :=
    m <- recv ;;
    send {| principal := principal m; payload := S (payload m) |}.

  (** A Single agent program *)
  Definition example: ctree (Storage +' Net 2) unit :=
    a <- load "a";;
    store "b" (S (default a 0)).

  Definition example_skip: ctree (Storage +' Net 2) unit :=
    Ret tt.

  (** Here we are evaluating two distributed systems to CTrees C1, C2.
      We will show they are equivalent by some sort of Applicative Bisimulation
      using the leaf equivalence below. *)
 Definition init_heap := (List.cons ("a", 0) List.nil).

  Definition C1 := run_network (map voidR (run_storage [example; example_skip] init_heap)).
  Definition C2 := run_network (map voidR (run_storage [example_alice; example_bob] init_heap)).

  Check (run_storage [example] init_heap).

  Definition final_heap1: heap := List.cons ("b", 1) (List.cons ("a", 0)   List.nil).
  Definition final_heap2: heap := List.cons ("a", 0) List.nil.

  Lemma left_tree_simpl: C1 ~ Ret (Some
                                     [(final_heap1, tt, List.nil); (final_heap2, tt, List.nil)]).
  Proof.
    unfold C1, final_heap1, final_heap2, init_heap, run_storage.
    rewrite Vector.map_map.
    cbn.
    unfold run_state.
    Search interp_state.
    s
    rewrite interp_state_bind.
    cbn.
    replace (map voidR (run_storage [example; example_skip] init_heap)) with
      ([run_storage example init_heap; run_storage example_skip init_heap]).

    Search map.

    sb_fwd_I.
    Check run_state.
    time repeat (sb_fwd_I; try reflexivity).
  Qed.

  Lemma sb_c1_c2: C1 ~ C2.
  Proof.
    rewrite left_tree_simpl.
    unfold C1, C2, init_heap.
    time repeat (sb_fwd_I; try reflexivity).
    (**  Takes 6035.167 secs ~ 1.7h *)
  Qed.

End Examples.


Require Export Iron.Language.SystemF2Cap.Value.
Require Export Iron.Language.SystemF2Cap.Store.
Require Export Iron.Language.SystemF2Cap.Step.Frame.
Require Export Iron.Language.SystemF2Cap.Step.TypeF.

(********************************************************************)
(* Type of an expression in a frame context. *)
Inductive TypeC
   :  kienv -> tyenv
   -> stenv -> stprops
   -> stack -> exp
   -> ty    -> ty -> Prop :=
 | TcExp
   :  forall ke te se sp fs x1 t1 e1 t2 e2 e3
   ,  EquivT ke sp (TSum e1 e2) e3 KEffect
   -> TypeX  ke te se sp x1 t1 e1
   -> TypeF  ke te se sp fs t1 t2 e2
   -> TypeC  ke te se sp fs x1 t2 e3.

Hint Constructors TypeC.

Ltac inverts_typec :=
 repeat
  (try (match goal with
        | [H: TypeC _ _ _ _ _ _ _ _ |- _ ] => inverts H
        end);
   try inverts_typef).

(********************************************************************)
Lemma typeC_kindT_effect
 :  forall ke te se sp fs x t e
 ,  TypeC  ke te se sp fs x t e
 -> KindT  ke sp e KEffect.
Proof.
 intros.
 induction H; eauto.
Qed.


From stdpp Require Export namespaces.
From iris.algebra Require Import gmap.
From iris.proofmode Require Import tactics.
From iris.base_logic.lib Require Export fancy_updates.
From iris.base_logic.lib Require Import wsat.
From iris.prelude Require Import options.
Import uPred.

(** Semantic Invariants *)
Definition inv_def `{!invG Σ} (N : namespace) (P : iProp Σ) : iProp Σ :=
  □ ∀ E, ⌜↑N ⊆ E⌝ → |={E,E ∖ ↑N}=> ▷ P ∗ (▷ P ={E ∖ ↑N,E}=∗ True).
Definition inv_aux : seal (@inv_def). Proof. by eexists. Qed.
Definition inv := inv_aux.(unseal).
Global Arguments inv {Σ _} N P.
Definition inv_eq : @inv = @inv_def := inv_aux.(seal_eq).
Global Instance: Params (@inv) 3 := {}.

(** * Invariants *)
Section inv.
  Context `{!invG Σ}.
  Implicit Types i : positive.
  Implicit Types N : namespace.
  Implicit Types E : coPset.
  Implicit Types P Q R : iProp Σ.

  (** ** Internal model of invariants *)
  Definition own_inv (N : namespace) (P : iProp Σ) : iProp Σ :=
    ∃ i, ⌜i ∈ (↑N:coPset)⌝ ∧ ownI i P.

  Lemma own_inv_acc E N P :
    ↑N ⊆ E → own_inv N P ={E,E∖↑N}=∗ ▷ P ∗ (▷ P ={E∖↑N,E}=∗ True).
  Proof.
    rewrite uPred_fupd_eq /uPred_fupd_def. iDestruct 1 as (i) "[Hi #HiP]".
    iDestruct "Hi" as % ?%elem_of_subseteq_singleton.
    rewrite {1 4}(union_difference_L (↑ N) E) // ownE_op; last set_solver.
    rewrite {1 5}(union_difference_L {[ i ]} (↑ N)) // ownE_op; last set_solver.
    iIntros "(Hw & [HE $] & $) !> !>".
    iDestruct (ownI_open i with "[$Hw $HE $HiP]") as "($ & $ & HD)".
    iIntros "HP [Hw $] !> !>". iApply (ownI_close _ P). by iFrame.
  Qed.

  Lemma fresh_inv_name (E : gset positive) N : ∃ i, i ∉ E ∧ i ∈ (↑N:coPset).
  Proof.
    exists (coPpick (↑ N ∖ gset_to_coPset E)).
    rewrite -elem_of_gset_to_coPset (comm and) -elem_of_difference.
    apply coPpick_elem_of=> Hfin.
    eapply nclose_infinite, (difference_finite_inv _ _), Hfin.
    apply gset_to_coPset_finite.
  Qed.

  Lemma own_inv_alloc N E P : ▷ P ={E}=∗ own_inv N P.
  Proof.
    rewrite uPred_fupd_eq. iIntros "HP [Hw $]".
    iMod (ownI_alloc (.∈ (↑N : coPset)) P with "[$HP $Hw]")
      as (i ?) "[$ ?]"; auto using fresh_inv_name.
    do 2 iModIntro. iExists i. auto.
  Qed.

  (* This does not imply [own_inv_alloc] due to the extra assumption [↑N ⊆ E]. *)
  Lemma own_inv_alloc_open N E P :
    ↑N ⊆ E → ⊢ |={E, E∖↑N}=> own_inv N P ∗ (▷P ={E∖↑N, E}=∗ True).
  Proof.
    rewrite uPred_fupd_eq. iIntros (Sub) "[Hw HE]".
    iMod (ownI_alloc_open (.∈ (↑N : coPset)) P with "Hw")
      as (i ?) "(Hw & #Hi & HD)"; auto using fresh_inv_name.
    iAssert (ownE {[i]} ∗ ownE (↑ N ∖ {[i]}) ∗ ownE (E ∖ ↑ N))%I
      with "[HE]" as "(HEi & HEN\i & HE\N)".
    { rewrite -?ownE_op; [|set_solver..].
      rewrite assoc_L -!union_difference_L //. set_solver. }
    do 2 iModIntro. iFrame "HE\N". iSplitL "Hw HEi"; first by iApply "Hw".
    iSplitL "Hi".
    { iExists i. auto. }
    iIntros "HP [Hw HE\N]".
    iDestruct (ownI_close with "[$Hw $Hi $HP $HD]") as "[$ HEi]".
    do 2 iModIntro. iSplitL; [|done].
    iCombine "HEi HEN\i HE\N" as "HEN".
    rewrite -?ownE_op; [|set_solver..].
    rewrite assoc_L -!union_difference_L //; set_solver.
  Qed.

  Lemma own_inv_to_inv M P: own_inv M P -∗ inv M P.
  Proof.
    iIntros "#I". rewrite inv_eq. iIntros (E H).
    iPoseProof (own_inv_acc with "I") as "H"; eauto.
  Qed.

  (** ** Public API of invariants *)
  Global Instance inv_contractive N : Contractive (inv N).
  Proof. rewrite inv_eq. solve_contractive. Qed.

  Global Instance inv_ne N : NonExpansive (inv N).
  Proof. apply contractive_ne, _. Qed.

  Global Instance inv_proper N : Proper (equiv ==> equiv) (inv N).
  Proof. apply ne_proper, _. Qed.

  Global Instance inv_persistent N P : Persistent (inv N P).
  Proof. rewrite inv_eq. apply _. Qed.

  Lemma inv_alter N P Q : inv N P -∗ ▷ □ (P -∗ Q ∗ (Q -∗ P)) -∗ inv N Q.
  Proof.
    rewrite inv_eq. iIntros "#HI #HPQ !>" (E H).
    iMod ("HI" $! E H) as "[HP Hclose]".
    iDestruct ("HPQ" with "HP") as "[$ HQP]".
    iIntros "!> HQ". iApply "Hclose". iApply "HQP". done.
  Qed.

  Lemma inv_iff N P Q : inv N P -∗ ▷ □ (P ↔ Q) -∗ inv N Q.
  Proof.
    iIntros "#HI #HPQ". iApply (inv_alter with "HI").
    iIntros "!> !> HP". iSplitL "HP".
    - by iApply "HPQ".
    - iIntros "HQ". by iApply "HPQ".
  Qed.

  Lemma inv_alloc N E P : ▷ P ={E}=∗ inv N P.
  Proof.
    iIntros "HP". iApply own_inv_to_inv.
    iApply (own_inv_alloc N E with "HP").
  Qed.

  Lemma inv_alloc_open N E P :
    ↑N ⊆ E → ⊢ |={E, E∖↑N}=> inv N P ∗ (▷P ={E∖↑N, E}=∗ True).
  Proof.
    iIntros (?). iMod own_inv_alloc_open as "[HI $]"; first done.
    iApply own_inv_to_inv. done.
  Qed.

  Lemma inv_acc E N P :
    ↑N ⊆ E → inv N P ={E,E∖↑N}=∗ ▷ P ∗ (▷ P ={E∖↑N,E}=∗ True).
  Proof.
    rewrite inv_eq /inv_def; iIntros (?) "#HI". by iApply "HI".
  Qed.

  Lemma inv_combine N1 N2 N P Q :
    N1 ## N2 →
    ↑N1 ∪ ↑N2 ⊆@{coPset} ↑N →
    inv N1 P -∗ inv N2 Q -∗ inv N (P ∗ Q).
  Proof.
    rewrite inv_eq. iIntros (??) "#HinvP #HinvQ !>"; iIntros (E ?).
    iMod ("HinvP" with "[%]") as "[$ HcloseP]"; first set_solver.
    iMod ("HinvQ" with "[%]") as "[$ HcloseQ]"; first set_solver.
    iMod (fupd_intro_mask' _ (E ∖ ↑N)) as "Hclose"; first set_solver.
    iIntros "!> [HP HQ]".
    iMod "Hclose" as %_. iMod ("HcloseQ" with "HQ") as %_. by iApply "HcloseP".
  Qed.

  Lemma inv_combine_dup_l N P Q :
    □ (P -∗ P ∗ P) -∗
    inv N P -∗ inv N Q -∗ inv N (P ∗ Q).
  Proof.
    rewrite inv_eq. iIntros "#HPdup #HinvP #HinvQ !>" (E ?).
    iMod ("HinvP" with "[//]") as "[HP HcloseP]".
    iDestruct ("HPdup" with "HP") as "[$ HP]".
    iMod ("HcloseP" with "HP") as %_.
    iMod ("HinvQ" with "[//]") as "[$ HcloseQ]".
    iIntros "!> [HP HQ]". by iApply "HcloseQ".
  Qed.

  (** ** Proof mode integration *)
  Global Instance into_inv_inv N P : IntoInv (inv N P) N := {}.

  Global Instance into_acc_inv N P E:
    IntoAcc (X := unit) (inv N P)
            (↑N ⊆ E) True (fupd E (E ∖ ↑N)) (fupd (E ∖ ↑N) E)
            (λ _ : (), (▷ P)%I) (λ _ : (), (▷ P)%I) (λ _ : (), None).
  Proof.
    rewrite inv_eq /IntoAcc /accessor bi.exist_unit.
    iIntros (?) "#Hinv _". iApply "Hinv"; done.
  Qed.

  (** ** Derived properties *)
  Lemma inv_acc_strong E N P :
    ↑N ⊆ E → inv N P ={E,E∖↑N}=∗ ▷ P ∗ ∀ E', ▷ P ={E',↑N ∪ E'}=∗ True.
  Proof.
    iIntros (?) "Hinv".
    iPoseProof (inv_acc (↑ N) N with "Hinv") as "H"; first done.
    rewrite difference_diag_L.
    iPoseProof (fupd_mask_frame_r _ _ (E ∖ ↑ N) with "H") as "H"; first set_solver.
    rewrite left_id_L -union_difference_L //. iMod "H" as "[$ H]"; iModIntro.
    iIntros (E') "HP".
    iPoseProof (fupd_mask_frame_r _ _ E' with "(H HP)") as "H"; first set_solver.
    by rewrite left_id_L.
  Qed.

  Lemma inv_acc_timeless E N P `{!Timeless P} :
    ↑N ⊆ E → inv N P ={E,E∖↑N}=∗ P ∗ (P ={E∖↑N,E}=∗ True).
  Proof.
    iIntros (?) "Hinv". iMod (inv_acc with "Hinv") as "[>HP Hclose]"; auto.
    iIntros "!> {$HP} HP". iApply "Hclose"; auto.
  Qed.

  Lemma inv_split_l N P Q : inv N (P ∗ Q) -∗ inv N P.
  Proof.
    iIntros "#HI". iApply inv_alter; eauto.
    iIntros "!> !> [$ $] $".
  Qed.
  Lemma inv_split_r N P Q : inv N (P ∗ Q) -∗ inv N Q.
  Proof.
    rewrite (comm _ P Q). eapply inv_split_l.
  Qed.
  Lemma inv_split N P Q : inv N (P ∗ Q) -∗ inv N P ∗ inv N Q.
  Proof.
    iIntros "#H".
    iPoseProof (inv_split_l with "H") as "$".
    iPoseProof (inv_split_r with "H") as "$".
  Qed.

End inv.


(* Celsius project *)
(* Clément Blaudeau - Lamp@EPFL & Inria 2020-2022 *)
(* ------------------------------------------------------------------------ *)
(* This file defines and proves the soundess of the type system. *)

From Celsius Require Export LocalReasoning Eval.
Implicit Type (ρ: Env).

(* ------------------------------------------------------------------------ *)
Local Hint Constructors evalP expr_typing expr_list_typing: typ.

(* We assume the class table is well typed : *)

Parameter typable_classes : T_Classes.

(* ------------------------------------------------------------------------ *)
(** ** Weakening *)

Lemma S_Typs_weakening:
  forall Γ Γ',
    S_Typs Γ' Γ ->
    forall x T__x, typeLookup Γ x = Some T__x -> exists T__x', typeLookup Γ' x = Some T__x' /\ T__x' <: T__x.
Proof with (meta; eauto with typ).
  intros. gen x T__x. unfold S_Typs in *.
  induction H; steps.
  - destruct x; steps.
  - destruct x0; steps...
Qed.
Global Hint Resolve S_Typs_weakening: typ.

(* Our typing enjoys a weakening lemma *)
Theorem weakening: forall Γ Γ' U e T,
    S_Typs Γ' Γ ->
    ((Γ, U) ⊢ e : T) ->
    ((Γ', U) ⊢ e : T).
Proof with (meta; eauto using expr_typing with typ lia).
  intros.
  lets: S_Typs_weakening H. clear H. gen Γ'.
  induction H0 using typing_ind with
    (Pl := fun Γ0 T0 el Ul _ =>
             forall Γ',
               (forall x T__x, typeLookup Γ0 x = Some T__x -> exists T__x', typeLookup Γ' x = Some T__x' /\ T__x' <: T__x) ->
               ((Γ0, T0) ⊩ el : Ul) ->
               ((Γ', T0) ⊩ el : Ul));
    intros ...
  eapply H1 in H__lkp as [T__x' [ ]]...
Qed.

(* ------------------------------------------------------------------------ *)
(** ** Soundness statements *)

Definition expr_soundness n e ρ σ ψ r Γ Σ U T :=
    ((Γ, U) ⊢ e : T) ->
    Σ ⊨ ρ : Γ ->
    Σ ⊨ σ ->
    (Σ ⊨ ψ : U) ->
    wf σ ->
    (codom ρ ∪ {ψ} ⪽ σ) ->
    ⟦e⟧(σ, ρ, ψ, n) = r ->
    r <> Timeout ->
    exists Σ' v σ',
      r = Success v σ' /\
        Σ ≼ Σ' /\ Σ ≪ Σ' /\ Σ ▷ Σ' /\ (Σ' ⊨ σ') /\ wf σ' /\
        Σ' ⊨ v : T.

Definition expr_list_soundness n el ρ σ ψ r Γ Σ U Tl :=
    ((Γ, U) ⊩ el : Tl) ->
    Σ ⊨ ρ : Γ ->
    Σ ⊨ σ ->
    (Σ ⊨ ψ : U) ->
    wf σ ->
    (codom ρ ∪ {ψ} ⪽ σ) ->
    ⟦_ el _⟧(σ, ρ, ψ, n) = r ->
    r <> Timeout_l ->
    exists Σ' vl σ',
      r = Success_l vl σ' /\
        Σ ≼ Σ' /\ Σ ≪ Σ' /\ Σ ▷ Σ' /\ (Σ' ⊨ σ') /\ wf σ' /\
        Σ' ⊨ vl : Tl.

Definition init_soundness n C ψ i i' ρ σ Γ Σ r :=
  forall Args Flds Mtds,
    Σ ⊨ ρ : Γ ->
    Σ ⊨ σ ->

    wf σ ->
    (codom ρ ∪ {ψ} ⪽ σ) ->

    ct C = class Args Flds Mtds ->
    getType Σ ψ = Some (C, cool i') ->
    S_Typs Γ Args ->
    i' >= i ->

    init C ψ i ρ σ n = r ->
    r <> Timeout_i ->

    exists Σ' σ',
      r = Success_i σ' /\
        Σ ≼ Σ' /\ Σ ≪ Σ' /\ ([ψ↦(C,cool (dom Flds))]Σ ▷ Σ') /\ (Σ' ⊨ σ') /\ wf σ'.

(* We then prove several cases as lemmas *)

(* ------------------------------------------------------------------------ *)
(** ** Soundness of field access *)

Lemma soundness_fld:
  forall n,
    (forall e ρ σ ψ r Γ Σ U T,
        expr_soundness n e ρ σ ψ r Γ Σ U T) /\
    (forall el ρ σ ψ r Γ Σ U Tl,
      expr_list_soundness n el ρ σ ψ r Γ Σ U Tl) /\
    (forall C I n1 n2 ρ σ Γ Σ r,
        init_soundness n C I n1 n2 ρ σ Γ Σ r) ->
    (forall e f ρ σ ψ r Γ Σ U T,
        expr_soundness (S n) (e_fld e f) ρ σ ψ r Γ Σ U T).
Proof with (meta; meta_clean; eauto 2 with typ;
            try match goal with
                | |- ?Σ ⊨ ?l : ?T => try solve [eapply vt_sub; eauto with typ]
                end) using.
  intros n [IH__expr [IH__list IH__init]];
    unfold expr_soundness, expr_list_soundness, init_soundness; intros.
  simpl in *...

  (* Induction on the typing judgment *)
  eapply t_fld_inv in H as
      (D & μ__e & μ__f & HT__e & H__fieldType & H__mode) ...
  destruct (ct D) as [Args Flds Mtds] eqn:H__ct.

  (* Destruct evaluation of e *)
  destruct_eval H__eval v' σ';
    lets (Σ0 & v0 & σ0 & H__r & H__mn0 & H__stk0 & H__aty0 & H__st0 & H__wf0 & H__v0) :
    IH__expr HT__e H0 H1 H3 H__eval; try inverts H__r; try congruence ...
  eapply eval_implies_evalP_expr in H__eval.
  lets (?C & ?ω & ?μ & H__obj & ? & H__ot): (proj2 H__st0) v0 ...
  rewrite H__obj in H5 |- *.

  (* Case analysis *)
  destruct H__mode as [ ? | [Ω [? [? ?]]]]; subst...
  + (* hot *)
    inverts H__ot...
    lets (v1 & ?D & ?μ & ? & ? & ?): H13 f... rewrite_any.
    exists Σ0, v1, σ0; splits ...
  + (* cool Ω *)
    inversion H12; subst;
      inverts H__ot.
    * (* cool Ω *)
      lets (v1 & ?D & ?μ & ? & ? & ?): H17 f...
      exists Σ0, v1, σ0; splits ... steps.
    * (* hot *)
      lets (v1 & ?D & ?μ & ? & ? & ?): H16 f... rewrite_any.
      exists Σ0, v1, σ0; splits ...
    * (* warm *)
      lets (v1 & ?D & ?μ & ? & ? & ?): H16 f... rewrite_any.
      exists Σ0, v1, σ0; splits ...
    * (* cool Ω1 + Ω2 *)
      lets (v1 & ?D & ?μ & ? & ? & ?): H18 f...
      exists Σ0, v1, σ0; splits ... steps.
Qed.

(* ------------------------------------------------------------------------ *)
(** ** Soundness of method call *)

Lemma soundness_mtd:
  forall n,
    (forall e ρ σ ψ r Γ Σ U T,
        expr_soundness n e ρ σ ψ r Γ Σ U T) /\
      (forall el ρ σ ψ r Γ Σ U Tl,
          expr_list_soundness n el ρ σ ψ r Γ Σ U Tl) /\
      (forall C I n1 n2 ρ σ Γ Σ r,
          init_soundness n C I n1 n2 ρ σ Γ Σ r) ->
    (forall e m args ρ σ ψ r Γ Σ U T,
        expr_soundness (S n) (e_mtd e m args) ρ σ ψ r Γ Σ U T).
Proof with (meta; meta_clean; eauto 2 with typ;
            try match goal with
                | |- ?Σ ⊨ ?l : ?T => try solve [eapply vt_sub; eauto 4 with typ]
                end) using.
  intros n [IH__expr [IH__list IH__init]];
    unfold expr_soundness, expr_list_soundness, init_soundness; intros.
  simpl in *...

  (* Induction on the typing judgment *)
  eapply t_mtd_inv in H as
      (?C & ?C & ?e__m & ?Args & ?Flds & ?μ__m & ?μ' & ?μ__r &
         HT__e0 & H__mtdinfo & ? & HT__args & HS__args & H__sub & H__hots) ...

  (* Destruct evaluation of e0 *)
  destruct_eval H__eval0 v σ';
    lets (Σ0 & v0 & σ0 & H__r & H__mn0 & H__stk0 & H__aty0 & H__st0 & H__wf0 & H__v0) :
    IH__expr HT__e0 H0 H1 H3 H__eval0; try inverts H__r; try congruence ...
  eapply eval_implies_evalP_expr in H__eval0.
  lets H__pM0: pM_theorem_expr H__eval0.
  lets (?C & ?ω & ?μ & H__obj & ? & ?): (proj2 H__st0) v0 ...
  rewrite H__obj in H5 |- *.

  (* Destruct method fetch*)
  unfold methodInfo in H__mtdinfo.
  destruct (ct C) as [Args1 Flds1 Mtds1] eqn:H__ct1.
  destruct (Mtds1 m) as [[?μ__r Ts retT ?] |] eqn:H__Mtds1; [| steps] . inverts H__mtdinfo...
  eval_dom.

  (* Destruct evaluation of arguments *)
  lets H__env0: env_typing_monotonicity H__mn0 H0.
  eval_dom. eval_wf...
  lets (?T & ?T & ? & ? & ?): H__mn0 ψ ...
  destruct_eval H__eval1 vl σ';
    lets (Σ1 & args_val & σ1 & H__r & H__mn1 & H__stk1 & H__aty1 & H__st1 & H__wf1 & H__v1) :
    IH__list HT__args H__env0 H__st0 H__wf0 H__eval1; try inverts H__r; try congruence ...
  eapply eval_implies_evalP_list in H__eval1. eval_dom; eval_wf.

  (* Extract typing for method body from Ξ (well-typed) *)
  pose proof (typable_classes C) as HT__em.
  rewrite H__ct1 in HT__em.
  destruct HT__em as [_ HT__em].
  specialize (HT__em m _ _ _ _ H__Mtds1).

  (* Destruct evaluation of method body *)
  lets (?T & ?T & ? & ? & ?): H__mn1 ψ...
  lets (?T & ?T & ? & ? & ?): H__mn1 v0...
  assert (HT__em': (Args, (C, μ__m)) ⊢ e__m : (C0, μ__r)) by (eapply weakening with (Γ := Flds); eauto with typ).
  assert (codom args_val ∪ {v0} ⪽ σ1). { ss... eapply wf_theorem_list... }
  destruct (⟦ e__m ⟧ (σ1, args_val, v0 ,  n)) as [ | | σ' v' ] eqn:H__eval2; try congruence;
    lets (Σ2 & v2 & σ2 & H__r & H__mn2 & H__stk2 & H__aty2 & H__st2 & H__wf2 & H__v2) :
    IH__expr HT__em' H__v1 H__st1 H__wf1 H__eval2; try inverts H__r; try congruence ...
  eapply eval_implies_evalP in H__eval2. subst.

  (* Result *)
  eval_dom; eval_wf.
  destruct H__hots as [? | [ H__hots ?] ]...

  - exists Σ2, v2, σ2; splits...
    all: eauto with typ.

  - (* Local reasoning *)
    subst; meta.
    destruct (Local_reasoning_for_typing Σ1 Σ2 σ1 σ2 (codom args_val ∪ { v0 }) {v2} ) as
      (Σ3 & ? & ? & ? & ? & H__v2); ss => //.
    + apply scp_theorem_expr with (e:=e__m); eauto with wf lia.
    + intros l' [l H__l | l H__l]; rch_set; [| exists C]...
    + lets: H__v2 v2 In_singleton. clear H__v2...
      lets (?T & ?T & ? &?&?): H13 v2...
      exists Σ3, v2, σ2; splits ; auto; [ | | | eexists ]; eauto with typ.
Qed.

(* ------------------------------------------------------------------------ *)
(** ** Soundness of instance creation *)

Lemma soundness_new:
  forall n,
    (forall e ρ σ ψ r Γ Σ U T,
        expr_soundness n e ρ σ ψ r Γ Σ U T) /\
      (forall el ρ σ ψ r Γ Σ U Tl,
          expr_list_soundness n el ρ σ ψ r Γ Σ U Tl) /\
      (forall C I n1 n2  ρ σ Γ Σ r,
          init_soundness n C I n1 n2 ρ σ Γ Σ r) ->
    (forall C args ρ σ ψ r Γ Σ U T,
        expr_soundness (S n) (e_new C args) ρ σ ψ r Γ Σ U T).
Proof with (meta; meta_clean; eauto 2 with typ;
            try match goal with
                | |- ?Σ ⊨ ?l : ?T => try solve [eapply vt_sub; eauto with typ]
                end) using.
  intros n [IH__expr [IH__list IH__init]];
    unfold expr_soundness, expr_list_soundness, init_soundness; intros.
  simpl in *...

  (* Induction on the typing judgment *)
  eapply t_new_inv in H as
      (Args & Flds & Mtds & argsTs & ?μ & ? & H__ct & HT__args & HS__args & H__mode) ...

  (* Destruct evaluation of arguments *)
  destruct_eval H__eval1 vl σ';
    lets (Σ1 & args_val & σ1 & H__r & H__mn1 & H__stk1 & H__aty1 & H__st1 & H__wf1 & H__argsval) :
    IH__list HT__args H0 H1 H3 H__eval1; try inverts H__r; try congruence ...
  inverts H...
  eapply eval_implies_evalP_list in H__eval1...

  (* Destruct result of initialization *)
  remember (Σ1 ++ [(C, cool 0)]) as Σ2.
  remember (σ1 ++ [(C, [])]) as σ2...
  assert ((codom args_val ∪ {dom σ1}) ⪽ σ2). {
    subst; ss; updates... apply ss_trans with σ1; updates...
    eapply wf_theorem_list... }
  assert (H__mn2:  Σ1 ≼ Σ2). {
    subst. intros l0 H__l0.
    lets [T ?]: getType_Some H__l0. exists T, T; splits...
    rewrite getType_last2... }
  lets H__env2: env_typing_monotonicity H__mn2 H__argsval.
  assert (H__st2: Σ2 ⊨ σ2). { (* could be a lemma *)
    subst. split; updates...
    intros l H__l.
    destruct_eq (l = dom σ1); subst; updates.
    - rewrite (proj1 H__st1) getType_last.
      exists C ([]:Env) (cool 0); splits...
      eapply ot_cool ...
    - rewrite getObj_last2...
      rewrite getType_last2...
      lets (?C & ?ω & ?μ & ? & ? & ?): (proj2 H__st1) l...
      repeat eexists... }
  lets H__wf2: wf_add_empty C H__wf1. rewrite -Heqσ2 in H__wf2.
  lets: getObj_last σ1 C ([]: Env).
  destruct (init C dom σ1 0 args_val σ2 n) as [ | | σ3] eqn:Heq;
    try rewrite Heq in H5 |- *; try congruence;
    specialize (IH__init C (dom σ1) 0 0 args_val σ2 argsTs Σ2);
  lets (Σ4 & σ4 & H__r & H__mn4 & H__stk4 & H__aty4 & H__st4 & H__wf4):
     IH__init H__st2 H__wf2 H__ct ; subst; simpl in *...
  all: try solve [intros; discriminate].
  all: try solve [rewrite (proj1 H__st1) getType_last; simpl; reflexivity].
  inverts H__r.
  eapply init_implies_initP in Heq...

  (* Promotion *)
  remember ([dom σ1 ↦ (C, warm)] (Σ4)) as Σ5.
  assert (H__aty4': Σ1 ▷ Σ4). {
    intros l ? ? H__getType.
    lets: getType_dom H__getType.
    assert (l <> dom Σ1) by lia.
    apply H__aty4...
    rewrite getType_update_diff...
    rewrite getType_last2... }
  assert (H__stk5: Σ1 ≪ [dom σ1 ↦ (C, warm)] (Σ4)). {
    intros l H__l. updates...
    assert (l < dom σ1 \/ l = dom σ1 \/ dom σ1 <> l) as [ |[|] ] by lia; subst...
    + left. exists C, (C, warm); updates...
    + destruct (H__stk4 l); updates...
      left; exists C0, (C0, μ0); updates...
  }
  lets: H__aty4 (dom σ1) C (dom Flds). rewrite getType_update_same in H5...
  specialize (H5 eq_refl).
  lets (H__aty5 & H__mn5' & H__stk5' & H__st5) : promotion Σ1 Σ4 (dom σ1) σ4 HeqΣ5...

  (* Case analysis : warm or hot *)
  destruct H__mode as [H__warm | H__hots].
  + (* warm *)
    exists Σ5, (dom σ1), σ4; splits...
    exists (C, warm); subst; updates...

  + (* hot *)
    eval_dom. updates...
    destruct (Local_reasoning_for_typing Σ1 Σ5 σ1 σ4 (codom args_val) {dom σ1} ) as
      (Σ6 & ? & ? & ? & ? & H__vnew)...
    * eapply wf_theorem_list...
    * lets: scp_theorem_init Heq; eauto with scp...
      apply scp_trans with σ4 (codom args_val ∪ {dom σ1}); ss... {
        eapply ss_trans with (σ1++[(C,[])]); updates...
      }
      ++ apply scp_trans with (σ1 ++ [(C, [])]) (codom args_val ∪ {dom σ1}); updates...
         intros ? ? l ? H__rch.
         apply rch_add_empty_set in H__rch as [ [x [ [ ] H__rch]] |]; rch_set...
         eexists...
         apply rch_dom2 in H__rch...
      ++ apply scp_refl2; intros ? [ ]. apply Union_intror, In_singleton.
    * intros l H__l.
      eapply P_Hots_env...
    * exists Σ6, (dom σ1), σ4; splits;
        eauto 3 with typ.
      exists (C, hot)...
      lets (? & ? & ? & ? & ?): H14 (dom σ1); subst...
      rewrite getType_update_same in H17... inverts H17...
      lets: H__vnew (dom σ1) In_singleton... inverts H17... inverts H19...
Qed.

(* ------------------------------------------------------------------------ *)
(** ** Soundness of assignment *)

Lemma soundness_asgn:
  forall n,
    (forall e ρ σ ψ r Γ Σ U T,
        expr_soundness n e ρ σ ψ r Γ Σ U T) /\
      (forall el ρ σ ψ r Γ Σ U Tl,
          expr_list_soundness n el ρ σ ψ r Γ Σ U Tl) /\
      (forall C I n1 n2 ρ σ Γ Σ r,
          init_soundness n C I n1 n2 ρ σ Γ Σ r) ->
    (forall e1 f e2 e' ρ σ ψ r Γ Σ U T,
        expr_soundness (S n) (e_asgn e1 f e2 e') ρ σ ψ r Γ Σ U T).
Proof with (meta; meta_clean; eauto 2 with typ;
            try match goal with
                | |- ?Σ ⊨ ?l : ?T => try solve [eapply vt_sub; eauto with typ]
                end) using.
  intros n [IH__expr [IH__list IH__init]];
    unfold expr_soundness, expr_list_soundness, init_soundness; intros.
  simpl in *...
  (* Induction on typing derivation *)
  eapply t_asgn_inv in H as
      (D & ? & ? & HT__e1 & HT__e2 & ? & HT__e3) ...
  eapply t_fld_inv in HT__e1 as
      (?D & μ__e & μ__f & HT__e1 & H__fieldType & H__mode) ...

  (* Destruct evaluation of e1 *)
  destruct_eval H__eval1 v' σ';
    lets (Σ1 & v1 & σ1 & H__r & H__mn1 & H__stk1 & H__aty1 & H__st1 & H__wf1 & H__v1) :
    IH__expr HT__e1 H0 H1 H3 H__eval1; try inverts H__r; try congruence ...
  eapply eval_implies_evalP_expr in H__eval1.
  lets (?C & ?ω & ?μ & H__obj & ? & H__ot): (proj2 H__st1) v1 ...

  (* Destruct evaluation of e2 *)
  lets (?T & ?T & ? & ? & ?): H__mn1 ψ ...
  lets H__env1: env_typing_monotonicity H__mn1 H0.
  eval_dom. eval_wf...
  destruct_eval H__eval2 v' σ';
    lets (Σ2 & v2 & σ2 & H__r & H__mn2 & H__stk2 & H__aty2 & H__st2 & H__wf2 & H__v2) :
    IH__expr HT__e2 H__env1 H__st1 H__wf1 H__eval2; try inverts H__r; try congruence ...
  eapply eval_implies_evalP_expr in H__eval2. eval_dom; eval_wf.
  lets (?T & ?T & ? & ? & ?): H__mn2 ψ ...

  (* Destruct assignment *)
  unfold assign in *.
  destruct (getObj σ2 v1) as [[?C ?ω] |] eqn:H__getObj.

  + (* Useful assignment *)
    remember ([v1 ↦ (C, [f ↦ v2] (ω0))] (σ2)) as σ2'. rewrite Heqσ2' in H6.
    assert (H__st2': Σ2 ⊨ σ2'). {
      subst. rename v1 into l, v2 into v.
      lets [?ω [H__obj2 _]]: pM_theorem_expr H__eval2 H__obj.
      lets (?T & ?T & ? & ? & ?): H__mn2 l...
      lets [v0 [H__v0 ?]]: cool_selection  l H__st2 H__obj2... {
        exists (C, μ5)... apply s_typ_mode.
        destruct H__mode as [|]; flatten; subst...
        eapply s_mode_trans with (cool Ω)...
      }
      eapply storeTyping_assgn...
    }
    assert (H__wf2': wf σ2') by (subst; eapply wf_assign; eauto).
    assert (H__codom' : (codom ρ ∪ {ψ}) ⪽ σ2'). by (subst; ss).
    destruct (⟦ e' ⟧ (σ2', ρ, ψ ,  n)) as [ | | σ' v' ] eqn:H__eval3; try congruence;
      lets (Σ3 & v3 & σ3 & H__r & H__mn3 & H__stk3 & H__aty3 & H__st3 & H__wf3 & H__v3) :
      IH__expr HT__e3 H__st2' H__eval3; try inverts H__r; try congruence ...
    (* eapply eval_implies_evalp in H__eval3. eval_dom; eval_wf.*)
    subst.
    exists Σ3, v3, σ3; subst; splits...
    all: eauto with typ.

  + (* Useless assignment *)
    destruct (⟦ e' ⟧ (σ2, ρ, ψ ,  n)) as [ | | σ' v' ] eqn:H__eval3; try congruence;
      lets (Σ3 & v3 & σ3 & H__r & H__mn3 & H__stk3 & H__aty3 & H__st3 & H__wf3 & H__v3) :
      IH__expr HT__e3 H__st2 H__wf2 H__eval3; try inverts H__r; try congruence ...
    eapply eval_implies_evalP_expr in H__eval3. eval_dom; eval_wf.
    exists Σ3, v3, σ3; splits...
    all: eauto with typ.
Qed.

(* ------------------------------------------------------------------------ *)
(** ** Soundness of initialization of a field *)

Lemma soundness_init_cons:
  forall n,
    (forall e ρ σ ψ r Γ Σ U T,
        expr_soundness n e ρ σ ψ r Γ Σ U T) /\
      (forall el ρ σ ψ r Γ Σ U Tl,
          expr_list_soundness n el ρ σ ψ r Γ Σ U Tl) /\
      (forall C I n1 n2 ρ σ Γ Σ r,
          init_soundness n C I n1 n2 ρ σ Γ Σ r) ->
    (forall C I n1 n2 ρ σ Γ Σ r,
        init_soundness (S n) C I n1 n2 ρ σ Γ Σ r).
Proof with (meta; meta_clean; eauto 2 with typ;
            try match goal with
                | |- ?Σ ⊨ ?l : ?T => try solve [eapply vt_sub; eauto with typ]
                end) using.
  intros n [IH__expr [IH__list IH__init]];
    unfold expr_soundness, expr_list_soundness, init_soundness; intros.
  simpl in *...
  rewrite H3 in H7.

  (* Retrieve current field *)
  assert (n2 <= dom Flds). {
    lets (?C&?ω&?&?&?&?): (proj2 H0) I...
    lets [? _]: H1 H10.
    lets: ot_cool_dom H12...
    lets: H4 H3...
  }
  destruct (nth_error Flds n1) as [[T e]|] eqn:?.
  2:{ (* no fields left*)
    apply nth_error_None in Heqo.
    assert (n1 = dom Flds) by lia; subst.
    assert (n2 = dom Flds) by lia; subst.
    rewrite Nat.eqb_refl in H8 |- *.
    exists Σ σ; splits...
    intros l D Ω ?. destruct_eq (I = l); subst; updates...
    rewrite getType_update_same in H7... inverts H7...
  }
  lets (DoneFlds&LeftFlds&?&?): nth_error_split Heqo; subst.

  (* Extract typing info from the well-typed classes *)
  pose proof (typable_classes C) as HT__C. rewrite H3 in HT__C.
  destruct HT__C as [HT__Field _].
  eapply T_Fields_In in HT__Field. simpl in HT__Field.
  eapply weakening with (Γ' := Γ) in HT__Field...
  rename HT__Field into HT__e.

  (* Destruct evaluation of e *)
  destruct_eval H__eval v' σ';
    lets (Σ0 & v0 & σ0 & H__r & H__mn0 & H__stk0 & H__aty0 & H__st0 & H__wf0 & H__v0) :
    IH__expr HT__e H0 H1 H2 H__eval; try inverts H__r; try congruence ...
  eapply eval_implies_evalP_expr in H__eval.
  lets: monotonicity_dom H__mn0.
  lets (? & ? & ? & ? & ?): H__mn0 I...
  lets (?C & ?ω & ?μ & ? & ? & ?): (proj2 H__st0) I...
  eval_dom; eval_wf.

  destruct (assign_new I dom DoneFlds v0 σ0) as [σ1 |] eqn:H__assign;
    [| unfold assign_new in H__assign; steps].
  lets: wf_assign_new H__assign... {updates... }
  lets: assign_new_dom H__assign.

  (* Use field initialization lemma *)
  lets H__env0: env_typing_monotonicity H__mn0 H.
  clear IH__expr IH__list.
  lets: H__aty0 I H13.
  assert (H__field: fieldType C (dom DoneFlds) = Some (C0, μ)). {
    unfold fieldType. rewrite H3.
    rewrite nth_error_app2... subst.
    rewrite -minus_diag_reverse...
  }
  cross_rewrites.

  (* Case analysis : is it the updating point ? *)
  destruct_eq (n2 = dom DoneFlds); subst.
  - (* Updating point, using the field initialization lemma *)
    remember ([I ↦ (C, cool (S (dom DoneFlds)))] (Σ0)) as Σ1.
    lets (H__st1 & H__mn1 & H__stk1): field_initialization I σ0 H__st0 H__field Σ1 ...
    { lets: ot_cool_dom σ0 H18... }

    (* Use induction hypothesis *)
    lets: env_typing_monotonicity H__mn1 H__env0.
    specialize (IH__init
                  C I (S dom DoneFlds) (S dom DoneFlds) ρ
                  σ1 Γ Σ1
                  (init C I (S dom DoneFlds) ρ σ1 n)
                  Args (DoneFlds++(field (C0,μ) e)::LeftFlds) Mtds).
    subst; modus.
    destruct IH__init
      as (Σ2 & σ2 & H__r & H__mn2 & H__stk2 & H__aty2 & H__st2 & H__wf2)...
    + apply ss_trans with σ0...
    + updates...
    + (* Result *)
      updates.
      lets H__initP: H__r.
      eapply init_implies_initP in H__initP;
        updates; try rewrite app_assoc_reverse...
      lets H__scpInit: scp_theorem_init H__initP.
      lets: scp_theorem_expr H__eval H1...
      exists Σ2, σ2; splits...
      * eauto with typ.
      * eauto with typ.
      * intros l ?C Ω H__getType.
        destruct_eq (I = l); subst;
           eapply H__aty2; updates...
        rewrite getType_update_same in H__getType...

  - (* Not an updating point, we keep Σ *)
    lets H__mn1: mn_refl Σ0.
    lets H__stk1: stk_st_refl Σ0.

    specialize (IH__init C I (S dom DoneFlds) n2 ρ σ1 Γ Σ0
                  (init C I (S dom DoneFlds) ρ σ1 n)
                  Args (DoneFlds++(field (C0,μ) e)::LeftFlds) Mtds).
    destruct IH__init
      as (Σ2 & σ2 & H__r & H__mn2 & H__stk2 & H__aty2 & H__st2 & H__wf2 )...
    + (* assign_new *)
      rewrite /assign_new H4 in H__assign.
      destruct_if_eqb; inverts H__assign.
      * lets (?&?&?&?&?&?): (proj2 H__st0) I...
        inverts H22. lets (?v&?C&?μ&?&?&?): H26 (dom ω)...
        lets: getVal_dom H16...
      * remember (dom DoneFlds) as x.
        assert (x < dom ω). { lets: ot_cool_dom Σ0 σ0 H18... }
        lets (v__old&?): getVal_Some ω x; auto.
        lets (?&?&?&?&?&?): (proj2 H__st0) I...
        inverts H24. lets (?v&?C&?μ&?&?&?): H28 x...
        split...
        intros.
        destruct_eq (l = I); [inverts Heq1|] ...
        -- rewrite getObj_update_same... repeat eexists...
           eapply ot_cool... intros.
           destruct_eq (f = x).
           ++ inverts Heq1; rewrite getVal_update_same...
              repeat eexists...
           ++ rewrite getVal_update_diff...
        -- rewrite getObj_update_diff...
           lets (?C&?ω&?): getObj_Some l...
           lets (?&?&?&?&?&?): (proj2 H__st0) l...
           repeat eexists...
    + apply ss_trans with σ0...
    + (* Result *)
      updates.
      lets H__initP: H__r.
      eapply init_implies_initP in H__initP;
        updates; try rewrite app_assoc_reverse...
      lets H__scpInit: scp_theorem_init H__initP.
      lets: scp_theorem_expr H__eval H1...
      exists Σ2, σ2; splits...
      intros l ?C Ω H__getType.
      destruct_eq (I = l); subst;
        eapply H__aty2; updates...
      rewrite getType_update_same in H__getType...
Qed.

(* ------------------------------------------------------------------------ *)
(** ** Final soundness theorem *)

Theorem soundness:
  forall n,
    (forall e ρ σ ψ r Γ Σ U T,
        expr_soundness n e ρ σ ψ r Γ Σ U T) /\
    (forall el ρ σ ψ r Γ Σ U Tl,
      expr_list_soundness n el ρ σ ψ r Γ Σ U Tl) /\
    (forall C I n1 n2 ρ σ Γ Σ r,
       init_soundness n C I n1 n2 ρ σ Γ Σ r).
Proof with (
    meta;
    meta_clean;
    eauto 4 with typ wf lia;
    try match goal with
        | |- ?Σ ⊨ ?l : ?T => try solve [eapply vt_sub; eauto with typ]
        end
  ).
  induction n as [n IHn] using lt_wf_ind. destruct n;
    intros; unfold expr_soundness, expr_list_soundness, init_soundness; splits; intros;
    [steps | steps | steps | destruct e | destruct el | ]; subst;
    simpl in *;
    try specialize (IHn n ltac:(lia)) as [IH__expr [IH__list IH__init]]...

  - (* e = var x *)
    eapply env_regularity in H as (?l & ?H__get & ?)...
    rewrite H__get in H6 |- * ...
    exists Σ, l, σ; steps...

  - (* e = this *)
    eapply t_this_inv in H.
    exists Σ, ψ, σ; steps...

  - eapply soundness_fld...

  - eapply soundness_mtd...

  - eapply soundness_new...

  - eapply soundness_asgn...

  - (* el = nil *)
    inverts H.
    exists Σ, ([]: list Loc), σ; splits...
    apply et_nil.

  - (* el = e::el *)
    inverts H ...

    (* Destruct evaluation of head *)
    destruct_eval H__eval v' σ';
      lets (Σ0 & v & σ0 & H__r & H__mn0 & H__stk0 & H__aty0 & H__st0 & H__wf0 & H__v0) :
      IH__expr H14 H0 H1 H3 H__eval; try inverts H__r; try congruence ...
    eapply eval_implies_evalP_expr in H__eval. eval_dom.

    (* Destruct evaluation of tail *)
    lets (?T & ?T & ? & ? & ?): H__mn0 ψ...
    lets H__env0: env_typing_monotonicity H__mn0 H0.
    destruct (⟦_ el _⟧ (σ0, ρ, ψ, n)) as [ | | σ' vl' ] eqn:H__eval1; try congruence;
    lets (Σ1 & vl & σ1 & H__r & H__mn1 & H__stk1 & H__aty1 & H__st1 & H__wf1 & H__v1):
      IH__list H12 H__env0 H__st0 H__wf0 H__eval1; try inverts H__r; try congruence ...

    (* Result *)
    exists Σ1, (v::vl), σ1; splits...
    lets (?T & ?T & ? & ? & ?): H__mn1 v ...
    apply et_cons...

  - (* init_cons *)
    eapply soundness_init_cons...
Qed.

(* ------------------------------------------------------------------------ *)
(** ** Soundness corollaries *)

Theorem Soundness :
  forall n e ρ σ ψ r Γ Σ Tthis T,
    ⟦e⟧(σ, ρ, ψ, n) = r ->
    r <> Timeout ->
    Σ ⊨ σ ->
    (Σ ⊨ ρ : Γ) ->
    (Σ ⊨ ψ : Tthis) ->
    ((Γ, Tthis) ⊢ e : T) ->
    wf σ ->
    (codom ρ ∪ {ψ} ⪽ σ) ->
    exists Σ' v σ',
      r = Success v σ' /\
        (Σ' ⊨ σ') /\
        (Σ' ⊨ v : T) /\
        Σ ≼ Σ' /\
        Σ ▷ Σ' /\
        Σ ≪ Σ'.
Proof with (eauto with typ).
  intros.
  lets [(Σ'& v& σ'& ?) _]: soundness n... steps.
  exists Σ', v, σ'; splits...
Qed.

Corollary Program_soundness :
  T_Prog ->
  forall n, eval_prog n <> Error.
Proof with (meta; eauto 2 with typ).
  unfold eval_prog, T_Prog.
  lets H__ct: EntryClass_ct. rewrite H__ct.
  destruct EntryClass.
  steps...
  specialize (H1 Entry). steps.
  specialize (H2 main hot [] (c,m) e matched).
  lets: Soundness [(Entry, hot)] H0 H2; eauto with typ; steps.
  + split; steps.
    ct_lookup Entry.
    assert (l = 0) by lia; steps.
    exists Entry, ([]: Env), hot; steps.
    eapply ot_hot...
    simpl; intros; lia.
  + eapply vt_sub; steps.
  + lets (? & ? & ?): H1; steps...
    intros l C ω ?H.
    lets: getObj_dom H3; simpl in *.
    assert (l=0) by lia; steps.
    lets: getVal_dom H6; simpl in *; try lia...
Qed.


Require Export low_mods.
Require Import Rep_Pred_FOv.

Lemma Pred_in_SO_rep_pred : forall (alpha cond : SecOrder) (x : FOvariable)
                              (P P2 : predicate),
  FO_frame_condition cond = true ->
    Pred_in_SO (replace_pred alpha P x cond) P2 ->
      Pred_in_SO alpha P2.
Proof.
  intros alpha cond x P P2 Hunary HPocc.
  unfold Pred_in_SO in *.
  induction alpha; try (    apply IHalpha; auto); try auto;
    try (    simpl in *; apply in_app_or in HPocc;
    apply in_or_app; firstorder).

  simpl in *. destruct (predicate_dec P p).
    subst. rewrite preds_in_rep_FOv in HPocc.
    rewrite FO_frame_condition_preds_in in HPocc.
    firstorder.  auto.
    simpl in *. auto.

    simpl in *. destruct (predicate_dec P p) as [H1 | H1].
    subst. right. firstorder.
    simpl in HPocc. destruct HPocc. auto.
    right. apply IHalpha. auto.

    simpl in *. destruct (predicate_dec P p) as [H1 | H1].
    subst. right. firstorder.
    simpl in HPocc. destruct HPocc. auto.
    right. apply IHalpha. auto.
Qed.

Lemma Pred_in_SO_rep_pred_f : forall (alpha cond : SecOrder) (x : FOvariable)
                                    (Q : predicate),
  FO_frame_condition cond = true ->
   ~ Pred_in_SO (replace_pred alpha Q x cond) Q.
Proof.
  intros alpha cond x Q Hcond.
  induction alpha; intros H; try contradiction.

  simpl in *. destruct (predicate_dec Q p) as [H1 | H1].
  subst. apply Pred_in_SO_FO_frame_condition in H. contradiction.
  apply rep_FOv_FO_frame_condition. auto.
  inversion H as [H2 | H2]; subst; contradiction.

  rewrite rep_pred_conjSO in H.
  apply Pred_in_SO_conjSO in H.
  destruct H; contradiction.

  rewrite rep_pred_disjSO in H.
  apply Pred_in_SO_conjSO in H.
  destruct H; contradiction.

  rewrite rep_pred_implSO in H.
  apply Pred_in_SO_conjSO in H.
  destruct H; contradiction.

  simpl in *. destruct (predicate_dec Q p) as [H1 | H1].
  subst. contradiction. inversion H as [H2 | H2].
  subst. contradiction.
  apply In_preds_in_rep_pred in H2.
  eapply Pred_in_SO_FO_frame_condition in H2. contradiction.
  auto.

  simpl in *. destruct (predicate_dec Q p) as [H1 | H1].
  subst. contradiction. inversion H as [H2 | H2].
  subst. contradiction.
  apply In_preds_in_rep_pred in H2.
  eapply Pred_in_SO_FO_frame_condition in H2. contradiction.
  auto.
Qed.


Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.
Require Import Coq.Strings.String.

(* Import functions from framework. *)
Require Import Hapsl.Ascii.Class.
Require Import Hapsl.Bool.Bool.
Require Import Hapsl.Checkers.Types.
Require Import Hapsl.Nat.Notations.
Require Import Hapsl.String.Distance.
Require Import Hapsl.String.Transform.
Require Import Hapsl.String.Palindrome.
Require Import Hapsl.String.Equality.
Require Import Hapsl.String.Search.
Require Import Hapsl.String.Sequence.

Local Open Scope string_scope.

(* Import required notations. *)
Import StringEqualityNotations.
Import NatNotations.

(* Utility function to deal with old passwords that might not exist. *)
Definition old_is_undefined (pt : PasswordTransition) : bool :=
  match pt with
  | PwdTransition old new =>
    match old with
    | None => true
    | Some str => false
    end
  end.

(* Extracts the new password from a password transition. *)
Definition new_pwd (pt : PasswordTransition) : Password :=
  match pt with
  | PwdTransition old new => new
  end.

(* Notations for checkers. *)
Module CheckerNotations.

  (* A check being disabled is the same as no error message. *)
  Notation DISABLE_CHECK := None.

  (* A 'good password' result is the same as no error message. *)
  Notation GOODPWD := None.

  (* A 'bad password' result is the same as some error message. *)
  Notation "BADPWD: msg" := (Some msg) (at level 80).

  (* Needs syntax to enable a check only when we have an old password. *)
  Notation "'NEEDS' old_pwd 'FROM' pt statement" :=
    (let old_pwd := (fun (pt : PasswordTransition) =>
                     match pt with
                       PwdTransition old new =>
                       match old with
                       | None => ""
                       | Some str => str
                       end
                     end) in
    if old_is_undefined pt then
      DISABLE_CHECK
    else
      statement) (at level 80).

End CheckerNotations.

Import CheckerNotations.

(* Some Basic Checkers *)

(* The new password must be different from old password *)
Definition diff_from_old_pwd (pt : PasswordTransition) : CheckerResult :=
  NEEDS old_pwd FROM pt
        if old_pwd(pt) ==_s new_pwd(pt) then
          BADPWD: "The new password is the same as the old password"
        else
          GOODPWD.

(* Prove that diff_from_old_password gives an error when old and new passwords are identical. *)
Theorem diff_from_old_pwd_correct : forall (old new : string),
    old = new -> diff_from_old_pwd (PwdTransition (Some old) new) <> None.
Proof.
  intros.
  unfold diff_from_old_pwd.
  simpl.
  rewrite H.
  rewrite beq_string_reflexive.
  congruence.
Qed.

(* The new password must not be a prefix of the old password (and vice-versa). *)
Definition prefix_of_old_pwd (pt : PasswordTransition) : CheckerResult :=
  NEEDS old_pwd FROM pt
        if prefix (old_pwd pt) (new_pwd pt) || prefix (new_pwd pt) (old_pwd pt) then
          BADPWD: "The new password is a prefix of the old password"
        else
          GOODPWD.

(* Prove that prefix_of_old_password gives an error when new password is prefix of the old one. *)
Definition prefix_of_old_pwd_correct : forall (old: string) (new : string),
    (prefix old new) = true \/ (prefix new old) = true ->
    prefix_of_old_pwd (PwdTransition (Some old) new) <> None.
Proof.
  intros.
  decompose [or] H.
  + unfold prefix_of_old_pwd.
    simpl.
    rewrite H0.
    rewrite orb_true_l.
    congruence.
  + unfold prefix_of_old_pwd.
    simpl.
    rewrite H0.
    rewrite orb_true_r.
    congruence.
Qed.

(* The new password must not be a palindrome *)
Definition not_palindrome (pt : PasswordTransition) : CheckerResult :=
  if palindrome (string_to_lower (new_pwd pt)) then
    BADPWD: "The new password is a palindrome."
  else
    GOODPWD.

(* Prove that not_palindrome gives an error when the new password is a palindrome. *)
Theorem not_palindrome_correct : forall (pt : PasswordTransition),
    palindrome (string_to_lower (new_pwd pt)) = true -> not_palindrome pt <> None.
Proof.
  intros.
  unfold not_palindrome.
  rewrite H.
  congruence.
Qed.

(* The new password must not be a rotated version of the old password. *)
Definition not_rotated (pt : PasswordTransition) : CheckerResult :=
  NEEDS old_pwd FROM pt
        if string_is_rotated (string_to_lower (old_pwd pt)) (string_to_lower (new_pwd pt)) then
	  BADPWD: "The new password is a rotated version of the old password."
	else
	  GOODPWD.

(* Prove that not_rotated gives an error when the new password is a rotated version of the old. *)
Theorem not_rotated_correct : forall (old new : string),
    string_is_rotated (string_to_lower old) (string_to_lower new) = true ->
    not_rotated (PwdTransition (Some old) new) <> None.
Proof.
  intros.
  unfold not_rotated.
  simpl.
  rewrite H.
  congruence.
Qed.

(* The new password must not just contain case changes in relation to the old password. *)
Definition not_case_changes_only (pt : PasswordTransition) : CheckerResult :=
  NEEDS old_pwd FROM pt
        if (string_to_lower (old_pwd pt)) ==_s (string_to_lower (new_pwd pt)) then
          BADPWD: "The new password contains case changes only compared to the old password."
        else
          GOODPWD.

(* Prove that not_case_changes_only gives an error when old and new passwords differ in case. *)
Theorem not_case_changes_only_correct : forall (old new : string),
    (string_to_lower old) = (string_to_lower new) ->
    not_case_changes_only (PwdTransition (Some old) new) <> None.
Proof.
  intros.
  unfold not_case_changes_only.
  simpl.
  rewrite <- H.
  rewrite beq_string_reflexive.
  congruence.
Qed.

(* The new password must have a certain Levenshtein distance from the old password. *)
Definition levenshtein_distance_gt (dist : nat) (pt : PasswordTransition) : CheckerResult :=
  NEEDS old_pwd FROM pt
        let old := string_to_lower (old_pwd pt) in
        let new := string_to_lower (new_pwd pt) in
        if levenshtein_distance old new <=? dist then
          BADPWD: "The new password is too similar to the old password."
        else
          GOODPWD.

(* Prove that levenshtein_distance_gt gives an error for passwords that are too similar. *)
Theorem levenshtein_distance_gt_correct : forall (dist : nat) (old new : string),
    levenshtein_distance (string_to_lower old) (string_to_lower (new)) <=? dist = true ->
    levenshtein_distance_gt dist (PwdTransition (Some old) new) <> None.
Proof.
  intros.
  unfold levenshtein_distance_gt.
  simpl.
  rewrite H.
  congruence.
Qed.

(* The new password must be long enough, taking into account number of character classes. *)
Definition credits_length_check (len : nat) (pt : PasswordTransition) : CheckerResult :=
  if length (new_pwd pt) >=? (len - string_count_character_classes (new_pwd pt)) then
    GOODPWD
  else
    BADPWD: "The new password is too short.".

Definition credits_length_check_correct : forall (len : nat) (old new : string),
    length new >=? (len - string_count_character_classes new) = false ->
    credits_length_check len (PwdTransition (Some old) new) <> None.
Proof.
  intros.
  unfold credits_length_check.
  simpl.
  rewrite H.
  congruence.
Qed.

(* The new password must be long enough. *)
Definition plain_length_check (len : nat) (pt : PasswordTransition) : CheckerResult :=
  if length (new_pwd pt) >=? len then
    GOODPWD
  else
    BADPWD: "The new password is too short.".

(* Prove that plain_length_check is correct for all lengths and password transitions. *)
Theorem plain_length_check_correct : forall (len : nat) (pt : PasswordTransition),
  plain_length_check len pt = GOODPWD <-> length (new_pwd pt) >=? len = true.
Proof.
  intros.
  split.
  + unfold plain_length_check.
    destruct (length (new_pwd pt) >=? len).
    (* Case 1: Premise is false. *)
    - simpl. congruence.
    (* Case 2: Trivial. *)
    - simpl. congruence.
  + unfold plain_length_check.
    destruct (length (new_pwd pt) <=? len).
    - unfold is_true. intros. rewrite H. reflexivity.
    - unfold is_true. intros. rewrite H. reflexivity.
Qed.

(* The new password must not contain more than a certain number of characters of the same class in
   a row. *)
Definition max_class_repeat (m : nat) (pt : PasswordTransition) : CheckerResult :=
  if m <=? (sequence_of (new_pwd pt) is_same_class 0) then
    GOODPWD
  else
    BADPWD: "The new password contains too many of the same character class in a row".

(* Prove that max_class_repeat gives an error appropriately. *)
Theorem max_class_repeat_correct : forall (m : nat) (pt : PasswordTransition),
    m <=? (sequence_of (new_pwd pt) is_same_class 0) = false -> max_class_repeat m pt <> None.
Proof.
  intros.
  unfold max_class_repeat.
  simpl.
  rewrite H.
  congruence.
Qed.

(* Some proofs on the behaviour of checkers (not the functional logic). *)

(* Returns true if the old password is undefined (none) otherwise returns false. *)
Definition old_pwd_is_undefined (pt : PasswordTransition): bool :=
  match pt with
  | PwdTransition old _ =>
    match old with
    | None => true
    | Some _ => false
    end
  end.

(* If the old password is undefined, then the checker prefix_of_old_pwd
   accepts any password (i.e. the prefix check is essentially disabled). *)
Lemma prefix_old_pwd_undefined: forall (pt: PasswordTransition),
    old_pwd_is_undefined(pt) = true -> prefix_of_old_pwd(pt) = GOODPWD.
Proof.
  intros.
  unfold old_pwd_is_undefined in H.
  (* Case analysis. *)
  destruct pt. destruct o.
   (* Case 1 (trivial): old password is defined. *)
   - congruence.
   (* Case 2: old password is undefined. *)
   - unfold prefix_of_old_pwd. simpl. auto.
Qed.


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

Local Open Scope Z_scope.

Section Spec.

  Definition complete_mmio_emulation_spec (rec: Pointer) (adt: RData) : option (RData * Z) :=
    rely (peq (base rec) buffer_loc);
    when gidx == (buffer (priv adt)) @ (offset rec);
    let gn := (gs (share adt)) @ gidx in
    rely (ref_accessible gn CPU_ID);
    rely (g_tag (ginfo gn) =? GRANULE_STATE_REC);
    let is_emul := (rec_run (priv adt)) @ 13 in
    let read_val := ((rec_run (priv adt)) @ 14) in
    rely is_int64 is_emul; rely is_int64 read_val;
    if is_emul =? 0 then
      Some (adt, 1)
    else
      let esr := g_esr (grec gn) in
      let rt := __esr_srt esr in
      let mask := __access_mask esr in
      rely is_int64 esr; rely is_int rt; rely is_int64 mask;
      if (negb (Z.land esr ESR_EL2_EC_MASK =? ESR_EL2_EC_DATA_ABORT) ||
            (Z.land esr ESR_EL2_ABORT_ISV_BIT =? 0))
      then
        Some (adt, 0)
      else
        rely is_int64 (g_pc (grec gn)); rely is_int64 (g_pc (grec gn) + 4);
        if (negb (__esr_is_write esr)) && (negb (rt =? 31)) then
          let val := Z.land read_val mask in
          let extend := __esr_sign_extend esr in
          rely is_int extend;
          if extend =? 0 then
            let g' := gn {grec: (grec gn) {g_regs: set_reg rt val (g_regs (grec gn))} {g_pc: (g_pc (grec gn)) + 4}} in
            Some (adt {share: (share adt) {gs: (gs (share adt)) # gidx == g'}}, 1)
          else
            let len := __access_len esr in
            rely is_int len;
            let bitcount := len * 8 in
            rely is_int bitcount; rely is_int (bitcount - 1);
            let mask := Z.shiftl 1 (bitcount - 1) in
            rely is_int64 mask; rely is_int64 (Z.lxor val mask);
            let val := (Z.lxor val mask) - mask in
            rely is_int64 val;
            if __esr_sixty_four esr then
              let g' := gn {grec: (grec gn) {g_regs: set_reg rt val (g_regs (grec gn))} {g_pc: (g_pc (grec gn)) + 4}} in
              Some (adt {share: (share adt) {gs: (gs (share adt)) # gidx == g'}}, 1)
            else
              let val := Z.land val 4294967295 in
              let g' := gn {grec: (grec gn) {g_regs: set_reg rt val (g_regs (grec gn))} {g_pc: (g_pc (grec gn)) + 4}} in
              Some (adt {share: (share adt) {gs: (gs (share adt)) # gidx == g'}}, 1)
        else
          let g' := gn {grec: (grec gn)  {g_pc: (g_pc (grec gn)) + 4}} in
          Some (adt {share: (share adt) {gs: (gs (share adt)) # gidx == g'}}, 1).

End Spec.