From ITree Require Import ITree.
From compcert Require Import AST Globalenvs Values Memory.
From compcert Require Clight.

Require Import sflib.
Require Import StdlibExt IntegersExt.

Require Import SysSem.
Require Import SyncSysModel.
Require Import IPModel DiscreteTimeModel IntByteModel.
Require Import NWSysModel.
Require Import OSModel OSNodes.
Require Import ProgSem.

Require Import ZArith String List Lia.

(* Import Params. *)

Set Nested Proofs Allowed.

(* Lemma Int_repr_eq_inv_signed *)
(*       z i *)
(*       (RANGE_Z: IntRange.sintz z) *)
(*       (REPR_EQ: Int.repr z = i) *)
(*   : z = Int.signed i. *)
(* Proof. *)
(*   subst i. r in RANGE_Z. *)
(*   rewrite Int.signed_repr. *)
(*   2: { apply RANGE_Z. } *)
(*   ss. *)
(* Qed. *)

Inductive extcallE: Type -> Type :=
| ExtcallEvent_Int (fname: string) (* (sig: signature) *) (args: list val)
  : extcallE int
| ExtcallEvent_Void (fname: string) (* (sig: signature) *) (args: list val)
  : extcallE unit
.

Notation obsE := (extcallE +' errE).
Notation progE := (osE +' obsE).
(* Notation nodeE := (nbE +' extcallE). *)

Lemma IntNat_of_nat_eq_inv_sint
      n m
      (RANGE_N: IntRange.sint n)
      (RANGE_M: IntRange.sint m)
      (INT_EQ: IntNat.of_nat n = IntNat.of_nat m)
  : n = m.
Proof.
  unfold IntNat.of_nat in INT_EQ.
  assert (Int.signed (Int.repr (Z.of_nat n)) =
          Int.signed (Int.repr (Z.of_nat m))).
  { congruence. }
  rewrite Int.signed_repr in * by range_stac.
  rewrite Int.signed_repr in * by range_stac.
  apply Nat2Z.inj. eauto.
Qed.

Lemma map_Byte_eq_inv
      bs1 bs2
      (MAP_EQ: map Byte bs1 = map Byte bs2)
  : bs1 = bs2.
Proof.
  depgen bs2.
  induction bs1; i;
    destruct bs2; ss.
  inv MAP_EQ.
  erewrite IHbs1; eauto.
Qed.

Lemma IntNat_of_nat64_eq_inv_uint
      n m
      (RANGE_N: IntRange.uint64 n)
      (RANGE_M: IntRange.uint64 m)
      (INT_EQ: IntNat.of_nat64 n = IntNat.of_nat64 m)
  : n = m.
Proof.
  unfold IntNat.of_nat64 in INT_EQ.
  cut (Int64.unsigned (Int64.repr (Z.of_nat n)) =
          Int64.unsigned (Int64.repr (Z.of_nat m))).
  { rewrite Int64.unsigned_repr by range_stac.
    rewrite Int64.unsigned_repr by range_stac.
    apply Nat2Z.inj.
  }
  rewrite INT_EQ. ss.
Qed.

(** ** External functions for progE *)

(* OS *)

Definition open_socket_ef: AST.external_function :=
  EF_external "pals_socket"
              (mksignature nil AST.Tint cc_default).
Definition bind_socket_ef: AST.external_function :=
  EF_external "pals_bind"
              (mksignature (AST.Tint :: AST.Tint :: nil)
                           AST.Tint cc_default).
Definition join_socket_ef: AST.external_function :=
  EF_external "pals_mcast_join"
              (mksignature (AST.Tint :: AST.Tlong :: nil)
                           AST.Tvoid cc_default).
(* Definition close_socket_ef: AST.external_function := *)
(*   EF_external "pals_close" *)
(*               (mksignature (AST.Tint :: nil) *)
(*                            AST.Tint cc_default). *)

Definition sendto_ef: AST.external_function :=
  EF_external "pals_sendto"
              (mksignature
                 (AST.Tint :: AST.Tlong :: AST.Tint :: AST.Tlong ::
                           AST.Tint :: nil) AST.Tint cc_default).
Definition recvfrom_ef: AST.external_function :=
  EF_external "pals_recvfrom"
              (mksignature (AST.Tint :: AST.Tlong :: AST.Tint :: nil)
                           AST.Tint cc_default).
Definition get_time_ef: AST.external_function :=
  EF_external "pals_current_time"
              (mksignature nil AST.Tlong cc_default).
Definition init_timer_ef: AST.external_function :=
  EF_external "pals_init_timer"
              (mksignature nil AST.Tint cc_default).
Definition wait_timer_ef: AST.external_function :=
  EF_external "pals_wait_timer"
              (mksignature (AST.Tlong :: nil)
                           AST.Tint cc_default).

Definition os_efs: list AST.external_function :=
  [open_socket_ef; bind_socket_ef; join_socket_ef;
  sendto_ef; recvfrom_ef;
  get_time_ef; init_timer_ef; wait_timer_ef ].
  (* get_user_input_ef; check_demand_ef; *)
  (* use_resource_ef; mark_complete_ef]. *)

(**)

Definition check_os_ef (ef: AST.external_function) : bool :=
  if find (fun ef' => Coqlib.proj_sumbool
                     (AST.external_function_eq ef ef')) os_efs
  then true else false.

(* Definition check_tlim_ef (ef: AST.external_function): bool := *)
(*   Coqlib.proj_sumbool (AST.external_function_eq ef). *)

Inductive ip_in_mem (ip: ip_t) (m: Mem.mem)
          (blk: block) (ofs: ptrofs): Prop :=
  IPInMem
    (mvs: list memval) (ip_bytes: list byte)
    (LOADBYTES: Mem.loadbytes m blk (Ptrofs.unsigned ofs)
                              (Zlength ip_bytes + 1) = Some mvs)
    (MEMDATA_BYTES: inj_bytes ip_bytes ++
                              [Memdata.Byte Byte.zero] = mvs)
    (CONVERT_FORMAT: IP.convert_brep ip_bytes = Some ip)
.

Lemma loadbytes_until_zero_length_not_lt
      z1 z2 bs1 bs2
      m b ofs
      (LB1: Mem.loadbytes m b ofs z1 =
            Some (inj_bytes bs1 ++ [Byte Byte.zero]))
      (LB2: Mem.loadbytes m b ofs z2 =
            Some (inj_bytes bs2 ++ [Byte Byte.zero]))
      (NZERO1: Forall (fun b => b <> Byte.zero) bs1)
      (NZERO2: Forall (fun b => b <> Byte.zero) bs2)
      (LT: (0 <= z1 < z2)%Z)
  : False.
Proof.
  assert (exists z', <<Z_POS': 0 < z'>> /\
                          <<Z'_DIFF: z1 + z' = z2>>)%Z.
  { exists (z2 - z1)%Z.
    splits; nia. }
  destruct LT as [Z1_NNEG LT12]. des.
  subst z2.
  apply Mem.loadbytes_split in LB2; cycle 1.
  { nia. }
  { nia. }

  destruct LB2 as (bytes1 & bytes2 & BYTES1 & BYTES2 & BS_EQ).
  rewrite LB1 in BYTES1.

  assert (INJ_BYTE_EX: forall b (IN1: In b bytes1),
             In b (inj_bytes bs2)).
  { assert (BYTES2_LEN_POS: 0 < length bytes2).
    { apply Mem.loadbytes_length in BYTES2.
      nia. }

    hexploit (des_snoc _ bytes2); eauto. i. des.
    subst bytes2.
    unfold snoc in BS_EQ.
    rewrite app_assoc in BS_EQ.

    hexploit snoc_eq_inv.
    { unfold snoc.
      apply BS_EQ. }
    intros (INJ_BS2_EQ & X_ZERO).
    rewrite INJ_BS2_EQ.
    apply in_or_app. left. eauto.
  }

  assert (BYTE_EX: forall b (IN1: In b bytes1),
             exists b', In b' bs2 /\ Byte b' = b).
  { intros mb MB_IN.
    hexploit INJ_BYTE_EX; eauto.
    intro IN_INJ.
    unfold inj_bytes in IN_INJ.
    rewrite in_map_iff in IN_INJ. des.
    esplits; eauto.
  }

  hexploit (BYTE_EX (Byte Byte.zero)).
  { clarify.
    apply in_or_app. right. ss. eauto. }
  i. des.

  rewrite Forall_forall in NZERO2.
  hexploit NZERO2; eauto.
  intro B. apply B. congruence.
Qed.

Lemma ip_in_mem_unique
      m blk ofs ip1 ip2
      (IP1: ip_in_mem ip1 m blk ofs)
      (IP2: ip_in_mem ip2 m blk ofs)
  : ip1 = ip2.
Proof.
  inv IP1.
  renames ip_bytes LOADBYTES CONVERT_FORMAT into
          ip_bs1 LOAD1 CONV1.
  inv IP2.
  renames ip_bytes LOADBYTES CONVERT_FORMAT into
          ip_bs2 LOAD2 CONV2.

  hexploit IP.valid_ip_brep_spec; try apply CONV1.
  intros (NZ1 & MAX1 & IP_RANGE1).
  hexploit IP.valid_ip_brep_spec; try apply CONV2.
  intros (NZ2 & MAX2 & IP_RANGE2).

  assert (LEN_EQ: Zlength ip_bs1 = Zlength ip_bs2).
  { destruct (Z_dec' (Zlength ip_bs1) (Zlength ip_bs2))
      as [[A | B] | C].
    - hexploit (loadbytes_until_zero_length_not_lt
                  (Zlength ip_bs1 + 1) (Zlength ip_bs2 + 1)); eauto.
      { splits.
        - rewrite Zlength_correct. nia.
        - nia. }
      ss.
    - hexploit (loadbytes_until_zero_length_not_lt
                  (Zlength ip_bs2 + 1) (Zlength ip_bs1 + 1)); eauto.
      { splits.
        - rewrite Zlength_correct. nia.
        - nia. }
      ss.
    - ss.
  }

  rewrite <- LEN_EQ in LOAD2.
  rewrite LOAD2 in LOAD1.

  assert (inj_bytes ip_bs1 = inj_bytes ip_bs2).
  { inv LOAD1.
    hexploit snoc_eq_inv; eauto. i. des. eauto. }

  cut (proj_bytes (inj_bytes ip_bs1) =
       proj_bytes (inj_bytes ip_bs2)).
  { do 2 rewrite proj_inj_bytes.
    i. congruence. }
  congruence.
Qed.

Inductive cprog_os_ec (senv: Senv.t) (ef: external_function)
  : list val -> Mem.mem -> forall {R}, osE R -> Prop :=
(* socket *)
| CProgOSEC_OpenSocket
    args m
    (EF: ef = open_socket_ef)
    (ARGS: args = [])
    (* (EC: ec = EventCall (subevent _ OSOpenSocket)) *)
  : cprog_os_ec senv ef args m OSOpenSocket

| CProgOSEC_BindSocket
    args m
    sid pn
    (EF: ef = bind_socket_ef)
    (RANGE_SID: IntRange.sint sid)
    (RANGE_PN: IntRange.sint pn)
    (ARGS: args = [Vint (IntNat.of_nat sid);
                  Vint (IntNat.of_nat pn)])
    (* (EC: ec = EventCall (subevent _ (OSBindSocket sid pn))) *)
  : cprog_os_ec senv ef args m (OSBindSocket sid pn)

| CProgOSEC_JoinSocket
    args m
    sid blk ofs ip_mcast
    (EF: ef = join_socket_ef)
    (RANGE_SID: IntRange.sint sid)
    (ARGS: args = [Vint (IntNat.of_nat sid);
                  Vptr blk ofs])
    (IP_IN_MEM: ip_in_mem ip_mcast m blk ofs)
    (* (EC: ec = EventCall (subevent _ )) *)
  : cprog_os_ec senv ef args m (OSJoinSocket sid ip_mcast)

| CProgOSEC_Sendto
    args m
    sid blk_buf ofs_buf sz_buf
    blk_ip ofs_ip
    bs ip_dest pn_dest
    (EF: ef = sendto_ef)
    (RANGE_SID: IntRange.sint sid)
    (RANGE_BUF_SIZE: IntRange.sint sz_buf)
    (RANGE_PN: IntRange.sint pn_dest)
    (ARGS: args = [Vint (IntNat.of_nat sid);
                  Vptr blk_ip ofs_ip;
                  Vint (IntNat.of_nat pn_dest);
                  Vptr blk_buf ofs_buf;
                  Vint (IntNat.of_nat sz_buf)])
    (BS_IN_MEM: Mem.loadbytes m blk_buf (Ptrofs.unsigned ofs_buf)
                              (Z.of_nat sz_buf) =
                Some (List.map Memdata.Byte bs))
    (IP_IN_MEM: ip_in_mem ip_dest m blk_ip ofs_ip)
    (* (EC: ec = EventCall (subevent _ (OSSendto sid bs ip_dest pn_dest))) *)
  : cprog_os_ec senv ef args m
                (OSSendto sid bs ip_dest pn_dest)

| CProgOSEC_Recvfrom
    args m
    sid blk_buf ofs_buf sz_buf
    (* (mvs: list memval) *)
    (EF: ef = recvfrom_ef)
    (RANGE_SID: IntRange.sint sid)
    (RANGE_BUF_SIZE: IntRange.sint sz_buf)
    (ARGS: args = [Vint (IntNat.of_nat sid);
                  Vptr blk_buf ofs_buf;
                  Vint (IntNat.of_nat sz_buf)])
    (WRITABLE_PERM: Mem.range_perm
                      m blk_buf (Ptrofs.unsigned ofs_buf)
                      (Ptrofs.unsigned ofs_buf + Z.of_nat sz_buf)
                      Cur Writable)
    (* (BS_IN_MEM: Mem.loadbytes m blk_buf (Ptrofs.unsigned ofs_buf) *)
    (*                           (Z.of_nat sz_buf) = *)
    (*             Some mvs) *)
    (* (EC: ec = EventCall (subevent _ (OSRecvfrom sid sz_buf))) *)
  : cprog_os_ec senv ef args m (OSRecvfrom sid sz_buf)

(* timer *)
| CProgOSEC_GetTime
    args m
    (EF: ef = get_time_ef)
    (ARGS: args = [])
    (* (EC: ec = EventCall (subevent _ OSGetTime)) *)
  : cprog_os_ec senv ef args m OSGetTime

| CProgOSEC_InitTimer
    args m
    (EF: ef = init_timer_ef)
    (ARGS: args = [])
    (* (EC: ec = EventCall (subevent _ OSInitTimer)) *)
  : cprog_os_ec senv ef args m OSInitTimer

| CProgOSEC_WaitTimer
    args m tm
    (EF: ef = wait_timer_ef)
    (RANGE_TM: IntRange.uint64 tm)
    (ARGS: args = [Vlong (IntNat.of_nat64 tm)])
    (* (EC: ec = EventCall (subevent _ (OSWaitTimer tm))) *)
  : cprog_os_ec senv ef args m (OSWaitTimer tm)
.

Inductive cprog_os_estep
          (senv: Senv.t)
  : forall {R}, osE R -> R ->
         list val -> Mem.mem -> val -> mem -> Prop :=
(* socket *)
| CProgOSEStep_OpenSocket
    (ret: Z) (args: list val) m retv
    (* (EVT: evt = Event (subevent _ OSOpenSocket) ret) *)
    (ARGS: args = [])
    (RANGE_RET: IntRange.sintz ret)
    (RET_VAL: retv = Vint (Int.repr ret))
  : cprog_os_estep senv OSOpenSocket
                   ret args m retv m

| CProgOSEStep_BindSocket
    (ret: Z) (args: list val) m retv
    sid pn
    (* (EVT: evt = Event (subevent _ (OSBindSocket sid pn)) ret) *)
    (RET_VAL: retv = Vint (Int.repr ret))
    (RANGE_RET: IntRange.sintz ret)
  : cprog_os_estep senv (OSBindSocket sid pn) ret
                   args m retv m

| CProgOSEStep_JoinSocket
    (ret: unit) (args: list val) m retv
    sid ip_mcast
    (* (EVT: evt = Event (subevent _ (OSJoinSocket sid ip_mcast)) ret) *)
    (RET_VAL: retv = Vundef)
  : cprog_os_estep senv (OSJoinSocket sid ip_mcast) ret
                   args m retv m

| CProgOSEStep_Sendto
    (ret: Z) (args: list val) m retv
    sid bs ip_d pn_d
    (* (EVT: evt = Event (subevent _ (OSSendto sid bs ip_d pn_d)) ret) *)
    (RET_VAL: retv = Vint (Int.repr ret))
    (RANGE_RET: IntRange.sintz ret)
  : cprog_os_estep senv (OSSendto sid bs ip_d pn_d) ret
                   args m retv m

| CProgOSEStep_Recvfrom
    (ret: (bytes?)) retz
    (args: list val) m retv m'
    sid sz_buf
    blk_buf ofs_buf
    (* (EVT: evt = Event (subevent _ (OSRecvfrom sid sz_buf)) ret) *)
    (ARGS: args = [Vint (IntNat.of_nat sid);
                  Vptr blk_buf ofs_buf;
                  Vint (IntNat.of_nat sz_buf)])
    (RETZ: (ret = None /\ m' = m /\ retz = Z_mone) \/
           (exists bs, ret = Some bs /\
                  Mem.storebytes
                    m blk_buf (Ptrofs.unsigned ofs_buf)
                    (List.map Memdata.Byte bs) = Some m' /\
                  retz = Zlength bs /\
                  length bs <= sz_buf /\
                  length bs <= Packet.maxlen))
    (RET_VAL: retv = Vint (Int.repr retz))
  : cprog_os_estep senv (OSRecvfrom sid sz_buf) ret
                   args m retv m'

(* timer *)
| CProgOSEStep_GetTime
    (ret: Z) (args: list val) m retv
    (* (EVT: evt = Event (subevent _ OSGetTime) ret) *)
    (RET_VAL: retv = Vlong (Int64.repr ret))
    (RANGE_RET: IntRange.uintz64 ret)
  : cprog_os_estep senv OSGetTime ret
                   args m retv m

| CProgOSEStep_InitTimer
    (ret: Z) (args: list val) m retv
    (* (EVT: evt = Event (subevent _ OSInitTimer) ret) *)
    (RET_VAL: retv = Vint (Int.repr ret))
    (RANGE_RET: IntRange.sintz ret)
  : cprog_os_estep senv OSInitTimer ret
                   args m retv m

| CProgOSEStep_WaitTimer
    (ret: Z) (args: list val) m retv tm
    (* (EVT: evt = Event (subevent _ (OSWaitTimer tm)) ret) *)
    (RET_VAL: retv = Vint (Int.repr ret))
    (RANGE_RET: IntRange.sintz ret)
  : cprog_os_estep senv (OSWaitTimer tm) ret
                    args m retv m

.

Section CPROG_SYS_EC.

  Definition retty_of_extcallE {R} (ec: extcallE R): rettype :=
    match ec with
    | ExtcallEvent_Int _ _ => Tint
    | ExtcallEvent_Void _ _ => Tvoid
    end.

  Inductive match_extcallE
    : forall {R}, external_function -> list val -> extcallE R -> Type :=
  | MatchExtcallE
      fname sig args
      (RET_INT: sig_res sig = Tint)
    : match_extcallE (EF_external fname sig) args
                     (ExtcallEvent_Int fname args)
  | MatchExtcallE_Void
      fname sig args
      (RET_VOID: sig_res sig = Tvoid)
    : match_extcallE (EF_external fname sig) args
                     (ExtcallEvent_Void fname args)
  .

  Section CPROG_EVENT_SEM.
    (* Context `{CProgSysEvent}. *)

    (* Match C program states with event calls *)
    Inductive cprog_ec
              (senv: Senv.t) (ef: external_function)
      : list val -> Mem.mem -> event_call (osE +' obsE) -> Prop :=
    | CProgEC_OS
        R (ose: osE R) ec
        args m
        (OS_EC: cprog_os_ec senv ef args m ose)
        (EVENT_CALL: ec = EventCall (subevent _ ose))
      : cprog_ec senv ef args m ec

    (* | CProgEC_TimeLimit *)
    (*     args m ec tm *)
    (*     (EF: ef = time_limit_ef) *)
    (*     (RANGE_TM: IntRange.uint64 tm) *)
    (*     (ARGS: args = [Vlong (IntNat.of_nat64 tm)]) *)
    (*     (EVENT_CALL: ec = EventCall (subevent _ (TimeLimitEvent tm))) *)
    (*   : cprog_ec senv ef args m ec *)

    | CProgEC_SystemEvent
        R args m ec (exte: extcallE R)
        (* (ret: R) *)
        (* fname sig *)
        (* (EXTFUN_EXTERNAL: ef = EF_external fname sig) *)
        (* (SYS_EC: cprog_sys_ec senv ef args m syse) *)
        (NOT_OS_CALL: forall R (ose: osE R), ~ cprog_os_ec senv ef args m ose)
        (* (NOT_SET_TLIM: ef <> time_limit_ef) *)
        (EVENT_CALL: ec = EventCall (subevent _ exte))
        (MATCH_EXTC: match_extcallE ef args exte)
      : cprog_ec senv ef args m ec
    .

    Inductive match_ext_retv: rettype -> forall {R}, R -> val -> Prop :=
    | MatchExtRetv_Int
        (n: int)
      : match_ext_retv Tint n (Vint n)
    | MatchExtRetv_Void
      : match_ext_retv Tvoid tt Vundef
    .

    (* system's cprog_match_after_event *)
    Inductive cprog_estep
              (senv: Senv.t)
              (evt: event (osE +' obsE)):
      list val -> Mem.mem -> val -> mem -> Prop :=
    (* socket *)
    | CProgEStep_OS
        R (ose: osE R) ret
        args m retv m'
        (OS_ESTEP: cprog_os_estep senv ose ret
                                  args m retv m')
        (EVENT: evt = Event (subevent _ ose) ret)
      : cprog_estep senv evt args m retv m'

    (* | CProgEStep_TimeLimit *)
    (*     (args: list val) m retv tm *)
    (*     (RET_VAL: retv = Vundef) *)
    (*     (EVENT: evt = Event (subevent _ (TimeLimitEvent tm)) tt) *)
    (*   : cprog_estep senv evt args m retv m *)

    | CProgEStep_SystemEvent
        R (exte: extcallE R) (ret: R) (retv: val)
        (args: list val) m
        (EVENT: evt = Event (subevent _ exte) ret)
        (MATCH_RETV: match_ext_retv (retty_of_extcallE exte) ret retv)
      : cprog_estep senv evt args m retv m
    .

    Program Instance cprog_event_instance
      : @cprog_event (osE +' obsE) :=
      {| cprog_event_call := cprog_ec ;
         cprog_event_step := cprog_estep ;
      |}.
    Next Obligation.
      inv AT_EVT1; inv AT_EVT2; ss.
      - inv OS_EC; inv OS_EC0; existT_elim1; ss.
        + list_eq_inv_tac.
          repeat f_equal.
          * apply IntNat_of_nat_eq_inv_sint; eauto.
            congruence.
          * apply IntNat_of_nat_eq_inv_sint; eauto.
            congruence.
        + list_eq_inv_tac.
          repeat f_equal.
          * apply IntNat_of_nat_eq_inv_sint; eauto.
            congruence.
          * inv ARGS1.
            eapply ip_in_mem_unique; eauto.
        + list_eq_inv_tac.
          repeat match goal with
                 | H: Vptr _ _ = Vptr _ _ |- _ => inv H
                 end.
          assert (sz_buf0 = sz_buf).
          { apply IntNat_of_nat_eq_inv_sint; eauto.
            congruence. }
          assert (sid0 = sid).
          { apply IntNat_of_nat_eq_inv_sint; eauto.
            congruence. }
          assert (pn_dest0 = pn_dest).
          { apply IntNat_of_nat_eq_inv_sint; eauto.
            congruence. }
          clarify.
          repeat f_equal.
          * apply map_Byte_eq_inv; eauto.
          * eapply ip_in_mem_unique; eauto.
        + list_eq_inv_tac.
          repeat match goal with
                 | H: Vptr _ _ = Vptr _ _ |- _ => inv H
                 end.
          assert (sz_buf0 = sz_buf).
          { apply IntNat_of_nat_eq_inv_sint; eauto.
            congruence. }
          assert (sid0 = sid).
          { apply IntNat_of_nat_eq_inv_sint; eauto.
            congruence. }
          clarify.
        + list_eq_inv_tac.
          repeat f_equal.
          eapply IntNat_of_nat64_eq_inv_uint; eauto.
          congruence.
      (* - inv OS_EC; ss. *)
      - exfalso.
        hexploit NOT_OS_CALL; eauto.
      (* - inv OS_EC; ss. *)
      (* - list_eq_inv_tac. *)
      (*   repeat f_equal. *)
      (*   eapply IntNat_of_nat64_eq_inv_uint; eauto. *)
      (*   congruence. *)
      - exfalso.
        hexploit NOT_OS_CALL; eauto.
      - inv MATCH_EXTC; inv MATCH_EXTC0; ss.
        + congruence.
        + congruence.
    Qed.

  End CPROG_EVENT_SEM.
End CPROG_SYS_EC.


From cap_machine Require Export logrel.
From iris.proofmode Require Import proofmode.
From iris.program_logic Require Import weakestpre adequacy lifting.
From stdpp Require Import base.
From cap_machine.ftlr Require Import ftlr_base interp_weakening.
From cap_machine Require Import addr_reg region.
From cap_machine.rules Require Import rules_base rules_Subseg.

Section fundamental.
  Context {Σ:gFunctors} {memg:memG Σ} {regg:regG Σ} {sealsg: sealStoreG Σ}
          {nainv: logrel_na_invs Σ}
          `{MachineParameters}.

  Notation D := ((leibnizO Word) -n> iPropO Σ).
  Notation R := ((leibnizO Reg) -n> iPropO Σ).
  Implicit Types w : (leibnizO Word).
  Implicit Types interp : (D).

  Lemma within_in_range:
    forall a b b' e e',
      (b <= b')%a ->
      (e' <= e)%a ->
      in_range a b' e' ->
      in_range a b e.
  Proof.
    intros * ? ? [? ?]. split; solve_addr.
  Qed.

  Lemma subseg_interp_preserved p b b' e e' a :
      p <> E ->

      (b <= b')%a ->
      (e' <= e)%a ->
      (□ ▷ (∀ a0 a1 a2 a3 a4,
             full_map a0
          -∗ (∀ (r1 : RegName) v, ⌜r1 ≠ PC⌝ → ⌜a0 !! r1 = Some v⌝ → (fixpoint interp1) v)
          -∗ registers_mapsto (<[PC:=WCap a1 a2 a3 a4]> a0)
          -∗ na_own logrel_nais ⊤
          -∗ □ (fixpoint interp1) (WCap a1 a2 a3 a4) -∗ interp_conf)) -∗
      (fixpoint interp1) (WCap p b e a) -∗
      (fixpoint interp1) (WCap p b' e' a).
  Proof.
    intros Hne Hb He. iIntros "#IH Hinterp".
    iApply (interp_weakening with "IH Hinterp"); eauto.
    destruct p; reflexivity.
  Qed.

  Lemma subseg_case (r : leibnizO Reg) (p : Perm)
        (b e a : Addr) (w : Word) (dst : RegName) (r1 r2 : Z + RegName) (P:D):
    ftlr_instr r p b e a w (Subseg dst r1 r2) P.
  Proof.
    intros Hp Hsome i Hbae Hi.
    iIntros "#IH #Hinv #Hinva #Hreg #[Hread Hwrite] Hown Ha HP Hcls HPC Hmap".
    rewrite delete_insert_delete.
    iDestruct ((big_sepM_delete _ _ PC) with "[HPC Hmap]") as "Hmap /=";
      [apply lookup_insert|rewrite delete_insert_delete;iFrame|]. simpl.
    iApply (wp_Subseg with "[$Ha $Hmap]"); eauto.
    { simplify_map_eq; auto. }
    { rewrite /subseteq /map_subseteq /set_subseteq_instance. intros rr _.
      apply elem_of_dom. apply lookup_insert_is_Some'; eauto. }

    iIntros "!>" (regs' retv). iDestruct 1 as (HSpec) "[Ha Hmap]".
    destruct HSpec as [ * Hdst ? Hao1 Hao2 Hwi HincrPC | * Hdst Hoo1 Hoo2 Hwi HincrPC | ].
    { apply incrementPC_Some_inv in HincrPC as (p''&b''&e''&a''& ? & HPC & Z & Hregs') .

      assert (a'' = a ∧ p'' = p) as (-> & ->).
      { destruct (decide (PC = dst)); simplify_map_eq; auto. }

      iApply wp_pure_step_later; auto.
      iMod ("Hcls" with "[HP Ha]");[iExists w;iFrame|iModIntro].
      iNext ; iIntros "_".
      iApply ("IH" $! regs' with "[%] [] [Hmap] [$Hown]").
      { cbn. intros. subst regs'. by repeat (apply lookup_insert_is_Some'; right). }
      { iIntros (ri v Hri Hvs).
        subst regs'.
        rewrite lookup_insert_ne in Hvs; auto.
        destruct (decide (ri = dst)).
        { subst ri.
          rewrite lookup_insert_ne in Hdst; auto.
          rewrite lookup_insert in Hvs; inversion Hvs. simplify_eq.
          unshelve iSpecialize ("Hreg" $! dst _ _ Hdst); eauto.
          rewrite /isWithin in Hwi.
          iApply (interp_weakening with "IH Hreg"); auto; try solve_addr.
          by rewrite PermFlowsToReflexive. }
        { repeat (rewrite lookup_insert_ne in Hvs); auto.
          iApply "Hreg"; auto. } }
        { subst regs'. rewrite insert_insert. iApply "Hmap". }
      iModIntro.
      iApply (interp_weakening with "IH Hinv"); auto; try solve_addr.
      { destruct Hp; by subst p. }
      { destruct (reg_eq_dec PC dst) as [Heq | Hne]; simplify_map_eq.
        1,2: rewrite /isWithin in Hwi; solve_addr. }
      { destruct (reg_eq_dec PC dst) as [Heq | Hne]; simplify_map_eq.
        1,2: rewrite /isWithin in Hwi; solve_addr. }
      { by rewrite PermFlowsToReflexive. }
    }
    { apply incrementPC_Some_inv in HincrPC as (p''&b''&e''&a''& ? & HPC & Z & Hregs') .
      assert (dst ≠ PC) as Hne.
      { destruct (decide (PC = dst)); last auto. simplify_map_eq; auto. }

      assert (p'' = p ∧ b'' = b ∧ e'' = e ∧ a'' = a) as (-> & -> & -> & ->).
      { simplify_map_eq; auto. }

      iApply wp_pure_step_later; auto.
      iMod ("Hcls" with "[HP Ha]");[iExists w;iFrame|iModIntro].
      iNext ; iIntros "_".
      iApply ("IH" $! regs' with "[%] [] [Hmap] [$Hown]").
      { cbn. intros. subst regs'. by repeat (apply lookup_insert_is_Some'; right). }
      { iIntros (ri v Hri Hvs).
        subst regs'.
        rewrite lookup_insert_ne in Hvs; auto.
        destruct (decide (ri = dst)).
        { subst ri.
          rewrite lookup_insert_ne in Hdst; auto.
          rewrite lookup_insert in Hvs; inversion Hvs. simplify_eq.
          unshelve iSpecialize ("Hreg" $! dst _ _ Hdst); eauto.
          rewrite /isWithin in Hwi.
          iApply (interp_weakening_ot with "Hreg"); auto; try solve_addr.
          by rewrite SealPermFlowsToReflexive. }
        { repeat (rewrite lookup_insert_ne in Hvs); auto.
          iApply "Hreg"; auto. } }
        { subst regs'. rewrite insert_insert. iApply "Hmap". }
      iModIntro.
      iApply (interp_weakening with "IH Hinv"); auto; try solve_addr.
      { destruct Hp; by subst p. }
      { by rewrite PermFlowsToReflexive. }
    }
    { iApply wp_pure_step_later; auto.
    iMod ("Hcls" with "[HP Ha]");[iExists w;iFrame|iModIntro].
    iNext ; iIntros "_".
    iApply wp_value; auto. iIntros; discriminate. }
Qed.

End fundamental.


Require Import Kami.AllNotations.

Class Params :=
  { name : string;
    size : nat;
    inReqK : Kind;
    vAddrSz : nat;
    compInstSz : nat;
    immResK : Kind;
    finalErrK : Kind;
    isCompressed: forall ty, Bit compInstSz @# ty -> Bool @# ty;
    isImmErr: forall ty, immResK @# ty -> Bool @# ty;
    isFinalErr: forall ty, finalErrK @# ty -> Bool @# ty;
  }.

Section Ifc.
  Context {params: Params}.

  Definition VAddr    := Bit vAddrSz.
  Definition CompInst := Bit compInstSz.
  Definition InstSz   := compInstSz + compInstSz.
  Definition Inst     := Bit InstSz.

  Definition OutReq := STRUCT_TYPE { "inReq" :: inReqK;
                                     "vaddr" :: VAddr }.

  Definition InRes
    := STRUCT_TYPE {
         "vaddr"  :: VAddr;
         "immRes" :: immResK;
         "error"  :: finalErrK;
         "inst"   :: Inst
       }.

  (* if inst contains a compressed instruction the upper 16 bit contain arbitrary data. *)
  Definition OutRes
    := STRUCT_TYPE {
         "notComplete?" :: Bool;
         "vaddr"        :: VAddr;
         "immRes"       :: immResK;
         "error"        :: finalErrK;
         "compressed?"  :: Bool;
         "errUpper?"    :: Bool;
         "inst"         :: Inst
       }.

  Record Ifc: Type :=
    {
      regs: list RegInitT;
      regFiles : list RegFileBase;

      isFull: forall {ty}, ActionT ty Bool;
      sendAddr (sendReq: forall ty, ty OutReq -> ActionT ty Bool) ty: ty OutReq -> ActionT ty Bool;
      callback: forall {ty}, ty InRes -> ActionT ty Void;
      deq: forall {ty}, ActionT ty Bool;
      first: forall {ty}, ActionT ty (Maybe OutRes);

      canClear: forall {ty}, ActionT ty Bool;
      clear: forall {ty}, ActionT ty Void;

      notCompleteDeqRule: forall {ty}, ActionT ty Void;
      transferRule: forall {ty}, ActionT ty Void;
    }.
End Ifc.


Require Import Coq.Strings.Ascii
        Coq.Bool.Bool
        Coq.Lists.List
        Coq.Structures.OrderedType.

Require Import
        Fiat.BinEncoders.Env.BinLib.Core
        Fiat.BinEncoders.Env.Common.Specs
        Fiat.BinEncoders.Env.Common.Compose
        Fiat.BinEncoders.Env.Common.ComposeOpt
        Fiat.BinEncoders.Env.Automation.Solver
        Fiat.BinEncoders.Env.Lib2.WordOpt
        Fiat.BinEncoders.Env.Lib2.NatOpt
        Fiat.BinEncoders.Env.Lib2.StringOpt
        Fiat.BinEncoders.Env.Lib2.EnumOpt
        Fiat.BinEncoders.Env.Lib2.FixListOpt
        Fiat.BinEncoders.Env.Lib2.SumTypeOpt.

Require Import
        Fiat.Common.SumType
        Fiat.Examples.Tutorial.Tutorial
        Fiat.Examples.DnsServer.DecomposeEnumField
        Fiat.QueryStructure.Automation.AutoDB
        Fiat.QueryStructure.Implementation.DataStructures.BagADT.BagADT
        Fiat.QueryStructure.Automation.IndexSelection
        Fiat.QueryStructure.Specification.SearchTerms.ListPrefix
        Fiat.QueryStructure.Automation.SearchTerms.FindPrefixSearchTerms
        Fiat.QueryStructure.Automation.MasterPlan
        Fiat.Examples.HACMSDemo.DuplicateFree
        Fiat.Examples.HACMSDemo.HACMSDemo
        Fiat.Examples.HACMSDemo.WheelSensor.

(* We first synthesize an implementation of our encoder. *)
Lemma Sharpened_encode_SensorData_Impl
  : { encode_SensorData_Impl : _ &
      forall ce (val : SensorType),
        refine (encode_SensorData_Spec val ce)
               (ret (encode_SensorData_Impl val ce))}.
Proof.
  eexists; intros; set_evars.
  unfold encode_SensorData_Spec.
  unfold compose, Bind2.
  setoid_rewrite refine_encode_enum; simplify with monad laws.
  setoid_rewrite (@refine_encode_SumType
          bin
          _
          2
          ([nat : Type; nat : Type])
          _
          (icons _
                 (icons _ (inil (A := Type))))).
  simplify with monad laws.
  simpl; rewrite app_nil_r.
  finish honing.
  simpl; f_equiv.
  simpl; repeat apply Build_prim_and; eauto;
    intros; rewrite refine_encode_nat; finish honing.
Defined.

(* Extract the synthesized encoder. *)
Definition encode_SensorData_Impl :=
  Eval simpl in projT1 Sharpened_encode_SensorData_Impl.

(* Extract its proof of correctness for good measure. *)
Lemma refine_encode_SensorData_Impl
  : forall ce (val : SensorType),
        refine (encode_SensorData_Spec val ce)
               (ret (encode_SensorData_Impl val ce)).
Proof.
  exact (projT2 Sharpened_encode_SensorData_Impl).
Qed.

Opaque encode_SensorData_Spec.

Theorem SharpenedWheelSensor :
    FullySharpened WheelSensorSpec.
Proof.
  start sharpening ADT.
  start_honing_QueryStructure'.
  (* We first insert checks for the DuplicateFree constraints.  *)
  hone method "AddSpeedSubscriber". { dropDuplicateFree. }
  hone method "AddTirePressureSubscriber". { dropDuplicateFree. }
  (* Break down the suscribers 'table' into one for each topic.  *)
  decompose_EnumField "subscribers" "topic".
  (* Select the kinds of searches each 'table' should support. *)
  chooseIndexes.
  (* Implement each method using the chosen search operations. *)
  initializer.
  insertOne.
  insertOne.
  rewrite refine_encode_SensorData_Impl; planOne.
  rewrite refine_encode_SensorData_Impl; planOne.
  (* Cleanup the synthesized methods. *)
  final_optimizations.
  (* Ensure the implementation is executable. *)
  determinize.
  (* Select concrete data structures for each table.  *)
  choose_data_structures.
  (* Some final cleanup. *)
  final_simplification.
  (* And we're done! *)
  use_this_one.
Defined.

(* We can now extract the implementation derived above. *)
Definition WheelSensorImpl := Eval simpl in projT1 SharpenedWheelSensor.
Print WheelSensorImpl.


(*
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

Require Import String.
Require Import List.
Require Import Compare_dec.
Require Import Equivalence.
Require Import Morphisms.
Require Import Setoid.
Require Import EquivDec.
Require Import Program.
Require Import Utils.
Require Import DataRuntime.
Require Import NNRSimp.
Require Import NNRSimpNorm.
Require Import NNRSimpEval.

Section NNRSimpEq.
  (* Equivalence for nnrs_imp *)

  Local Open Scope nnrs_imp_scope.

  Context {fruntime:foreign_runtime}.

  Definition nnrs_imp_expr_eq (e₁ e₂:nnrs_imp_expr) : Prop :=
    forall (h:list(string*string))
           (σc:list (string*data))
           (dn_σc: Forall (data_normalized h) (map snd σc))
           (σ:pd_bindings)
           (dn_σ: forall d, In (Some d) (map snd σ) -> data_normalized h d),
      nnrs_imp_expr_eval h σc σ e₁ = nnrs_imp_expr_eval h σc σ e₂.

  Definition nnrs_imp_stmt_eq (s₁ s₂:nnrs_imp_stmt) : Prop :=
    forall (h:list(string*string))
           (σc:list (string*data))
           (dn_σc: Forall (data_normalized h) (map snd σc))
           (σ:pd_bindings)
           (dn_σ: forall d, In (Some d) (map snd σ) -> data_normalized h d),
      nnrs_imp_stmt_eval h σc s₁ σ = nnrs_imp_stmt_eval h σc s₂ σ.

  Definition nnrs_imp_eq (si₁ si₂:nnrs_imp) : Prop :=
    forall (h:list(string*string))
           (σc:list (string*data))
           (dn_σc: Forall (data_normalized h) (map snd σc)),
      nnrs_imp_eval h σc si₁ = nnrs_imp_eval h σc si₂.

  Global Instance nnrs_imp_expr_equiv : Equivalence nnrs_imp_expr_eq.
  Proof.
    unfold nnrs_imp_expr_eq.
    constructor; red; intros.
    - reflexivity.
    - symmetry; eauto.
    - rewrite H; eauto.
  Qed.

  Global Instance nnrs_imp_stmt_equiv : Equivalence nnrs_imp_stmt_eq.
  Proof.
    unfold nnrs_imp_stmt_eq.
    constructor; red; intros.
    - reflexivity.
    - symmetry; eauto.
    - rewrite H; eauto.
  Qed.

  Global Instance nnrs_imp_equiv : Equivalence nnrs_imp_eq.
  Proof.
    unfold nnrs_imp_eq.
    constructor; red; intros.
    - reflexivity.
    - symmetry; eauto.
    - rewrite H; eauto.
  Qed.

  Section proper.

    Global Instance NNRSimpGetConstant_proper v :
      Proper nnrs_imp_expr_eq (NNRSimpGetConstant v).
    Proof.
      unfold Proper, respectful, nnrs_imp_expr_eq; trivial.
    Qed.

    Global Instance NNRSimpVar_proper v :
      Proper nnrs_imp_expr_eq (NNRSimpVar v).
    Proof.
      unfold Proper, respectful, nnrs_imp_expr_eq; trivial.
    Qed.

    Global Instance NNRSimpConst_proper d :
      Proper nnrs_imp_expr_eq (NNRSimpConst d).
    Proof.
      unfold Proper, respectful, nnrs_imp_expr_eq; trivial.
    Qed.

    Global Instance NNRSimpBinop_proper :
      Proper (binary_op_eq ==> nnrs_imp_expr_eq ==> nnrs_imp_expr_eq ==> nnrs_imp_expr_eq) NNRSimpBinop.
    Proof.
      unfold Proper, respectful, nnrs_imp_expr_eq; intros; simpl.
      rewrite H0, H1 by trivial.
      apply olift2_ext; intros.
      apply H
      ; eapply nnrs_imp_expr_eval_normalized; eauto.
    Qed.

    Global Instance NNRSimpUnop_proper :
      Proper (unary_op_eq ==> nnrs_imp_expr_eq ==> nnrs_imp_expr_eq) NNRSimpUnop.
    Proof.
      unfold Proper, respectful, nnrs_imp_expr_eq; intros; simpl.
      rewrite H0 by trivial.
      apply olift_ext; intros.
      apply H
      ; eapply nnrs_imp_expr_eval_normalized; eauto.
    Qed.

    Global Instance NNRSimpGroupBy_proper s ls :
      Proper (nnrs_imp_expr_eq ==> nnrs_imp_expr_eq) (NNRSimpGroupBy s ls).
    Proof.
      unfold Proper, respectful, nnrs_imp_expr_eq; intros; simpl.
      rewrite H; trivial.
    Qed.

    Global Instance NNRSimpSeq_proper :
      Proper (nnrs_imp_stmt_eq ==> nnrs_imp_stmt_eq ==> nnrs_imp_stmt_eq) NNRSimpSeq.
    Proof.
      unfold Proper, respectful, nnrs_imp_stmt_eq; intros; simpl.
      rewrite H by trivial.
      apply olift_ext; intros.
      apply H0; trivial.
      eapply nnrs_imp_stmt_eval_normalized; eauto.
    Qed.

    Global Instance NNRSimpAssign_proper v :
      Proper (nnrs_imp_expr_eq ==> nnrs_imp_stmt_eq) (NNRSimpAssign v).
    Proof.
      unfold Proper, respectful, nnrs_imp_stmt_eq; intros; simpl.
      rewrite H; trivial.
    Qed.

    Global Instance NNRSimpLet_proper v :
      Proper (lift2P nnrs_imp_expr_eq ==> nnrs_imp_stmt_eq ==> nnrs_imp_stmt_eq) (NNRSimpLet v).
    Proof.
      unfold Proper, respectful, nnrs_imp_stmt_eq; intros; simpl.
      unfold lift2P in H.
      destruct x; destruct y; try contradiction; trivial.
      - rewrite H; eauto 2.
        apply olift_ext; simpl; intros ? eqq.
        rewrite H0; trivial; simpl.
        apply some_lift in eqq.
        destruct eqq as [???]; subst.
        intuition.
        invcs H2; qeauto.
      - rewrite H0; trivial; simpl.
        intuition; try discriminate.
    Qed.

    Global Instance NNRSimpLet_none_proper v :
      Proper (nnrs_imp_stmt_eq ==> nnrs_imp_stmt_eq) (NNRSimpLet v None).
    Proof.
      apply NNRSimpLet_proper.
      simpl; trivial.
    Qed.

    Global Instance NNRSimpFor_proper v :
      Proper (nnrs_imp_expr_eq ==> nnrs_imp_stmt_eq ==> nnrs_imp_stmt_eq) (NNRSimpFor v).
    Proof.
      unfold Proper, respectful, nnrs_imp_stmt_eq; intros; simpl.
      rewrite H; eauto 2.
      apply olift_ext; simpl; intros ? eqq.
      destruct a; trivial.
      eapply nnrs_imp_expr_eval_normalized in eqq; eauto.
      invcs eqq.
      revert σ dn_σ.
      induction l; simpl; trivial; intros σ dn_σ.
      invcs H2.
      rewrite H0; simpl; trivial.
      - repeat (match_case; intros); subst.
        apply IHl; trivial; intros.
        eapply nnrs_imp_stmt_eval_normalized; eauto; simpl
        ; intuition.
        invcs H7; trivial.
      - intuition.
        invcs H3; trivial.
    Qed.

    Global Instance NNRSimpIf_proper :
      Proper (nnrs_imp_expr_eq ==> nnrs_imp_stmt_eq ==> nnrs_imp_stmt_eq ==> nnrs_imp_stmt_eq) NNRSimpIf.
    Proof.
      unfold Proper, respectful, nnrs_imp_stmt_eq; intros; simpl.
      rewrite H; eauto 2.
      match_case; intros ? eqq.
      destruct d; trivial.
      destruct b; eauto.
    Qed.

    Global Instance NNRSimpEither_proper :
      Proper (nnrs_imp_expr_eq ==> eq ==> nnrs_imp_stmt_eq ==> eq ==> nnrs_imp_stmt_eq ==> nnrs_imp_stmt_eq) NNRSimpEither.
    Proof.
      unfold Proper, respectful, nnrs_imp_stmt_eq; intros; simpl.
      subst.
      rewrite H; eauto 2.
      match_case; intros ? eqq.
      eapply nnrs_imp_expr_eval_normalized in eqq; eauto.
      destruct d; trivial
      ; invcs eqq.
      - rewrite H1; eauto; simpl; intuition
        ; invcs H4; eauto.
      - rewrite H3; eauto; simpl; intuition
        ; invcs H4; eauto.
    Qed.

    Lemma NNRSImp_proper {s₁ s₂} : nnrs_imp_stmt_eq s₁ s₂ ->
                                   forall v, nnrs_imp_eq (s₁, v) (s₂, v).
    Proof.
      unfold nnrs_imp_eq; intros eqq v; intros; simpl.
      rewrite eqq; trivial.
      simpl; intuition congruence.
    Qed.

  End proper.

End NNRSimpEq.

Notation "X ≡ᵉ Y" := (nnrs_imp_expr_eq X Y) (at level 90) : nnrs_imp_scope. (* ≡ = \equiv *)

Notation "X ≡ˢ Y" := (nnrs_imp_stmt_eq X Y) (at level 90) : nnrs_imp_scope. (* ≡ = \equiv *)

Notation "X ≡ˢⁱ Y" := (nnrs_imp_eq X Y) (at level 90) : nnrs_imp_scope. (* ≡ = \equiv *)


(* 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                                                     *)

Require Import Bool.
Require Import Sumbool.
Require Import Arith.
Require Import ZArith NArith Nnat Ndec Ndigits.
From IntMap Require Import Map.
From IntMap Require Import Allmaps.
Require Import List.
Require Import Wf_nat.

Require Import misc.
Require Import bool_fun.
Require Import myMap.
Require Import config.
Require Import alloc.
Require Import make.

Section BDD_neg.

Variable gc : BDDconfig -> list ad -> BDDconfig.
Hypothesis gc_is_OK : gc_OK gc.

Fixpoint BDDneg_1 (cfg : BDDconfig) (ul : list ad)
 (node : ad) (bound : nat) {struct bound} : BDDconfig * ad :=
  match bound with
  | O => (* Error *)  (initBDDconfig, BDDzero)
  | S bound' =>
      match MapGet _ (negm_of_cfg cfg) node with
      | Some node' => (cfg, node')
      | None =>
          match MapGet _ (fst cfg) node with
          | None =>
              if Neqb node BDDzero
              then (BDDneg_memo_put cfg BDDzero BDDone, BDDone)
              else (BDDneg_memo_put cfg BDDone BDDzero, BDDzero)
          | Some (x, (l, r)) =>
              match BDDneg_1 cfg ul l bound' with
              | (cfgl, nodel) =>
                  match BDDneg_1 cfgl (nodel :: ul) r bound' with
                  | (cfgr, noder) =>
                      match
                        BDDmake gc cfgr x nodel noder (noder :: nodel :: ul)
                      with
                      | (cfg', node') =>
                          (BDDneg_memo_put cfg' node node', node')
                      end
                  end
              end
          end
      end
  end.

Lemma BDDneg_1_lemma :
 forall (bound : nat) (cfg : BDDconfig) (ul : list ad) (node : ad),
 nat_of_N (node_height cfg node) < bound ->
 BDDconfig_OK cfg ->
 used_list_OK cfg ul ->
 used_node' cfg ul node ->
 BDDconfig_OK (fst (BDDneg_1 cfg ul node bound)) /\
 config_node_OK (fst (BDDneg_1 cfg ul node bound))
   (snd (BDDneg_1 cfg ul node bound)) /\
 used_nodes_preserved cfg (fst (BDDneg_1 cfg ul node bound)) ul /\
 Neqb
   (node_height (fst (BDDneg_1 cfg ul node bound))
      (snd (BDDneg_1 cfg ul node bound))) (node_height cfg node) = true /\
 bool_fun_eq
   (bool_fun_of_BDD (fst (BDDneg_1 cfg ul node bound))
      (snd (BDDneg_1 cfg ul node bound)))
   (bool_fun_neg (bool_fun_of_BDD cfg node)).
Proof.
  simple induction bound.  intros.  absurd (nat_of_N (node_height cfg node) < 0).
  apply lt_n_O.  assumption.  simpl in |- *.  intros.
  elim (option_sum _ (MapGet _ (negm_of_cfg cfg) node)).  intro y.
  elim y; clear y; intros node' H4.  rewrite H4.  simpl in |- *.
  elim (negm_of_cfg_OK _ H1 node node' H4).  intros.  split.  assumption.
  split.  inversion H6.  inversion H8.  assumption.  split.
  apply used_nodes_preserved_refl.  split.  exact (proj1 (proj2 H6)).
  exact (proj2 (proj2 H6)).  intro y.  rewrite y.
  elim (option_sum _ (MapGet (BDDvar * (ad * ad)) (fst cfg) node)).  intro y0.
  elim y0; clear y0.
  intro x; elim x; clear x; intros x x0; elim x0; clear x0; intros l r H4.
  rewrite H4.  elim (prod_sum _ _ (BDDneg_1 cfg ul l n)).  intros cfgl H5.
  elim H5; clear H5.  intros nodel H5.  rewrite H5.
  elim (prod_sum _ _ (BDDneg_1 cfgl (nodel :: ul) r n)).  intros cfgr H6.
  elim H6; clear H6; intros noder H6.  rewrite H6.
  elim (prod_sum _ _ (BDDmake gc cfgr x nodel noder (noder :: nodel :: ul))).
  intros cfg' H7; elim H7; clear H7; intros node' H7.  rewrite H7.  simpl in |- *.
  cut (nat_of_N (node_height cfg l) < n).  cut (nat_of_N (node_height cfg r) < n).
  intros.  cut (used_node' cfg ul l).  cut (used_node' cfg ul r).  intros.
  cut
   (BDDconfig_OK cfgl /\
    config_node_OK cfgl nodel /\
    used_nodes_preserved cfg cfgl ul /\
    Neqb (node_height cfgl nodel) (node_height cfg l) = true /\
    bool_fun_eq (bool_fun_of_BDD cfgl nodel)
      (bool_fun_neg (bool_fun_of_BDD cfg l))).
  intro.  elim H12; clear H12; intros.  elim H13; clear H13; intros.
  elim H14; clear H14; intros.  elim H15; clear H15; intros.
  cut (config_node_OK cfg l).  cut (config_node_OK cfg r).  intros.
  cut (used_list_OK cfgl ul).  intro.  cut (used_list_OK cfgl (nodel :: ul)).
  intro.  cut (used_node' cfgl ul r).  intro.
  cut (used_node' cfgl (r :: ul) r).  intro.
  cut
   (BDDconfig_OK cfgr /\
    config_node_OK cfgr noder /\
    used_nodes_preserved cfgl cfgr (nodel :: ul) /\
    Neqb (node_height cfgr noder) (node_height cfgl r) = true /\
    bool_fun_eq (bool_fun_of_BDD cfgr noder)
      (bool_fun_neg (bool_fun_of_BDD cfgl r))).
  intros.  elim H23; clear H23; intros.  elim H24; clear H24; intros.
  elim H25; clear H25; intros.  elim H26; clear H26; intros.
  cut (used_list_OK cfgr (nodel :: ul)).  intro.
  cut (used_list_OK cfgr (noder :: nodel :: ul)).  intro.
  cut (used_node' cfgr (noder :: nodel :: ul) nodel).
  cut (used_node' cfgr (noder :: nodel :: ul) noder).  intros.
  cut
   (forall (xl : BDDvar) (ll rl : ad),
    MapGet _ (fst cfgr) nodel = Some (xl, (ll, rl)) ->
    BDDcompare xl x = Datatypes.Lt).
  cut
   (forall (xr : BDDvar) (lr rr : ad),
    MapGet _ (fst cfgr) noder = Some (xr, (lr, rr)) ->
    BDDcompare xr x = Datatypes.Lt).
  intros.  cut (BDDconfig_OK cfg').
  cut (used_nodes_preserved cfgr cfg' (noder :: nodel :: ul)).
  cut (config_node_OK cfg' node').
  cut
   (bool_fun_eq (bool_fun_of_BDD cfg' node')
      (bool_fun_if x (bool_fun_of_BDD cfgr noder)
         (bool_fun_of_BDD cfgr nodel))).
  cut (Neqb (node_height cfg' node') (ad_S x) = true).  intros.
  cut (config_node_OK cfg' node).  intro.
  cut (nodes_preserved cfg' (BDDneg_memo_put cfg' node node')).  intro.
  cut (BDDconfig_OK (BDDneg_memo_put cfg' node node')).  intro.  split.
  assumption.  split.  apply nodes_preserved_config_node_OK with (cfg1 := cfg').
  assumption.  assumption.  split.
  apply used_nodes_preserved_trans with (cfg2 := cfgr).  assumption.
  apply used_nodes_preserved_trans with (cfg2 := cfgl).  assumption.  assumption.
  apply used_nodes_preserved_cons with (node := nodel).  assumption.
  apply used_nodes_preserved_trans with (cfg2 := cfg').  assumption.
  apply used_nodes_preserved_cons with (node := nodel).
  apply used_nodes_preserved_cons with (node := noder).
  assumption.  apply nodes_preserved_used_nodes_preserved.  assumption.
  rewrite
   (Neqb_complete (node_height (BDDneg_memo_put cfg' node node') node')
      (node_height cfg' node')).
  split.  rewrite (Neqb_complete _ _ H34).  unfold node_height in |- *.  unfold bs_node_height in |- *.
  rewrite H4.  apply Neqb_correct.
  apply bool_fun_eq_trans with (bf2 := bool_fun_of_BDD cfg' node').
  apply nodes_preserved_bool_fun.  assumption.  assumption.  assumption.
  assumption.  apply
   bool_fun_eq_trans
    with
      (bf2 := bool_fun_if x (bool_fun_of_BDD cfgr noder)
                (bool_fun_of_BDD cfgr nodel)).
  assumption.  apply
   bool_fun_eq_trans
    with
      (bf2 := bool_fun_if x (bool_fun_neg (bool_fun_of_BDD cfg r))
                (bool_fun_neg (bool_fun_of_BDD cfg l))).
  apply bool_fun_if_preserves_eq.  apply bool_fun_eq_trans with (bf2 := bool_fun_neg (bool_fun_of_BDD cfgl r)).
  assumption.  apply bool_fun_neg_preserves_eq.
  apply used_nodes_preserved'_bool_fun with (ul := ul).
  assumption.  assumption.  assumption.  assumption.  assumption.
  apply bool_fun_eq_trans with (bf2 := bool_fun_of_BDD cfgl nodel).
  apply used_nodes_preserved'_bool_fun with (ul := nodel :: ul).  assumption.
  assumption.  assumption.  assumption.  apply used_node'_cons_node_ul.
  assumption.  apply bool_fun_eq_sym.
  apply
   bool_fun_eq_trans
    with
      (bf2 := bool_fun_neg
                (bool_fun_if x (bool_fun_of_BDD cfg r)
                   (bool_fun_of_BDD cfg l))).
  apply bool_fun_neg_preserves_eq.  apply bool_fun_of_BDD_int.  assumption.
  assumption.  apply bool_fun_neg_orthogonal.  apply nodes_preserved_node_height_eq.
  assumption.  assumption.  assumption.  assumption.  apply BDDnegm_put_OK.
  assumption.  assumption.  assumption.  rewrite (Neqb_complete _ _ H34).
  rewrite (Neqb_complete (node_height cfg' node) (node_height cfg node)).  unfold node_height in |- *.
  unfold bs_node_height in |- *.  rewrite H4.  apply Neqb_correct.
  apply used_nodes_preserved'_node_height_eq with (ul := ul).  assumption.  assumption.
  apply used_nodes_preserved_trans with (cfg2 := cfgl).  assumption.  assumption.
  apply used_nodes_preserved_trans with (cfg2 := cfgr).  assumption.
  apply used_nodes_preserved_cons with (node := nodel).  assumption.
  apply used_nodes_preserved_cons with (node := nodel).
  apply used_nodes_preserved_cons with (node := noder).  assumption.  assumption.
  assumption.  apply
   bool_fun_eq_trans
    with
      (bf2 := bool_fun_if x (bool_fun_of_BDD cfgr noder)
                (bool_fun_of_BDD cfgr nodel)).
  assumption.  apply
   bool_fun_eq_trans
    with
      (bf2 := bool_fun_if x (bool_fun_neg (bool_fun_of_BDD cfg r))
                (bool_fun_neg (bool_fun_of_BDD cfg l))).
  apply bool_fun_if_preserves_eq.
  apply bool_fun_eq_trans with (bf2 := bool_fun_neg (bool_fun_of_BDD cfgl r)).
  assumption.  apply bool_fun_neg_preserves_eq.
  apply used_nodes_preserved'_bool_fun with (ul := ul).
  assumption.  assumption.  assumption.  assumption.  assumption.
  apply bool_fun_eq_trans with (bf2 := bool_fun_of_BDD cfgl nodel).
  apply used_nodes_preserved'_bool_fun with (ul := nodel :: ul).  assumption.
  assumption.  assumption.  assumption.  apply used_node'_cons_node_ul.
  assumption.  apply
   bool_fun_eq_trans with (bf2 := bool_fun_neg (bool_fun_of_BDD cfg node)).
  apply
   bool_fun_eq_trans
    with
      (bf2 := bool_fun_neg
                (bool_fun_if x (bool_fun_of_BDD cfg r)
                   (bool_fun_of_BDD cfg l))).
  apply bool_fun_eq_sym.  apply bool_fun_neg_orthogonal.
  apply bool_fun_neg_preserves_eq.  apply bool_fun_eq_sym.
  apply bool_fun_of_BDD_int.  assumption.  assumption.
  apply bool_fun_neg_preserves_eq.  apply bool_fun_eq_sym.
  apply used_nodes_preserved'_bool_fun with (ul := ul).  assumption.  assumption.
  apply used_nodes_preserved_trans with (cfg2 := cfgl).  assumption.  assumption.
  apply used_nodes_preserved_trans with (cfg2 := cfgr).  assumption.
  apply used_nodes_preserved_cons with (node := nodel).  assumption.
  apply used_nodes_preserved_cons with (node := nodel).
  apply used_nodes_preserved_cons with (node := noder).  assumption.  assumption.
  assumption.  apply BDDnegm_put_nodes_preserved.
  apply used_nodes_preserved_node_OK' with (ul := ul) (cfg := cfg).  assumption.
  assumption.  assumption.  apply used_nodes_preserved_trans with (cfg2 := cfgl).
  assumption.  assumption.  apply used_nodes_preserved_trans with (cfg2 := cfgr).
  assumption.  apply used_nodes_preserved_cons with (node := nodel).  assumption.
  apply used_nodes_preserved_cons with (node := nodel).
  apply used_nodes_preserved_cons with (node := noder).  assumption.
  replace cfg' with
   (fst (BDDmake gc cfgr x nodel noder (noder :: nodel :: ul))).
  replace node' with
   (snd (BDDmake gc cfgr x nodel noder (noder :: nodel :: ul))).
  apply BDDmake_node_height_eq.  assumption.  intros.  apply not_true_is_false.
  unfold not in |- *; intro.  apply eq_true_false_abs with (b := Neqb l r).
  apply BDDunique with (cfg := cfg).  assumption.  assumption.  assumption.
  apply bool_fun_eq_trans with (bf2 := bool_fun_of_BDD cfgl r).
  apply bool_fun_eq_neg_eq.
  apply bool_fun_eq_trans with (bf2 := bool_fun_of_BDD cfgl nodel).
  apply bool_fun_eq_sym.  assumption.
  apply bool_fun_eq_trans with (bf2 := bool_fun_of_BDD cfgr nodel).
  apply bool_fun_eq_sym.
  apply used_nodes_preserved'_bool_fun with (ul := nodel :: ul).  assumption.
  assumption.  assumption.  assumption.  apply used_node'_cons_node_ul.
  rewrite (Neqb_complete _ _ H34).  assumption.
  apply used_nodes_preserved'_bool_fun with (ul := ul).  assumption.  assumption.
  assumption.  assumption.  assumption.
  apply low_high_neq with (cfg := cfg) (node := node) (x := x).  assumption.  assumption.
  rewrite H7.  reflexivity.  rewrite H7.  reflexivity.
  replace cfg' with
   (fst (BDDmake gc cfgr x nodel noder (noder :: nodel :: ul))).
  replace node' with
   (snd (BDDmake gc cfgr x nodel noder (noder :: nodel :: ul))).
  apply BDDmake_bool_fun.  assumption.  assumption.  assumption.  assumption.
  assumption.  assumption.  assumption.  rewrite H7.  reflexivity.  rewrite H7.
  reflexivity.  replace cfg' with
   (fst (BDDmake gc cfgr x nodel noder (noder :: nodel :: ul))).
  replace node' with
   (snd (BDDmake gc cfgr x nodel noder (noder :: nodel :: ul))).
  apply BDDmake_node_OK.  assumption.  assumption.  assumption.  assumption.
  assumption.  assumption.  assumption.  rewrite H7.  reflexivity.  rewrite H7.
  reflexivity.  replace cfg' with
   (fst (BDDmake gc cfgr x nodel noder (noder :: nodel :: ul))).
  replace node' with
   (snd (BDDmake gc cfgr x nodel noder (noder :: nodel :: ul))).
  apply BDDmake_preserves_used_nodes.  assumption.  assumption.  assumption.
  rewrite H7.  reflexivity.  rewrite H7.  reflexivity.
  replace cfg' with
   (fst (BDDmake gc cfgr x nodel noder (noder :: nodel :: ul))).
  apply BDDmake_keeps_config_OK.  assumption.  assumption.  assumption.
  assumption.  assumption.  assumption.  assumption.  rewrite H7.  reflexivity.
  intros.  rewrite (ad_S_compare xr x).
  replace (ad_S xr) with (bs_node_height (fst cfgr) noder).
  replace (ad_S x) with (bs_node_height (fst cfg) node).  unfold node_height in H26.
  rewrite (Neqb_complete _ _ H26).  cut (Neqb (node_height cfgl r) (node_height cfg r) = true).
  intro.  unfold node_height in H33.  rewrite (Neqb_complete _ _ H33).
  apply bs_node_height_right with (x := x) (l := l).  exact (proj1 H1).  assumption.
  apply used_nodes_preserved'_node_height_eq with (ul := ul).  assumption.  assumption.
  assumption.  assumption.  assumption.  unfold bs_node_height in |- *.  rewrite H4.
  reflexivity.  unfold bs_node_height in |- *.  rewrite H32.  reflexivity.  intros.
  rewrite (ad_S_compare xl x).  replace (ad_S xl) with (bs_node_height (fst cfgr) nodel).
  replace (ad_S x) with (bs_node_height (fst cfg) node).
  cut (Neqb (node_height cfgr nodel) (node_height cfgl nodel) = true).  intro.
  unfold node_height in H33.  rewrite (Neqb_complete _ _ H33).  unfold node_height in H15.
  rewrite (Neqb_complete _ _ H15).  apply bs_node_height_left with (x := x) (r := r).
  exact (proj1 H1).  assumption.
  apply used_nodes_preserved'_node_height_eq with (ul := nodel :: ul).  assumption.
  assumption.  assumption.  assumption.  apply used_node'_cons_node_ul.
  unfold bs_node_height in |- *.  rewrite H4.  reflexivity.  unfold bs_node_height in |- *.  rewrite H32.
  reflexivity.  apply used_node'_cons_node_ul.  apply used_node'_cons_node'_ul.
  apply used_node'_cons_node_ul.  apply node_OK_list_OK.  assumption.
  assumption.  apply used_nodes_preserved_list_OK with (cfg := cfgl).  assumption.
  assumption.  replace cfgr with (fst (BDDneg_1 cfgl (nodel :: ul) r n)).
  replace noder with (snd (BDDneg_1 cfgl (nodel :: ul) r n)).  apply H.
  apply lt_trans_1 with (y := nat_of_N (node_height cfg node)).
  cut (Neqb (node_height cfgl r) (node_height cfg r) = true).  intro.
  rewrite (Neqb_complete _ _ H23).  apply BDDcompare_lt.  unfold node_height in |- *.
  apply bs_node_height_right with (x := x) (l := l).  exact (proj1 H1).  assumption.
  apply used_nodes_preserved'_node_height_eq with (ul := ul).  assumption.  assumption.
  assumption.  assumption.  assumption.  assumption.  assumption.  assumption.
  apply used_node'_cons_node'_ul.  assumption.  rewrite H6.  reflexivity.
  rewrite H6.  reflexivity.  apply used_node'_cons_node_ul.
  apply used_nodes_preserved_used_node' with (cfg := cfg).  assumption.  assumption.
  assumption.  apply node_OK_list_OK.  assumption.  assumption.
  apply used_nodes_preserved_list_OK with (cfg := cfg).  assumption.  assumption.
  apply used_node'_OK with (ul := ul).  assumption.  assumption.  assumption.
  apply used_node'_OK with (ul := ul).  assumption.  assumption.  assumption.
  replace cfgl with (fst (BDDneg_1 cfg ul l n)).
  replace nodel with (snd (BDDneg_1 cfg ul l n)).  apply H.
  apply lt_trans_1 with (y := nat_of_N (node_height cfg node)).  apply BDDcompare_lt.
  unfold node_height in |- *.  apply bs_node_height_left with (x := x) (r := r).  exact (proj1 H1).
  assumption.  assumption.  assumption.  assumption.  assumption.  rewrite H5.
  reflexivity.  rewrite H5.  reflexivity.
  apply high_used' with (x := x) (l := l) (node := node).  assumption.  assumption.
  assumption.  apply low_used' with (x := x) (r := r) (node := node).  assumption.
  assumption.  assumption.  apply lt_trans_1 with (y := nat_of_N (node_height cfg node)).
  apply BDDcompare_lt.  unfold node_height in |- *.  apply bs_node_height_right with (x := x) (l := l).
  exact (proj1 H1).  assumption.  assumption.
  apply lt_trans_1 with (y := nat_of_N (node_height cfg node)).  apply BDDcompare_lt.
  unfold node_height in |- *.  apply bs_node_height_left with (x := x) (r := r).  exact (proj1 H1).
  assumption.  assumption.  intro y0.  rewrite y0.
  elim (sumbool_of_bool (Neqb node BDDzero)).  intro y1.  rewrite y1.
  rewrite (Neqb_complete _ _ y1).  simpl in |- *.
  cut (BDDconfig_OK (BDDneg_memo_put cfg BDDzero BDDone)).  intro.  split.
  assumption.  cut (nodes_preserved cfg (BDDneg_memo_put cfg BDDzero BDDone)).
  intro.  split.  apply nodes_preserved_config_node_OK with (cfg1 := cfg).
  assumption.  apply one_OK.  split.  apply nodes_preserved_used_nodes_preserved.
  assumption.  split.  rewrite <-
   (Neqb_complete (node_height cfg BDDone) (node_height cfg BDDzero))
   .
  apply nodes_preserved_node_height_eq.  assumption.  assumption.  assumption.
  apply one_OK.  rewrite (Neqb_complete _ _ (node_height_zero _ H1)).
  rewrite (Neqb_complete _ _ (node_height_one _ H1)).  reflexivity.
  apply bool_fun_eq_trans with (bf2 := bool_fun_one).  apply bool_fun_of_BDD_one.
  assumption.  apply bool_fun_eq_trans with (bf2 := bool_fun_neg bool_fun_zero).
  apply bool_fun_eq_sym.  exact bool_fun_neg_zero.
  apply bool_fun_neg_preserves_eq.  apply bool_fun_eq_sym.
  apply bool_fun_of_BDD_zero.  assumption.  apply BDDnegm_put_nodes_preserved.
  apply BDDnegm_put_OK.  assumption.  apply zero_OK.  apply one_OK.
  rewrite (Neqb_complete _ _ (node_height_zero _ H1)).
  rewrite (Neqb_complete _ _ (node_height_one _ H1)).  reflexivity.
  apply bool_fun_eq_trans with (bf2 := bool_fun_neg bool_fun_zero).
  apply bool_fun_of_BDD_one.  assumption.  apply bool_fun_neg_preserves_eq.
  apply bool_fun_eq_sym.  apply bool_fun_of_BDD_zero.  assumption.  intro y1.
  rewrite y1.  simpl in |- *.  cut (BDDconfig_OK (BDDneg_memo_put cfg BDDone BDDzero)).
  intro.  split.  assumption.
  cut (nodes_preserved cfg (BDDneg_memo_put cfg BDDone BDDzero)).  intro.
  split.  apply nodes_preserved_config_node_OK with (cfg1 := cfg).  assumption.
  apply zero_OK.  split.  apply nodes_preserved_used_nodes_preserved.
  assumption.  elim (used_node'_OK cfg ul node H1 H2 H3).  intro.
  rewrite H6 in y1.  simpl in y1.  discriminate.  intro.  elim H6.  intro.
  rewrite H7.  split.  rewrite <-
   (Neqb_complete (node_height cfg BDDzero) (node_height cfg BDDone))
   .
  apply nodes_preserved_node_height_eq.  assumption.  assumption.  assumption.
  apply zero_OK.  rewrite (Neqb_complete _ _ (node_height_zero _ H1)).
  rewrite (Neqb_complete _ _ (node_height_one _ H1)).  reflexivity.
  apply bool_fun_eq_trans with (bf2 := bool_fun_zero).  apply bool_fun_of_BDD_zero.
  assumption.  apply bool_fun_eq_trans with (bf2 := bool_fun_neg bool_fun_one).
  apply bool_fun_eq_sym.  exact bool_fun_neg_one.
  apply bool_fun_neg_preserves_eq.  apply bool_fun_eq_sym.
  apply bool_fun_of_BDD_one.  assumption.  intro.  unfold in_dom in H7.
  rewrite y0 in H7.  discriminate.  apply BDDnegm_put_nodes_preserved.
  apply BDDnegm_put_OK.  assumption.  apply one_OK.  apply zero_OK.
  rewrite (Neqb_complete _ _ (node_height_zero _ H1)).
  rewrite (Neqb_complete _ _ (node_height_one _ H1)).  reflexivity.
  apply bool_fun_eq_trans with (bf2 := bool_fun_neg bool_fun_one).
  apply bool_fun_of_BDD_zero.  assumption.  apply bool_fun_neg_preserves_eq.
  apply bool_fun_eq_sym.  apply bool_fun_of_BDD_one.  assumption.
Qed.

End BDD_neg.


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

Local Open Scope Z_scope.

Section SpecLow.

  Definition init_rec_sysregs_spec0 (rec: Pointer) (mpidr: Z64) (adt: RData) : option RData :=
    match rec, mpidr with
    | (_rec_base, _rec_ofst), VZ64 _mpidr =>
      when adt == set_rec_sysregs_spec (_rec_base, _rec_ofst) 39 (VZ64 64) adt;
      when adt == set_rec_sysregs_spec (_rec_base, _rec_ofst) 47 (VZ64 12912760) adt;
      when adt == set_rec_sysregs_spec (_rec_base, _rec_ofst) 65 (VZ64 4096) adt;
      rely is_int64 _mpidr;
      when adt == set_rec_sysregs_spec (_rec_base, _rec_ofst) 72 (VZ64 _mpidr) adt;
      when adt == set_rec_sysregs_spec (_rec_base, _rec_ofst) 69 (VZ64 3072) adt;
      Some adt
     end
    .

End SpecLow.


Require Import Coq.Logic.Classical_Prop.
Require Import EqNat.
Require Import ZArith.
Require Import Lia.
Require Import List.
Require Import Relations.
Require Import FunctionalExtensionality.

Require Import Semantics.
Require Import Utils Lattices CLattices.
Require Import Instr.
Require Import AbstractCommon Rules QuasiAbstractMachine.
Require Import Concrete ConcreteMachine CodeGen CodeSpecs.
Require Import FaultRoutine.
Require Import Determinism.
Require Import ConcreteExecutions.
Require Import Refinement.
Require Import RefinementAC.
Require Import Encodable.

Require Import Refinement.
Require RefinementAC.

(** The Abstract Machine refines the Concrete Machine (with appropriate fault handler). *)

Set Implicit Arguments.
Local Open Scope Z_scope.

Section QuasiAbstractAbstract.

Context {T: Type}
        {Latt: JoinSemiLattice T}.

Program Definition quasi_abstract_abstract_sref :=
  @strong_refinement tini_quasi_abstract_machine
                     AbstractMachine.abstract_machine
                     eq eq _.
Next Obligation.
  exists a2. exists s22.
  repeat split; trivial.
  - generalize abstract_step_equiv. simpl. intuition.
    rewrite H. trivial.
  - destruct a2; constructor; trivial.
Qed.

Program Definition quasi_abstract_abstract_ref :=
  @refinement_from_state_refinement tini_quasi_abstract_machine
                                    AbstractMachine.abstract_machine
                                    quasi_abstract_abstract_sref eq
                                    _.

End QuasiAbstractAbstract.

Section Ref.

Context {L: Type}
        {Latt: JoinSemiLattice L}
        {CLatt: ConcreteLattice L}
        {ELatt: Encodable L}
        {WFCLatt: WfConcreteLattice L Latt CLatt ELatt}.

(** The fault handler code and its correctness *)
Notation fetch_rule_g := fetch_rule. (* Should be able to replace this with a generic one later *)
Definition fetch_rule_withsig := (fun opcode => existT _ (labelCount opcode) (fetch_rule_g opcode)).
Definition LCL := LatticeConcreteLabels fetch_rule_withsig.
Definition faultHandler := @FaultRoutine.faultHandler L ELatt labelCount
                                                      (ifc_run_tmr fetch_rule_g)
                                                      LCL.

(* Bit more glue *)
Lemma handler_correct :
  forall m i s raddr c opcode vls pcl olr lpc,
  forall (INPUT: cache_hit c (opCodeToZ opcode) (@labsToZs L ELatt _ vls) (labToZ pcl))
         (RULE: apply_rule (fetch_rule_g opcode) pcl vls = Some (olr,lpc)),
    exists c',
    runsToEscape (CState c m faultHandler i (CRet raddr false false::s) (0,handlerTag) true)
                 (CState c' m faultHandler i s raddr false) /\
    handler_final_mem_matches (T:=L) olr lpc c c'.
Proof.
  intros.
  exploit (handler_correct_succeed (CT := LCL)); unfold fetch_rule_withsig; eauto.
Qed.

Lemma match_stacks_args' : forall args s cs,
   match_stacks (args ++ s) cs ->
   exists args' cs', cs = args'++cs'
                      /\ match_stacks args args'
                      /\ match_stacks s cs'.
Proof.
  induction args; intros.
  - simpl in *. exists nil; exists cs. repeat (split; eauto). constructor.
  - simpl in *.
    inv H.
    + exploit IHargs; eauto; intros [args' [cs' [Heq [Hmatch Hmatch']]]]; subst.
      exists (atom_labToZ a0 ::: args').
      eexists; split; eauto ; try reflexivity.
      split; eauto.
      constructor; eauto.
    + exploit IHargs; eauto; intros [args' [cs' [Heq [Hmatch Hmatch']]]]; subst.
      exists (CRet (atom_labToZ a0) r false :: args').
      eexists; split; eauto ; try reflexivity.
      split; eauto.
      constructor; eauto.
Qed.

Lemma match_stacks_data' : forall s cs,
    match_stacks s cs ->
    (forall a, In a s -> exists d : Atom, a = AData d) ->
    (forall a, In a cs -> exists d : Atom, a = CData d).
Proof.
  induction 1;  intros.
  - inv H0.
  - inv H2.  eauto.
    eapply IHmatch_stacks; eauto.
    intros; eapply H1; eauto.
    econstructor 2; eauto.
  - inv H2.
    eelim (H1 (ARet a r)); eauto. intros. congruence.
    constructor; auto.
    eapply IHmatch_stacks; eauto.
    intros; eapply H1; eauto.
    econstructor 2; eauto.
Qed.

Lemma match_stacks_pop_to_return : forall dstk cdstk pcv pcl b stk cs p,
   match_stacks (dstk  ++ ARet (pcv, pcl)        b   :: stk)
                (cdstk ++ CRet (pcv, labToZ pcl) b p :: cs) ->
   (forall e, In e dstk -> exists a, e = AData a) ->
   length dstk = length cdstk ->
   pop_to_return   (dstk  ++ ARet (pcv, pcl)        b   :: stk) (ARet (pcv, pcl) b :: stk) ->
   c_pop_to_return (cdstk ++ CRet (pcv, labToZ pcl) b p :: cs)  (CRet (pcv, labToZ pcl) b p ::cs).
Proof.
  intros.
  exploit match_stacks_app_length; eauto. intros [Hmatch Hmatch'].
  inv Hmatch'. inv H10.
  assert (Hcdstk:= match_stacks_data' Hmatch H0); eauto.
  eapply c_pop_to_return_pops_data; eauto.
Qed.

(** Observing a concete cache is just projecting it a the abstract level.
    Defining related notions and conversions
 *)
Fixpoint c_to_a_stack (cs : list CStkElmt): list (@StkElmt L) :=
  match cs with
    | nil => nil
    | CData s :: cs => (AData (atom_ZToLab s))::(c_to_a_stack cs)
    | CRet a r p::cs => ARet (atom_ZToLab a) r::(c_to_a_stack cs)
  end.

Lemma match_stacks_obs : forall s s',
    match_stacks s s' ->
    c_to_a_stack s' = s.
Proof.
  induction s ; intros.
  inv H; simpl; auto.
  inv H; simpl; rewrite IHs; eauto;
  rewrite <- atom_ZToLab_labToZ_id; auto.
Qed.

Hint Rewrite match_stacks_obs.

Definition observe_cstate (cs: CS) : @AS L :=
  match cs with
    | CState c m fh i s pc p =>
      AState (mem_ZToLab m) i (c_to_a_stack s) (atom_ZToLab pc)
  end.

Lemma handler_cache_hit_read :
  forall rl m rpcl tmuc,
    handler_final_mem_matches rpcl rl m tmuc ->
    cache_hit_read tmuc (labToZ rl) (labToZ rpcl).
Proof.
  intros; inv H ; auto.
Qed.

Ltac allinv' :=
  allinv ;
    (match goal with
       | [ H1:  ?f _ _ = _ ,
           H2:  ?f _ _ = _ |- _ ] => rewrite H1 in H2 ; inv H2
     end).

Lemma handler_final_cache_hit_preserved:
  forall tmuc tmuc' rl opcode labs rpcl pcl,
    handler_final_mem_matches rpcl rl tmuc tmuc' ->
    cache_hit tmuc  opcode labs pcl ->
    cache_hit tmuc' opcode labs pcl.
Proof.
  intros *. intros Hfinal HCHIT. inv HCHIT.
  inv Hfinal. unfold update_cache_spec_rvec in *.
  assert (exists tagr tagrpc, cache_hit_read tmuc' tagr tagrpc)
    by (eexists; eexists; eauto).
  destruct H1 as [tagr' [tagrpc' C]].
  inv C.
  repeat (match goal with
    | [ HTAG : tag_in_mem _ ?addr _ |- _ ] => inv HTAG
  end).
  econstructor;
  try solve [econstructor;
              try (rewrite <- H0; eauto;
                   match goal with
                     | [ |- ?a <> ?b ] => try (unfold a, b ; congruence)
                   end; fail); eauto];
  eauto.
Qed.

Lemma opCodeToZ_inj: forall o1 o2, opCodeToZ o1 = opCodeToZ o2 -> o1 = o2.
Proof.
  intros o1 o2 Heq.
  destruct o1, o2; inv Heq; try congruence.
Qed.

Hint Constructors cstep runsToEscape match_stacks match_states : core.

Ltac inv_cache_update :=
  unfold cache_up2date in *;
  unfold cache_up2date_weak; intros;
  exploit handler_final_cache_hit_preserved; eauto; intros;
  let P1 := fresh in let P2 := fresh in let P3 := fresh in
  match goal with
    |  [CHIT: cache_hit ?C _ _ _,
        CHIT': cache_hit ?C _ _ _ |- _] =>
       destruct (cache_hit_unique CHIT CHIT') as [P1 [P2 P3]];
       subst;
       apply opCodeToZ_inj in P1; subst;
       apply labsToZs_inj in P2; try (zify; lia); subst;
       apply labToZ_inj in P3 ;subst
   end;
  try allinv';
  try match goal with
        | [H : apply_rule _ _ _ = _ |- _] =>
          rewrite H
      end;
  try solve [eapply handler_cache_hit_read; eauto].

Lemma match_observe:
  forall s1 s2,
    match_states fetch_rule_g s1 s2 ->
    s1 = observe_cstate s2.
Proof.
  intros.
  inv H.
  simpl. erewrite match_stacks_obs; eauto.
  rewrite <- atom_ZToLab_labToZ_id.
  rewrite <- mem_ZToLab_labToZ_id.
  auto.
Qed.

Hint Constructors star plus : core.

Lemma update_list_map : forall xv rl m n m',
   update_list n (xv, rl) m = Some m' ->
   update_list n (xv, labToZ rl) (mem_labToZ m) = Some (mem_labToZ m').
Proof.
  induction m ; intros; simpl in *.
  destruct n ; simpl in *; inv H.
  destruct n ; simpl in *.
  - inv H. reflexivity.
  - case_eq (update_list n (xv,rl) m); intros; rewrite H0 in *; inv H.
    erewrite IHm ; eauto. reflexivity.
Qed.

Lemma upd_m_mem_labToZ : forall m addrv xv rl m',
  upd_m addrv (xv, rl) m = Some m' ->
  upd_m addrv (xv, labToZ rl) (mem_labToZ m) = Some (mem_labToZ m').
Proof.
  unfold upd_m.
  intros; simpl in *.
  case (addrv <? 0) in *. inv H.
  eapply update_list_map; eauto.
Qed.

Ltac renaming :=
  match goal with
    | [ Hrule : ifc_run_tmr _ ?opcode ?pcl ?v = Some (?rpcl, ?rl) |- _ ]  =>
      set (tags := labsToZs v);
      set (op := opCodeToZ opcode);
      set (pct := labToZ pcl);
      set (rpct := labToZ rpcl);
      set (rt := labToZ rl)
  end;
  match goal with
    | [ HH: match_states _ (AState ?m _ _ _) _ |- _ ] => set (cm := mem_labToZ m)
  end.

Ltac solve_read_m :=
  (unfold nth_labToZ; simpl);
  (unfold Vector.nth_order; simpl);
  (eapply read_m_labToZ; eauto).

Ltac res_label :=
  try match goal with
    | [Hrule: apply_rule _ _ _ = Some (_,_),
       Hcache : cache_up2date_weak _ _,
       CHIT : cache_hit _ _ _ _ |- _ ] =>
      let ASSERT := fresh "Assert" in
      assert (ASSERT := Hcache _ _ _ _ _ Hrule CHIT); eauto;
      simpl in ASSERT;
      inv ASSERT
      end.

Lemma update_cache_hit :
  forall opcode tags pctag tmuc,
    cache_hit (update_cache opcode tags pctag tmuc) opcode tags pctag.
Proof.
  intros.
  destruct tags as [[t1 t2] t3].
  econstructor; econstructor; unfold update_cache;
  rewrite index_list_Z_update_list_list;
  reflexivity.
Qed.

Ltac build_cache_and_tmu :=
  simpl;
  match goal with
    | [Hmiss: ~ cache_hit ?tmuc ?op ?tags ?pct ,
       Hrule: apply_rule _ _ _ = Some _ ,
       i : list Instr
     |- context[ (CState _ ?cm _ _ ?cstk (?pcv,_) _) ] ] =>
      let CHIT := fresh "CHIT" in
      set (tmuc':= update_cache op tags pct tmuc);
      assert (CHIT : cache_hit tmuc' op tags pct)
        by (eauto using update_cache_hit);
      edestruct (handler_correct cm i cstk (pcv,pct) _ _ CHIT Hrule) as [c [Hruns Hmfinal]];
      eauto
  end.

Hint Resolve match_stacks_app match_stacks_data' match_stacks_length : core.

Definition op_cons_ZToLab (oe: Event+τ) (t: list CEvent) :=
  match oe with
    | E (EInt e) => (CEInt (atom_labToZ e))::t
    | Silent => t
  end.

Lemma op_cons_ZToLab_none : (op_cons_ZToLab Silent nil) = (op_cons Silent (@nil CEvent)).
Proof. reflexivity. Qed.

Ltac hint_event := rewrite op_cons_ZToLab_none.

Ltac priv_steps :=
  match goal with
    | [Hruns : runsToEscape ?s ?s',
       Hmfinal: handler_final_mem_matches _ _ _ _ |- _ ] =>
      (eapply runsToEscape_plus in Hruns; [| congruence]);
        let Hll := fresh "Hll" in
        let Hspec := fresh "Hspec" in
      (generalize Hmfinal; intros [Hll Hspec]; inv Hll);
      (simpl atom_labToZ);
      (eapply plus_trans with (s2:= s) (t:= @nil CEvent); eauto);
      try (match goal with
          | [ |- cstep _ _ _ ] =>
            [> once (econstructor; solve [ eauto | eauto; solve_read_m ]) ..]
          | [ |- cstep _ _ _ ] =>
            econstructor ; eauto
           end);
      try match goal with
            | [ |- plus _ _ _ _ ] =>
              (eapply plus_right with (s2:= s') (t:= nil) (e:= Silent); eauto);
              [> once (econstructor; solve [eauto;
                                            try (eapply handler_final_cache_hit_preserved; eauto);
                                            try (solve_read_m; eauto)]) ..]
          end
  end.

Lemma step_preserved:
  forall s1 s1' e s2,
    step_rules (ifc_run_tmr fetch_rule_g) s1 e s1' ->
    match_states fetch_rule_g s1 s2 ->
    (exists s2', plus (step (concrete_machine faultHandler)) s2 (op_cons_ZToLab e nil) s2' /\ match_states fetch_rule_g s1' s2').
Proof.
  intros s1 s1' e s2 Hstep Hmatch.
  inv Hstep; renaming;
  match goal with
    | [Htmr : ifc_run_tmr _ _ _ _ = _ ,
       Hmatch : match_states _ _ _ |- _ ] =>
      inv Hmatch;
      unfold ifc_run_tmr in Htmr
  end;
  generalize (cache_up2date_success CACHE);
  intros CACHE'.

  - (* Noop *)
    destruct (classic (cache_hit tmuc op tags pct)) as [CHIT | CMISS].
    + exists (CState tmuc cm faultHandler i cstk (pcv+1, pct) false).
      res_label. subst pct.
      inv H0.
      split; eauto.
      hint_event.
      eapply plus_step; eauto; eapply cstep_nop; eauto.
      econstructor; eauto.

    + build_cache_and_tmu.
      exists (CState c cm faultHandler i cstk (pcv+1, rpct) false). split.
      * priv_steps.
      * econstructor; eauto.
        inv_cache_update.

 - (* Add *)
   inv STKS. inv H3.
   destruct (classic (cache_hit tmuc op tags pct)) as [CHIT | CMISS].
   + exists (CState tmuc cm faultHandler i ((x1v+x2v,rt):::cs0) (pcv+1,rpct) false).
     split.
     * eapply plus_step ; eauto. eapply cstep_add ; eauto.
       auto.
     * eauto.
       econstructor; eauto.
   + build_cache_and_tmu.
     exists (CState c cm faultHandler i ((CData (x1v+x2v,rt))::cs0) (pcv+1, rpct) false).
     split.
     * priv_steps.
     * econstructor ; eauto.
       inv_cache_update.

 - (* Sub *)
   inv STKS. inv H3.
   destruct (classic (cache_hit tmuc op tags pct)) as [CHIT | CMISS].
   + exists (CState tmuc cm faultHandler i ((x1v-x2v,rt):::cs0) (pcv+1,rpct) false).
     split.
     * eapply plus_step ; eauto. eapply cstep_sub ; eauto.
       auto.
     * eauto.
       econstructor; eauto.
   + build_cache_and_tmu.
     exists (CState c cm faultHandler i ((x1v-x2v,rt):::cs0) (pcv+1, rpct) false).
     split.
     * priv_steps.
     * econstructor ; eauto.
       inv_cache_update.

- (* Push *)
  destruct (classic (cache_hit tmuc op tags pct)) as [CHIT | CMISS].
   + exists (CState tmuc cm faultHandler i ((cv,rt):::cstk) (pcv+1,rpct) false).
     split.
     * eapply plus_step ; eauto. eapply cstep_push ; eauto.
       auto.
     * eauto.
       econstructor; eauto.
   + build_cache_and_tmu.
     exists (CState c cm faultHandler i ((cv,rt):::cstk) (pcv+1, rpct) false). split.
     * priv_steps.
     * econstructor ; eauto.
       inv_cache_update.

- (* Pop *)
  inv STKS.
  destruct (classic (cache_hit tmuc op tags pct)) as [CHIT | CMISS].
  + exists (CState tmuc cm faultHandler i cs (pcv+1,rpct) false).
    hint_event.
    split; eauto.
    eapply plus_step; eauto.
    eapply cstep_pop; eauto.
    econstructor; eauto.
  + build_cache_and_tmu.
    exists (CState c cm faultHandler i cs (pcv+1, rpct) false). split.
    * priv_steps.
    * econstructor; eauto.
      inv_cache_update.

- (* Load *)
  inv STKS.
  destruct (classic (cache_hit tmuc op tags pct)) as [CHIT | CMISS].
   + exists (CState tmuc cm faultHandler i ((xv,rt):::cs) (pcv+1,rpct) false).
     split.
     * eapply plus_step ; eauto.
       eapply cstep_load ; eauto.
       solve_read_m. auto.
     * eauto.
       econstructor; eauto.
   + build_cache_and_tmu.
     exists (CState c cm faultHandler i ((xv,rt):::cs) (pcv+1, rpct) false). split.
     * priv_steps. reflexivity.
     * econstructor ; eauto.
       inv_cache_update.

- (* Store *)
  inv STKS. inv H5.
  exploit upd_m_mem_labToZ ; eauto. intros Hcm'.
  destruct (classic (cache_hit tmuc op tags pct)) as [CHIT | CMISS].
   + exists (CState tmuc (mem_labToZ m') faultHandler i cs0 (pcv+1,rpct) false).
     split.
     * eapply plus_step ; eauto.
       eapply cstep_store  ; eauto.
       solve_read_m. auto.
     * econstructor; eauto.
   + build_cache_and_tmu.
     exists (CState c (mem_labToZ m') faultHandler i cs0 (pcv+1, rpct) false). split.
     * priv_steps. reflexivity.
     * econstructor ; eauto.
       inv_cache_update.

- (* Jump *)
  inv STKS.
  destruct (classic (cache_hit tmuc op tags pct)) as [CHIT | CMISS].
   + exists (CState tmuc cm faultHandler i cs (pcv',rpct) false).
     split.
     * eapply plus_step ; eauto. simpl.
       res_label. hint_event. reflexivity.
     * econstructor; eauto.
   + build_cache_and_tmu. res_label.
     exists (CState c cm faultHandler i cs (pcv', rpct) false). split.
     * priv_steps.
     * econstructor ; eauto.
       inv_cache_update.

- (* Branch *)
  inv STKS.
  destruct (classic (cache_hit tmuc op tags pct)) as [CHIT | CMISS].
   + exists (CState tmuc cm faultHandler i cs
                    (if 0 =? 0 then pcv+1 else pcv+offv , rpct) false).
     split.
     * eapply plus_step ; eauto. res_label.
       eapply cstep_bnz ; eauto. auto.
     * econstructor; eauto.
   + build_cache_and_tmu.
     res_label.
     exists (CState c cm faultHandler i cs
                    (if 0 =? 0 then pcv+1 else pcv+offv , rpct) false).
     split.
     * res_label. priv_steps.
     * econstructor ; eauto.
       inv_cache_update.

- (* Branch YES *)
  inv STKS.
  destruct (classic (cache_hit tmuc op tags pct)) as [CHIT | CMISS].
   + exists (CState tmuc cm faultHandler i cs
                    (if av =? 0 then pcv+1 else pcv+offv , rpct) false).
     split.
     * eapply plus_step ; eauto. res_label.
       eapply cstep_bnz ; eauto. auto.
     * econstructor; eauto.
       case_eq (av =? 0)%Z; intros; auto.
       eelim H1; eauto.
       rewrite Z.eqb_eq in H2. auto.
   + build_cache_and_tmu. res_label.
     exists (CState c cm faultHandler i cs
                    (if av =? 0 then pcv+1 else pcv+offv , rpct) false).
     split.
     * priv_steps.
     * econstructor ; eauto.
       inv_cache_update.
       case_eq (av =? 0)%Z; intros; auto.
       eelim H1; eauto.
       rewrite Z.eqb_eq in H2. auto.

- (* Call *)
  inv STKS.
  edestruct (match_stacks_args' _ _ H4) as [args' [cs' [Heq [Hargs Hcs]]]]; eauto.
  inv Heq.
  destruct (classic (cache_hit tmuc op tags pct)) as [CHIT | CMISS].
   + exists (CState tmuc cm faultHandler i
                    (args'++ (CRet (pcv+1, rt) r false)::cs') (pcv',rpct) false).
     split.
     * eapply plus_step; eauto.
       eapply cstep_call ; eauto.
       auto.
     * econstructor; eauto.
   + build_cache_and_tmu.
     exists (CState c cm faultHandler i
                    (args'++ (CRet (pcv+1, rt) r false)::cs') (pcv',rpct) false).
     split.
     * priv_steps.
     * econstructor ; eauto.
       inv_cache_update.

- (* Ret *)
  exploit @pop_to_return_spec; eauto.
  intros [dstk [stk [a [b [Heq Hdata]]]]]. inv Heq.
  exploit @pop_to_return_spec2; eauto. intros Heq. inv Heq.
  exploit @pop_to_return_spec3; eauto. intros Heq. inv Heq.

  edestruct (match_stacks_args' _ _ STKS) as [args' [cs' [Heq [Hargs Hcs]]]]; eauto.
  inv Heq. inv Hcs. simpl atom_labToZ in *.

  exploit match_stacks_pop_to_return; eauto.
  erewrite match_stacks_length; auto.
  intros.

  destruct (classic (cache_hit tmuc op tags pct)) as [CHIT | CMISS].
  + exists (CState tmuc cm faultHandler i cs (pcv',rpct) false).
     split.
     * simpl. res_label.
     * econstructor; eauto.

   + build_cache_and_tmu.
     exists (CState c cm faultHandler i cs (pcv',rpct) false). res_label.
     split.
     * priv_steps.
     * econstructor ; eauto.
       inv_cache_update.

- (* VRet *)
  inv STKS.
  exploit @pop_to_return_spec; eauto.
  intros [dstk [stk [a [b [Heq Hdata]]]]]. inv Heq.
  exploit @pop_to_return_spec2; eauto. intros Heq. inv Heq.
  exploit @pop_to_return_spec3; eauto. intros Heq. inv Heq.
  edestruct (match_stacks_args' _ _ H4) as [args' [cs' [Heq [Hargs Hcs]]]]; eauto.
  inv Heq. inv Hcs. simpl atom_labToZ in *.
  exploit match_stacks_pop_to_return; eauto.
  erewrite match_stacks_length; auto.
  intros.

  destruct (classic (cache_hit tmuc op tags pct)) as [CHIT | CMISS].
   + exists (CState tmuc cm faultHandler i (CData (resv,rt)::cs) (pcv',rpct) false).
     split.
     * eapply plus_step ; eauto.
       eapply cstep_vret ; eauto.
       auto.
     * econstructor; eauto.
   + build_cache_and_tmu.
     exists (CState c cm faultHandler i (CData (resv,rt)::cs) (pcv',rpct) false).
     split.
     * (eapply runsToEscape_plus in Hruns; [| congruence]);
       (generalize Hmfinal; intros [Hll Hspec]; inv Hll);
       (simpl atom_labToZ).
       (eapply plus_trans with (s2:= (CState tmuc' (mem_labToZ m) faultHandler i
                                             (CRet (pcv, pct) false false
                                                   :: (resv, labToZ resl)
                                                   ::: args' ++ CRet (pcv', labToZ pcl') true false :: cs)
                                             (0, handlerTag) true)); eauto).
       eapply plus_right ; eauto.
       eapply cstep_vret; eauto.
       eapply handler_final_cache_hit_preserved; eauto.
       reflexivity.
     * econstructor ; eauto.
       inv_cache_update.

- (* Output *)
  inv STKS.
  destruct (classic (cache_hit tmuc op tags pct)) as [CHIT | CMISS].
   + exists (CState tmuc cm faultHandler i cs (pcv+1,rpct) false).
     split.
     * eapply plus_step ; eauto.
       eapply cstep_out ; eauto.
       auto.
     * econstructor; eauto.
   + build_cache_and_tmu.
     exists (CState c cm faultHandler i cs (pcv+1, rpct) false).
     split.
     *
       (eapply runsToEscape_plus in Hruns; [| congruence]);
       (generalize Hmfinal; intros [Hll Hspec]; inv Hll);
       (simpl atom_labToZ).
       (eapply plus_trans ; eauto).
       eapply plus_right ; eauto.
       eapply cstep_out; eauto.
       eapply handler_final_cache_hit_preserved; eauto.
       simpl.
       reflexivity.
     * econstructor ; eauto.
       inv_cache_update.
Qed.

Lemma plus_exec :
  forall (S : semantics) s t s',
    plus (step S) s t s' ->
    TINI.exec s t s'.
Proof.
  induction 1 as [s t s' [e|] STEP E|s s' s'' [e|] t t' STEP PLUS IH E]; simpl in *; subst; eauto.
Qed.

Lemma exec_trans :
  forall (S : semantics) (s : Semantics.state S) t1 s' t2 s''
         (E1 : TINI.exec s t1 s')
         (E2 : TINI.exec s' t2 s''),
    TINI.exec s (t1 ++ t2) s''.
Proof. induction 1; simpl; eauto. Qed.

Lemma concrete_quasi_abstract_sref_prop :
  state_refinement_statement (concrete_machine faultHandler)
                             (ifc_quasi_abstract_machine fetch_rule_g)
                             (fun cs qas => match_states fetch_rule_g qas cs)
                             (fun e1 e2 => RefinementAC.match_events e2 e1).
Proof.
  intros s1 s2 t2 s2' MATCH EXEC.
  gdep s1.
  induction EXEC as [s2|s2 e2 s2' t2 s2'' STEP EXEC IH|s2 s2' t2 s2'' STEP EXEC IH]; intros.
  - eexists nil.
    exists s1.
    split; constructor.
  - exploit step_preserved; eauto.
    intros [s1' [PLUS MATCH']].
    exploit IH; eauto.
    intros [t1 [s1'' [EXEC' MATCH'']]].
    exists (op_cons_ZToLab (E e2) t1).
    exists s1''.
    destruct e2 as [e2].
    split.
    + exploit plus_exec; eauto.
      simpl.
      intros.
      exploit exec_trans; eauto.
    + simpl. constructor; eauto.
      destruct e2. reflexivity.
  - exploit step_preserved; eauto.
    intros [s1' [PLUS MATCH']].
    exploit IH; eauto.
    intros [t1 [s1'' [EXEC' MATCH'']]].
    exists (op_cons_ZToLab Silent t1).
    exists s1''.
    split; eauto.
    exploit plus_exec; eauto.
    simpl.
    intros.
    exploit exec_trans; eauto.
Qed.

Definition concrete_quasi_abstract_sref :=
  {| sref_prop := concrete_quasi_abstract_sref_prop |}.

Definition concrete_quasi_abstract_ref :
  refinement (concrete_machine faultHandler)
             (ifc_quasi_abstract_machine fetch_rule_g) :=
  @refinement_from_state_refinement _ _
                                    concrete_quasi_abstract_sref
                                    (fun i1 i2 => ac_match_initial_data i2 i1)
                                    (fun i1 i2 => @ac_match_initial_data_match_initial_states _ _ _ _ _ _ i2 i1).

Lemma step_preserved_observ:
  forall s1 e s1' s2,
    step_rules (ifc_run_tmr fetch_rule_g) s1 e s1' ->
    match_states fetch_rule_g s1 s2 ->
    s1 = observe_cstate s2 /\ (exists s2', plus cstep s2 (op_cons_ZToLab e nil) s2' /\ match_states fetch_rule_g s1' s2').
Proof.
  intros.
  split.
  apply match_observe; auto.
  eapply step_preserved; eauto.
Qed.

End Ref.

(** Combining the above into the final result *)
(** This is where we instantiate the generic refinement *)
Section RefCA.

Context {observer: Type}
        {Latt: JoinSemiLattice observer}
        {CLatt: ConcreteLattice observer}
        {ELatt : Encodable observer}
        {WFCLatt: WfConcreteLattice observer Latt CLatt ELatt}.

Definition tini_fetch_rule_withsig :=
  (fun opcode => existT _
                        (QuasiAbstractMachine.labelCount opcode)
                        (QuasiAbstractMachine.fetch_rule opcode)).
Definition tini_faultHandler := @FaultRoutine.faultHandler observer ELatt
                                                           labelCount
                                                           (ifc_run_tmr fetch_rule)
                                                           (LatticeConcreteLabels (fetch_rule_impl fetch_rule)).
Definition tini_match_states := match_states QuasiAbstractMachine.fetch_rule.

Program Definition concrete_abstract_ref :
  refinement tini_concrete_machine AbstractMachine.abstract_machine :=
  @ref_composition _ _ _
                   concrete_quasi_abstract_ref
                   quasi_abstract_abstract_ref
                   (fun i1 i2 => @ac_match_initial_data _ _ _ _ _ fetch_rule i2 i1)
                   (fun e1 e2 => match_events e2 e1)
                   _ _.

Next Obligation.
  eauto.
Qed.

End RefCA.


Require Import Bool.
Require Import ZArith.
Require Import BinPos.

Require Import Axioms.

Require Import compcert_imports. Import CompcertCommon.

Require Import sepcomp. Import SepComp.
Require Import arguments.

Require Import rc_semantics.

Require Import ssreflect ssrbool ssrfun seq eqtype fintype.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import SM_simulation.

Section rc_2lems.

Variables F_S V_S F_T V_T : Type.

Variables C D : Type.

Variable eff_S : @EffectSem (Genv.t F_S V_S) C.

Variable eff_T : @EffectSem (Genv.t F_T V_T) D.

Variable ge_S : Genv.t F_S V_S.

Variable ge_T : Genv.t F_T V_T.

Variable sim : SM_simulation_inject eff_S eff_T ge_S ge_T.

Lemma rc_sim :
  SM_simulation_inject (RC.effsem eff_S) eff_T ge_S ge_T.
Proof.
case: sim=> cd mtch ord (*d*) e f g h i j init step halt atext aftext.
eapply Build_SM_simulation_inject with
       (core_data   := cd)
       (core_ord    := ord)
       (match_state :=
         fun cd mu c m d tm =>
           mtch cd mu (RC.core c) m d tm); eauto.
{ move=> v vals1 c1 m1 j0 vals2 m2 dS dT.
move=> init1 inj vinj pres pres2 H I J K.
have [c1' init1']:
  exists c1', initial_core eff_S ge_S v vals1 = Some c1'.
{ move: init1; rewrite /= /RC.initial_core.
  case x: (initial_core _ _ _ _)=> //.
  by case; case: c1=> c ?; case=> -> _; exists c. }
move: (init v vals1 c1' m1 j0 vals2 m2 dS dT init1').
case/(_ inj vinj pres pres2 H I J K)=> x []c2' []init2' mtch12.
exists x,c2'; split=> //.
move: init1; rewrite /= /RC.initial_core; rewrite init1'; case.
by case: c1=> ? ?; case=> <- <- /=. }
{ move=> st1 m1 st1' m1' U1 estep cd0 st2 mu m2 mtch12.
move: estep; rewrite /= /RC.effstep=> [][]estep []ctnd' locs.
move: (step (RC.core st1) m1 (RC.core st1') m1' U1 estep cd0).
case/(_ st2 mu m2 mtch12)=> st2' []m2' []cd' []mu'.
case=> incr (*[]sep*) []localloc []mtch12' []U2 []estep' trackback.
exists st2',m2',cd',mu'=> /=.
split=> //.
split=> //.
split=> //.
split=> //.
by exists estep'.
(*by exists U2.*) }
{ move=> cd0 mu c1 m1 c2 m2 v1 M; rewrite /= /RC.halted.
  case hlt1: (halted _ _)=> //.
  case def1: (vals_def _)=> //; case=> <-.
  case: (halt _ _ _ _ _ _ _ M hlt1)=> v2 []? []? ?.
  exists v2; split=> //. }
{ move=> cd0 mu c1 m1 c2 m2 e0 vals1 ef_sig mtch' at1.
have at1': at_external eff_S (RC.core c1) = Some (e0, ef_sig, vals1).
{ move: at1; rewrite /= /RC.at_external.
  by case q: (at_external _ _)=> [[[? ?] ?]|//]; case r: (vals_def _). }
case: (atext cd0 mu (RC.core c1) m1 c2 m2 e0 vals1 ef_sig mtch' at1').
by move=> H H2; split. }
{ move=> cd0 mu st1 st2 m1 e0 vals1 m2 sig vals2 e' ef_sig'.
move=> inj mtch' at1 at2 vinj pSrc' H pTgt' I nu J nu' ret1 m1' ret2 m2'.
move=> ty1 ty2 eincr sep wd val inj' vinj' fwd fwd' fS' K fT' L mu' M unch1 unch2.
have at1': at_external eff_S (RC.core st1) = Some (e0, sig, vals1).
{ move: at1; rewrite /= /RC.at_external.
  by case q: (at_external _ _)=> [[[? ?] ?]|//]; case r: (vals_def _). }
case: (aftext cd0 mu (RC.core st1) st2 m1 e0 vals1 m2 sig vals2 e' ef_sig'
  inj mtch' at1' at2 vinj pSrc' H pTgt' I nu J nu' ret1 m1' ret2 m2'
  ty1 ty2 eincr sep wd val inj' vinj' fwd fwd' fS' K fT' L mu' M unch1 unch2).
move=> cd' []st1' []st2' []aft1' []aft2' mtch12'.
exists cd'.
exists (RC.mk st1' [predU getBlocks [::ret1] & RC.locs st1]).
exists st2'.
split=> //.
by rewrite /= /RC.after_external aft1'. }
Qed.

End rc_2lems.


Require Import CoqlibC.
Require Import Memory.
Require Import Values.
Require Import Maps.
Require Import Events.
Require Import Globalenvs.
Require Import sflib.
Require Import RelationClasses.
Require Import FSets.
Require Import Ordered.
Require Import AST.
Require Import Integers.

(* Require Import IntegersC LinkingC. *)
(* Require Import SimSymb Skeleton Mod ModSem. *)
Require Import ModSem Skeleton.
(* Require SimSymbId. *)
(* Require Import SimMem. *)

Require Import Sound.
Require Import SemiLattice.
Require Import FinFun.

Set Implicit Arguments.

Global Program Instance Top: Sound.class := {
  t := unit;
  lepriv := top2;
  wf := top1;
  val := top2;
  mem := top2;
  mle := top3;
  skenv := top3;
}.
(* Next Obligation. *)
  (* destruct su_gr0, su_gr1; ss. *)
(* Qed. *)
Next Obligation. esplits; eauto. econs; eauto. Qed.
Next Obligation. esplits; eauto. Qed.

Require Import Preservation.

Definition sound_state {STATE: Type}: Sound.t -> mem -> STATE -> Prop := top3.

Lemma sound_state_local_preservation: forall ms,
    <<PRSV: local_preservation ms sound_state>>.
Proof.
  econs; ii; ss; eauto.
  { esplits; eauto. rr. des_ifs. esplits; eauto. rr. rewrite Forall_forall. ii; ss. }
  { esplits; eauto. rr. des_ifs. }
Unshelve.
  all: ss.
Qed.


Require Import Bool.
Require Import ZArith.
Require Import BinPos.

Require Import Axioms.

Require Import concurrency.compcert_imports. Import CompcertCommon.

Require Import concurrency.sepcomp. Import SepComp.
Require Import sepcomp.arguments.

Require Import concurrency.rc_semantics.

From mathcomp.ssreflect Require Import ssreflect ssrbool ssrnat ssrfun seq fintype.
Set Implicit Arguments.

Import SM_simulation.

Section rc_2lems.

Variables F_S V_S F_T V_T : Type.

Variables C D : Type.

Variable eff_S : @EffectSem (Genv.t F_S V_S) C.

Variable eff_T : @EffectSem (Genv.t F_T V_T) D.

Variable ge_S : Genv.t F_S V_S.

Variable ge_T : Genv.t F_T V_T.

Variable sim : SM_simulation_inject eff_S eff_T ge_S ge_T.

Lemma rc_sim :
  SM_simulation_inject (RC.effsem eff_S) eff_T ge_S ge_T.
Proof.
case: sim=> cd mtch ord e f g genv_infos h i j init step halt atext aftext.
eapply Build_SM_simulation_inject with
       (core_data   := cd)
       (core_ord    := ord)
       (match_state :=
         fun cd mu c m d tm =>
           mtch cd mu (RC.core c) m d tm); eauto.
{ move=> v vals1 c1 m1 j0 vals2 m2 dS dT.
move=> init1 inj vinj pres pres2 H I resp1 resp2 J K.
have [c1' init1']:
  exists c1', initial_core eff_S ge_S v vals1 = Some c1'.
{ move: init1; rewrite /= /RC.initial_core.
  case x: (initial_core _ _ _ _)=> //.
  by case; case: c1=> c ?; case=> -> _; exists c. }
move: (init v vals1 c1' m1 j0 vals2 m2 dS dT init1').
case/(_ inj vinj pres pres2 H I resp1 resp2 J K)=> x []c2' []init2' mtch12.
exists x,c2'; split=> //.
move: init1; rewrite /= /RC.initial_core; rewrite init1'; case.
by case: c1=> ? ?; case=> <- <- /=. }
{ move=> st1 m1 st1' m1' U1 estep cd0 st2 mu m2 mtch12.
move: estep; rewrite /= /RC.effstep=> [][]estep []ctnd' locs.
move: (step (RC.core st1) m1 (RC.core st1') m1' U1 estep cd0).
case/(_ st2 mu m2 mtch12)=> st2' []m2' []cd' []mu'.
case=> incr (*[]sep*) []localloc []mtch12' []U2 []estep' trackback.
exists st2',m2',cd',mu'=> /=.
split=> //.
split=> //.
split=> //.
split=> //.
by exists estep'.
(*by exists U2.*) }
{ move=> cd0 mu c1 m1 c2 m2 v1 M; rewrite /= /RC.halted.
  case hlt1: (halted _ _)=> //.
  case def1: (vals_def _)=> //; case=> <-.
  case: (halt _ _ _ _ _ _ _ M hlt1)=> v2 []? []? ?.
  exists v2; split=> //. }
{ move=> cd0 mu c1 m1 c2 m2 e0 vals1 mtch' at1.
have at1': at_external eff_S (RC.core c1) = Some (e0, vals1).
{ move: at1; rewrite /= /RC.at_external.
  by case q: (at_external _ _)=> [[? ?]|//]; case r: (vals_def _). }
case: (atext cd0 mu (RC.core c1) m1 c2 m2 e0 vals1 mtch' at1').
by move=> H H2; split. }
{ move=> cd0 mu st1 st2 m1 e0 vals1 m2 vals2 e'.
move=> inj mtch' at1 at2 vinj pSrc' H pTgt' I nu J nu' ret1 m1' ret2 m2'.
move=> ty1 ty2 eincr sep wd val inj' vinj' fwd fwd' rdo rdo' fS' K fT' L mu' M unch1 unch2.
have at1': at_external eff_S (RC.core st1) = Some (e0, vals1).
{ move: at1; rewrite /= /RC.at_external.
  by case q: (at_external _ _)=> [[? ?]|//]; case r: (vals_def _). }
case: (aftext cd0 mu (RC.core st1) st2 m1 e0 vals1 m2 vals2 e'
  inj mtch' at1' at2 vinj pSrc' H pTgt' I nu J nu' ret1 m1' ret2 m2'
  ty1 ty2 eincr sep wd val inj' vinj' fwd fwd' rdo rdo' fS' K fT' L mu' M unch1 unch2).
move=> cd' []st1' []st2' []aft1' []aft2' mtch12'.
exists cd'.
exists (RC.mk st1' [predU getBlocks [::ret1] & RC.locs st1]).
exists st2'.
split=> //.
by rewrite /= /RC.after_external aft1'. }
Qed.

End rc_2lems.