Require Export compcert.lib.Axioms.
Require Export compcert.lib.Integers.
Require Export compcert.lib.Floats.
Require Export compcert.lib.Maps.
Require Export compcert.common.AST.
Require Export compcert.common.Values.
Require Export compcert.cfrontend.Ctypes.
Require Export compcert.cfrontend.Clight.
Require Export VST.sepcomp.Address.
Require Export VST.msl.eq_dec.
Require Export VST.msl.shares.
Require Export VST.msl.predicates_rec.
Require Export VST.msl.contractive.
Require Export VST.msl.seplog.
Require Export VST.msl.ghost_seplog.
Require Export VST.msl.alg_seplog.
Require Export VST.msl.log_normalize.
Require Export VST.msl.wand_frame.
Require Export VST.msl.wandQ_frame.
Require Export VST.msl.ramification_lemmas.
Require Export VST.veric.tycontext.
Require Export VST.veric.change_compspecs.
Require Export VST.veric.mpred.
Require Export VST.veric.expr.
Require Export VST.veric.Clight_lemmas.
Require Export VST.veric.composite_compute.
Require Export VST.veric.align_mem.
Require Export VST.veric.shares.
Require Export VST.veric.seplog.
Require VST.veric.Clight_seplog.
Require VST.veric.Clight_assert_lemmas.
Require VST.veric.semax_prog.
Require VST.veric.semax_ext.
Instance Nveric: NatDed mpred := algNatDed compcert_rmaps.RML.R.rmap.
Instance Sveric: SepLog mpred := algSepLog compcert_rmaps.RML.R.rmap.
Instance Cveric: ClassicalSep mpred := algClassicalSep compcert_rmaps.RML.R.rmap.
Instance Iveric: Indir mpred := algIndir compcert_rmaps.RML.R.rmap.
Instance Rveric: RecIndir mpred := algRecIndir compcert_rmaps.RML.R.rmap.
Instance SIveric: SepIndir mpred := algSepIndir compcert_rmaps.RML.R.rmap.
Instance CSLveric: CorableSepLog mpred := algCorableSepLog compcert_rmaps.RML.R.rmap.
Instance CIveric: CorableIndir mpred := algCorableIndir compcert_rmaps.RML.R.rmap.
Instance SRveric: SepRec mpred := algSepRec compcert_rmaps.RML.R.rmap.
Instance Bveric: BupdSepLog mpred gname compcert_rmaps.RML.R.preds :=
mkBSL _ _ _ _ _ bupd (@own) bupd_intro bupd_mono bupd_trans bupd_frame_r
(@ghost_alloc) (@ghost_op) (@ghost_valid_2) (@ghost_update_ND) (@ghost_dealloc).
Instance LiftNatDed' T {ND: NatDed T}: NatDed (LiftEnviron T) := LiftNatDed _ _.
Instance LiftSepLog' T {ND: NatDed T}{SL: SepLog T}: SepLog (LiftEnviron T) := LiftSepLog _ _.
Instance LiftClassicalSep' T {ND: NatDed T}{SL: SepLog T}{CS: ClassicalSep T} :
ClassicalSep (LiftEnviron T) := LiftClassicalSep _ _.
Instance LiftIndir' T {ND: NatDed T}{SL: SepLog T}{IT: Indir T} :
Indir (LiftEnviron T) := LiftIndir _ _.
Instance LiftSepIndir' T {ND: NatDed T}{SL: SepLog T}{IT: Indir T}{SI: SepIndir T} :
SepIndir (LiftEnviron T) := LiftSepIndir _ _.
Instance LiftCorableSepLog' T {ND: NatDed T}{SL: SepLog T}{CSL: CorableSepLog T} :
CorableSepLog (LiftEnviron T) := LiftCorableSepLog _ _.
Instance LiftCorableIndir' T {ND: NatDed T}{SL: SepLog T}{IT: Indir T}{SI: SepIndir T}{CSL: CorableSepLog T}{CI: CorableIndir T} :
CorableIndir (LiftEnviron T) := LiftCorableIndir _ _.
Definition local:  (environ -> Prop) -> environ->mpred :=  lift1 prop.
Global Opaque mpred Nveric Sveric Cveric Iveric Rveric Sveric SIveric CSLveric CIveric SRveric Bveric.
Hint Resolve any_environ : typeclass_instances.
Local Open Scope logic.
Transparent mpred Nveric Sveric Cveric Iveric Rveric Sveric SIveric CSLveric CIveric SRveric Bveric.
(* BEGIN from expr2.v *)
Definition denote_tc_iszero v : mpred :=
match v with
| Vint i => prop (is_true (Int.eq i Int.zero))
| Vlong i => prop (is_true (Int64.eq i Int64.zero))
| _ => FF
end.
Definition denote_tc_nonzero v : mpred :=
match v with
| Vint i => prop (i <> Int.zero)
| Vlong i =>prop (i <> Int64.zero)
| _ => FF end.
Definition denote_tc_igt i v : mpred :=
match v with
| Vint i1 => prop (Int.unsigned i1 < Int.unsigned i)
| _ => FF
end.
Definition denote_tc_lgt l v : mpred :=
match v with
| Vlong l1 => prop (Int64.unsigned l1 < Int64.unsigned l)
| _ => FF
end.
Definition Zoffloat (f:float): option Z := (**r conversion to Z *)
match f with
| IEEE754.Binary.B754_finite s m (Zpos e) _ =>
Some (Zaux.cond_Zopp s (Zpos m) * Zpower_pos 2 e)%Z
| IEEE754.Binary.B754_finite s m 0 _ => Some (Zaux.cond_Zopp s (Zpos m))
| IEEE754.Binary.B754_finite s m (Zneg e) _ => Some (Zaux.cond_Zopp s (Zpos m / Zpower_pos 2 e))
| IEEE754.Binary.B754_zero _ => Some 0
| _ => None
end.  (* copied from CompCert 2.3, because it's missing in CompCert 2.4,
then adapted after CompCert 3.5 when Flocq was rearranged *)
Definition Zofsingle (f: float32): option Z := (**r conversion to Z *)
match f with
| IEEE754.Binary.B754_finite s m (Zpos e) _ =>
Some (Zaux.cond_Zopp s (Zpos m) * Zpower_pos 2 e)%Z
| IEEE754.Binary.B754_finite s m 0 _ => Some (Zaux.cond_Zopp s (Zpos m))
| IEEE754.Binary.B754_finite s m (Zneg e) _ => Some (Zaux.cond_Zopp s (Zpos m / Zpower_pos 2 e))
| IEEE754.Binary.B754_zero _ => Some 0
| _ => None
end.
Definition denote_tc_Zge z v : mpred :=
match v with
| Vfloat f => match Zoffloat f with
| Some n => prop (z >= n)
| None => FF
end
| Vsingle f => match Zofsingle f with
| Some n => prop (z >= n)
| None => FF
end
| _ => FF
end.
Definition denote_tc_Zle z v : mpred :=
match v with
| Vfloat f => match Zoffloat f with
| Some n => prop (z <= n)
| None => FF
end
| Vsingle f => match Zofsingle f with
| Some n => prop (z <= n)
| None => FF
end
| _ => FF
end.
Definition sameblock v1 v2 : bool :=
match v1, v2 with
| Vptr b1 _, Vptr b2 _ => peq b1 b2
| _, _ => false
end.
Definition denote_tc_samebase v1 v2 : mpred :=
prop (is_true (sameblock v1 v2)).
(** Case for division of int min by -1, which would cause overflow **)
Definition denote_tc_nodivover v1 v2 : mpred :=
match v1, v2 with
| Vint n1, Vint n2 => prop (~(n1 = Int.repr Int.min_signed /\ n2 = Int.mone))
| Vlong n1, Vlong n2 => prop (~(n1 = Int64.repr Int64.min_signed /\ n2 = Int64.mone))
| Vint n1, Vlong n2 => TT
| Vlong n1, Vint n2 => prop (~ (n1 = Int64.repr Int64.min_signed  /\ n2 = Int.mone))
| _ , _ => FF
end.
Definition denote_tc_nosignedover (op: Z->Z->Z) v1 v2 : mpred :=
match v1,v2 with
| Vint n1, Vint n2 =>
prop (Int.min_signed <= op (Int.signed n1) (Int.signed n2) <= Int.max_signed)
| Vlong n1, Vlong n2 =>
prop (Int64.min_signed <= op (Int64.signed n1) (Int64.signed n2) <= Int64.max_signed)
| Vint n1, Vlong n2 =>
prop (Int64.min_signed <= op (Int.signed n1) (Int64.signed n2) <= Int64.max_signed)
| Vlong n1, Vint n2 =>
prop (Int64.min_signed <= op (Int64.signed n1) (Int.signed n2) <= Int64.max_signed)
| _, _ => FF
end.
Definition denote_tc_initialized id ty rho : mpred :=
prop (exists v, Map.get (te_of rho) id = Some v
/\ tc_val ty v).
Definition denote_tc_isptr v : mpred :=
prop (isptr v).
Definition denote_tc_isint v : mpred :=
prop (is_int I32 Signed v).
Definition denote_tc_islong v : mpred :=
prop (is_long v).
Definition test_eq_ptrs v1 v2 : mpred :=
if sameblock v1 v2
then (andp (weak_valid_pointer v1) (weak_valid_pointer v2))
else (andp (valid_pointer v1) (valid_pointer v2)).
Definition test_order_ptrs v1 v2 : mpred :=
if sameblock v1 v2
then (andp (weak_valid_pointer v1) (weak_valid_pointer v2))
else FF.
Definition denote_tc_test_eq v1 v2 : mpred :=
match v1, v2 with
| Vint i, Vint j =>
if Archi.ptr64 then FF else andp (prop (i = Int.zero)) (prop (j = Int.zero))
| Vlong i, Vlong j =>
if Archi.ptr64 then andp (prop (i = Int64.zero)) (prop (j = Int64.zero)) else FF
| Vint i, Vptr _ _ =>
if Archi.ptr64 then FF else andp (prop (i = Int.zero)) (weak_valid_pointer v2)
| Vlong i, Vptr _ _ =>
if Archi.ptr64 then andp (prop (i = Int64.zero)) (weak_valid_pointer v2) else FF
| Vptr _ _, Vint i =>
if Archi.ptr64 then FF else andp (prop (i = Int.zero)) (weak_valid_pointer v1)
| Vptr _ _, Vlong i =>
if Archi.ptr64 then andp (prop (i = Int64.zero)) (weak_valid_pointer v1) else FF
| Vptr _ _, Vptr _ _ =>
test_eq_ptrs v1 v2
| _, _ => FF
end.
Definition denote_tc_test_order v1 v2 : mpred :=
match v1, v2 with
| Vint i, Vint j => if Archi.ptr64 then FF else andp (prop (i = Int.zero)) (prop (j = Int.zero))
| Vlong i, Vlong j => if Archi.ptr64 then andp (prop (i = Int64.zero)) (prop (j = Int64.zero)) else FF
| Vptr _ _, Vptr _ _ =>
test_order_ptrs v1 v2
| _, _ => FF
end.
Definition typecheck_error (e: tc_error) : Prop := False.
Global Opaque typecheck_error.
(* Somehow, this fixes a universe collapse issue that will occur if fool is not defined. *)
Definition fool := @map _ Type (fun it : ident * type => mpred).
Fixpoint denote_tc_assert {CS: compspecs} (a: tc_assert) : environ -> mpred :=
match a with
| tc_FF msg => `(prop (typecheck_error msg))
| tc_TT => TT
| tc_andp' b c => fun rho => andp (denote_tc_assert b rho) (denote_tc_assert c rho)
| tc_orp' b c => `orp (denote_tc_assert b) (denote_tc_assert c)
| tc_nonzero' e => `denote_tc_nonzero (eval_expr e)
| tc_isptr e => `denote_tc_isptr (eval_expr e)
| tc_isint e => `denote_tc_isint (eval_expr e)
| tc_islong e => `denote_tc_islong (eval_expr e)
| tc_test_eq' e1 e2 => `denote_tc_test_eq (eval_expr e1) (eval_expr e2)
| tc_test_order' e1 e2 => `denote_tc_test_order (eval_expr e1) (eval_expr e2)
| tc_ilt' e i => `(denote_tc_igt i) (eval_expr e)
| tc_llt' e i => `(denote_tc_lgt i) (eval_expr e)
| tc_Zle e z => `(denote_tc_Zge z) (eval_expr e)
| tc_Zge e z => `(denote_tc_Zle z) (eval_expr e)
| tc_samebase e1 e2 => `denote_tc_samebase (eval_expr e1) (eval_expr e2)
| tc_nodivover' v1 v2 => `denote_tc_nodivover (eval_expr v1) (eval_expr v2)
| tc_initialized id ty => denote_tc_initialized id ty
| tc_iszero' e => `denote_tc_iszero (eval_expr e)
| tc_nosignedover op e1 e2 => `(denote_tc_nosignedover op) (eval_expr e1) (eval_expr e2)
end.
Definition fool' := @map _ Type (fun it : ident * type => mpred).
Opaque mpred Nveric Sveric Cveric Iveric Rveric Sveric SIveric CSLveric CIveric SRveric Bveric.
(* END from expr2.v *)
Definition cast_pointer_to_bool t1 t2 :=
match t1 with (Tpointer _ _ | Tarray _ _ _ | Tfunction _ _ _) =>
match t2 with Tint IBool _ _ => true | _ => false end
| _ => false
end.
Fixpoint ext_link_prog' (dl: list (ident * globdef fundef type)) (s: String.string) : option ident :=
match dl with
| (id, Gfun (External EF_malloc _ _ _)) :: dl' =>
if String.string_dec s "_malloc" then Some id else ext_link_prog' dl' s
| (id, Gfun (External EF_free _ _ _)) :: dl' =>
if String.string_dec s "_free" then Some id else ext_link_prog' dl' s
| (id, Gfun (External (EF_external s' _) _ _ _)) :: dl' =>
if String.string_dec s s' then Some id else ext_link_prog' dl' s
| (id, Gfun (External (EF_builtin s' _) _ _ _)) :: dl' =>
if String.string_dec s s' then Some id else ext_link_prog' dl' s
| _ :: dl' =>
ext_link_prog' dl' s
| nil => None
end.
Definition ext_link_prog (p: program) (s: String.string) : ident :=
match ext_link_prog' (prog_defs p) s with Some id => id | None => 1%positive end.
Definition closed_wrt_vars {B} (S: ident -> Prop) (F: environ -> B) : Prop :=
forall rho te',
(forall i, S i \/ Map.get (te_of rho) i = Map.get te' i) ->
F rho = F (mkEnviron (ge_of rho) (ve_of rho) te').
Definition closed_wrt_lvars {B} (S: ident -> Prop) (F: environ -> B) : Prop :=
forall rho ve',
(forall i, S i \/ Map.get (ve_of rho) i = Map.get ve' i) ->
F rho = F (mkEnviron (ge_of rho) ve' (te_of rho)).
Definition not_a_param (params: list (ident * type)) (i : ident) : Prop :=
~ In i (map (@fst _ _) params).
Definition precondition_closed (fs: list (ident*type)) {A: rmaps.TypeTree}
(P: forall ts, functors.MixVariantFunctor._functor (rmaps.dependent_type_functor_rec ts (AssertTT A)) mpred) : Prop :=
forall ts x,
closed_wrt_vars (not_a_param fs) (P ts x) /\
closed_wrt_lvars (fun _ => True) (P ts x).
Definition typed_true (t: type) (v: val)  : Prop :=  strict_bool_val v t
= Some true.
Definition typed_false (t: type)(v: val) : Prop :=  strict_bool_val v t =
Some false.
Definition subst {A} (x: ident) (v: environ -> val) (P: environ -> A) : environ -> A :=
fun s => P (env_set s x (v s)).
Definition substopt {A} (ret: option ident) (v: environ -> val) (P: environ -> A)  : environ -> A :=
match ret with
| Some id => subst id v P
| None => P
end.
Definition cast_expropt {CS: compspecs} (e: option expr) t : environ -> option val :=
match e with Some e' => `Some (eval_expr (Ecast e' t))  | None => `None end.
Definition typecheck_tid_ptr_compare
Delta id :=
match (temp_types Delta) ! id with
| Some t => is_int_type t
| None => false
end.
Definition mapsto (sh: Share.t) (t: type) (v1 v2 : val): mpred :=
match access_mode t with
| By_value ch =>
match type_is_volatile t with
| false =>
match v1 with
| Vptr b ofs =>
if readable_share_dec sh
then @orp mpred _
(@andp mpred _ (!!tc_val t v2)
(res_predicates.address_mapsto ch v2 sh (b, Ptrofs.unsigned ofs)))
(@andp mpred _ (!! (v2 = Vundef))
(@exp mpred _ val (fun v2' =>res_predicates.address_mapsto ch v2' sh (b, Ptrofs.unsigned ofs))))
else @andp mpred _
(!! (tc_val' t v2 /\ (Memdata.align_chunk ch | Ptrofs.unsigned ofs)))
(res_predicates.nonlock_permission_bytes sh (b, Ptrofs.unsigned ofs) (Memdata.size_chunk ch))
| _ => FF
end
| _ => FF
end
| _ => FF
end.
Definition mapsto_ sh t v1 := mapsto sh t v1 Vundef.
Definition mapsto_zeros (n: Z) (sh: share) (a: val) : mpred :=
match a with
| Vptr b z =>
!! (0 <= Ptrofs.unsigned z  /\ n + Ptrofs.unsigned z < Ptrofs.modulus)%Z &&
mapsto_memory_block.address_mapsto_zeros sh (Z.to_nat n) (b, Ptrofs.unsigned z)
| _ => FF
end.
Definition init_data2pred (d: init_data)  (sh: share) (a: val) (rho: environ) : mpred :=
match d with
| Init_int8 i => mapsto sh (Tint I8 Unsigned noattr) a (Vint (Int.zero_ext 8 i))
| Init_int16 i => mapsto sh (Tint I16 Unsigned noattr) a (Vint (Int.zero_ext 16 i))
| Init_int32 i => mapsto sh (Tint I32 Unsigned noattr) a (Vint i)
| Init_int64 i => mapsto sh (Tlong Unsigned noattr) a (Vlong i)
| Init_float32 r =>  mapsto sh (Tfloat F32 noattr) a (Vsingle r)
| Init_float64 r =>  mapsto sh (Tfloat F64 noattr) a (Vfloat r)
| Init_space n => mapsto_zeros n sh a
| Init_addrof symb ofs =>
match Map.get (ge_of rho) symb with
| Some b => mapsto sh (Tpointer Tvoid noattr) a (Vptr b ofs)
| _ => mapsto_ sh (Tpointer Tvoid noattr) a
end
end.
(*Definition extern_retainer : share := fst (Share.split Share.Lsh). *)
Definition init_data_size (i: init_data) : Z :=
match i with
| Init_int8 _ => 1
| Init_int16 _ => 2
| Init_int32 _ => 4
| Init_int64 _ => 8
| Init_float32 _ => 4
| Init_float64 _ => 8
| Init_addrof _ _ => if Archi.ptr64 then 8 else 4
| Init_space n => Z.max n 0
end.
Fixpoint init_data_list_size (il: list init_data) {struct il} : Z :=
match il with
| nil => 0
| i :: il' => init_data_size i + init_data_list_size il'
end.
Fixpoint init_data_list2pred  (dl: list init_data)
(sh: share) (v: val)  : environ -> mpred :=
match dl with
| d::dl' =>
sepcon (init_data2pred d sh v)
(init_data_list2pred dl' sh (offset_val (init_data_size d) v))
| nil => emp
end.
Definition readonly2share (rdonly: bool) : share :=
if rdonly then Ers else Ews.
Definition globals := ident -> val.
Definition globvar2pred (gv: globals) (idv: ident * globvar type) : environ->mpred :=
if (gvar_volatile (snd idv))
then  lift0 TT
else    init_data_list2pred (gvar_init (snd idv))
(readonly2share (gvar_readonly (snd idv))) (gv (fst idv)).
Definition globals_of_env (rho: environ) (i: ident) : val :=
match Map.get (ge_of rho) i with Some b => Vptr b Ptrofs.zero | None => Vundef end.
Definition globvars2pred  (gv: globals)  (vl: list (ident * globvar type)) : environ->mpred :=
(lift2 andp) (fun rho => prop (gv = globals_of_env rho))
(fold_right sepcon emp (map (globvar2pred gv) vl)).
Definition initializer_aligned (z: Z) (d: init_data) : bool :=
match d with
| Init_int16 n => Zeq_bool (z mod 2) 0
| Init_int32 n => Zeq_bool (z mod 4) 0
| Init_int64 n => Zeq_bool (z mod 8) 0
| Init_float32 n =>  Zeq_bool (z mod 4) 0
| Init_float64 n =>  Zeq_bool (z mod 8) 0
| Init_addrof symb ofs =>  Zeq_bool (z mod (size_chunk Mptr)) 0
| _ => true
end.
Fixpoint initializers_aligned (z: Z) (dl: list init_data) : bool :=
match dl with
| nil => true
| d::dl' => andb (initializer_aligned z d) (initializers_aligned (z + init_data_size d) dl')
end.
Definition funsig := (list (ident*type) * type)%type. (* argument and result signature *)
Definition memory_block (sh: share) (n: Z) (v: val) : mpred :=
match v with
| Vptr b ofs => (!! (Ptrofs.unsigned ofs + n < Ptrofs.modulus)) && mapsto_memory_block.memory_block' sh (Z.to_nat n) b (Ptrofs.unsigned ofs)
| _ => FF
end.

Lemma memory_block_share_join:
forall sh1 sh2 sh n p,
sepalg.join sh1 sh2 sh ->
memory_block sh1 n p * memory_block sh2 n p = memory_block sh n p.