Module ValueAOp

Require Import Coqlib Compopts.
Require Import AST Integers Floats Values Memory Globalenvs.
Require Import Op ExtValues ExtFloats RTL ValueDomain.
Definition minf := binop_float ExtFloat.min.
Definition maxf := binop_float ExtFloat.max.
Definition minfs := binop_single ExtFloat32.min.
Definition maxfs := binop_single ExtFloat32.max.

Definition ntop3 (x y z: aval) : aval := Ifptr (plub (provenance x) (plub (provenance y) (provenance z))).
               
Definition triple_op_float (sem: float -> float -> float -> float) (x y z: aval) :=
  match x, y, z with
  | F a, F b, F c => F (sem a b c)
  | _, _, _ => ntop3 x y z
  end.
               
Definition triple_op_single (sem: float32 -> float32 -> float32 -> float32) (x y z: aval) :=
  match x, y, z with
  | FS a, FS b, FS c => FS (sem a b c)
  | _, _, _ => ntop3 x y z
  end.

Definition fmaddf := triple_op_float (fun x y z => Float.fma y z x).
Definition fmsubf := triple_op_float (fun x y z => Float.fma (Float.neg y) z x).
Definition fmaddfs := triple_op_single (fun x y z => Float32.fma y z x).
Definition fmsubfs := triple_op_single (fun x y z => Float32.fma (Float32.neg y) z x).

Definition invfs (y : aval) :=
  match y with
  | FS f => FS (ExtFloat32.inv f)
  | _ => ntop1 y
  end.


Definition filter_static_condition (cond: condition) (vl: list aval): list aval :=
  match cond, vl with
  | (Ccomp Ceq | Ccompu Ceq), v1 :: v2 :: nil =>
      let v := vglb v1 v2 in
      v :: v :: nil
  | (Ccompimm Ceq n | Ccompuimm Ceq n), v1 :: nil =>
      (vglb v1 (I n))::nil
  | _, _ => vl
  end.

Definition eval_static_condition (cond: condition) (vl: list aval): abool :=
  match cond, vl with
  | Ccomp c, v1 :: v2 :: nil => cmp_bool c v1 v2
  | Ccompu c, v1 :: v2 :: nil => cmpu_bool c v1 v2
  | Ccompimm c n, v1 :: nil => cmp_bool c v1 (I n)
  | Ccompuimm c n, v1 :: nil => cmpu_bool c v1 (I n)
  | Ccompl c, v1 :: v2 :: nil => cmpl_bool c v1 v2
  | Ccomplu c, v1 :: v2 :: nil => cmplu_bool c v1 v2
  | Ccomplimm c n, v1 :: nil => cmpl_bool c v1 (L n)
  | Ccompluimm c n, v1 :: nil => cmplu_bool c v1 (L n)
  | Ccompf c, v1 :: v2 :: nil => cmpf_bool c v1 v2
  | Cnotcompf c, v1 :: v2 :: nil => cnot (cmpf_bool c v1 v2)
  | Ccompfs c, v1 :: v2 :: nil => cmpfs_bool c v1 v2
  | Cnotcompfs c, v1 :: v2 :: nil => cnot (cmpfs_bool c v1 v2)
  | _, _ => Bnone
  end.

Definition eval_static_addressing (addr: addressing) (vl: list aval): aval :=
  match addr, vl with
  | Aindexed n, v1::nil => offset_ptr v1 n
  | Aindexed2, v1::v2::nil => addl v1 v2
  | Aindexed2XS scale, v1::v2::nil => addl v1 (shll v2 (I (Int.repr scale)))
  | Aglobal s ofs, nil => Ptr (Gl s ofs)
  | Ainstack ofs, nil => Ptr (Stk ofs)
  | _, _ => Vbot
  end.

Definition eval_static_condition0 (cond : condition0) (v : aval) : abool :=
  match cond with
  | Ccomp0 c => cmp_bool c v (I Int.zero)
  | Ccompu0 c => cmpu_bool c v (I Int.zero)
  | Ccompl0 c => cmpl_bool c v (L Int64.zero)
  | Ccomplu0 c => cmplu_bool c v (L Int64.zero)
  end.
  

