(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Set Implicit Arguments.
Unset Strict Implicit.
Require Export Sub_sgroup.
Require Export Monoid_facts.
Section Def.
Variable G : MONOID.
Section Sub_monoid.
Variable H : subsgroup G.
Hypothesis Hunit : in_part (monoid_unit G) H.

Definition submonoid_monoid : monoid.
apply (Build_monoid (monoid_sgroup:=H)).
apply (Build_monoid_on (A:=H) (monoid_unit:=Build_subtype Hunit)).
red in |- *.
simpl in |- *.
unfold subtype_image_equal in |- *.
simpl in |- *.
auto with algebra.
red in |- *.
simpl in |- *.
unfold subtype_image_equal in |- *.
simpl in |- *.
auto with algebra.
Defined.
End Sub_monoid.

Record submonoid : Type :=
  {submonoid_subsgroup : subsgroup G;
   submonoid_prop : in_part (monoid_unit G) submonoid_subsgroup}.

Definition monoid_of_submonoid (H : submonoid) :=
  submonoid_monoid (submonoid_prop H).
End Def.
Coercion monoid_of_submonoid : submonoid >-> monoid.
Coercion submonoid_subsgroup : submonoid >-> subsgroup.
Section Injection.
Variable G : MONOID.
Variable H : submonoid G.

Lemma submonoid_in_prop : in_part (monoid_unit G) H.
apply (submonoid_prop (G:=G) H); auto with algebra.
Qed.

Definition inj_submonoid : Hom (H:MONOID) G.
apply (Build_monoid_hom (E:=H) (F:=G) (monoid_sgroup_hom:=inj_subsgroup H)).
red in |- *.
auto with algebra.
Defined.

Lemma inj_subsmonoid_injective : injective inj_submonoid.
red in |- *.
auto with algebra.
Qed.
End Injection.
Hint Resolve submonoid_in_prop inj_subsmonoid_injective: algebra.


(* Inductive mismatches *)

Module Type SA. Inductive TA : nat -> Prop := CA : nat -> TA 0. End SA.
Module MA : SA. Inductive TA : Prop := CA : bool -> TA. Fail End MA.

Module Type SA. Inductive TA := CA : nat -> TA. End SA.
Module MA : SA. Inductive TA := CA : bool -> TA. Fail End MA.

Module Type SA. Inductive TA := CA : nat -> TA. End SA.
Module MA : SA. Inductive TA := CA : bool -> nat -> TA. Fail End MA.

Module Type SA2. Inductive TA2 := CA2 : nat -> TA2. End SA2.
Module MA2 : SA2. Inductive TA2 := CA2 : nat -> TA2 | DA2 : TA2. Fail End MA2.

Module Type SA3. Inductive TA3 := CA3 : nat -> TA3. End SA3.
Module MA3 : SA3. Inductive TA3 := CA3 : nat -> TA3 with UA3 := DA3. Fail End MA3.

Module Type SA4. Inductive TA4 := CA4 : nat -> TA4 with UA4 := DA4. End SA4.
Module MA4 : SA4. Inductive TA4 := CA4 : nat -> TA4 with VA4 := DA4. Fail End MA4.

Module Type SA5. Inductive TA5 := CA5 : nat -> TA5 with UA5 := DA5. End SA5.
Module MA5 : SA5. Inductive TA5 := CA5 : nat -> TA5 with UA5 := EA5. Fail End MA5.

Module Type SA6. Inductive TA6 (A:Type) := CA6 : A -> TA6 A. End SA6.
Module MA6 : SA6. Inductive TA6 (A B:Type):= CA6 : A -> TA6 A B. Fail End MA6.

Module Type SA7. Inductive TA7 (A:Type) := CA7 : A -> TA7 A. End SA7.
Module MA7 : SA7. CoInductive TA7 (A:Type):= CA7 : A -> TA7 A. Fail End MA7.

Module Type SA8. CoInductive TA8 (A:Type) := CA8 : A -> TA8 A. End SA8.
Module MA8 : SA8. Inductive TA8 (A:Type):= CA8 : A -> TA8 A. Fail End MA8.

Module Type SA9. Record TA9 (A:Type) := { CA9 : A }. End SA9.
Module MA9 : SA9. Inductive TA9 (A:Type):= CA9 : A -> TA9 A. Fail End MA9.

Module Type SA10. Inductive TA10 (A:Type) := CA10 : A -> TA10 A. End SA10.
Module MA10 : SA10. Record TA10 (A:Type):= { CA10 : A }. Fail End MA10.

Module Type SA11. Record TA11 (A:Type):= { CA11 : A }. End SA11.
Module MA11 : SA11. Record TA11 (A:Type):= { DA11 : A }. Fail End MA11.

(* Basic mismatches *)
Module Type SB. Inductive TB := CB : nat -> TB. End SB.
Module MB : SB. Module Type TB. End TB. Fail End MB.

Module Type SC. Module Type TC. End TC. End SC.
Module MC : SC. Inductive TC := CC : nat -> TC. Fail End MC.

Module Type SD. Module TD. End TD. End SD.
Module MD : SD. Inductive TD := DD : nat -> TD. Fail End MD.

Module Type SE. Definition DE := nat. End SE.
Module ME : SE. Definition DE := bool. Fail End ME.

Module Type SF. Parameter DF : nat. End SF.
Module MF : SF. Definition DF := bool. Fail End MF.

(* Needs a type constraint in module type *)
Module Type SG. Definition DG := Type. End SG.
Module MG : SG. Definition DG := Type : Type. Fail End MG.

(* Should work *)
Module Type SA7. Inductive TA7 (A:Type) := CA7 : A -> TA7 A. End SA7.
Module MA7 : SA7. Inductive TA7 (B:Type):= CA7 : B -> TA7 B. End MA7.

Module Type SA11. Record TA11 (B:Type):= { CA11 : B }. End SA11.
Module MA11 : SA11. Record TA11 (A:Type):= { CA11 : A }. End MA11.

Module Type SE. Parameter DE : Type. End SE.
Module ME : SE. Definition DE := Type : Type. End ME.


(**************************  uc/OS-II  *******************************)
(*************************** OS_CORE.C *******************************)
(*Proof of Internal Fucntion:  BOOLEAN OS_EventSearch (OS_EVETN* pevent)*)
(****************************  Code:   *******************************)
(***
int OS_EventSearch (OS_EVENT *pevent)
{
     OS_EVENT *p, *p1;
     int x;

1    p = OSEventList;
2    x = 0;
3    while (p != (OS_EVENT* )0 && x == 0)
     {
4        p1 = p -> OSEventListPtr;
5        if(p != pevent)
         {
6          p = p1
         }
         else
         {
7          x = 1
         }
     };
8    return x;
}
 ***)
Require Import ucos_include.
Require Import symbolic_lemmas.
Require Import OSESearchPure.

Open Scope code_scope.
Open Scope Z_scope.
Open Scope int_scope.
Open Scope list_scope.

Lemma OSEventSearch_proof:
  forall vl p r logicl tid,
    Some p =
    BuildPreI os_internal OS_EventSearch vl logicl OS_EventSearchPre tid ->
    Some r =
    BuildRetI os_internal OS_EventSearch vl logicl OS_EventSearchPost tid ->
    exists t d1 d2 s,
      os_internal OS_EventSearch = Some (t, d1, d2, s) /\
      {| OS_spec, GetHPrio, OSLInv, I, r, Afalse |} |-tid {{p}} s {{Afalse}}.
Proof.
  init_spec.

  (*L1: p = OSEventList *)
  hoare unfold.
  hoare forward.
  pauto.

  (*L2: x = 0 *)
  hoare forward.

  (*L3: while (p != (OS_EVENT* )0 && x == 0 *)
  (*1: remember irrelevant sep-conjunctions*)
  hoare remember (1::2::3::5::19::20::nil)%nat pre.

  (*2: get the while loop inv into the pre-condition,
    so the pre-condition after the while statement
    can be correctly instantiated
   *)

  apply backward_rule1 with (p := (*below is the loop inv*)
   (
     (EX v v1 ectrl1 ectrl2 msgqls1 msgqls2 mqls1 mqls2,
      <|| v'16 ||> **
          LV x @ Int8u |-> (V$0) **
          LV p @ os_ucos_h.OS_EVENT ∗ |-> v **
          LV p1 @ os_ucos_h.OS_EVENT ∗ |-> v1 **
          LV pevent @ os_ucos_h.OS_EVENT ∗ |-> Vptr v'14 **
          evsllseg v'17 v ectrl1 msgqls1 ** evsllseg v Vnull ectrl2 msgqls2 **
          [|v'3 = ectrl1 ++ ectrl2|] **
          [|v'2 = msgqls1 ++ msgqls2|] **
          [|ECBList_P v'17 v ectrl1 msgqls1 mqls1 v'13|] **
          [|ECBList_P v Vnull ectrl2 msgqls2 mqls2 v'13|] **
          [|EcbMod.join mqls1 mqls2 v'12|] **
          [|EcbMod.get mqls1 v'14 = None |] ** H0)
       \\//
       (EX vn v1 ectrl1 ectrl2 msgqls1 msgqls2 osevent etbl mqls1 mqls' mqls2 mq msgq,
        <|| v'16 ||> **
            LV x @ Int8u |-> (V$1) **
            LV p @ os_ucos_h.OS_EVENT ∗ |-> (Vptr v'14) **
            LV p1 @ os_ucos_h.OS_EVENT ∗ |-> v1 **
            LV pevent @ os_ucos_h.OS_EVENT ∗ |-> Vptr v'14 **
            evsllseg v'17 (Vptr v'14) ectrl1 msgqls1 **
            evsllseg vn Vnull ectrl2 msgqls2 **
            [|V_OSEventListPtr osevent = Some vn|] **
            AEventNode (Vptr v'14) osevent etbl msgq **
            [|ECBList_P v'17 (Vptr v'14) ectrl1 msgqls1 mqls1 v'13|] **
            [|ECBList_P vn Vnull ectrl2 msgqls2 mqls2 v'13|] **
            [|RLH_ECBData_P msgq mq|] **
            [|v'3 = ectrl1 ++ ((osevent, etbl) :: nil) ++ ectrl2|] **
            [|v'2 = msgqls1 ++ (msgq :: nil) ++ msgqls2|] **
            [|length ectrl1 = length msgqls1|] **
            [|R_ECB_ETbl_P v'14 (osevent, etbl) v'13|] **
            [|EcbMod.joinsig v'14 mq mqls2 mqls' /\ EcbMod.join mqls1 mqls' v'12|] **
            H0)
   )
                            ).
  intros.
  left.
  exists v'17 v'1 (nil : (list EventCtr)) v'3 (nil : (list EventData)) v'2.
  exists EcbMod.emp v'12.
  unfold evsllseg at 1.
  unfold ECBList_P at 1.
  sep pauto.
  apply EcbMod.join_emp; auto.
  (*end 2*)

  (*3: apply the 'seq_rule' to get the while statement
    off the remaining statements, then apply the 'while_rule'
   *)
  eapply seq_rule.
  eapply while_rule with (tp := Int32u).

  (*4: prove the condition expression of while is legal *)
  intros.
  destruct H3. (*2 cases*)
  (*case 1*)
  do 8 destruct H3.
  sep lift 7%nat in H3.
  pose proof evsllseg_isptr H3.
  symbolic_execution.
  pauto.
  destruct x; simpl; intro; tryfalse;
  try (unfolds in H6; destruct H6; [tryfalse | destruct H6; tryfalse]).
  destruct a; simpl in H0; tryfalse.

  destruct x;
    try solve [simpl; unfolds in H6; destruct H6; [tryfalse | destruct H0; tryfalse]].
  simpl; intro; tryfalse.
  simpl; destruct a; simpl; intro; tryfalse.

  rewrite Int.eq_true.
(*  simpl; intro; tryfalse.

  rewrite Int.eq_true. *)
  destruct x;
    try solve [simpl; unfolds in H6; destruct H6; [tryfalse | destruct H0; tryfalse]].
  simpl.
  destruct (Int.ltu Int.zero (Int.notbool Int.one) && Int.ltu Int.zero Int.one); simpl; intro; tryfalse.
  simpl; destruct a; simpl.
  destruct (Int.ltu Int.zero (Int.notbool Int.zero) && Int.ltu Int.zero Int.one); simpl; intro; tryfalse.

  (*case 2*)
  do 13 destruct H3.
  sep lift 7%nat in H3.
  pose proof evsllseg_isptr H3.
  destruct v'14.
  symbolic_execution; pure_auto.

  (*5: the cond-expr of while hold implies the left part
    of the loop-inv*)
  apply backward_rule1 with ( p:= (
    (EX v v1 (ectrl1 ectrl2 : list EventCtr)
        (msgqls1 msgqls2 : list EventData) (mqls1 mqls2 : EcbMod.map),
     <|| v'16 ||> **
         LV x @ Int8u |-> (V$0) **
         LV p @ os_ucos_h.OS_EVENT ∗ |-> (Vptr v) **
         LV p1 @ os_ucos_h.OS_EVENT ∗ |-> v1 **
         LV pevent @ os_ucos_h.OS_EVENT ∗ |-> Vptr v'14 **
         evsllseg v'17 (Vptr v) ectrl1 msgqls1 **
         evsllseg (Vptr v) Vnull ectrl2 msgqls2 **
         [|v'3 = ectrl1 ++ ectrl2|] **
         [|v'2 = msgqls1 ++ msgqls2|] **
         [|ECBList_P v'17 (Vptr v) ectrl1 msgqls1 mqls1 v'13|] **
         [|ECBList_P (Vptr v) Vnull ectrl2 msgqls2 mqls2 v'13|] **
         [|EcbMod.join mqls1 mqls2 v'12|] ** [|EcbMod.get mqls1 v'14 = None|]
         ** H0)
                                 )).
  intros.
  destruct H3.
  destruct H3. (*2 cases*)
  (*case 1*)
  do 8 destruct H3.
  assert (exists v, x = Vptr v).
  sep lift 7%nat in H3.
  pose proof evsllseg_isptr H3.
  sep remember (3::4::nil)%nat in H3.
  clear - H3 H6 H7.
  destruct_s s.
  simpl in H3; simpljoin1.
  simpl in H6.
  rewrite H25 in H6.
  rewrite H16 in H6.
  unfold uop_type in H6.
  unfold cmp_int_type in H6.
  unfold bop_int_type in H6.
  destruct x; try solve [simpl; unfolds in H7; destruct H7; [tryfalse | destruct H; tryfalse]].
  simp join.
  destruct (load os_ucos_h.OS_EVENT ∗ m (x26, 0)) eqn : eq1; tryfalse.
  destruct (val_eq v Vnull) eqn : eq2; tryfalse.
  destruct (notint v0) eqn : eq3; tryfalse.
  destruct (load Int8u m (x27, 0)); tryfalse.
  destruct (val_eq v2 (V$0)); tryfalse.

  intros.
  pose proof bool_and_true_1 H1 H.
  simp join.
  unfolds in eq3.
  destruct v0; tryfalse.
  inverts eq3.

  pose proof ltu_zero_notbool_true H3.

  pose proof val_eq_zero_neq eq2 H2.
  replace (Int.unsigned Int.zero) with 0 in H17.
  assert (load os_ucos_h.OS_EVENT ∗ x6 (x26, 0) = Some Vnull).
  eapply mapstoval_load; eauto.

(* ** ac:   Print addr. *)
  pose proof load_mono (os_ucos_h.OS_EVENT ∗) (x26,0)%Z H5 H6.
  apply join_comm in H0.
  rewrite H6 in H9.
  pose proof load_mono (os_ucos_h.OS_EVENT ∗) (x26,0)%Z H0 H9.
  rewrite eq1 in H10.
  rewrite H9 in H10.
  inverts H10.
  tryfalse.
  rewrite Int.unsigned_zero; auto.
  eauto.
  destruct H7.
  substs.
  do 8 eexists.
  sep auto.

  (*case 2*)
  do 13 destruct H3.
  sep remember (2::3::nil)%nat in H3.
  destruct_s s.
  simpl in H3; simpljoin1.
  simpl in H6.
  rewrite H21, H30 in H6.
  unfold uop_type in H6.
  unfold cmp_int_type in H6.
  unfold bop_int_type in H6.
  destruct (load os_ucos_h.OS_EVENT ∗ m (x38, 0)).
  destruct (load Int8u m (x39, 0)) eqn : eq1.
  destruct (val_eq v0 (V$0)) eqn : eq2.
  destruct (val_eq v Vnull).
  destruct (notint v2).
  simpljoin1.

  pose proof bool_and_true_gt H0 H3.
  simpljoin1.
  clear H9 H0.

  apply mapstoval_load in H31; auto.
  pose proof (load_mono Int8u (x39, Int.unsigned Int.zero) H8 H31).
  rewrite H31 in H0.
  rewrite Int.unsigned_zero in H0.
  rewrite eq1 in H0.
  inverts H0.
  simpl in eq2.
  rewrite Int.eq_false in eq2.
  inverts eq2.
  apply Int.ltu_inv in H10; omega.
  intro; tryfalse.

  simpljoin1; tryfalse.
  simpljoin1; tryfalse.
  destruct (val_eq v Vnull); simpljoin1; tryfalse.
  destruct (notint v1); simpljoin1; tryfalse.
  destruct (val_eq v Vnull); simpljoin1; tryfalse.
  destruct (notint v0); simpljoin1; tryfalse.
  simpljoin1; tryfalse.

  (*L4: p1 = p -> OSEventListPtr *)
  (* extract the node which p points to*)
  hoare_ex_intro.
  destruct v'21.
  simpl evsllseg at 5.
  hoare_split_pure_all; simpljoin1.
  inversion H3.
  destruct v'23.
  simpl evsllseg at 5.

  Ltac solve_Afalse_in_pre :=
    eapply backward_rule1 with (p:=Afalse);
    [intros s_1 H_1; destruct_s s_1; simpl in H_1; simpljoin1; tryfalse |
     apply pfalse_rule].
  solve_Afalse_in_pre.

  unfold evsllseg at 5; fold evsllseg.

  destruct e.
  unfold AEventNode at 1.
(*  destruct e0. *)
  pure intro.
  unfold AOSEvent at 2; unfold node.
  pure intro.
  hoare forward; pure_auto.

  (*L5: if(p != pevent)*)
  hoare normal pre; hoare_ex_intro.
  eapply forward_rule2.
  eapply if_rule2'.
  symbolic_execution.
  destruct v'14.
  destruct (peq v'27 b).
  destruct (Int.eq Int.zero i2); simpl; intro; tryfalse.
  simpl; intro; tryfalse.
  destruct v'14.
  destruct (peq v'27 b).
  destruct (Int.eq Int.zero i2); simpl; auto.
  simpl; intro; tryfalse.
(*  simpl; intro; tryfalse.
  simpl; intro; tryfalse.*)

  (*L6: p=p1*)
  hoare_split_pure_all.
  hoare forward.
  pauto.

  (*L7: x=1*)
  hoare_split_pure_all.
  hoare forward.

  (*prove the loop inv hold after the if statement*)
  intros.
  destruct H0.
  left.
(*  simpl AEventData in H0. *)
  sep split in H0.
(*
  unfolds in H5; simpl in H5; inverts H5.
  unfolds in H7; simpl in H7; inverts H7.
*)

  (*if true, p=p1*)
  exists v'26 v'26
         (v'20 ++ (Vint32 i0 :: Vint32 i :: Vint32 i1 :: x2 :: x3 :: v'26 :: nil, v0)::nil) v'21 (v'22 ++ e0::nil).
  exists v'23.
  unfold ECBList_P in H9; fold ECBList_P in H9; simpljoin1.
  unfolds in H27; simpl in H27; inverts H27; inverts H9.
  exists (EcbMod.merge v'24 (EcbMod.sig (v'27, Int.zero) x0)) x1.
(*   sep split in H0.
  mytac. *)

  (*prove (v'28, Int.zero) <> (b, i2)*)
  destruct v'14.
  assert ((v'27, Int.zero) <> (b, i2)).
  destruct (peq v'27 b) eqn : eq1.
  destruct (Int.eq Int.zero i2) eqn : eq2.
  simpl in H3.
  unfold Int.notbool in H3.
  rewrite Int.eq_false in H3.
  tryfalse.
  auto.
  intro.
  inversion H7.
  rewrite H31 in eq2.
  rewrite Int.eq_true in eq2; tryfalse.
  pose proof peq v'27 b.
  destruct H7; tryfalse.
  intro.
  inversion H7.
  rewrite H27 in n0.
  tryfalse.
  clear H3 H24 H25.
  sep split; auto.
  (*end*)

  sep pauto.
  sep lift 4%nat in H0.
  eapply evsllseg_append; eauto.
  pauto.

  rewrite EcbMod.merge_sem.
  rewrite H11.

  rewrite EcbMod.get_sig_none; auto.

  clear - H10 H28.
  eapply EcbMod.join_shift_l; eauto.

  sep remember (3::9::nil)%nat in H0.
  clear - H8 H29 H0 H28 H26.
  eapply ECBList_P_append; eauto.
  unfold TcbJoin in H28.
  unfold join, sig in H28; simpl in H28.
  eauto.

  apply list_cons_assoc.
  apply list_cons_assoc.

  (*if false, x=1*)
  right.

  (*prove (v'28, Int.zero) = (b, i0)*)
  (*line: a*)sep split in H0.  (*problem here: all the pure assertions are split out*)
  destruct v'14.
  assert ((v'27, Int.zero) = (b, i2)).
  clear - H3.
  destruct (peq v'27 b) eqn : eq1.
  destruct (Int.eq Int.zero i2) eqn : eq2.
  simpl in H3.
  unfold Int.notbool in H3.
  rewrite Int.eq_false in H3.
  pose proof Int.eq_spec Int.zero i2.
  rewrite eq2 in H.
  destruct H3; tryfalse.
  substs; auto.
  intro; tryfalse.
  simpl in H3.
  unfold Int.notbool in H3.
  rewrite Int.eq_true in H3.
  destruct H3; tryfalse.
  simpl in H3.
  unfold Int.notbool in H3.
  rewrite Int.eq_true in H3.
  destruct H3; tryfalse.
  clear H3.
  inversion H24; substs; clear H24.
  (*end*)

  unfold ECBList_P in H9; fold ECBList_P in H9.
  simpljoin1.
  (*have to manually instantiate the EX variables.
  can not use 'sep pauto' first because some of the register assertions split into the context at line:a are not easy to apply when 'sep auto' has changed 's'*)
  unfold V_OSEventListPtr in H9; simpl in H9; inverts H9.
  destruct x; inverts H3.
  exists x4 x4 v'20 v'21 v'22 v'23.
  exists (Vint32 i0 :: Vint32 i :: Vint32 i1 :: x2 :: x3 :: x4 :: nil)
         v0 v'24 v'25 x1 x0.
  exists e0.
  sep split; auto.
  sep pauto.
  unfold AEventNode.
  unfold AOSEvent.
  unfold node.
  sep pauto; eauto.
  split; pauto.

  sep remember (9::nil)%nat in H0.
  eapply evsllseg_list_len_eq; eauto.

  (*L8:  return x*)
  apply disj_conj_distrib_pre.
  apply disj_rule.

  (*the right case, return 1*)
  eapply rete_rule' with (t := Int8u); intros.
  (*s|= LV x @ Int8u |-> (V$0) ** P -> s |= Rv x' @ Int8u == (V$0)*)
  instantiate (1:=(V$0)).

  destruct H3.
  symbolic_execution.

  pauto.
  substs.
  destruct H3.
  do 8 destruct H0.
  assert (x = Vnull).
  sep lift 7%nat in H0.
  pose proof evsllseg_isptr H0.
  sep remember (3::4::nil)%nat in H0.
  clear - H0 H3 H6.
  destruct_s s; simpl in H0; simpljoin1.
  simpl in H3.
  rewrite H25 in H3.
  rewrite H16 in H3.
  unfold uop_type in H3.
  unfold cmp_int_type in H3.
  unfold bop_int_type in H3.
  destruct (load Int8u m (x27, 0)) eqn : eq1.
  replace (Int.unsigned Int.zero) with 0 in *.
  apply mapstoval_load in H26.
  pose proof load_mono Int8u (x27, 0) H0 H26.
  rewrite eq1 in H.
  rewrite H26 in H.
  inverts H.
  unfold val_eq at 2 in H3.
  rewrite Int.eq_true in H3.
  simpljoin1.
  destruct (load os_ucos_h.OS_EVENT ∗ m (x26, 0)) eqn : eq2; tryfalse.
  destruct (val_eq v Vnull) eqn : eq3; tryfalse.
  destruct (notint v0) eqn: eq4; tryfalse.
  unfolds in H.
  destruct v1; tryfalse.
  destruct (Int.ltu Int.zero i2 && Int.ltu Int.zero Int.one) eqn : eq5.
  inverts H.
  simpl in H1.
  rewrite Int.eq_false in H1.
  tryfalse.
  intro; tryfalse.
  inverts H.
  assert(Int.ltu Int.zero Int.one = true).
  unfolds.
  apply zlt_true.
  rewrite Int.unsigned_zero; rewrite Int.unsigned_one.
  omega.
  rewrite H in eq5.
  rewrite andb_false_iff in eq5.
  destruct eq5; tryfalse.
  unfolds in eq3.
  destruct v; tryfalse.
  apply mapstoval_load in H17.
  pose proof load_mono (os_ucos_h.OS_EVENT ∗) (x26, 0) H8 H17.
  rewrite H17 in H3.
  apply join_comm in H0.
  pose proof load_mono (os_ucos_h.OS_EVENT ∗) (x26, 0) H0 H3.
  rewrite H3 in H4.
  rewrite eq2 in H4.
  inverts H4; auto.
  simpl.
  pauto.
  destruct a0.
  inverts eq3.
  unfolds in eq4.
  unfold Int.notbool in eq4.
  rewrite Int.eq_true in eq4.
  inverts eq4.
  rewrite H in H2; tryfalse.
  auto.
  rewrite Int.unsigned_zero; auto.
  simpljoin1.
  destruct (load os_ucos_h.OS_EVENT ∗ m (x26, 0) ); tryfalse.
  destruct (val_eq v Vnull); tryfalse.
  destruct (notint v0); tryfalse.
  substs.

  sep lift 7%nat.
  (*  sep lift 8%nat.*)
  sep cancel 28%nat 1%nat.
(*  sep lift 25%nat in H0. (*can not cancel A_dom_env assertion, ?*)*)
  sep normal.
  exists (Vptr v'14) Vnull (V$0) x0.
  sep pauto.
(*  rename s' into s1. *)
(*  sep cancel 1%nat 1%nat.*)
  right.
  sep pauto.
  sep cancel 1%nat 10%nat.
  do 4 sep cancel 3%nat 2%nat.
  do 3 sep cancel 3%nat 2%nat.

  instantiate (4 := (x1 ++ x2)).
  instantiate (3 := (x3 ++ x4)).
  instantiate (2 := v'4).
  instantiate (1 := v'15).
  apply ECBList_P_nil in H10; simpljoin1.
  unfold evsllseg at 2 in H0.
  sep split in H0.
  do 2 rewrite app_nil_r.
  auto.
  auto.
  split; auto.

  apply ECBList_P_nil in H10; simpljoin1.
  apply EcbMod.join_comm in H11.
  apply EcbMod.join_emp_eq in H11.
  substs; auto.
  auto.

  (*the left case, return 0*)
  eapply rete_rule' with (t := Int8u); intros.
  instantiate (1 := (V$1)).

  destruct H3.
  symbolic_execution.

  destruct H3.
  do 13 destruct H3.
  unfold AEventNode in H3.
  sep pauto.
  clear H6.
  sep pauto.

  sep cancel 20%nat 2%nat.
(*  sep cancel 1%nat 2%nat. *)
  left.

  do 27 eexists.
  sep auto; pauto.
Qed.


(* (c) Copyright 2006-2018 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat seq.
From fourcolor Require Import cfmap cfreducible configurations.

(******************************************************************************)
(* Reducibility of configurations number 190 to 206, whose indices in         *)
(* the_configs range over segment [189, 206).                                 *)
(******************************************************************************)

Lemma red189to206 : reducible_in_range 189 206 the_configs.
Proof. CheckReducible. Qed.


Require Import Coqlib.
Require Import Asm.
Require Import PeekTactics.
Require Import PeepsLib.
Require Import PregTactics.
Require Import StepIn.
Require Import AsmBits.
Require Import Values.
Require Import ValEq.
Require Import Integers.
Require Import PeepsTactics.

Definition peep_test_vec_add_example := Paddd_ff XMM0 XMM0 :: nil.

Section TEST_VEC_ADD.

  Variable concrete : code.
  Variable r1 : freg.
  Variable r2 : freg.

  Definition make_bfreg (f : freg) : bfreg :=
    match f with
      | XMM0 => xmm0
      | XMM1 => xmm1
      | XMM2 => xmm2
      | XMM3 => xmm3
      | XMM4 => xmm4
      | XMM5 => xmm5
      | XMM6 => xmm6
      | XMM7 => xmm7
    end.

  Definition get_high_reg (b : bfreg) : hfreg :=
    let (_,h) := split_big_freg b in h.

  Definition br1 := make_bfreg r1.
  Definition br2 := make_bfreg r2.
  Definition hr1 := get_high_reg br1.
  Definition hr2 := get_high_reg br2.

  Definition peep_test_vec_add_defs : rewrite_defs :=
    {|
      fnd :=
        Paddd_ff r1 r2 :: nil
      ; rpl :=
          Paddpd_ff (make_bfreg r1) (make_bfreg r2) :: nil
      ; lv_in := FR r1 :: FR r2 :: PC :: nil
      ; lv_out := FR r1 :: PC :: nil
      ; clobbered := FRH hr1 :: FRH hr2 :: nil
    |}.

  Lemma peep_test_vec_add_selr :
    StepEquiv.step_through_equiv_live (fnd peep_test_vec_add_defs) (rpl peep_test_vec_add_defs) (lv_in peep_test_vec_add_defs) (lv_out peep_test_vec_add_defs).
  Proof.
    admit.
    (* prep_l. *)
    (* step_l. *)
    (* prep_r. *)
    (* step_r. *)
    (* finish_r. *)
    (* split. *)
  Qed.

  Definition peep_test_vec_add_proofs : rewrite_proofs :=
    {|
      defs := peep_test_vec_add_defs
      ; selr := peep_test_vec_add_selr
    |}.

  Definition peep_test_vec_add :
    concrete = fnd peep_test_vec_add_defs ->
    StepEquiv.rewrite.
  Proof.
    intros.
    peep_tac_mk_rewrite peep_test_vec_add_defs peep_test_vec_add_proofs.
    admit. (* idk, tactic didn't work *)
  Qed.

End TEST_VEC_ADD.

Definition peep_test_vec_add_rewrite (c : code) : option StepEquiv.rewrite.
  name peep_test_vec_add p.
  unfold peep_test_vec_add_defs in p.
  simpl in p.
  specialize (p c).
  set_code_cons c.
  set_code_nil c.
  set_instr_eq i 0%nat peep_test_vec_add_example.
  specialize (p rd r1 eq_refl). exact (Some p).
Defined.

Definition test_vec_add (c : code) : list StepEquiv.rewrite :=
  collect (map peep_test_vec_add_rewrite (ParamSplit.matched_pat peep_test_vec_add_example c)).


Require Import Coq.Classes.Morphisms Coq.Relations.Relation_Definitions.

Set Implicit Arguments.

Scheme Minimality for option Sort Type.
Scheme Minimality for option Sort Set.
Scheme Minimality for option Sort Prop.

Lemma fold_option_rect {A B} (S : forall a : A, B (Some a)) (N : B None) (v : option A)
  : match v return B v with
    | Some x => S x
    | None => N
    end = option_rect B S N v.
Proof.
  reflexivity.
Qed.
Lemma fold_option_rect_nd {A B} (S : A -> B) (N : B) (v : option A)
  : match v return B with
    | Some x => S x
    | None => N
    end = option_rect (fun _ => B) S N v.
Proof.
  reflexivity.
Qed.

Global Instance option_rect_Proper_nd_forall {A B}
  : Proper (pointwise_relation _ eq ==> eq ==> forall_relation (fun _ => eq))
           (@option_rect A (fun _ => B)).
Proof.
  intros ?????? [?|]; subst; simpl; eauto.
Qed.
Lemma fold_option_rect_nodep {A B} (S : A -> B) (N : B) (v : option A)
  : match v return B with
    | Some x => S x
    | None => N
    end = option_rect_nodep S N v.
Proof.
  reflexivity.
Qed.

Lemma option_map_None A B (f : A -> B) x
: option_map f x = None <-> x = None.
Proof.
  destruct x; simpl; split; intros; trivial; congruence.
Qed.

Global Instance option_rect_Proper_nondep {A B}
: Proper (pointwise_relation _ eq ==> eq ==> eq ==> eq)
         (@option_rect A (fun _ => B)).
Proof.
  repeat (intros [] || intro); simpl; eauto.
Qed.

Global Instance option_rect_Proper {A B}
: Proper (forall_relation (fun _ => eq) ==> eq ==> forall_relation (fun _ => eq))
         (@option_rect A B).
Proof.
  repeat (intros [] || intro); simpl; eauto.
Qed.

Lemma option_rect_Proper_nondep_eq {A B} {S S' : A -> B} {N N' v}
      (HS : forall vv, v = Some vv -> S vv = S' vv)
      (Hn : v = None -> N = N')
: option_rect (fun _ : option A => B) S N v
  = option_rect (fun _ : option A => B) S' N' v.
Proof.
  destruct v; simpl; auto using eq_refl with nocore.
Qed.

Definition option_eq {A} eq (x y : option A) :=
  match x with
  | None    => y = None
  | Some ax => match y with
               | None => False
               | Some ay => eq ax ay
               end
  end.

Global Instance Equivalence_option_eq {T} {R} {Equivalence_R:@Equivalence T R}
  : Equivalence (option_eq R).
Proof.
  split; cbv; repeat (intros [|] || intro || intuition congruence ||
                      solve [ apply reflexivity | apply symmetry; eassumption | eapply transitivity; eassumption ] ).
Qed.

Global Instance Proper_option_rect_nd_changebody
      {A B:Type} {RB:relation B} {a:option A}
  : Proper (pointwise_relation _ RB ==> RB ==> RB) (fun S N => option_rect (fun _ => B) S N a).
Proof. destruct a; cbv; repeat (intros [|] || intro); intuition. Qed.

(* FIXME: there used to be a typeclass resolution hint here, something like
  Hint Extern 1 (Proper _ (@option_rect ?A (fun _ => ?B))) => exact (@Proper_option_rect_nd_changebody A B _ _) : typeclass_instances.
 but I could not get it working after generalizing [RB] from [Logic.eq] ~ andreser *)

Global Instance Proper_option_rect_nd_changevalue
      {A B RA RB} some {Proper_some: Proper (RA==>RB) some}
  : Proper (RB ==> option_eq RA ==> RB) (@option_rect A (fun _ => B) some).
Proof. cbv; repeat (intros [|] || intro || f_equiv || intuition congruence). Qed.

Lemma option_rect_false_returns_true_iff {T} (f:T->bool) (o:option T) :
  option_rect (fun _ => bool) f false o = true <-> exists s:T, o = Some s /\ f s = true.
Proof.
  unfold option_rect; split;
    [ destruct o; simpl; intro; try discriminate; eexists | intros [? [? ?]]; subst ];
    eauto.
Qed.

Lemma option_rect_option_map : forall {A B C} (f:A->B) some none v,
    option_rect (fun _ => C) (fun x => some (f x)) none v = option_rect (fun _ => C) some none (option_map f v).
Proof.
  destruct v; reflexivity.
Qed.

Lemma option_rect_function {A B C S' N' v} f
  : f (option_rect (fun _ : option A => option B) S' N' v)
    = option_rect (fun _ : option A => C) (fun x => f (S' x)) (f N') v.
Proof. destruct v; reflexivity. Qed.

(*
Ltac commute_option_rect_Let_In := (* pull let binders out side of option_rect pattern matching *)
  idtac;
  lazymatch goal with
  | [ |- ?LHS = option_rect ?P ?S ?N (Let_In ?x ?f) ]
    => (* we want to just do a [change] here, but unification is stupid, so we have to tell it what to unfold in what order *)
    cut (LHS = Let_In x (fun y => option_rect P S N (f y))); cbv beta;
    [ set_evars;
      let H := fresh in
      intro H;
      rewrite H;
      clear;
      abstract (cbv [Let_In]; reflexivity)
    | ]
  end.
*)

Ltac replace_option_match_with_option_rect :=
  idtac;
  lazymatch goal with
  | [ |- _ = ?RHS :> ?T ]
    => lazymatch RHS with
       | match ?a with None => ?N | Some x => @?S x end
         => replace RHS with (option_rect (fun _ => T) S N a) by (destruct a; reflexivity)
       end
  end.

Ltac simpl_option_rect := (* deal with [option_rect _ _ _ None] and [option_rect _ _ _ (Some _)] *)
  repeat match goal with
         | [ |- context[option_rect ?P ?S ?N None] ]
           => change (option_rect P S N None) with N
         | [ |- context[option_rect ?P ?S ?N (Some ?x) ] ]
           => change (option_rect P S N (Some x)) with (S x); cbv beta
         end.

Definition option_leq_to_eq {A} (x y : option A) : x = y -> option_eq eq x y.
Proof. destruct x; intro; subst; simpl; reflexivity. Qed.

Ltac inversion_option_step :=
  match goal with
  | [ H : Some _ = Some _ |- _ ] => apply option_leq_to_eq in H; unfold option_eq in H
  | [ H : None = Some _ |- _ ] => solve [ inversion H ]
  | [ H : Some _ = None |- _ ] => solve [ inversion H ]
  | [ H : None = None |- _ ] => clear H
  end.

Ltac inversion_option := repeat inversion_option_step.