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.

(** Executing an instruction in related states results in related states: 1. The renaming function is extended to accommodate newly allocated blocks. 2. The extension to the renaming only relates newly allocated blocks 3. The nextblock of the two memories is increased by the same amount of blocks 4. Any newly allocated block on the second memory is mapped by a new block on the first memory (computable inverse) 5. If the initial nextblocks are equal and the two memories were related by an id renaming, then the new memories are still related by an (extended) id renaming*)
Lemma exec_instr_ren:
forall (g : genv) (fn : function) (i : instruction) (rs rs' rs2: regset)
(m m' m2 : mem) (f fg: memren)
(Hmem_obs_eq: mem_obs_eq f m m')
(Hrs_eq: regset_ren f rs rs')
(Hfg: forall b1 b2, fg b1 = Some b2 -> b1 = b2)
(Hge_wd: ge_wd fg g)
(Hincr: ren_incr fg f)
(Hexec: exec_instr g fn i rs m = Next rs2 m2),
exists f' rs2' m2',
exec_instr g fn i rs' m' = Next rs2' m2' /\
regset_ren f' rs2 rs2' /\
mem_obs_eq f' m2 m2' /\
ren_incr f f' /\
ren_separated f f' m m' /\
((exists p : positive,
Mem.nextblock m2 = (Mem.nextblock m + p)%positive /\
Mem.nextblock m2' = (Mem.nextblock m' + p)%positive) \/
Mem.nextblock m2 = Mem.nextblock m /\
Mem.nextblock m2' = Mem.nextblock m') /\
(forall b0 : block,
Mem.valid_block m2' b0 ->
~ Mem.valid_block m' b0 ->
f'
(Z.to_pos
match (- Z.pos_sub (Mem.nextblock m') (Mem.nextblock m))%Z with
| 0%Z => Z.pos b0
| Z.pos y' => Z.pos (b0 + y')
| Z.neg y' => Z.pos_sub b0 y'
end) = Some b0 /\
f
(Z.to_pos
match (- Z.pos_sub (Mem.nextblock m') (Mem.nextblock m))%Z with
| 0%Z => Z.pos b0
| Z.pos y' => Z.pos (b0 + y')
| Z.neg y' => Z.pos_sub b0 y'
end) = None) /\
(Mem.nextblock m = Mem.nextblock m' ->
(forall b1 b3 : block, f b1 = Some b3 -> b1 = b3) ->
forall b1 b0 : block, f' b1 = Some b0 -> b1 = b0) /\
(forall b2 : block,
~ (exists b1 : block, f' b1 = Some b2) ->
forall ofs : Z,
permissions.permission_at m' b2 ofs Cur = permissions.permission_at m2' b2 ofs Cur).