Section X86CoreErasure.
Variable the_program: Asm.program.
Variable Hsafe : Asm_core.safe_genv (@the_ge the_program).
Instance X86Sem : Semantics := @X86Context.X86Sem the_program Hsafe.
Definition reg_erasure (r:PregEq.t) (rs rs' : regset) : Prop :=
val_erasure (Pregmap.get r rs) (Pregmap.get r rs').
Definition regs_erasure rs rs' : Prop :=
forall r, reg_erasure r rs rs'.
Definition core_erasure c c' :=
match c, c' with
| State rs  _, State rs' _ =>
regs_erasure rs rs'
end.
(* Definition erasedPerm c := *)
(*   match c with *)
(*   | State _ mem => *)
(*     forall (b : block) (ofs : Z) (k : perm_kind), *)
(*       Mem.valid_block mem b -> (Mem.mem_access mem) !! b ofs k = Some Freeable *)
(*   end. *)
Proof with eauto with val_erasure.
intros rs r;
unfold reg_erasure...
Qed.
Hint Immediate regs_erasure_refl : regs_erasure.
Hint Immediate val_erasure_list_refl : val_erasure.
Proof with eauto with val_erasure regs_erasure.
destruct c; simpl.
repeat split...
Qed.
Hint Immediate core_erasure_refl: regs_erasure.
Hint Resolve regs_erasure_get regs_erasure_refl regs_erasure_set
: regs_erasure.
Notation the_ge := (@the_ge the_program).
(** ** Result about at_external, after_external and initial_core *)
Hint Resolve regs_erasure_set_undef : regs_erasure.
Hint Resolve regs_erasure_set_res : regs_erasure.
Proof with eauto 10 with val_erasure regs_erasure.
intros.
unfold eval_addrmode.
assert (Hptr64: Archi.ptr64 = false) by auto.
rewrite Hptr64.
eapply eval_addrmode32_erase;
now eauto.
Qed.
Proof with eauto 12 using val_erasure_cmpu with regs_erasure val_erasure.
intros.
unfold compare_ints...
Qed.
Hint Extern 0 (val_erasure Vundef _) => reflexivity : val_erasure.
Proof with eauto 10 using val_erasure_cmpu with regs_erasure val_erasure.
intros.
unfold compare_floats.
destruct v1,v2; inv Hval_erasure; inv Hval_erasure2; simpl;
eauto 6 with regs_erasure val_erasure;
try destruct v1'; try destruct v2';
eauto 6 with regs_erasure val_erasure;
unfold Val.of_bool;
repeat rewrite if_negb;
repeat match goal with
| [|- context[match ?Expr with | _ => _ end]] =>
destruct Expr eqn:?
end...
Qed.
Proof with eauto 10 using val_erasure_cmpu with regs_erasure val_erasure.
intros.
unfold compare_floats32.
destruct v1,v2; inv Hval_erasure; inv Hval_erasure2; simpl;
eauto 6 with regs_erasure val_erasure;
try destruct v1'; try destruct v2';
eauto 6 with regs_erasure val_erasure;
unfold Val.of_bool;
repeat rewrite if_negb;
repeat match goal with
| [|- context[match ?Expr with | _ => _ end]] =>
destruct Expr eqn:?
end...
Qed.
Hint Transparent undef_regs: regs_erasure.
Proof with eauto 10 using val_erasure_cmpu with regs_erasure val_erasure.
intros.
unfold compare_longs.
destruct v1,v2; inv Hval1; inv Hval2; simpl;
eauto 6 with regs_erasure val_erasure;
try destruct v1'; try destruct v2';
eauto 6 with regs_erasure val_erasure;
unfold Val.of_bool;
repeat rewrite if_negb;
repeat match goal with
| [|- context[match ?Expr with | _ => _ end]] =>
destruct Expr eqn:?
end...
Qed.
Hint Resolve compare_ints_erasure compare_floats_erasure compare_longs_erasure
compare_floats32_erasure val_erasure_addrmode eval_addrmode32_erase
eval_addrmode64_erase regs_erasure_undef : regs_erasure.
Hint Extern 0 (val_erasure (undef_regs _ _ # _ <- _ _) _) =>
eapply regs_erasure_set : regs_erasure.
(* Lemma extcall_arg_erasure: *)
(*   forall m m' loc arg rs rs' ev *)
(*     (Harg: extcall_arg rs m loc arg) *)
(*     (Harg_ev: Asm_event.extcall_arg_ev rs m loc arg ev) *)
(*     (Hmem_obs_eq: mem_erasure m m') *)
(*     (Hrs : regs_erasure rs rs'), *)
(*   exists arg' ev', *)
(*     Asm_event.extcall_arg_ev rs' m' loc arg' ev' /\ *)
(*     extcall_arg rs' m' loc arg' /\ *)
(*     val_erasure arg arg' /\ *)
(*     mem_event_list_erasure ev ev'. *)
(* Proof with eauto with val_erasure regs_erasure. *)
(*   intros. *)
(*   inversion Harg; subst. *)
(*   - inversion Harg_ev; subst. *)
(*     exists (rs' (preg_of r)), [::]; *)
(*     (repeat split); try econstructor... *)
(*   - inversion Harg_ev; subst. *)
(*     eapply mem_loadv_erased in H0; eauto. *)
(*     destruct H0 as [arg' [Hload' Harg_erasure]]. *)
(*     eapply loadbytes_erasure in H6; eauto. *)
(*     destruct H6 as [bytes' [Hloadbytes' Hbytes_erasure]]. *)
(*     rewrite H3 in Hload'. simpl in Hload'. *)
(*     assert (Val.add (rs' ESP) (Vint (Int.repr (Stacklayout.fe_ofs_arg + 4 * ofs))) *)
(*             = Vptr b z) *)
(*       by (eapply val_erasure_add_result; eauto with val_erasure regs_erasure ). *)
(*       exists arg', [:: Read b (Int.unsigned z) (size_chunk (chunk_of_type ty)) *)
(*                 bytes']. *)
(*     (repeat split); try econstructor... *)
(*     eapply Mem.loadbytes_load in Hloadbytes'; eauto. *)
(*     rewrite Hloadbytes' in Hload'. inv Hload'. *)
(*     reflexivity. *)
(*     rewrite H. simpl; auto. *)
(*     econstructor; eauto. *)
(*     constructor. *)
(* Qed. *)
(* Lemma extcall_arg_pair_erasure: *)
(*   forall m m' loc arg rs rs' ev *)
(*     (Harg_ev: Asm_event.extcall_arg_pair_ev rs m loc arg ev) *)
(*     (Hmem_obs_eq: mem_erasure m m') *)
(*     (Hrs : regs_erasure rs rs'), *)
(*   exists arg' ev', *)
(*     Asm_event.extcall_arg_pair_ev rs' m' loc arg' ev' /\ *)
(*     extcall_arg_pair rs' m' loc arg' /\ *)
(*     val_erasure arg arg' /\ *)
(*     mem_event_list_erasure ev ev'. *)
(* Proof with eauto with val_erasure regs_erasure. *)
(*   intros. *)
(*   inv Harg_ev. *)
(*   - pose proof (Asm_event.extcall_arg_ev_extcall_arg _ _ _ _ _ H). *)
(*     eapply extcall_arg_erasure in H; eauto. *)
(*     destruct H as [? [? [? [? [? ?]]]]]. *)
(*     do 2 eexists; (repeat split); try econstructor... *)
(*   - pose proof (Asm_event.extcall_arg_ev_extcall_arg _ _ _ _ _ H). *)
(*     pose proof (Asm_event.extcall_arg_ev_extcall_arg _ _ _ _ _ H0). *)
(*     eapply extcall_arg_erasure in H; eauto. *)
(*     eapply extcall_arg_erasure in H0; eauto. *)
(*     destruct H as [vhi' [T1' [? [? [? ?]]]]]. *)
(*     destruct H0 as [vlo' [T2' [? [? [? ?]]]]]. *)
(*     exists (Val.longofwords vhi' vlo'), (T1' ++ T2'). *)
(*     (repeat split); try econstructor... *)
(*     eapply mem_event_list_erasure_cat; eauto. *)
(* Qed. *)
(* Lemma extcall_arguments_erasure: *)
(*   forall m m' ef args rs rs' ev *)
(*     (Hexternal_ev: Asm_event.extcall_arguments_ev rs m (ef_sig ef) args ev) *)
(*     (Hmem_obs_eq: mem_erasure m m') *)
(*     (Hrs : regs_erasure rs rs'), *)
(*   exists args' ev', *)
(*     Asm_event.extcall_arguments_ev rs' m' (ef_sig ef) args' ev' /\ *)
(*     extcall_arguments rs' m' (ef_sig ef) args' /\ *)
(*     val_erasure_list args args' /\ *)
(*     mem_event_list_erasure ev ev'. *)
(* Proof. *)
(*   intros. *)
(*   unfold extcall_arguments, Asm_event.extcall_arguments_ev in *. *)
(*   generalize dependent ev. *)
(*   generalize dependent (Conventions1.loc_arguments (ef_sig ef)). *)
(*   induction args; intros. *)
(*   - inv Hexternal_ev. *)
(*     exists [::], [::]. *)
(*     repeat split; *)
(*       constructor. *)
(*   - inv Hexternal_ev. *)
(*     destruct (IHargs _ _ H6) as (args' & T2' & Hargs_ev & *)
(*                                     Hls & Hargs_erasure & HT_erasure2). *)
(*     eapply extcall_arg_pair_erasure in H4; eauto. *)
(*     destruct H4 as (arg' & T1' & Harg_ev' & Harg' & Harg_erasure' & HT_erasure1). *)
(*     exists (arg' :: args'), (T1' ++ T2'). *)
(*     repeat split; try econstructor; eauto. *)
(*     eapply mem_event_list_erasure_cat; eauto. *)
(* Qed. *)
(* Axiom extsem_erasure: *)
(*   forall name sg vs1 vs1' t vres m1 m1' m2 *)
(*     (Hmem: mem_erasure m1 m1') *)
(*     (Hval_erasure: val_erasure_list vs1 vs1') *)
(*     (Hextcall: external_functions_sem name sg the_ge vs1 m1 t vres m2), *)
(*   exists vres' m2', *)
(*     external_functions_sem name sg the_ge vs1' m1' t vres' m2' /\ *)
(*     val_erasure vres vres' /\ *)
(*     mem_erasure m2 (erasePerm m2'). *)
(* Axiom inline_assembly_erasure: *)
(*   forall text sg vs1 vs1' t vres m1 m1' m2 *)
(*     (Hmem: mem_erasure m1 m1') *)
(*     (Hval_erasure: val_erasure_list vs1 vs1') *)
(*     (Hextcall: inline_assembly_sem text sg the_ge vs1 m1 t vres m2), *)
(*   exists vres' m2', *)
(*     inline_assembly_sem text sg the_ge vs1' m1' t vres' m2' /\ *)
(*     val_erasure vres vres' /\ *)
(*     mem_erasure m2 (erasePerm m2'). *)

Lemma evstep_erase:
forall c1 c1' c2 ev m1 m1' m2
(HeraseCores: core_erasure c1 c1')
(HerasedMem: mem_erasure m1 m1')
(Hstep: ev_step semSem c1 m1 ev c2 m2),
exists c2' m2' ev',
ev_step semSem c1' m1' ev' c2' m2' /\
core_erasure c2 c2' /\
mem_erasure m2 (erasePerm m2') /\
mem_event_list_erasure ev ev'.