Section MATCH.
Variable bc: block_classification.
(** * Abstracting the result of conditions (type [option bool]) *)
Inductive abool :=
| Bnone               (**r always [None] (undefined) *)
| Just (b: bool)      (**r always [Some b] (defined and known to be [b]) *)
| Maybe (b: bool)     (**r either [None] or [Some b] (known to be [b] if defined) *)
| Btop.               (**r unknown, all results are possible *)
Inductive cmatch: option bool -> abool -> Prop :=
| cmatch_none: cmatch None Bnone
| cmatch_just: forall b, cmatch (Some b) (Just b)
| cmatch_maybe_none: forall b, cmatch None (Maybe b)
| cmatch_maybe_some: forall b, cmatch (Some b) (Maybe b)
| cmatch_top: forall ob, cmatch ob Btop.
Hint Constructors cmatch : va.
Definition club (x y: abool) : abool :=
match x, y with
| Bnone, Bnone => Bnone
| Bnone, (Just b | Maybe b) => Maybe b
| (Just b | Maybe b), Bnone => Maybe b
| Just b1, Just b2 => if eqb b1 b2 then x else Btop
| Maybe b1, Maybe b2 => if eqb b1 b2 then x else Btop
| Maybe b1, Just b2 => if eqb b1 b2 then x else Btop
| Just b1, Maybe b2 => if eqb b1 b2 then y else Btop
| _, _ => Btop
end.
Definition cnot (x: abool) : abool :=
match x with
| Just b => Just (negb b)
| Maybe b => Maybe (negb b)
| _ => x
end.
(** * Abstracting pointers *)
Inductive aptr : Type :=
| Pbot                         (**r bottom (empty set of pointers) *)
| Gl (id: ident) (ofs: ptrofs) (**r pointer into the block for global variable [id] at offset [ofs] *)
| Glo (id: ident)              (**r pointer anywhere into the block for global [id] *)
| Glob                         (**r pointer into any global variable *)
| Stk (ofs: ptrofs)            (**r pointer into the current stack frame at offset [ofs] *)
| Stack                        (**r pointer anywhere into the current stack frame *)
| Nonstack                     (**r pointer anywhere but into the current stack frame *)
| Ptop.                        (**r any valid pointer *)
Definition eq_aptr: forall (p1 p2: aptr), {p1=p2} + {p1<>p2}.
Definition plub (p q: aptr) : aptr :=
match p, q with
| Pbot, _ => q
| _, Pbot => p
| Gl id1 ofs1, Gl id2 ofs2 =>
if ident_eq id1 id2 then if Ptrofs.eq_dec ofs1 ofs2 then p else Glo id1 else Glob
| Gl id1 ofs1, Glo id2 =>
if ident_eq id1 id2 then q else Glob
| Glo id1, Gl id2 ofs2 =>
if ident_eq id1 id2 then p else Glob
| Glo id1, Glo id2 =>
if ident_eq id1 id2 then p else Glob
| (Gl _ _ | Glo _ | Glob), Glob => Glob
| Glob, (Gl _ _ | Glo _) => Glob
| (Gl _ _ | Glo _ | Glob | Nonstack), Nonstack =>
Nonstack
| Nonstack, (Gl _ _ | Glo _ | Glob) =>
Nonstack
| Stk ofs1, Stk ofs2 =>
if Ptrofs.eq_dec ofs1 ofs2 then p else Stack
| (Stk _ | Stack), Stack =>
Stack
| Stack, Stk _ =>
Stack
| _, _ => Ptop
end.
Definition pincl (p q: aptr) : bool :=
match p, q with
| Pbot, _ => true
| Gl id1 ofs1, Gl id2 ofs2 => peq id1 id2 && Ptrofs.eq_dec ofs1 ofs2
| Gl id1 ofs1, Glo id2 => peq id1 id2
| Glo id1, Glo id2 => peq id1 id2
| (Gl _ _ | Glo _ | Glob), Glob => true
| (Gl _ _ | Glo _ | Glob | Nonstack), Nonstack => true
| Stk ofs1, Stk ofs2 => Ptrofs.eq_dec ofs1 ofs2
| Stk ofs1, Stack => true
| Stack, Stack => true
| _, Ptop => true
| _, _ => false
end.
Definition padd (p: aptr) (n: ptrofs) : aptr :=
match p with
| Gl id ofs => Gl id (Ptrofs.add ofs n)
| Stk ofs => Stk (Ptrofs.add ofs n)
| _ => p
end.
Definition psub (p: aptr) (n: ptrofs) : aptr :=
match p with
| Gl id ofs => Gl id (Ptrofs.sub ofs n)
| Stk ofs => Stk (Ptrofs.sub ofs n)
| _ => p
end.
Definition poffset (p: aptr) : aptr :=
match p with
| Gl id ofs => Glo id
| Stk ofs => Stack
| _ => p
end.
Definition cmp_different_blocks (c: comparison) : abool :=
match c with
| Ceq => Maybe false
| Cne => Maybe true
| _   => Bnone
end.
Definition pcmp (c: comparison) (p1 p2: aptr) : abool :=
match p1, p2 with
| Pbot, _ | _, Pbot => Bnone
| Gl id1 ofs1, Gl id2 ofs2 =>
if peq id1 id2 then Maybe (Ptrofs.cmpu c ofs1 ofs2)
else cmp_different_blocks c
| Gl id1 ofs1, Glo id2 =>
if peq id1 id2 then Btop else cmp_different_blocks c
| Glo id1, Gl id2 ofs2 =>
if peq id1 id2 then Btop else cmp_different_blocks c
| Glo id1, Glo id2 =>
if peq id1 id2 then Btop else cmp_different_blocks c
| Stk ofs1, Stk ofs2 => Maybe (Ptrofs.cmpu c ofs1 ofs2)
| (Gl _ _ | Glo _ | Glob | Nonstack), (Stk _ | Stack) => cmp_different_blocks c
| (Stk _ | Stack), (Gl _ _ | Glo _ | Glob | Nonstack) => cmp_different_blocks c
| _, _ => Btop
end.
Definition pdisjoint (p1: aptr) (sz1: Z) (p2: aptr) (sz2: Z) : bool :=
match p1, p2 with
| Pbot, _ => true
| _, Pbot => true
| Gl id1 ofs1, Gl id2 ofs2 =>
if peq id1 id2
then zle (Ptrofs.unsigned ofs1 + sz1) (Ptrofs.unsigned ofs2)
|| zle (Ptrofs.unsigned ofs2 + sz2) (Ptrofs.unsigned ofs1)
else true
| Gl id1 ofs1, Glo id2 => negb(peq id1 id2)
| Glo id1, Gl id2 ofs2 => negb(peq id1 id2)
| Glo id1, Glo id2 => negb(peq id1 id2)
| Stk ofs1, Stk ofs2 =>
zle (Ptrofs.unsigned ofs1 + sz1) (Ptrofs.unsigned ofs2)
|| zle (Ptrofs.unsigned ofs2 + sz2) (Ptrofs.unsigned ofs1)
| (Gl _ _ | Glo _ | Glob | Nonstack), (Stk _ | Stack) => true
| (Stk _ | Stack), (Gl _ _ | Glo _ | Glob | Nonstack) => true
| _, _ => false
end.
(** * Abstracting values *)
Inductive aval : Type :=
| Vbot                     (**r bottom (empty set of values) *)
| I (n: int)               (**r exactly [Vint n] *)
| Uns (p: aptr) (n: Z)     (**r a [n]-bit unsigned integer, or [Vundef] *)
| Sgn (p: aptr) (n: Z)     (**r a [n]-bit signed integer, or [Vundef] *)
| L (n: int64)             (**r exactly [Vlong n] *)
| F (f: float)             (**r exactly [Vfloat f] *)
| FS (f: float32)          (**r exactly [Vsingle f] *)
| Ptr (p: aptr)            (**r a pointer from the set [p], or [Vundef] *)
| Ifptr (p: aptr).         (**r a pointer from the set [p], or a number, or [Vundef] *)
(** The "top" of the value domain is defined as any pointer, or any number, or [Vundef]. *)
Definition Vtop := Ifptr Ptop.
(** The [p] parameter (an abstract pointer) to [Uns] and [Sgn] helps keeping track of pointers that leak through arithmetic operations such as shifts. See the section "Tracking leakage of pointers" below. In strict analysis mode, [p] is always [Pbot]. *)
Definition eq_aval: forall (v1 v2: aval), {v1=v2} + {v1<>v2}.
Hint Extern 1 (vmatch _ _) => constructor : va.
(* Some properties about [is_uns] and [is_sgn]. *)
Definition usize := Int.size.
Definition ssize (i: int) := Int.size (if Int.lt i Int.zero then Int.not i else i) + 1.
Hint Resolve is_uns_mon is_sgn_mon is_uns_sgn is_uns_usize is_sgn_ssize : va.
(** Tracking leakage of pointers through arithmetic operations.  In the CompCert semantics, arithmetic operations (e.g. "xor") applied to pointer values are undefined or produce the [Vundef] result. So, in strict mode, we can abstract the result values of such operations as [Ifptr Pbot], namely: [Vundef], or any number, but not a pointer.  In real code, such arithmetic over pointers occurs, so we need to be more prudent.  The policy we take, inspired by that of GCC, is that "undefined" arithmetic operations involving pointer arguments can produce a pointer, but not any pointer: rather, a pointer to the same block, but possibly with a different offset.  Hence, if the operation has a pointer to abstract region [p] as argument, the result value can be a pointer to abstract region [poffset p].  In other words, the result value is abstracted as [Ifptr (poffset p)].  We encapsulate this reasoning in the following [ntop1] and [ntop2] functions ("numerical top"). *)
Definition provenance (x: aval) : aptr :=
if va_strict tt then Pbot else
match x with
| Ptr p | Ifptr p | Uns p _ | Sgn p _ => poffset p
| _ => Pbot
end.
Definition ntop : aval := Ifptr Pbot.
Definition ntop1 (x: aval) : aval := Ifptr (provenance x).
Definition ntop2 (x y: aval) : aval := Ifptr (plub (provenance x) (provenance y)).
(** Smart constructors for [Uns] and [Sgn]. *)
Definition uns (p: aptr) (n: Z) : aval :=
if zle n 1 then Uns p 1
else if zle n 7 then Uns p 7
else if zle n 8 then Uns p 8
else if zle n 15 then Uns p 15
else if zle n 16 then Uns p 16
else Ifptr p.
Definition sgn (p: aptr) (n: Z) : aval :=
if zle n 8 then Sgn p 8 else if zle n 16 then Sgn p 16 else Ifptr p.
Hint Resolve vmatch_uns vmatch_uns_undef vmatch_sgn vmatch_sgn_undef : va.
(** Ordering *)
Inductive vge: aval -> aval -> Prop :=
| vge_bot: forall v, vge v Vbot
| vge_i: forall i, vge (I i) (I i)
| vge_l: forall i, vge (L i) (L i)
| vge_f: forall f, vge (F f) (F f)
| vge_s: forall f, vge (FS f) (FS f)
| vge_uns_i: forall p n i, 0 <= n -> is_uns n i -> vge (Uns p n) (I i)
| vge_uns_uns: forall p1 n1 p2 n2, n1 >= n2 -> pge p1 p2 -> vge (Uns p1 n1) (Uns p2 n2)
| vge_sgn_i: forall p n i, 0 < n -> is_sgn n i -> vge (Sgn p n) (I i)
| vge_sgn_sgn: forall p1 n1 p2 n2, n1 >= n2 -> pge p1 p2 -> vge (Sgn p1 n1) (Sgn p2 n2)
| vge_sgn_uns: forall p1 n1 p2 n2, n1 > n2 -> pge p1 p2 -> vge (Sgn p1 n1) (Uns p2 n2)
| vge_p_p: forall p q, pge p q -> vge (Ptr p) (Ptr q)
| vge_ip_p: forall p q, pge p q -> vge (Ifptr p) (Ptr q)
| vge_ip_ip: forall p q, pge p q -> vge (Ifptr p) (Ifptr q)
| vge_ip_i: forall p i, vge (Ifptr p) (I i)
| vge_ip_l: forall p i, vge (Ifptr p) (L i)
| vge_ip_f: forall p f, vge (Ifptr p) (F f)
| vge_ip_s: forall p f, vge (Ifptr p) (FS f)
| vge_ip_uns: forall p q n, pge p q -> vge (Ifptr p) (Uns q n)
| vge_ip_sgn: forall p q n, pge p q -> vge (Ifptr p) (Sgn q n).
Hint Constructors vge : va.
Hint Resolve vge_top : va.
(** Least upper bound *)
Definition vlub (v w: aval) : aval :=
match v, w with
| Vbot, _ => w
| _, Vbot => v
| I i1, I i2 =>
if Int.eq i1 i2 then v else
if Int.lt i1 Int.zero || Int.lt i2 Int.zero
then sgn Pbot (Z.max (ssize i1) (ssize i2))
else uns Pbot (Z.max (usize i1) (usize i2))
| I i, Uns p n | Uns p n, I i =>
if Int.lt i Int.zero
then sgn p (Z.max (ssize i) (n + 1))
else uns p (Z.max (usize i) n)
| I i, Sgn p n | Sgn p n, I i =>
sgn p (Z.max (ssize i) n)
| I i, (Ptr p | Ifptr p) | (Ptr p | Ifptr p), I i =>
if va_strict tt || Int.eq i Int.zero then Ifptr p else Vtop
| Uns p1 n1, Uns p2 n2 => Uns (plub p1 p2) (Z.max n1 n2)
| Uns p1 n1, Sgn p2 n2 => sgn (plub p1 p2) (Z.max (n1 + 1) n2)
| Sgn p1 n1, Uns p2 n2 => sgn (plub p1 p2) (Z.max n1 (n2 + 1))
| Sgn p1 n1, Sgn p2 n2 => sgn (plub p1 p2) (Z.max n1 n2)
| F f1, F f2 =>
if Float.eq_dec f1 f2 then v else ntop
| FS f1, FS f2 =>
if Float32.eq_dec f1 f2 then v else ntop
| L i1, L i2 =>
if Int64.eq i1 i2 then v else ntop
| Ptr p1, Ptr p2 => Ptr(plub p1 p2)
| Ptr p1, Ifptr p2 => Ifptr(plub p1 p2)
| Ifptr p1, Ptr p2 => Ifptr(plub p1 p2)
| Ifptr p1, Ifptr p2 => Ifptr(plub p1 p2)
| (Ptr p1 | Ifptr p1), (Uns p2 _ | Sgn p2 _) => Ifptr(plub p1 p2)
| (Uns p1 _ | Sgn p1 _), (Ptr p2 | Ifptr p2) => Ifptr(plub p1 p2)
| _, (Ptr p | Ifptr p) | (Ptr p | Ifptr p), _ => if va_strict tt then Ifptr p else Vtop
| _, _ => Vtop
end.
Hint Resolve vge_uns_uns' vge_uns_i' vge_sgn_sgn' vge_sgn_i' : va.
(** In the CompCert semantics, a memory load or store succeeds only if the address is a pointer value.  Hence, in strict mode, [aptr_of_aval x] returns [Pbot] (no pointer value) if [x] denotes a number or [Vundef].  However, in real code, memory addresses are sometimes synthesized from integers, e.g. an absolute address for a hardware device.  It is a reasonable assumption that these absolute addresses do not point within the stack block, however.  Therefore, in relaxed mode, [aptr_of_aval x] returns [Nonstack] (any pointer outside the stack) when [x] denotes a number. *)
Definition aptr_of_aval (v: aval) : aptr :=
match v with
| Ptr p => p
| Ifptr p => p
| _ => if va_strict tt then Pbot else Nonstack
end.
Definition vplub (v: aval) (p: aptr) : aptr :=
match v with
| Ptr q => plub q p
| Ifptr q => plub q p
| _ => p
end.
(** Inclusion *)
Definition vpincl (v: aval) (p: aptr) : bool :=
match v with
| Ptr q | Ifptr q | Uns q _ | Sgn q _ => pincl q p
| _ => true
end.
Definition vincl (v w: aval) : bool :=
match v, w with
| Vbot, _ => true
| I i, I j => Int.eq_dec i j
| I i, Uns p n => Int.eq_dec (Int.zero_ext n i) i && zle 0 n
| I i, Sgn p n => Int.eq_dec (Int.sign_ext n i) i && zlt 0 n
| Uns p n, Uns q m => zle n m && pincl p q
| Uns p n, Sgn q m => zlt n m && pincl p q
| Sgn p n, Sgn q m => zle n m && pincl p q
| L i, L j => Int64.eq_dec i j
| F i, F j => Float.eq_dec i j
| FS i, FS j => Float32.eq_dec i j
| Ptr p, Ptr q => pincl p q
| (Ptr p | Ifptr p | Uns p _ | Sgn p _), Ifptr q => pincl p q
| _, Ifptr _ => true
| _, _ => false
end.
(** Loading constants *)
Definition genv_match (ge: genv) : Prop :=
(forall id b, Genv.find_symbol ge id = Some b <-> bc b = BCglob id)
/\(forall b, Plt b (Genv.genv_next ge) -> bc b <> BCinvalid /\ bc b <> BCstack).
(** Generic operations that just do constant propagation. *)
Definition unop_int (sem: int -> int) (x: aval) :=
match x with I n => I (sem n) | _ => ntop1 x end.
Definition binop_int (sem: int -> int -> int) (x y: aval) :=
match x, y with I n, I m => I (sem n m) | _, _ => ntop2 x y end.
Definition unop_long (sem: int64 -> int64) (x: aval) :=
match x with L n => L (sem n) | _ => ntop1 x end.
Definition binop_long (sem: int64 -> int64 -> int64) (x y: aval) :=
match x, y with L n, L m => L (sem n m) | _, _ => ntop2 x y end.
Definition unop_float (sem: float -> float) (x: aval) :=
match x with F n => F (sem n) | _ => ntop1 x end.
Definition binop_float (sem: float -> float -> float) (x y: aval) :=
match x, y with F n, F m => F (sem n m) | _, _ => ntop2 x y end.
Definition unop_single (sem: float32 -> float32) (x: aval) :=
match x with FS n => FS (sem n) | _ => ntop1 x end.
Definition binop_single (sem: float32 -> float32 -> float32) (x y: aval) :=
match x, y with FS n, FS m => FS (sem n m) | _, _ => ntop2 x y end.
(** Logical operations *)
Definition shl (v w: aval) :=
match w with
| I amount =>
if Int.ltu amount Int.iwordsize then
match v with
| I i => I (Int.shl i amount)
| Uns p n => uns p (n + Int.unsigned amount)
| Sgn p n => sgn p (n + Int.unsigned amount)
| _ => ntop1 v
end
else ntop1 v
| _ => ntop1 v
end.
Definition shru (v w: aval) :=
match w with
| I amount =>
if Int.ltu amount Int.iwordsize then
match v with
| I i => I (Int.shru i amount)
| Uns p n => uns p (n - Int.unsigned amount)
| _ => uns (provenance v) (Int.zwordsize - Int.unsigned amount)
end
else ntop1 v
| _ => ntop1 v
end.
Definition shr (v w: aval) :=
match w with
| I amount =>
if Int.ltu amount Int.iwordsize then
match v with
| I i => I (Int.shr i amount)
| Uns p n => sgn p (n + 1 - Int.unsigned amount)
| Sgn p n => sgn p (n - Int.unsigned amount)
| _ => sgn (provenance v) (Int.zwordsize - Int.unsigned amount)
end
else ntop1 v
| _ => ntop1 v
end.

Lemma shr_sound:
forall v w x y, vmatch v x -> vmatch w y -> vmatch (Val.shr v w) (shr x y).