Require Import List.
Require Import Bool.
Require Import BinNat.
Require Import Omega.
Require Import sflib.

Require Import Common.
Require Import Memory.
Require Import Value.
Require Import Lang.
Require Import State.
Require Import LoadStore.
Require Import Behaviors.

Module Ir.

Module SmallStep.

Section SMALLSTEP.

Import Ir.Inst.
Variable md:Ir.IRModule.t.

(* Returns basic block id of pc *)
Definition pc_bbid (p:Ir.IRFunction.pc): nat :=
  match p with
  | Ir.IRFunction.pc_phi bbid _ => bbid
  | Ir.IRFunction.pc_inst bbid _ => bbid
  end.

(* Increment pc of the config. *)
Definition incrpc (c:Ir.Config.t) :=
  match (Ir.Config.cur_fdef_pc md c) with
  | Some (fdef, pc0) =>
    match (Ir.IRFunction.next_trivial_pc pc0 fdef) with
    | Some pc' =>
      Ir.Config.update_pc c pc'
    | None => c (* Cannot happen..! *)
    end
  | None => c (* Cannot happen *)
  end.

(* Updates register & Increments PC. *)
Definition update_reg_and_incrpc (c:Ir.Config.t) (r:Ir.reg) (v:Ir.val) :=
  incrpc (Ir.Config.update_rval c r v).

(* Helper functions *)
Definition twos_compl (n:nat) (sz:nat):nat :=
  Nat.modulo n (Nat.shiftl 2 (sz - 1)).

Definition twos_compl_add (x y:nat) (sz:nat):nat :=
  twos_compl (x + y) sz.

Definition twos_compl_sub (x y:nat) (sz:nat):nat :=
  twos_compl (x + (Nat.shiftl 2 (sz - 1)) - y) sz.

Definition to_num (b:bool): Ir.val :=
  Ir.num (if b then 1 else 0).

(* Definition of the result after a step. *)
Inductive step_res :=
| sr_success: Ir.event -> Ir.Config.t -> step_res
| sr_goes_wrong: step_res (* went wrong. *)
| sr_oom: step_res (* out-of-memory *)
| sr_prog_finish: Ir.val -> step_res (* program has finished (with a return value). *)
.

(****************************************************
             Semantics of instructions.
 ****************************************************)

