From sflib Require Import sflib.
From Paco Require Import paco.
Require Import Coq.Classes.RelationClasses Lia Program.
From Fairness Require Export
     ITreeLib WFLib FairBeh Mod pind Axioms
     Linking SCM Red IRed.
From PromisingSEQ Require Import View.
From Ordinal Require Export ClassicalHessenberg.
From Fairness Require Import NatStructsLow.

Set Implicit Arguments.

Module AbsLock.

  Definition lock_fun
    : ktree (programE thread_id (bool * NatMap.t unit)%type) unit unit :=
    fun _ =>
      _ <- trigger Yield;;
      tid <- trigger (GetTid);;
      '(own, ts) <- trigger (Get id);;
      let ts := NatMap.add tid tt ts in
      _ <- trigger (Put (own, ts));;
      _ <- (ITree.iter
             (fun (_: unit) =>
                _ <- trigger Yield;;
                '(own, ts) <- trigger (Get id);;
                if (Bool.eqb own true)
                then Ret (inl tt)
                else Ret (inr tt)) tt);;
      '(_, ts) <- trigger (Get id);;
      let ts := NatMap.remove tid ts in
      _ <- trigger (Put (true, ts));;
      _ <- trigger (Fair (fun i => if tid_dec i tid then Flag.success
                               else if (NatMapP.F.In_dec ts i) then Flag.fail
                                    else Flag.emp));;
      _ <- trigger Yield;;
      Ret tt.

  Definition unlock_fun
    : ktree (programE thread_id (bool * NatMap.t unit)%type) unit unit :=
    fun _ =>
      _ <- trigger Yield;;
      '(own, ts) <- trigger (Get id);;
      if (Bool.eqb own true)
      then _ <- trigger (Put (false, ts));; _ <- trigger Yield;; Ret tt
      else UB.

  Definition mod: Mod.t :=
    Mod.mk
      (false, NatMap.empty unit)
      (Mod.get_funs [("lock", Mod.wrap_fun lock_fun);
                     ("unlock", Mod.wrap_fun unlock_fun)]).

End AbsLock.

Module AbsLockW.

  Definition st := (((bool * View.t) * bool) * NatMap.t unit)%type.

  Definition lock_fun
    : ktree (programE thread_id st) View.t View.t :=
    fun tvw =>
      _ <- trigger Yield;;
      tid <- trigger (GetTid);;
      '(own_lvw, ts) <- trigger (Get id);;
      let ts := NatMap.add tid tt ts in
      _ <- trigger (Put (own_lvw, ts));;
      _ <- (ITree.iter
             (fun (_: unit) =>
                _ <- trigger Yield;;
                '(((own, _), _), _) <- trigger (Get id);;
                match own with
                | true => Ret (inl tt)
                | false => Ret (inr tt)
                end)
             tt);;
      '(((_, tvw_lock), ing), ts) <- trigger (Get id);;
      if (ing: bool)
      (* then UB *)
      then trigger (Choose (void)) >>= (Empty_set_rect _)
      else
        let ts := NatMap.remove tid ts in
        '(exist _ tvw' _) <- trigger (Choose (sig (fun tvw' => View.le (View.join tvw tvw_lock) tvw')));;
        (* to prove weak mem ticket lock, needs to store tvw_lock, not tvw';
           this is related to now_serving's points_to's V and Q, which is not updated at lock
         *)
        _ <- trigger (Put (((true, tvw_lock), false), ts));;
        _ <- trigger (Fair (fun i => if tid_dec i tid then Flag.success
                                 else if (NatMapP.F.In_dec ts i) then Flag.fail
                                      else Flag.emp));;
        _ <- trigger Yield;;
        Ret tvw'.

  Definition unlock_fun
    : ktree (programE thread_id st) View.t View.t :=
    fun tvw =>
      _ <- trigger Yield;;
      '(((own, lvw), ing), ts) <- trigger (Get id);;
      if (excluded_middle_informative (View.le lvw tvw))
      then
        match own, ing with
        | true, false =>
            _ <- trigger (Put (((own, lvw), true), ts));;
            _ <- trigger Yield;;
            '(((_, _), _), ts) <- trigger (Get id);;
            (* tvw_V <- trigger (Choose (View.t));; *)
            '(exist _ tvw_V _) <- trigger (Choose (sig (fun tvw' => View.le tvw tvw')));;
            _ <- trigger (Put (((false, tvw_V), false), ts));;
            (* '(exist _ tvw' _) <- trigger (Choose (sig (fun tvw' => View.le (View.join tvw tvw_V) tvw')));; *)
            '(exist _ tvw' _) <- trigger (Choose (sig (fun tvw' => View.le tvw_V tvw')));;
            _ <- trigger Yield;;
            Ret tvw'
        | _, _ => UB
        end
      else UB.

  Definition mod: Mod.t :=
    Mod.mk
      (((false, View.bot), false), NatMap.empty unit)
      (Mod.get_funs [("lock", Mod.wrap_fun lock_fun);
                     ("unlock", Mod.wrap_fun unlock_fun)]).

