Set Implicit Arguments.

Require Import Platform.Cito.Syntax.
Require Import Platform.Cito.SyntaxExpr.
Require Import Platform.Cito.GeneralTactics.
Require Import Platform.Cito.Notations3.
Require Import Platform.Cito.SemanticsExpr.
Require Import Platform.Cito.GoodOptimizer.

Require Import Bedrock.StringSet.
Module Import SS := StringSet.
Require Import Platform.Cito.StringSetFacts.
Module SSF := StringSetFacts.
Require Import Platform.Cito.StringSetTactics.

Require Import Platform.Cito.StringMap.
Import StringMap.
Require Import Platform.Cito.StringMapFacts.

Definition const_dec : forall e, {w | e = Const w} + {~ exists w, e = Const w}.
  intros; destruct e; solve [ right; intuition; openhyp; intuition | left; eauto ].
Qed.

Definition const_zero_dec : forall e, {e = Const $0} + {e <> Const $0}.
  intros; destruct e; solve [right; intuition | destruct (weq w $0); intuition ].
Qed.

Ltac f_equal' :=
  match goal with
    | |- (if ?E1 then _ else _) = (if ?E2 then _ else _) => replace E2 with E1; try reflexivity
  end.

Require Import Platform.Cito.Option.

Ltac openhyp' :=
  repeat match goal with
           | H : context [const_dec ?E] |- _ => destruct (const_dec E)
           | |- context [const_dec ?E] => destruct (const_dec E)
           | H : context [const_zero_dec ?E] |- _ => destruct (const_zero_dec E)
           | |- context [const_zero_dec ?E] => destruct (const_zero_dec E)
           | H : context [option_dec ?E] |- _ => destruct (option_dec E)
           | |- context [option_dec ?E] => destruct (option_dec E)
           | H : context [ { _ | _ } ] |- _ => destruct H
         end.

Ltac descend :=
  repeat match goal with
           | [ |- exists x, _ ] => eexists
         end.

Ltac unfold_all :=
  repeat match goal with
           | H := _ |- _ => unfold H in *; clear H
         end.

Definition SET := SS.t.
Definition Map := t W.
Definition empty_set := SS.empty.
Definition empty_map := empty W.
Definition Submap elt m1 m2 := forall k v, @find elt k m1 = Some v -> find k m2 = Some v.
Definition subtract elt m s := @filter elt (fun k _ => negb (SS.mem k s)) m.