(* Convert a pointer into nat. *)
Definition p2N (p:Ir.ptrval) (m:Ir.Memory.t) (sz:nat):nat :=
  let sz := Nat.min Ir.PTRSZ sz in
  match p with
  | Ir.plog l o =>
    match Ir.log_to_phy m l o with
    | Some (Ir.pphy o' _ _) =>
      twos_compl o' sz
    | _ => twos_compl o sz (* unreachable in well-typed program *)
    end
  | Ir.pphy o _ _ =>
    twos_compl o sz
  end.

(* Pointer subtraction. *)
Definition psub p1 p2 m bsz :=
  match (p1, p2) with
  | (Ir.plog l1 o1, Ir.plog l2 o2) =>
    if Nat.eqb l1 l2 then
      (* psub on two same block *)
      Ir.num (twos_compl (twos_compl_sub o1 o2 Ir.PTRSZ) bsz)
    else
      (* psub on two different blocks *)
      Ir.poison
  (* In all other cases, returns concrete number *)
  | (Ir.pphy o1 _ _, Ir.plog _ _) =>
    Ir.num (twos_compl (twos_compl_sub o1 (p2N p2 m Ir.PTRSZ) Ir.PTRSZ) bsz)
  | (Ir.plog _ _, Ir.pphy o2 _ _) =>
    Ir.num (twos_compl (twos_compl_sub (p2N p1 m Ir.PTRSZ) o2 Ir.PTRSZ) bsz)
  | (Ir.pphy o1 _ _, Ir.pphy o2 _ _) =>
    Ir.num (twos_compl (twos_compl_sub o1 o2 Ir.PTRSZ) bsz)
  end.

(* getelementptr with/without inbounds tag. *)
Definition gep (p:Ir.ptrval) (idx0:nat) (t:Ir.ty) (m:Ir.Memory.t) (inb:bool): Ir.val :=
  let idx := idx0 * (Ir.ty_bytesz t) in
  match p with
  | Ir.plog l o =>
    let o' := twos_compl_add o idx Ir.PTRSZ in
    if inb then
      (* In case of inbounds: check whether input/output pointer is
         within bounds. *)
      match (Ir.Memory.get m l) with
      | Some blk =>
        if Ir.MemBlock.inbounds o blk &&
           Ir.MemBlock.inbounds o' blk then Ir.ptr (Ir.plog l o')
        else Ir.poison (* out of bounds *)
      | None => Ir.poison (* unreachable *)
      end
    else
      (* otherwise: just returns the pointer with updated offset. *)
      Ir.ptr (Ir.plog l o')
  | Ir.pphy o Is cid =>
    let o' := twos_compl_add o idx Ir.PTRSZ in
    if inb then
      if Nat.ltb idx (Nat.shiftl 1 (Ir.PTRSZ - 1)) then
        (* idx is positive. *)
        if Nat.ltb (o + idx) Ir.MEMSZ then
          (* Should not overflow Ir.MEMSZ *)
          Ir.ptr (Ir.pphy o' (o::o'::Is) cid)
        else Ir.poison
      else
        (* idx is negative. *)
        if Nat.leb Ir.MEMSZ (o + idx) then
          (* Should not underflow 0 (= Ir.MEMSZ). *)
          Ir.ptr (Ir.pphy o' (o::o'::Is) cid)
        else Ir.poison
    else
      (* if no inbounds tag, don't update Is. *)
      Ir.ptr (Ir.pphy o' Is cid)
  end.

(* free operation. *)
Definition free p m: option (Ir.Memory.t) :=
  match p with
  | Ir.plog l 0 => Ir.Memory.free m l
  | Ir.pphy o Is cid =>
    (* find a block which corresponds to o. *)
    match (Ir.Memory.zeroofs_block m o) with
    | None => None
    | Some (bid, mb) =>
      if Ir.deref m p 1 then (* to use Is, cid info *)
        Ir.Memory.free m bid
      else None
    end
  | _ => None
  end.

(* Returns true if `icmp eq` on two poiners will return nondeterministic
   value, false otherwise. *)
Definition icmp_eq_ptr_nondet_cond (p1 p2:Ir.ptrval) (m:Ir.Memory.t): bool :=
  match (p1, p2) with
  | (Ir.plog l1 o1, Ir.plog l2 o2) =>
    match (Ir.Memory.get m l1, Ir.Memory.get m l2) with
    | (Some mb1, Some mb2) =>
      (negb (Nat.eqb l1 l2)) && (* two pointers should point to diff. blocks *)
       (* o1 = n /\ o2 = 0 *)
      ((Nat.eqb o1 mb1.(Ir.MemBlock.n) && Nat.eqb o2 0) ||
       (* n < o1 *)
       (mb1.(Ir.MemBlock.n) <? o1) ||
       (* o1 = 0 /\ o2 = n *)
       (Nat.eqb o1 0 && Nat.eqb o2 mb2.(Ir.MemBlock.n)) ||
       (* n < o2 *)
       (mb2.(Ir.MemBlock.n) <? o2) ||
       (* even if offsets are inbounds, comparison result is nondeterministic
          if lifetimes are disjoint.
          Note that using <= is fine because no two blocks can have
          same birth time or end time. *)
       (match (mb1.(Ir.MemBlock.r), mb2.(Ir.MemBlock.r)) with
        | ((b1, None), (b2, None)) => false
        | ((b1, None), (b2, Some e2)) => e2 <=? b1
        | ((b1, Some e1), (b2, None)) => e1 <=? b2
        | ((b1, Some e1), (b2, Some e2)) => (e1 <=? b2) || (e2 <=? b1)
        end))
    | (_, _) => false
    end
  | (_, _) => false
  end.

(* p1 == p2 *)
Definition icmp_eq_ptr (p1 p2:Ir.ptrval) (m:Ir.Memory.t): option bool :=
  match (p1, p2) with
  | (Ir.plog l1 o1, Ir.plog l2 o2) =>
    if Nat.eqb l1 l2 then
      (* ICMP-PTR-LOGICAL *)
      Some (Nat.eqb o1 o2)
    else
      if icmp_eq_ptr_nondet_cond p1 p2 m then None
      else Some false
  | (Ir.pphy o1 Is1 cid1, _) =>
    Some (Nat.eqb o1 (p2N p2 m Ir.PTRSZ))
  | (_, Ir.pphy o2 Is2 cid2) =>
    Some (Nat.eqb (p2N p1 m Ir.PTRSZ) o2)
  end.

(* Returns true if `icmp ule` on two poiners will return nondeterministic
   value, false otherwise. *)
Definition icmp_ule_ptr_nondet_cond (p1 p2:Ir.ptrval) (m:Ir.Memory.t): bool :=
  match (p1, p2) with
  | (Ir.plog l1 o1, Ir.plog l2 o2) =>
    negb (Nat.eqb l1 l2) || (* they point to different blocks, or *)
    match Ir.Memory.get m l1 with
    | Some mb1 =>
      (* ~ (o1 <= n /\ o2 <= n) *)
      (negb (Nat.leb o1 (Ir.MemBlock.n mb1))) ||
      (negb (Nat.leb o2 (Ir.MemBlock.n mb1)))
    | None => false
    end
  | _ => false
  end.

(* p1 <= p2 *)
Definition icmp_ule_ptr (p1 p2:Ir.ptrval) (m:Ir.Memory.t): option bool :=
  if icmp_ule_ptr_nondet_cond p1 p2 m then None
  else Some
    match (p1, p2) with
    | (Ir.plog l1 o1, Ir.plog l2 o2) =>
      (* always l1 = l2 *)
      match (Ir.Memory.get m l1) with
      | Some mb1 => Nat.leb o1 o2
      | None => false (* unreachable *)
      end
    | (Ir.pphy o1 Is1 cid1, _) =>
      Nat.leb o1 (p2N p2 m Ir.PTRSZ)
    | (_, Ir.pphy o2 Is2 cid2) =>
      Nat.leb (p2N p1 m Ir.PTRSZ) o2
    end.

Definition binop (bopc:Ir.Inst.bopcode) (i1 i2:nat) (bsz:nat):nat :=
  match bopc with
  | Ir.Inst.bop_add => twos_compl_add i1 i2 bsz
  | Ir.Inst.bop_sub => twos_compl_sub i1 i2 bsz
  end.

(* Semantics of an instruction which behaves deterministically.
   If IR module of c is well-typed, and this function returns Some (result),
   there is no possible execution other than the result.
   If running the instruction raises nondeterministic result,
   this function returns None. *)
Definition inst_det_step (c:Ir.Config.t): option step_res :=
  match (Ir.Config.cur_inst md c) with
  | Some i =>
    match i with
    | ibinop r opty bopc op1 op2 =>
      Some (sr_success Ir.e_none (update_reg_and_incrpc c r
        match opty with
        | Ir.ity bsz =>
          match (Ir.Config.get_val c op1, Ir.Config.get_val c op2) with
          | (Some (Ir.num i1), Some (Ir.num i2)) => Ir.num (binop bopc i1 i2 bsz)
          | (_, _) => Ir.poison
          end
        | _ => Ir.poison
        end))

    | ifreeze r op retty =>
      match (Ir.Config.get_val c op) with
      | (Some (Ir.num i1)) =>
        Some (sr_success Ir.e_none (update_reg_and_incrpc c r (Ir.num i1)))
      | _ => None
      end

    | iselect r opcond condty op1 op2 opty =>
      Some (sr_success Ir.e_none (update_reg_and_incrpc c r
        match (Ir.Config.get_val c opcond,
               Ir.Config.get_val c op1,
               Ir.Config.get_val c op2) with
        | (Some Ir.poison, _, _) => Ir.poison
        | (Some (Ir.num icond), Some v1, Some v2) =>
           if Nat.eqb icond 1 then v1 else v2
        | (_, _, _) => Ir.poison
        end))

    | ipsub r retty ptrty op1 op2 =>
      Some (sr_success Ir.e_none (update_reg_and_incrpc c r
        match retty with
        | Ir.ity bsz =>
          match (Ir.Config.get_val c op1, Ir.Config.get_val c op2) with
          | (Some (Ir.ptr p1), Some (Ir.ptr p2)) => psub p1 p2 (Ir.Config.m c) bsz
          | (_, _) => Ir.poison
          end
        | _ => Ir.poison
        end))

    | igep r ptrty opptr opidx inb =>
      Some (sr_success Ir.e_none (update_reg_and_incrpc c r
        match ptrty with
        | Ir.ptrty retty =>
          match (Ir.Config.get_val c opptr, Ir.Config.get_val c opidx) with
          | (Some (Ir.ptr p), Some (Ir.num idx)) => gep p idx retty (Ir.Config.m c) inb
          | (_, _) => Ir.poison
          end
        | _ => Ir.poison
        end))

    | iload r retty opptr =>
      match (Ir.Config.get_val c opptr) with
      | (Some (Ir.ptr p)) =>
        if Ir.deref (Ir.Config.m c) p (Ir.ty_bytesz retty) then
          Some (sr_success Ir.e_none (update_reg_and_incrpc c r (Ir.load_val (Ir.Config.m c) p retty)))
        else Some sr_goes_wrong
      | (Some Ir.poison) => Some sr_goes_wrong
      | _ => (* type check fail *)
        Some (sr_success Ir.e_none (update_reg_and_incrpc c r Ir.poison))
      end

    | istore valty opptr opval =>
      match (Ir.Config.get_val c opptr, Ir.Config.get_val c opval) with
      | (Some (Ir.ptr p), Some v) =>
        if Ir.deref (Ir.Config.m c) p (Ir.ty_bytesz valty) then
          Some (sr_success Ir.e_none
                           (incrpc (Ir.Config.update_m c (Ir.store_val (Ir.Config.m c) p v valty))))
        else Some sr_goes_wrong
      | (Some Ir.poison, Some v) => Some sr_goes_wrong
      | (_, _) => (* type check fail *)
        Some (sr_success Ir.e_none (incrpc c))
      end

    | imalloc r opty opval =>
      (* malloc is not determinstic! *)
      None

    | ifree opptr =>
      match (Ir.Config.get_val c opptr) with
      | Some (Ir.ptr p) =>
        match (free p (Ir.Config.m c)) with
        | Some m => Some (sr_success Ir.e_none (incrpc (Ir.Config.update_m c m)))
        | None => Some sr_goes_wrong
        end
      | _ => Some sr_goes_wrong
      end

    | ibitcast r opval retty =>
      Some (sr_success Ir.e_none (update_reg_and_incrpc c r
        match (Ir.Config.get_val c opval) with
        | Some (Ir.ptr p) =>
          match retty with
          | Ir.ptrty _ => Ir.ptr p
          | _ => Ir.poison (* ex: `bitcast i8* to i64' is invalid. *)
          end
        | Some (Ir.num n) =>
          match retty with
          | Ir.ity _ => Ir.num n
          | _ => Ir.poison (* ex: `bitcast i64 to i8*' is invaild. *)
          end
        | _ => Ir.poison
        end))

    | iptrtoint r opptr retty =>
      Some (sr_success Ir.e_none (update_reg_and_incrpc c r
        match retty with
        | Ir.ity retty =>
          match (Ir.Config.get_val c opptr) with
          | Some (Ir.ptr p) => Ir.num (p2N p (Ir.Config.m c) retty)
          | _ => Ir.poison
          end
        | _ => Ir.poison
        end))

    | iinttoptr r opint retty =>
      Some (sr_success Ir.e_none (update_reg_and_incrpc c r
        match retty with
        | Ir.ptrty retty =>
          match (Ir.Config.get_val c opint) with
          | Some (Ir.num n) => Ir.ptr (Ir.pphy (twos_compl n Ir.PTRSZ) nil None)
          | _ => Ir.poison
          end
        | _ => Ir.poison
        end))

    | ievent opval =>
      match (Ir.Config.get_val c opval) with
      | Some (Ir.num n) => Some (sr_success (Ir.e_some n) (incrpc c))
      | _ => Some sr_goes_wrong
      end

    | iicmp_eq r opty op1 op2 =>
      match (Ir.Config.get_val c op1, Ir.Config.get_val c op2) with
      (* Integer comparison *)
      | (Some (Ir.num n1), Some (Ir.num n2)) =>
        Some (sr_success Ir.e_none (update_reg_and_incrpc c r (to_num (Nat.eqb n1 n2))))
      (* Pointer comparison *)
      | (Some (Ir.ptr p1), Some (Ir.ptr p2)) =>
        match (icmp_eq_ptr p1 p2 (Ir.Config.m c)) with
        | Some b => Some (sr_success Ir.e_none (update_reg_and_incrpc c r (to_num b)))
        | None => None (* nondet. result *)
        end
      | (_, _) => (* In other cases, it is untyped. *)
        Some (sr_success Ir.e_none (update_reg_and_incrpc c r Ir.poison))
      end

    | iicmp_ule r opty opptr1 opptr2 =>
      match (Ir.Config.get_val c opptr1, Ir.Config.get_val c opptr2) with
      (* Integer comparison *)
      | (Some (Ir.num n1), Some (Ir.num n2)) =>
        Some (sr_success Ir.e_none (update_reg_and_incrpc c r (to_num (Nat.leb n1 n2))))
      (* Comparison with pointer *)
      | (Some (Ir.ptr p1), Some (Ir.ptr p2)) =>
        match (icmp_ule_ptr p1 p2 (Ir.Config.m c)) with
        | Some b => Some (sr_success Ir.e_none (update_reg_and_incrpc c r (to_num b)))
        | None => None
        end
      | (_, _) => (* In other cases, it is untyped. *)
        Some (sr_success Ir.e_none (update_reg_and_incrpc c r Ir.poison))
      end
    end

  | None => Some sr_goes_wrong
  end.

(* Inductive definition of small-step semantics of instruction. *)
Inductive inst_step: Ir.Config.t -> step_res -> Prop :=
(* small-step with deterministic semantics. *)
| s_det: forall c sr
      (HNEXT:Some sr = inst_det_step c), inst_step c sr

(* freeze, with poison value given as operand *)
| s_freeze: forall c i r op1 isz j
      (HCUR:Some i = Ir.Config.cur_inst md c)
      (HINST:i = Ir.Inst.ifreeze r op1 (Ir.ity isz))
      (HPOISON:Some Ir.poison = Ir.Config.get_val c op1),
    inst_step c (sr_success Ir.e_none
                            (update_reg_and_incrpc c r (Ir.num (twos_compl j isz))))

(* a case where malloc nondeterministically returns NULL.
   This is required because we really cannot expect when
   malloc will return NULL in assembly code. *)
| s_malloc_null: forall c i r szty opsz
      (HCUR:Some i = Ir.Config.cur_inst md c)
      (HINST:i = Ir.Inst.imalloc r szty opsz),
    inst_step c (sr_success Ir.e_none (update_reg_and_incrpc c r (Ir.ptr Ir.NULL)))

(* a case where malloc returned oom. *)
| s_malloc_oom: forall c i r szty opsz nsz
      (HCUR:Some i = Ir.Config.cur_inst md c)
      (HINST:i = Ir.Inst.imalloc r szty opsz)
      (HSZ:Some (Ir.num nsz) = Ir.Config.get_val c opsz)
      (HNOSPACE:~exists (P:list nat),
            Ir.Memory.allocatable (Ir.Config.m c) (List.map (fun addr => (addr, nsz)) P) = true),
    inst_step c sr_oom

(* Malloc which does twin memory allocation.
   P is the list of beginning offsets.
   l is the returned block id. *)
| s_malloc: forall c i r szty opsz nsz (P:list nat) m' l contents
      (HCUR:Some i = Ir.Config.cur_inst md c)
      (HINST:i = Ir.Inst.imalloc r szty opsz)
      (HSZ:Some (Ir.num nsz) = Ir.Config.get_val c opsz)
      (HSZ2:nsz > 0)
      (HC:contents = List.repeat (Ir.Byte.poison) nsz)
      (HMBWF:forall begt, Ir.MemBlock.wf (Ir.MemBlock.mk
                                            (Ir.heap) (begt, None) nsz
                                            (Ir.SYSALIGN) contents P))
      (HDISJ:Ir.Memory.allocatable (Ir.Config.m c)
                       (List.map (fun addr => (addr, nsz)) P) = true)
      (HNEW: (m', l) = Ir.Memory.new (Ir.Config.m c) (Ir.heap) nsz
                                     (Ir.SYSALIGN) contents P),
    inst_step c (sr_success Ir.e_none (update_reg_and_incrpc
                                           (Ir.Config.update_m c m') r
                    (Ir.ptr (Ir.plog l 0))))

(* a case when icmp eq returns value nondeterminstically *)
| s_icmp_eq_nondet: forall c i r opty op1 op2 p1 p2 res
      (HCUR:Some i = Ir.Config.cur_inst md c)
      (HINST:i = Ir.Inst.iicmp_eq r opty op1 op2)
      (HOP1:Some (Ir.ptr p1) = Ir.Config.get_val c op1)
      (HOP2:Some (Ir.ptr p2) = Ir.Config.get_val c op2)
      (HNONDET:icmp_eq_ptr_nondet_cond p1 p2 (Ir.Config.m c) = true),
    inst_step c (sr_success Ir.e_none (update_reg_and_incrpc c r (Ir.num res)))

(* a case when icmp ule returns value nondeterminstically *)
| s_icmp_ule_nondet: forall c i r opty op1 op2 p1 p2 res
      (HCUR:Some i = Ir.Config.cur_inst md c)
      (HINST:i = Ir.Inst.iicmp_ule r opty op1 op2)
      (HOP1:Some (Ir.ptr p1) = Ir.Config.get_val c op1)
      (HOP2:Some (Ir.ptr p2) = Ir.Config.get_val c op2)
      (HNONDET:icmp_ule_ptr_nondet_cond p1 p2 (Ir.Config.m c) = true),
    inst_step c (sr_success Ir.e_none (update_reg_and_incrpc c r (Ir.num res)))

.

(* Result of N small steps on instructions. *)
Inductive inst_nstep: Ir.Config.t -> nat -> Ir.trace * step_res -> Prop :=
| ns_one: forall c sr (HSINGLE:inst_step c sr),
    inst_nstep c 1 (nil, sr)
| ns_success: forall c n c' tr e sr
           (HSUCC: inst_nstep c n (tr, sr_success e c'))
           (HSINGLE: inst_step c' sr),
      inst_nstep c (S n) (e::tr, sr)
| ns_oom: forall c n tr (HOOM: inst_nstep c n (tr, sr_oom)),
    inst_nstep c (S n) (tr, sr_oom)
| ns_goes_wrong: forall c n tr (HGW: inst_nstep c n (tr, sr_goes_wrong)),
    inst_nstep c (S n) (tr, sr_goes_wrong).

(* Categorization of instructions. *)
Definition changes_mem (i:Ir.Inst.t): bool :=
  match i with
  | ibinop _ _ _ _ _ => false
  | ifreeze _ _ _ => false
  | iselect _ _ _ _ _ _ => false
  | ipsub _ _ _ _ _ => false
  | igep _ _ _ _ _ => false
  | iload _ _ _ => false
  | istore _ _ _ => true
  | imalloc _ _ _ => true
  | ifree _ => true
  | ibitcast _ _ _ => false
  | iptrtoint _ _ _ => false
  | iinttoptr _ _ _ => false
  | ievent _ => false
  | iicmp_eq _ _ _ _ => false
  | iicmp_ule _ _ _ _ => false
  end.
Definition never_goes_wrong (i:Ir.Inst.t): bool :=
  match i with
  | ibinop _ _ _ _ _ => true
  | ifreeze _ _ _ => true
  | iselect _ _ _ _ _ _ => true
  | ipsub _ _ _ _ _ => true
  | igep _ _ _ _ _ => true
  | iload _ _ _ => false
  | istore _ _ _ => false
  | imalloc _ _ _ => true
  | ifree _ => false
  | ibitcast _ _ _ => true
  | iptrtoint _ _ _ => true
  | iinttoptr _ _ _ => true
  | ievent _ => false
  | iicmp_eq _ _ _ _ => true
  | iicmp_ule _ _ _ _ => true
  end.
Definition allocates_mem (i:Ir.Inst.t): bool :=
  match i with
  | imalloc _ _ _ => true
  | _ => false
  end.
Definition raises_event (i:Ir.Inst.t): bool :=
  match i with
  | ibinop _ _ _ _ _ => false
  | ifreeze _ _ _ => false
  | iselect _ _ _ _ _ _ => false
  | ipsub _ _ _ _ _ => false
  | igep _ _ _ _ _ => false
  | iload _ _ _ => false
  | istore _ _ _ => false
  | imalloc _ _ _ => false
  | ifree _ => false
  | ibitcast _ _ _ => false
  | iptrtoint _ _ _ => false
  | iinttoptr _ _ _ => false
  | ievent _ => true
  | iicmp_eq _ _ _ _ => false
  | iicmp_ule _ _ _ _ => false
  end.

(****************************************************
             Semantics of terminator.
 ****************************************************)
Definition br (c:Ir.Config.t) (bbid:nat): step_res :=
  match (Ir.Config.cur_fdef_pc md c) with
  | Some (fdef, pc0) =>
    let bbid_old := pc_bbid pc0 in
    match (Ir.IRFunction.get_begin_pc_bb bbid fdef) with
    | Some pc_next =>
      sr_success Ir.e_none (Ir.Config.update_pc c pc_next)
    | None => sr_goes_wrong
    end
  | None => sr_goes_wrong
  end.

Definition t_step (c:Ir.Config.t) : step_res :=
  match (Ir.Config.cur_terminator md c) with
  | Some t =>
    match t with
    | Ir.Terminator.tbr bbid =>
      (* Unconditional branch. *)
      br c bbid

    | Ir.Terminator.tbr_cond condop bbid_t bbid_f =>
      (* Conditional branch. *)
      let tgt :=
          match (Ir.Config.get_val c condop) with
          | Some (Ir.num cond) =>
            if Nat.eqb cond 0 then Some bbid_f
            else Some bbid_t
          | _ => None (* note that 'br poison' is UB. *)
          end in
      match tgt with
      | None => sr_goes_wrong
      | Some bbid => br c bbid
      end

    | Ir.Terminator.tret retop =>
      match (Ir.Config.get_val c retop) with
      | Some v =>
        if Ir.Config.has_nestedcall c then
          (* TODO: Will be revisited later, after 'call' instruction is added. *)
          sr_goes_wrong
        else
          sr_prog_finish v
      (* is there only one activation record in a call stack? *)
      | None => sr_goes_wrong
      end
    end
  | _ => sr_goes_wrong
  end.

(****************************************************
             Semantics of phi node.
 ****************************************************)
Definition phi_step (bef_bbid:nat) (c:Ir.Config.t)
: option Ir.Config.t :=
  match (Ir.Config.cur_phi md c) with
  | Some p =>
    match list_find_key p.(snd) bef_bbid with
    | (_, op0)::_ =>
      match Ir.Config.get_val c op0 with
      | Some v => Some (update_reg_and_incrpc c p.(fst).(fst) v)
      | None => None
      end
    | nil => None
    end
  | _ => None
  end.

Inductive phi_bigstep: nat -> Ir.Config.t -> Ir.Config.t -> Prop :=
| pbs_one:
    forall c c' bef_bbid (HSTEP:phi_step bef_bbid c = Some c'),
    phi_bigstep bef_bbid c c'
| pbs_succ:
    forall c c' c'' bef_bbid
           (HNSTEP:phi_bigstep bef_bbid c c')
           (HSTEP:phi_step bef_bbid c' = Some c''),
    phi_bigstep bef_bbid c c''.

(****************************************************
        Semantics of a general small step.
 ****************************************************)

Definition is_pc_phi (pc0:Ir.IRFunction.pc): bool :=
  match pc0 with
  | Ir.IRFunction.pc_phi _ _ => true
  | _ => false
  end.

Inductive sstep: Ir.Config.t -> step_res -> Prop :=
| ss_inst:
    forall st sr (HISTEP:inst_step st sr),
      sstep st sr
| ss_br_goes_wrong:
    forall st t
           (HCUR:Some t = Ir.Config.cur_terminator md st)
           (HTSTEP:t_step st = sr_goes_wrong),
      sstep st sr_goes_wrong
| ss_br_success:
    (* It is assumed that phi is executed continuously
       after br is executed. This follows Vellvm's style. *)
    forall st0 fdef0 pc0 st' st'' fdef'' pc''
           (HTSTEP:t_step st0 = sr_success Ir.e_none st')
           (HCURPC:Some (fdef0, pc0) = Ir.Config.cur_fdef_pc md st0)
           (HPSTEP:phi_bigstep (pc_bbid pc0) st' st'')
           (HCURPC':Some (fdef'', pc'') = Ir.Config.cur_fdef_pc md st'')
           (HNOT_PHI_ANYMORE:is_pc_phi pc'' = false),
      sstep st0 (sr_success Ir.e_none st'').

End SMALLSTEP.

End SmallStep.

End Ir.


From Tweetnacl.Gen Require Import AMZubSqSel.

Module Gen.

Section ABCDEF.

Context {T : Type}.
Context {T' : Type}.
Context {Mod : T -> T}.
Context {O : @Ops T T' Mod}.

Definition fa r (a b c d e f x:T) :=
  Sel25519 r
     (M (Sq (A (Sel25519 r a b) (Sel25519 r c d)))
        (Sq (Zub (Sel25519 r a b) (Sel25519 r c d))))
     (Sq
        (A
           (M (A (Sel25519 r b a) (Sel25519 r d c))
              (Zub (Sel25519 r a b) (Sel25519 r c d)))
           (M (Zub (Sel25519 r b a) (Sel25519 r d c))
              (A (Sel25519 r a b) (Sel25519 r c d))))).
Definition fb r (a b c d e f x:T) :=
  Sel25519 r
     (Sq
        (A
           (M (A (Sel25519 r b a) (Sel25519 r d c))
              (Zub (Sel25519 r a b) (Sel25519 r c d)))
           (M (Zub (Sel25519 r b a) (Sel25519 r d c))
              (A (Sel25519 r a b) (Sel25519 r c d)))))
     (M (Sq (A (Sel25519 r a b) (Sel25519 r c d)))
        (Sq (Zub (Sel25519 r a b) (Sel25519 r c d)))).
Definition fc r (a b c d e f x:T) :=
Sel25519 r
  (M
     (Zub (Sq (A (Sel25519 r a b) (Sel25519 r c d)))
        (Sq (Zub (Sel25519 r a b) (Sel25519 r c d))))
     (A
        (M
           (Zub (Sq (A (Sel25519 r a b) (Sel25519 r c d)))
              (Sq (Zub (Sel25519 r a b) (Sel25519 r c d)))) C_121665)
        (Sq (A (Sel25519 r a b) (Sel25519 r c d)))))
  (M
     (Sq
        (Zub
           (M (A (Sel25519 r b a) (Sel25519 r d c))
              (Zub (Sel25519 r a b) (Sel25519 r c d)))
           (M (Zub (Sel25519 r b a) (Sel25519 r d c))
              (A (Sel25519 r a b) (Sel25519 r c d))))) x).
Definition fd r (a b c d e f x:T) :=
Sel25519 r
  (M
     (Sq
        (Zub
           (M (A (Sel25519 r b a) (Sel25519 r d c))
              (Zub (Sel25519 r a b) (Sel25519 r c d)))
           (M (Zub (Sel25519 r b a) (Sel25519 r d c))
              (A (Sel25519 r a b) (Sel25519 r c d))))) x)
  (M
     (Zub (Sq (A (Sel25519 r a b) (Sel25519 r c d)))
        (Sq (Zub (Sel25519 r a b) (Sel25519 r c d))))
     (A
        (M
           (Zub (Sq (A (Sel25519 r a b) (Sel25519 r c d)))
              (Sq (Zub (Sel25519 r a b) (Sel25519 r c d)))) C_121665)
        (Sq (A (Sel25519 r a b) (Sel25519 r c d))))).
Definition fe r (a b c d e f x:T) :=
A
  (M (A (Sel25519 r b a) (Sel25519 r d c))
     (Zub (Sel25519 r a b) (Sel25519 r c d)))
  (M (Zub (Sel25519 r b a) (Sel25519 r d c))
     (A (Sel25519 r a b) (Sel25519 r c d))).
Definition ff r (a b c d e f x:T) :=
  Sq (Zub (Sel25519 r a b) (Sel25519 r c d)).

End ABCDEF.

End Gen.


(* 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 List.
Require Export DistributedReferenceCounting.machine3.invariant0.
Require Export DistributedReferenceCounting.machine3.invariant1.
Require Export DistributedReferenceCounting.machine3.invariant2.

Unset Standard Proposition Elimination Names.

(* Where properties of rooted_fun are derived --> this
   should obviously be abstracted and given decent names *)

Section INVARIANT3.
Lemma sigma_rooted_fun2 :
 forall (s s1 s2 : Site) (d : Message),
 s2 <> owner -> s1 <> s -> s2 <> s -> rooted_fun s s1 s2 d = 0%Z.
Proof.
  intros.
  unfold rooted_fun in |- *.
  elim d.
  rewrite case_ineq.
  auto.
  auto.
  intro.
  case (eq_site_dec s0 s).
  intro; rewrite case_ineq.
  auto.
  auto.
  auto.
  rewrite case_ineq.
  auto.
  auto.
Qed.

Lemma sigma_rooted_fun3 :
 forall s1 : Site,
 sigma_but Site owner eq_site_dec LS
   (fun s : Site => rooted_fun s s1 owner dec) = 0%Z.
Proof.
  intro.
  apply sigma_but_null.
  intros.
  unfold rooted_fun in |- *.
  rewrite case_ineq.
  auto.
  auto.
Qed.

Lemma sigma_rooted_fun4 :
 forall (s s1 : Site) (l : list Site),
 ~ In s l ->
 sigma_but Site owner eq_site_dec l
   (fun s0 : Site => rooted_fun s0 s1 owner (inc_dec s)) = 0%Z.
Proof.
  intro; intro; intro.
  elim l.
  simpl in |- *.
  auto.

  simpl in |- *.
  intros.
  rewrite H.
  case (eq_site_dec a owner).
  auto.

  intro.
  case (eq_site_dec s a).
  intro.
  elim H0.
  left; auto.

  auto.

  generalize H0.
  intuition.
Qed.

Lemma sigma_rooted_fun6 :
 forall (s s1 : Site) (l : list Site),
 ~ In s l ->
 sigma_but Site owner eq_site_dec l
   (fun s0 : Site => rooted_fun s0 s owner copy) = 0%Z.
Proof.
  intro; intro; intro.
  elim l.
  simpl in |- *.
  auto.

  simpl in |- *.
  intros.
  case (eq_site_dec a owner).
  intro.
  rewrite H.
  auto.
  generalize H0; intuition.
  intro.
  case (eq_site_dec s a).
  intro.
  elim H0.
  left; auto.
  intro.
  rewrite H.
  auto.
  generalize H0; intuition.
Qed.

Lemma sigma_rooted_fun7 :
 forall (s : Site) (l : list Site),
 only_once Site eq_site_dec s l ->
 s <> owner ->
 sigma_but Site owner eq_site_dec l
   (fun s0 : Site => rooted_fun s0 s owner copy) = 1%Z.

Proof.
  simple induction l.
  simpl in |- *; intuition.

  intros.
  generalize H.
  generalize (sigma_rooted_fun6 s a l0).
  simpl in |- *.
  intros.
  case (eq_site_dec a owner).
  intro.
  rewrite H3.
  auto.

  generalize H0; simpl in |- *.
  case (eq_site_dec s a).
  rewrite e.
  intuition.

  auto.

  auto.

  intro.
  case (eq_site_dec s a).
  intro.
  rewrite H2.
  auto.

  generalize H0; simpl in |- *.
  case (eq_site_dec s a).
  auto.

  intuition.

  intro.
  rewrite H3.
  auto.

  generalize H0.
  simpl in |- *.
  case (eq_site_dec s a).
  intuition.

  auto.

  auto.
Qed.

Lemma sigma_rooted_fun8 :
 forall (s2 : Site) (l : list Site),
 ~ In s2 l ->
 sigma_but Site owner eq_site_dec l
   (fun s : Site => rooted_fun s owner s2 dec) = 0%Z.
Proof.
  intro; intro.
  elim l.
  simpl in |- *.
  auto.
  simpl in |- *.
  intros.
  case (eq_site_dec a owner).
  intro.
  rewrite H.
  auto.
  generalize H0; intuition.
  intro.
  case (eq_site_dec s2 a).
  intro; elim H0.
  left; auto.
  intro.
  rewrite H.
  auto.
  generalize H0; intuition.
Qed.

Lemma sigma_rooted_fun9 :
 forall (s2 : Site) (l : list Site),
 only_once Site eq_site_dec s2 l ->
 s2 <> owner ->
 sigma_but Site owner eq_site_dec l
   (fun s : Site => rooted_fun s owner s2 dec) = 1%Z.
Proof.
  simple induction l.
  simpl in |- *; intuition.
  intros.
  generalize H.
  generalize (sigma_rooted_fun8 s2 l0).
  simpl in |- *.
  intros.
  case (eq_site_dec a owner).
  intros.
  apply H3.
  generalize H0; simpl in |- *.
  case (eq_site_dec s2 a).
  rewrite e.
  intuition.
  auto.
  auto.
  intro.
  case (eq_site_dec s2 a).
  auto.
  intro.
  rewrite H2.
  auto.

  generalize H0.
  rewrite e; simpl in |- *.
  case (eq_site_dec a a).
  auto.

  intuition.

  intro.
  rewrite H3.
  auto.

  generalize H0.
  simpl in |- *.
  case (eq_site_dec s2 a).
  intuition.

  auto.

  auto.
Qed.

Lemma sigma_rooted_fun10 :
 forall s2 : Site,
 sigma_but Site owner eq_site_dec LS
   (fun s : Site => rooted_fun s owner s2 copy) = 0%Z.
Proof.
  intros.
  apply sigma_but_null.
  intros.
  simpl in |- *.
  rewrite case_ineq.
  auto.
  auto.
Qed.

Lemma sigma_rooted_fun11 :
 forall (s1 s2 : Site) (l : list Site),
 s2 <> owner ->
 s1 <> owner ->
 ~ In s2 l ->
 sigma_but Site owner eq_site_dec l (fun s : Site => rooted_fun s s1 s2 dec) =
 0%Z.
Proof.
  intro; intro.
  intro; intro.
  intro.
  simpl in |- *.
  elim l.
  simpl in |- *.
  auto.
  simpl in |- *.
  intros.
  case (eq_site_dec a owner).
  intro.
  rewrite H1.
  auto.
  generalize H2; intuition.
  intro.
  case (eq_site_dec s2 a).
  intro.
  elim H2.
  left; auto.
  intro.
  rewrite H1.
  auto.
  generalize H2; intuition.
Qed.

Lemma sigma_rooted_fun12 :
 forall s1 s2 : Site,
 s2 <> owner ->
 s1 <> owner ->
 only_once Site eq_site_dec s2 LS ->
 sigma_but Site owner eq_site_dec LS (fun s : Site => rooted_fun s s1 s2 dec) =
 1%Z.
Proof.
  intros.
  generalize H1.
  elim LS.
  simpl in |- *.
  intuition.

  simpl in |- *.
  intros.
  case (eq_site_dec a owner).
  intro.
  rewrite H2.
  auto.

  generalize H3.
  case (eq_site_dec s2 a).
  rewrite e.
  intro; elim H; auto.

  auto.

  generalize (sigma_rooted_fun11 s1 s2 l H H0).
  simpl in |- *.
  intros.
  case (eq_site_dec s2 a).
  intro; rewrite H4.
  auto.

  generalize H3.
  case (eq_site_dec s2 a).
  auto.

  intro.
  elim n0; auto.

  intro.
  rewrite H2.
  auto.

  generalize H3.
  case (eq_site_dec s2 a).
  intro; elim n0; auto.

  auto.
Qed.

Lemma sigma_rooted_fun13 :
 forall (s1 s2 : Site) (l : list Site),
 s2 <> owner ->
 s1 <> owner ->
 ~ In s1 l ->
 sigma_but Site owner eq_site_dec l (fun s : Site => rooted_fun s s1 s2 copy) =
 0%Z.
Proof.
   intro; intro.
   intro; intro.
   intro.
   elim l.
   simpl in |- *; auto.
   simpl in |- *.
   intros.
   case (eq_site_dec a owner).
   intro.
   rewrite H1.
   auto.
   generalize H2; intuition.
   intro.
   case (eq_site_dec s1 a).
   intro.
   elim H2.
   left; auto.
   intro.
   rewrite H1.
   auto.
   generalize H2; intuition.
Qed.

Lemma sigma_rooted_fun14 :
 forall (s1 s2 : Site) (l : list Site),
 s2 <> owner ->
 s1 <> owner ->
 only_once Site eq_site_dec s1 l ->
 sigma_but Site owner eq_site_dec l (fun s : Site => rooted_fun s s1 s2 copy) =
 1%Z.
Proof.
  intro; intro; intro; intro; intro.
  elim l.
  simpl in |- *.
  intuition.

  simpl in |- *.
  intros.
  case (eq_site_dec a owner).
  intro.
  rewrite H1.
  auto.

  generalize H2.
  case (eq_site_dec s1 a).
  intro.
  elim H0.
  rewrite e0; rewrite e.
  auto.

  auto.

  intro.
  case (eq_site_dec s1 a).
  intro.
  generalize (sigma_rooted_fun13 s1 s2 l0 H H0).
  simpl in |- *.
  intros.
  rewrite H3.
  auto.

  generalize H2.
  case (eq_site_dec s1 a).
  auto.

  intro.
  elim n0; auto.

  intro.
  rewrite H1.
  auto.

  generalize H2.
  case (eq_site_dec s1 a).
  intro; elim n0; auto.

  auto.
Qed.

Lemma sigma_rooted_fun5 :
 forall s s1 : Site,
 only_once Site eq_site_dec s LS ->
 s <> owner ->
 sigma_but Site owner eq_site_dec LS
   (fun s0 : Site => rooted_fun s0 s1 owner (inc_dec s)) = 1%Z.
Proof.
  intro; intro.
  elim LS.
  simpl in |- *.
  intuition.

  intros.
  case (eq_site_dec a owner).
  intro.
  generalize H0.
  case (eq_site_dec s a).
  rewrite e.
  intuition.

  generalize H.
  simpl in |- *.
  intros.
  rewrite H2.
  case (eq_site_dec a owner).
  auto.

  intuition.

  generalize H3.
  case (eq_site_dec s a).
  intuition.

  auto.

  auto.

  intros.
  generalize H.
  generalize (sigma_rooted_fun4 s s1 l).
  simpl in |- *.
  intros.
  rewrite case_ineq.
  case (eq_site_dec s a).
  intro.
  rewrite H2.
  rewrite case_eq.
  auto.

  generalize H0; simpl in |- *.
  case (eq_site_dec s a).
  auto.

  intuition.

  intros.
  rewrite H3.
  auto.

  generalize H0; simpl in |- *.
  case (eq_site_dec s a).
  intuition.

  auto.

  auto.

  auto.
Qed.

Lemma sigma_rooted_fun1 :
 forall (s s1 s2 : Site) (d : Message),
 s2 <> owner ->
 ~ In s1 LS ->
 ~ In s2 LS ->
 sigma_but Site owner eq_site_dec LS (fun s : Site => rooted_fun s s1 s2 d) =
 0%Z.
Proof.
  intros s s1 s2 d H.
  elim LS.
  simpl in |- *.
  auto.
  intros.
  simpl in |- *.
  case (eq_site_dec a owner).
  intro.
  apply H0.
  generalize H1; simpl in |- *.
  intuition.
  generalize H2; simpl in |- *; intuition.
  intro.
  rewrite H0.
  case (eq_site_dec s1 a).
  generalize H1; simpl in |- *.
  intro.
  intro.
  elim H3.
  left; auto.
  intro.
  case (eq_site_dec s2 a).
  generalize H2; simpl in |- *; intro; intro.
  elim H3.
  left; auto.
  intro.
  rewrite sigma_rooted_fun2.
  omega.
  auto.
  auto.
  auto.
  generalize H1; simpl in |- *; intuition.
  generalize H2; simpl in |- *; intuition.
Qed.

Lemma add_reduce4 :
 forall x y z a : Z, (x + y)%Z = (z + a)%Z -> (x - a)%Z = (z - y)%Z.
Proof.
intros; omega.
Qed.

Lemma add_reduce5 :
 forall x y z a : Z, (x - a)%Z = (z - y)%Z -> x = (a + z - y)%Z.
Proof.
intros; omega.
Qed.

Lemma add_reduce6 : forall x y z : Z, x = (z + y)%Z -> (x - z)%Z = y.
Proof.
intros; omega.
Qed.

End INVARIANT3.


(*
 * Copyright (c) 2009-2011, Andrew Appel, Robert Dockins and Aquinas Hobor.
 *
 *)

Require Import VST.msl.base.
Require Import VST.msl.sepalg.
Require Import VST.msl.psepalg.
Require Import VST.msl.eq_dec.
Require Import VST.msl.shares.

(** The prototypical example of a psepalg is the positive shares, which
    are just the lifted basic shares. *)
Definition pshare : Type := lifted Share.Join_ba.
Instance Join_pshare: Join pshare := @Join_lift _ _.
Instance Perm_pshare : Perm_alg pshare := Perm_lift Share.pa.
Instance Canc_pshare : Canc_alg pshare := @Canc_lift _ _ Share.ca.
Instance Disj_pshare : Disj_alg pshare := @Disj_lift _ _ Share.da.
Instance Pos_pshare : Pos_alg pshare := @Pos_lift _ _.

Definition pshare_sh : pshare -> share := @lifted_obj share Share.Join_ba.
Coercion pshare_sh : pshare >-> share.

Lemma pshare_eq_dec: forall sh1 sh2: pshare, {sh1=sh2}+{sh1<>sh2}.
Proof.
  intros.
  destruct sh1; destruct sh2.
  destruct (eq_dec x x0); [left|right].
  subst x0.
  rewrite (proof_irr n n0); auto.
  intro.
  inv H.
  contradiction n1; auto.
Qed.

Instance EqDec_pshare : EqDec pshare := pshare_eq_dec.

Definition pfullshare : pshare :=
  mk_lifted fullshare top_share_nonunit.

Lemma pfullshare_pfull : full pfullshare.
Proof with auto.
  unfold pshare.
  apply lifted_full. auto with typeclass_instances.
  apply fullshare_full.
Qed.

Lemma join_sub_pfullshare: forall (p: pshare),
  @join_sub share Share.Join_ba pfullshare p ->
  p = pfullshare.
Proof.
  intros. apply join_sub_fullshare in H. apply lifted_eq. trivial.
Qed.

Lemma pjoin_sub_pfullshare: forall (p : pshare),
  join_sub pfullshare p -> False.
Proof.
  intros.
  generalize pfullshare_pfull; intro.
  rewrite pfull_pmaximal in H0.
  generalize (H0 _ H); intro.
  destruct H. subst p.
  apply join_comm in H.
  contradiction (no_units x pfullshare).
Qed.

Lemma pshare_join_full_false1 : forall (p:pshare),
   joins pfullshare p -> False.
Proof.
  intros.
  destruct H. inv H. simpl in *. unfold fullshare in H0.
  rewrite Share.glb_commute in H0. rewrite Share.glb_top in H0.
  destruct p; simpl in *. subst. contradiction (n Share.bot). auto.
Qed.

Lemma pshare_join_full_false2 : forall (p:pshare),
   joins p pfullshare -> False.
Proof.
  intros. apply joins_comm in H. apply pshare_join_full_false1 with p; auto.
Qed.

Lemma pshare_join_full_false3: forall (p1: pshare) sh3,
  join (lifted_obj p1) Share.top sh3 -> False.
Proof.
  intros.
  destruct p1. unfold lifted_obj, pfullshare, mk_lifted, proj1_sig in H.
  destruct H. rewrite Share.glb_top in H. subst. contradiction (n Share.bot); auto.
Qed.

Lemma pshare_join_full_false4: forall (p1: pshare) sh3,
  join Share.top (lifted_obj p1) sh3 -> False.
Proof.
  intros.
  eapply pshare_join_full_false3. apply join_comm in H. eauto.
Qed.

Lemma pshare_pjoin_full_false3: forall (p1: pshare) pp sh3,
   join p1 (mk_lifted Share.top pp) sh3 -> False.
Proof.
  intros. destruct sh3.
  do 2 red in H. simpl lifted_obj in *.
 apply pshare_join_full_false3 in H. trivial.
Qed.

Lemma pshare_pjoin_full_false4: forall (p1: pshare) pp sh3,
   join (mk_lifted Share.top pp) p1 sh3 -> False.
Proof.
  intros. destruct sh3.
  do 2 red in H. simpl lifted_obj in *.
  apply pshare_join_full_false4 in H. trivial.
Qed.

Ltac pfullshare_join :=
  elimtype False;
  solve [ eapply pshare_join_full_false1; eauto
    | eapply pshare_join_full_false2; eauto
    | eapply pshare_join_full_false3; eauto
    | eapply pshare_join_full_false4; eauto
    | eapply pshare_pjoin_full_false3; eauto
    | eapply pshare_pjoin_full_false4; eauto
  ].

Program Definition split_pshare (sh: pshare) : pshare * pshare :=
  (mk_lifted (fst (Share.split sh)) _, mk_lifted (snd (Share.split sh)) _).
Next Obligation.
Proof.
  intros.
  case_eq (Share.split (proj1_sig sh)); simpl.
  intros.
  generalize (split_nontrivial' _ _ _ H); intro.
  intros ? ?. apply unit_identity in H1. destruct sh; simpl in H0.
  assert (identity x0) by auto. contradiction (n x0).
  apply identity_unit_equiv in H2; auto.
Qed.
Next Obligation.
Proof.
  intros.
  case_eq (Share.split (proj1_sig sh)); simpl.
  intros.
  generalize (split_nontrivial' _ _ _ H); intro.
  intros ? ?. apply unit_identity in H1. destruct sh; simpl in H0.
  assert (identity x0) by auto. contradiction (n x0).
  apply identity_unit_equiv in H2; auto.
Qed.

Lemma psplit_split: forall psh psha pshb,
  (split_pshare psh = (psha, pshb)) =
  (Share.split (lifted_obj psh) = (lifted_obj psha, lifted_obj pshb)).
Proof.
  unfold split_pshare, lifted_obj.
  intros. apply prop_ext. split; intro.
  inversion H.
  apply injective_projections; auto.
  apply injective_projections; apply lifted_eq; simpl; rewrite H; auto.
Qed.

Lemma psplit_pjoin: forall psh psha pshb,
  split_pshare psh = (psha, pshb) ->
   join psha pshb psh.
Proof.
  intros.
  rewrite psplit_split in H.
  apply split_join in H.
  trivial.
Qed.

Lemma pshare_split_neq1: forall psh psh1 psh2, split_pshare psh = (psh1, psh2) -> psh1 <> psh.
Proof.
  intros.
  apply psplit_pjoin in H.
  intro contra. subst psh1.
  apply  join_comm in H.
  apply pjoin_unit in H. trivial.
Qed.

Lemma pshare_split_neq2: forall psh psh1 psh2, split_pshare psh = (psh1, psh2) -> psh2 <> psh.
Proof.
  intros.
  apply psplit_pjoin in H.
  intro contra. subst psh2.
  apply pjoin_unit in H. trivial.
Qed.

Definition pLhalf : pshare := fst (split_pshare pfullshare).
Definition pRhalf : pshare := snd (split_pshare pfullshare).

Lemma pleftright :  join pLhalf pRhalf pfullshare.
Proof.
  apply psplit_pjoin.
  trivial.
Qed.

Lemma pshare_nonunit: forall sh: pshare, nonunit (pshare_sh sh).
Proof. repeat intro. destruct sh; simpl in *. apply n in H. auto.
Qed.

Lemma pshare_not_identity: forall sh: pshare, ~ identity (pshare_sh sh).
Proof. intros. apply nonunit_nonidentity. apply pshare_nonunit.
Qed.


Require Import ExtLib.Core.RelDec.
Require Import MirrorCore.Lambda.Expr.
Require Import MirrorCore.Lambda.AppN.
Require Import MirrorCharge.ILogicFunc.
Require Import MirrorCharge.Imp.Syntax.

Set Implicit Arguments.
Set Strict Implicit.

Local Existing Instance SS.
Local Existing Instance SU.
Local Existing Instance RSym_ilfunc.
Local Existing Instance RS.
Local Existing Instance Expr_expr.

Local Notation "a @ b" := (@App typ _ a b) (at level 30).
Local Notation "\ t -> e" := (@Abs typ _ t e) (at level 40).
Local Notation "'Ap' '[' x , y ']'" := (Inj (inl (inr (pAp x y)))) (at level 0).
Local Notation "'Pure' '[' x ']'" := (Inj (inl (inr (pPure x)))) (at level 0).
Local Notation "x '|-' y" :=
  (App (App (Inj (inr (ilf_entails (tyArr tyLocals tyHProp)))) x) y) (at level 10).
Local Notation "'{{'  P  '}}'  c  '{{'  Q  '}}'" :=
  (Inj (inl (inl 1%positive)) @ P @ c @ Q) (at level 20).
Local Notation "c1 ;; c2" := (Inj (inl (inl 2%positive)) @ c1 @ c2) (at level 30).

Fixpoint expr_eq (a b : expr typ func) : option bool :=
  match a , b with
    | Var a , Var b => if a ?[ eq ] b then Some true else None
    | UVar a , UVar b => if a ?[ eq ] b then Some true else None
    | Inj a , Inj b => SymI.sym_eqb a b
    | App a b , App c d =>
      match expr_eq a c with
        | Some true => expr_eq b d
        | _ => None
      end
    | Abs t a , Abs t' b => expr_eq a b
    | _ , _ => None
  end.

Section interp_get.
  Variable v : expr typ func.

  Definition compare_expr (e1 e2 : expr typ func) : option bool :=
    expr_eq e1 e2.

  Fixpoint interp_get (updf : expr typ func)
  : expr typ func :=
    match updf with
      | App (App (Inj (inl (inr pLocals_upd))) v') val =>
        match compare_expr v v' with
          | Some true =>
            lpure tyNat val
          | Some false =>
            App flocals_get v
          | None =>
            App (App (Inj (inl (inr (pUpdate tyNat)))) updf) (App flocals_get v)
        end
      | _ =>
        App (App (Inj (inl (inr (pUpdate tyNat)))) updf) (App flocals_get v)
    end.
End interp_get.

Section pushUpdates.
  Variable f : expr typ func.

  Fixpoint pushUpdates (e : expr typ func) (t : typ)
  : expr typ func :=
    match e with
      | App (App (Inj (inl (inr (pStar t)))) L) R =>
        lstar t (pushUpdates L t) (pushUpdates R t)
      | Inj (inr (ilf_true t)) => Inj (inr (ilf_true t))
      | Inj (inr (ilf_false t)) => Inj (inr (ilf_false t))
      | App (App (Inj (inr (ilf_and t))) L) R =>
        App (App (Inj (inr (ilf_and t))) (pushUpdates L t)) (pushUpdates R t)
      | App (App (Inj (inr (ilf_or t))) L) R =>
        App (App (Inj (inr (ilf_or t))) (pushUpdates L t)) (pushUpdates R t)
      | App (App (Inj (inr (ilf_impl t))) L) R =>
        App (App (Inj (inr (ilf_impl t))) (pushUpdates L t)) (pushUpdates R t)
      | App (Inj (inr (ilf_exists X t))) (Abs t' e) =>
        App (Inj (inr (ilf_exists X t))) (Abs t' (pushUpdates e t))
      | App (Inj (inr (ilf_forall X t))) (Abs t' e) =>
        App (Inj (inr (ilf_forall X t))) (Abs t' (pushUpdates e t))
      | App (Pure [t]) e =>
        App (Pure [t]) e
      | App (App (Ap [t1,t2]) e1) e2 =>
        App (App (Ap [t1,t2]) (pushUpdates e1 (tyArr t1 t2))) (pushUpdates e2 t1)
      | App (Inj (inl (inr pLocals_get))) v =>
        interp_get v f
      | _ => App (App (Inj (inl (inr (pUpdate t)))) f) e
    end.
End pushUpdates.

Definition simplify (e : expr typ func) (args : list (expr typ func))
: expr typ func :=
  match e with
    | Inj (inl (inr pEval_expri)) =>
      match args with
        | App (Inj (inl (inr eVar))) X :: xs =>
          apps (App flocals_get X) xs
        | _ => apps e args
      end
    | Inj (inl (inr (pUpdate t))) =>
      match args with
        | f :: e :: nil =>
          pushUpdates f e t
        | _ => apps e args
      end
    | _ => apps e args
  end.


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

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************)
(*           The Calculus of Inductive Constructions            *)
(*                       COQ v5.10                              *)
(*                                                              *)
(* Laurent Arditi.  Laboratoire I3S. CNRS ura 1376.             *)
(* Universite de Nice - Sophia Antipolis                        *)
(* arditi@unice.fr, http://wwwi3s.unice.fr/~arditi/lolo.html    *)
(*                                                              *)
(* date: november 1995                                          *)
(* file: Fill_spec.v                                            *)
(* contents: proof of a memory block instruction: Fills cx words*)
(* in memory starting at address di with value al.              *)
(* Specification level                                          *)
(****************************************************************)

Require Export Fill_defs.

(* Specification:

cx: register a_size
di: register a_size
al: register d_size
mem: memory of d_size bit words, addresses of a_size bits

while not(cx=0) do begin
  mem[di] <- al
  di <- di+1
  cx <- cx-1
end
*)

(****************************************************************)

Fixpoint di (st : nat) : BV -> BV -> BV -> Memo -> BV :=
  fun (di0 cx0 al0 : BV) (mem0 : Memo) =>
  match st return BV with
  | O => di0
  | S t =>
      match IsNull (cx t di0 cx0 al0 mem0) return BV with
      | true => di t di0 cx0 al0 mem0
      | false => BV_increment (di t di0 cx0 al0 mem0)
      end
  end

 with cx (st : nat) : BV -> BV -> BV -> Memo -> BV :=
  fun (di0 cx0 al0 : BV) (mem0 : Memo) =>
  match st return BV with
  | O => cx0
  | S t =>
      match IsNull (cx t di0 cx0 al0 mem0) return BV with
      | true => cx t di0 cx0 al0 mem0
      | false => BV_decrement (cx t di0 cx0 al0 mem0)
      end
  end

 with al (st : nat) : BV -> BV -> BV -> Memo -> BV :=
  fun (di0 cx0 al0 : BV) (mem0 : Memo) =>
  match st return BV with
  | O => al0
  | S t =>
      match IsNull (cx t di0 cx0 al0 mem0) return BV with
      | true => al t di0 cx0 al0 mem0
      | false => al t di0 cx0 al0 mem0
      end
  end

 with mem (st : nat) : BV -> BV -> BV -> Memo -> Memo :=
  fun (di0 cx0 al0 : BV) (mem0 : Memo) =>
  match st return Memo with
  | O => mem0
  | S t =>
      match IsNull (cx t di0 cx0 al0 mem0) return Memo with
      | true => mem t di0 cx0 al0 mem0
      | false =>
          MemoWrite (mem t di0 cx0 al0 mem0)
            (BV_to_nat (di t di0 cx0 al0 mem0)) (al t di0 cx0 al0 mem0)
      end
  end.

(****************************************************************)
(* Valeurs generales des registres *)

Lemma di_t :
 forall (t : nat) (di0 cx0 al0 : BV) (mem0 : Memo),
 di (S t) di0 cx0 al0 mem0 =
 match IsNull (cx t di0 cx0 al0 mem0) return BV with
 | true => di t di0 cx0 al0 mem0
 | false => BV_increment (di t di0 cx0 al0 mem0)
 end.
auto.
Qed.

Lemma cx_t :
 forall (t : nat) (di0 cx0 al0 : BV) (mem0 : Memo),
 cx (S t) di0 cx0 al0 mem0 =
 match IsNull (cx t di0 cx0 al0 mem0) return BV with
 | true => cx t di0 cx0 al0 mem0
 | false => BV_decrement (cx t di0 cx0 al0 mem0)
 end.
auto.
Qed.

Lemma al_t :
 forall (t : nat) (di0 cx0 al0 : BV) (mem0 : Memo),
 al (S t) di0 cx0 al0 mem0 =
 match IsNull (cx t di0 cx0 al0 mem0) return BV with
 | true => al t di0 cx0 al0 mem0
 | false => al t di0 cx0 al0 mem0
 end.
auto.
Qed.

Lemma al_constant :
 forall (t : nat) (di0 cx0 al0 : BV) (mem0 : Memo),
 al t di0 cx0 al0 mem0 = al0.
simple induction t. auto.
intros. rewrite al_t. elim (IsNull (cx n di0 cx0 al0 mem0)). apply H. apply H.
Qed.

Lemma mem_t :
 forall (t : nat) (di0 cx0 al0 : BV) (mem0 : Memo),
 mem (S t) di0 cx0 al0 mem0 =
 match IsNull (cx t di0 cx0 al0 mem0) return Memo with
 | true => mem t di0 cx0 al0 mem0
 | false =>
     MemoWrite (mem t di0 cx0 al0 mem0) (BV_to_nat (di t di0 cx0 al0 mem0))
       (al t di0 cx0 al0 mem0)
 end.
auto.
Qed.
(****************************************************************)
(* Longueurs des registres *)

Lemma length_di :
 forall t : nat, lengthbv (di t di_init cx_init al_init mem_init) = a_size.
simple induction t. simpl in |- *. exact di_initsize.
intros.
rewrite di_t. elim (IsNull (cx n di_init cx_init al_init mem_init)). exact H.
rewrite length_BV_increment. exact H.
Qed.

Lemma length_cx :
 forall t : nat, lengthbv (cx t di_init cx_init al_init mem_init) = a_size.
simple induction t. simpl in |- *. exact cx_initsize.
intros.
rewrite cx_t. elim (IsNull (cx n di_init cx_init al_init mem_init)). exact H.
rewrite length_BV_decrement. exact H.
Qed.

Lemma length_al :
 forall t : nat, lengthbv (al t di_init cx_init al_init mem_init) = d_size.
intro. rewrite al_constant. exact al_initsize.
Qed.


(* Copyright (c) 2011. Greg Morrisett, Gang Tan, Joseph Tassarotti,
   Jean-Baptiste Tristan, and Edward Gan.

   This file is part of RockSalt.

   This file is free software; you can redistribute it and/or
   modify it under the terms of the GNU General Public License as
   published by the Free Software Foundation; either version 2 of
   the License, or (at your option) any later version.
*)

Require Coqlib.
Require Import Parser.
Require Import Ascii.
Require Import String.
Require Import List.
Unset Automatic Introduction.
Set Implicit Arguments.
Open Scope char_scope.

Require ExtrOcamlString.
Require ExtrOcamlNatBigInt.
(*Require ExtrOcamlNatInt.*)

Module TEST_PARSER_ARG.
  Definition char_p := bool.
  Definition char_eq := Bool.bool_dec.

  Inductive type : Set :=
  | Int_t : type.

  Definition tipe := type.
  Definition tipe_eq : forall (t1 t2:tipe), {t1=t2} + {t1<>t2}.
    intros ; decide equality.
  Defined.
  Definition tipe_m (t:tipe) :=
    match t with
      | Int_t => nat
    end.
End TEST_PARSER_ARG.

Module TEST_PARSER.
Module T := Parser.Parser(TEST_PARSER_ARG).
Import TEST_PARSER_ARG.
Import T.
Infix "|+|" := Alt_p (right associativity, at level 80).
Infix "$" := Cat_p (right associativity, at level 70).
Definition map_p t1 t2 (p:parser t1) (f:result_m t1 -> result_m t2) := @Map_p t1 t2 f p.
Implicit Arguments map_p [t1 t2].
Infix "@" := map_p (right associativity, at level 75).
Definition Plus_p t (p:parser t) :=
  (Cat_p p (Star_p p)) @ (fun p => ((fst p)::(snd p)): result_m (list_t t)).
Definition Alts_p t (ps:list (parser t)) :=
  List.fold_right (@Alt_p t) (Zero_p t) ps.
Definition int_t := tipe_t Int_t.
Notation "e %% t" := (e : result_m t) (at level 80).

Definition one := Char_p true @ (fun _ => 1 %% int_t).
Definition zero := Char_p false @ (fun _ => 0 %% int_t).
Definition bit' := zero |+| one.
Definition bit := Any_p @ (fun c => (if c then 1 else 0) %% int_t).
Definition nibble :=
  bit $ bit $ bit $ bit @
  (fun x => match x with
              | (b3,(b2,(b1,b0))) => b0 + 2*b1 + 4*b2 + 8*b3
            end %% int_t).
Definition byte :=
  nibble $ nibble @ (fun p => (snd p + (fst p)*256) %% int_t).

(* is a parser deterministic for strings up to length n? *)
Definition is_deterministic t (p:parser t) n :=
  is_determ (snd (parser2regexp p)) 2 (fun n => (match n with 0 => false | _ => true end)::nil) n
  (fst (parser2regexp p)) (p2r_wf p _).

Lemma is_deterministic_byte : is_deterministic byte 8 = true.
Proof.
  auto.
Qed.

Definition ambiguous_p := nibble |+| nibble.

Lemma is_deterministic_ambiguous_p : is_deterministic ambiguous_p 4 = false.
Proof.
  auto.
Qed.

Fixpoint explode(s:string) : list bool :=
  match s with
    | ""%string => nil
    | String "0" t => false::(explode t)
    | String _ t => true::(explode t)
  end.

Definition lex t (p:parser t) s := parse p (explode s).

(*
Opaque result_m.
Opaque p2r_wf.
Opaque wf_derivs.
Eval compute in lex (nibble) "0101". *)
End TEST_PARSER.


(*
 * Strong Normalization for Nested Relational Calculus.
 * Copyright Ezra Cooper, 2008-2020.
 *)

Add Rec LoadPath "Listkit" as Listkit.

Require Import List.
Require Import Term.

Load "eztactics.v".

Require Import Listkit.NthError.

Hint Rewrite app_comm_cons : list.

(** Weaken a typing derivation by extending its environment
    and it still holds. *)
Lemma Weakening :
  forall env' tm ty env, Typing env tm ty ->
    Typing (env++env') tm ty.
Proof.
 induction tm; intros ty env tp; inversion tp; eauto with NthError.
  apply TAbs.
  autorewrite with list.
  seauto.
 apply TBind with s.
  apply IHtm1; sauto.
 autorewrite with list.
 apply IHtm2; sauto.
Qed.

(** Special case of weakening for closed terms. *)
Lemma Weakening_closed :
  forall tm ty env, Typing nil tm ty -> Typing env tm ty.
Proof.
 intros tm ty env H.
 replace env with (nil ++ env); auto using Weakening.
Qed.

#[export]
Hint Resolve Weakening_closed.


Require Import Coq.Logic.ProofIrrelevance.
Require Import Coq.Sets.Ensembles.
Require Import Coq.Sets.Finite_sets.
Require Import Coq.Lists.List.
Require Import Coq.Classes.Morphisms.
Require Import CertiGraph.lib.Coqlib.
Require Import CertiGraph.lib.List_ext.
Require Import CertiGraph.lib.EquivDec_ext.
Require Import VST.msl.Coqlib2.
Require Import CertiGraph.graph.graph_model.
Require Import CertiGraph.graph.path_lemmas. Import CertiGraph.graph.path_lemmas.PathNotation.
Require Import CertiGraph.graph.reachable_computable.
Require Import CertiGraph.graph.reachable_ind.
Require Import CertiGraph.graph.subgraph2.

Section Dag.

Context {V : Type}.
Context {E : Type}.
Context {EV: EqDec V eq}.
Context {EE: EqDec E eq}.

Notation Graph := (PreGraph V E).

Definition not_in_circle (g: Graph) (x: V) := forall y: V, edge g x y -> reachable g y x -> False.

Definition localDag (g: Graph) (x: V) := forall y, reachable g x y -> not_in_circle g y.

Definition Dag (g: Graph) := forall x, not_in_circle g x.

Lemma local_dag_step: forall (g: Graph) x y, localDag g x -> vvalid g x -> step g x y -> localDag g y.
Proof.
  intros.
  unfold localDag in *.
  intros z ?.
  apply (H z).
  apply step_reachable with y; auto.
Qed.

Lemma dag_local_dag: forall (g: Graph) x, Dag g -> localDag g x.
Proof.
  intros.
  intro; intros.
  apply H.
Qed.

Lemma si_local_dag: forall (g1 g2: Graph) x, g1 ~=~ g2 -> (localDag g1 x <-> localDag g2 x).
Proof.
  cut (forall (g1 g2: Graph) x, g1 ~=~ g2 -> localDag g1 x -> localDag g2 x).
  1: intros; split; apply H; [| symmetry]; auto.
  intros.
  hnf; intros.
  rewrite <- H in H1.
  specialize (H0 _ H1); clear H1.
  hnf; intros.
  pose proof edge_si _ _ y y0 H.
  rewrite <- H3 in H1.
  rewrite <- H in H2.
  specialize (H0 _ H1 H2).
  auto.
Qed.

Lemma si_dag: forall (g1 g2: Graph), g1 ~=~ g2 -> (Dag g1 <-> Dag g2).
Proof.
  cut (forall (g1 g2: Graph), g1 ~=~ g2 -> Dag g1 -> Dag g2).
  1: intros; split; apply H; [| symmetry]; auto.
  intros.
  hnf; intros.
  hnf; intros.
  pose proof edge_si _ _ x y H.
  rewrite <- H in H2.
  rewrite <- H3 in H1.
  specialize (H0 _ _ H1 H2).
  auto.
Qed.

#[export] Instance local_dag_proper: Proper (structurally_identical ==> eq ==> iff) localDag.
Proof.
  do 2 (hnf; intros).
  subst.
  apply si_local_dag; auto.
Defined.

#[export] Instance dag_proper: Proper (structurally_identical ==> iff) Dag.
Proof.
  hnf; intros.
  apply si_dag; auto.
Defined.

Lemma localDag_reachable_spec: forall g x S,
  vvalid g x ->
  localDag g x ->
  step_list g x S ->
  (forall y, reachable g x y <-> reachable_through_set g S y \/ y = x) /\
  (forall y, reachable_through_set g S y -> y <> x).
Proof.
  intros.
  split; intros.
  + rewrite (reachable_ind' g x S y H H1).
    assert (x = y <-> y = x) by (split; congruence).
    tauto.
  + destruct H2 as [x0 [? ?]].
    rewrite (H1 x0) in H2.
    specialize (H0 x).
    spec H0; [apply reachable_refl; auto |].
    specialize (H0 x0).
    assert (vvalid g x0) by (apply reachable_head_valid in H3; auto).
    assert (edge g x x0) by (split; [| split]; auto).
    spec H0; [auto |].
    intro; subst; tauto.
Qed.

Lemma localDag_reachable_spec': forall g x S,
  vvalid g x ->
  localDag g x ->
  step_list g x S ->
  Prop_join (reachable_through_set g S) (eq x) (reachable g x).
Proof.
  intros.
  destruct (localDag_reachable_spec _ _ _ H H0 H1).
  split.
  + intros y; specialize (H2 y).
    rewrite H2; clear.
    firstorder.
  + intros y; specialize (H3 y).
    firstorder.
Qed.

Lemma localDag_reachable_list_spec: forall g x S l,
  vvalid g x ->
  localDag g x ->
  step_list g x S ->
  reachable_list g x l ->
  reachable_set_list g S (remove equiv_dec x l).
Proof.
  intros.
  intro y.
  specialize (H2 y).
  rewrite remove_In_iff.
  rewrite H2.
  rewrite (reachable_ind' g x S y H H1).
  assert (x = y <-> y = x) by (split; intros; congruence).
  assert (reachable_through_set g S y -> y <> x); [| tauto].
  specialize (H0 x).
  spec H0; [apply reachable_refl; auto |].
  intros [z [? ?]] ?.
  subst.
  specialize (H0 z).
  rewrite (H1 z) in H4.
  apply H0; auto.
  split; [| split]; auto.
  apply reachable_head_valid in H5; auto.
Qed.

Lemma localDag_step_rev: forall g x S,
  vvalid g x ->
  step_list g x S ->
  ~ reachable_through_set g S x ->
  Forall (localDag g) S ->
  localDag g x.
Proof.
  intros.
  intros y ?; simpl.
  rewrite (reachable_ind' g x S y H H0) in H3.
  destruct H3.
  + subst y.
    intros y ? ?.
    apply H1; exists y; split; auto.
    rewrite (H0 y).
    destruct H3 as [? [? ?]]; auto.
  + destruct H3 as [s [? ?]].
    rewrite Forall_forall in H2; specialize (H2 s H3).
    apply H2; auto.
Qed.

End Dag.


Require Import RelationClasses.
Require Import List.
Require Import Omega.
Require Import sflib.
From Paco Require Import paco.
Require Import Basics.

Require Import Basic.
Require Import Axioms.
Require Import Loc.
Require Import Language.
Require Import ZArith.
Require Import Maps.
Require Import Iteration.

Require Import FSets.
Require Import FSetInterface.
Require Import Lattice.
Require Import Event.
Require Import Syntax.
Require Import Semantics.
Require Import Kildall.
Require Import Coqlib.

Require Import Integers.
Require Import LibTactics.
Require Import CorrectOpt.
Require Import Lib_Ordering.
Set Implicit Arguments.

(** * Loop Invariant Detecting *)

(** This file defines the analysis to detect loop invariants. *)

(** ** Evaluation of the Dominator *)
(** For each block labelled f, its NDominators returns whether a node f' is
    its dominators.
    If f' maps to true, it means that f' is not the dominator of f;
    if f' maps to false, it means that f' is the dominator of f. *)
Module NDominators := LPMap(LBoolean).
Module NDomDS := Dataflow_Solver(NDominators)(NodeSetForward).

(** [dominator] justifies that whether the block labelled f' is the
    dominator of the block that we focus on. *)
Definition dominator (ndom: NDominators.t) (f': positive) :=
  if NDominators.get f' ndom then false else true.

(** ** Back Edge *)
(** After evaluating the dominators of each block, we can find the loop.
    l_entry and l_exit are entry and exit of a loop,
    if l_exit points to l_entry and l_entry dominates l_exit. *)
Definition back_edge (l_exit l_entry: positive)
           (ndom: NDominators.t) (cdhp: CodeHeap) :=
  match PTree.get l_exit cdhp with
  | Some BB =>
    In l_entry (succ BB) /\ dominator ndom l_entry = true
  | None => False
  end.

Lemma back_edge_eq_dec
      l_exit l_entry ndom cdhp:
  {back_edge l_exit l_entry ndom cdhp} + {~ back_edge l_exit l_entry ndom cdhp}.
Proof.
  unfold back_edge.
  destruct (cdhp ! l_exit) eqn:EXIT; ss.
  2: { right. ii; eauto. }
  pose proof in_dec as LIST_IN_EQ_DEC.
  specialize (LIST_IN_EQ_DEC Language.fid).
  assert (forall x y: positive, {x = y} + {x <> y}).
  {
    ii. eapply Pos.eq_dec; eauto.
  }
  eapply LIST_IN_EQ_DEC with (l := succ t) (a := l_entry) in H.
  destruct H.
  {
    destruct (dominator ndom l_entry) eqn:IS_IN_DOM; ss.
    eauto.
    right. ii. des. ss.
  }
  {
    right. ii. des. eapply n in H. tryfalse.
  }
Qed.

(** Finding the back edge, whose exit node is l_exit. *)
Fixpoint back_edge' (l_exit: positive) (ls: list (positive * BBlock.t))
         (ndom: NDominators.t) (cdhp: CodeHeap) :=
  match ls with
  | nil => nil
  | (l, _) :: ls' =>
    if back_edge_eq_dec l_exit l ndom cdhp then
      (l_exit, l) :: back_edge' l_exit ls' ndom cdhp
    else
      back_edge' l_exit ls' ndom cdhp
  end.

(** Finding all the back edges in the code heap. *)
Fixpoint back_edges' (ls: list (positive * BBlock.t))
         (ndoms: PMap.t NDomDS.L.t) (cdhp: CodeHeap) :=
  match ls with
  | nil => nil
  | (l_exit, _) :: ls' =>
    match ((snd ndoms) ! l_exit) with
    | None => back_edges' ls' ndoms cdhp
    | Some ndom =>
      (back_edge' l_exit (PTree.elements cdhp) ndom cdhp)
        ++ back_edges' ls' ndoms cdhp
    end
  end.

Definition back_edges (ndoms: PMap.t NDomDS.L.t) (cdhp: CodeHeap):
  list (Language.fid * Language.fid) :=
  back_edges' (PTree.elements cdhp) ndoms cdhp.

(** ** Detecting Loops *)
(** We define [Reach](l, l', cdhp, l_entry) to determinate
    whether l can reach l' and does not pass l_entry *)
Fixpoint Reach'(l l': positive) (cdhp: CodeHeap) (l_entry: positive)
         (ls: list positive) (n: nat) : bool :=
  match n with
  | 0%nat => false
  | S n' =>
    match ls with
    | nil => false
    | l0 :: ls' =>
      if Ident.eq_dec l0 l' then true else
        if Ident.eq_dec l0 l_entry then
          Reach' l l' cdhp l_entry ls' n'
        else
          match (PTree.get l0 cdhp) with
          | None => Reach' l l' cdhp l_entry ls' n'
          | Some BB =>
            match (Reach' l0 l' cdhp l_entry (succ BB) n') with
            | true => true
            | false =>
              Reach' l l' cdhp l_entry ls' n'
            end
          end
    end
  end.

Definition Reach (l l': Language.fid) (cdhp: CodeHeap) (l_entry: positive) : bool :=
  if Ident.eq_dec l l_entry then false else
    match (PTree.get l cdhp) with
    | None => false
    | Some BB =>
      Reach' l l' cdhp l_entry (succ BB) (Pos.to_nat PrimIter.num_iterations)
    end.

(** ** Natural Loop *)
(** [natural_loop] returns the list of nodes that belong to the loop,
    where l_exit and l_entry construct the back edge of the loop. *)
Definition in_loop (l l_exit l_entry: positive) (cdhp: CodeHeap) (ndom: NDominators.t) :=
  dominator ndom l_entry && Reach l l_exit cdhp l_entry.
Fixpoint natural_loop'
         (l_exit l_entry: Language.fid) (cdhp: CodeHeap) (ndoms: PMap.t NDomDS.L.t)
         (ls: list (Language.fid * BBlock.t)) :=
  match ls with
  | nil => IdentSet.empty
  | (l, _) :: ls' =>
    match ((snd ndoms) ! l) with
    | None => IdentSet.empty
    | Some ndom => if in_loop l l_exit l_entry cdhp ndom then
                    IdentSet.add l (natural_loop' l_exit l_entry cdhp ndoms ls')
                  else
                    natural_loop' l_exit l_entry cdhp ndoms ls'
    end
  end.

Definition natural_loop (l_exit l_entry: positive) (cdhp: CodeHeap) (ndoms: PMap.t NDomDS.L.t) :=
  natural_loop' l_exit l_entry cdhp ndoms (PTree.elements cdhp).

(** ** Detecting Loops  *)
(** [det_loops] returns the list of loops.
    The loop is represented as a tuple:
    - l_entry: entry point;
    - l_exit: exit point;
    - ls: list of nodes in the loop. *)
Fixpoint det_loops' (cdhp: CodeHeap) (ndoms: PMap.t NDomDS.L.t)
         (bk_edges: list (positive * positive)) :=
  match bk_edges with
  | nil => nil
  | (l_exit, l_entry) :: bk_edges' =>
    match (PTree.get l_exit cdhp), (PTree.get l_entry cdhp) with
    | Some BB_exit, Some BB_entry =>
      (l_entry, l_exit, natural_loop l_exit l_entry cdhp ndoms) :: det_loops' cdhp ndoms bk_edges'
    | _, _ => det_loops' cdhp ndoms bk_edges'
    end
  end.

Definition transf (p: positive) (ndom: NDomDS.L.t) :=
  NDominators.set p false ndom.

Definition det_loops (cdhp: CodeHeap) (ep: positive) :=
  match NDomDS.fixpoint cdhp succ transf ep NDominators.top with
  | Some ndoms =>
    det_loops' cdhp ndoms (back_edges ndoms cdhp)
  | None => nil
  end.

(** ** Loop Invariants *)
Inductive LOOP_INV : Set :=
| LINV_EXPR (r: Reg.t) (e: Inst.expr)
| LINV_LOC (r: Reg.t) (loc: Loc.t).

Fixpoint expr_is_loop_inv (e: Inst.expr) (loop_invs: list LOOP_INV) :=
  match loop_invs with
  | nil => False
  | (LINV_EXPR r' e') :: loop_invs =>
    if Inst.expr_eq_dec e e' then True
    else  expr_is_loop_inv e loop_invs
  | _ :: loop_invs => expr_is_loop_inv e loop_invs
  end.

Lemma in_expr_linv_eq_dec:
  forall(loop_invs: list LOOP_INV) e,
    {expr_is_loop_inv e loop_invs} + {~ expr_is_loop_inv e loop_invs}.
Proof.
  induction loop_invs; ss; ii.
  - right. ii; ss.
  - destruct a; ss.
    des_if; eauto.
Qed.

(** [not_write_regs](rs, RS_W) returns true,
    if all the registers in rs have not been written. *)
Fixpoint not_write_regs (rs: list Reg.t) (RS_W: RegSet.t) :=
  match rs with
  | r :: rs' => if RegSet.mem r RS_W then false
               else not_write_regs rs' RS_W
  | nil => true
  end.

(** An expression e is an loop invariant, if
    - all its registers have not been written;
    - it has not been detected as a loop invariant.

    Reading from a location loc is an loop invariant, if
    - it is a non-atomic location;
    - it has not been written by other instrucitons.
 *)
Fixpoint loop_invB (BB: BBlock.t) (RS_W: RegSet.t) (LS_W: LocSet.t)
         (max_reg: Reg.t) (loop_invs: list LOOP_INV) (lo: Ordering.LocOrdMap) :=
  match BB with
  | (Inst.assign r e) ## BB' =>
    if (not_write_regs (RegSet.elements (Inst.regs_of_expr e)) RS_W) then
      if in_expr_linv_eq_dec loop_invs e then
        loop_invB BB' RS_W LS_W max_reg loop_invs lo
      else
        loop_invB BB' RS_W LS_W (Pos.succ max_reg) ((LINV_EXPR max_reg e) :: loop_invs) lo
    else
      loop_invB BB' RS_W LS_W max_reg loop_invs lo
  | (Inst.load r loc Ordering.plain) ## BB' =>
    match (lo loc) with
    | Ordering.nonatomic =>
      if LocSet.mem loc LS_W then
        loop_invB BB' RS_W LS_W max_reg loop_invs lo
      else
        loop_invB BB' RS_W LS_W (Pos.succ max_reg) ((LINV_LOC max_reg loc) :: loop_invs) lo
    | Ordering.atomic =>
      loop_invB BB' RS_W LS_W max_reg loop_invs lo
    end
  | _ ## BB' =>
    loop_invB BB' RS_W LS_W max_reg loop_invs lo
  | _ => (loop_invs, max_reg)
  end.

Fixpoint loop_invBS (BS: list BBlock.t) (RS_W: RegSet.t) (LS_W: LocSet.t)
         (max_reg: Reg.t) (loop_invs: list LOOP_INV) (lo: Ordering.LocOrdMap) :=
  match BS with
  | BB :: BS' =>
    match loop_invB BB RS_W LS_W max_reg loop_invs lo with
    | (loop_invs', max_reg') =>
      loop_invBS BS' RS_W LS_W max_reg' loop_invs' lo
    end
  | nil => (loop_invs, max_reg)
  end.

(** [loop_invC] returns the loop invariants in the code heap. *)
Definition RS_W_instr (c: Inst.t) :=
  match c with
  | Inst.skip => RegSet.empty
  | Inst.assign reg rhs => RegSet.singleton reg
  | Inst.load reg loc _ => RegSet.singleton reg
  | Inst.store loc rhs _ => RegSet.empty
  | Inst.cas reg loc er ew _ _ => RegSet.singleton reg
  | Inst.print e => RegSet.empty
  | _ => RegSet.empty
  end.

Definition LS_W_instr (c: Inst.t) :=
  match c with
  | Inst.skip => LocSet.empty
  | Inst.assign reg rhs => LocSet.empty
  | Inst.load reg loc _ => LocSet.empty
  | Inst.store loc rhs _ => LocSet.singleton loc
  | Inst.cas reg loc er ew _ _ => LocSet.empty
  | Inst.print e => LocSet.empty
  | _ => LocSet.empty
  end.

Fixpoint RS_LS_W_evalB (BB: BBlock.t) :=
  match BB with
  | c ## BB' => match RS_LS_W_evalB BB' with
               | (rsw, lsw) =>
                 (RegSet.union (RS_W_instr c) rsw, LocSet.union (LS_W_instr c) lsw)
               end
  | _ => (RegSet.empty, LocSet.empty)
  end.

Fixpoint RS_LS_W_eval (ls: list Language.fid) (cdhp: CodeHeap) :=
  match ls with
  | l :: ls' =>
    match (PTree.get l cdhp) with
    | Some BB =>
      let (rsw1, lsw1) := RS_LS_W_evalB BB in
      let (rsw2, lsw2) := RS_LS_W_eval ls' cdhp in
      (RegSet.union rsw1 rsw2, LocSet.union lsw1 lsw2)
    | None => RS_LS_W_eval ls' cdhp
    end
  | nil => (RegSet.empty, LocSet.empty)
  end.

Fixpoint BS_in_loops (ls: list Language.fid) (cdhp: CodeHeap) :=
  match ls with
  | l :: ls' =>
    match (PTree.get l cdhp) with
    | Some BB => BB :: (BS_in_loops ls' cdhp)
    | None => BS_in_loops ls' cdhp
    end
  | nil => nil
  end.

Fixpoint loop_invC' (loops: list (positive * positive * IdentSet.t))
         (max_reg0: Reg.t) (cdhp: CodeHeap) (lo: Ordering.LocOrdMap) :=
  match loops with
  | (l_entry, l_exit, iset) :: loops' =>
    let ls := IdentSet.elements iset in
    let (rsw, lsw) := RS_LS_W_eval ls cdhp in
    let BS := BS_in_loops ls cdhp in
    let (loop_invs, max_reg) :=
        loop_invBS BS rsw lsw max_reg0 nil lo in
    (l_entry, l_exit, loop_invs) :: loop_invC' loops' max_reg cdhp lo
  | nil => nil
  end.

Definition loop_invC (lo: Ordering.LocOrdMap) (func: Func) :=
  let (cdhp, ep) := func in
  let loops := det_loops cdhp ep in
  let rs := regs_of_cdhp cdhp in
  match (RegSet.max_elt rs) with
  | None => loop_invC' loops 1%positive cdhp lo
  | Some max_reg => loop_invC' loops (Pos.succ max_reg) cdhp lo
  end.

Lemma loopinv_det_prop1:
  forall loops max_reg cdhp lo l_entry l_exit loopinvs
    (IN: In (l_entry, l_exit, loopinvs) (loop_invC' loops max_reg cdhp lo)),
  exists ls, In (l_entry, l_exit, ls) loops.
Proof.
  induction loops; ii; ss.
  destruct a. destruct p.
  destruct (RS_LS_W_eval (IdentSet.elements t) cdhp) eqn:Heqe1; ss.
  destruct (loop_invBS (BS_in_loops (IdentSet.elements t) cdhp) t0 t1 max_reg nil lo) eqn:Heqe2; ss.
  des1. inv IN; ss. eexists. left. eauto.
  eapply IHloops in IN; eauto. des1.
  exists ls. right; eauto.
Qed.

Lemma loopinv_det_prop2':
    forall bk_edges cdhp ndoms l_entry l_exit ls
      (IN: In (l_entry, l_exit, ls) (det_loops' cdhp ndoms bk_edges)),
      <<ENTRY_IN: exists BB, PTree.get l_entry cdhp = Some BB>> /\
      <<EXIT_IN: exists BB, PTree.get l_exit cdhp = Some BB>>.
Proof.
  induction bk_edges; ii; ss.
  destruct a; ss.
  destruct (cdhp ! p) eqn:GET_FID1; ss;
    destruct (cdhp ! p0) eqn:GET_FID2; ss;
      try solve [eapply IHbk_edges in IN; eauto].
  des1. inv IN; ss. split; eauto.
  eapply IHbk_edges in IN; eauto.
Qed.

Lemma loopinv_det_prop2
          cdhp ep l_entry l_exit ls
          (IN: In (l_entry, l_exit, ls) (det_loops cdhp ep)):
  <<ENTRY_IN: exists BB, PTree.get l_entry cdhp = Some BB>> /\
  <<EXIT_IN: exists BB, PTree.get l_exit cdhp = Some BB>>.
Proof.
  unfold det_loops in *.
  destruct (NDomDS.fixpoint cdhp succ transf ep NDominators.top) eqn:Heqe; ss.
  eapply loopinv_det_prop2'; eauto.
Qed.

Lemma wf_loop_invC1
      cdhp l_entry l_exit loopinvs lo ep
      (LOOP_INV: In (l_entry, l_exit, loopinvs) (loop_invC lo (cdhp, ep))):
  <<ENTRY_IN: exists BB, PTree.get l_entry cdhp = Some BB>> /\
  <<EXIT_IN: exists BB, PTree.get l_exit cdhp = Some BB>>.
Proof.
  unfold loop_invC in *.
  destruct (RegSet.max_elt (regs_of_cdhp cdhp)) eqn: MAX_REG.
  - renames e to max_reg.
    eapply loopinv_det_prop1 in LOOP_INV; eauto. des1.
    eapply loopinv_det_prop2; eauto.
  - eapply loopinv_det_prop1 in LOOP_INV; eauto. des1.
    eapply loopinv_det_prop2; eauto.
Qed.

Lemma loop_invB_reg_prop:
  forall BB rsw lsw max_reg loopinvs lo loopinvs' t
    (LOOP_INVB: loop_invB BB rsw lsw max_reg loopinvs lo = (loopinvs', t)),
    (max_reg <= t)%positive.
Proof.
  induction BB; ii; ss; eauto;
    try solve [inv LOOP_INVB; rewrite Pos.compare_refl in H; ss].
  destruct c; ss; eauto; try solve [eapply IHBB in LOOP_INVB; eauto].
  des_ifH LOOP_INVB; ss;
    try solve [eapply IHBB in LOOP_INVB; eauto].
  des_ifH LOOP_INVB; ss;
    try solve [eapply IHBB in LOOP_INVB; eauto].
  eapply IHBB in LOOP_INVB; eauto.
  assert (SUCC_LT: (max_reg < Pos.succ max_reg)%positive).
  {
    eapply Pos.lt_succ_diag_r; eauto.
  }
  assert (SUCC_LT': (max_reg < t)%positive).
  {
    eapply Pos.lt_le_trans; eauto.
  }
  rewrite SUCC_LT' in H. ss.
  pose proof (nonatomic_or_atomic or). des1.
  - subst.
    destruct (lo loc) eqn:LOC_AT_OR_NA; ss.
    eapply IHBB in LOOP_INVB; eauto.
    des_ifH LOOP_INVB; ss.
    {
      eapply IHBB in LOOP_INVB; eauto.
    }
    {
      eapply IHBB in LOOP_INVB; eauto.
      assert (SUCC_LT: (max_reg < Pos.succ max_reg)%positive).
      {
        eapply Pos.lt_succ_diag_r; eauto.
      }
      assert (SUCC_LT': (max_reg < t)%positive).
      {
        eapply Pos.lt_le_trans; eauto.
      }
      rewrite SUCC_LT' in H. ss.
    }
  - assert (match or with
              | Ordering.plain =>
                  match lo loc with
                  | Ordering.atomic => loop_invB BB rsw lsw max_reg loopinvs lo
                  | Ordering.nonatomic =>
                      if LocSet.mem loc lsw
                      then loop_invB BB rsw lsw max_reg loopinvs lo
                      else loop_invB BB rsw lsw (Pos.succ max_reg) (LINV_LOC max_reg loc :: loopinvs) lo
                  end
              | _ => loop_invB BB rsw lsw max_reg loopinvs lo
            end =
            loop_invB BB rsw lsw max_reg loopinvs lo).
    {
      destruct or; ss; eauto.
    }
    rewrite H1 in LOOP_INVB. clear H1.
    eapply IHBB in LOOP_INVB; eauto.
Qed.

Lemma loop_invB_reg_prop':
  forall BB rsw lsw max_reg loopinvs loopinvs' lo max_reg' r
    (LOOP_INVB: loop_invB BB rsw lsw max_reg loopinvs lo = (loopinvs', max_reg'))
    (IN: (exists e, In (LINV_EXPR r e) loopinvs') \/ (exists loc, In (LINV_LOC r loc) loopinvs')),
    ((exists e, In (LINV_EXPR r e) loopinvs) \/ (exists loc, In (LINV_LOC r loc) loopinvs)) \/
    (max_reg <= r)%positive.
Proof.
  induction BB; ii; ss; eauto;
    try solve [inv LOOP_INVB; eauto].
  destruct c; ss; eauto.
  - des_ifH LOOP_INVB; ss.
    des_ifH LOOP_INVB; ss;
      try solve [eapply IHBB in LOOP_INVB; eauto].
    eapply IHBB in LOOP_INVB; eauto.
    des1.
    {
      des1; ss. des1; ss. des1. inv LOOP_INVB. right.
      eapply POrderedType.Positive_as_DT.le_refl; eauto.
      left. eauto.
      des1. des1. inv LOOP_INVB. eauto.
    }
    {
      assert (SUCC_LT: (max_reg < Pos.succ max_reg)%positive).
      {
        eapply Pos.lt_succ_diag_r; eauto.
      }
      assert (SUCC_LT': (max_reg < r)%positive).
      {
        eapply Pos.lt_le_trans; eauto.
      }
      right. eapply POrderedType.Positive_as_DT.lt_le_incl; eauto.
    }
    eapply IHBB in LOOP_INVB; eauto.
  - pose proof (nonatomic_or_atomic or). des1.
    {
      subst.
      destruct (lo loc) eqn:LOC; ss.
      eapply IHBB in LOOP_INVB; eauto.
      des_ifH LOOP_INVB; ss; eauto.
      eapply IHBB in LOOP_INVB; eauto.
      des1.
      des1.
      des1; ss. des1. inv LOOP_INVB. eauto.
      des1; ss. des1. inv LOOP_INVB.
      right. eapply POrderedType.Positive_as_DT.le_refl; eauto.
      eauto.
      assert (SUCC_LT: (max_reg < Pos.succ max_reg)%positive).
      {
        eapply Pos.lt_succ_diag_r; eauto.
      }
      assert (SUCC_LT': (max_reg < r)%positive).
      {
        eapply Pos.lt_le_trans; eauto.
      }
      right. eapply POrderedType.Positive_as_DT.lt_le_incl; eauto.
    }
    {
      assert (match or with
              | Ordering.plain =>
                  match lo loc with
                  | Ordering.atomic => loop_invB BB rsw lsw max_reg loopinvs lo
                  | Ordering.nonatomic =>
                      if LocSet.mem loc lsw
                      then loop_invB BB rsw lsw max_reg loopinvs lo
                      else loop_invB BB rsw lsw (Pos.succ max_reg) (LINV_LOC max_reg loc :: loopinvs) lo
                  end
              | _ => loop_invB BB rsw lsw max_reg loopinvs lo
              end = loop_invB BB rsw lsw max_reg loopinvs lo).
      {
        destruct or; ss.
      }
      rewrite H0 in LOOP_INVB; clear H0; ss.
      eapply IHBB in LOOP_INVB; eauto.
    }
Qed.

Lemma loop_invBS_reg_prop:
  forall BS rsw lsw max_reg max_reg' loopinvs0 loopinvs max_reg'' lo r
    (LOOP_INVBS: loop_invBS BS rsw lsw max_reg' loopinvs0 lo = (loopinvs, max_reg''))
    (REG: (exists e, In (LINV_EXPR r e) loopinvs) \/ (exists loc, In (LINV_LOC r loc) loopinvs))
    (GT: (max_reg < max_reg')%positive),
    ((exists e, In (LINV_EXPR r e) loopinvs0) \/ (exists loc, In (LINV_LOC r loc) loopinvs0)) \/
    (max_reg' <= r)%positive.
Proof.
  induction BS; ii; ss.
  - inv LOOP_INVBS.
    left. eauto.
  - destruct (loop_invB a rsw lsw max_reg' loopinvs0 lo) eqn:Heqe; ss.
    eapply IHBS in LOOP_INVBS; eauto.
    2: {
      instantiate (1 := max_reg). renames a to BB.
      eapply loop_invB_reg_prop in Heqe; eauto.
      eapply Pos.lt_le_trans; eauto. }
    renames a to BB. des1.
    {
      eapply loop_invB_reg_prop'; eauto.
    }
    {
      eapply loop_invB_reg_prop in Heqe; eauto.
      right. eapply Pos.le_trans; eauto.
    }
Qed.

Lemma loop_invBS_reg_prop2:
  forall BS rsw lsw max_reg max_reg' loopinvs0 loopinvs lo
    (LOOP_INVBS: loop_invBS BS rsw lsw max_reg loopinvs0 lo = (loopinvs, max_reg')),
    (max_reg <= max_reg')%positive.
Proof.
  induction BS; ii; ss; eauto.
  - inv LOOP_INVBS. rewrite Pos.compare_refl in H; ss.
  - destruct (loop_invB a rsw lsw max_reg loopinvs0 lo) eqn:Heqe; ss.
    eapply IHBS in LOOP_INVBS; eauto.
    eapply loop_invB_reg_prop in Heqe; eauto.
    assert ((max_reg <= max_reg')%positive).
    eapply Pos.le_trans; eauto. tryfalse.
Qed.

Lemma wf_loop_invC2':
  forall loops max_reg max_reg' l_entry l_exit loopinvs lo cdhp r
    (MAX_REG: RegSet.max_elt (regs_of_cdhp cdhp) = Some max_reg)
    (IN: In (l_entry, l_exit, loopinvs) (loop_invC' loops max_reg' cdhp lo))
    (REG: (exists e, In (LINV_EXPR r e) loopinvs) \/ (exists loc, In (LINV_LOC r loc) loopinvs))
    (GT: (max_reg < max_reg')%positive),
    ~ (RegSet.In r (regs_of_cdhp cdhp)).
Proof.
  induction loops; ii; ss.
  destruct a; ss. destruct p; ss.
  destruct (RS_LS_W_eval (IdentSet.elements t) cdhp) eqn:Heqe1; ss.
  destruct (loop_invBS (BS_in_loops (IdentSet.elements t) cdhp) t0 t1 max_reg' nil lo) eqn:Heqe2; ss.
  destruct IN as [IN1 | IN2]; ss; eauto.
  - inv IN1.
    renames t0 to rsw, t1 to lsw.
    eapply loop_invBS_reg_prop in Heqe2; eauto.
    des1. simpl in Heqe2. des1; des1; ss.
    eapply RegSet.max_elt_spec2 in MAX_REG.
    2: { eapply H. }
    contradiction MAX_REG.
    assert ((max_reg < r)%positive).
    {
      eapply Pos.lt_le_trans; eauto.
    }
    eauto.
  - renames t0 to rsw, t1 to lsw.
    eapply IHloops in MAX_REG; eauto.
    eapply loop_invBS_reg_prop2 in Heqe2; eauto.
    eapply Pos.lt_le_trans; eauto.
Qed.

Lemma wf_loop_invC2
      cdhp l_entry l_exit loopinvs lo ep r
      (LOOP_INV: In (l_entry, l_exit, loopinvs) (loop_invC lo (cdhp, ep)))
      (REG: (exists e, In (LINV_EXPR r e) loopinvs) \/ (exists loc, In (LINV_LOC r loc) loopinvs)):
  <<NEW_REG: ~ (RegSet.In r (regs_of_cdhp cdhp))>>.
Proof.
  unfold loop_invC in *.
  destruct (RegSet.max_elt (regs_of_cdhp cdhp)) eqn:Heqe; ss.
  - renames e to max_reg.
    eapply wf_loop_invC2'; eauto.
    eapply Pos.lt_succ_diag_r; eauto.
  - eapply RegSet.max_elt_spec3 in Heqe.
    unfold RegSet.Empty in *. specialize (Heqe r). eauto.
Qed.

Lemma loop_invB_loc_prop:
  forall BB rsw lsw max_reg loopinvs0 lo loopinvs max_reg' r loc
    (LOOP_INVB: loop_invB BB rsw lsw max_reg loopinvs0 lo = (loopinvs, max_reg'))
    (IN: In (LINV_LOC r loc) loopinvs),
    In (LINV_LOC r loc) loopinvs0 \/ lo loc = Ordering.nonatomic.
Proof.
  induction BB; ii; ss;
    try solve [inv LOOP_INVB; eauto].
  destruct c; ss; eauto.
  - des_ifH LOOP_INVB; ss; eauto.
    des_ifH LOOP_INVB; ss; eauto.
    eapply IHBB in LOOP_INVB; eauto.
    des1; eauto.
    simpl in LOOP_INVB.
    des1; eauto.
    inv LOOP_INVB.
  - pose proof (nonatomic_or_atomic or); ss.
    des1; subst.
    {
      destruct (lo loc0) eqn:Heqe; ss; eauto.
      des_ifH LOOP_INVB; ss; eauto.
      eapply IHBB in LOOP_INVB; eauto.
      des1; eauto.
      simpl in LOOP_INVB. des1; eauto.
      inv LOOP_INVB. eauto.
    }
    {
      assert (match or with
              | Ordering.plain =>
                match lo loc0 with
                | Ordering.atomic => loop_invB BB rsw lsw max_reg loopinvs0 lo
                | Ordering.nonatomic =>
                  if LocSet.mem loc0 lsw
                  then loop_invB BB rsw lsw max_reg loopinvs0 lo
                  else loop_invB BB rsw lsw (Pos.succ max_reg) (LINV_LOC max_reg loc0 :: loopinvs0) lo
                end
              | _ => loop_invB BB rsw lsw max_reg loopinvs0 lo
              end =
              loop_invB BB rsw lsw max_reg loopinvs0 lo).
      {
        destruct or; ss; eauto.
      }
      rewrite H0 in LOOP_INVB. clear H0.
      eapply IHBB in LOOP_INVB; eauto.
    }
Qed.

Lemma loop_invBS_loc_prop:
  forall BS rsw lsw max_reg loopinvs0 lo loopinvs max_reg' r loc
    (LOOP_INVBS: loop_invBS BS rsw lsw max_reg loopinvs0 lo = (loopinvs, max_reg'))
    (LOC: In (LINV_LOC r loc) loopinvs),
    In (LINV_LOC r loc) loopinvs0 \/ lo loc = Ordering.nonatomic.
Proof.
  induction BS; ii; ss.
  - inv LOOP_INVBS. eauto.
  - destruct (loop_invB a rsw lsw max_reg loopinvs0 lo) eqn:Heqe; ss.
    eapply IHBS in LOOP_INVBS; eauto. des1; eauto.
    eapply loop_invB_loc_prop in Heqe; eauto.
Qed.

Lemma wf_loop_invC3':
  forall loops max_reg cdhp lo l_entry l_exit loopinvs r loc
    (IN: In (l_entry, l_exit, loopinvs) (loop_invC' loops max_reg cdhp lo))
    (LOC: In (LINV_LOC r loc) loopinvs),
    lo loc = Ordering.nonatomic.
Proof.
  induction loops; ii; ss; eauto.
  destruct a; ss. destruct p; ss.
  destruct (RS_LS_W_eval (IdentSet.elements t) cdhp) eqn:Heqe1; ss.
  destruct (loop_invBS (BS_in_loops (IdentSet.elements t) cdhp) t0 t1 max_reg nil lo) eqn:Heqe2; ss.
  des1.
  {
    inv IN.
    eapply loop_invBS_loc_prop in Heqe2; eauto. ss.
    des1; ss.
  }
  {
    eapply IHloops in IN; eauto.
  }
Qed.

Lemma wf_loop_invC3
      cdhp l_entry l_exit loopinvs lo ep loc
      (LOOP_INV: In (l_entry, l_exit, loopinvs) (loop_invC lo (cdhp, ep)))
      (LOC: exists r, In (LINV_LOC r loc) loopinvs):
  <<NA_LOC: lo loc = Ordering.nonatomic>>.
Proof.
  des1. unfold loop_invC in *; ss.
  destruct (RegSet.max_elt (regs_of_cdhp cdhp)) eqn:Heqe; ss.
  - eapply wf_loop_invC3'; eauto.
  - eapply wf_loop_invC3'; eauto.
Qed.

(** ** Detecting Loop Invariant in Code Heap *)
Definition det_loop_invs (prog: Code) (lo: Ordering.LocOrdMap) :=
  PTree.map (fun l (func: Func) =>
               let (cdhp, ep) := func in
               match (cdhp ! ep) with
               | Some BB => loop_invC lo (cdhp, ep)
               | None => nil
               end
            ) prog.