End AbsLockW.

(* Module FairLock. *)
(*   Definition lock_fun: WMod.function bool unit void := *)
(*     WMod.mk_fun *)
(*       tt *)
(*       (fun (_: unit) st next => *)
(*          match st with *)
(*          | true => next = WMod.disabled *)
(*          | false => next = WMod.normal true tt (sum_fmap_l (fun _ => Flag.fail)) *)
(*          end). *)

(*   Definition unlock_fun: WMod.function bool unit void := *)
(*     WMod.mk_fun *)
(*       tt *)
(*       (fun (_: unit) st next => *)
(*          match st with *)
(*          | false => next = WMod.stuck *)
(*          | true => next = WMod.normal false tt (sum_fmap_l (fun _ => Flag.emp)) *)
(*          end). *)

(*   Definition wmod: WMod.t := *)
(*     WMod.mk *)
(*       false *)
(*       [("lock", lock_fun); *)
(*        ("unlock", unlock_fun) *)
(*       ]. *)

(*   Definition mod: Mod.t := *)
(*     WMod.interp_mod wmod. *)
(* End FairLock. *)

(* From Fairness Require Export WMM. *)

(* Module FairLockW. *)
(*   Definition lock_fun: WMod.function (option View.t) unit void := *)
(*     WMod.mk_fun *)
(*       tt *)
(*       (fun (tvw: View.t) st next => *)
(*          match st with *)
(*          | None => next = WMod.disabled *)
(*          | Some tvw_lock => *)
(*              next = WMod.normal None (View.join tvw tvw_lock) (sum_fmap_l (fun _ => Flag.fail)) *)
(*          end). *)

(*   Definition unlock_fun: WMod.function (option View.t) unit void := *)
(*     WMod.mk_fun *)
(*       tt *)
(*       (fun (tvw: View.t) st next => *)
(*          match st with *)
(*          | Some _ => next = WMod.stuck *)
(*          | None => next = WMod.normal (Some tvw) tvw (sum_fmap_l (fun _ => Flag.emp)) *)
(*          end). *)

(*   Definition wmod: WMod.t := *)
(*     WMod.mk *)
(*       (Some View.bot) *)
(*       [("lock", lock_fun); *)
(*        ("unlock", unlock_fun) *)
(*       ]. *)

(*   Definition mod: Mod.t := *)
(*     WMod.interp_mod wmod. *)
(* End FairLockW. *)


Require Import Io.All.
Require Model.
Require Import Semantics.

Module C.
  Module DeadLockFree.
    Inductive t {E S A} (m : Model.t E S) (s : S) (x : C.t E A) : Prop :=
    | New :
      (exists p, exists v, C.Last.Eval.t p x v) \/
        (exists c, exists x', exists s', C.Step.t m c s x x' s') ->
      (forall c x' s', C.Step.t m c s x x' s' -> t m s' x') ->
      t m s x.
  End DeadLockFree.
End C.

Module Choose.
  Module DeadLockFree.
    Inductive t {E S A} (m : Model.t E S) (s : S) (x : Choose.t E A) : Prop :=
    | New :
      (exists p, exists v, Choose.Last.Eval.t p x v) \/
        (exists c, exists x', exists s', Choose.Step.t m c s x x' s') ->
      (forall c x' s', Choose.Step.t m c s x x' s' -> t m s' x') ->
      t m s x.
  End DeadLockFree.
