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.

Lemma corestep_obs_eq:
forall the_ge (Hsafe : safe_genv the_ge) (cc cf cc' : state) (mc mf mc' : mem) f fg,
mem_obs_eq f mc mf ->
core_inj f cc cf ->
(forall b1 b2, fg b1 = Some b2 -> b1 = b2) ->
ge_wd fg the_ge ->
ren_incr fg f ->
corestep (Asm_core_sem the_ge) cc mc cc' mc' ->
exists (cf' : state) (mf' : mem) (f' : Renamings.memren),
corestep (Asm_core_sem the_ge) cf mf cf' mf' /\
core_inj f' cc' cf' /\
mem_obs_eq f' mc' mf' /\
ren_incr f f' /\
ren_separated f f' mc mf /\
((exists p : positive,
Mem.nextblock mc' = (Mem.nextblock mc + p)%positive /\
Mem.nextblock mf' = (Mem.nextblock mf + p)%positive) \/
Mem.nextblock mc' = Mem.nextblock mc /\
Mem.nextblock mf' = Mem.nextblock mf) /\
(forall b : block,
Mem.valid_block mf' b ->
~ Mem.valid_block mf b ->
let bz :=
(Z.pos b - (Z.pos (Mem.nextblock mf) - Z.pos (Mem.nextblock mc)))%Z in
f' (Z.to_pos bz) = Some b /\ f (Z.to_pos bz) = None) /\
(Mem.nextblock mc = Mem.nextblock mf ->
(forall b1 b2 : block, f b1 = Some b2 -> b1 = b2) ->
forall b1 b2 : block, f' b1 = Some b2 -> b1 = b2) /\
(forall b2 : block,
~ (exists b1 : block, f' b1 = Some b2) ->
forall ofs : Z,
permissions.permission_at mf b2 ofs Cur = permissions.permission_at mf' b2 ofs Cur).