Module X86Inj.
(** Injections on registers *)
Definition reg_ren f (r:PregEq.t) (rs rs' : regset) : Prop :=
val_obs f (Pregmap.get r rs) (Pregmap.get r rs').
Definition regset_ren f rs rs' : Prop :=
forall r, reg_ren f r rs rs'.
Definition core_inj f c c' :=
match c, c' with State rs _, State rs' _ => regset_ren f rs rs' end.
Include X86WD.
(* Lemma decode_longs_val_obs_list: forall f (vals vals' : seq val) tys (Hobs_eq: val_obs_list f vals vals'), val_obs_list f (val_casted.decode_longs tys vals) (val_casted.decode_longs tys vals'). *)
(** ** Proof that related states take related steps*)
Proof with eauto with renamings.
intros.
destruct Hge_wd as (? & ?).
unfold Senv.symbol_address in *.
specialize (H0 id ofs _ ltac:(reflexivity)).
destruct (Senv.find_symbol g id) eqn:Hsymb; constructor.
destruct H0 as [b' Hfg'].
assert (Heq := Hfg _ _ Hfg'); subst...
Qed.
Proof with eauto with renamings reg_renamings val_renamings.
intros.
destruct Hmem_obs_eq.
pose proof (injective weak_obs_eq0).
induction Heval; subst;
try by (eexists; split)...
- eapply loadv_val_obs with (vptr2 := Val.offset_ptr (rs' RSP) ofs) in H...
destruct H as (varg' & Hload' & Hval_obs)...
- assert (Hb: val_obs f (Senv.symbol_address g id ofs)
(Senv.symbol_address g id ofs))
by (eapply symb_val_obs; eauto).
eapply loadv_val_obs with (vptr2 := Senv.symbol_address g id ofs) in H;
eauto.
destruct H as (varg' & Hload' & Hval_obs)...
- assert (Hb: val_obs f (Senv.symbol_address g id ofs)
(Senv.symbol_address g id ofs))
by (eapply symb_val_obs; eauto)...
- destruct IHHeval1 as (vhi' & ? & ?), IHHeval2 as (vlo' & ? & ?)...
- destruct IHHeval1 as (vhi' & ? & ?), IHHeval2 as (vlo' & ? & ?).
eexists; split; [constructor; eauto|].
destruct Archi.ptr64...
Qed.
Proof with eauto 10 with val_renamings reg_renamings ge_renamings.
intros.
unfold eval_addrmode32.
destruct a, base, ofs, const; autounfold with renamings;
try destruct p; try destruct p0;
try match goal with
| [|- context[match ?Expr with _ => _ end]] =>
destruct Expr
end...
Qed.
Proof with eauto 10 with val_renamings reg_renamings ge_renamings.
intros.
unfold eval_addrmode64.
destruct a, base, ofs, const; autounfold with renamings;
try destruct p; try destruct p0;
try match goal with
| [|- context[match ?Expr with _ => _ end]] =>
destruct Expr
end...
Qed.
Proof with eauto 15 with reg_renamings val_renamings.
intros.
assert (Hinjective := injective (weak_obs_eq Hmem_obs_eq)).
unfold compare_ints...
Qed.
Proof with eauto 15 with reg_renamings val_renamings.
intros.
assert (Hinjective := injective (weak_obs_eq Hmem_obs_eq)).
unfold compare_longs...
Qed.
Proof with eauto 10 with reg_renamings val_renamings.
intros.
unfold compare_floats32;
destruct v1; inversion Hval_obs; subst;
destruct v2; inversion Hval_obs'; subst...
Qed.
Proof with eauto 10 with reg_renamings val_renamings.
intros.
unfold compare_floats;
destruct v1; inversion Hval_obs; subst;
destruct v2; inversion Hval_obs'; subst...
Qed.
Proof with eauto with val_renamings.
intros.
erewrite eval_testcond_ren; eauto.
destruct (eval_testcond c rs') as [[|]|];
unfold Val.of_optbool, Vtrue, Vfalse...
Qed.
Hint Resolve compare_floats_ren compare_floats32_ren
compare_ints_ren compare_longs_ren : reg_renamings.
Hint Resolve val_obs_addrmode32 val_obs_addrmode64 val_obs_addrmode val_obs_testcond : val_renamings.
Proof with eauto 8 with renamings ge_renamings reg_renamings val_renamings.
intros.
assert (Hinjective := injective (weak_obs_eq Hmem_obs_eq)).
assert (Hstrong_obs := strong_obs_eq Hmem_obs_eq).
destruct i; simpl in *;
unfold goto_label in *;
repeat match goal with
| [H: context[match eval_testcond _ rs with _ => _ end] |- _] =>
erewrite eval_testcond_ren with (rs := rs) (rs' := rs') in H; eauto
end;
repeat match goal with
| [H1: context[match (rs ?R) with _ => _ end] |- _] =>
pose proof (Hrs_eq R); unfold reg_ren, Pregmap.get in *;
destruct (rs R);
match goal with
| [H2: val_obs _ _ _ |- _] =>
inv H2
end
end; auto;
repeat match goal with
| [H: match ?Expr with _ => _ end = _ |- _] =>
destruct Expr eqn:?
end; try discriminate;
try match goal with
| [H: exec_store ?G ?CHUNK ?M ?A ?RS ?RS0 _ = _ |- _] =>
unfold exec_store in *;
destruct (Mem.storev CHUNK M (eval_addrmode G A RS) (RS RS0)) eqn:?;
inv H; exists f
| [H: exec_load ?G ?CHUNK ?M ?A ?RS ?RD = _ |- _] =>
unfold exec_load in *;
destruct (Mem.loadv CHUNK M (eval_addrmode G A RS)) eqn:?;
inv H; exists f
| [H: Next _ _ = Next _ _, H2: Mem.alloc _ _ _ = _  |- _] =>
inv H
| [H: Next _ _ = Next _ _ |- _] =>
inv H; exists f
end;
try match goal with
| [H: Mem.loadv _ _ (eval_addrmode ?G ?A rs) = _ |- _] =>
eapply loadv_val_obs with
(f := f) (mf := m') (vptr2 := eval_addrmode G A rs') in H;
eauto with val_renamings reg_renamings;
destruct H as [? [? ?]]
| [H: Mem.storev _ _ (eval_addrmode ?G ?A rs) (rs ?R) = _ |- _] =>
pose proof (nextblock_storev _ _ _ _ H);
eapply storev_val_obs with
(vptr2 := eval_addrmode g a rs') (v2 := rs' R) in H;
eauto with val_renamings reg_renamings;
destruct H as [? [Hstore' ?]];
rewrite Hstore';
pose proof (nextblock_storev _ _ _ _ Hstore')
| [H: Val.divs _ _ = _, H2: Val.mods _ _ = _ |- _] =>
erewrite divs_ren with (v1' := rs' EAX) (v2' := rs' # EDX <- Vundef r1) in H;
eauto with reg_renamings val_renamings;
erewrite mods_ren with (v1' := rs' EAX) (v2' := rs' # EDX <- Vundef r1)
in H2; eauto with reg_renamings val_renamings
| [H: Val.divu _ _ = _, H2: Val.modu _ _ = _ |- _] =>
erewrite divu_ren with (v1' := rs' EAX) (v2' := rs' # EDX <- Vundef r1) in H;
eauto with reg_renamings val_renamings;
erewrite modu_ren with (v1' := rs' EAX) (v2' := rs' # EDX <- Vundef r1)
in H2; eauto with reg_renamings val_renamings
end;
repeat match goal with
| [|- exists _ _, _ ] => do 2 eexists; split; first by eauto
| [|- _ /\ _] => split; eauto 3 with renamings
| [H: Mem.loadv _ _ _ = _ |- _] =>
rewrite H; clear H
| [H: Val.divu _ _ = _ |- _] =>
rewrite H
| [H: Val.modu _ _ = _ |- _] =>
rewrite H
| [H: Val.divs _ _ = _ |- _] =>
rewrite H
| [H: Val.mods _ _ = _ |- _] =>
rewrite H
| [|- regset_ren _ _ _] =>
unfold nextinstr_nf, nextinstr, Vone, Vzero;
eauto 20 with reg_renamings ge_renamings val_renamings
| [|- forall _, _] => intros
end; try (by exfalso);
repeat match goal with
| [H: Mem.nextblock ?X = Mem.nextblock ?Y,
H2: Mem.valid_block ?X _ |- _] =>
unfold Mem.valid_block in *;
rewrite H in H2;
try by exfalso
| [|- regset_ren _ _ _] =>
autorewrite with reg_renamings;
first by eauto 25 with reg_renamings val_renamings
| [ |- ~ List.In _ _] =>
compute; intros ?
| [H: _ \/ _ |- _] =>
destruct H; try discriminate;
try auto
end;
(* unmapped blocks*)
repeat match goal with
| [|- permissions.permission_at _ _ _ _ = _] =>
do 2 rewrite <- permissions.getCurPerm_correct
| [H: Mem.storev _ _ _ _ = _ |- _] =>
destruct (mem_storev_store _ _ _ _ _ H) as (? & ? & ? & ?);
erewrite mem_store_cur by eauto;
reflexivity
end.
(* Cleaning up some cases manually, to avoid overcomplicating automation*)
apply regset_ren_set.
apply regset_ren_undef.
apply regset_ren_set...
apply val_obs_offset_ptr...
repeat match goal with
| [|- val_obs _ (undef_regs _ _ _) _] =>
rewrite gso_undef_regs
| [|- val_obs _ _ (undef_regs _ _ _)] =>
rewrite gso_undef_regs
| [ |- ~ List.In _ _] =>
compute; intros ?
| [H: _ \/ _ |- _] =>
destruct H; try discriminate;
try auto
end.
erewrite Pregmap.gso by congruence...
apply regset_ren_set.
apply regset_ren_undef.
apply regset_ren_set...
apply val_obs_offset_ptr...
repeat match goal with
| [|- val_obs _ (undef_regs _ _ _) _] =>
rewrite gso_undef_regs
| [|- val_obs _ _ (undef_regs _ _ _)] =>
rewrite gso_undef_regs
| [ |- ~ List.In _ _] =>
compute; intros ?
| [H: _ \/ _ |- _] =>
destruct H; try discriminate;
try auto
end.
erewrite Pregmap.gso by congruence...
admit. (* This goal was not around before the merge.
is it a new case or is the automation failing?
*)
erewrite !Pregmap.gso in * by discriminate.
pose proof (Hrs_eq PC) as HPC.
unfold reg_ren, Pregmap.get in HPC; rewrite Heqv in HPC; inv HPC.
repeat match goal with
| [|- exists _ _, _ ] => do 2 eexists; split; first by eauto
| [|- _ /\ _] => split; eauto 3 with renamings
| [|- regset_ren _ _ _] =>
unfold nextinstr_nf, nextinstr, Vone, Vzero;
eauto 20 with reg_renamings ge_renamings val_renamings
| [|- forall _, _] => intros
end; try (by exfalso).
(* Allocation case*)
destruct (Mem.alloc m' 0 sz) as [m0' b'] eqn:Halloc'.
destruct (alloc_obs_eq Hmem_obs_eq Heqp Halloc') as
(f' & Hf' & Hmem_obs_eq' & Hincr' & Hsep & Hnextblock & Hinverse & Hid).
exists f'.
pose proof (Mem.nextblock_store _ _ _ _ _ _ Heqo) as Hnext.
eapply store_val_obs with (f := f') (mf := m0') (b2 := b') in Heqo...
destruct Heqo as [m1' [Hstore' ?]].
pose proof (Mem.nextblock_store _ _ _ _ _ _ Hstore') as Hnext'.
pose proof (Mem.nextblock_store _ _ _ _ _ _ Heqo0) as Hnext0.
eapply store_val_obs with (f := f') (mf := m1') (b2 := b') in Heqo0...
destruct Heqo0 as [m2' [Hstore'' ?]].
pose proof (Mem.nextblock_store _ _ _ _ _ _ Hstore'') as Hnext0'.
unfold nextinstr. eexists. exists m2'.
unfold Mem.valid_block in *.
rewrite Hstore' Hstore''.
rewrite Hnext0' Hnext0 Hnext Hnext'.
repeat match goal with
| [|- exists _ _, _ ] => do 2 eexists; split; first by eauto
| [|- _ /\ _] => split; eauto 3 with renamings
| [|- regset_ren _ _ _] =>
unfold nextinstr_nf, nextinstr, Vone, Vzero;
eauto 20 using regset_ren_incr
with reg_renamings ge_renamings val_renamings
| [|- forall _, _] => intros
end; try (by exfalso).
assert (b2 <> b')
by (intros Hcontra; subst;
eauto).
erewrite permission_at_alloc_4 with (m := m') (m' := m0'); eauto.
do 2 rewrite <- permissions.getCurPerm_correct.
erewrite mem_store_cur by eauto.
erewrite mem_store_cur by eauto.
reflexivity.
(* Free case *)
pose proof (Mem.nextblock_free _ _ _ _ _ Heqo1) as Hnb.
eapply mem_free_obs in Heqo1...
destruct Heqo1 as [m2' [Hfree' ?]].
pose proof (Mem.nextblock_free _ _ _ _ _ Hfree') as Hnb'.
rewrite Hfree'.
eapply loadv_val_obs with
(f := f) (mf := m') (vptr2 := Val.offset_ptr (Vptr b2 i) ofs_ra) in Heqo;
eauto with val_renamings reg_renamings;
destruct Heqo as [? [Hload' ?]].
eapply loadv_val_obs with
(f := f) (mf := m') (vptr2 := Val.offset_ptr (Vptr b2 i) ofs_link) in Heqo0;
eauto with val_renamings reg_renamings;
destruct Heqo0 as [? [Hload2' ?]].
rewrite Hload' Hload2'.
eexists; exists m2'.
unfold nextinstr, Mem.valid_block.
rewrite Hnb' Hnb.
repeat match goal with
| [|- exists _ _, _ ] => do 2 eexists; split; first by eauto
| [|- _ /\ _] => split; eauto 3 with renamings
| [|- regset_ren _ _ _] =>
unfold nextinstr_nf, nextinstr, Vone, Vzero;
eauto 20 with reg_renamings ge_renamings val_renamings
| [|- forall _, _] => intros
end; try (by exfalso).
assert (b2 <> b0)
by (intros Hcontra; subst; eauto).
erewrite permission_at_free_2 by eauto.
reflexivity.
Admitted.
Proof with eauto with reg_renamings val_renamings.
intros.
inversion Harg; subst.
exists (rs' (preg_of r)).
split...
constructor.
pose proof (strong_obs_eq Hobs_eq).
pose proof (injective (weak_obs_eq Hobs_eq)).
eapply loadv_val_obs in H0...
destruct H0 as [arg' [Hloadv' Hval_obs]].
exists arg'; split; auto.
econstructor; eauto.
Qed.
Proof with eauto with reg_renamings val_renamings.
intros.
inversion Harg; subst.
eapply extcall_arg_reg in H; eauto.
destruct H as [arg' [Harg' Hobs_arg]].
exists arg'.
split...
constructor; auto.
eapply extcall_arg_reg in H; eauto.
eapply extcall_arg_reg in H0; eauto.
destruct H as [vhi' [Hhi' Hobs_hi]].
destruct H0 as [vlo' [Hlo' Hobs_lo]].
exists (Val.longofwords vhi' vlo').
split...
constructor; auto.
Qed.
Proof with (eauto with renamings reg_renamings val_renamings).
intros the_ge ? cc cf cc' mc mf mc' f fg
Hobs_eq Hcore_inj Hfg Hge_wd Hincr Hcorestep.
destruct cc as [rs], cf as [rsF], cc' as [rs'].
inv Hcorestep.
rename m1 into mc'.
assert (Smallstep.at_external (part_semantics the_ge) (set_mem (State rsF m0) mf) = None) as Hext.
{ exploit core_inj_ext; eauto using core_inj_wd.
simpl in *;rewrite H0; clear H0.
destruct (rsF PC); auto.
destruct (Ptrofs.eq_dec _ _); auto.
destruct (find_funct_ptr _ _); auto.
destruct f0; auto.
destruct (get_extcall_arguments _ _ _); auto; contradiction. }
inv H.
- assert (Hpc' := get_reg_ren PC Hcore_inj H5).
destruct Hpc' as [v' [Hpc' Hpc_obs]].
inversion Hpc_obs; subst. rewrite <- H1 in Hpc_obs.
assert (Hfun := find_funct_ptr_ren Hfg Hge_wd Hincr Hpc_obs H7); subst b2.
destruct (exec_instr_ren _ _ Hobs_eq Hcore_inj Hfg Hge_wd Hincr H9)
as (f' & rsF' & mF' & Hexec' & Hrs_ren' & Hobs_eq' & Hincr' & Hsep
& Hnextblocks & Hinverse & Hid_extend & Hunmapped).
exists (State rsF' mF'), mF', f'.
repeat match goal with
| [ |- _ /\ _] =>
split; simpl; eauto with renamings reg_renamings
end.
econstructor...
econstructor...
- exploit Hsafe; eauto.
assert (Hpc' := get_reg_ren PC Hcore_inj H5).
destruct Hpc' as [v' [Hpc' Hpc_obs]].
inversion Hpc_obs; subst. rewrite <- H1 in Hpc_obs.
assert (Hfun := find_funct_ptr_ren Hfg Hge_wd Hincr Hpc_obs H6); subst b2.
eapply eval_builtin_args_ren in H9 as (args' & ? & ?); eauto.
(* We need Hsafe to give us that external calls behave the same even on injected arguments. *)
destruct ef;
try (intros (_ & _ & Hcontra);
now exfalso).
+ (* EF_malloc case*)
pose proof H10 as Hext_call.
simpl in H10.
inv H10.
remember (Mem.alloc mf (- size_chunk Mptr) (Ptrofs.unsigned sz)) as p eqn:HallocF.
destruct p as [mf' b0F].
symmetry in HallocF.
destruct (alloc_obs_eq Hobs_eq H4 HallocF)
as [f' [Hb0 [Hobs_eq' [Hincr' [Hsep [Hnextblock_eq [Hmap_spec Hunchanged_map]]]]]]].
pose proof H8 as Hstore.
eapply store_val_obs with (v2 := Vptrofs sz) in H8; eauto.
destruct H8 as [mf'' [HstoreF Hobs_eq'']].
exists (State (nextinstr_nf
(set_res res (Vptr b0F Ptrofs.zero)
(undef_regs (List.map preg_of (Machregs.destroyed_by_builtin
EF_malloc)) rsF))) mf''), mf'', f'.
repeat match goal with
| [|- _ /\ _] => split
end; eauto.
* (* injected machine steps *)
simpl.
econstructor; eauto.
simpl.
eapply Asm.exec_step_builtin; eauto.
simpl.
inv H2.
inv H13.
assert (v' = Vptrofs sz)
by (unfold Vptrofs in *;
destruct Archi.ptr64; inv H11; reflexivity); subst.
econstructor.
eauto.
eauto.
* (* injection on cores is preserved *)
simpl.
unfold nextinstr_nf, nextinstr.
eauto 15 using regset_ren_incr with reg_renamings val_renamings renamings.
* (* nextblock relation *)
eapply Mem.nextblock_store in Hstore.
eapply Mem.nextblock_store in HstoreF.
rewrite Hstore HstoreF.
destruct Hnextblock_eq as [? [? ?]].
left; eexists; now eauto.
* intros b1 Hvalid'' Hinvalid.
simpl.
eapply Hmap_spec; eauto.
eapply Mem.store_valid_block_2;
now eauto.
* intros b2 Hunmapped ofs0.
assert (b2 <> b0F)
by (intros Hcontra; subst;
eapply Hunmapped; eexists; eauto).
erewrite permission_at_alloc_4 by eauto.
unfold permissions.permission_at.
erewrite Mem.store_access with (m2 := mf'') by eauto.
reflexivity.
* econstructor.
+ (*EF_free*)
pose proof H10 as Hext_call.
simpl in H10.
inv H10.
inv H2. inv H14.
inv H12.
destruct (mem_free_obs _ _ _ Hobs_eq H13 H9) as [mf' [HfreeF Hobs_eq']].
eapply load_val_obs with (mf := mf) in H4; eauto.
destruct H4 as [vF [HloadF Hval_obs]].
assert (vF = Vptrofs sz)
by (unfold Vptrofs in *;
destruct (Archi.ptr64); inv Hval_obs; reflexivity); subst.
exists (State (nextinstr_nf
(set_res res Vundef
(undef_regs (List.map preg_of
(Machregs.destroyed_by_builtin EF_free)) rsF)))
mf'), mf', f.
repeat match goal with
| [|- _ /\ _] => split
end; eauto.
* (* injected machine steps *)
simpl.
econstructor; eauto.
simpl.
eapply Asm.exec_step_builtin; eauto.
simpl.
econstructor;
now eauto.
* (* injection on cores is preserved *)
simpl.
unfold nextinstr_nf, nextinstr.
eauto 15 using regset_ren_incr with reg_renamings val_renamings renamings.
* (*ren_incr *)
eauto using ren_incr_refl.
* eauto using ren_separated_refl.
* (* nextblock relation *)
eapply Mem.nextblock_free in HfreeF.
eapply Mem.nextblock_free in H9.
rewrite H9 HfreeF.
right; now eauto.
* intros b1 Hvalid'' Hinvalid.
exfalso.
eapply Hinvalid.
eapply Mem.valid_block_free_2; eauto.
* intros b1 Hunmmaped ofs0.
erewrite permission_at_free_2; eauto.
intros Hcontra.
subst. now eauto.
* destruct Hobs_eq.
destruct weak_obs_eq0.
now eauto.
* destruct Hobs_eq;
now eauto.
+ (* EF_memcpy *)
pose proof H10 as Hext_call.
simpl in H10.
inv H10.
inv H2.
inv H19.
inv H17.
inv H20.
inv H16.
eapply loadbytes_val_obs with (f := f) (mf := mf) in H14; eauto.
destruct H14 as [mv' [HloadbytesF Hmemval_obs]].
pose proof H15 as Hstore.
eapply storebytes_val_obs with (mv2 := mv') in H15; eauto.
destruct H15 as [mf'' [HstoreF Hobs_eq'']].
exists (State (nextinstr_nf
(set_res res Vundef
(undef_regs (List.map preg_of (Machregs.destroyed_by_builtin
(EF_memcpy sz al)))
rsF))) mf''), mf'', f.
repeat match goal with
| [|- _ /\ _] => split
end; eauto.
* (* injected machine steps *)
simpl.
econstructor; eauto.
simpl.
eapply Asm.exec_step_builtin; eauto.
simpl.
econstructor; eauto.
destruct H13 as [Hneq | ?]; [|now auto].
left.
intros Hcontra.
subst.
eapply Hneq.
eapply (injective (weak_obs_eq Hobs_eq));
now eauto.
* (* injection on cores is preserved *)
simpl.
unfold nextinstr_nf, nextinstr.
eauto 15 using regset_ren_incr with reg_renamings val_renamings renamings.
* (*ren_incr *)
eauto using ren_incr_refl.
* eauto using ren_separated_refl.
* (* nextblock relation *)
eapply Mem.nextblock_storebytes in Hstore.
eapply Mem.nextblock_storebytes in HstoreF.
rewrite Hstore HstoreF.
right; now auto.
* intros b1 Hvalid'' Hinvalid.
simpl.
exfalso.
eapply Hinvalid.
eapply Mem.storebytes_valid_block_2;
now eauto.
* intros b1 Hunmapped ofs0.
unfold permissions.permission_at.
erewrite Mem.storebytes_access with (m2 := mf'') by eauto.
reflexivity.
* now eapply (injective (weak_obs_eq Hobs_eq)).
* destruct Hobs_eq;
now auto.
- simpl in H0.
rewrite H5 in H0.
destruct (Ptrofs.eq_dec _ _); [|contradiction].
rewrite H6 in H0.
apply get_extcall_arguments_spec in H8; rewrite H8 in H0; discriminate.
Qed.
(** Coresteps maintain well-definedness *)

Lemma extcall_arg_valid:
forall f rs m locs arg
(Hrs_wd: regset_wd f rs)
(Hmem_wd : valid_mem m)
(Hobs_eq: domain_memren f m)
(Harg: extcall_arg rs m locs arg),
valid_val f arg.