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.
Definition and (v w: aval) :=
match v, w with
| I i1, I i2 => I (Int.and i1 i2)
| I i, Uns p n | Uns p n, I i => uns p (Z.min n (usize i))
| I i, x | x, I i => uns (provenance x) (usize i)
| Uns p1 n1, Uns p2 n2 => uns (plub p1 p2) (Z.min n1 n2)
| Uns p n, _ => uns (plub p (provenance w)) n
| _, Uns p n => uns (plub (provenance v) p) n
| Sgn p1 n1, Sgn p2 n2 => sgn (plub p1 p2) (Z.max n1 n2)
| _, _ => ntop2 v w
end.
Definition or (v w: aval) :=
match v, w with
| I i1, I i2 => I (Int.or i1 i2)
| I i, Uns p n | Uns p n, I i => uns p (Z.max n (usize i))
| Uns p1 n1, Uns p2 n2 => uns (plub p1 p2) (Z.max n1 n2)
| Sgn p1 n1, Sgn p2 n2 => sgn (plub p1 p2) (Z.max n1 n2)
| _, _ => ntop2 v w
end.
Definition xor (v w: aval) :=
match v, w with
| I i1, I i2 => I (Int.xor i1 i2)
| I i, Uns p n | Uns p n, I i => uns p (Z.max n (usize i))
| Uns p1 n1, Uns p2 n2 => uns (plub p1 p2) (Z.max n1 n2)
| Sgn p1 n1, Sgn p2 n2 => sgn (plub p1 p2) (Z.max n1 n2)
| _, _ => ntop2 v w
end.
Definition notint (v: aval) :=
match v with
| I i => I (Int.not i)
| Uns p n => sgn p (n + 1)
| Sgn p n => Sgn p n
| _ => ntop1 v
end.
Definition rol (x y: aval) :=
match y, x with
| I j, I i => I(Int.rol i j)
| I j, Uns p n => uns p (n + Int.unsigned j)
| I j, Sgn p n => if zlt n Int.zwordsize then sgn p (n + Int.unsigned j) else ntop1 x
| _, _ => ntop1 x
end.
Definition ror (x y: aval) :=
match y, x with
| I j, I i => I(Int.ror i j)
| _, _ => ntop1 x
end.
Definition rolm (x: aval) (amount mask: int) :=
and (rol x (I amount)) (I mask).
(** Integer arithmetic operations *)
Definition neg := unop_int Int.neg.
Proof (unop_int_sound Int.neg).
Definition add (x y: aval) :=
match x, y with
| I i, I j => I (Int.add i j)
| Ptr p, I i | I i, Ptr p => Ptr (if Archi.ptr64 then poffset p else padd p (Ptrofs.of_int i))
| Ptr p, _   | _, Ptr p   => Ptr (poffset p)
| Ifptr p, I i | I i, Ifptr p => Ifptr (if Archi.ptr64 then poffset p else padd p (Ptrofs.of_int i))
| Ifptr p, Ifptr q => Ifptr (plub (poffset p) (poffset q))
| Ifptr p, _ | _, Ifptr p => Ifptr (poffset p)
| _, _ => ntop2 x y
end.
Definition sub (v w: aval) :=
match v, w with
| I i1, I i2 => I (Int.sub i1 i2)
| Ptr p, I i => if Archi.ptr64 then Ifptr (poffset p) else Ptr (psub p (Ptrofs.of_int i))
| Ptr p, _   => Ifptr (poffset p)
| Ifptr p, I i => if Archi.ptr64 then Ifptr (plub (poffset p) (provenance w)) else Ifptr (psub p (Ptrofs.of_int i))
| Ifptr p, _ => Ifptr (plub (poffset p) (provenance w))
| _, _ => ntop2 v w
end.
Definition mul := binop_int Int.mul.
Proof (binop_int_sound Int.mul).
Definition mulhs := binop_int Int.mulhs.
Proof (binop_int_sound Int.mulhs).
Definition mulhu := binop_int Int.mulhu.
Proof (binop_int_sound Int.mulhu).
Definition divs (v w: aval) :=
match w, v with
| I i2, I i1 =>
if Int.eq i2 Int.zero
|| Int.eq i1 (Int.repr Int.min_signed) && Int.eq i2 Int.mone
then if va_strict tt then Vbot else ntop
else I (Int.divs i1 i2)
| _, _ => ntop2 v w
end.
Definition divu (v w: aval) :=
match w, v with
| I i2, I i1 =>
if Int.eq i2 Int.zero
then if va_strict tt then Vbot else ntop
else I (Int.divu i1 i2)
| _, _ => ntop2 v w
end.
Definition mods (v w: aval) :=
match w, v with
| I i2, I i1 =>
if Int.eq i2 Int.zero
|| Int.eq i1 (Int.repr Int.min_signed) && Int.eq i2 Int.mone
then if va_strict tt then Vbot else ntop
else I (Int.mods i1 i2)
| _, _ => ntop2 v w
end.
Definition modu (v w: aval) :=
match w, v with
| I i2, I i1 =>
if Int.eq i2 Int.zero
then if va_strict tt then Vbot else ntop
else I (Int.modu i1 i2)
| I i2, _ => uns (provenance v) (usize i2)
| _, _ => ntop2 v w
end.
Definition shrx (v w: aval) :=
match v, w with
| I i, I j => if Int.ltu j (Int.repr 31) then I(Int.shrx i j) else ntop
| _, _ => ntop1 v
end.
(** 64-bit integer operations *)
Definition shift_long (sem: int64 -> int -> int64) (v w: aval) :=
match w with
| I amount =>
if Int.ltu amount Int64.iwordsize' then
match v with
| L i => L (sem i amount)
| _ => ntop1 v
end
else ntop1 v
| _ => ntop1 v
end.
Definition shll := shift_long Int64.shl'.
Proof (shift_long_sound Int64.shl').
Definition shrl := shift_long Int64.shr'.
Proof (shift_long_sound Int64.shr').
Definition shrlu := shift_long Int64.shru'.
Proof (shift_long_sound Int64.shru').
Definition andl := binop_long Int64.and.
Proof (binop_long_sound Int64.and).
Definition orl := binop_long Int64.or.
Proof (binop_long_sound Int64.or).
Definition xorl := binop_long Int64.xor.
Proof (binop_long_sound Int64.xor).
Definition notl := unop_long Int64.not.
Proof (unop_long_sound Int64.not).
Definition rotate_long (sem: int64 -> int64 -> int64) (v w: aval) :=
match v, w with
| L i, I amount => L (sem i (Int64.repr (Int.unsigned amount)))
| _, _ => ntop1 v
end.
Definition roll := rotate_long Int64.rol.
Proof (rotate_long_sound Int64.rol).
Definition rorl := rotate_long Int64.ror.
Proof (rotate_long_sound Int64.ror).
Definition negl := unop_long Int64.neg.
Proof (unop_long_sound Int64.neg).
Definition addl (x y: aval) :=
match x, y with
| L i, L j => L (Int64.add i j)
| Ptr p, L i | L i, Ptr p => Ptr (if Archi.ptr64 then padd p (Ptrofs.of_int64 i) else poffset p)
| Ptr p, _   | _, Ptr p   => Ptr (poffset p)
| Ifptr p, L i | L i, Ifptr p => Ifptr (if Archi.ptr64 then padd p (Ptrofs.of_int64 i) else poffset p)
| Ifptr p, Ifptr q => Ifptr (plub (poffset p) (poffset q))
| Ifptr p, _ | _, Ifptr p => Ifptr (poffset p)
| _, _ => ntop2 x y
end.
Definition subl (v w: aval) :=
match v, w with
| L i1, L i2 => L (Int64.sub i1 i2)
| Ptr p, L i => if Archi.ptr64 then Ptr (psub p (Ptrofs.of_int64 i)) else Ifptr (poffset p)
| Ptr p, _   => Ifptr (poffset p)
| Ifptr p, L i => if Archi.ptr64 then Ifptr (psub p (Ptrofs.of_int64 i)) else Ifptr (plub (poffset p) (provenance w))
| Ifptr p, _ => Ifptr (plub (poffset p) (provenance w))
| _, _ => ntop2 v w
end.
Definition mull := binop_long Int64.mul.
Proof (binop_long_sound Int64.mul).
Definition mullhs := binop_long Int64.mulhs.
Proof (binop_long_sound Int64.mulhs).
Definition mullhu := binop_long Int64.mulhu.
Proof (binop_long_sound Int64.mulhu).
Definition divls (v w: aval) :=
match w, v with
| L i2, L i1 =>
if Int64.eq i2 Int64.zero
|| Int64.eq i1 (Int64.repr Int64.min_signed) && Int64.eq i2 Int64.mone
then if va_strict tt then Vbot else ntop
else L (Int64.divs i1 i2)
| _, _ => ntop2 v w
end.
Definition divlu (v w: aval) :=
match w, v with
| L i2, L i1 =>
if Int64.eq i2 Int64.zero
then if va_strict tt then Vbot else ntop
else L (Int64.divu i1 i2)
| _, _ => ntop2 v w
end.
Definition modls (v w: aval) :=
match w, v with
| L i2, L i1 =>
if Int64.eq i2 Int64.zero
|| Int64.eq i1 (Int64.repr Int64.min_signed) && Int64.eq i2 Int64.mone
then if va_strict tt then Vbot else ntop
else L (Int64.mods i1 i2)
| _, _ => ntop2 v w
end.
Definition modlu (v w: aval) :=
match w, v with
| L i2, L i1 =>
if Int64.eq i2 Int64.zero
then if va_strict tt then Vbot else ntop
else L (Int64.modu i1 i2)
| _, _ => ntop2 v w
end.
Definition shrxl (v w: aval) :=
match v, w with
| L i, I j => if Int.ltu j (Int.repr 63) then L(Int64.shrx' i j) else ntop
| _, _ => ntop1 v
end.
Definition rolml (x: aval) (amount: int) (mask: int64) :=
andl (roll x (I amount)) (L mask).
(** Pointer operations *)
Definition offset_ptr (v: aval) (n: ptrofs) :=
match v with
| Ptr p => Ptr (padd p n)
| Ifptr p => Ifptr (padd p n)
| _ => ntop1 v
end.
(** Floating-point arithmetic operations *)
Definition negf := unop_float Float.neg.
Proof (unop_float_sound Float.neg).
Definition absf := unop_float Float.abs.
Proof (unop_float_sound Float.abs).
Definition addf := binop_float Float.add.
Proof (binop_float_sound Float.add).
Definition subf := binop_float Float.sub.
Proof (binop_float_sound Float.sub).
Definition mulf := binop_float Float.mul.
Proof (binop_float_sound Float.mul).
Definition divf := binop_float Float.div.
Proof (binop_float_sound Float.div).
Definition negfs := unop_single Float32.neg.
Proof (unop_single_sound Float32.neg).
Definition absfs := unop_single Float32.abs.
Proof (unop_single_sound Float32.abs).
Definition addfs := binop_single Float32.add.
Proof (binop_single_sound Float32.add).
Definition subfs := binop_single Float32.sub.
Proof (binop_single_sound Float32.sub).
Definition mulfs := binop_single Float32.mul.
Proof (binop_single_sound Float32.mul).
Definition divfs := binop_single Float32.div.
Proof (binop_single_sound Float32.div).
(** Conversions *)
Definition zero_ext (nbits: Z) (v: aval) :=
match v with
| I i => I (Int.zero_ext nbits i)
| Uns p n => uns p (Z.min n nbits)
| _ => uns (provenance v) nbits
end.
Definition sign_ext (nbits: Z) (v: aval) :=
if zle nbits 0 then Uns (provenance v) 0 else
match v with
| I i => I (Int.sign_ext nbits i)
| Uns p n => if zlt n nbits then Uns p n else sgn p nbits
| Sgn p n => sgn p (Z.min n nbits)
| _ => sgn (provenance v) nbits
end.
Definition zero_ext_l (s: Z) := unop_long (Int64.zero_ext s).
Definition sign_ext_l (s: Z) := unop_long (Int64.sign_ext s).
Definition longofint (v: aval) :=
match v with
| I i => L (Int64.repr (Int.signed i))
| _ => ntop1 v
end.
Definition longofintu (v: aval) :=
match v with
| I i => L (Int64.repr (Int.unsigned i))
| _ => ntop1 v
end.
Definition singleoffloat (v: aval) :=
match v with
| F f => FS (Float.to_single f)
| _   => ntop1 v
end.
Definition floatofsingle (v: aval) :=
match v with
| FS f => F (Float.of_single f)
| _   => ntop1 v
end.
Definition intoffloat (x: aval) :=
match x with
| F f =>
match Float.to_int f with
| Some i => I i
| None => if va_strict tt then Vbot else ntop
end
| _ => ntop1 x
end.
Definition intuoffloat (x: aval) :=
match x with
| F f =>
match Float.to_intu f with
| Some i => I i
| None => if va_strict tt then Vbot else ntop
end
| _ => ntop1 x
end.
Definition floatofint (x: aval) :=
match x with
| I i => F(Float.of_int i)
| _   => ntop1 x
end.
Definition floatofintu (x: aval) :=
match x with
| I i => F(Float.of_intu i)
| _   => ntop1 x
end.
Definition intofsingle (x: aval) :=
match x with
| FS f =>
match Float32.to_int f with
| Some i => I i
| None => if va_strict tt then Vbot else ntop
end
| _ => ntop1 x
end.
Definition intuofsingle (x: aval) :=
match x with
| FS f =>
match Float32.to_intu f with
| Some i => I i
| None => if va_strict tt then Vbot else ntop
end
| _ => ntop1 x
end.
Definition singleofint (x: aval) :=
match x with
| I i => FS(Float32.of_int i)
| _   => ntop1 x
end.
Definition singleofintu (x: aval) :=
match x with
| I i => FS(Float32.of_intu i)
| _   => ntop1 x
end.
Definition longoffloat (x: aval) :=
match x with
| F f =>
match Float.to_long f with
| Some i => L i
| None => if va_strict tt then Vbot else ntop
end
| _ => ntop1 x
end.
Definition longuoffloat (x: aval) :=
match x with
| F f =>
match Float.to_longu f with
| Some i => L i
| None => if va_strict tt then Vbot else ntop
end
| _ => ntop1 x
end.
Definition floatoflong (x: aval) :=
match x with
| L i => F(Float.of_long i)
| _   => ntop1 x
end.
Definition floatoflongu (x: aval) :=
match x with
| L i => F(Float.of_longu i)
| _   => ntop1 x
end.
Definition longofsingle (x: aval) :=
match x with
| FS f =>
match Float32.to_long f with
| Some i => L i
| None => if va_strict tt then Vbot else ntop
end
| _ => ntop1 x
end.
Definition longuofsingle (x: aval) :=
match x with
| FS f =>
match Float32.to_longu f with
| Some i => L i
| None => if va_strict tt then Vbot else ntop
end
| _ => ntop1 x
end.
Definition singleoflong (x: aval) :=
match x with
| L i => FS(Float32.of_long i)
| _   => ntop1 x
end.
Definition singleoflongu (x: aval) :=
match x with
| L i => FS(Float32.of_longu i)
| _   => ntop1 x
end.
Definition floatofwords (x y: aval) :=
match x, y with
| I i, I j => F(Float.from_words i j)
| _, _     => ntop2 x y
end.
Definition longofwords (x y: aval) :=
match y, x with
| I j, I i => L(Int64.ofwords i j)
| _, _     => ntop2 x y
end.
Definition loword (x: aval) :=
match x with
| L i => I(Int64.loword i)
| _   => ntop1 x
end.
Definition hiword (x: aval) :=
match x with
| L i => I(Int64.hiword i)
| _   => ntop1 x
end.
(** Comparisons and variation intervals *)
Definition cmp_intv (c: comparison) (i: Z * Z) (n: Z) : abool :=
let (lo, hi) := i in
match c with
| Ceq => if zlt n lo || zlt hi n then Maybe false else Btop
| Cne => Btop
| Clt => if zlt hi n then Maybe true else if zle n lo then Maybe false else Btop
| Cle => if zle hi n then Maybe true else if zlt n lo then Maybe false else Btop
| Cgt => if zlt n lo then Maybe true else if zle hi n then Maybe false else Btop
| Cge => if zle n lo then Maybe true else if zlt hi n then Maybe false else Btop
end.
Definition zcmp (c: comparison) (n1 n2: Z) : bool :=
match c with
| Ceq => zeq n1 n2
| Cne => negb (zeq n1 n2)
| Clt => zlt n1 n2
| Cle => zle n1 n2
| Cgt => zlt n2 n1
| Cge => zle n2 n1
end.
Definition uintv (v: aval) : Z * Z :=
match v with
| I n => (Int.unsigned n, Int.unsigned n)
| Uns _ n => if zlt n Int.zwordsize then (0, two_p n - 1) else (0, Int.max_unsigned)
| _ => (0, Int.max_unsigned)
end.
Definition sintv (v: aval) : Z * Z :=
match v with
| I n => (Int.signed n, Int.signed n)
| Uns _ n =>
if zlt n Int.zwordsize then (0, two_p n - 1) else (Int.min_signed, Int.max_signed)
| Sgn _ n =>
if zlt n Int.zwordsize
then (let x := two_p (n-1) in (-x, x-1))
else (Int.min_signed, Int.max_signed)
| _ => (Int.min_signed, Int.max_signed)
end.
(** Comparisons *)
Definition cmpu_bool (c: comparison) (v w: aval) : abool :=
match v, w with
| I i1, I i2 => Just (Int.cmpu c i1 i2)
| Ptr _, I i => if Int.eq i Int.zero then cmp_different_blocks c else Btop
| I i, Ptr _ => if Int.eq i Int.zero then cmp_different_blocks c else Btop
| Ptr p1, Ptr p2 => pcmp c p1 p2
| _, I i => club (cmp_intv c (uintv v) (Int.unsigned i)) (cmp_different_blocks c)
| I i, _ => club (cmp_intv (swap_comparison c) (uintv w) (Int.unsigned i)) (cmp_different_blocks c)
| _, _ => Btop
end.
Definition cmp_bool (c: comparison) (v w: aval) : abool :=
match v, w with
| I i1, I i2 => Just (Int.cmp c i1 i2)
| _, I i => cmp_intv c (sintv v) (Int.signed i)
| I i, _ => cmp_intv (swap_comparison c) (sintv w) (Int.signed i)
| _, _ => Btop
end.
Definition cmplu_bool (c: comparison) (v w: aval) : abool :=
match v, w with
| L i1, L i2 => Just (Int64.cmpu c i1 i2)
| Ptr _, L i => if Int64.eq i Int64.zero then cmp_different_blocks c else Btop
| L i, Ptr _ => if Int64.eq i Int64.zero then cmp_different_blocks c else Btop
| Ptr p1, Ptr p2 => pcmp c p1 p2
| _, _ => Btop
end.
Definition cmpl_bool (c: comparison) (v w: aval) : abool :=
match v, w with
| L i1, L i2 => Just (Int64.cmp c i1 i2)
| _, _ => Btop
end.
Definition cmpf_bool (c: comparison) (v w: aval) : abool :=
match v, w with
| F f1, F f2 => Just (Float.cmp c f1 f2)
| _, _ => Btop
end.
Definition cmpfs_bool (c: comparison) (v w: aval) : abool :=
match v, w with
| FS f1, FS f2 => Just (Float32.cmp c f1 f2)
| _, _ => Btop
end.
Definition maskzero (x: aval) (mask: int) : abool :=
match x with
| I i => Just (Int.eq (Int.and i mask) Int.zero)
| Uns p n => if Int.eq (Int.zero_ext n mask) Int.zero then Maybe true else Btop
| _ => Btop
end.
Definition of_optbool (ab: abool) : aval :=
match ab with
| Just b => I (if b then Int.one else Int.zero)
| _ => Uns Pbot 1
end.
Definition resolve_branch (ab: abool) : option bool :=
match ab with
| Just b => Some b
| Maybe b => Some b
| _ => None
end.
(** Select either returns one of its arguments, or Vundef. *)
Definition add_undef (x: aval) :=
match x with
| Vbot => ntop
| I i =>
if Int.lt i Int.zero
then sgn Pbot (ssize i)
else uns Pbot (usize i)
| L _ | F _ | FS _ => ntop
| _ => x
end.
Definition select (ab: abool) (x y: aval) :=
match ab with
| Bnone => ntop
| Just b | Maybe b => add_undef (if b then x else y)
| Btop => add_undef (vlub x y)
end.
(** Normalization at load time *)
Definition vnormalize (chunk: memory_chunk) (v: aval) :=
match chunk, v with
| _, Vbot => Vbot
| Mint8signed, I i => I (Int.sign_ext 8 i)
| Mint8signed, Uns p n => if zlt n 8 then Uns (provenance v) n else Sgn (provenance v) 8
| Mint8signed, Sgn p n => Sgn (provenance v) (Z.min n 8)
| Mint8signed, _ => Sgn (provenance v) 8
| Mint8unsigned, I i => I (Int.zero_ext 8 i)
| Mint8unsigned, Uns p n => Uns (provenance v) (Z.min n 8)
| Mint8unsigned, _ => Uns (provenance v) 8
| Mint16signed, I i => I (Int.sign_ext 16 i)
| Mint16signed, Uns p n => if zlt n 16 then Uns (provenance v) n else Sgn (provenance v) 16
| Mint16signed, Sgn p n => Sgn (provenance v) (Z.min n 16)
| Mint16signed, _ => Sgn (provenance v) 16
| Mint16unsigned, I i => I (Int.zero_ext 16 i)
| Mint16unsigned, Uns p n => Uns (provenance v) (Z.min n 16)
| Mint16unsigned, _ => Uns (provenance v) 16
| Mint32, (I _ | Uns _ _ | Sgn _ _ | Ifptr _) => v
| Mint32, Ptr p => if Archi.ptr64 then Ifptr p else v
| Mint64, (L _ | Ifptr _) => v
| Mint64, (Uns p _ | Sgn p _) => Ifptr p
| Mint64, Ptr p => if Archi.ptr64 then v else Ifptr p
| Mfloat32, FS f => v
| Mfloat64, F f => v
| Many32, (I _ | Uns _ _ | Sgn _ _ | FS _ | Ifptr _) => v
| Many32, Ptr p => if Archi.ptr64 then Ifptr p else v
| Many64, _ => v
| _, _ => Ifptr (provenance v)
end.
Remark poffset_monotone:
forall p q, pge p q -> pge (poffset p) (poffset q).
Remark provenance_monotone:
forall x y, vge x y -> pge (provenance x) (provenance y).
Proof with (auto using provenance_monotone with va).
intros chunk x y V; unfold vnormalize; generalize Archi.ptr64; intro ptr64; inversion V; subst; destruct chunk eqn:C; simpl...
- destruct (zlt n 8); constructor...
apply is_sign_ext_uns...
apply is_sign_ext_sgn...
- constructor... apply is_zero_ext_uns... apply Z.min_case...
- destruct (zlt n 16); constructor...
apply is_sign_ext_uns...
apply is_sign_ext_sgn...
- constructor... apply is_zero_ext_uns... apply Z.min_case...
- unfold provenance; destruct (va_strict tt)...
- destruct (zlt n1 8). rewrite zlt_true by omega...
destruct (zlt n2 8)...
- destruct (zlt n1 16). rewrite zlt_true by omega...
destruct (zlt n2 16)...
- constructor... apply is_sign_ext_sgn... apply Z.min_case...
- constructor... apply is_zero_ext_uns...
- constructor... apply is_sign_ext_sgn... apply Z.min_case...
- constructor... apply is_zero_ext_uns...
- unfold provenance; destruct (va_strict tt)...
- destruct (zlt n2 8); constructor...
- destruct (zlt n2 16); constructor...
- destruct ptr64...
- destruct ptr64...
- destruct ptr64...
- destruct ptr64...
- destruct ptr64...
- destruct ptr64...
- constructor... apply is_sign_ext_sgn...
- constructor... apply is_zero_ext_uns...
- constructor... apply is_sign_ext_sgn...
- constructor... apply is_zero_ext_uns...
- unfold provenance; destruct (va_strict tt)...
- unfold provenance; destruct (va_strict tt)...
- unfold provenance; destruct (va_strict tt)...
- unfold provenance; destruct (va_strict tt)...
- unfold provenance; destruct (va_strict tt)...
- unfold provenance; destruct (va_strict tt)...
- unfold provenance; destruct (va_strict tt)...
- unfold provenance; destruct (va_strict tt)...
- destruct (zlt n 8)...
- destruct (zlt n 16)...
Qed.
(** Analysis of known builtin functions.  All we have is a dynamic semantics as a function [list val -> option val], but we can still perform some constant propagation. *)
Definition val_of_aval (a: aval) : val :=
match a with
| I n => Vint n
| L n => Vlong n
| F f => Vfloat f
| FS f => Vsingle f
| _ => Vundef
end.
Definition aval_of_val (v: val) : option aval :=
match v with
| Vint n => Some (I n)
| Vlong n => Some (L n)
| Vfloat f => Some (F f)
| Vsingle f => Some (FS f)
| _ => None
end.
(** * Abstracting memory blocks *)
Inductive acontent : Type :=
| ACval (chunk: memory_chunk) (av: aval).
Definition eq_acontent : forall (c1 c2: acontent), {c1=c2} + {c1<>c2}.
Definition inval_if (hi: Z) (lo: Z) (c: ZTree.t acontent) :=
match c##lo with
| None => c
| Some (ACval chunk av) => if zle (lo + size_chunk chunk) hi then c else ZTree.remove lo c
end.
Function inval_before (hi: Z) (lo: Z) (c: ZTree.t acontent) { wf (Zwf_up hi) lo } : ZTree.t acontent :=
if zlt lo hi
then inval_before hi (lo + 1) (inval_if hi lo c)
else c.
Definition ablock_store (chunk: memory_chunk) (ab: ablock) (i: Z) (av: aval) : ablock :=
{| ab_contents :=
ZTree.set i (ACval chunk av)
(inval_before i (i - 7)
(inval_after (i + 1) (i + size_chunk chunk - 1) ab.(ab_contents)));
ab_summary :=
vplub av ab.(ab_summary) |}.
Definition ablock_store_anywhere (chunk: memory_chunk) (ab: ablock) (av: aval) : ablock :=
ablock_init (vplub av ab.(ab_summary)).
Definition ablock_loadbytes (ab: ablock) : aptr := ab.(ab_summary).
Definition ablock_storebytes (ab: ablock) (p: aptr) (ofs: Z) (sz: Z) :=
{| ab_contents :=
inval_before ofs (ofs - 7)
(inval_after ofs (ofs + sz - 1) ab.(ab_contents));
ab_summary :=
plub p ab.(ab_summary) |}.
Definition ablock_storebytes_anywhere (ab: ablock) (p: aptr) :=
ablock_init (plub p ab.(ab_summary)).
Definition smatch (m: mem) (b: block) (p: aptr) : Prop :=
(forall chunk ofs v, Mem.load chunk m b ofs = Some v -> vmatch v (Ifptr p))
/\(forall ofs b' ofs' q i, Mem.loadbytes m b ofs 1 = Some (Fragment (Vptr b' ofs') q i :: nil) -> pmatch b' ofs' p).
Remark loadbytes_load_ext:
forall b m m',
(forall ofs n bytes, Mem.loadbytes m' b ofs n = Some bytes -> n >= 0 -> Mem.loadbytes m b ofs n = Some bytes) ->
forall chunk ofs v, Mem.load chunk m' b ofs = Some v -> Mem.load chunk m b ofs = Some v.
Definition bmatch (m: mem) (b: block) (ab: ablock) : Prop :=
smatch m b ab.(ab_summary) /\
forall chunk ofs v, Mem.load chunk m b ofs = Some v -> vmatch v (ablock_load chunk ab ofs).
Remark inval_after_outside:
forall i lo hi c, i < lo \/ i > hi -> (inval_after lo hi c)##i = c##i.
Remark inval_after_contents:
forall chunk av i lo hi c,
(inval_after lo hi c)##i = Some (ACval chunk av) ->
c##i = Some (ACval chunk av) /\ (i < lo \/ i > hi).
Remark inval_before_outside:
forall i hi lo c, i < lo \/ i >= hi -> (inval_before hi lo c)##i = c##i.
Remark inval_before_contents_1:
forall i chunk av lo hi c,
lo <= i < hi -> (inval_before hi lo c)##i = Some(ACval chunk av) ->
c##i = Some(ACval chunk av) /\ i + size_chunk chunk <= hi.
Remark inval_before_contents:
forall i c chunk' av' j,
(inval_before i (i - 7) c)##j = Some (ACval chunk' av') ->
c##j = Some (ACval chunk' av') /\ (j + size_chunk chunk' <= i \/ i <= j).
(** Boolean equality *)
Definition bbeq (ab1 ab2: ablock) : bool :=
eq_aptr ab1.(ab_summary) ab2.(ab_summary) &&
ZTree.beq (fun c1 c2 => proj_sumbool (eq_acontent c1 c2)) ab1.(ab_contents) ab2.(ab_contents).

Lemma bbeq_load:
forall ab1 ab2,
bbeq ab1 ab2 = true ->
ab1.(ab_summary) = ab2.(ab_summary)
/\ (forall chunk i, ablock_load chunk ab1 i = ablock_load chunk ab2 i).