Definition eval_static_extfs (stop : Z) (start : Z) (v : aval) :=
  if is_bitfield stop start
  then
    let stop' := Z.add stop Z.one in
    match v with
    | I w =>
      I (Int.shr (Int.shl w (Int.repr (Z.sub Int.zwordsize stop'))) (Int.repr (Z.sub Int.zwordsize (Z.sub stop' start))))
    | _ => Vtop
    end
  else Vtop.

Definition eval_static_extfz (stop : Z) (start : Z) (v : aval) :=
  if is_bitfield stop start
  then
    let stop' := Z.add stop Z.one in
    match v with
    | I w =>
      I (Int.shru (Int.shl w (Int.repr (Z.sub Int.zwordsize stop'))) (Int.repr (Z.sub Int.zwordsize (Z.sub stop' start))))
    | _ => Vtop
    end
  else Vtop.

Definition eval_static_extfsl (stop : Z) (start : Z) (v : aval) :=
  if is_bitfieldl stop start
  then
    let stop' := Z.add stop Z.one in
    match v with
    | L w =>
      L (Int64.shr' (Int64.shl' w (Int.repr (Z.sub Int64.zwordsize stop'))) (Int.repr (Z.sub Int64.zwordsize (Z.sub stop' start))))
    | _ => Vtop
    end
  else Vtop.

Definition eval_static_extfzl (stop : Z) (start : Z) (v : aval) :=
  if is_bitfieldl stop start
  then
    let stop' := Z.add stop Z.one in
    match v with
    | L w =>
      L (Int64.shru' (Int64.shl' w (Int.repr (Z.sub Int64.zwordsize stop'))) (Int.repr (Z.sub Int64.zwordsize (Z.sub stop' start))))
    | _ => Vtop
    end
  else Vtop.

Definition eval_static_insf stop start prev fld :=
  let mask := Int.repr (zbitfield_mask stop start) in
  if is_bitfield stop start
  then
    match prev, fld with
    | (I prevI), (I fldI) =>
      if Int.ltu (Int.repr start) Int.iwordsize
      then I (Int.or (Int.and prevI (Int.not mask))
                     (Int.and (Int.shl fldI (Int.repr start)) mask))
      else Vtop
    | _, _ => Vtop
    end
  else Vtop.