Section TopSection.

  Notation "m %%- k" := (remove k m) (at level 60).
  Infix "%<=" := Subset (at level 60).
  Infix "%%<=" := Submap (at level 60).
  Infix "+" := union.
  Infix "-" := subtract.
  Notation "! x" := (singleton x) (at level 100).
  Notation "[]" := (@empty _).
  Open Scope stmt_scope.
  Infix "<-" := Syntax.Assign.

  Fixpoint const_folding_expr (e : Expr) (env : Map) : Expr :=
    match e with
      | Var var =>
        match option_dec (find var env) with
          | inleft (exist w _) => Const w
          | _ => e
        end
      | Const w => e
      | SyntaxExpr.Binop op a b =>
        let a' := const_folding_expr a env in
        let b' := const_folding_expr b env in
        match const_dec a', const_dec b' with
          | inleft (exist wa _),  inleft (exist wb _) => Const (evalBinop op wa wb)
          | _, _ => SyntaxExpr.Binop op a' b'
        end
      | TestE op a b =>
        let a' := const_folding_expr a env in
        let b' := const_folding_expr b env in
        match const_dec a', const_dec b' with
          | inleft (exist wa _),  inleft (exist wb _) => Const (if evalTest op wa wb then $1 else $0)
          | _, _ => TestE op a' b'
        end
    end.

  Fixpoint const_folding (s : Stmt) (map : Map) : Stmt * Map * SET :=
    match s with
      | skip => (skip, map, empty_set)
      | a ;; b =>
        let result_a := const_folding a map in
        let map' := snd (fst result_a) in
        let result_b := const_folding b map' in
        let a' := fst (fst result_a) in
        let b' := fst (fst result_b) in
        let map'' := snd (fst result_b) in
        let written_a := snd result_a in
        let written_b := snd result_b in
        (a' ;; b', map'', written_a + written_b)
      | Syntax.If c t f =>
        let c' := const_folding_expr c map in
        match const_dec c' with
          | inleft (exist w _) =>
            if wneb w $0 then
              const_folding t map
            else
              const_folding f map
          | inright _ =>
            let result_t := const_folding t map in
            let result_f := const_folding f map in
            let t' := fst (fst result_t) in
            let f' := fst (fst result_f) in
            let written_t := snd result_t in
            let written_f := snd result_f in
            (* written vars in branches will no longer have known values *)
            let map' := map - written_t - written_f in
            (Syntax.If c' t' f', map', written_t + written_f)
        end
      | Syntax.While c b =>
        if const_zero_dec (const_folding_expr c map) then
          (skip, map, empty_set)
        else
          let c' := const_folding_expr c [] in
          let result_b := const_folding b [] in
          let b' := fst (fst result_b) in
          let written_b := snd result_b in
          (* written vars in loop body will no longer have known values *)
          let map' := map - written_b in
          (Syntax.While c' b', map', written_b)
      | x <- e =>
        let e' := const_folding_expr e map in
        match const_dec e' with
          | inleft (exist w _) =>
            let map' := add x w map  in
            (x <- w, map', !x)
          | inright _ =>
            let map' := map %%- x in
            (x <- e', map', !x)
        end
      | Syntax.Label x l =>
        let map := map %%- x in
        (s, map, !x)
      | Syntax.Call x f args =>
        let f' := const_folding_expr f map in
        let args' := List.map (fun e => const_folding_expr e map) args in
        match x with
          | Some s =>
            let map := map %%- s in
            (Syntax.Call x f' args', map, !s)
          | None =>
            (Syntax.Call x f' args', map, empty_set)
        end
    end.

  Definition constant_folding s := fst (fst (const_folding s empty_map)).

  Definition optimizer := constant_folding.

  Definition opt : Optimizer := fun s _ => optimizer s.

  Lemma union_same_subset : forall s, s + s %<= s.
    intros; subset_solver.
  Qed.

  Require Import Platform.Cito.GeneralTactics2.
  Require Import Coq.Bool.Bool.
  Require Import Coq.Classes.Morphisms.

  Lemma subtract_none : forall elt (m : t elt) s x, SS.In x s -> find x (m - s) = None.
    unfold subtract; intros.
    eapply not_find_in_iff.
    nintro.
    eapply In_MapsTo in H0; openhyp.
    eapply filter_iff in H0; openhyp.
    eapply negb_true_iff in H1.
    eapply not_mem_iff in H1; intuition.
    unfold Proper.
    unfold respectful.
    intros; subst; eauto.
  Qed.

  Lemma empty_submap : forall elt (m : t elt), [] %%<= m.
    unfold Submap; intros.
    eapply find_2 in H; eapply empty_mapsto_iff in H; intuition.
  Qed.

  Lemma subtract_submap : forall elt (m : t elt) s, m - s %%<= m.
    unfold subtract, Submap.
    intros.
    eapply find_2 in H.
    eapply filter_iff in H.
    openhyp.
    eapply find_1; eauto.
    unfold Proper.
    unfold respectful.
    intros; subst; eauto.
  Qed.

  Lemma subtract_mapsto_iff : forall elt m s k v, @MapsTo elt k v (m - s) <-> (MapsTo k v m /\ ~ SS.In k s).
    unfold subtract.
    split; intros.
    eapply filter_iff in H.
    openhyp.
    split; eauto.
    eapply negb_true_iff in H0.
    eapply not_mem_iff; eauto.
    unfold Proper.
    unfold respectful.
    intros; subst; eauto.
    openhyp.
    eapply filter_iff.
    unfold Proper.
    unfold respectful.
    intros; subst; eauto.
    split; eauto.
    eapply negb_true_iff.
    eapply not_mem_iff; eauto.
  Qed.

  Section HintsSection.

    Hint Resolve empty_iff.
    Hint Unfold Subset.
    Hint Unfold Submap.
    Hint Resolve subtract_none.
    Hint Resolve singleton_iff.
    Hint Resolve union_subset_1.
    Hint Resolve union_subset_2.
    Hint Immediate subset_refl.
    Hint Resolve union_same_subset.
    Hint Resolve empty_submap.
    Hint Resolve subtract_submap.
    Hint Resolve union_iff union_1 union_2 union_3.

    Definition agree_with (v : vals) (m : Map) :=
      forall x w,
        find x m = Some w ->
        Locals.sel v x = w.

    Lemma agree_with_remove : forall local m x e, agree_with local m -> agree_with (upd local x e) (m %%- x).
      unfold agree_with; intros; destruct (string_dec x x0).
      subst.
      eapply find_2 in H0; eapply remove_mapsto_iff in H0; intuition.
      eapply find_2 in H0; eapply remove_mapsto_iff in H0; openhyp.
      rewrite sel_upd_ne.
      eapply H; eauto.
      eapply find_1; eauto.
      eauto.
    Qed.
    Hint Resolve agree_with_remove.

    Lemma agree_with_add : forall local m x w, agree_with local m -> agree_with (upd local x w) (add x w m).
      unfold agree_with; intros; destruct (string_dec x x0).
      subst.
      rewrite sel_upd_eq in *.
      eapply find_2 in H0; eapply add_mapsto_iff in H0; openhyp; intuition.
      eauto.
      rewrite sel_upd_ne in *.
      eapply H; eauto.
      eapply find_1.
      eapply find_2 in H0; eapply add_mapsto_iff in H0; openhyp; intuition.
      eauto.
    Qed.
    Hint Resolve agree_with_add.

    Lemma everything_agree_with_empty_map : forall v, agree_with v empty_map.
      unfold agree_with.
      intros.
      eapply find_2 in H; eapply empty_mapsto_iff in H.
      intuition.
    Qed.
    Hint Resolve everything_agree_with_empty_map.

    Definition agree_except (a b : vals) (s : SET) :=
      forall x,
        Locals.sel a x <> Locals.sel b x -> SS.In x s.

    Lemma agree_except_upd : forall local x w, agree_except local (upd local x w) (!x).
      unfold agree_except.
      intros.
      destruct (string_dec x x0).
      subst.
      eapply singleton_iff; eauto.
      rewrite sel_upd_ne in H.
      intuition.
      eauto.
    Qed.
    Hint Resolve agree_except_upd.

    Lemma agree_except_same : forall local s, agree_except local local s.
      intuition.
    Qed.
    Hint Resolve agree_except_same.

    Lemma agree_except_incl : forall v1 v2 s s', agree_except v1 v2 s -> s %<= s' -> agree_except v1 v2 s'.
      unfold agree_except; eauto.
    Qed.
    Hint Resolve agree_except_incl.

    Lemma agree_except_trans : forall m1 m2 m3 s1 s2, agree_except m1 m2 s1 -> agree_except m2 m3 s2 -> agree_except m1 m3 (s1 + s2).
      unfold agree_except.
      intros.
      destruct (weq (Locals.sel m1 x) (Locals.sel m2 x)).
      destruct (weq (Locals.sel m2 x) (Locals.sel m3 x)).
      intuition.
      eauto.
      eauto.
    Qed.
    Hint Resolve agree_except_trans.

    Lemma agree_with_agree_except_subtract : forall v1 v2 m s, agree_with v1 m -> agree_except v1 v2 s -> agree_with v2 (m - s).
      unfold agree_with, agree_except.
      intros.
      destruct (weq (Locals.sel v1 x) (Locals.sel v2 x)).
      rewrite <- e.
      eapply H.
      eapply find_2 in H1.
      eapply subtract_mapsto_iff in H1.
      openhyp.
      eapply find_1; eauto.
      eapply H0 in n.
      eapply subtract_none with (m := m) in n.
      erewrite H1 in n.
      intuition.
    Qed.
    Hint Resolve agree_with_agree_except_subtract.

  End HintsSection.

  Hint Resolve union_subset_1.
  Hint Resolve union_subset_2.
  Hint Immediate subset_refl.
  Hint Resolve union_same_subset.
  Hint Resolve empty_submap.
  Hint Resolve subtract_submap.

  Hint Resolve agree_with_remove.
  Hint Resolve agree_with_add.
  Hint Resolve everything_agree_with_empty_map.
  Hint Resolve agree_except_upd.
  Hint Resolve agree_except_same.
  Hint Resolve agree_except_trans.
  Hint Resolve agree_with_agree_except_subtract.
  Hint Resolve agree_except_incl.

  Remove Hints WordKey.W_as_OT.eq_trans.
  Remove Hints WordKey.W_as_OT_new.eq_trans.

  Lemma const_folding_expr_correct :
    forall e m local,
      agree_with local m ->
      eval local (const_folding_expr e m) = eval local e.
  Proof.
    induction e; simpl; intuition; openhyp'; simpl in *; eauto.

    symmetry; eauto.

    f_equal.
    erewrite <- (IHe1 m); eauto.
    erewrite e0; eauto.
    erewrite <- (IHe2 m); eauto.
    erewrite e; eauto.

    f_equal; eauto.

    f_equal; eauto.

    f_equal'; f_equal.
    erewrite <- (IHe1 m); eauto.
    erewrite e0; eauto.
    erewrite <- (IHe2 m); eauto.
    erewrite e; eauto.

    f_equal'; f_equal; eauto.

    f_equal'; f_equal; eauto.
  Qed.

  Lemma const_folding_expr_correct' :
    forall e e' m local,
      e' = const_folding_expr e m ->
      agree_with local m ->
      eval local e' = eval local e.
  Proof.
    intros; subst; eapply const_folding_expr_correct; eauto.
  Qed.

  Lemma const_folding_expr_submap_const : forall e m w, const_folding_expr e m = Const w -> forall m', m %%<= m' -> const_folding_expr e m' = Const w.
    induction e; simpl; intuition; openhyp'; simpl in *; try discriminate.

    eapply H0 in e0.
    rewrite e0 in e.
    injection e; intros; subst.
    eauto.

    eapply H0 in e0.
    rewrite e0 in e.
    discriminate.

    eapply IHe1 in e4; eauto.
    eapply IHe2 in e3; eauto.
    rewrite e0 in e4; injection e4; intros; subst.
    rewrite e in e3; injection e3; intros; subst.
    eauto.

    contradict n.
    descend.
    eauto.

    contradict n.
    descend.
    eauto.

    eapply IHe1 in e4; eauto.
    eapply IHe2 in e3; eauto.
    rewrite e0 in e4; injection e4; intros; subst.
    rewrite e in e3; injection e3; intros; subst.
    eauto.

    contradict n.
    descend.
    eauto.

    contradict n.
    descend.
    eauto.

  Qed.
  Hint Resolve const_folding_expr_submap_const.

  Lemma not_const_zero_submap : forall e m m', const_folding_expr e m <> Const $0 -> m' %%<= m -> const_folding_expr e m' <> Const $0.
    intuition eauto.
  Qed.
  Hint Resolve not_const_zero_submap.

  Lemma not_const_zero_empty_map : forall e m, const_folding_expr e m <> Const $0 -> const_folding_expr e empty_map <> Const $0.
    intros.
    eapply not_const_zero_submap; eauto.
    eapply empty_submap.
  Qed.
  Hint Resolve not_const_zero_empty_map.

  Lemma break_pair : forall A B (p : A * B), p = (fst p, snd p).
    intros; destruct p; eauto.
  Qed.

End TopSection.

Ltac rewrite_expr := repeat erewrite const_folding_expr_correct in * by eauto.

Lemma const_folding_expr_correct_list :
  forall es m local,
    agree_with local m ->
    List.map (fun e => eval local (const_folding_expr e m)) es = List.map (eval local) es.
Proof.
  induction es; simpl; intuition; rewrite_expr; f_equal; eauto.
Qed.

Ltac rewrite_expr_list := repeat erewrite map_map in *; repeat erewrite const_folding_expr_correct_list in * by eauto.

Require Import Platform.Cito.ADT.

Module Make (Import E : ADT).

  Module Import GoodOptimizerMake := GoodOptimizer.Make E.
  Require Import Platform.Cito.Semantics.
  Import SemanticsMake.

  Section TopSection.

    Notation "m %%- k" := (remove k m) (at level 60).
    Infix "%<=" := Subset (at level 60).
    Infix "%%<=" := Submap (at level 60).
    Infix "+" := union.
    Infix "-" := subtract.
    Notation "! x" := (singleton x) (at level 100).
    Notation "[]" := empty_map.
    Open Scope stmt_scope.
    Infix "<-" := Syntax.Assign.

    Hint Resolve union_subset_1.
    Hint Resolve union_subset_2.
    Hint Immediate subset_refl.
    Hint Resolve union_same_subset.
    Hint Resolve empty_submap.
    Hint Resolve subtract_submap.

    Hint Resolve agree_with_remove.
    Hint Resolve agree_with_add.
    Hint Resolve everything_agree_with_empty_map.
    Hint Resolve agree_except_upd.
    Hint Resolve agree_except_same.
    Hint Resolve agree_except_trans.
    Hint Resolve agree_with_agree_except_subtract.
    Hint Resolve agree_except_incl.

    Hint Unfold RunsTo.
    Hint Constructors Semantics.RunsTo.
    Hint Unfold Safe.
    Hint Constructors Semantics.Safe.

    Lemma while_case :
      forall fs t v v',
        RunsTo fs t v v' ->
        forall s c b m,
          let result := const_folding s m in
          let s' := fst (fst result) in
          let m' := snd (fst result) in
          let written := snd result in
          s = Syntax.While c b ->
          t = s' ->
          agree_with (fst v) m ->
          (let s := b in
           (* the induction hypothesis from Lemma const_folding_is_backward_simulation' *)

           forall (vs : vals) (heap : Heap) (vs' : vals)
                  (heap' : Heap) (m : Map),
             let result := const_folding s m in
             let s' := fst (fst result) in
             let m' := snd (fst result) in
             let written := snd result in
             RunsTo fs s' (vs, heap) (vs', heap') ->
             agree_with vs m ->
             RunsTo fs s (vs, heap) (vs', heap') /\
             agree_with vs' m' /\
             agree_except vs vs' written

          ) ->
          RunsTo fs s v v' /\
          agree_with (fst v') m' /\
          agree_except (fst v) (fst v') written.
    Proof.
      induction 1; simpl; intros; unfold_all; subst.

      (* skip *)
      simpl in *; openhyp'; simpl in *; intuition.
      econstructor 6.
      erewrite <- const_folding_expr_correct'.
      2 : symmetry; eauto.
      simpl; eauto.
      simpl; eauto.
      econstructor.

      (* seq *)
      simpl in *; openhyp'; simpl in *; intuition.

      (* seq *)
      simpl in *; openhyp'; simpl in *; intuition.

      (* if *)
      simpl in *; openhyp'; simpl in *; intuition.

      (* if *)
      simpl in *; openhyp'; simpl in *; intuition.

      (* while *)
      simpl in *; openhyp'; simpl in *; try discriminate.
      injection H3; intros; subst.
      destruct v; simpl in *.
      destruct v'; simpl in *.
      eapply H5 in H0; eauto; openhyp.
      destruct v''; simpl in *.
      edestruct IHRunsTo2; try reflexivity.
      3 : eauto.
      replace (While (const_folding_expr c _) (fst (fst (const_folding b _)))) with (fst (fst (const_folding (While c b ) (m - snd (const_folding b []))))).
      Focus 2.
      simpl in *; openhyp'; [contradict e; eauto | simpl; eauto ].
      eapply not_const_zero_submap; eauto.
      eauto.
      eauto.
      openhyp.
      simpl in *; openhyp'; [ contradict e; eauto | ]; simpl in *.
      eapply not_const_zero_submap; eauto.
      rewrite_expr.
      intuition eauto.

      (* while *)
      simpl in *; openhyp'; simpl in *; try discriminate.
      injection H1; intros; subst.
      rewrite_expr.
      intuition eauto.

      (* call *)
      simpl in *; openhyp'; simpl in *; intuition.

      (* call *)
      simpl in *; openhyp'; simpl in *; intuition.

      (* label *)
      simpl in *; openhyp'; simpl in *; intuition.

      (* assign *)
      simpl in *; openhyp'; simpl in *; intuition.

    Qed.

    Lemma const_folding_is_backward_simulation :
      forall fs s vs heap vs' heap' m,
        let result := const_folding s m in
        let s' := fst (fst result) in
        let m' := snd (fst result) in
        let written := snd result in
        RunsTo fs s' (vs, heap) (vs', heap') ->
        agree_with vs m ->
        RunsTo fs s (vs, heap) (vs', heap') /\
        agree_with vs' m' /\
        agree_except vs vs' written.
    Proof.
      induction s;
      match goal with
        | |- context [Syntax.While] => solve [intros; split; intros; eapply while_case in H; eauto; openhyp; eauto]
        | |- _ => idtac
      end; simpl; intros.

      (* skip *)
      inversion H; unfold_all; subst; rewrite_expr; eauto.

      (* seq *)
      inversion H; unfold_all; subst.
      destruct v'; simpl in *.
      eapply IHs1 in H3; eauto; openhyp.
      eapply IHs2 in H6; eauto; openhyp.
      eauto 6.

      (* if *)
      openhyp'.

      destruct (Sumbool.sumbool_of_bool (wneb x $0)); rewrite e1 in *; simpl in *.
      eapply IHs1 in H; eauto; openhyp.
      replace x with (eval vs x) in e1 by eauto.
      rewrite <- e0 in e1.
      rewrite_expr.
      eauto.
      eapply IHs2 in H; eauto; openhyp.
      replace x with (eval vs x) in e1 by eauto.
      rewrite <- e0 in e1.
      rewrite_expr.
      eauto.

      simpl in *.
      inversion H; unfold_all; subst.
      rewrite_expr.
      eapply IHs1 in H7; eauto; openhyp.
      intuition eauto.
      rewrite_expr.
      eapply IHs2 in H7; eauto; openhyp.
      split; [econstructor 4 | ]; eauto.

      Focus 3.
      (* assign *)
      openhyp'; simpl in *; inversion H; unfold_all; subst; simpl in *.
      split.
      replace x with (eval vs x) by eauto.
      rewrite <- e0.
      rewrite_expr.
      econstructor; eauto.
      eauto.

      split.
      rewrite_expr.
      econstructor; eauto.
      eauto.

      (* call *)
      destruct o; openhyp'; simpl in *; inversion H; unfold_all; subst; simpl in *.
      split.
      rewrite_expr.
      rewrite_expr_list.
      specialize RunsToCallInternal; intros.
      simpl in *.
      specialize (H1 _ fs (Some s)).
      simpl in *.
      eapply H1; eauto.
      eauto.

      split.
      rewrite_expr.
      rewrite_expr_list.
      specialize RunsToCallForeign; intros.
      simpl in *.
      specialize (H1 _ fs (Some s)).
      simpl in *.
      eapply H1; eauto.
      eauto.

      split.
      rewrite_expr.
      rewrite_expr_list.
      specialize RunsToCallInternal; intros.
      simpl in *.
      specialize (H1 _ fs None).
      simpl in *.
      eapply H1; eauto.
      eauto.

      split.
      rewrite_expr.
      rewrite_expr_list.
      specialize RunsToCallForeign; intros.
      simpl in *.
      specialize (H1 _ fs None).
      simpl in *.
      eapply H1; eauto.
      eauto.

      (* label *)
      openhyp'; simpl in *; inversion H; unfold_all; subst; simpl in *.
      split.
      rewrite_expr.
      econstructor; eauto.
      eauto.
    Qed.

    Lemma PreserveRunsTo_opt : PreserveRunsTo opt.
      unfold PreserveRunsTo, opt, optimizer, constant_folding; intros.
      destruct v.
      destruct v'; simpl in *.
      eapply const_folding_is_backward_simulation in H; openhyp; eauto.
    Qed.

    Lemma const_folding_is_safety_preservation :
      forall fs s vs heap m,
        let result := const_folding s m in
        let s' := fst (fst result) in
        Safe fs s (vs, heap) ->
        agree_with vs m ->
        Safe fs s' (vs, heap).
    Proof.
      induction s.

      Focus 4.
      intros.
      unfold_all.
      eapply
        (Safe_coind
           (fun s' v =>
              (exists c b m,
                 let s := While c b in
                 Safe fs s v /\
                 agree_with (fst v) m /\
                 (let s := b in
                  forall (vs : vals) (heap : Heap) (m : Map),
                    Safe fs s (vs, heap) ->
                    agree_with vs m -> Safe fs (fst (fst (const_folding s m))) (vs, heap)
                 ) /\
                 s' = fst (fst (const_folding s m))) \/
              Safe fs s' v
        )); [ .. | left; descend; intuition eauto ]; clear; simpl; intros; openhyp.

      (* seq *)
      simpl in *; openhyp'; simpl in *; intuition.

      inversion_clear H.
      intuition eauto.

      (* if *)
      simpl in *; openhyp'; simpl in *; intuition.

      inversion H; subst.
      openhyp.
      intuition eauto.
      right; intuition eauto.

      (* while *)
      simpl in *; openhyp'; simpl in *; intuition.
      injection H2; intros; subst.
      rewrite_expr.
      inversion H; unfold_all; subst.
      destruct v; simpl in *.
      left.
      repeat split.
      eauto.
      right.
      eauto.

      intros.
      left.
      destruct v'; simpl in *.
      eapply const_folding_is_backward_simulation in H3; eauto; openhyp.
      descend; intuition.
      simpl in *; openhyp'; [ contradict e; eauto | ]; simpl in *.
      eapply not_const_zero_empty_map; eauto.
      eauto.

      right.
      eauto.

      inversion H; unfold_all; subst.
      intuition eauto.
      right.
      intuition eauto.

      simpl in *; openhyp'; simpl in *; intuition.

      inversion H; unfold_all; subst.
      left.
      descend.
      intuition eauto.
      right.
      descend.
      intuition eauto.

      simpl in *; openhyp'; simpl in *; intuition.
      inversion_clear H; eauto.

      (* skip *)
      eauto.

      (* seq *)
      simpl; intros; inversion H; unfold_all; subst.
      econstructor.
      simpl in *.
      eapply IHs1; eauto.
      intros.
      destruct v'; simpl in *.
      eapply const_folding_is_backward_simulation in H1.
      openhyp.
      eapply IHs2; eauto.
      eauto.

      (* if *)
      simpl; intros; openhyp'.

      destruct (Sumbool.sumbool_of_bool (wneb x $0)); rewrite e1 in *; simpl in *.
      inversion H; subst.
      unfold_all.
      openhyp.
      eauto.
      erewrite <- const_folding_expr_correct' in H1.
      2 : symmetry; eauto.
      simpl in *.
      intuition.
      eauto.
      inversion H; subst.
      unfold_all.
      openhyp.
      erewrite <- const_folding_expr_correct' in H1.
      2 : symmetry; eauto.
      simpl in *.
      intuition.
      eauto.
      eauto.

      simpl in *.
      inversion H; subst.
      unfold_all.
      openhyp.
      econstructor.
      left.
      rewrite_expr.
      intuition eauto.
      eapply IHs1; eauto.
      econstructor.
      right.
      rewrite_expr.
      intuition eauto.
      eapply IHs2; eauto.

      (* call *)
      destruct o; simpl; intros; inversion H; unfold_all; subst.

      econstructor; rewrite_expr; rewrite_expr_list; eauto.
      rewrite map_length; eauto.

      eapply SafeCallForeign; rewrite_expr; eauto; rewrite_expr_list; eauto.

      econstructor; rewrite_expr; rewrite_expr_list; eauto.
      rewrite map_length; eauto.

      eapply SafeCallForeign; rewrite_expr; eauto; rewrite_expr_list; eauto.

      (* assign *)
      simpl; intros; simpl in *; openhyp'; simpl in *; eauto.

      (* label *)
      simpl; intros; simpl in *; openhyp'; simpl in *; eauto.

    Qed.

    Lemma PreserveSafe_opt : PreserveSafe opt.
      unfold PreserveSafe, opt, optimizer, constant_folding; intros.
      destruct v.
      eapply const_folding_is_safety_preservation in H; openhyp; eauto.
    Qed.

    Require Import Platform.Cito.FreeVarsExpr.

    Lemma const_folding_expr_footprint : forall e m, SS.Subset (free_vars (const_folding_expr e m)) (free_vars e).
    Proof.
      induction e; simpl; intros; openhyp'; simpl in *; subset_solver; eauto using subset_trans.
    Qed.
    Hint Resolve const_folding_expr_footprint.

    Lemma const_folding_expr_footprint_list : forall es m, SS.Subset (Union.union_list (List.map free_vars (List.map (fun e => const_folding_expr e m) es))) (Union.union_list (List.map free_vars es)).
    Proof.
      unfold Union.union_list.
      induction es; simpl; intuition eauto.
      subset_solver; eauto using subset_trans.
    Qed.

    Hint Resolve const_folding_expr_footprint_list.

    Require Import Platform.Cito.FreeVars.

    Lemma const_folding_footprint : forall s m, SS.Subset (free_vars (fst (fst (const_folding s m)))) (free_vars s).
    Proof.
      induction s; simpl; intros; openhyp'; simpl in *; subset_solver.
      eauto using subset_trans.
      eauto using subset_trans.
      destruct (Sumbool.sumbool_of_bool (wneb x $0)); rewrite e1 in *; simpl in *.
      eauto using subset_trans.
      eauto using subset_trans.
      eauto using subset_trans.
      eauto using subset_trans.
      eauto using subset_trans.
      eauto using subset_trans.
      eauto using subset_trans.
      destruct o; simpl in *.
      subset_solver; eauto using subset_trans.
      subset_solver; eauto using subset_trans.
      eauto using subset_trans.
    Qed.

    Lemma optimizer_footprint : forall s, SS.Subset (free_vars (optimizer s)) (free_vars s).
      unfold optimizer, constant_folding; intros; eapply const_folding_footprint.
    Qed.

    Open Scope nat.

    Require Import Coq.Arith.Le.
    Require Import Coq.Arith.Max.
    Require Import Platform.Cito.MaxFacts.

    Hint Resolve both_le Le.le_n_S.

    Require Import Platform.Cito.DepthExpr.

    Lemma const_folding_expr_depth : forall e m, depth (const_folding_expr e m) <= depth e.
    Proof.
      induction e; simpl; intuition; openhyp'; simpl in *; eauto.
    Qed.
    Hint Resolve const_folding_expr_depth.

    Lemma const_folding_expr_depth_list : forall es m, le (Max.max_list 0 (List.map depth (List.map (fun e => const_folding_expr e m) es))) (Max.max_list 0 (List.map depth es)).
    Proof.
      unfold Max.max_list.
      induction es; simpl; intuition eauto.
    Qed.

    Hint Resolve const_folding_expr_depth_list.

    Require Import Platform.Cito.Depth.

    Hint Extern 0 (le _ _) => progress (simpl; max_solver).

    Lemma const_folding_depth : forall s m, depth (fst (fst (const_folding s m))) <= depth s.
    Proof.
      induction s; simpl; intuition; openhyp'; simpl in *; eauto.

      destruct (Sumbool.sumbool_of_bool (wneb x $0)); rewrite e1 in *; simpl in *.
      eauto using le_trans.
      eauto using le_trans.
      destruct o; simpl in *.
      max_solver; eauto using le_trans.
      max_solver; eauto using le_trans.
    Qed.

    Lemma optimizer_depth : forall s, depth (optimizer s) <= depth s.
      unfold optimizer, constant_folding; intros; eapply const_folding_depth.
    Qed.

    Import NPeano.Nat.
    Require Import Platform.Cito.GetLocalVars.
    Require Import Platform.Cito.GetLocalVarsFacts.

    Lemma PreserveGoodSize_opt : PreserveGoodSize opt.
      unfold PreserveGoodSize, opt; intros.
      eapply goodSize_weaken; eauto.
      eapply add_le_mono.
      2 : eapply optimizer_depth.
      eapply get_local_vars_cardinal.
      eapply optimizer_footprint; eauto.
    Qed.

    Require Import Platform.Cito.CompileStmtSpec.
    Require Import Platform.Cito.SetoidListFacts.
    Require Import Platform.Cito.GeneralTactics2.

    Require Import Platform.Cito.WellFormed.

    Hint Constructors args_not_too_long.

    Lemma const_folding_wellformed : forall s m, wellformed s -> wellformed (fst (fst (const_folding s m))).
      unfold wellformed.
      induction s; simpl; intuition; openhyp'; inversion_clear H; simpl in *; eauto.
      destruct (Sumbool.sumbool_of_bool (wneb x $0)); rewrite e1 in *; simpl in *; eauto.
      destruct o; simpl in *; eauto; econstructor; eauto; rewrite map_length; eauto.
    Qed.

    Lemma PreserveSynReq_opt : PreserveSynReq opt.
      unfold PreserveSynReq, opt; intros.
      unfold syn_req in *.
      unfold in_scope in *.
      openhyp.
      repeat split; eauto.
      eapply get_local_vars_subset; eauto.
      eapply const_folding_wellformed; eauto.
    Qed.

    Lemma good_optimizer : GoodOptimizer opt.
      unfold GoodOptimizer.
      split.
      eapply PreserveRunsTo_opt.
      split.
      eapply PreserveSafe_opt.
      split.
      eapply PreserveGoodSize_opt.
      eapply PreserveSynReq_opt.
    Qed.

  End TopSection.

End Make.


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

(** RTL function inlining *)

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

(** ** Environment of inlinable functions *)

(** We maintain a mapping from function names to their definitions.
  In this mapping, we only include internal functions that are eligible for
  inlining, as determined by the external heuristic
  [should_inline]. *)

Definition funenv : Type := PTree.t function.

Definition size_fenv (fenv: funenv) := PTree_Properties.cardinal fenv.

Parameter should_inline: ident -> function -> bool.

Definition add_globdef (fenv: funenv) (idg: ident * globdef fundef unit) : funenv :=
  match idg with
  | (id, Gfun (Internal f)) =>
      if should_inline id f
      then PTree.set id f fenv
      else PTree.remove id fenv
  | (id, _) =>
      PTree.remove id fenv
  end.

Definition funenv_program (p: program) : funenv :=
  List.fold_left add_globdef p.(prog_defs) (PTree.empty function).

(** State monad *)

(** To construct incrementally the CFG of a function after inlining,
  we use a state monad similar to that used in module [RTLgen].
  It records the current state of the CFG, plus counters to generate
  fresh pseudo-registers and fresh CFG nodes.  It also records the
  stack size needed for the inlined function. *)

Record state : Type := mkstate {
  st_nextreg: positive;                 (**r last used pseudo-register *)
  st_nextnode: positive;                (**r last used CFG node *)
  st_code: code;                        (**r current CFG  *)
  st_stksize: Z                         (**r current stack size *)
}.

(** Monotone evolution of the state. *)

Inductive sincr (s1 s2: state) : Prop :=
  Sincr (NEXTREG: Ple s1.(st_nextreg) s2.(st_nextreg))
        (NEXTNODE: Ple s1.(st_nextnode) s2.(st_nextnode))
        (STKSIZE: s1.(st_stksize) <= s2.(st_stksize)).

Remark sincr_refl: forall s, sincr s s.
Proof.
  intros; constructor; xomega.
Qed.

Lemma sincr_trans: forall s1 s2 s3, sincr s1 s2 -> sincr s2 s3 -> sincr s1 s3.
Proof.
  intros. inv H; inv H0. constructor; xomega.
Qed.

(** Dependently-typed state monad, ensuring that the final state is
  greater or equal (in the sense of predicate [sincr] above) than
  the initial state. *)

Inductive res {A: Type} {s: state}: Type := R (x: A) (s': state) (I: sincr s s').

Definition mon (A: Type) : Type := forall (s: state), @res A s.

(** Operations on this monad. *)

Definition ret {A: Type} (x: A): mon A :=
  fun s => R x s (sincr_refl s).

Definition bind {A B: Type} (x: mon A) (f: A -> mon B): mon B :=
  fun s1 => match x s1 with R vx s2 I1 =>
              match f vx s2 with R vy s3 I2 =>
                R vy s3 (sincr_trans s1 s2 s3 I1 I2)
              end
            end.

Notation "'do' X <- A ; B" := (bind A (fun X => B))
   (at level 200, X ident, A at level 100, B at level 200).

Definition initstate :=
  mkstate 1%positive 1%positive (PTree.empty instruction) 0.

Program Definition set_instr (pc: node) (i: instruction): mon unit :=
  fun s =>
    R tt
      (mkstate s.(st_nextreg) s.(st_nextnode) (PTree.set pc i s.(st_code)) s.(st_stksize))
      _.
Next Obligation.
  intros; constructor; simpl; xomega.
Qed.

Program Definition add_instr (i: instruction): mon node :=
  fun s =>
    let pc := s.(st_nextnode) in
    R pc
      (mkstate s.(st_nextreg) (Psucc pc) (PTree.set pc i s.(st_code)) s.(st_stksize))
      _.
Next Obligation.
  intros; constructor; simpl; xomega.
Qed.

Program Definition reserve_nodes (numnodes: positive): mon positive :=
  fun s =>
    R s.(st_nextnode)
      (mkstate s.(st_nextreg) (Pplus s.(st_nextnode) numnodes) s.(st_code) s.(st_stksize))
      _.
Next Obligation.
  intros; constructor; simpl; xomega.
Qed.

Program Definition reserve_regs (numregs: positive): mon positive :=
  fun s =>
    R s.(st_nextreg)
      (mkstate (Pplus s.(st_nextreg) numregs) s.(st_nextnode) s.(st_code) s.(st_stksize))
      _.
Next Obligation.
  intros; constructor; simpl; xomega.
Qed.

Program Definition request_stack (sz: Z): mon unit :=
  fun s =>
    R tt
      (mkstate s.(st_nextreg) s.(st_nextnode) s.(st_code) (Zmax s.(st_stksize) sz))
      _.
Next Obligation.
  intros; constructor; simpl; xomega.
Qed.

Program Definition ptree_mfold {A: Type} (f: positive -> A -> mon unit) (t: PTree.t A): mon unit :=
  fun s =>
    R tt
      (PTree.fold (fun s1 k v => match f k v s1 return _ with R _ s2 _ => s2 end) t s)
      _.
Next Obligation.
  apply PTree_Properties.fold_rec.
  auto.
  apply sincr_refl.
  intros. destruct (f k v a). eapply sincr_trans; eauto.
Qed.

(** ** Inlining contexts *)

(** A context describes how to insert the CFG for a source function into
  the CFG for the function after inlining:
- a source instruction at PC [n] is relocated to PC [n + ctx.(dpc)];
- all pseudo-registers of this instruction are shifted by [ctx.(dreg)];
- all stack references are shifted by [ctx.(dstk)];
- "return" instructions are transformed into "return" or "move" instructions
  as governed by [ctx.(retinfo)].
*)

Record context: Type := mkcontext {
  dpc: positive;                        (**r offset for PCs *)
  dreg: positive;                       (**r offset for pseudo-regs *)
  dstk: Z;                              (**r offset for stack references *)
  mreg: positive;                       (**r max pseudo-reg number *)
  mstk: Z;                              (**r original stack block size *)
  retinfo: option(node * reg)           (**r where to branch on return *)
                                        (**r and deposit return value *)
}.

(** The following functions "shift" (relocate) PCs, registers, operations, etc. *)

Definition shiftpos (p amount: positive) := Ppred (Pplus p amount).

Definition spc (ctx: context) (pc: node) := shiftpos pc ctx.(dpc).

Definition sreg (ctx: context) (r: reg) := shiftpos r ctx.(dreg).

Definition sregs (ctx: context) (rl: list reg) := List.map (sreg ctx) rl.

Definition sros (ctx: context) (ros: reg + ident) := sum_left_map (sreg ctx) ros.

Definition sop (ctx: context) (op: operation) :=
  shift_stack_operation ctx.(dstk) op.

Definition saddr (ctx: context) (addr: addressing) :=
  shift_stack_addressing ctx.(dstk) addr.

Fixpoint sbuiltinarg (ctx: context) (a: builtin_arg reg) : builtin_arg reg :=
  match a with
  | BA x => BA (sreg ctx x)
  | BA_loadstack chunk ofs => BA_loadstack chunk (Ptrofs.add ofs (Ptrofs.repr ctx.(dstk)))
  | BA_addrstack ofs => BA_addrstack (Ptrofs.add ofs (Ptrofs.repr ctx.(dstk)))
  | BA_splitlong hi lo => BA_splitlong (sbuiltinarg ctx hi) (sbuiltinarg ctx lo)
  | _ => a
  end.

Definition sbuiltinres (ctx: context) (a: builtin_res reg) : builtin_res reg :=
  match a with
  | BR x => BR (sreg ctx x)
  | _    => BR_none
  end.

(** The initial context, used to copy the CFG of a toplevel function. *)

Definition initcontext (dpc dreg nreg: positive) (sz: Z) :=
  {| dpc := dpc;
     dreg := dreg;
     dstk := 0;
     mreg := nreg;
     mstk := Zmax sz 0;
     retinfo := None |}.

(** The context used to inline a call to another function. *)

Definition min_alignment (sz: Z) :=
  if zle sz 1 then 1
  else if zle sz 2 then 2
  else if zle sz 4 then 4 else 8.

Definition callcontext (ctx: context)
                      (dpc dreg nreg: positive) (sz: Z)
                      (retpc: node) (retreg: reg) :=
  {| dpc := dpc;
     dreg := dreg;
     dstk := align (ctx.(dstk) + ctx.(mstk)) (min_alignment sz);
     mreg := nreg;
     mstk := Zmax sz 0;
     retinfo := Some (spc ctx retpc, sreg ctx retreg) |}.

(** The context used to inline a tail call to another function. *)

Definition tailcontext (ctx: context) (dpc dreg nreg: positive) (sz: Z) :=
  {| dpc := dpc;
     dreg := dreg;
     dstk := align ctx.(dstk) (min_alignment sz);
     mreg := nreg;
     mstk := Zmax sz 0;
     retinfo := ctx.(retinfo) |}.

(** ** Recursive expansion and copying of a CFG *)

(** Insert "move" instructions to copy the arguments of an inlined
    function into its parameters. *)

Fixpoint add_moves (srcs dsts: list reg) (succ: node): mon node :=
  match srcs, dsts with
  | s1 :: sl, d1 :: dl =>
      do n <- add_instr (Iop Omove (s1 :: nil) d1 succ);
      add_moves sl dl n
  | _, _ =>
      ret succ
  end.

(** To prevent infinite inlining of a recursive function, when we
  inline the body of a function [f], this function is removed from the
  environment of inlinable functions and therefore becomes ineligible
  for inlining.  This decreases the size (number of entries) of the
  environment and guarantees termination.  Inlining is, therefore,
  presented as a well-founded recursion over the size of the environment. *)

Section EXPAND_CFG.

Variable fenv: funenv.

(** The [rec] parameter is the recursor: [rec fenv' P ctx f] copies
  the body of function [f], with inline expansion within, as governed
  by context [ctx].  It can only be called for function environments
  [fenv'] strictly smaller than the current environment [fenv]. *)

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

(** Given a register-or-symbol [ros], can we inline the corresponding call? *)

Inductive inline_decision (ros: reg + ident) : Type :=
  | Cannot_inline
  | Can_inline (id: ident) (f: function) (P: ros = inr reg id) (Q: fenv!id = Some f).

Program Definition can_inline (ros: reg + ident): inline_decision ros :=
  match ros with
  | inl r => Cannot_inline _
  | inr id => match fenv!id with Some f => Can_inline _ id f _ _ | None => Cannot_inline _ end
  end.

(** Inlining of a call to function [f].  An appropriate context is
  created, then the CFG of [f] is recursively copied, then moves
  are inserted to copy the arguments of the call to the parameters of [f]. *)

Definition inline_function (ctx: context) (id: ident) (f: function)
                           (P: PTree.get id fenv = Some f)
                           (args: list reg)
                           (retpc: node) (retreg: reg) : mon node :=
  let npc := max_pc_function f in
  let nreg := max_reg_function f in
  do dpc <- reserve_nodes npc;
  do dreg <- reserve_regs nreg;
  let ctx' := callcontext ctx dpc dreg nreg f.(fn_stacksize) retpc retreg in
  do x <- rec (PTree.remove id fenv) (PTree_Properties.cardinal_remove P) ctx' f;
  add_moves (sregs ctx args) (sregs ctx' f.(fn_params)) (spc ctx' f.(fn_entrypoint)).

(** Inlining of a tail call to function [f].  Similar to [inline_function],
  but the new context is different. *)

Definition inline_tail_function (ctx: context) (id: ident) (f: function)
                               (P: PTree.get id fenv = Some f)
                               (args: list reg): mon node :=
  let npc := max_pc_function f in
  let nreg := max_reg_function f in
  do dpc <- reserve_nodes npc;
  do dreg <- reserve_regs nreg;
  let ctx' := tailcontext ctx dpc dreg nreg f.(fn_stacksize) in
  do x <- rec (PTree.remove id fenv) (PTree_Properties.cardinal_remove P) ctx' f;
  add_moves (sregs ctx args) (sregs ctx' f.(fn_params)) (spc ctx' f.(fn_entrypoint)).

(** The instruction generated for a [Ireturn] instruction found in an
  inlined function body. *)

Definition inline_return (ctx: context) (or: option reg) (retinfo: node * reg) :=
  match retinfo, or with
  | (retpc, retreg), Some r => Iop Omove (sreg ctx r :: nil) retreg retpc
  | (retpc, retreg), None   => Inop retpc
  end.

(** Expansion and copying of an instruction.  For most instructions,
  its registers and successor PC are shifted as per the context [ctx],
  then the instruction is inserted in the final CFG at its final position
  [spc ctx pc].

  [Icall] instructions are either replaced by a "goto" to the expansion
  of the called function, or shifted as described above.

  [Itailcall] instructions are similar, with one additional case.  If
  the [Itailcall] occurs in the body of an inlined function, and
  cannot be inlined itself, it must be turned into an [Icall]
  instruction that branches to the return point of the inlined
  function.

  Finally, [Ireturn] instructions within an inlined function are
  turned into a "move" or "goto" that stores the result, if any,
  into the destination register, then branches back to the successor
  of the inlined call. *)

Definition expand_instr (ctx: context) (pc: node) (i: instruction): mon unit :=
  match i with
  | Inop s =>
      set_instr (spc ctx pc) (Inop (spc ctx s))
  | Iop op args res s =>
      set_instr (spc ctx pc)
                (Iop (sop ctx op) (sregs ctx args) (sreg ctx res) (spc ctx s))
  | Iload chunk addr args dst s =>
      set_instr (spc ctx pc)
                (Iload chunk (saddr ctx addr) (sregs ctx args) (sreg ctx dst) (spc ctx s))
  | Istore chunk addr args src s =>
      set_instr (spc ctx pc)
                (Istore chunk (saddr ctx addr) (sregs ctx args) (sreg ctx src) (spc ctx s))
  | Icall sg ros args res s =>
      match can_inline ros with
      | Cannot_inline =>
          set_instr (spc ctx pc)
                    (Icall sg (sros ctx ros) (sregs ctx args) (sreg ctx res) (spc ctx s))
      | Can_inline id f P Q =>
          do n <- inline_function ctx id f Q args s res;
          set_instr (spc ctx pc) (Inop n)
      end
  | Itailcall sg ros args =>
      match can_inline ros with
      | Cannot_inline =>
          match ctx.(retinfo) with
          | None =>
              set_instr (spc ctx pc)
                        (Itailcall sg (sros ctx ros) (sregs ctx args))
          | Some(rpc, rreg) =>
              set_instr (spc ctx pc)
                        (Icall sg (sros ctx ros) (sregs ctx args) rreg rpc)
          end
      | Can_inline id f P Q =>
          do n <- inline_tail_function ctx id f Q args;
          set_instr (spc ctx pc) (Inop n)
      end
  | Ibuiltin ef args res s =>
      set_instr (spc ctx pc)
                (Ibuiltin ef (map (sbuiltinarg ctx) args) (sbuiltinres ctx res) (spc ctx s))
  | Icond cond args s1 s2 =>
      set_instr (spc ctx pc)
                (Icond cond (sregs ctx args) (spc ctx s1) (spc ctx s2))
  | Ijumptable r tbl =>
      set_instr (spc ctx pc)
                (Ijumptable (sreg ctx r) (List.map (spc ctx) tbl))
  | Ireturn or =>
      match ctx.(retinfo) with
      | None =>
          set_instr (spc ctx pc) (Ireturn (option_map (sreg ctx) or))
      | Some rinfo =>
          set_instr (spc ctx pc) (inline_return ctx or rinfo)
      end
  end.

(** The expansion of a function [f] iteratively expands all its
  instructions, after recording how much stack it needs. *)

Definition expand_cfg_rec (ctx: context) (f: function): mon unit :=
  do x <- request_stack (ctx.(dstk) + ctx.(mstk));
  ptree_mfold (expand_instr ctx) f.(fn_code).

End EXPAND_CFG.

(** Here we "tie the knot" of the recursion, taking the fixpoint
  of [expand_cfg_rec]. *)

Definition expand_cfg := Fixm size_fenv expand_cfg_rec.

(** Start of the recursion: copy and inline function [f] in the
  initial context. *)

Definition expand_function (fenv: funenv) (f: function): mon context :=
  let npc := max_pc_function f in
  let nreg := max_reg_function f in
  do dpc <- reserve_nodes npc;
  do dreg <- reserve_regs nreg;
  let ctx := initcontext dpc dreg nreg f.(fn_stacksize) in
  do x <- expand_cfg fenv ctx f;
  ret ctx.

(** ** Inlining in functions and whole programs. *)

Local Open Scope string_scope.

(** Inlining can increase the size of the function's stack block.  We must
  make sure that the new size does not exceed [Ptrofs.max_unsigned], otherwise
  address computations within the stack would overflow and produce incorrect
  results. *)

Definition transf_function (fenv: funenv) (f: function) : Errors.res function :=
  let '(R ctx s _) := expand_function fenv f initstate in
  if zlt s.(st_stksize) Ptrofs.max_unsigned then
    OK (mkfunction f.(fn_sig)
                   (sregs ctx f.(fn_params))
                   s.(st_stksize)
                   s.(st_code)
                   (spc ctx f.(fn_entrypoint)))
  else
    Error(msg "Inlining: stack too big").

Definition transf_fundef (fenv: funenv) (fd: fundef) : Errors.res fundef :=
  AST.transf_partial_fundef (transf_function fenv) fd.

Definition transf_program (p: program): Errors.res program :=
  let fenv := funenv_program p in
  AST.transform_partial_program (transf_fundef fenv) p.


Inductive Vec (A:Set) : forall n1 n2:nat, Set :=
nil : Vec A 0 0.

Check Vec.
(*
Vec
     : Set -> nat -> nat -> Set

When we have cons, we will obviously need A_R.
We want to get rid of n1 and n2?
Why is that justified?
In the type of Vec, there is absolutely no difference between parameters and indices --
we can write another Vec of the same type where all of them are params or all
of them are indices.
Perhaps the principle is the difference between Sort and Type in the domain of Pi Type.
If so, we will not want to erase the indices_R of the following:

λ x.x : Type -> Type
the translation  is λ x1 x2 xr, xr. the input xr is crucial.

Another example below, which I dont understand.
*)

Inductive Monad  : Type -> Type :=
ret : forall T, Monad T.

(*
If we cannot erase the index here, we will be forced to keep the equalities
and implement the hard things anyway. So there is no advantage of trying
to enforce irrelevance over small type domains in function types, because
that seems ugly to implement, as discussed in this file
*)


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
Require Import ssrZ ZArith_ext seq_ext machine_int multi_int uniq_tac.
Import MachineInt.
Require Import mips_seplog mips_contrib mips_tactics mapstos.
Require Import multi_lt_prg.

Local Open Scope machine_int_scope.
Import expr_m.
Local Open Scope mips_expr_scope.
Import assert_m.
Local Open Scope mips_assert_scope.
Local Open Scope mips_cmd_scope.
Local Open Scope mips_hoare_scope.
Local Open Scope uniq_scope.
Local Open Scope multi_int_scope.

Section multi_lt.

Variables k a b i flag ret ret2 a0 a1 : reg.

Lemma multi_lt_triple : uniq(k, a, b, i, flag, ret, ret2, a0, a1, r0) ->
  forall nk A B va vb, size A = nk -> size B = nk ->
  {{ fun s h => u2Z [ k ]_s = Z_of_nat nk /\ [ a ]_s = va /\ [ b ]_s = vb /\
     (var_e a |--> A ** var_e b |--> B) s h }}
  multi_lt k a b i flag ret ret2 a0 a1
  {{ fun s h => u2Z [ k ]_s = Z_of_nat nk /\ [ a ]_s = va /\ [ b ]_s = vb /\
    (((\S_{ nk } A < \S_{ nk } B /\ [ret]_s = one32 /\ [ret2]_s = zero32) \/
      (\S_{ nk } A > \S_{ nk } B /\ [ret]_s = zero32 /\ [ret2]_s = one32) \/
      (\S_{ nk } A = \S_{ nk } B /\ [ret]_s = zero32 /\ [ret2]_s = zero32)) /\
    (var_e a |--> A ** var_e b |--> B) s h) }}.
Proof.
move=> Hset nk A B va vb HlenA HlenB.
rewrite /multi_lt.

(** addiu i k zero16 ; *)

apply hoare_addiu with (fun s h => u2Z [k]_s = Z_of_nat nk /\ [a]_s = va /\
  [b]_s = vb /\ (var_e a |--> A ** var_e b |--> B) s h /\ [i]_s = [k]_s).

move => s h [r_k [r_a [r_b Hmem]]].
rewrite /wp_addiu; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
by rewrite sext_0 addi0.

(** addiu flag r0 one16 ; *)

apply hoare_addiu with (fun s h => u2Z [k]_s = Z_of_nat nk /\ [a]_s = va /\
  [b]_s = vb /\ (var_e a |--> A ** var_e b |--> B) s h /\
  [i]_s = [k]_s /\ [flag]_s = one32).

move=> s h [r_k [r_a [r_b [Hmem r_i]]]].
rewrite /wp_addiu; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
by rewrite add0i sext_Z2u.

(** ifte (beq i r0) *)

apply while.hoare_ifte.

(** addiu ret r0 zero16 *)

apply hoare_addiu with (fun s h => u2Z [k]_s = Z_of_nat nk /\ [a]_s = va /\
  [b]_s = vb /\ (var_e a |--> A ** var_e b |--> B) s h /\
  [i]_s = [k]_s /\ [flag]_s = one32 /\ [i]_s = zero32 /\ [ret]_s = zero32).

rewrite /wp_addiu => s h [[r_k [r_a [r_b [Hmem [r_i r_flag]]]]] r_i'].
repeat Reg_upd.
have {}r_i' : [i]_s = zero32.
  move/eqP : r_i' => /= /u2Z_inj ->.
  by rewrite store.get_r0.
repeat (split; trivial).
by Assert_upd.
by rewrite sext_Z2u // addi0.

apply hoare_addiu'.
move => s h [r_k [r_a [r_b [Hmem [r_i [r_flag [r_i' r_ret]]]]]]].
rewrite /wp_addiu; repeat Reg_upd; repeat (split; trivial).
- right; right.
  rewrite -r_i r_i' Z2uK // in r_k.
  destruct nk; last by [].
  by rewrite sext_Z2u // addi0.
- by Assert_upd.

(** while (bne flag r0) ( *)

apply hoare_prop_m.hoare_while_invariant with (fun s h => u2Z [k]_s = Z_of_nat nk /\ [a]_s = va /\
  [b]_s = vb /\ (var_e a |--> A ** var_e b |--> B) s h /\
  exists ni, u2Z [i]_s = Z_of_nat ni /\
    (ni <= nk)%nat /\
    (([flag]_s <> zero32 /\ [i]_s <> zero32 /\
      \S_{ nk - ni } (drop ni A) = \S_{ nk - ni } (drop ni B)) \/
     [flag]_s = zero32 /\
     (([ret]_s = one32 /\ [ret2]_s = zero32 /\
       \S_{ nk - ni } (drop ni A) < \S_{ nk - ni } (drop ni B)) \/
      ([ret]_s = zero32 /\ [ret2]_s = one32 /\
        \S_{ nk - ni } (drop ni A) > \S_{ nk - ni } (drop ni B)) \/
      ([ret]_s = zero32 /\ [i]_s = zero32 /\ [ret2]_s = zero32 /\
       \S_{ nk - ni } (drop ni A) = \S_{ nk - ni } (drop ni B))))).

move=> s h [[r_k [r_a [r_b [Hmem [r_i r_flag]]]]] r_i'].
rewrite /= store.get_r0 Z2uK // in r_i'; move/eqP in r_i'.
repeat (split; trivial).
exists nk; split; first by rewrite r_i r_k.
split => //.
left; split.
- rewrite r_flag; exact: Z2u_dis.
- split.
  + contradict r_i'; by rewrite r_i' Z2uK.
  + by rewrite subnn.

move=> s h [ [r_k [r_a [r_b [Hmem [ni [r_i [Hnink [
  [r_flag [r_ret2 Hsum]] |
  [ r_flag [ [r_ret [r_ret2 Hsum] ] |
  [ [r_ret [r_ret2 Hsum]] |
  [gprret [r_i' [r_ret2 Hsum]]]]]]]]]]]]]] Hneq]; rewrite /= in Hneq.
- have {}Hneq : u2Z [flag]_s = u2Z zero32.
    move/negPn/eqP : Hneq.
    by rewrite store.get_r0.
  apply u2Z_inj in Hneq; contradiction.
- repeat (split; trivial).
  left; split; last by [].
  by eapply lSum_skipn; eauto.
- repeat (split; trivial).
  right; left; split; last by [].
  apply Z.lt_gt.
  apply Z.gt_lt in Hsum.
  by eapply lSum_skipn; eauto.
- repeat (split; trivial).
  right; right; split; last by [].
  have ni_O : ni = O .
    symmetry in r_i; move: r_i.
    rewrite r_i' /zero32 Z2uK //; by move/Z_of_nat_0.
  by rewrite ni_O subn0 !drop0 in Hsum.

(**  addiu i i mone16 ; *)

apply hoare_addiu with (fun s h => u2Z [k]_s = Z_of_nat nk /\ [a]_s = va /\
  [b]_s = vb /\ (var_e a |--> A ** var_e b |--> B) s h /\
  exists ni, u2Z [i]_s = Z_of_nat ni /\ (ni < nk)%nat /\
    ([flag]_s <> zero32 /\
      \S_{ nk - S ni } (drop (S ni) A) = \S_{ nk - S ni } (drop (S ni) B))).

move=> s h [ [r_k [ r_a [r_b [Hmem [ni [r_i [Hnink [
  [r_flag [r_i' Hsum] ] |
  [ r_flag [ [r_ret Hsum] |
  [ [r_ret Hsum] |
  [r_ret [r_i' Hsum]]]]]]]]]]]]] Hneq]; rewrite /= in Hneq.
- have X : (1 <= ni)%nat.
    apply/ltP/not_ge; contradict r_i'.
    apply u2Z_inj; rewrite r_i Z2uK //.
    apply le_n_0_eq in r_i'; by subst ni.
  rewrite /wp_addiu; repeat Reg_upd; repeat (split; trivial).
  + by Assert_upd.
  + exists (ni - 1)%nat; repeat (split; trivial).
    * rewrite sext_Z2s // u2Z_add_Z2s //.
      rewrite r_i inj_minus1 //; exact/leP.
      rewrite r_i.
      apply (@leZ_trans (1 + -1)); first by [].
      apply leZ_add2r.
      rewrite (_ : 1 = Z_of_nat 1) //; exact/inj_le/leP.
    * destruct ni.
      by move/leP in X; apply le_Sn_0 in X.
      by rewrite /= subn1.
    * by rewrite -subSn //= subn1.
- move/eqP: Hneq; by rewrite r_flag store.get_r0.
- move/eqP: Hneq; by rewrite r_flag store.get_r0.
- move/eqP: Hneq; by rewrite r_flag store.get_r0.

(**  lwxs a0 i a ; *)

apply hoare_lwxs_back_alt'' with (fun s h => u2Z [k]_s = Z_of_nat nk /\
  [a]_s = va /\ [b]_s = vb /\ (var_e a |--> A ** var_e b |--> B) s h /\
  exists ni, u2Z [i]_s = Z_of_nat ni /\ (ni < nk)%nat /\
    ([flag]_s <> zero32 /\
      \S_{ nk - S ni } (drop (S ni) A) = \S_{ nk - S ni } (drop (S ni) B)) /\
    [a0]_s = A `32_ ni).

move=> s h [r_k [r_a [r_b [Hmem [ni [r_i [ni_nk [r_flag Hsum]]]]]]]].
exists (A `32_ ni); split.
- Decompose_32 A ni A1 A2 HlenA1 HA'; last by rewrite HlenA.
  rewrite HA' (decompose_equiv _ _ _ _ _ HlenA1) !assert_m.conAE assert_m.conCE !assert_m.conAE in Hmem.
  move: Hmem; apply monotony => // h'.
  apply mapsto_ext => //.
  by rewrite /= shl_Z2u r_i inj_mult mulZC.
- rewrite /update_store_lwxs; repeat Reg_upd; repeat (split; trivial).
  by Assert_upd.
  by exists ni.

(**  lwxs a1 i b ; *)

apply hoare_lwxs_back_alt'' with (fun s h => u2Z [k]_s = Z_of_nat nk /\
  [a]_s = va /\ [b]_s = vb /\ (var_e a |--> A ** var_e b |--> B) s h /\
  exists ni, u2Z [i]_s = Z_of_nat ni /\ (ni < nk)%nat /\
    ([flag]_s <> zero32 /\
      \S_{ nk - S ni } (drop (S ni) A) = \S_{ nk - S ni } (drop (S ni) B)) /\
    [a0]_s = A `32_ ni /\ [a1]_s = B `32_ ni).

move=> s h [r_k [r_a [r_b [Hmem [ni [r_i [ni_nk [[r_flag Hsum] r_a0]]]]]]]].
exists (B `32_ ni); split.
- Decompose_32 B ni B1 B2 HlenB1 HB'; last by rewrite HlenB.
  rewrite HB' (decompose_equiv _ _ _ _ _ HlenB1) assert_m.conCE !assert_m.conAE assert_m.conCE !assert_m.conAE in Hmem.
  move: Hmem; apply monotony => // h'.
  apply mapsto_ext => //.
  by rewrite /= shl_Z2u r_i inj_mult mulZC.
- rewrite /update_store_lwxs; repeat Reg_upd; repeat (split; trivial).
  by Assert_upd.
  by exists ni.

(**  sltu ret a0 a1 ; *)

apply hoare_sltu with (fun s h => u2Z [k]_s = Z_of_nat nk /\ [a]_s = va /\
  [b]_s = vb /\ (var_e a |--> A ** var_e b |--> B) s h /\
  exists ni, u2Z [i]_s = Z_of_nat ni /\ (ni < nk)%nat /\
    ([flag]_s <> zero32 /\
      \S_{ nk - S ni } (drop (S ni) A) = \S_{ nk - S ni } (drop (S ni) B)) /\
    [a0]_s = A `32_ ni /\ [a1]_s = B `32_ ni /\
    (([ret]_s = one32 /\ u2Z [a0]_s < u2Z [a1]_s) \/
      ([ret]_s = zero32 /\ u2Z [a0]_s >= u2Z [a1]_s))).

move=> s h [r_k [r_a [r_b [Hmem [ni [r_i [ni_nk [[r_flag Hsum [r_a0 r_a1]]]]]]]]]].
rewrite /wp_sltu; repeat Reg_upd; repeat (split; trivial).
- by Assert_upd.
- exists ni; repeat (split; trivial).
  case: ifP; move/ltZP.
  by move=> ?; left.
  by move/Znot_lt_ge; right.

(**  movn flag r0 ret ; *)

apply hoare_movn with (fun s h => u2Z [k]_s = Z_of_nat nk /\ [a]_s = va /\
  [b]_s = vb /\ (var_e a |--> A ** var_e b |--> B) s h /\
  exists ni, u2Z [i]_s = Z_of_nat ni /\ (ni < nk)%nat /\
    (\S_{ nk - S ni } (drop (S ni) A) = \S_{ nk - S ni } (drop (S ni) B)) /\
    [a0]_s = A `32_ ni /\ [a1]_s = B `32_ ni /\
    (([ret]_s = one32 /\ [flag]_s = zero32 /\
      u2Z [a0]_s < u2Z [a1]_s) \/
     ([ret]_s = zero32 /\ [flag]_s <> zero32 /\
      u2Z [a0]_s >= u2Z [a1]_s))).

move=> s h [r_k [r_a [r_b [Hmem [ni [r_i [ni_nk [[r_flag HSum]]]]]]]] [r_a0 [r_a1 [ [X1 X2] | [X1 X2]]]]].
- rewrite /wp_movn; repeat Reg_upd; split => Hr_ret.
  + repeat (split; trivial).
    * by Assert_upd.
    * exists ni; repeat (split; trivial); by left.
  + rewrite X1 in Hr_ret.
    have {Hr_ret}: u2Z one32 = u2Z zero32 by rewrite Hr_ret.
    by rewrite ?Z2uK.
- rewrite /wp_movn; repeat Reg_upd; split => Hr_ret.
  + done.
  + repeat (split; trivial).
    exists ni; repeat (split; trivial).
    by right.

(**  sltu ret2 a1 a0 ; *)

apply hoare_sltu with (fun s h => u2Z [k]_s = Z_of_nat nk /\ [a]_s = va /\
  [b]_s = vb /\ (var_e a |--> A ** var_e b |--> B) s h /\
  exists ni, u2Z [i]_s = Z_of_nat ni /\ (ni < nk)%nat /\
    \S_{ nk - S ni } (drop (S ni) A) = \S_{ nk - S ni } (drop (S ni) B) /\
    [a0]_s = A `32_ ni /\ [a1]_s = B `32_ ni /\
    (([ret]_s = one32 /\ [ret2]_s = zero32 /\
        [flag]_s = zero32 /\ u2Z [a0]_s < u2Z [a1]_s) \/
     ([ret]_s = zero32 /\ [ret2]_s = one32 /\
        [flag]_s <> zero32 /\ u2Z [a0]_s > u2Z [a1]_s) \/
     ([ret]_s = zero32 /\ [ret2]_s = zero32 /\
        [flag]_s <> zero32 /\ u2Z [a0]_s = u2Z [a1]_s))).

move=> s h [r_k [r_a [r_b [Hmem [ni [r_i [ni_nk [Hsum [r_a0 [r_a1 [
  [r_ret [r_flag Hneq] ] |
  [r_ret [r_flag Hneq]]]]]]]]]]]]].
- rewrite /wp_sltu; repeat Reg_upd; repeat (split; trivial).
  by Assert_upd.
  exists ni; repeat (split; trivial).
  left; split; first by [].
  rewrite ifF //; apply/negbTE/ltZP; rewrite -leZNgt; exact/ltZW.
- rewrite /wp_sltu; repeat Reg_upd; repeat (split; trivial).
  by Assert_upd.
  exists ni; repeat (split; trivial).
  right.
  move/Z.ge_le : Hneq; case/leZ_eqVlt => Hneq.
  * right; repeat (split => //).
    by rewrite Hneq ltZZ'.
  * left; repeat (split; trivial).
    by move/ltZP : Hneq => ->.
    exact/Z.lt_gt.

(**  movn flag r0 ret2 ; *)

apply hoare_movn with (fun s h => u2Z [k]_s = Z_of_nat nk /\ [a]_s = va /\
  [b]_s = vb /\ (var_e a |--> A ** var_e b |--> B) s h /\
  exists ni, u2Z [i]_s = Z_of_nat ni /\ (ni < nk)%nat /\
    \S_{ nk - S ni } (drop (S ni) A) = \S_{ nk - S ni} (drop (S ni) B) /\
    [a0]_s = A `32_ ni /\ [a1]_s = B `32_ ni /\
    (([ret]_s = one32 /\ [ret2]_s = zero32 /\ [flag]_s = zero32 /\ u2Z [a0]_s < u2Z [a1]_s) \/
     ([ret]_s = zero32 /\ [ret2]_s = one32 /\ [flag]_s = zero32 /\ u2Z [a0]_s > u2Z [a1]_s) \/
     ([ret]_s = zero32 /\ [ret2]_s = zero32 /\ [flag]_s <> zero32 /\ u2Z [a0]_s = u2Z [a1]_s))).

move=> s h [r_k [r_a [r_b [Hmem [ni [r_i [ni_nk [Hsum [r_a0 [r_a1 [
[r_ret [r_ret2 [r_flag Hneq] ] ] |
[[r_ret [r_ret2 [r_flag Hneq] ] ] |
[r_ret [r_ret2 [r_flag Hneq]]]]]]]]]]]]]]].
- rewrite /wp_movn; repeat Reg_upd; split=> r_ret2'.
  + by rewrite r_ret2 in r_ret2'.
  + repeat (split; trivial).
    exists ni; repeat (split; trivial).
    by left.
- rewrite /wp_movn; repeat Reg_upd; split=> r_ret2'.
  + repeat (split; trivial).
    by Assert_upd.
    exists ni; repeat (split; trivial).
    by right; left.
  + rewrite r_ret2 in r_ret2'.
    have {r_ret2'} : u2Z one32 = u2Z zero32 by rewrite r_ret2'.
    by rewrite ?Z2uK.
- rewrite /wp_movn; repeat Reg_upd; split => r_ret2'.
  + by rewrite r_ret2 in r_ret2'.
  + repeat (split; trivial).
    exists ni; repeat (split; trivial).
    by right; right.

(**  movz flag r0 i
). *)

apply hoare_movz'.

move=> s h [r_k [r_a [r_b [Hmem [ni [r_i [Hnink [Hsum [r_a0 [r_a1 [ [r_ret [r_ret2 [r_flag Hneq]] ] |
[ [r_ret [r_ret2 [r_flag Hneq]] ] |
[r_ret [r_ret2 [r_flag Hneq] ]]]]]]]]]]]]]].
- rewrite /wp_movz; repeat Reg_upd; split => r_i'.
  + repeat (split; trivial).
    by Assert_upd.
    exists ni; repeat (split; trivial).
    by rewrite ltnW.
    right; split; first by [].
    left; split; first by [].
    have ? : ni = O.
      symmetry in r_i; move: r_i.
      rewrite r_i' Z2uK //; by move/Z_of_nat_0.
    subst ni.
    rewrite subn0 !drop0.
    destruct nk as [|nk].
    * by move: (lt_irrefl O).
    * split; first by [].
      destruct A => //; destruct B => //.
      rewrite /= subn1 /= !drop0 in Hsum.
      rewrite /nth' /= in r_a0 r_a1.
      rewrite 2!lSum_S Hsum -r_a0 -r_a1; exact/ltZ_add2r.
  + repeat (split; trivial).
    exists ni; repeat (split; trivial).
    exact/ltnW.
    right; split; first by [].
    left; split; first by [].
    destruct nk as [|nk].
    * by rewrite ltn0 in Hnink.
    * split; first by []; rewrite /= in Hsum.
      rewrite subSn; last by rewrite -ltnS.
      rewrite (drop_nth zero32); last by rewrite HlenA.
      apply Z.gt_lt.
      rewrite -/(A `32_ ni) -r_a0 lSum_S [drop _ _]/= (drop_nth zero32); last by rewrite HlenB.
      rewrite -/(B `32_ ni) [drop _ _]/= -r_a1 lSum_S Hsum; exact/Z.lt_gt/ltZ_add2r.
- rewrite /wp_movz; repeat Reg_upd; split => r_i'.
  + repeat (split; trivial).
    by Assert_upd.
    exists ni; split; first by [].
    split; first exact/ltnW.
    right; split; first by [].
    right; left; split; first by [].
    have ? : ni = O.
      symmetry in r_i; move: r_i.
      rewrite r_i' Z2uK //; by move/Z_of_nat_0.
    subst ni.
    rewrite /= subn0.
    rewrite /= in Hsum.
    destruct A.
    * rewrite -HlenA in Hnink; by rewrite lt0n in Hnink.
    * destruct B.
      - by rewrite -HlenB in Hnink; rewrite lt0n in Hnink.
      - rewrite /= in Hsum.
        destruct nk.
        + by rewrite ltnn in Hnink.
        + split; first by [].
          rewrite /= subn1 !drop0 in Hsum.
          rewrite /nth' /= in r_a0 r_a1.
          rewrite 2!lSum_S Hsum -r_a0 -r_a1; exact/Z.lt_gt/ltZ_add2r/Z.gt_lt.
  + repeat (split; trivial).
    exists ni; split; trivial.
    split; first exact/ltnW.
    right; split; first by [].
    right; left; split; first by [].
    rewrite /= in Hsum.
    destruct A.
    * rewrite -HlenA in Hnink; by rewrite ltn0 in Hnink.
    * destruct B.
      - rewrite -HlenB in Hnink; by rewrite ltn0 in Hnink.
      - split; first by [].
        rewrite /= in Hsum.
        rewrite (drop_nth zero32); last by rewrite HlenA.
        apply Z.lt_gt.
        rewrite (drop_nth zero32); last by rewrite HlenB.
        have -> : (nk - ni = S (nk - S ni))%nat by rewrite -subSn.
        simpl drop; rewrite 2!lSum_S.
        rewrite Hsum -!/(nth' _ _ _).
        rewrite -r_a0 -r_a1; exact/ltZ_add2r/Z.gt_lt.
- rewrite /wp_movz; repeat Reg_upd; split=> r_i'.
  + repeat (split; trivial).
    by Assert_upd.
    exists ni; split; trivial.
    split; first exact/ltnW.
    right; split; first by [].
    right; right; split; first by [].
    split; first by [].
    have ? : ni = O.
      rewrite r_i' Z2uK // in r_i.
      symmetry in r_i; by move/Z_of_nat_0 : r_i.
    subst ni.
    rewrite /= subn0.
    rewrite /= in Hsum.
    destruct nk => //; destruct A => //; destruct B => //.
    rewrite /= subn1 !drop0 in Hsum.
    rewrite /nth' /= in r_a0 r_a1.
    by rewrite 2!lSum_S Hsum -r_a0 -r_a1 Hneq.
  + repeat (split; trivial).
    exists ni; split; first by [].
    split; first exact/ltnW.
    left; split; first by [].
    split; first by [].
    rewrite /= in Hsum.
    destruct nk as [|nk].
    * by rewrite ltn0 in Hnink.
    * destruct A => //; destruct B => //.
      rewrite /= in Hsum.
      rewrite subSn; last by rewrite -ltnS.
      rewrite (drop_nth zero32); last by rewrite HlenA.
      symmetry.
      rewrite (drop_nth zero32); last by rewrite HlenB.
      rewrite 2!lSum_S Hsum; simpl drop.
      by rewrite -!/(nth' _ _ _) -r_a0 -r_a1 Hneq.
Qed.

End multi_lt.


Require Import Arith.
Require Import ZArith.
Require Import List.
Import ListNotations.

Require Import v1.NeutronTactics.
Require Import v1.Util.
Require Import v1.Multi.

Require Import epics.SpecTypes.
Require Import expr.Expr.

Definition abs_value := option (Z * Z).

(* calc *)
Record calc_abs : Set :=
    CalcAbs {
        calc_A_to_L : multi 12 abs_value;
        calc_VAL : abs_value
    }.

(* calc_out *)
Record calc_out_abs : Set :=
    CalcOutAbs {
        calc_out_A_to_L : multi 12 abs_value;
        calc_out_VAL : abs_value;
        calc_out_PVAL : abs_value;
        calc_out_OVAL : abs_value;
        calc_out_tmp0 : abs_value
    }.

(* str_calc_out *)
Record str_calc_out_abs : Set :=
    StrCalcOutAbs {
        str_calc_out_A_to_L : multi 12 abs_value;
        (* str_calc_out_AA_to_LL : HAVOC; *)
        str_calc_out_VAL : abs_value;
        (* str_calc_out_SVAL : HAVOC; *)
        str_calc_out_PVAL : abs_value;
        str_calc_out_OVAL : abs_value;
        (* str_calc_out_OSV : HAVOC; *)
        str_calc_out_tmp0 : abs_value
    }.

(* array_calc_out *)
Record array_calc_out_abs {n : nat} : Set :=
    ArrayCalcOutAbs {
        array_calc_out_A_to_L : multi 12 abs_value;
        (* array_calc_out_AA_to_LL : HAVOC; *)
        array_calc_out_VAL : abs_value;
        (* array_calc_out_AVAL : HAVOC; *)
        array_calc_out_PVAL : abs_value;
        array_calc_out_OVAL : abs_value;
        (* array_calc_out_OAV : HAVOC; *)
        array_calc_out_tmp0 : abs_value
    }.
Implicit Arguments array_calc_out_abs.

(* fanout *)
Record fanout_abs : Set :=
    FanoutAbs {
    }.

(* ai *)
Record analog_in_abs : Set :=
    AnalogInAbs {
        analog_in_VAL : abs_value
    }.

(* ao *)
Record analog_out_abs : Set :=
    AnalogOutAbs {
        analog_out_VAL : abs_value;
        analog_out_PVAL : abs_value
    }.

(* bi *)
Record binary_in_abs : Set :=
    BinaryInAbs {
        binary_in_VAL : abs_value
    }.

(* bo *)
Record binary_out_abs : Set :=
    BinaryOutAbs {
        binary_out_VAL : abs_value;
    }.

(* mbbo *)
Record mbbo_abs : Set :=
    MBBOAbs {
        mbbo_VAL : abs_value
    }.

(* stringin *)
Record string_in_abs : Set :=
    StringInAbs {
    }.

(* stringout *)
Record string_out_abs : Set :=
    StringOutAbs {
    }.

(* longin *)
Record long_in_abs : Set :=
    LongInAbs {
        long_in_VAL : abs_value
    }.

(* longout *)
Record long_out_abs : Set :=
    LongOutAbs {
        long_out_VAL : abs_value
    }.

(* dfanout *)
Record dfanout_abs : Set :=
    DFanoutAbs {
        dfanout_VAL : abs_value
    }.

(* seq *)
Record seq_abs : Set :=
    SeqAbs {
        seq_DO1_to_DOA : multi 10 abs_value
    }.

(* waveform *)
Record waveform_abs {ty : elem_type} {n : nat} : Set :=
    WaveformAbs {
        (* waveform_VAL : HAVOC *)
    }.
Implicit Arguments waveform_abs.

(* subarray *)
Record subarray_abs {ty : elem_type} {n m : nat} : Set :=
    SubarrayAbs {
        (* subarray_VAL : HAVOC; *)
        (* subarray_tmp0 : HAVOC *)
    }.
Implicit Arguments subarray_abs.

(* asyn *)
Record asyn_abs : Set :=
    AsynAbs {
    }.


Require Export Arith.EqNat.
Require Export Arith.Lt.
Require Export Arith.Compare_dec.
Require Export List.
Require Import String.
Open Scope string_scope.
Require Import TacticsSF.
Require Import TacticsCPDT.
Require Import Process.
Require Import List.
Require Import PrettyPrinter.
Require Import TypeAssignmentPoly.
Require Import ResultBasics.
Require Import ExampleCommon.
Require Import ExampleRecursion.

Lemma abp_recvA_Ack_procR_typing :
  forall i t (xc:free_id) (xerr2:free_id) (xout:free_id),
    ~ In xc ("recv_true" :: "recv_false" :: nil)
    ->
    ~ In xerr2 (xc :: "recv_true" :: "recv_false" :: nil)
    ->
    ~ In xout (xerr2 :: xc :: "recv_true" :: "recv_false" :: nil)
    ->
    (CTX.add (ValVariable (Var (Free xout)), TChannel (SDual (SToks t)))
      (CTX.add (ValVariable (Var (Free xc)), TChannel SEpsilon)
      (CTX.add (ValVariable (Var (Free xerr2)),
        TChannel (SDual (SAck t (token_of_bool (negb i)))))
      (CTX.add (ValName (Nm (Free ("recv_" ++ string_of_bool i))),
        TChannel (SFwd (SRecv i)))
      (CTX.add (ValName (CoNm (Free ("recv_" ++ string_of_bool i))),
        TChannel (SDual (SFwd (SRecv i))))
      (CTX.add (ValName (CoNm (Free ("recv_" ++ string_of_bool (negb i)))),
        TChannel (SDual (SFwd (SRecv (negb i)))))
      CTX.empty))))))
    |-p Var (Free xerr2) !
          Token (if if i then false else true then "true" else "false");
        (New
        (CoNm (Free (String.append "recv_" (if i then "true" else "false")))
          ! Nm (Bound 0);
        (CoNm (Bound 0) ! Var (Free xerr2);
        (CoNm (Bound 0) ! Var (Free xout);
        Zero)))).
Proof.
  intros i t xc xerr2 xout Hxc_nin Hxerr2_nin Hxout_nin.
  (* err2!(1-i); rest *)
  eapply TypPrefixOutput with
      (s:=SDual (SAck t (token_of_bool (negb i))))
      (rho:=TSingleton (token_of_bool (negb i)))
      (t:=SDual (SAck t (token_of_bool (negb i))));
    [apply trdual_w_mdual_involution; constructor; assumption
      | left; discriminate
      | constructor; [destruct i; ctx_wf; discriminate_w_list | x_in_G]
      | apply LToken; destruct i; ctx_wf; discriminate_w_list
      | right; split; [reflexivity | constructor]
      | reflexivity
      | ].
  (* recv_i(err2, out), i.e. New d *)
  apply TypNew with (s:=SRecv i)
      (L:=xc :: xerr2 :: xout :: "recv_true" :: "recv_false" :: nil);
    intros d G' H_d_nin G'def; compute; subst G'.
  (* d!"recv_i"; rest *)
  eapply TypPrefixOutput with (s:=SDual (SFwd (SRecv i)))
      (rho:=TChannel (SRecv i)) (t:=SDual (SFwd (SRecv i)));
    [apply trdual_w_mdual_involution; constructor
      | left; discriminate
      | constructor; [destruct i; ctx_wf; discriminate_w_list | x_in_G]
      | constructor; [destruct i; ctx_wf; discriminate_w_list | x_in_G]
      | left; reflexivity
      | reflexivity
      | ].
  (* d!err2; rest *)
  eapply TypPrefixOutput with (s:=SDual (SRecv i))
      (rho:=TChannel (SDual (SAck t (token_of_bool (negb i)))))
      (t:=SDual (SRecv1 i (SAck t (token_of_bool (negb i))) t));
    [apply trdual_w_mdual_involution; constructor; reflexivity
      | left; discriminate
      | constructor; [destruct i; ctx_wf; discriminate_w_list | x_in_G]
      | constructor; [destruct i; ctx_wf; discriminate_w_list | x_in_G]
      | left; reflexivity
      | reflexivity
      | ].
  (* d!out; rest *)
  eapply TypPrefixOutput with
      (s:=SDual (SRecv1 i (SAck t (token_of_bool (negb i))) t))
      (rho:=TChannel (SDual (SToks t)))
      (t:=SDual SEpsilon);
    [apply trdual_w_mdual_involution; constructor; reflexivity
      | left; discriminate
      | constructor; [destruct i; ctx_wf; discriminate_w_list | x_in_G]
      | constructor; [destruct i; ctx_wf; discriminate_w_list | x_in_G]
      | left; reflexivity
      | reflexivity
      | ].
  (* 0 *)
  apply TypZero;
    destruct i;
    ctx_wf;
    discriminate_w_list.
Qed.


Set Implicit Arguments.

Section ADTValue.

  Variable ADTValue : Type.

  Require Import Coq.Lists.List.

  Require Import Platform.Cito.WordMap.
  Import WordMap.
  Require Import Platform.Cito.WordMapFacts.
  Import FMapNotations.
  Open Scope fmap_scope.

  Require Import Platform.Cito.GeneralTactics4.

  Arguments empty {_}.

  Require Import Platform.Cito.SemanticsUtil.

  Definition make_heap' := fold_right (fun x m => @store_pair ADTValue m x) empty.

  Definition no_clash A (p1 p2 : A * Value ADTValue) :=
    match snd p1, snd p2 with
      | ADT _, ADT _ => (fst p1 <> fst p2)%type
      | _, _ => True
    end.

  Definition no_clash_ls A p := List.Forall (@no_clash A p).

  Definition not_in_heap elt w (v : Value ADTValue) (h : WordMap.t elt) :=
    match v with
      | SCA _ => True
      | ADT _ => ~ WordMap.In w h
    end.

  Require Import Coq.Setoids.Setoid.

  Add Morphism (@store_pair ADTValue) with signature Equal ==> eq ==> Equal as store_pair_Equal_m.
  Proof.
    intros st1 st2 Heq [w v].
    unfold store_pair.
    destruct v.
    eauto.
    simpl.
    rewrite Heq.
    reflexivity.
  Qed.

  Add Parametric Morphism elt : (@not_in_heap elt) with signature eq ==> eq ==> Equal ==> iff as not_in_heap_Equal_m.
  Proof.
    intros w v st1 st2 Heq.
    destruct v; simpl in *.
    intuition.
    rewrite Heq.
    intuition.
  Qed.

  Lemma store_pair_comm p1 p2 h : no_clash p1 p2 -> store_pair (store_pair h p1) p2 == store_pair (store_pair h p2) p1.
  Proof.
    intros Hnc.
    intros p.
    destruct p1 as [w1 v1].
    destruct p2 as [w2 v2].
    unfold store_pair.
    simpl.
    destruct v1 as [? | a1]; destruct v2 as [? | a2]; eauto.
    unfold no_clash in *.
    simpl in *.
    Require Import Bedrock.Word.
    destruct (weq p w2) as [? | Hne2].
    {
      subst.
      rewrite add_eq_o by eauto.
      rewrite add_neq_o by eauto.
      rewrite add_eq_o by eauto.
      eauto.
    }
    rewrite add_neq_o by eauto.
    destruct (weq p w1) as [? | Hne1].
    {
      subst.
      rewrite add_eq_o by eauto.
      rewrite add_eq_o by eauto.
      eauto.
    }
    rewrite add_neq_o by eauto.
    rewrite add_neq_o by eauto.
    rewrite add_neq_o by eauto.
    eauto.
  Qed.

  Definition DisjointPtrs A := List.ForallOrdPairs (@no_clash A).

  Require Import Bedrock.Memory.

  Definition disjoint_ptrs_ls (p : W * Value ADTValue) (pairs : list (W * Value ADTValue)):=
    match (snd p) with
      | SCA _ => True
      | ADT _ => ~ List.In (fst p) (List.map fst (List.filter (fun p => is_adt (snd p)) pairs))
    end.

  Require Import Platform.Cito.Semantics.

  Lemma disjoint_ptrs_cons_elim' pairs : forall p, disjoint_ptrs (p :: pairs) -> disjoint_ptrs_ls p pairs /\ disjoint_ptrs pairs.
  Proof.
    induction pairs; simpl; intros [w1 v1] H.
    {
      split.
      unfold disjoint_ptrs_ls; simpl.
      destruct v1; intuition.
      unfold disjoint_ptrs; simpl.
      econstructor.
    }
    destruct a as [w2 v2]; simpl in *.
    destruct v1 as [? | a1]; destruct v2 as [? | a2]; simpl in *; try solve [unfold disjoint_ptrs, disjoint_ptrs_ls in *; simpl in *; eauto].
    {
      inversion H; subst; clear H.
      split; eauto.
    }
    {
      inversion H; subst; clear H.
      split; eauto.
    }
  Qed.

  Lemma disjoint_ptrs_ls_no_clash_ls pairs : forall p, disjoint_ptrs_ls p pairs -> no_clash_ls p pairs.
  Proof.
    induction pairs; simpl; intros [w1 v1] H.
    {
      econstructor.
    }
    destruct a as [w2 v2]; simpl in *.
    destruct v1 as [? | a1]; destruct v2 as [? | a2]; simpl in *; eauto.
    {
      unfold disjoint_ptrs_ls, no_clash_ls, no_clash in *.
      econstructor.
      eauto.
      eapply Forall_forall.
      intuition.
    }
    {
      unfold disjoint_ptrs_ls, no_clash_ls, no_clash in *.
      econstructor.
      eauto.
      eapply Forall_forall.
      intuition.
    }
    {
      unfold disjoint_ptrs_ls, no_clash_ls, no_clash in *; simpl in *.
      econstructor; simpl in *.
      eauto.
      eapply (IHpairs (w1, ADT a1)); eauto.
    }
    {
      unfold disjoint_ptrs_ls, no_clash_ls, no_clash in *; simpl in *.
      intuition.
      econstructor; simpl in *.
      eauto.
      eapply (IHpairs (w1, ADT a1)); eauto.
    }
  Qed.

  Lemma disjoint_ptrs_cons_elim pairs : forall p, disjoint_ptrs (p :: pairs) -> no_clash_ls p pairs /\ disjoint_ptrs pairs.
    intros p H.
    eapply disjoint_ptrs_cons_elim' in H.
    Require Import Platform.Cito.GeneralTactics.
    openhyp.
    split; eauto.
    eapply disjoint_ptrs_ls_no_clash_ls; eauto.
  Qed.

  Lemma disjoint_ptrs_DisjointPtrs ls : disjoint_ptrs ls -> DisjointPtrs ls.
  Proof.
    induction ls; simpl; intros H.
    {
      econstructor.
    }
    eapply disjoint_ptrs_cons_elim in H.
    openhyp.
    econstructor; eauto.
    eapply IHls; eauto.
  Qed.

  Lemma no_clash_ls_not_in_heap pairs : forall w v, no_clash_ls (w, v) pairs -> not_in_heap w v (make_heap' pairs).
  Proof.
    induction pairs; simpl; intros w v H.
    {
      destruct v; simpl.
      eauto.
      intros Hin.
      eapply empty_in_iff in Hin.
      eauto.
    }
    inversion H; subst.
    destruct a as [w' v'].
    destruct v as [? | a]; simpl in *.
    { eauto. }
    unfold store_pair.
    destruct v' as [? | a']; simpl in *.
    {
      eapply IHpairs in H3.
      simpl in *.
      eauto.
    }
    unfold no_clash in H2; simpl in *.
    intros Hin.
    eapply add_in_iff in Hin.
    destruct Hin as [Hin | Hin].
    {
      subst; intuition.
    }
    eapply IHpairs in H3.
    simpl in *.
    intuition.
  Qed.

  Arguments store_pair {_} _ _.

  Lemma fold_left_store_pair_comm pairs : forall w v h1 h2, no_clash_ls (w, v) pairs -> h2 == store_pair h1 (w, v) -> fold_left store_pair pairs h2 == store_pair (fold_left store_pair pairs h1) (w, v).
  Proof.
    induction pairs; simpl; intros w v h1 h2 Hnin Hh.
    rewrite Hh; reflexivity.
    destruct a as [w' v'].
    inversion Hnin; subst.
    eapply IHpairs; eauto.
    rewrite Hh.
    rewrite store_pair_comm by eauto.
    reflexivity.
  Qed.

  Lemma make_heap_make_heap' pairs : disjoint_ptrs pairs -> make_heap pairs == make_heap' pairs.
  Proof.
    induction pairs; simpl; intros Hdisj.
    reflexivity.
    unfold make_heap in *.
    simpl.
    destruct a as [w v].
    eapply disjoint_ptrs_cons_elim in Hdisj.
    destruct Hdisj as [Hnin Hdisj].
    rewrite <- IHpairs by eauto.
    eapply fold_left_store_pair_comm; eauto.
    reflexivity.
  Qed.

  Add Morphism (@Semantics.word_adt_match ADTValue) with signature Equal ==> eq ==> iff as word_adt_match_Equal_m.
  Proof.
    intros st1 st2 Heq [w v].
    unfold Semantics.word_adt_match.
    simpl.
    destruct v.
    {
      intuition.
    }
    rewrite Heq.
    intuition.
  Qed.

  Arguments word_scalar_match {ADTValue} _.

  Lemma DisjointPtrs_good_scalars_forall_word_adt_match : forall pairs h, DisjointPtrs pairs -> List.Forall word_scalar_match pairs -> List.Forall (word_adt_match (fold_left store_pair pairs h)) pairs.
  Proof.
    induction pairs; simpl; try solve [intuition].
    intros h Hdisj H.
    inversion H; subst.
    inversion Hdisj; subst.
    destruct a as [w v]; simpl in *.
    econstructor.
    {
      rewrite fold_left_store_pair_comm; try reflexivity; trivial.
      unfold word_adt_match.
      unfold Semantics.word_adt_match.
      unfold word_scalar_match in *.
      simpl in *.
      destruct v; simpl in *; trivial.
      unfold store_pair; simpl.
      rewrite add_eq_o by eauto.
      eauto.
    }
    eapply IHpairs; eauto.
  Qed.

  Lemma disjoint_ptrs_good_scalars_good_inputs pairs :
    @disjoint_ptrs ADTValue pairs ->
    good_scalars pairs ->
    good_inputs (make_heap pairs) pairs.
  Proof.
    intros Hdisj Hgs.
    split; eauto.
    eapply DisjointPtrs_good_scalars_forall_word_adt_match; eauto.
    eapply disjoint_ptrs_DisjointPtrs; eauto.
  Qed.

  Lemma good_inputs_add addr (a : ADTValue) h : ~ In addr h -> good_inputs (add addr a h) ((addr, ADT a) :: nil).
  Proof.
    intros Hnin.
    unfold good_inputs.
    unfold Semantics.good_inputs.
    unfold Semantics.disjoint_ptrs.
    unfold Semantics.word_adt_match.
    simpl.
    split.
    - repeat econstructor; simpl.
      rewrite add_eq_o by eauto.
      eauto.
    - repeat econstructor; eauto.
  Qed.

End ADTValue.


(* En este archivo se demuestra la corrección de la acción revokeGroup *)
Require Export Exec.
Require Export Implementacion.
Require Export AuxFunsCorrect.
Require Export ListAuxFuns.
Require Import Classical.
Require Import Estado.
Require Import DefBasicas.
Require Import Semantica.
Require Import Operaciones.
Require Import ErrorManagement.
Require Import Maps.
Require Import Tacticas.
Require Import ValidStateLemmas.

Section RevokeGroup.

Lemma postRevokeGroupCorrect : forall (s:System) (a:idApp) (p:idGrp), (pre (revokePermGroup p a) s) -> validstate s -> post_revokeGroup p a s (revokegroup_post p a s).
Proof.
    intros.
    unfold post_revokeGroup.
    split. simpl; auto.
    simpl in H.
    unfold pre_revokeGroup in H;simpl in H.
    destruct H.

    split.
    destruct H.
    unfold Semantica.revokePermGroup.
    unfold revokegroup_post;unfold revokePermissionGroup;simpl.
    rewrite H.
    split;intros.
    elim (classic (a=a'));intros.
    exists x.

    split.
    rewrite<- H3.
    auto.
    intros.
    rewrite<- H3 in H2.
    rewrite <-(addAndApply idApp_eq a (remove idGrp_eq p x) (grantedPermGroups (state s))) in H2.
    inversion H2.
    rewrite<- H6 in H4.
    apply removeSthElse in H4.
    destruct H4.
    auto.

    exists lGrp'.
    split.
    rewrite overrideNotEq in H2.
    auto.
    auto.
    intros.
    auto.

    split;intros.
    elim (classic (a=a'));intros.
    exists (remove idGrp_eq p x).
    split.
    rewrite H3.
    symmetry.
    apply addAndApply.
    intros.
    split;auto.
    symmetry.
    apply (notInRemove idGrp x g' p idGrp_eq ).
    rewrite H3 in H.
    rewrite H in H2.
    inversion H2.
    auto.
    auto.

    exists lGrp.
    split.
    rewrite overrideNotEq.
    auto.
    auto.
    intros.
    contradiction.
    split.
    exists (remove idGrp_eq p x).
    split.
    symmetry.
    apply addAndApply.
    rewrite <-removeSthElse.
    unfold not;intros.
    destruct H2.
    apply H2;auto.
    apply addPreservesCorrectness.
    apply grantedPermGroupsCorrect;auto.

    split.
  - unfold revokegroup_post. unfold revokeGroupedPerms; simpl.
    assert (exists l : list Perm,
             map_apply idApp_eq (perms (state s)) a = Value idApp l).
    destructVS H0.
    destructSC statesConsistencyVS a.
    destruct H.
    destruct grantedPermGroupsSC. clear H1.
    assert (exists l : list idGrp,
        map_apply idApp_eq (grantedPermGroups (state s)) a = Value idApp l).
    exists x; auto.
    apply H2 in H1.
    apply permsSC in H1. auto.
    repeat split.
 -- intros.
    elim (classic (a=a'));intros.
    rewrite <- H3. destruct H1 as [lPerm H1].
    exists lPerm. split; auto.
    intros. unfold revokeAllPermsOfGroup in H2; rewrite H1 in H2.
    rewrite <- H3 in H2.
    rewrite <- addAndApply in H2.
    inversion H2. clear H2.
    rewrite <- H6 in H4. clear H6.
    induction (getPermsOfGroup p a s).
    simpl in H4. auto.
    simpl in H4. apply removeSthElse in H4.
    destruct H4. apply IHl. auto.

    (* Caso a <> a' *)
    exists lPerm'. destruct H1 as [lPerm H1].
    unfold revokeAllPermsOfGroup in H2. rewrite H1 in H2.
    split.
    apply (overrideNotEq idApp_eq (MyList.removeAll EqTheorems.Perm_eq (getPermsOfGroup p a s) lPerm) (perms (state s))) in H3.
    rewrite <- H3. auto.
    intros; auto.
 -- intros.
    elim (classic (a=a'));intros.
    unfold revokeAllPermsOfGroup.
    rewrite H3. clear H1. rewrite H2.
    exists (MyList.removeAll EqTheorems.Perm_eq (getPermsOfGroup p a' s) lPerm).
    split.
    rewrite <- addAndApply. auto.
    intros. split; auto.

    assert (In p' (getPermsOfGroup p a' s)).
    specialize (notInRemoveAll Perm (getPermsOfGroup p a' s) lPerm p' EqTheorems.Perm_eq H1 H4).
    intros; auto.

    apply (ifInPermsOfGroupThenSome p' p a' s).
    auto.
    exists lPerm. split.
    destruct H1.
    unfold revokeAllPermsOfGroup.
    rewrite H1.
    rewrite overrideNotEq.
    auto. auto.
    intros. contradiction.
 -- destruct H1 as [lPerm H1].
    unfold revokeAllPermsOfGroup. rewrite H1.
    exists (MyList.removeAll EqTheorems.Perm_eq (getPermsOfGroup p a s) lPerm).
    split.

    rewrite <- addAndApply. auto.
    intros. unfold not. intros.
    apply inRemoveAll in H3.
    destruct H3.

    assert (In p0 (getPermsOfGroup p a s)).
    unfold getPermsOfGroup. unfold grantedPermsForApp.
    rewrite H1. clear H1.
    induction lPerm.
    intros. inversion H3.
    simpl in *.
    destruct H3.
    rewrite <- H1 in H2. rewrite H2.
    destruct (idGrp_eq p p).
    simpl. left. auto.
    contradiction.
    apply IHlPerm in H1.
    case_eq (maybeGrp a0); intros.
    simpl. destruct (idGrp_eq p i).
    simpl. right. auto. auto. auto.

    contradiction.
 -- unfold revokeAllPermsOfGroup.
    destruct H1. rewrite H1.
    apply addPreservesCorrectness.
    apply permsCorrect;auto.

  - repeat (split;auto).
Qed.

Lemma notPreRevokeGroupThenError : forall (s:System) (a:idApp) (p:idGrp), ~(pre (revokePermGroup p a) s) -> validstate s -> exists ec : ErrorCode, response (step s (revokePermGroup p a)) = error ec /\ ErrorMsg s (revokePermGroup p a) ec /\ s = system (step s (revokePermGroup p a)).
Proof.
    intros.
    simpl.
    simpl in H.
    unfold pre_revokeGroup in H.
    exists group_wasnt_granted.
    assert (revokegroup_pre p a s=Some group_wasnt_granted).
    unfold revokegroup_pre.
    case_eq (map_apply idApp_eq (grantedPermGroups (state s)) a);intros.
    assert (InBool idGrp idGrp_eq p l=false).
    rewrite<- not_true_iff_false.
    unfold not;intros.
    apply H.
    unfold InBool in H2.
    rewrite existsb_exists in H2.
    destruct H2.
    destruct H2.
    unfold grantedPermsForApp in H2.
    destruct idGrp_eq in H3.
    exists l.
    rewrite e.
    auto.
    discriminate H3.
    rewrite H2;auto.
    auto.
    unfold revokegroup_safe.
    rewrite H1.
    simpl.
    auto.
Qed.

Lemma revokegroupIsSound : forall (s:System) (a:idApp) (p:idGrp),
        validstate s -> exec s (revokePermGroup p a) (system (step s (revokePermGroup p a))) (response (step s (revokePermGroup p a))).
Proof.
    intros.
    unfold exec.
    split.
    auto.
    elim (classic (pre (revokePermGroup p a) s));intro.
    left.
    assert(revokegroup_pre p a s = None).
    unfold revokegroup_pre.
    destruct H0.

    destruct H0.
    rewrite H0.
    assert (InBool idGrp idGrp_eq p x = true).
    unfold InBool.
    rewrite existsb_exists.
    exists p.
    split.
    auto.
    destruct idGrp_eq.
    auto.
    destruct n.
    auto.
    rewrite H2.
    auto.

    unfold step;simpl.
    unfold revokegroup_safe;simpl.
    rewrite H1;simpl.
    split;auto.
    split;auto.
    apply postRevokeGroupCorrect;auto.
    right.
    apply notPreRevokeGroupThenError;auto.

Qed.
End RevokeGroup.


From Coq Require Import Extraction.
From Coq Require Import ZArith.

Extract Inductive nat => "u64" ["0" "__nat_succ"] "__nat_elim!".
Extract Inductive positive => "u64" ["__pos_onebit" "__pos_zerobit" "1"] "__pos_elim!".
Extract Inductive N => "u64" ["0" "__N_frompos"] "__N_elim!".
Extract Inductive Z => "i64" ["0" "__Z_frompos" "__Z_fromneg"] "__Z_elim!".
Extract Inductive comparison =>
  "std::cmp::Ordering"
    ["std::cmp::Ordering::Equal"
     "std::cmp::Ordering::Less"
     "std::cmp::Ordering::Greater"].

Extract Constant BinPosDef.Pos.add => "fn ##name##(&'a self, a: u64, b: u64) -> u64 { a.checked_add(b).unwrap() }".
Extract Constant BinPosDef.Pos.succ => "fn ##name##(&'a self, a: u64) -> u64 { a.checked_add(1).unwrap() }".
Extract Constant BinPosDef.Pos.pred => "fn ##name##(&'a self, a: u64) -> u64 { a.checked_sub(1).unwrap_or(1) }".
Extract Constant BinPosDef.Pos.sub => "fn ##name##(&'a self, a: u64, b: u64) -> u64 { a.checked_sub(b).unwrap_or(1) }".
Extract Constant BinPosDef.Pos.mul => "fn ##name##(&'a self, a: u64, b: u64) -> u64 { a.checked_mul(b).unwrap() }".
Extract Constant BinPosDef.Pos.min => "fn ##name##(&'a self, a: u64, b: u64) -> u64 { std::cmp::min(a, b) }".
Extract Constant BinPosDef.Pos.max => "fn ##name##(&'a self, a: u64, b: u64) -> u64 { std::cmp::max(a, b) }".
Extract Constant BinPosDef.Pos.eqb => "fn ##name##(&'a self, a: u64, b: u64) -> bool { a == b }".
Extract Constant BinPosDef.Pos.compare =>
"fn ##name##(&'a self, a: u64, b: u64) -> std::cmp::Ordering {
  a.cmp(&b)
}".
Extract Constant BinPosDef.Pos.compare_cont =>
"fn ##name##(&'a self, cont: std::cmp::Ordering, a: u64, b: u64) -> std::cmp::Ordering {
  if a < b then
    std::cmp::Ordering::Less
  else if a == b then
    cont
  else
    std::cmp::Ordering::Greater".

Extract Constant BinNatDef.N.add => "fn ##name##(&'a self, a: u64, b: u64) -> u64 { a.checked_add(b).unwrap() }".
Extract Constant BinNatDef.N.succ => "fn ##name##(&'a self, a: u64) -> u64 { a.checked_add(1).unwrap() }".
Extract Constant BinNatDef.N.pred => "fn ##name##(&'a self, a: u64) -> u64 { a.checked_sub(1).unwrap_or(0) }".
Extract Constant BinNatDef.N.sub => "fn ##name##(&'a self, a: u64, b: u64) -> u64 { a.checked_sub(b).unwrap_or(0) }".
Extract Constant BinNatDef.N.mul => "fn ##name##(&'a self, a: u64, b: u64) -> u64 { a.checked_mul(b).unwrap() }".
Extract Constant BinNatDef.N.div => "fn ##name##(&'a self, a: u64, b: u64) -> u64 { a.checked_div(b).unwrap_or(0) }".
Extract Constant BinNatDef.N.modulo => "fn ##name##(&'a self, a: u64, b: u64) -> u64 { a.checked_rem(b).unwrap_or(a) }".
Extract Constant BinNatDef.N.min => "fn ##name##(&'a self, a: u64, b: u64) -> u64 { std::cmp::min(a, b) }".
Extract Constant BinNatDef.N.max => "fn ##name##(&'a self, a: u64, b: u64) -> u64 { std::cmp::max(a, b) }".
Extract Constant BinNatDef.N.eqb => "fn ##name##(&'a self, a: u64, b: u64) -> bool { a == b }".
Extract Constant BinNatDef.N.compare =>
"fn ##name##(&'a self, a: u64, b: u64) -> std::cmp::Ordering { a.cmp(&b) }".

Extract Constant BinIntDef.Z.add => "fn ##name##(&'a self, a: i64, b: i64) -> i64 { a.checked_add(b).unwrap() }".
Extract Constant BinIntDef.Z.succ => "fn ##name##(&'a self, a: i64) -> i64 { a.checked_add(1).unwrap() }".
Extract Constant BinIntDef.Z.pred => "fn ##name##(&'a self, a: i64) -> i64 { a.checked_sub(1).unwrap() }".
Extract Constant BinIntDef.Z.sub => "fn ##name##(&'a self, a: i64, b: i64) -> i64 { a.checked_sub(b).unwrap() }".
Extract Constant BinIntDef.Z.mul => "fn ##name##(&'a self, a: i64, b: i64) -> i64 { a.checked_mul(b).unwrap() }".
Extract Constant BinIntDef.Z.opp => "fn ##name##(&'a self, a: i64) -> i64 { a.checked_neg().unwrap() }".
Extract Constant BinIntDef.Z.min => "fn ##name##(&'a self, a: i64, b: i64) -> i64 { std::cmp::min(a, b) }".
Extract Constant BinIntDef.Z.max => "fn ##name##(&'a self, a: i64, b: i64) -> i64 { std::cmp::max(a, b) }".
Extract Constant BinIntDef.Z.eqb => "fn ##name##(&'a self, a: i64, b: i64) -> bool { a == b }".
(* TODO: div and modulo are nontrivial since Coq rounds towards negative infinity *)
(*Extract ConstanBinIntDef.t Z.div => "fn ##name##(a: i64, b: i64) -> i64 { a.checked_div(b).unwrap_or(0) }".
Extract Constant BinIntDef.Z.modulo => "fn ##name##(a: i64, b: i64) -> i64 { a.checked_rem(b).unwrap_or(a) }".*)
Extract Constant BinIntDef.Z.compare =>
"fn ##name##(&'a self, a: i64, b: i64) -> std::cmp::Ordering { a.cmp(&b) }".
Extract Constant BinIntDef.Z.of_N =>
"fn ##name##(&'a self, a: u64) -> i64 {
  use std::convert::TryFrom;
  i64::try_from(a).unwrap()
}".
Extract Constant BinIntDef.Z.abs_N => "fn ##name#(&'a self, a: i64) -> u64 { a.unsigned_abs() }".