End Choose.


Require Import Coq.Lists.List.
Require Import Coq.Bool.Bool.
Require Import NetCore.NetCoreEval.
Require Import Common.Types.
Require Import Classifier.Classifier.
Require Import Word.WordInterface.
Require Import Pattern.Pattern.
(* TODO: MJR Move 'switchId' from messagesDef so that we don't have to include this whole thing *)
Require Import OpenFlow.OpenFlow0x01Types.
Require Import NetCore.NetCoreTypes.
Require Import Network.NetworkPacket.

Set Implicit Arguments.

Import ListNotations.

Fixpoint desugar_pred (p : predicate) := match p with
  | DlSrc eth => PrHdr (Pattern.dlSrc eth)
  | DlDst eth => PrHdr (Pattern.dlDst eth)
  (* | DlTyp typ => PrHdr (Pattern.dlType typ) *)
  (* | DlVlan (Some vlan) => PrHdr (Pattern.dlVlan vlan) *)
  (* | DlVlan None => PrHdr (Pattern.dlVlan VLAN_NONE) *)
  (* | NwProto proto => PrHdr (Pattern.nwProto proto) *)
  | Switch sw => PrOnSwitch sw
  | InPort pt => PrHdr (Pattern.inPort pt)
  | And p1 p2 =>
      (* de Morgan's law *)
      PrNot (PrOr (PrNot (desugar_pred p1)) (PrNot (desugar_pred p2)))
  | Or p1 p2 => PrOr (desugar_pred p1) (desugar_pred p2)
  | Not p => PrNot (desugar_pred p)
  | All => PrAll
  | NoPackets => PrNone
end.

Definition desugar_action (a : action) :=
  match a with
    | To p => Forward unmodified (PhysicalPort  p)
    | ToAll => Forward unmodified AllPorts
    | GetPacket f => ActGetPkt (MkId 0)
  end.

Fixpoint desugar_actions acts :=
  match acts with
    | [] => []
    | a :: acts => (desugar_action a) :: desugar_actions acts
end.

Fixpoint desugar_pol' p pr :=
  match p with
    | Policy pred act => PoAtom (desugar_pred (And pred pr)) (desugar_actions act)
    | Par p1 p2 => PoUnion (desugar_pol' p1 pr) (desugar_pol' p2 pr)
    (* | Restrict p pr' => desugar_pol' p (And pr' pr) *)
  end.

Definition desugar_pol (p : policy) := desugar_pol' p All.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import TableDataOpsIntro.Spec.
Require Import TableDataOpsRef2.Spec.

Local Open Scope Z_scope.

Section SpecLow.

  Definition table_destroy3_spec0 (g_rd: Pointer) (map_addr: Z64) (rtt_addr: Z64) (level: Z64) (adt: RData) : option (RData * Z64) :=
    match g_rd, map_addr, rtt_addr, level with
    | (_g_rd_base, _g_rd_ofst), VZ64 _map_addr, VZ64 _rtt_addr, VZ64 _level =>
      rely is_int64 _map_addr;
      rely is_int64 _rtt_addr;
      rely is_int64 _level;
      when' _t'1, adt == table_destroy2_spec (_g_rd_base, _g_rd_ofst) (VZ64 _map_addr) (VZ64 _rtt_addr) (VZ64 _level) adt;
      rely is_int64 _t'1;
      Some (adt, (VZ64 _t'1))
     end
    .

End SpecLow.


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

Set Implicit Arguments.
Unset Strict Implicit.
Require Export Ring_cat.
(** Title "The category of integral domains." *)
Section Objects.

Definition idomain_prop (R : CRING) :=
  forall x y : R,
  ~ Equal x (monoid_unit R) ->
  ~ Equal y (monoid_unit R) -> ~ Equal (ring_mult x y) (monoid_unit R).

Record idomain_on (R : cring) : Type :=  {idomain_prf : idomain_prop R}.

Record idomain : Type :=
  {idomain_ring :> cring; idomain_on_def :> idomain_on idomain_ring}.
Coercion Build_idomain : idomain_on >-> idomain.

Definition INTEGRAL_DOMAIN :=
  full_subcat (C:=CRING) (C':=idomain) idomain_ring.
End Objects.