Definition eval_static_insfl stop start prev fld :=
  let mask := Int64.repr (zbitfield_mask stop start) in
  if is_bitfieldl stop start
  then
    match prev, fld with
    | (L prevL), (L fldL) =>
      if Int.ltu (Int.repr start) Int64.iwordsize'
      then L (Int64.or (Int64.and prevL (Int64.not mask))
                       (Int64.and (Int64.shl' fldL (Int.repr start)) mask))
      else Vtop
    | _,_ => Vtop
    end
  else Vtop.

Definition absdiff := binop_int
   (fun i1 i2 => ExtValues.int_absdiff i1 i2).

Definition absdiffl := binop_long
   (fun i1 i2 => ExtValues.long_absdiff i1 i2).
              
Definition eval_static_operation (op: operation) (vl: list aval): aval :=
  match op, vl with
  | Omove, v1::nil => v1
  | Ocopy, v1::v2::nil => copy v1
  | Ocopyimm uid, v1::nil => copy v1
  | Ointconst n, nil => I n
  | Olongconst n, nil => L n
  | Ofloatconst n, nil => if propagate_float_constants tt then F n else ntop
  | Osingleconst n, nil => if propagate_float_constants tt then FS n else ntop
  | Oaddrsymbol id ofs, nil => Ptr (Gl id ofs)
  | Oaddrstack ofs, nil => Ptr (Stk ofs)
  | Ocast8signed, v1 :: nil => sign_ext 8 v1
  | Ocast16signed, v1 :: nil => sign_ext 16 v1
  | Oadd, v1::v2::nil => add v1 v2
  | Oaddimm n, v1::nil => add v1 (I n)
  | Oaddx shift, v1::v2::nil => add v2 (shl v1 (I (int_of_shift1_4 shift)))
  | Oaddximm shift n, v1::nil => add (I n) (shl v1 (I (int_of_shift1_4 shift)))
  | Oneg, v1::nil => neg v1
  | Osub, v1::v2::nil => sub v1 v2
  | Orevsubx shift, v1::v2::nil => sub v2 (shl v1 (I (int_of_shift1_4 shift)))
  | Orevsubimm n, v1::nil => sub (I n) v1
  | Orevsubximm shift n, v1::nil => sub (I n) (shl v1 (I (int_of_shift1_4 shift)))
  | Omul, v1::v2::nil => mul v1 v2
  | Omulimm n, v1::nil => mul v1 (I n)
  | Odiv, v1::v2::nil => divs v1 v2
  | Odivu, v1::v2::nil => divu v1 v2
  | Omod, v1::v2::nil => mods v1 v2
  | Omodu, v1::v2::nil => modu v1 v2
  | Oand, v1::v2::nil => and v1 v2
  | Oandimm n, v1::nil => and v1 (I n)
  | Onand, v1::v2::nil => notint (and v1 v2)
  | Onandimm n, v1::nil => notint (and v1 (I n))
  | Oor, v1::v2::nil => or v1 v2
  | Oorimm n, v1::nil => or v1 (I n)
  | Onor, v1::v2::nil => notint (or v1 v2)
  | Onorimm n, v1::nil => notint (or v1 (I n))
  | Oxor, v1::v2::nil => xor v1 v2
  | Oxorimm n, v1::nil => xor v1 (I n)
  | Onxor, v1::v2::nil => notint (xor v1 v2)
  | Onxorimm n, v1::nil => notint (xor v1 (I n))
  | Onot, v1::nil => notint v1
  | Oandn, v1::v2::nil => and (notint v1) v2
  | Oandnimm n, v1::nil => and (notint v1) (I n)
  | Oorn, v1::v2::nil => or (notint v1) v2
  | Oornimm n, v1::nil => or (notint v1) (I n)
  | Oshl, v1::v2::nil => shl v1 v2
  | Oshlimm n, v1::nil => shl v1 (I n)
  | Oshr, v1::v2::nil => shr v1 v2
  | Oshrimm n, v1::nil => shr v1 (I n)
  | Ororimm n, v1::nil => ror v1 (I n)
  | Oshru, v1::v2::nil => shru v1 v2
  | Oshruimm n, v1::nil => shru v1 (I n)
  | Oshrximm n, v1::nil => shrx v1 (I n)
  | Omadd, v1::v2::v3::nil => add v1 (mul v2 v3)
  | Omaddimm n, v1::v2::nil => add v1 (mul v2 (I n))
  | Omsub, v1::v2::v3::nil => sub v1 (mul v2 v3)
  | Omakelong, v1::v2::nil => longofwords v1 v2
  | Olowlong, v1::nil => loword v1
  | Ohighlong, v1::nil => hiword v1
  | Ocast32signed, v1::nil => longofint v1
  | Ocast32unsigned, v1::nil => longofintu v1
  | Oaddl, v1::v2::nil => addl v1 v2
  | Oaddlimm n, v1::nil => addl v1 (L n)
  | Oaddxl shift, v1::v2::nil => addl v2 (shll v1 (I (int_of_shift1_4 shift)))
  | Oaddxlimm shift n, v1::nil => addl (L n) (shll v1 (I (int_of_shift1_4 shift)))
  | Onegl, v1::nil => negl v1
  | Osubl, v1::v2::nil => subl v1 v2
  | Orevsubxl shift, v1::v2::nil => subl v2 (shll v1 (I (int_of_shift1_4 shift)))
  | Orevsublimm n, v1::nil => subl (L n) v1
  | Orevsubxlimm shift n, v1::nil => subl (L n) (shll v1 (I (int_of_shift1_4 shift)))
  | Omull, v1::v2::nil => mull v1 v2
  | Omullimm n, v1::nil => mull v1 (L n)
  | Omullhs, v1::v2::nil => mullhs v1 v2
  | Omullhu, v1::v2::nil => mullhu v1 v2
  | Odivl, v1::v2::nil => divls v1 v2
  | Odivlu, v1::v2::nil => divlu v1 v2
  | Omodl, v1::v2::nil => modls v1 v2
  | Omodlu, v1::v2::nil => modlu v1 v2
  | Oandl, v1::v2::nil => andl v1 v2
  | Oandlimm n, v1::nil => andl v1 (L n)
  | Onandl, v1::v2::nil => notl (andl v1 v2)
  | Onandlimm n, v1::nil => notl (andl v1 (L n))
  | Oorl, v1::v2::nil => orl v1 v2
  | Oorlimm n, v1::nil => orl v1 (L n)
  | Onorl, v1::v2::nil => notl (orl v1 v2)
  | Onorlimm n, v1::nil => notl (orl v1 (L n))
  | Oxorl, v1::v2::nil => xorl v1 v2
  | Oxorlimm n, v1::nil => xorl v1 (L n)
  | Onxorl, v1::v2::nil => notl (xorl v1 v2)
  | Onxorlimm n, v1::nil => notl (xorl v1 (L n))
  | Onotl, v1::nil => notl v1
  | Oandnl, v1::v2::nil => andl (notl v1) v2
  | Oandnlimm n, v1::nil => andl (notl v1) (L n)
  | Oornl, v1::v2::nil => orl (notl v1) v2
  | Oornlimm n, v1::nil => orl (notl v1) (L n)
  | Oshll, v1::v2::nil => shll v1 v2
  | Oshllimm n, v1::nil => shll v1 (I n)
  | Oshrl, v1::v2::nil => shrl v1 v2
  | Oshrlimm n, v1::nil => shrl v1 (I n)
  | Oshrlu, v1::v2::nil => shrlu v1 v2
  | Oshrluimm n, v1::nil => shrlu v1 (I n)
  | Oshrxlimm n, v1::nil => shrxl v1 (I n)
  | Omaddl, v1::v2::v3::nil => addl v1 (mull v2 v3)
  | Omaddlimm n, v1::v2::nil => addl v1 (mull v2 (L n))
  | Omsubl, v1::v2::v3::nil => subl v1 (mull v2 v3)
  | Onegf, v1::nil => negf v1
  | Oabsf, v1::nil => absf v1
  | Oaddf, v1::v2::nil => addf v1 v2
  | Osubf, v1::v2::nil => subf v1 v2
  | Omulf, v1::v2::nil => mulf v1 v2
  | Odivf, v1::v2::nil => divf v1 v2
  | Ominf, v1::v2::nil => minf v1 v2
  | Omaxf, v1::v2::nil => maxf v1 v2
  | Ofmaddf, v1::v2::v3::nil => fmaddf v1 v2 v3
  | Ofmsubf, v1::v2::v3::nil => fmsubf v1 v2 v3
  | Onegfs, v1::nil => negfs v1
  | Oabsfs, v1::nil => absfs v1
  | Oaddfs, v1::v2::nil => addfs v1 v2
  | Osubfs, v1::v2::nil => subfs v1 v2
  | Omulfs, v1::v2::nil => mulfs v1 v2
  | Odivfs, v1::v2::nil => divfs v1 v2
  | Ominfs, v1::v2::nil => minfs v1 v2
  | Omaxfs, v1::v2::nil => maxfs v1 v2
  | Oinvfs, v1::nil => invfs v1
  | Ofmaddfs, v1::v2::v3::nil => fmaddfs v1 v2 v3
  | Ofmsubfs, v1::v2::v3::nil => fmsubfs v1 v2 v3
  | Osingleoffloat, v1::nil => singleoffloat v1
  | Ofloatofsingle, v1::nil => floatofsingle v1
  | Ointoffloat, v1::nil => intoffloat_total v1
  | Ointuoffloat, v1::nil => intuoffloat_total v1
  | Ointofsingle, v1::nil => intofsingle_total v1
  | Ointuofsingle, v1::nil => intuofsingle_total v1
  | Osingleofint, v1::nil => singleofint v1
  | Osingleofintu, v1::nil => singleofintu v1
  | Olongoffloat, v1::nil => longoffloat_total v1
  | Olonguoffloat, v1::nil => longuoffloat_total v1
  | Ofloatoflong, v1::nil => floatoflong v1
  | Ofloatoflongu, v1::nil => floatoflongu v1
  | Olongofsingle, v1::nil => longofsingle_total v1
  | Olonguofsingle, v1::nil => longuofsingle_total v1
  | Osingleoflong, v1::nil => singleoflong v1
  | Osingleoflongu, v1::nil => singleoflongu v1
  | Ointofsingle_ne, v1::nil => intofsingle_ne_total v1
  | Ointuofsingle_ne, v1::nil => intuofsingle_ne_total v1
  | Olongoffloat_ne, v1::nil => longoffloat_ne_total v1
  | Olonguoffloat_ne, v1::nil => longuoffloat_ne_total v1
  | Ocmp c, _ => of_optbool (eval_static_condition c vl)
  | (Oextfz stop start), v0::nil => eval_static_extfz stop start v0
  | (Oextfs stop start), v0::nil => eval_static_extfs stop start v0
  | (Oextfzl stop start), v0::nil => eval_static_extfzl stop start v0
  | (Oextfsl stop start), v0::nil => eval_static_extfsl stop start v0
  | (Oinsf stop start), v0::v1::nil => eval_static_insf stop start v0 v1
  | (Oinsfl stop start), v0::v1::nil => eval_static_insfl stop start v0 v1
  | Osel c, v1::v2::vc::nil => select (eval_static_condition0 c vc) v1 v2
  | Oselimm c imm, v1::vc::nil => select (eval_static_condition0 c vc) v1 (I imm)
  | Osellimm c imm, v1::vc::nil => select (eval_static_condition0 c vc) v1 (L imm)
  | Oabsdiff, v1::v2::nil => absdiff v1 v2
  | (Oabsdiffimm n2), v1::nil => absdiff v1 (I n2)
  | Oabsdiffl, v1::v2::nil => absdiffl v1 v2
  | (Oabsdifflimm n2), v1::nil => absdiffl v1 (L n2)
  | _, _ => Vbot
  end.

Section SOUNDNESS.

Variable bc: block_classification.
Variable genF genV: Type.
Variable ge: Genv.t genF genV.
Hypothesis GENV: genv_match bc ge.
Variable sp: block.
Hypothesis STACK: bc sp = BCstack.

Theorem filter_static_condition_sound:
  forall cond vargs m aargs
         (MATCH : list_forall2 (vmatch bc) vargs aargs)
         (COND : (eval_condition cond vargs m) = Some true),
     (list_forall2 (vmatch bc) vargs (filter_static_condition cond aargs)).

Lemma absdiff_sound:
  forall v x w y
         (vMATCH : vmatch bc v x)
         (wMATCH : vmatch bc w y),
    vmatch bc (ExtValues.absdiff v w) (absdiff x y).

Lemma absdiffl_sound:
  forall v x w y
         (vMATCH : vmatch bc v x)
         (wMATCH : vmatch bc w y),
    vmatch bc (ExtValues.absdiffl v w) (absdiffl x y).

Lemma minf_sound:
  forall v x w y, vmatch bc v x -> vmatch bc w y -> vmatch bc (ExtValues.minf v w) (minf x y).

Lemma maxf_sound:
  forall v x w y, vmatch bc v x -> vmatch bc w y -> vmatch bc (ExtValues.maxf v w) (maxf x y).

Lemma minfs_sound:
  forall v x w y, vmatch bc v x -> vmatch bc w y -> vmatch bc (ExtValues.minfs v w) (minfs x y).

Lemma maxfs_sound:
  forall v x w y, vmatch bc v x -> vmatch bc w y -> vmatch bc (ExtValues.maxfs v w) (maxfs x y).

Lemma invfs_sound:
  forall v x, vmatch bc v x -> vmatch bc (ExtValues.invfs v) (invfs x).

Lemma triple_op_float_sound:
  forall f a x b y c z,
    vmatch bc a x -> vmatch bc b y -> vmatch bc c z ->
    vmatch bc (ExtValues.triple_op_float f a b c)
           (triple_op_float f x y z).

Lemma triple_op_single_sound:
  forall f a x b y c z,
    vmatch bc a x -> vmatch bc b y -> vmatch bc c z ->
    vmatch bc (ExtValues.triple_op_single f a b c)
           (triple_op_single f x y z).

Lemma fmaddf_sound :
  forall a x b y c z, vmatch bc a x -> vmatch bc b y -> vmatch bc c z ->
                      vmatch bc (ExtValues.fmaddf a b c) (fmaddf x y z).

Lemma fmaddfs_sound :
  forall a x b y c z, vmatch bc a x -> vmatch bc b y -> vmatch bc c z ->
                      vmatch bc (ExtValues.fmaddfs a b c) (fmaddfs x y z).

Lemma fmsubf_sound :
  forall a x b y c z, vmatch bc a x -> vmatch bc b y -> vmatch bc c z ->
                      vmatch bc (ExtValues.fmsubf a b c) (fmsubf x y z).

Lemma fmsubfs_sound :
  forall a x b y c z, vmatch bc a x -> vmatch bc b y -> vmatch bc c z ->
                      vmatch bc (ExtValues.fmsubfs a b c) (fmsubfs x y z).
Hint Resolve minf_sound maxf_sound minfs_sound maxfs_sound invfs_sound fmaddf_sound fmaddfs_sound fmsubf_sound fmsubfs_sound : va.

Theorem eval_static_condition_sound:
  forall cond vargs m aargs,
  list_forall2 (vmatch bc) vargs aargs ->
  cmatch (eval_condition cond vargs m) (eval_static_condition cond aargs).

Theorem eval_static_condition0_sound:
  forall cond varg m aarg,
  vmatch bc varg aarg ->
  cmatch (eval_condition0 cond varg m) (eval_static_condition0 cond aarg).

Lemma symbol_address_sound:
  forall id ofs,
  vmatch bc (Genv.symbol_address ge id ofs) (Ptr (Gl id ofs)).

Lemma symbol_address_sound_2:
  forall id ofs,
  vmatch bc (Genv.symbol_address ge id ofs) (Ifptr (Gl id ofs)).

Hint Resolve symbol_address_sound symbol_address_sound_2: va.

Ltac InvHyps :=
  match goal with
  | [H: None = Some _ |- _ ] => discriminate
  | [H: Some _ = Some _ |- _] => inv H
  | [H1: match ?vl with nil => _ | _ :: _ => _ end = Some _ ,
     H2: list_forall2 _ ?vl _ |- _ ] => inv H2; InvHyps
  | [H: (if Archi.ptr64 then _ else _) = Some _ |- _] => destruct Archi.ptr64 eqn:?; InvHyps
  | _ => idtac
  end.

Theorem eval_static_addressing_sound:
  forall addr vargs vres aargs,
  eval_addressing ge (Vptr sp Ptrofs.zero) addr vargs = Some vres ->
  list_forall2 (vmatch bc) vargs aargs ->
  vmatch bc vres (eval_static_addressing addr aargs).

Theorem eval_static_addressing_sound_none:
  forall addr vargs aargs,
  eval_addressing ge (Vptr sp Ptrofs.zero) addr vargs = None ->
  list_forall2 (vmatch bc) vargs aargs ->
  (eval_static_addressing addr aargs) = Vbot.

Lemma vmatch_vint_ntop1:
  forall x y, vmatch bc (Vint x) (ntop1 y).

Lemma vmatch_vlong_ntop1:
  forall x y, vmatch bc (Vlong x) (ntop1 y).

Hint Resolve vmatch_vint_ntop1 vmatch_vlong_ntop1: va.

Lemma select_sound' : forall c v1 v2 ty ac a1 a2,
    cmatch c ac ->
    vmatch bc v1 a1 ->
    vmatch bc v2 a2 ->
    vmatch bc (Val.normalize (Val.select c v1 v2) ty) (select ac a1 a2).

Theorem eval_static_operation_sound:
  forall op vargs m vres aargs,
  eval_operation ge (Vptr sp Ptrofs.zero) op vargs m = Some vres ->
  list_forall2 (vmatch bc) vargs aargs ->
  vmatch bc vres (eval_static_operation op aargs).

End SOUNDNESS.

Arguments eval_static_operation_sound (bc) {genF genV}.
Arguments eval_static_addressing_sound (bc) {genF genV}.