summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.depend2
-rw-r--r--Makefile13
-rw-r--r--_tags1
-rw-r--r--backend/CMlexer.mll7
-rw-r--r--backend/CMparser.mly2
-rw-r--r--backend/Cminor.v27
-rw-r--r--backend/CminorSel.v1
-rw-r--r--backend/PrintCminor.ml8
-rw-r--r--backend/RTLgen.v4
-rw-r--r--backend/RTLgenproof.v224
-rw-r--r--backend/RTLgenspec.v10
-rw-r--r--backend/Selectionproof.v3
-rw-r--r--cfrontend/C2C.ml2
-rw-r--r--cfrontend/Cexec.v3
-rw-r--r--cfrontend/Clight.v67
-rw-r--r--cfrontend/ClightBigstep.v18
-rw-r--r--cfrontend/Cminorgen.v304
-rw-r--r--cfrontend/Cminorgenproof.v2704
-rw-r--r--cfrontend/Csem.v1
-rw-r--r--cfrontend/Csharpminor.v184
-rw-r--r--cfrontend/Cshmgen.v116
-rw-r--r--cfrontend/Cshmgenproof.v386
-rw-r--r--cfrontend/ExportClight.ml534
-rw-r--r--cfrontend/SimplExpr.v29
-rw-r--r--cfrontend/SimplExprproof.v42
-rw-r--r--cfrontend/SimplExprspec.v2
-rw-r--r--cfrontend/SimplLocals.v234
-rw-r--r--cfrontend/SimplLocalsproof.v2277
-rw-r--r--common/Errors.v2
-rw-r--r--driver/Clightgen.ml282
-rw-r--r--driver/Compiler.v13
-rw-r--r--driver/Driver.ml10
-rw-r--r--extraction/extraction.v2
-rw-r--r--lib/Camlcoq.ml4
34 files changed, 4800 insertions, 2718 deletions
diff --git a/.depend b/.depend
index 5fd67ab..6428c7b 100644
--- a/.depend
+++ b/.depend
@@ -111,6 +111,8 @@ cfrontend/SimplExprspec.vo cfrontend/SimplExprspec.glob: cfrontend/SimplExprspec
cfrontend/SimplExprproof.vo cfrontend/SimplExprproof.glob: cfrontend/SimplExprproof.v lib/Axioms.vo lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Errors.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Events.vo common/Smallstep.vo common/Globalenvs.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Cstrategy.vo cfrontend/Clight.vo cfrontend/SimplExpr.vo cfrontend/SimplExprspec.vo
cfrontend/Clight.vo cfrontend/Clight.glob: cfrontend/Clight.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/AST.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo cfrontend/Ctypes.vo cfrontend/Cop.vo
cfrontend/ClightBigstep.vo cfrontend/ClightBigstep.glob: cfrontend/ClightBigstep.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/AST.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Clight.vo
+cfrontend/SimplLocals.vo cfrontend/SimplLocals.glob: cfrontend/SimplLocals.v lib/Coqlib.vo lib/Ordered.vo common/AST.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Clight.vo
+cfrontend/SimplLocalsproof.vo cfrontend/SimplLocalsproof.glob: cfrontend/SimplLocalsproof.v lib/Coqlib.vo common/Errors.vo lib/Ordered.vo common/AST.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo common/Smallstep.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Clight.vo cfrontend/SimplLocals.vo
cfrontend/Cshmgen.vo cfrontend/Cshmgen.glob: cfrontend/Cshmgen.v lib/Coqlib.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/AST.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Clight.vo backend/Cminor.vo cfrontend/Csharpminor.vo
cfrontend/Cshmgenproof.vo cfrontend/Cshmgenproof.glob: cfrontend/Cshmgenproof.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/AST.vo common/Values.vo common/Events.vo common/Memory.vo common/Globalenvs.vo common/Smallstep.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Clight.vo backend/Cminor.vo cfrontend/Csharpminor.vo cfrontend/Cshmgen.vo
cfrontend/Csharpminor.vo cfrontend/Csharpminor.glob: cfrontend/Csharpminor.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo backend/Cminor.vo common/Smallstep.vo
diff --git a/Makefile b/Makefile
index 844697d..f91301c 100644
--- a/Makefile
+++ b/Makefile
@@ -93,7 +93,8 @@ BACKEND=\
CFRONTEND=Ctypes.v Cop.v Csyntax.v Csem.v Cstrategy.v Cexec.v \
Initializers.v Initializersproof.v \
SimplExpr.v SimplExprspec.v SimplExprproof.v \
- Clight.v ClightBigstep.v Cshmgen.v Cshmgenproof.v \
+ Clight.v ClightBigstep.v SimplLocals.v SimplLocalsproof.v \
+ Cshmgen.v Cshmgenproof.v \
Csharpminor.v Cminorgen.v Cminorgenproof.v
# Putting everything together (in driver/)
@@ -141,7 +142,15 @@ cchecklink.byte: driver/Configuration.ml
$(OCAMLBUILD) $(OCB_OPTIONS_CHECKLINK) Validator.d.byte \
&& rm -f cchecklink.byte && $(SLN) _build/checklink/Validator.d.byte cchecklink.byte
-.PHONY: proof extraction cil ccomp ccomp.prof ccomp.byte runtime cchecklink cchecklink.byte
+clightgen: driver/Configuration.ml
+ $(OCAMLBUILD) $(OCB_OPTIONS) Clightgen.native \
+ && rm -f clightgen && $(SLN) _build/driver/Clightgen.native clightgen
+
+clightgen.byte: driver/Configuration.ml
+ $(OCAMLBUILD) $(OCB_OPTIONS) Clightgen.d.byte \
+ && rm -f clightgen.byte && $(SLN) _build/driver/Clightgen.d.byte clightgen.byte
+
+.PHONY: proof extraction cil ccomp ccomp.prof ccomp.byte runtime cchecklink cchecklink.byte clightgen clightgen.byte
all:
$(MAKE) proof
diff --git a/_tags b/_tags
index 501e42a..0653ec6 100644
--- a/_tags
+++ b/_tags
@@ -1,3 +1,4 @@
<driver/Driver.*{byte,native}>: use_unix,use_str,use_Cparser
+<driver/Clightgen.*{byte,native}>: use_unix,use_str,use_Cparser
<checklink/*.ml>: pkg_bitstring,warn_error_A
<checklink/Validator.*{byte,native}>: pkg_unix,pkg_str,pkg_bitstring,use_Cparser
diff --git a/backend/CMlexer.mll b/backend/CMlexer.mll
index fba85ff..2eaa488 100644
--- a/backend/CMlexer.mll
+++ b/backend/CMlexer.mll
@@ -25,7 +25,7 @@ let floatlit =
('.' ['0'-'9' '_']* )?
(['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']*)?
let ident = ['A'-'Z' 'a'-'z' '_'] ['A'-'Z' 'a'-'z' '_' '$' '0'-'9']*
-let temp = "$" ['0'-'9'] ['0'-'9']*
+let temp = "$" ['1'-'9'] ['0'-'9']*
let intlit = "-"? ( ['0'-'9']+ | "0x" ['0'-'9' 'a'-'f' 'A'-'F']+
| "0o" ['0'-'7']+ | "0b" ['0'-'1']+ )
let stringlit = "\"" [ ^ '"' ] * '"'
@@ -125,10 +125,7 @@ rule token = parse
| floatlit { FLOATLIT(float_of_string(Lexing.lexeme lexbuf)) }
| stringlit { let s = Lexing.lexeme lexbuf in
STRINGLIT(intern_string(String.sub s 1 (String.length s - 2))) }
- | ident { IDENT(BinPos.Coq_xO (intern_string(Lexing.lexeme lexbuf))) }
- | temp { let s = Lexing.lexeme lexbuf in
- let n = Int32.of_string(String.sub s 1 (String.length s -1)) in
- IDENT(if n = 0l then BinPos.Coq_xH else BinPos.Coq_xI (positive_of_camlint n)) }
+ | ident | temp { IDENT(intern_string(Lexing.lexeme lexbuf)) }
| eof { EOF }
| _ { raise(Error("illegal character `" ^ Char.escaped (Lexing.lexeme_char lexbuf 0) ^ "'")) }
diff --git a/backend/CMparser.mly b/backend/CMparser.mly
index a62bd74..ce9bd08 100644
--- a/backend/CMparser.mly
+++ b/backend/CMparser.mly
@@ -43,7 +43,7 @@ let temporaries = ref []
let mktemp () =
incr temp_counter;
let n = Printf.sprintf "__t%d" !temp_counter in
- let id = Coq_xO (intern_string n) in
+ let id = intern_string n in
temporaries := id :: !temporaries;
id
diff --git a/backend/Cminor.v b/backend/Cminor.v
index 4bc6b72..3d177e4 100644
--- a/backend/Cminor.v
+++ b/backend/Cminor.v
@@ -360,7 +360,6 @@ Inductive step: state -> trace -> state -> Prop :=
E0 (State f Sskip k sp e m)
| step_skip_call: forall f k sp e m m',
is_call_cont k ->
- f.(fn_sig).(sig_res) = None ->
Mem.free m sp 0 f.(fn_stackspace) = Some m' ->
step (State f Sskip k (Vptr sp Int.zero) e m)
E0 (Returnstate Vundef k m')
@@ -534,12 +533,12 @@ Definition outcome_block (out: outcome) : outcome :=
Definition outcome_result_value
(out: outcome) (retsig: option typ) (vres: val) : Prop :=
- match out, retsig with
- | Out_normal, None => vres = Vundef
- | Out_return None, None => vres = Vundef
- | Out_return (Some v), Some ty => vres = v
- | Out_tailcall_return v, _ => vres = v
- | _, _ => False
+ match out with
+ | Out_normal => vres = Vundef
+ | Out_return None => vres = Vundef
+ | Out_return (Some v) => retsig <> None /\ vres = v
+ | Out_tailcall_return v => vres = v
+ | _ => False
end.
Definition outcome_free_mem
@@ -845,20 +844,12 @@ Proof.
eapply star_trans. eexact A.
inversion B; clear B; subst out; simpl in H3; simpl; try contradiction.
(* Out normal *)
- assert (f.(fn_sig).(sig_res) = None /\ vres = Vundef).
- destruct f.(fn_sig).(sig_res). contradiction. auto.
- destruct H7. subst vres.
- apply star_one. apply step_skip_call; auto.
+ subst vres. apply star_one. apply step_skip_call; auto.
(* Out_return None *)
- assert (f.(fn_sig).(sig_res) = None /\ vres = Vundef).
- destruct f.(fn_sig).(sig_res). contradiction. auto.
- destruct H8. subst vres.
- replace k with (call_cont k') by congruence.
+ subst vres. replace k with (call_cont k') by congruence.
apply star_one. apply step_return_0; auto.
(* Out_return Some *)
- assert (f.(fn_sig).(sig_res) <> None /\ vres = v).
- destruct f.(fn_sig).(sig_res). split; congruence. contradiction.
- destruct H9. subst vres.
+ destruct H3. subst vres.
replace k with (call_cont k') by congruence.
apply star_one. eapply step_return_1; eauto.
(* Out_tailcall_return *)
diff --git a/backend/CminorSel.v b/backend/CminorSel.v
index bb5143c..a063544 100644
--- a/backend/CminorSel.v
+++ b/backend/CminorSel.v
@@ -246,7 +246,6 @@ Inductive step: state -> trace -> state -> Prop :=
E0 (State f Sskip k sp e m)
| step_skip_call: forall f k sp e m m',
is_call_cont k ->
- f.(fn_sig).(sig_res) = None ->
Mem.free m sp 0 f.(fn_stackspace) = Some m' ->
step (State f Sskip k (Vptr sp Int.zero) e m)
E0 (Returnstate Vundef k m')
diff --git a/backend/PrintCminor.ml b/backend/PrintCminor.ml
index 8e49303..dfcabb3 100644
--- a/backend/PrintCminor.ml
+++ b/backend/PrintCminor.ml
@@ -41,13 +41,9 @@ let rec precedence = function
| Ebinop(Oor, _, _) -> (6, LtoR)
| Eload _ -> (15, RtoL)
-(* Naming idents. We assume idents are encoded as in Cminorgen. *)
+(* Naming idents. *)
-let ident_name id =
- match id with
- | Coq_xO n -> extern_atom n
- | Coq_xI n -> Printf.sprintf "$%ld" (camlint_of_positive n)
- | Coq_xH -> "$0"
+let ident_name = Camlcoq.extern_atom
(* Naming operators *)
diff --git a/backend/RTLgen.v b/backend/RTLgen.v
index d3b99bb..62df254 100644
--- a/backend/RTLgen.v
+++ b/backend/RTLgen.v
@@ -319,7 +319,7 @@ Fixpoint add_vars (map: mapping) (names: list ident)
Definition find_var (map: mapping) (name: ident) : mon reg :=
match PTree.get name map.(map_vars) with
- | None => error (Errors.MSG "RTLgen: unbound variable " :: Errors.CTXL name :: nil)
+ | None => error (Errors.MSG "RTLgen: unbound variable " :: Errors.CTX name :: nil)
| Some r => ret r
end.
@@ -598,7 +598,7 @@ Fixpoint transl_stmt (map: mapping) (s: stmt) (nd: node)
error (Errors.msg "RTLgen: wrong switch")
| Sreturn opt_a =>
match opt_a, rret with
- | None, None => ret nret
+ | None, _ => ret nret
| Some a, Some r => transl_expr map a r nret
| _, _ => error (Errors.msg "RTLgen: type mismatch on return")
end
diff --git a/backend/RTLgenproof.v b/backend/RTLgenproof.v
index 659e8d0..1b8e853 100644
--- a/backend/RTLgenproof.v
+++ b/backend/RTLgenproof.v
@@ -116,9 +116,9 @@ Record match_env
mk_match_env {
me_vars:
(forall id v,
- e!id = Some v -> exists r, map.(map_vars)!id = Some r /\ rs#r = v);
+ e!id = Some v -> exists r, map.(map_vars)!id = Some r /\ Val.lessdef v rs#r);
me_letvars:
- rs##(map.(map_letvars)) = le
+ Val.lessdef_list le rs##(map.(map_letvars))
}.
Lemma match_env_find_var:
@@ -126,7 +126,7 @@ Lemma match_env_find_var:
match_env map e le rs ->
e!id = Some v ->
map.(map_vars)!id = Some r ->
- rs#r = v.
+ Val.lessdef v rs#r.
Proof.
intros. exploit me_vars; eauto. intros [r' [EQ' RS]].
replace r with r'. auto. congruence.
@@ -137,12 +137,17 @@ Lemma match_env_find_letvar:
match_env map e le rs ->
List.nth_error le idx = Some v ->
List.nth_error map.(map_letvars) idx = Some r ->
- rs#r = v.
+ Val.lessdef v rs#r.
Proof.
- intros. exploit me_letvars; eauto. intros.
- rewrite <- H2 in H0. rewrite list_map_nth in H0.
- change reg with positive in H1. rewrite H1 in H0.
- simpl in H0. congruence.
+ intros. exploit me_letvars; eauto.
+ clear H. revert le H0 H1. generalize (map_letvars map). clear map.
+ induction idx; simpl; intros.
+ inversion H; subst le; inversion H0. subst v1.
+ destruct l; inversion H1. subst r0.
+ inversion H2. subst v2. auto.
+ destruct l; destruct le; try discriminate.
+ eapply IHidx; eauto.
+ inversion H. auto.
Qed.
Lemma match_env_invariant:
@@ -154,8 +159,8 @@ Proof.
intros. inversion H. apply mk_match_env.
intros. exploit me_vars0; eauto. intros [r [A B]].
exists r; split. auto. rewrite H0; auto. left; exists id; auto.
- rewrite <- me_letvars0. apply list_map_exten. intros.
- symmetry. apply H0. right; auto.
+ replace (rs'##(map_letvars map)) with (rs ## (map_letvars map)). auto.
+ apply list_map_exten. intros. apply H0. right; auto.
Qed.
(** Matching between environments is preserved when an unmapped register
@@ -181,33 +186,35 @@ Hint Resolve match_env_update_temp: rtlg.
environment). *)
Lemma match_env_update_var:
- forall map e le rs id r v,
+ forall map e le rs id r v tv,
+ Val.lessdef v tv ->
map_wf map ->
map.(map_vars)!id = Some r ->
match_env map e le rs ->
- match_env map (PTree.set id v e) le (rs#r <- v).
+ match_env map (PTree.set id v e) le (rs#r <- tv).
Proof.
- intros. inversion H. inversion H1. apply mk_match_env.
+ intros. inversion H0. inversion H2. apply mk_match_env.
intros id' v'. rewrite PTree.gsspec. destruct (peq id' id); intros.
- subst id'. inv H2. exists r; split. auto. apply PMap.gss.
+ subst id'. inv H3. exists r; split. auto. rewrite PMap.gss. auto.
exploit me_vars0; eauto. intros [r' [A B]].
exists r'; split. auto. rewrite PMap.gso; auto.
red; intros. subst r'. elim n. eauto.
- rewrite <- me_letvars0. apply list_map_exten; intros.
- symmetry. apply PMap.gso. red; intros. subst x. eauto.
+ erewrite list_map_exten. eauto.
+ intros. symmetry. apply PMap.gso. red; intros. subst x. eauto.
Qed.
(** A variant of [match_env_update_var] where a variable is optionally
assigned to, depending on the [dst] parameter. *)
Lemma match_env_update_dest:
- forall map e le rs dst r v,
+ forall map e le rs dst r v tv,
+ Val.lessdef v tv ->
map_wf map ->
reg_map_ok map r dst ->
match_env map e le rs ->
- match_env map (set_optvar dst v e) le (rs#r <- v).
+ match_env map (set_optvar dst v e) le (rs#r <- tv).
Proof.
- intros. inv H0; simpl.
+ intros. inv H1; simpl.
eapply match_env_update_temp; eauto.
eapply match_env_update_var; eauto.
Qed.
@@ -218,7 +225,7 @@ Hint Resolve match_env_update_dest: rtlg.
Lemma match_env_bind_letvar:
forall map e le rs r v,
match_env map e le rs ->
- rs#r = v ->
+ Val.lessdef v rs#r ->
match_env (add_letvar map r) e (v :: le) rs.
Proof.
intros. inv H. unfold add_letvar. apply mk_match_env; simpl; auto.
@@ -230,7 +237,7 @@ Lemma match_env_unbind_letvar:
match_env map e le rs.
Proof.
unfold add_letvar; intros. inv H. simpl in *.
- constructor. auto. congruence.
+ constructor. auto. inversion me_letvars0. auto.
Qed.
(** Matching between initial environments. *)
@@ -242,7 +249,7 @@ Lemma match_env_empty:
Proof.
intros. apply mk_match_env.
intros. rewrite PTree.gempty in H0. discriminate.
- rewrite H. reflexivity.
+ rewrite H. constructor.
Qed.
(** The assignment of function arguments to local variables (on the Cminor
@@ -250,10 +257,11 @@ Qed.
between environments. *)
Lemma match_set_params_init_regs:
- forall il rl s1 map2 s2 vl i,
+ forall il rl s1 map2 s2 vl tvl i,
add_vars init_mapping il s1 = OK (rl, map2) s2 i ->
- match_env map2 (set_params vl il) nil (init_regs vl rl)
- /\ (forall r, reg_fresh r s2 -> (init_regs vl rl)#r = Vundef).
+ Val.lessdef_list vl tvl ->
+ match_env map2 (set_params vl il) nil (init_regs tvl rl)
+ /\ (forall r, reg_fresh r s2 -> (init_regs tvl rl)#r = Vundef).
Proof.
induction il; intros.
@@ -264,27 +272,29 @@ Proof.
exploit add_vars_valid; eauto. apply init_mapping_valid. intros [A B].
exploit add_var_valid; eauto. intros [A' B']. clear B'.
monadInv EQ1.
- destruct vl as [ | v1 vs].
+ destruct H0 as [ | v1 tv1 vs tvs].
(* vl = nil *)
- destruct (IHil _ _ _ _ nil _ EQ) as [ME UNDEF]. inv ME. split.
+ destruct (IHil _ _ _ _ nil nil _ EQ) as [ME UNDEF]. constructor. inv ME. split.
+ replace (init_regs nil x) with (Regmap.init Vundef) in me_vars0, me_letvars0.
constructor; simpl.
intros id v. repeat rewrite PTree.gsspec. destruct (peq id a); intros.
- subst a. inv H. exists x1; split. auto. apply Regmap.gi.
- replace (init_regs nil x) with (Regmap.init Vundef) in me_vars0. eauto.
+ subst a. inv H. exists x1; split. auto. constructor.
+ eauto.
+ eauto.
destruct x; reflexivity.
- destruct (map_letvars x0). auto. simpl in me_letvars0. congruence.
intros. apply Regmap.gi.
(* vl = v1 :: vs *)
- destruct (IHil _ _ _ _ vs _ EQ) as [ME UNDEF]. inv ME. split.
+ destruct (IHil _ _ _ _ _ _ _ EQ H0) as [ME UNDEF]. inv ME. split.
constructor; simpl.
intros id v. repeat rewrite PTree.gsspec. destruct (peq id a); intros.
- subst a. inv H. exists x1; split. auto. apply Regmap.gss.
+ subst a. inv H. inv H1. exists x1; split. auto. rewrite Regmap.gss. constructor.
+ inv H1. eexists; eauto.
exploit me_vars0; eauto. intros [r' [C D]].
exists r'; split. auto. rewrite Regmap.gso. auto.
apply valid_fresh_different with s.
apply B. left; exists id; auto.
eauto with rtlg.
- destruct (map_letvars x0). auto. simpl in me_letvars0. congruence.
+ destruct (map_letvars x0). auto. simpl in me_letvars0. inversion me_letvars0.
intros. rewrite Regmap.gso. apply UNDEF.
apply reg_fresh_decr with s2; eauto with rtlg.
apply sym_not_equal. apply valid_fresh_different with s2; auto.
@@ -309,19 +319,19 @@ Proof.
constructor.
intros id v. simpl. repeat rewrite PTree.gsspec.
destruct (peq id a). subst a. intro.
- exists x1. split. auto. inv H3.
- apply H1. apply reg_fresh_decr with s. auto.
+ exists x1. split. auto. inv H3. constructor.
eauto with rtlg.
intros. eapply me_vars; eauto.
simpl. eapply me_letvars; eauto.
Qed.
Lemma match_init_env_init_reg:
- forall params s0 rparams map1 s1 i1 vars rvars map2 s2 i2 vparams,
+ forall params s0 rparams map1 s1 i1 vars rvars map2 s2 i2 vparams tvparams,
add_vars init_mapping params s0 = OK (rparams, map1) s1 i1 ->
add_vars map1 vars s1 = OK (rvars, map2) s2 i2 ->
+ Val.lessdef_list vparams tvparams ->
match_env map2 (set_locals vars (set_params vparams params))
- nil (init_regs vparams rparams).
+ nil (init_regs tvparams rparams).
Proof.
intros.
exploit match_set_params_init_regs; eauto. intros [A B].
@@ -475,7 +485,8 @@ Section CORRECTNESS_EXPR.
Variable sp: val.
Variable e: env.
-Variable m: mem.
+Variable m tm: mem.
+Hypothesis mem_extends: Mem.extends m tm.
(** The proof of semantic preservation for the translation of expressions
is a simulation argument based on diagrams of the following form:
@@ -515,9 +526,9 @@ Definition transl_expr_prop
(TE: tr_expr f.(fn_code) map pr a ns nd rd dst)
(ME: match_env map e le rs),
exists rs',
- star step tge (State cs f sp ns rs m) E0 (State cs f sp nd rs' m)
+ star step tge (State cs f sp ns rs tm) E0 (State cs f sp nd rs' tm)
/\ match_env map (set_optvar dst v e) le rs'
- /\ rs'#rd = v
+ /\ Val.lessdef v rs'#rd
/\ (forall r, In r pr -> rs'#r = rs#r).
Definition transl_exprlist_prop
@@ -527,9 +538,9 @@ Definition transl_exprlist_prop
(TE: tr_exprlist f.(fn_code) map pr al ns nd rl)
(ME: match_env map e le rs),
exists rs',
- star step tge (State cs f sp ns rs m) E0 (State cs f sp nd rs' m)
+ star step tge (State cs f sp ns rs tm) E0 (State cs f sp nd rs' tm)
/\ match_env map e le rs'
- /\ rs'##rl = vl
+ /\ Val.lessdef_list vl rs'##rl
/\ (forall r, In r pr -> rs'#r = rs#r).
(** The correctness of the translation is a huge induction over
@@ -541,7 +552,7 @@ Definition transl_exprlist_prop
corresponding to the evaluations of sub-expressions or sub-statements. *)
Lemma transl_expr_Evar_correct:
- forall (le : letenv) (id : positive) (v : val),
+ forall (le : letenv) (id : positive) (v: val),
e ! id = Some v ->
transl_expr_prop le (Evar id) v.
Proof.
@@ -558,7 +569,7 @@ Proof.
split. congruence. auto.
(* general case *)
split.
- apply match_env_invariant with (rs#rd <- v).
+ apply match_env_invariant with (rs#rd <- (rs#r)).
apply match_env_update_dest; auto.
intros. rewrite Regmap.gsspec. destruct (peq r0 rd). congruence. auto.
split. congruence.
@@ -576,18 +587,17 @@ Proof.
intros; red; intros. inv TE.
(* normal case *)
exploit H0; eauto. intros [rs1 [EX1 [ME1 [RR1 RO1]]]].
- exists (rs1#rd <- v).
+ edestruct eval_operation_lessdef as [v' []]; eauto.
+ exists (rs1#rd <- v').
(* Exec *)
split. eapply star_right. eexact EX1.
- eapply exec_Iop; eauto.
- subst vargs.
- rewrite (@eval_operation_preserved CminorSel.fundef _ _ _ ge tge).
- auto.
+ eapply exec_Iop; eauto.
+ rewrite (@eval_operation_preserved CminorSel.fundef _ _ _ ge tge). eauto.
exact symbols_preserved. traceEq.
(* Match-env *)
split. eauto with rtlg.
(* Result reg *)
- split. apply Regmap.gss.
+ split. rewrite Regmap.gss. auto.
(* Other regs *)
intros. rewrite Regmap.gso. auto. intuition congruence.
Qed.
@@ -603,15 +613,17 @@ Lemma transl_expr_Eload_correct:
Proof.
intros; red; intros. inv TE.
exploit H0; eauto. intros [rs1 [EX1 [ME1 [RES1 OTHER1]]]].
- exists (rs1#rd <- v).
+ edestruct eval_addressing_lessdef as [vaddr' []]; eauto.
+ edestruct Mem.loadv_extends as [v' []]; eauto.
+ exists (rs1#rd <- v').
(* Exec *)
split. eapply star_right. eexact EX1. eapply exec_Iload; eauto.
- rewrite RES1. rewrite (@eval_addressing_preserved _ _ _ _ ge tge).
- exact H1. exact symbols_preserved. traceEq.
+ rewrite (@eval_addressing_preserved _ _ _ _ ge tge). eauto.
+ exact symbols_preserved. traceEq.
(* Match-env *)
split. eauto with rtlg.
(* Result *)
- split. apply Regmap.gss.
+ split. rewrite Regmap.gss. auto.
(* Other regs *)
intros. rewrite Regmap.gso. auto. intuition congruence.
Qed.
@@ -634,7 +646,7 @@ Proof.
exists rs2.
(* Exec *)
split. eapply star_trans. eexact EX1.
- eapply star_left. eapply exec_Icond. eauto. rewrite RES1; eauto. reflexivity.
+ eapply star_left. eapply exec_Icond. eauto. eapply eval_condition_lessdef; eauto. reflexivity.
eexact EX2. reflexivity. traceEq.
(* Match-env *)
split. assumption.
@@ -656,7 +668,7 @@ Proof.
exploit H0; eauto. intros [rs1 [EX1 [ME1 [RES1 OTHER1]]]].
assert (map_wf (add_letvar map r)).
eapply add_letvar_wf; eauto.
- exploit H2; eauto. eapply match_env_bind_letvar; eauto.
+ exploit H2; eauto. eapply match_env_bind_letvar; eauto.
intros [rs2 [EX2 [ME3 [RES2 OTHER2]]]].
exists rs2.
(* Exec *)
@@ -685,10 +697,11 @@ Proof.
subst r dst; simpl.
apply match_env_invariant with rs. auto.
intros. destruct (Reg.eq r rd). subst r. auto. auto.
- apply match_env_invariant with (rs#rd <- v).
- apply match_env_update_dest; auto.
- intros. rewrite Regmap.gsspec. destruct (peq r0 rd); auto.
- subst. rewrite RES1. eapply match_env_find_letvar; eauto.
+ apply match_env_invariant with (rs#rd <- (rs#r)).
+ apply match_env_update_dest; auto.
+ eapply match_env_find_letvar; eauto.
+ intros. rewrite Regmap.gsspec. destruct (peq r0 rd); auto.
+ congruence.
(* Result *)
split. rewrite RES1. eapply match_env_find_letvar; eauto.
(* Other regs *)
@@ -706,7 +719,7 @@ Proof.
exists rs.
split. apply star_refl.
split. assumption.
- split. reflexivity.
+ split. constructor.
auto.
Qed.
@@ -728,8 +741,9 @@ Proof.
(* Match-env *)
split. assumption.
(* Results *)
- split. simpl. rewrite RES2. rewrite OTHER2. rewrite RES1. auto.
- simpl; tauto.
+ split. simpl. constructor. rewrite OTHER2. auto.
+ simpl; tauto.
+ auto.
(* Other regs *)
intros. transitivity (rs1#r).
apply OTHER2; auto. simpl; tauto.
@@ -893,25 +907,30 @@ with match_stacks: CminorSel.cont -> list RTL.stackframe -> Prop :=
Inductive match_states: CminorSel.state -> RTL.state -> Prop :=
| match_state:
- forall f s k sp e m cs tf ns rs map ncont nexits ngoto nret rret
+ forall f s k sp e m tm cs tf ns rs map ncont nexits ngoto nret rret
(MWF: map_wf map)
(TS: tr_stmt tf.(fn_code) map s ns ncont nexits ngoto nret rret)
(TF: tr_fun tf map f ngoto nret rret)
(TK: tr_cont tf.(fn_code) map k ncont nexits ngoto nret rret cs)
- (ME: match_env map e nil rs),
+ (ME: match_env map e nil rs)
+ (MEXT: Mem.extends m tm),
match_states (CminorSel.State f s k sp e m)
- (RTL.State cs tf sp ns rs m)
+ (RTL.State cs tf sp ns rs tm)
| match_callstate:
- forall f args k m cs tf
+ forall f args targs k m tm cs tf
(TF: transl_fundef f = OK tf)
- (MS: match_stacks k cs),
+ (MS: match_stacks k cs)
+ (LD: Val.lessdef_list args targs)
+ (MEXT: Mem.extends m tm),
match_states (CminorSel.Callstate f args k m)
- (RTL.Callstate cs tf args m)
+ (RTL.Callstate cs tf targs tm)
| match_returnstate:
- forall v k m cs
- (MS: match_stacks k cs),
+ forall v tv k m tm cs
+ (MS: match_stacks k cs)
+ (LD: Val.lessdef v tv)
+ (MEXT: Mem.extends m tm),
match_states (CminorSel.Returnstate v k m)
- (RTL.Returnstate cs v m).
+ (RTL.Returnstate cs tv tm).
Lemma match_stacks_call_cont:
forall c map k ncont nexits ngoto nret rret cs,
@@ -988,15 +1007,13 @@ Proof.
assert ((fn_code tf)!ncont = Some(Ireturn rret)
/\ match_stacks k cs).
inv TK; simpl in H; try contradiction; auto.
- destruct H2.
- assert (rret = None).
- inv TF. unfold ret_reg. rewrite H0. auto.
+ destruct H1.
assert (fn_stacksize tf = fn_stackspace f).
inv TF. auto.
- subst rret.
+ edestruct Mem.free_parallel_extends as [tm' []]; eauto.
econstructor; split.
left; apply plus_one. eapply exec_Ireturn. eauto.
- rewrite H5. eauto.
+ rewrite H3. eauto.
constructor; auto.
(* assign *)
@@ -1008,14 +1025,14 @@ Proof.
right; split. eauto. Lt_state.
econstructor; eauto. constructor.
(* alternate translation (2 addr) *)
- exploit transl_expr_correct; eauto.
+ exploit transl_expr_correct; eauto.
intros [rs' [A [B [C D]]]].
exploit tr_move_correct; eauto.
intros [rs'' [P [Q R]]].
econstructor; split.
right; split. eapply star_trans. eexact A. eexact P. traceEq. Lt_state.
econstructor; eauto. constructor.
- simpl in B. apply match_env_invariant with (rs'#r <- v).
+ simpl in B. apply match_env_invariant with (rs'#r <- (rs'#rd)).
apply match_env_update_var; auto.
intros. rewrite Regmap.gsspec. destruct (peq r0 r). congruence. auto.
@@ -1025,13 +1042,15 @@ Proof.
intros [rs' [A [B [C D]]]].
exploit transl_expr_correct; eauto.
intros [rs'' [E [F [G J]]]].
- assert (rs''##rl = vl).
- rewrite <- C. apply list_map_exten. intros. symmetry. apply J. auto.
+ assert (Val.lessdef_list vl rs''##rl).
+ replace (rs'' ## rl) with (rs' ## rl). auto.
+ apply list_map_exten. intros. apply J. auto.
+ edestruct eval_addressing_lessdef as [vaddr' []]; eauto.
+ edestruct Mem.storev_extends as [tm' []]; eauto.
econstructor; split.
left; eapply plus_right. eapply star_trans. eexact A. eexact E. reflexivity.
- eapply exec_Istore with (a := vaddr); eauto.
- rewrite H3. rewrite <- H1. apply eval_addressing_preserved. exact symbols_preserved.
- rewrite G. eauto.
+ eapply exec_Istore with (a := vaddr'); eauto.
+ rewrite <- H4. apply eval_addressing_preserved. exact symbols_preserved.
traceEq.
econstructor; eauto. constructor.
@@ -1045,10 +1064,10 @@ Proof.
exploit functions_translated; eauto. intros [tf' [P Q]].
econstructor; split.
left; eapply plus_right. eapply star_trans. eexact A. eexact E. reflexivity.
- eapply exec_Icall; eauto. simpl. rewrite J. rewrite C. eauto. simpl; auto.
+ eapply exec_Icall; eauto. simpl. rewrite J. destruct C. eauto. discriminate P. simpl; auto.
apply sig_transl_function; auto.
traceEq.
- rewrite G. constructor. auto. econstructor; eauto.
+ constructor; auto. econstructor; eauto.
(* direct *)
exploit transl_exprlist_correct; eauto.
intros [rs'' [E [F [G J]]]].
@@ -1059,7 +1078,7 @@ Proof.
rewrite Genv.find_funct_find_funct_ptr in P. eauto.
apply sig_transl_function; auto.
traceEq.
- rewrite G. constructor. auto. econstructor; eauto.
+ constructor; auto. econstructor; eauto.
(* tailcall *)
inv TS; inv H.
@@ -1071,19 +1090,21 @@ Proof.
exploit functions_translated; eauto. intros [tf' [P Q]].
exploit match_stacks_call_cont; eauto. intros [U V].
assert (fn_stacksize tf = fn_stackspace f). inv TF; auto.
+ edestruct Mem.free_parallel_extends as [tm' []]; eauto.
econstructor; split.
left; eapply plus_right. eapply star_trans. eexact A. eexact E. reflexivity.
- eapply exec_Itailcall; eauto. simpl. rewrite J. rewrite C. eauto. simpl; auto.
+ eapply exec_Itailcall; eauto. simpl. rewrite J. destruct C. eauto. discriminate P. simpl; auto.
apply sig_transl_function; auto.
rewrite H; eauto.
traceEq.
- rewrite G. constructor; auto.
+ constructor; auto.
(* direct *)
exploit transl_exprlist_correct; eauto.
intros [rs'' [E [F [G J]]]].
exploit functions_translated; eauto. intros [tf' [P Q]].
exploit match_stacks_call_cont; eauto. intros [U V].
assert (fn_stacksize tf = fn_stackspace f). inv TF; auto.
+ edestruct Mem.free_parallel_extends as [tm' []]; eauto.
econstructor; split.
left; eapply plus_right. eexact E.
eapply exec_Itailcall; eauto. simpl. rewrite symbols_preserved. rewrite H5.
@@ -1091,16 +1112,17 @@ Proof.
apply sig_transl_function; auto.
rewrite H; eauto.
traceEq.
- rewrite G. constructor; auto.
+ constructor; auto.
(* builtin *)
inv TS.
exploit transl_exprlist_correct; eauto.
intros [rs' [E [F [G J]]]].
+ edestruct external_call_mem_extends as [tv [tm' [A [B [C D]]]]]; eauto.
econstructor; split.
left. eapply plus_right. eexact E.
- eapply exec_Ibuiltin. eauto. rewrite G.
- eapply external_call_symbols_preserved; eauto.
+ eapply exec_Ibuiltin. eauto.
+ eapply external_call_symbols_preserved. eauto.
exact symbols_preserved. exact varinfo_preserved.
traceEq.
econstructor; eauto. constructor.
@@ -1116,7 +1138,8 @@ Proof.
inv TS. inv H13.
exploit transl_exprlist_correct; eauto. intros [rs' [A [B [C D]]]].
econstructor; split.
- left. eapply plus_right. eexact A. eapply exec_Icond; eauto. rewrite C; eauto. traceEq.
+ left. eapply plus_right. eexact A. eapply exec_Icond; eauto.
+ eapply eval_condition_lessdef; eauto. traceEq.
destruct b; econstructor; eauto.
(* loop *)
@@ -1156,7 +1179,7 @@ Proof.
exploit validate_switch_correct; eauto. intro CTM.
exploit transl_expr_correct; eauto.
intros [rs' [A [B [C D]]]].
- exploit transl_switch_correct; eauto.
+ exploit transl_switch_correct; eauto. inv C. auto.
intros [nd [rs'' [E [F G]]]].
econstructor; split.
right; split. eapply star_trans. eexact A. eexact E. traceEq. Lt_state.
@@ -1167,6 +1190,7 @@ Proof.
inv TS.
exploit match_stacks_call_cont; eauto. intros [U V].
inversion TF.
+ edestruct Mem.free_parallel_extends as [tm' []]; eauto.
econstructor; split.
left; apply plus_one. eapply exec_Ireturn; eauto.
rewrite H2; eauto.
@@ -1178,10 +1202,11 @@ Proof.
intros [rs' [A [B [C D]]]].
exploit match_stacks_call_cont; eauto. intros [U V].
inversion TF.
+ edestruct Mem.free_parallel_extends as [tm' []]; eauto.
econstructor; split.
left; eapply plus_right. eexact A. eapply exec_Ireturn; eauto.
rewrite H4; eauto. traceEq.
- simpl. rewrite C. constructor; auto.
+ simpl. constructor; auto.
(* label *)
inv TS.
@@ -1201,13 +1226,14 @@ Proof.
monadInv TF. exploit transl_function_charact; eauto. intro TRF.
inversion TRF. subst f0.
pose (e := set_locals (fn_vars f) (set_params vargs (CminorSel.fn_params f))).
- pose (rs := init_regs vargs rparams).
+ pose (rs := init_regs targs rparams).
assert (ME: match_env map2 e nil rs).
unfold rs, e. eapply match_init_env_init_reg; eauto.
assert (MWF: map_wf map2).
assert (map_valid init_mapping s0) by apply init_mapping_valid.
exploit (add_vars_valid (CminorSel.fn_params f)); eauto. intros [A B].
eapply add_vars_wf; eauto. eapply add_vars_wf; eauto. apply init_mapping_wf.
+ edestruct Mem.alloc_extends as [tm' []]; eauto; try apply Zle_refl.
econstructor; split.
left; apply plus_one. eapply exec_function_internal; simpl; eauto.
simpl. econstructor; eauto.
@@ -1216,9 +1242,10 @@ Proof.
(* external call *)
monadInv TF.
+ edestruct external_call_mem_extends as [tvres [tm' [A [B [C D]]]]]; eauto.
econstructor; split.
left; apply plus_one. eapply exec_function_external; eauto.
- eapply external_call_symbols_preserved; eauto.
+ eapply external_call_symbols_preserved. eauto.
exact symbols_preserved. exact varinfo_preserved.
constructor; auto.
@@ -1243,13 +1270,14 @@ Proof.
eexact A.
rewrite <- H2. apply sig_transl_function; auto.
constructor. auto. constructor.
+ constructor. apply Mem.extends_refl.
Qed.
Lemma transl_final_states:
forall S R r,
match_states S R -> CminorSel.final_state S r -> RTL.final_state R r.
Proof.
- intros. inv H0. inv H. inv MS. constructor.
+ intros. inv H0. inv H. inv MS. inv LD. constructor.
Qed.
Theorem transf_program_correct:
diff --git a/backend/RTLgenspec.v b/backend/RTLgenspec.v
index 579a6c2..5114390 100644
--- a/backend/RTLgenspec.v
+++ b/backend/RTLgenspec.v
@@ -901,8 +901,8 @@ Inductive tr_stmt (c: code) (map: mapping):
tr_expr c map nil a ns n r None ->
tr_switch c map r nexits t n ->
tr_stmt c map (Sswitch a cases default) ns nd nexits ngoto nret rret
- | tr_Sreturn_none: forall nret nd nexits ngoto,
- tr_stmt c map (Sreturn None) nret nd nexits ngoto nret None
+ | tr_Sreturn_none: forall nret nd nexits ngoto rret,
+ tr_stmt c map (Sreturn None) nret nd nexits ngoto nret rret
| tr_Sreturn_some: forall a ns nd nexits ngoto nret rret,
tr_expr c map nil a ns nret rret None ->
tr_stmt c map (Sreturn (Some a)) ns nd nexits ngoto nret (Some rret)
@@ -1302,12 +1302,12 @@ Proof.
eapply transl_switch_charact with (s := s0); eauto with rtlg.
monadInv TR.
(* Sreturn *)
- destruct o; destruct rret; inv TR.
- inv OK.
+ destruct o.
+ destruct rret; inv TR. inv OK.
econstructor; eauto with rtlg.
eapply transl_expr_charact; eauto with rtlg.
constructor. auto. simpl; tauto.
- constructor.
+ monadInv TR. constructor.
(* Slabel *)
generalize EQ0; clear EQ0. case_eq (ngoto!l); intros; monadInv EQ0.
generalize EQ1; clear EQ1. unfold handle_error.
diff --git a/backend/Selectionproof.v b/backend/Selectionproof.v
index 2fb56f8..2fd9219 100644
--- a/backend/Selectionproof.v
+++ b/backend/Selectionproof.v
@@ -468,8 +468,7 @@ Proof.
(* skip call *)
exploit Mem.free_parallel_extends; eauto. intros [m2' [A B]].
left; econstructor; split.
- econstructor. inv H10; simpl in H; simpl; auto.
- rewrite <- H0; reflexivity.
+ econstructor. inv H9; simpl in H; simpl; auto.
eauto.
constructor; auto.
(* assign *)
diff --git a/cfrontend/C2C.ml b/cfrontend/C2C.ml
index aa9eca0..d425693 100644
--- a/cfrontend/C2C.ml
+++ b/cfrontend/C2C.ml
@@ -752,7 +752,7 @@ let string_of_errmsg msg =
let string_of_err = function
| Errors.MSG s -> camlstring_of_coqstring s
| Errors.CTX i -> extern_atom i
- | Errors.CTXL i -> "" (* should not happen *)
+ | Errors.POS i -> sprintf "%ld" (camlint_of_positive i)
in String.concat "" (List.map string_of_err msg)
let rec convertInit env init =
diff --git a/cfrontend/Cexec.v b/cfrontend/Cexec.v
index c768118..c370c60 100644
--- a/cfrontend/Cexec.v
+++ b/cfrontend/Cexec.v
@@ -2015,7 +2015,6 @@ Definition do_step (w: world) (s: state) : list (trace * state) :=
ret (Returnstate Vundef (call_cont k) m')
| State f (Sreturn (Some x)) k e m => ret (ExprState f x (Kreturn k) e m)
| State f Sskip ((Kstop | Kcall _ _ _ _ _) as k) e m =>
- check type_eq (f.(fn_return)) Tvoid;
do m' <- Mem.free_list m (blocks_of_env e);
ret (Returnstate Vundef k m')
@@ -2183,7 +2182,7 @@ Proof with (unfold ret; auto with coqlib).
destruct H0; subst x...
rewrite H0...
rewrite H0; rewrite H1...
- rewrite H1. rewrite dec_eq_true. rewrite H2. red in H0. destruct k; try contradiction...
+ rewrite H1. red in H0. destruct k; try contradiction...
destruct H0; subst x...
rewrite H0...
diff --git a/cfrontend/Clight.v b/cfrontend/Clight.v
index d1ab673..e9ec7cc 100644
--- a/cfrontend/Clight.v
+++ b/cfrontend/Clight.v
@@ -269,6 +269,16 @@ Fixpoint create_undef_temps (temps: list (ident * type)) : temp_env :=
| (id, t) :: temps' => PTree.set id Vundef (create_undef_temps temps')
end.
+(** Initialization of temporary variables that are parameters to a function. *)
+
+Fixpoint bind_parameter_temps (formals: list (ident * type)) (args: list val)
+ (le: temp_env) : option temp_env :=
+ match formals, args with
+ | nil, nil => Some le
+ | (id, t) :: xl, v :: vl => bind_parameter_temps xl vl (PTree.set id v le)
+ | _, _ => None
+ end.
+
(** Return the list of blocks in the codomain of [e], with low and high bounds. *)
Definition block_of_binding (id_b_ty: ident * (block * type)) :=
@@ -500,6 +510,16 @@ with find_label_ls (lbl: label) (sl: labeled_statements) (k: cont)
end
end.
+(** Semantics for allocation of variables and binding of parameters at
+ function entry. Two semantics are supported: one where
+ parameters are local variables, reside in memory, and can have their address
+ taken; the other where parameters are temporary variables and do not reside
+ in memory. We parameterize the [step] transition relation over the
+ parameter binding semantics, then instantiate it later to give the two
+ semantics described above. *)
+
+Variable function_entry: function -> list val -> mem -> env -> temp_env -> mem -> Prop.
+
(** Transition relation *)
Inductive step: state -> trace -> state -> Prop :=
@@ -580,7 +600,6 @@ Inductive step: state -> trace -> state -> Prop :=
E0 (Returnstate v' (call_cont k) m')
| step_skip_call: forall f k e le m m',
is_call_cont k ->
- f.(fn_return) = Tvoid ->
Mem.free_list m (blocks_of_env e) = Some m' ->
step (State f Sskip k e le m)
E0 (Returnstate Vundef k m')
@@ -606,12 +625,10 @@ Inductive step: state -> trace -> state -> Prop :=
step (State f (Sgoto lbl) k e le m)
E0 (State f s' k' e le m)
- | step_internal_function: forall f vargs k m e m1 m2,
- list_norepet (var_names f.(fn_params) ++ var_names f.(fn_vars)) ->
- alloc_variables empty_env m (f.(fn_params) ++ f.(fn_vars)) e m1 ->
- bind_parameters e m1 f.(fn_params) vargs m2 ->
+ | step_internal_function: forall f vargs k m e le m1,
+ function_entry f vargs m e le m1 ->
step (Callstate (Internal f) vargs k m)
- E0 (State f f.(fn_body) k e (create_undef_temps f.(fn_temps)) m2)
+ E0 (State f f.(fn_body) k e le m1)
| step_external_function: forall ef targs tres vargs k m vres t m',
external_call ef ge vargs m t vres m' ->
@@ -646,19 +663,47 @@ Inductive final_state: state -> int -> Prop :=
End SEMANTICS.
-(** Wrapping up these definitions in a small-step semantics. *)
+(** The two semantics for function parameters. First, parameters as local variables. *)
+
+Inductive function_entry1 (f: function) (vargs: list val) (m: mem) (e: env) (le: temp_env) (m': mem) : Prop :=
+ | function_entry1_intro: forall m1,
+ list_norepet (var_names f.(fn_params) ++ var_names f.(fn_vars)) ->
+ alloc_variables empty_env m (f.(fn_params) ++ f.(fn_vars)) e m1 ->
+ bind_parameters e m1 f.(fn_params) vargs m' ->
+ le = create_undef_temps f.(fn_temps) ->
+ function_entry1 f vargs m e le m'.
+
+Definition step1 (ge: genv) := step ge function_entry1.
+
+(** Second, parameters as temporaries. *)
+
+Inductive function_entry2 (f: function) (vargs: list val) (m: mem) (e: env) (le: temp_env) (m': mem) : Prop :=
+ | function_entry2_intro:
+ list_norepet (var_names f.(fn_vars)) ->
+ list_norepet (var_names f.(fn_params)) ->
+ list_disjoint (var_names f.(fn_params)) (var_names f.(fn_temps)) ->
+ alloc_variables empty_env m f.(fn_vars) e m' ->
+ bind_parameter_temps f.(fn_params) vargs (create_undef_temps f.(fn_temps)) = Some le ->
+ function_entry2 f vargs m e le m'.
+
+Definition step2 (ge: genv) := step ge function_entry2.
+
+(** Wrapping up these definitions in two small-step semantics. *)
+
+Definition semantics1 (p: program) :=
+ Semantics step1 (initial_state p) final_state (Genv.globalenv p).
-Definition semantics (p: program) :=
- Semantics step (initial_state p) final_state (Genv.globalenv p).
+Definition semantics2 (p: program) :=
+ Semantics step2 (initial_state p) final_state (Genv.globalenv p).
(** This semantics is receptive to changes in events. *)
Lemma semantics_receptive:
- forall (p: program), receptive (semantics p).
+ forall (p: program), receptive (semantics1 p).
Proof.
intros. constructor; simpl; intros.
(* receptiveness *)
- assert (t1 = E0 -> exists s2, step (Genv.globalenv p) s t2 s2).
+ assert (t1 = E0 -> exists s2, step1 (Genv.globalenv p) s t2 s2).
intros. subst. inv H0. exists s1; auto.
inversion H; subst; auto.
(* builtin *)
diff --git a/cfrontend/ClightBigstep.v b/cfrontend/ClightBigstep.v
index 7603b6b..293ea5d 100644
--- a/cfrontend/ClightBigstep.v
+++ b/cfrontend/ClightBigstep.v
@@ -299,14 +299,14 @@ Lemma exec_stmt_eval_funcall_steps:
(forall e le m s t le' m' out,
exec_stmt ge e le m s t le' m' out ->
forall f k, exists S,
- star step ge (State f s k e le m) t S
+ star step1 ge (State f s k e le m) t S
/\ outcome_state_match e le' m' f k out S)
/\
(forall m fd args t m' res,
eval_funcall ge m fd args t m' res ->
forall k,
is_call_cont k ->
- star step ge (Callstate fd args k m) t (Returnstate res k m')).
+ star step1 ge (Callstate fd args k m) t (Returnstate res k m')).
Proof.
apply exec_stmt_funcall_ind; intros.
@@ -450,7 +450,7 @@ Proof.
(* call internal *)
destruct (H3 f k) as [S1 [A1 B1]].
- eapply star_left. eapply step_internal_function; eauto.
+ eapply star_left. eapply step_internal_function; eauto. econstructor; eauto.
eapply star_right. eexact A1.
inv B1; simpl in H4; try contradiction.
(* Out_normal *)
@@ -477,7 +477,7 @@ Lemma exec_stmt_steps:
forall e le m s t le' m' out,
exec_stmt ge e le m s t le' m' out ->
forall f k, exists S,
- star step ge (State f s k e le m) t S
+ star step1 ge (State f s k e le m) t S
/\ outcome_state_match e le' m' f k out S.
Proof (proj1 exec_stmt_eval_funcall_steps).
@@ -486,7 +486,7 @@ Lemma eval_funcall_steps:
eval_funcall ge m fd args t m' res ->
forall k,
is_call_cont k ->
- star step ge (Callstate fd args k m) t (Returnstate res k m').
+ star step1 ge (Callstate fd args k m) t (Returnstate res k m').
Proof (proj2 exec_stmt_eval_funcall_steps).
Definition order (x y: unit) := False.
@@ -494,12 +494,12 @@ Definition order (x y: unit) := False.
Lemma evalinf_funcall_forever:
forall m fd args T k,
evalinf_funcall ge m fd args T ->
- forever_N step order ge tt (Callstate fd args k m) T.
+ forever_N step1 order ge tt (Callstate fd args k m) T.
Proof.
cofix CIH_FUN.
assert (forall e le m s T f k,
execinf_stmt ge e le m s T ->
- forever_N step order ge tt (State f s k e le m) T).
+ forever_N step1 order ge tt (State f s k e le m) T).
cofix CIH_STMT.
intros. inv H.
@@ -558,13 +558,13 @@ Proof.
(* call internal *)
intros. inv H0.
eapply forever_N_plus.
- eapply plus_one. econstructor; eauto.
+ eapply plus_one. econstructor; eauto. econstructor; eauto.
apply H; eauto.
traceEq.
Qed.
Theorem bigstep_semantics_sound:
- bigstep_sound (bigstep_semantics prog) (semantics prog).
+ bigstep_sound (bigstep_semantics prog) (semantics1 prog).
Proof.
constructor; simpl; intros.
(* termination *)
diff --git a/cfrontend/Cminorgen.v b/cfrontend/Cminorgen.v
index a47efb2..e024caf 100644
--- a/cfrontend/Cminorgen.v
+++ b/cfrontend/Cminorgen.v
@@ -14,6 +14,8 @@
Require Import FSets.
Require FSetAVL.
+Require Import Orders.
+Require Mergesort.
Require Import Coqlib.
Require Import Errors.
Require Import Maps.
@@ -49,26 +51,10 @@ Local Open Scope error_monad_scope.
(** * Handling of variables *)
-Definition for_var (id: ident) : ident := xO id.
-Definition for_temp (id: ident) : ident := xI id.
+(** To every Csharpminor variable, the compiler associates its offset
+ in the Cminor stack data block. *)
-(** Compile-time information attached to each Csharpminor
- variable: global variables, local variables, function parameters.
- [Var_local] denotes a scalar local variable whose address is not
- taken; it will be translated to a Cminor local variable of the
- same name. [Var_stack_scalar] and [Var_stack_array] denote
- local variables that are stored as sub-blocks of the Cminor stack
- data block. [Var_global_scalar] and [Var_global_array] denote
- global variables, stored in the global symbols with the same names. *)
-
-Inductive var_info: Type :=
- | Var_local (chunk: memory_chunk)
- | Var_stack_scalar (chunk: memory_chunk) (ofs: Z)
- | Var_stack_array (ofs sz al: Z)
- | Var_global_scalar (chunk: memory_chunk)
- | Var_global_array.
-
-Definition compilenv := PMap.t var_info.
+Definition compilenv := PTree.t Z.
(** * Helper functions for code generation *)
@@ -237,62 +223,13 @@ End Approx.
(** * Translation of expressions and statements. *)
-(** Generation of a Cminor expression for reading a Csharpminor variable. *)
-
-Definition var_get (cenv: compilenv) (id: ident): res (expr * approx) :=
- match PMap.get id cenv with
- | Var_local chunk =>
- OK(Evar (for_var id), Approx.of_chunk chunk)
- | Var_stack_scalar chunk ofs =>
- OK(Eload chunk (make_stackaddr ofs), Approx.of_chunk chunk)
- | Var_global_scalar chunk =>
- OK(Eload chunk (make_globaladdr id), Approx.of_chunk chunk)
- | _ =>
- Error(msg "Cminorgen.var_get")
- end.
-
(** Generation of a Cminor expression for taking the address of
a Csharpminor variable. *)
-Definition var_addr (cenv: compilenv) (id: ident): res (expr * approx) :=
- match PMap.get id cenv with
- | Var_local chunk => Error(msg "Cminorgen.var_addr")
- | Var_stack_scalar chunk ofs => OK (make_stackaddr ofs, Any)
- | Var_stack_array ofs sz al => OK (make_stackaddr ofs, Any)
- | _ => OK (make_globaladdr id, Any)
- end.
-
-(** Generation of a Cminor statement performing an assignment to
- a variable. The value being assigned is normalized according to
- its chunk type, as guaranteed by C#minor semantics. *)
-
-Definition var_set (cenv: compilenv)
- (id: ident) (rhs: expr): res stmt :=
- match PMap.get id cenv with
- | Var_local chunk =>
- OK(Sassign (for_var id) rhs)
- | Var_stack_scalar chunk ofs =>
- OK(make_store chunk (make_stackaddr ofs) rhs)
- | Var_global_scalar chunk =>
- OK(make_store chunk (make_globaladdr id) rhs)
- | _ =>
- Error(msg "Cminorgen.var_set")
- end.
-
-(** A variant of [var_set] used for initializing function parameters.
- The value to be stored already resides in the Cminor variable called [id]. *)
-
-Definition var_set_self (cenv: compilenv) (id: ident) (k: stmt): res stmt :=
- match PMap.get id cenv with
- | Var_local chunk =>
- OK k
- | Var_stack_scalar chunk ofs =>
- OK (Sseq (make_store chunk (make_stackaddr ofs) (Evar (for_var id))) k)
- | Var_stack_array ofs sz al =>
- OK (Sseq (Sbuiltin None (EF_memcpy sz al)
- (make_stackaddr ofs :: Evar (for_var id) :: nil)) k)
- | _ =>
- Error(msg "Cminorgen.var_set_self")
+Definition var_addr (cenv: compilenv) (id: ident): expr :=
+ match PTree.get id cenv with
+ | Some ofs => make_stackaddr ofs
+ | None => make_globaladdr id
end.
(** Translation of constants. *)
@@ -313,11 +250,9 @@ Fixpoint transl_expr (cenv: compilenv) (e: Csharpminor.expr)
{struct e}: res (expr * approx) :=
match e with
| Csharpminor.Evar id =>
- var_get cenv id
- | Csharpminor.Etempvar id =>
- OK (Evar (for_temp id), Any)
+ OK (Evar id, Any)
| Csharpminor.Eaddrof id =>
- var_addr cenv id
+ OK (var_addr cenv id, Any)
| Csharpminor.Econst cst =>
let (tcst, a) := transl_constant cst in OK (Econst tcst, a)
| Csharpminor.Eunop op e1 =>
@@ -388,21 +323,14 @@ Fixpoint switch_env (ls: lbl_stmt) (e: exit_env) {struct ls}: exit_env :=
(** Translation of statements. The nonobvious part is
the translation of [switch] statements, outlined above. *)
-Definition typ_of_opttyp (ot: option typ) :=
- match ot with None => Tint | Some t => t end.
-
-Fixpoint transl_stmt (ret: option typ) (cenv: compilenv)
- (xenv: exit_env) (s: Csharpminor.stmt)
+Fixpoint transl_stmt (cenv: compilenv) (xenv: exit_env) (s: Csharpminor.stmt)
{struct s}: res stmt :=
match s with
| Csharpminor.Sskip =>
OK Sskip
- | Csharpminor.Sassign id e =>
- do (te, a) <- transl_expr cenv e;
- var_set cenv id te
| Csharpminor.Sset id e =>
do (te, a) <- transl_expr cenv e;
- OK (Sassign (for_temp id) te)
+ OK (Sassign id te)
| Csharpminor.Sstore chunk e1 e2 =>
do (te1, a1) <- transl_expr cenv e1;
do (te2, a2) <- transl_expr cenv e2;
@@ -410,24 +338,24 @@ Fixpoint transl_stmt (ret: option typ) (cenv: compilenv)
| Csharpminor.Scall optid sig e el =>
do (te, a) <- transl_expr cenv e;
do tel <- transl_exprlist cenv el;
- OK (Scall (option_map for_temp optid) sig te tel)
+ OK (Scall optid sig te tel)
| Csharpminor.Sbuiltin optid ef el =>
do tel <- transl_exprlist cenv el;
- OK (Sbuiltin (option_map for_temp optid) ef tel)
+ OK (Sbuiltin optid ef tel)
| Csharpminor.Sseq s1 s2 =>
- do ts1 <- transl_stmt ret cenv xenv s1;
- do ts2 <- transl_stmt ret cenv xenv s2;
+ do ts1 <- transl_stmt cenv xenv s1;
+ do ts2 <- transl_stmt cenv xenv s2;
OK (Sseq ts1 ts2)
| Csharpminor.Sifthenelse e s1 s2 =>
do (te, a) <- transl_expr cenv e;
- do ts1 <- transl_stmt ret cenv xenv s1;
- do ts2 <- transl_stmt ret cenv xenv s2;
+ do ts1 <- transl_stmt cenv xenv s1;
+ do ts2 <- transl_stmt cenv xenv s2;
OK (Sifthenelse te ts1 ts2)
| Csharpminor.Sloop s =>
- do ts <- transl_stmt ret cenv xenv s;
+ do ts <- transl_stmt cenv xenv s;
OK (Sloop ts)
| Csharpminor.Sblock s =>
- do ts <- transl_stmt ret cenv (true :: xenv) s;
+ do ts <- transl_stmt cenv (true :: xenv) s;
OK (Sblock ts)
| Csharpminor.Sexit n =>
OK (Sexit (shift_exit xenv n))
@@ -435,195 +363,95 @@ Fixpoint transl_stmt (ret: option typ) (cenv: compilenv)
let cases := switch_table ls O in
let default := length cases in
do (te, a) <- transl_expr cenv e;
- transl_lblstmt ret cenv (switch_env ls xenv) ls (Sswitch te cases default)
+ transl_lblstmt cenv (switch_env ls xenv) ls (Sswitch te cases default)
| Csharpminor.Sreturn None =>
OK (Sreturn None)
| Csharpminor.Sreturn (Some e) =>
do (te, a) <- transl_expr cenv e;
OK (Sreturn (Some te))
| Csharpminor.Slabel lbl s =>
- do ts <- transl_stmt ret cenv xenv s; OK (Slabel lbl ts)
+ do ts <- transl_stmt cenv xenv s; OK (Slabel lbl ts)
| Csharpminor.Sgoto lbl =>
OK (Sgoto lbl)
end
-with transl_lblstmt (ret: option typ) (cenv: compilenv)
- (xenv: exit_env) (ls: Csharpminor.lbl_stmt) (body: stmt)
+with transl_lblstmt (cenv: compilenv) (xenv: exit_env) (ls: Csharpminor.lbl_stmt) (body: stmt)
{struct ls}: res stmt :=
match ls with
| Csharpminor.LSdefault s =>
- do ts <- transl_stmt ret cenv xenv s;
+ do ts <- transl_stmt cenv xenv s;
OK (Sseq (Sblock body) ts)
| Csharpminor.LScase _ s ls' =>
- do ts <- transl_stmt ret cenv xenv s;
- transl_lblstmt ret cenv (List.tail xenv) ls' (Sseq (Sblock body) ts)
+ do ts <- transl_stmt cenv xenv s;
+ transl_lblstmt cenv (List.tail xenv) ls' (Sseq (Sblock body) ts)
end.
(** * Stack layout *)
-(** Computation of the set of variables whose address is taken in
- a piece of Csharpminor code. *)
-
-Module Identset := FSetAVL.Make(OrderedPositive).
-
-Fixpoint addr_taken_expr (e: Csharpminor.expr): Identset.t :=
- match e with
- | Csharpminor.Evar id => Identset.empty
- | Csharpminor.Etempvar id => Identset.empty
- | Csharpminor.Eaddrof id => Identset.add id Identset.empty
- | Csharpminor.Econst cst => Identset.empty
- | Csharpminor.Eunop op e1 => addr_taken_expr e1
- | Csharpminor.Ebinop op e1 e2 =>
- Identset.union (addr_taken_expr e1) (addr_taken_expr e2)
- | Csharpminor.Eload chunk e => addr_taken_expr e
- end.
-
-Fixpoint addr_taken_exprlist (e: list Csharpminor.expr): Identset.t :=
- match e with
- | nil => Identset.empty
- | e1 :: e2 =>
- Identset.union (addr_taken_expr e1) (addr_taken_exprlist e2)
- end.
-
-Fixpoint addr_taken_stmt (s: Csharpminor.stmt): Identset.t :=
- match s with
- | Csharpminor.Sskip => Identset.empty
- | Csharpminor.Sassign id e => addr_taken_expr e
- | Csharpminor.Sset id e => addr_taken_expr e
- | Csharpminor.Sstore chunk e1 e2 =>
- Identset.union (addr_taken_expr e1) (addr_taken_expr e2)
- | Csharpminor.Scall optid sig e el =>
- Identset.union (addr_taken_expr e) (addr_taken_exprlist el)
- | Csharpminor.Sbuiltin optid ef el =>
- addr_taken_exprlist el
- | Csharpminor.Sseq s1 s2 =>
- Identset.union (addr_taken_stmt s1) (addr_taken_stmt s2)
- | Csharpminor.Sifthenelse e s1 s2 =>
- Identset.union (addr_taken_expr e)
- (Identset.union (addr_taken_stmt s1) (addr_taken_stmt s2))
- | Csharpminor.Sloop s => addr_taken_stmt s
- | Csharpminor.Sblock s => addr_taken_stmt s
- | Csharpminor.Sexit n => Identset.empty
- | Csharpminor.Sswitch e ls =>
- Identset.union (addr_taken_expr e) (addr_taken_lblstmt ls)
- | Csharpminor.Sreturn None => Identset.empty
- | Csharpminor.Sreturn (Some e) => addr_taken_expr e
- | Csharpminor.Slabel lbl s => addr_taken_stmt s
- | Csharpminor.Sgoto lbl => Identset.empty
- end
-
-with addr_taken_lblstmt (ls: Csharpminor.lbl_stmt): Identset.t :=
- match ls with
- | Csharpminor.LSdefault s => addr_taken_stmt s
- | Csharpminor.LScase _ s ls' => Identset.union (addr_taken_stmt s) (addr_taken_lblstmt ls')
- end.
-
(** Layout of the Cminor stack data block and construction of the
- compilation environment. Csharpminor local variables that are
- arrays or whose address is taken are allocated a slot in the Cminor
- stack data. Sufficient padding is inserted to ensure adequate alignment
- of addresses. *)
+ compilation environment. Every Csharpminor local variable is
+ allocated a slot in the Cminor stack data. Sufficient padding is
+ inserted to ensure adequate alignment of addresses. *)
-Definition array_alignment (sz: Z) : Z :=
+Definition block_alignment (sz: Z) : Z :=
if zlt sz 2 then 1
else if zlt sz 4 then 2
else if zlt sz 8 then 4 else 8.
Definition assign_variable
- (atk: Identset.t)
- (id_lv: ident * var_kind)
- (cenv_stacksize: compilenv * Z) : compilenv * Z :=
+ (cenv_stacksize: compilenv * Z) (id_sz: ident * Z) : compilenv * Z :=
+ let (id, sz) := id_sz in
let (cenv, stacksize) := cenv_stacksize in
- match id_lv with
- | (id, Varray sz al) =>
- let ofs := align stacksize (array_alignment sz) in
- (PMap.set id (Var_stack_array ofs sz al) cenv, ofs + Zmax 0 sz)
- | (id, Vscalar chunk) =>
- if Identset.mem id atk then
- let sz := size_chunk chunk in
- let ofs := align stacksize sz in
- (PMap.set id (Var_stack_scalar chunk ofs) cenv, ofs + sz)
- else
- (PMap.set id (Var_local chunk) cenv, stacksize)
- end.
+ let ofs := align stacksize (block_alignment sz) in
+ (PTree.set id ofs cenv, ofs + Zmax 0 sz).
-Fixpoint assign_variables
- (atk: Identset.t)
- (id_lv_list: list (ident * var_kind))
- (cenv_stacksize: compilenv * Z)
- {struct id_lv_list}: compilenv * Z :=
- match id_lv_list with
- | nil => cenv_stacksize
- | id_lv :: rem =>
- assign_variables atk rem (assign_variable atk id_lv cenv_stacksize)
- end.
+Definition assign_variables (cenv_stacksize: compilenv * Z) (vars: list (ident * Z)) : compilenv * Z :=
+ List.fold_left assign_variable vars cenv_stacksize.
-Definition build_compilenv
- (globenv: compilenv) (f: Csharpminor.function) : compilenv * Z :=
- assign_variables
- (addr_taken_stmt f.(Csharpminor.fn_body))
- (fn_variables f)
- (globenv, 0).
-
-Definition assign_global_def
- (ce: compilenv) (gdef: ident * globdef Csharpminor.fundef var_kind) : compilenv :=
- let (id, gd) := gdef in
- let kind :=
- match gd with
- | Gvar (mkglobvar (Vscalar chunk) _ _ _) => Var_global_scalar chunk
- | Gvar (mkglobvar (Varray _ _) _ _ _) => Var_global_array
- | Gfun f => Var_global_array
- end in
- PMap.set id kind ce.
-
-Definition build_global_compilenv (p: Csharpminor.program) : compilenv :=
- List.fold_left assign_global_def p.(prog_defs) (PMap.init Var_global_array).
+(** Before allocating stack slots, we sort variables by increasing size
+ so as to minimize padding. *)
-(** * Translation of functions *)
+Module VarOrder <: TotalLeBool.
+ Definition t := (ident * Z)%type.
+ Definition leb (v1 v2: t) : bool := zle (snd v1) (snd v2).
+ Theorem leb_total: forall v1 v2, leb v1 v2 = true \/ leb v2 v1 = true.
+ Proof.
+ unfold leb; intros.
+ assert (snd v1 <= snd v2 \/ snd v2 <= snd v1) by omega.
+ unfold proj_sumbool. destruct H; [left|right]; apply zle_true; auto.
+ Qed.
+End VarOrder.
-(** Function parameters whose address is taken must be stored in their
- stack slots at function entry. (Cminor passes these parameters in
- local variables.) *)
-
-Fixpoint store_parameters
- (cenv: compilenv) (params: list (ident * var_kind))
- {struct params} : res stmt :=
- match params with
- | nil => OK Sskip
- | (id, vk) :: rem =>
- do s <- store_parameters cenv rem;
- var_set_self cenv id s
- end.
+Module VarSort := Mergesort.Sort(VarOrder).
+
+Definition build_compilenv (f: Csharpminor.function) : compilenv * Z :=
+ assign_variables (PTree.empty Z, 0) (VarSort.sort (Csharpminor.fn_vars f)).
+
+(** * Translation of functions *)
(** Translation of a Csharpminor function. We must check that the
required Cminor stack block is no bigger than [Int.max_signed],
otherwise address computations within the stack block could
overflow machine arithmetic and lead to incorrect code. *)
-Definition transl_funbody
- (cenv: compilenv) (stacksize: Z) (f: Csharpminor.function): res function :=
- do tbody <- transl_stmt f.(fn_return) cenv nil f.(Csharpminor.fn_body);
- do sparams <- store_parameters cenv f.(Csharpminor.fn_params);
+Definition transl_funbody
+ (cenv: compilenv) (stacksize: Z) (f: Csharpminor.function): res function :=
+ do tbody <- transl_stmt cenv nil f.(Csharpminor.fn_body);
OK (mkfunction
(Csharpminor.fn_sig f)
- (List.map for_var (Csharpminor.fn_params_names f))
- (List.map for_var (Csharpminor.fn_vars_names f) ++
- List.map for_temp (Csharpminor.fn_temps f))
+ (Csharpminor.fn_params f)
+ (Csharpminor.fn_temps f)
stacksize
- (Sseq sparams tbody)).
+ tbody).
-Definition transl_function
- (gce: compilenv) (f: Csharpminor.function): res function :=
- let (cenv, stacksize) := build_compilenv gce f in
+Definition transl_function (f: Csharpminor.function): res function :=
+ let (cenv, stacksize) := build_compilenv f in
if zle stacksize Int.max_unsigned
then transl_funbody cenv stacksize f
else Error(msg "Cminorgen: too many local variables, stack size exceeded").
-Definition transl_fundef (gce: compilenv) (f: Csharpminor.fundef): res fundef :=
- transf_partial_fundef (transl_function gce) f.
-
-Definition transl_globvar (vk: var_kind) := OK tt.
+Definition transl_fundef (f: Csharpminor.fundef): res fundef :=
+ transf_partial_fundef transl_function f.
Definition transl_program (p: Csharpminor.program) : res program :=
- let gce := build_global_compilenv p in
- transform_partial_program2 (transl_fundef gce) transl_globvar p.
+ transform_partial_program transl_fundef p.
diff --git a/cfrontend/Cminorgenproof.v b/cfrontend/Cminorgenproof.v
index 42f54b3..018fcec 100644
--- a/cfrontend/Cminorgenproof.v
+++ b/cfrontend/Cminorgenproof.v
@@ -14,6 +14,7 @@
Require Import Coq.Program.Equality.
Require Import FSets.
+Require Import Permutation.
Require Import Coqlib.
Require Intv.
Require Import Errors.
@@ -40,102 +41,50 @@ Variable prog: Csharpminor.program.
Variable tprog: program.
Hypothesis TRANSL: transl_program prog = OK tprog.
Let ge : Csharpminor.genv := Genv.globalenv prog.
-Let gce : compilenv := build_global_compilenv prog.
Let tge: genv := Genv.globalenv tprog.
Lemma symbols_preserved:
forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s.
-Proof (Genv.find_symbol_transf_partial2 (transl_fundef gce) transl_globvar _ TRANSL).
+Proof (Genv.find_symbol_transf_partial transl_fundef _ TRANSL).
Lemma function_ptr_translated:
forall (b: block) (f: Csharpminor.fundef),
Genv.find_funct_ptr ge b = Some f ->
exists tf,
- Genv.find_funct_ptr tge b = Some tf /\ transl_fundef gce f = OK tf.
-Proof (Genv.find_funct_ptr_transf_partial2 (transl_fundef gce) transl_globvar _ TRANSL).
+ Genv.find_funct_ptr tge b = Some tf /\ transl_fundef f = OK tf.
+Proof (Genv.find_funct_ptr_transf_partial transl_fundef _ TRANSL).
Lemma functions_translated:
forall (v: val) (f: Csharpminor.fundef),
Genv.find_funct ge v = Some f ->
exists tf,
- Genv.find_funct tge v = Some tf /\ transl_fundef gce f = OK tf.
-Proof (Genv.find_funct_transf_partial2 (transl_fundef gce) transl_globvar _ TRANSL).
+ Genv.find_funct tge v = Some tf /\ transl_fundef f = OK tf.
+Proof (Genv.find_funct_transf_partial transl_fundef _ TRANSL).
-Lemma var_info_translated:
- forall b v,
- Genv.find_var_info ge b = Some v ->
- exists tv, Genv.find_var_info tge b = Some tv /\ transf_globvar transl_globvar v = OK tv.
-Proof (Genv.find_var_info_transf_partial2 (transl_fundef gce) transl_globvar _ TRANSL).
-
-Lemma var_info_rev_translated:
- forall b tv,
- Genv.find_var_info tge b = Some tv ->
- exists v, Genv.find_var_info ge b = Some v /\ transf_globvar transl_globvar v = OK tv.
-Proof (Genv.find_var_info_rev_transf_partial2 (transl_fundef gce) transl_globvar _ TRANSL).
+Lemma varinfo_preserved:
+ forall b, Genv.find_var_info tge b = Genv.find_var_info ge b.
+Proof (Genv.find_var_info_transf_partial transl_fundef _ TRANSL).
Lemma sig_preserved_body:
forall f tf cenv size,
transl_funbody cenv size f = OK tf ->
tf.(fn_sig) = Csharpminor.fn_sig f.
Proof.
- intros. monadInv H. reflexivity.
+ intros. unfold transl_funbody in H. monadInv H; reflexivity.
Qed.
Lemma sig_preserved:
forall f tf,
- transl_fundef gce f = OK tf ->
+ transl_fundef f = OK tf ->
Cminor.funsig tf = Csharpminor.funsig f.
Proof.
intros until tf; destruct f; simpl.
- unfold transl_function. destruct (build_compilenv gce f).
+ unfold transl_function. destruct (build_compilenv f).
case (zle z Int.max_unsigned); simpl bind; try congruence.
intros. monadInv H. simpl. eapply sig_preserved_body; eauto.
intro. inv H. reflexivity.
Qed.
-Definition global_compilenv_match (ce: compilenv) (ge: Csharpminor.genv) : Prop :=
- forall id,
- match ce!!id with
- | Var_global_scalar chunk =>
- forall b gv, Genv.find_symbol ge id = Some b ->
- Genv.find_var_info ge b = Some gv ->
- gv.(gvar_info) = Vscalar chunk
- | Var_global_array => True
- | _ => False
- end.
-
-Lemma global_compilenv_charact:
- global_compilenv_match gce ge.
-Proof.
- assert (A: forall ge, global_compilenv_match (PMap.init Var_global_array) ge).
- intros; red; intros. rewrite PMap.gi. auto.
- assert (B: forall ce ge idg,
- global_compilenv_match ce ge ->
- global_compilenv_match (assign_global_def ce idg)
- (Genv.add_global ge idg)).
- intros; red; intros. unfold assign_global_def.
- destruct idg as [id1 gd]. rewrite PMap.gsspec. destruct (peq id id1).
- (* same var *)
- subst id1. destruct gd as [f | [info1 init1 ro1 vo1]]. auto.
- destruct info1; auto.
- unfold Genv.find_symbol, Genv.find_var_info. simpl; intros.
- rewrite PTree.gss in H0. inv H0. rewrite ZMap.gss in H1. inv H1; auto.
- (* different var *)
- generalize (H id). unfold Genv.find_symbol, Genv.find_var_info. simpl. intros.
- destruct (ce!!id); auto. intros.
- rewrite PTree.gso in H1; auto.
- destruct gd as [f|v]. eauto. rewrite ZMap.gso in H2. eauto.
- exploit Genv.genv_symb_range; eauto. unfold block, ZIndexed.t; omega.
- assert (C: forall gl ce ge,
- global_compilenv_match ce ge ->
- global_compilenv_match (fold_left assign_global_def gl ce)
- (Genv.add_globals ge gl)).
- induction gl; simpl; intros. auto. apply IHgl. apply B. auto.
-
- unfold gce, build_global_compilenv, ge, Genv.globalenv.
- apply C. apply A.
-Qed.
-
(** * Derived properties of memory operations *)
Lemma load_freelist:
@@ -202,397 +151,109 @@ Proof.
eapply Mem.nextblock_store; eauto.
Qed.
-(** * Correspondence between Csharpminor's and Cminor's environments and memory states *)
+(** * Correspondence between C#minor's and Cminor's environments and memory states *)
-(** In Csharpminor, every variable is stored in a separate memory block.
- In the corresponding Cminor code, some of these variables reside in
- the local variable environment; others are sub-blocks of the stack data
- block. We capture these changes in memory via a memory injection [f]:
-- [f b = None] means that the Csharpminor block [b] no longer exist
- in the execution of the generated Cminor code. This corresponds to
- a Csharpminor local variable translated to a Cminor local variable.
-- [f b = Some(b', ofs)] means that Csharpminor block [b] corresponds
+(** In C#minor, every variable is stored in a separate memory block.
+ In the corresponding Cminor code, these variables become sub-blocks
+ of the stack data block. We capture these changes in memory via a
+ memory injection [f]:
+ [f b = Some(b', ofs)] means that C#minor block [b] corresponds
to a sub-block of Cminor block [b] at offset [ofs].
A memory injection [f] defines a relation [val_inject f] between
- values and a relation [Mem.inject f] between memory states.
- These relations will be used intensively
- in our proof of simulation between Csharpminor and Cminor executions.
-
- In this section, we define the relation between
- Csharpminor and Cminor environments. *)
-
-(** Matching for a Csharpminor variable [id].
-- If this variable is mapped to a Cminor local variable, the
- corresponding Csharpminor memory block [b] must no longer exist in
- Cminor ([f b = None]). Moreover, the content of block [b] must
- match the value of [id] found in the Cminor local environment [te].
-- If this variable is mapped to a sub-block of the Cminor stack data
- at offset [ofs], the address of this variable in Csharpminor [Vptr b
- Int.zero] must match the address of the sub-block [Vptr sp (Int.repr
- ofs)].
-*)
+ values and a relation [Mem.inject f] between memory states. These
+ relations will be used intensively in our proof of simulation
+ between C#minor and Cminor executions. *)
-Inductive match_var (f: meminj) (id: ident)
- (e: Csharpminor.env) (m: mem) (te: env) (sp: block) :
- var_info -> Prop :=
- | match_var_local:
- forall chunk b v v',
- PTree.get id e = Some (b, Vscalar chunk) ->
- Mem.load chunk m b 0 = Some v ->
- f b = None ->
- PTree.get (for_var id) te = Some v' ->
- val_inject f v v' ->
- match_var f id e m te sp (Var_local chunk)
- | match_var_stack_scalar:
- forall chunk ofs b,
- PTree.get id e = Some (b, Vscalar chunk) ->
- val_inject f (Vptr b Int.zero) (Vptr sp (Int.repr ofs)) ->
- match_var f id e m te sp (Var_stack_scalar chunk ofs)
- | match_var_stack_array:
- forall ofs sz al b,
- PTree.get id e = Some (b, Varray sz al) ->
+(** ** Matching between Cshaprminor's temporaries and Cminor's variables *)
+
+Definition match_temps (f: meminj) (le: Csharpminor.temp_env) (te: env) : Prop :=
+ forall id v, le!id = Some v -> exists v', te!(id) = Some v' /\ val_inject f v v'.
+
+Lemma match_temps_invariant:
+ forall f f' le te,
+ match_temps f le te ->
+ inject_incr f f' ->
+ match_temps f' le te.
+Proof.
+ intros; red; intros. destruct (H _ _ H1) as [v' [A B]]. exists v'; eauto.
+Qed.
+
+Lemma match_temps_assign:
+ forall f le te id v tv,
+ match_temps f le te ->
+ val_inject f v tv ->
+ match_temps f (PTree.set id v le) (PTree.set id tv te).
+Proof.
+ intros; red; intros. rewrite PTree.gsspec in *. destruct (peq id0 id).
+ inv H1. exists tv; auto.
+ eauto.
+Qed.
+
+(** ** Matching between C#minor's variable environment and Cminor's stack pointer *)
+
+Inductive match_var (f: meminj) (sp: block): option (block * Z) -> option Z -> Prop :=
+ | match_var_local: forall b sz ofs,
val_inject f (Vptr b Int.zero) (Vptr sp (Int.repr ofs)) ->
- match_var f id e m te sp (Var_stack_array ofs sz al)
- | match_var_global_scalar:
- forall chunk,
- PTree.get id e = None ->
- (forall b gv, Genv.find_symbol ge id = Some b ->
- Genv.find_var_info ge b = Some gv ->
- gvar_info gv = Vscalar chunk) ->
- match_var f id e m te sp (Var_global_scalar chunk)
- | match_var_global_array:
- PTree.get id e = None ->
- match_var f id e m te sp (Var_global_array).
-
-(** Matching between a Csharpminor environment [e] and a Cminor
- environment [te]. The [lo] and [hi] parameters delimit the range
+ match_var f sp (Some(b, sz)) (Some ofs)
+ | match_var_global:
+ match_var f sp None None.
+
+(** Matching between a C#minor environment [e] and a Cminor
+ stack pointer [sp]. The [lo] and [hi] parameters delimit the range
of addresses for the blocks referenced from [te]. *)
Record match_env (f: meminj) (cenv: compilenv)
- (e: Csharpminor.env) (le: Csharpminor.temp_env) (m: mem)
- (te: env) (sp: block)
+ (e: Csharpminor.env) (sp: block)
(lo hi: Z) : Prop :=
mk_match_env {
-(** Each variable mentioned in the compilation environment must match
- as defined above. *)
+(** C#minor local variables match sub-blocks of the Cminor stack data block. *)
me_vars:
- forall id, match_var f id e m te sp (PMap.get id cenv);
-
-(** Temporaries match *)
- me_temps:
- forall id v, le!id = Some v ->
- exists v', te!(for_temp id) = Some v' /\ val_inject f v v';
+ forall id, match_var f sp (e!id) (cenv!id);
(** [lo, hi] is a proper interval. *)
me_low_high:
lo <= hi;
-(** Every block appearing in the Csharpminor environment [e] must be
+(** Every block appearing in the C#minor environment [e] must be
in the range [lo, hi]. *)
me_bounded:
- forall id b lv, PTree.get id e = Some(b, lv) -> lo <= b < hi;
-
-(** Distinct Csharpminor local variables must be mapped to distinct blocks. *)
- me_inj:
- forall id1 b1 lv1 id2 b2 lv2,
- PTree.get id1 e = Some(b1, lv1) ->
- PTree.get id2 e = Some(b2, lv2) ->
- id1 <> id2 -> b1 <> b2;
+ forall id b sz, PTree.get id e = Some(b, sz) -> lo <= b < hi;
(** All blocks mapped to sub-blocks of the Cminor stack data must be
- images of variables from the Csharpminor environment [e] *)
+ images of variables from the C#minor environment [e] *)
me_inv:
forall b delta,
f b = Some(sp, delta) ->
- exists id, exists lv, PTree.get id e = Some(b, lv);
+ exists id, exists sz, PTree.get id e = Some(b, sz);
-(** All Csharpminor blocks below [lo] (i.e. allocated before the blocks
+(** All C#minor blocks below [lo] (i.e. allocated before the blocks
referenced from [e]) must map to blocks that are below [sp]
(i.e. allocated before the stack data for the current Cminor function). *)
me_incr:
forall b tb delta,
- f b = Some(tb, delta) -> b < lo -> tb < sp;
-
-(** The sizes of blocks appearing in [e] agree with their types *)
- me_bounds:
- forall id b lv ofs p,
- PTree.get id e = Some(b, lv) -> Mem.perm m b ofs Max p -> 0 <= ofs < sizeof lv
+ f b = Some(tb, delta) -> b < lo -> tb < sp
}.
-Hint Resolve me_low_high.
-
-(** The remainder of this section is devoted to showing preservation
- of the [match_en] invariant under various assignments and memory
- stores. First: preservation by memory stores to ``mapped'' blocks
- (block that have a counterpart in the Cminor execution). *)
-
Ltac geninv x :=
let H := fresh in (generalize x; intro H; inv H).
-Lemma match_env_store_mapped:
- forall f cenv e le m1 m2 te sp lo hi chunk b ofs v,
- f b <> None ->
- Mem.store chunk m1 b ofs v = Some m2 ->
- match_env f cenv e le m1 te sp lo hi ->
- match_env f cenv e le m2 te sp lo hi.
-Proof.
- intros; inv H1; constructor; auto.
- (* vars *)
- intros. geninv (me_vars0 id); econstructor; eauto.
- rewrite <- H4. eapply Mem.load_store_other; eauto.
- left. congruence.
- (* bounds *)
- intros. eauto with mem.
-Qed.
-
-(** Preservation by assignment to a Csharpminor variable that is
- translated to a Cminor local variable. The value being assigned
- must be normalized with respect to the memory chunk of the variable. *)
-
-Remark val_normalized_has_type:
- forall v chunk,
- val_normalized v chunk -> Val.has_type v (type_of_chunk chunk).
-Proof.
- intros. red in H. rewrite <- H.
- destruct chunk; destruct v; exact I.
-Qed.
-
-Lemma match_env_store_local:
- forall f cenv e le m1 m2 te sp lo hi id b chunk v tv,
- e!id = Some(b, Vscalar chunk) ->
- val_normalized v chunk ->
- val_inject f v tv ->
- Mem.store chunk m1 b 0 v = Some m2 ->
- match_env f cenv e le m1 te sp lo hi ->
- match_env f cenv e le m2 (PTree.set (for_var id) tv te) sp lo hi.
-Proof.
- intros. inv H3. constructor; auto.
- (* vars *)
- intros. geninv (me_vars0 id0).
- (* var_local *)
- case (peq id id0); intro.
- (* the stored variable *)
- subst id0.
- assert (b0 = b) by congruence. subst.
- assert (chunk0 = chunk) by congruence. subst.
- econstructor. eauto.
- eapply Mem.load_store_same; eauto. auto.
- rewrite PTree.gss. reflexivity.
- red in H0. rewrite H0. auto.
- (* a different variable *)
- econstructor; eauto.
- rewrite <- H6. eapply Mem.load_store_other; eauto.
- rewrite PTree.gso; auto. unfold for_var; congruence.
- (* var_stack_scalar *)
- econstructor; eauto.
- (* var_stack_array *)
- econstructor; eauto.
- (* var_global_scalar *)
- econstructor; eauto.
- (* var_global_array *)
- econstructor; eauto.
- (* temps *)
- intros. rewrite PTree.gso. auto. unfold for_temp, for_var; congruence.
- (* bounds *)
- intros. eauto with mem.
-Qed.
-
-(** Preservation by assignment to a Csharpminor temporary and the
- corresponding Cminor local variable. *)
-
-Lemma match_env_set_temp:
- forall f cenv e le m te sp lo hi id v tv,
- val_inject f v tv ->
- match_env f cenv e le m te sp lo hi ->
- match_env f cenv e (PTree.set id v le) m (PTree.set (for_temp id) tv te) sp lo hi.
-Proof.
- intros. inv H0. constructor; auto.
- (* vars *)
- intros. geninv (me_vars0 id0).
- (* var_local *)
- econstructor; eauto. rewrite PTree.gso. auto. unfold for_var, for_temp; congruence.
- (* var_stack_scalar *)
- econstructor; eauto.
- (* var_stack_array *)
- econstructor; eauto.
- (* var_global_scalar *)
- econstructor; eauto.
- (* var_global_array *)
- econstructor; eauto.
- (* temps *)
- intros. rewrite PTree.gsspec in H0. destruct (peq id0 id).
- inv H0. exists tv; split; auto. apply PTree.gss.
- rewrite PTree.gso. eauto. unfold for_temp; congruence.
-Qed.
-
-(** The [match_env] relation is preserved by any memory operation
- that preserves sizes and loads from blocks in the [lo, hi] range. *)
-
Lemma match_env_invariant:
- forall f cenv e le m1 m2 te sp lo hi,
- (forall b ofs chunk v,
- lo <= b < hi -> Mem.load chunk m1 b ofs = Some v ->
- Mem.load chunk m2 b ofs = Some v) ->
- (forall b ofs p,
- lo <= b < hi -> Mem.perm m2 b ofs Max p -> Mem.perm m1 b ofs Max p) ->
- match_env f cenv e le m1 te sp lo hi ->
- match_env f cenv e le m2 te sp lo hi.
-Proof.
- intros. inv H1. constructor; eauto.
- (* vars *)
- intros. geninv (me_vars0 id); econstructor; eauto.
-Qed.
-
-(** [match_env] is insensitive to the Cminor values of stack-allocated data. *)
-
-Lemma match_env_extensional:
- forall f cenv e le m te1 sp lo hi te2,
- match_env f cenv e le m te1 sp lo hi ->
- (forall id chunk, cenv!!id = Var_local chunk -> te2!(for_var id) = te1!(for_var id)) ->
- (forall id v, le!id = Some v -> te2!(for_temp id) = te1!(for_temp id)) ->
- match_env f cenv e le m te2 sp lo hi.
-Proof.
- intros. inv H; econstructor; eauto.
- intros. geninv (me_vars0 id); econstructor; eauto. rewrite <- H6. eauto.
- intros. rewrite (H1 _ _ H). auto.
-Qed.
-
-(** [match_env] and allocations *)
-
-Inductive alloc_condition: var_info -> var_kind -> block -> option (block * Z) -> Prop :=
- | alloc_cond_local: forall chunk sp,
- alloc_condition (Var_local chunk) (Vscalar chunk) sp None
- | alloc_cond_stack_scalar: forall chunk pos sp,
- alloc_condition (Var_stack_scalar chunk pos) (Vscalar chunk) sp (Some(sp, pos))
- | alloc_cond_stack_array: forall pos sz al sp,
- alloc_condition (Var_stack_array pos sz al) (Varray sz al) sp (Some(sp, pos)).
-
-Lemma match_env_alloc_same:
- forall f1 cenv e le m1 te sp lo lv m2 b f2 id info tv,
- match_env f1 cenv e le m1 te sp lo (Mem.nextblock m1) ->
- Mem.alloc m1 0 (sizeof lv) = (m2, b) ->
+ forall f1 cenv e sp lo hi f2,
+ match_env f1 cenv e sp lo hi ->
inject_incr f1 f2 ->
- alloc_condition info lv sp (f2 b) ->
- (forall b', b' <> b -> f2 b' = f1 b') ->
- te!(for_var id) = Some tv ->
- e!id = None ->
- match_env f2 (PMap.set id info cenv) (PTree.set id (b, lv) e) le m2 te sp lo (Mem.nextblock m2).
+ (forall b delta, f2 b = Some(sp, delta) -> f1 b = Some(sp, delta)) ->
+ (forall b, b < lo -> f2 b = f1 b) ->
+ match_env f2 cenv e sp lo hi.
Proof.
- intros until tv.
- intros ME ALLOC INCR ACOND OTHER TE E.
- inv ME; constructor.
+ intros. destruct H. constructor; auto.
(* vars *)
- intros. rewrite PMap.gsspec. destruct (peq id0 id). subst id0.
- (* the new var *)
- inv ACOND; econstructor.
- (* local *)
- rewrite PTree.gss. reflexivity.
- eapply Mem.load_alloc_same'; eauto. omega. simpl; omega. apply Zdivide_0.
- auto. eauto. constructor.
- (* stack scalar *)
- rewrite PTree.gss; reflexivity.
- econstructor; eauto. rewrite Int.add_commut; rewrite Int.add_zero; auto.
- (* stack array *)
- rewrite PTree.gss; reflexivity.
- econstructor; eauto. rewrite Int.add_commut; rewrite Int.add_zero; auto.
- (* the other vars *)
- geninv (me_vars0 id0); econstructor.
- (* local *)
- rewrite PTree.gso; eauto. eapply Mem.load_alloc_other; eauto.
- rewrite OTHER; auto.
- exploit me_bounded0; eauto. exploit Mem.alloc_result; eauto. unfold block; omega.
- eauto. eapply val_inject_incr; eauto.
- (* stack scalar *)
- rewrite PTree.gso; eauto. eapply val_inject_incr; eauto.
- (* stack array *)
- rewrite PTree.gso; eauto. eapply val_inject_incr; eauto.
- (* global scalar *)
- rewrite PTree.gso; auto. auto.
- (* global array *)
- rewrite PTree.gso; auto.
-(* temps *)
- intros. exploit me_temps0; eauto. intros [v' [A B]].
- exists v'; split; auto. eapply val_inject_incr; eauto.
-(* low high *)
- exploit Mem.nextblock_alloc; eauto. unfold block in *; omega.
+ intros. geninv (me_vars0 id); econstructor; eauto.
(* bounded *)
- exploit Mem.alloc_result; eauto. intro RES.
- exploit Mem.nextblock_alloc; eauto. intro NEXT.
- intros until lv0. rewrite PTree.gsspec. destruct (peq id0 id); intro EQ.
- inv EQ. unfold block in *; omega.
- exploit me_bounded0; eauto. unfold block in *; omega.
-(* inj *)
- intros until lv2. repeat rewrite PTree.gsspec.
- exploit Mem.alloc_result; eauto. intro RES.
- destruct (peq id1 id); destruct (peq id2 id); subst; intros A1 A2 DIFF.
- congruence.
- inv A1. exploit me_bounded0; eauto. unfold block; omega.
- inv A2. exploit me_bounded0; eauto. unfold block; omega.
- eauto.
-(* inv *)
- intros. destruct (zeq b0 b).
- subst. exists id; exists lv. apply PTree.gss.
- exploit me_inv0; eauto. rewrite <- OTHER; eauto.
- intros [id' [lv' A]]. exists id'; exists lv'.
- rewrite PTree.gso; auto. congruence.
-(* incr *)
- intros. eapply me_incr0; eauto. rewrite <- OTHER; eauto.
- exploit Mem.alloc_result; eauto. unfold block; omega.
-(* bounds *)
- intros. rewrite PTree.gsspec in H.
- exploit Mem.perm_alloc_inv. eexact ALLOC. eauto.
- destruct (peq id0 id).
- inv H. rewrite zeq_true. auto.
- rewrite zeq_false. eauto.
- apply Mem.valid_not_valid_diff with m1.
- exploit me_bounded0; eauto. intros [A B]. auto.
- eauto with mem.
-Qed.
-
-Lemma match_env_alloc_other:
- forall f1 cenv e le m1 te sp lo hi sz m2 b f2,
- match_env f1 cenv e le m1 te sp lo hi ->
- Mem.alloc m1 0 sz = (m2, b) ->
- inject_incr f1 f2 ->
- (forall b', b' <> b -> f2 b' = f1 b') ->
- hi <= b ->
- match f2 b with None => True | Some(b',ofs) => sp < b' end ->
- match_env f2 cenv e le m2 te sp lo hi.
-Proof.
- intros until f2; intros ME ALLOC INCR OTHER BOUND TBOUND.
- inv ME.
- assert (BELOW: forall id b' lv, e!id = Some(b', lv) -> b' <> b).
- intros. exploit me_bounded0; eauto. exploit Mem.alloc_result; eauto.
- unfold block in *; omega.
- econstructor; eauto.
-(* vars *)
- intros. geninv (me_vars0 id); econstructor.
- (* local *)
- eauto. eapply Mem.load_alloc_other; eauto.
- rewrite OTHER; eauto. eauto. eapply val_inject_incr; eauto.
- (* stack scalar *)
- eauto. eapply val_inject_incr; eauto.
- (* stack array *)
- eauto. eapply val_inject_incr; eauto.
- (* global scalar *)
- auto. auto.
- (* global array *)
- auto.
-(* temps *)
- intros. exploit me_temps0; eauto. intros [v' [A B]].
- exists v'; split; auto. eapply val_inject_incr; eauto.
-(* inv *)
- intros. rewrite OTHER in H. eauto.
- red; intro; subst b0. rewrite H in TBOUND. omegaContradiction.
-(* incr *)
- intros. eapply me_incr0; eauto. rewrite <- OTHER; eauto.
- exploit Mem.alloc_result; eauto. unfold block in *; omega.
-(* bounds *)
- intros. exploit Mem.perm_alloc_inv. eexact ALLOC. eauto.
- rewrite zeq_false. eauto.
- exploit me_bounded0; eauto.
+ intros. eauto.
+(* below *)
+ intros. rewrite H2 in H; eauto.
Qed.
(** [match_env] and external calls *)
@@ -621,48 +282,175 @@ Proof.
Qed.
Lemma match_env_external_call:
- forall f1 cenv e le m1 te sp lo hi m2 f2 m1',
- match_env f1 cenv e le m1 te sp lo hi ->
- mem_unchanged_on (loc_unmapped f1) m1 m2 ->
+ forall f1 cenv e sp lo hi f2 m1 m1',
+ match_env f1 cenv e sp lo hi ->
inject_incr f1 f2 ->
inject_separated f1 f2 m1 m1' ->
- (forall b ofs p, Mem.valid_block m1 b -> Mem.perm m2 b ofs Max p -> Mem.perm m1 b ofs Max p) ->
hi <= Mem.nextblock m1 -> sp < Mem.nextblock m1' ->
- match_env f2 cenv e le m2 te sp lo hi.
+ match_env f2 cenv e sp lo hi.
+Proof.
+ intros. apply match_env_invariant with f1; auto.
+ intros. eapply inject_incr_separated_same'; eauto.
+ intros. eapply inject_incr_separated_same; eauto. red. destruct H. omega.
+Qed.
+
+(** [match_env] and allocations *)
+
+Lemma match_env_alloc:
+ forall f1 id cenv e sp lo m1 sz m2 b ofs f2,
+ match_env f1 (PTree.remove id cenv) e sp lo (Mem.nextblock m1) ->
+ Mem.alloc m1 0 sz = (m2, b) ->
+ cenv!id = Some ofs ->
+ inject_incr f1 f2 ->
+ f2 b = Some(sp, ofs) ->
+ (forall b', b' <> b -> f2 b' = f1 b') ->
+ e!id = None ->
+ match_env f2 cenv (PTree.set id (b, sz) e) sp lo (Mem.nextblock m2).
Proof.
- intros until m1'. intros ME UNCHANGED INCR SEPARATED BOUNDS VALID VALID'.
- destruct UNCHANGED as [UNCHANGED1 UNCHANGED2].
- inversion ME. constructor; auto.
+ intros until f2; intros ME ALLOC CENV INCR SAME OTHER ENV.
+ exploit Mem.nextblock_alloc; eauto. intros NEXTBLOCK.
+ exploit Mem.alloc_result; eauto. intros RES.
+ inv ME; constructor.
(* vars *)
- intros. geninv (me_vars0 id); try (econstructor; eauto; fail).
- (* local *)
- econstructor.
- eauto.
- apply UNCHANGED2; eauto.
- rewrite <- H3. eapply inject_incr_separated_same; eauto.
- red. exploit me_bounded0; eauto. omega.
- eauto. eauto.
-(* temps *)
- intros. exploit me_temps0; eauto. intros [v' [A B]].
- exists v'; split; auto. eapply val_inject_incr; eauto.
+ intros. rewrite PTree.gsspec. destruct (peq id0 id).
+ (* the new var *)
+ subst id0. rewrite CENV. constructor. econstructor. eauto.
+ rewrite Int.add_commut; rewrite Int.add_zero; auto.
+ (* old vars *)
+ generalize (me_vars0 id0). rewrite PTree.gro; auto. intros M; inv M.
+ constructor; eauto.
+ constructor.
+(* low-high *)
+ rewrite NEXTBLOCK; omega.
+(* bounded *)
+ intros. rewrite PTree.gsspec in H. destruct (peq id0 id).
+ inv H. rewrite NEXTBLOCK; omega.
+ exploit me_bounded0; eauto. rewrite NEXTBLOCK; omega.
(* inv *)
- intros. apply me_inv0 with delta. eapply inject_incr_separated_same'; eauto.
+ intros. destruct (zeq b (Mem.nextblock m1)).
+ subst b. rewrite SAME in H; inv H. exists id; exists sz. apply PTree.gss.
+ rewrite OTHER in H; auto. exploit me_inv0; eauto.
+ intros [id1 [sz1 EQ]]. exists id1; exists sz1. rewrite PTree.gso; auto. congruence.
(* incr *)
- intros.
- exploit inject_incr_separated_same; eauto.
- instantiate (1 := b). red; omega. intros.
- apply me_incr0 with b delta. congruence. auto.
-(* bounds *)
- intros. eapply me_bounds0; eauto. eapply BOUNDS; eauto.
- red. exploit me_bounded0; eauto. omega.
+ intros. rewrite OTHER in H. eauto. unfold block in *; omega.
+Qed.
+
+(** The sizes of blocks appearing in [e] are respected. *)
+
+Definition match_bounds (e: Csharpminor.env) (m: mem) : Prop :=
+ forall id b sz ofs p,
+ PTree.get id e = Some(b, sz) -> Mem.perm m b ofs Max p -> 0 <= ofs < sz.
+
+Lemma match_bounds_invariant:
+ forall e m1 m2,
+ match_bounds e m1 ->
+ (forall id b sz ofs p,
+ PTree.get id e = Some(b, sz) -> Mem.perm m2 b ofs Max p -> Mem.perm m1 b ofs Max p) ->
+ match_bounds e m2.
+Proof.
+ intros; red; intros. eapply H; eauto.
+Qed.
+
+(** ** Permissions on the Cminor stack block *)
+
+(** The parts of the Cminor stack data block that are not images of
+ C#minor local variable blocks remain freeable at all times. *)
+
+Inductive is_reachable_from_env (f: meminj) (e: Csharpminor.env) (sp: block) (ofs: Z) : Prop :=
+ | is_reachable_intro: forall id b sz delta,
+ e!id = Some(b, sz) ->
+ f b = Some(sp, delta) ->
+ delta <= ofs < delta + sz ->
+ is_reachable_from_env f e sp ofs.
+
+Definition padding_freeable (f: meminj) (e: Csharpminor.env) (tm: mem) (sp: block) (sz: Z) : Prop :=
+ forall ofs,
+ 0 <= ofs < sz -> Mem.perm tm sp ofs Cur Freeable \/ is_reachable_from_env f e sp ofs.
+
+Lemma padding_freeable_invariant:
+ forall f1 e tm1 sp sz cenv lo hi f2 tm2,
+ padding_freeable f1 e tm1 sp sz ->
+ match_env f1 cenv e sp lo hi ->
+ (forall ofs, Mem.perm tm1 sp ofs Cur Freeable -> Mem.perm tm2 sp ofs Cur Freeable) ->
+ (forall b, b < hi -> f2 b = f1 b) ->
+ padding_freeable f2 e tm2 sp sz.
+Proof.
+ intros; red; intros.
+ exploit H; eauto. intros [A | A].
+ left; auto.
+ right. inv A. exploit me_bounded; eauto. intros [D E].
+ econstructor; eauto. rewrite H2; auto.
+Qed.
+
+(** Decidability of the [is_reachable_from_env] predicate. *)
+
+Lemma is_reachable_from_env_dec:
+ forall f e sp ofs, is_reachable_from_env f e sp ofs \/ ~is_reachable_from_env f e sp ofs.
+Proof.
+ intros.
+ set (pred := fun id_b_sz : ident * (block * Z) =>
+ match id_b_sz with
+ | (id, (b, sz)) =>
+ match f b with
+ | None => false
+ | Some(sp', delta) =>
+ if eq_block sp sp'
+ then zle delta ofs && zlt ofs (delta + sz)
+ else false
+ end
+ end).
+ destruct (List.existsb pred (PTree.elements e)) as []_eqn.
+ (* yes *)
+ rewrite List.existsb_exists in Heqb.
+ destruct Heqb as [[id [b sz]] [A B]].
+ simpl in B. destruct (f b) as [[sp' delta] |]_eqn; try discriminate.
+ destruct (eq_block sp sp'); try discriminate.
+ destruct (andb_prop _ _ B).
+ left. apply is_reachable_intro with id b sz delta.
+ apply PTree.elements_complete; auto.
+ congruence.
+ split; eapply proj_sumbool_true; eauto.
+ (* no *)
+ right; red; intro NE; inv NE.
+ assert (existsb pred (PTree.elements e) = true).
+ rewrite List.existsb_exists. exists (id, (b, sz)); split.
+ apply PTree.elements_correct; auto.
+ simpl. rewrite H0. rewrite dec_eq_true.
+ unfold proj_sumbool. destruct H1. rewrite zle_true; auto. rewrite zlt_true; auto.
+ congruence.
+Qed.
+
+(** * Correspondence between global environments *)
+
+(** Global environments match if the memory injection [f] leaves unchanged
+ the references to global symbols and functions. *)
+
+Inductive match_globalenvs (f: meminj) (bound: Z): Prop :=
+ | mk_match_globalenvs
+ (POS: bound > 0)
+ (DOMAIN: forall b, b < bound -> f b = Some(b, 0))
+ (IMAGE: forall b1 b2 delta, f b1 = Some(b2, delta) -> b2 < bound -> b1 = b2)
+ (SYMBOLS: forall id b, Genv.find_symbol ge id = Some b -> b < bound)
+ (FUNCTIONS: forall b fd, Genv.find_funct_ptr ge b = Some fd -> b < bound)
+ (VARINFOS: forall b gv, Genv.find_var_info ge b = Some gv -> b < bound).
+
+Remark inj_preserves_globals:
+ forall f hi,
+ match_globalenvs f hi ->
+ meminj_preserves_globals ge f.
+Proof.
+ intros. inv H.
+ split. intros. apply DOMAIN. eapply SYMBOLS. eauto.
+ split. intros. apply DOMAIN. eapply VARINFOS. eauto.
+ intros. symmetry. eapply IMAGE; eauto.
Qed.
(** * Invariant on abstract call stacks *)
(** Call stacks represent abstractly the execution state of the current
- Csharpminor and Cminor functions, as well as the states of the
+ C#minor and Cminor functions, as well as the states of the
calling functions. A call stack is a list of frames, each frame
- collecting information on the current execution state of a Csharpminor
+ collecting information on the current execution state of a C#minor
function and its Cminor translation. *)
Inductive frame : Type :=
@@ -676,18 +464,6 @@ Inductive frame : Type :=
Definition callstack : Type := list frame.
-(** Global environments match if the memory injection [f] leaves unchanged
- the references to global symbols and functions. *)
-
-Inductive match_globalenvs (f: meminj) (bound: Z): Prop :=
- | mk_match_globalenvs
- (POS: bound > 0)
- (DOMAIN: forall b, b < bound -> f b = Some(b, 0))
- (IMAGE: forall b1 b2 delta, f b1 = Some(b2, delta) -> b2 < bound -> b1 = b2)
- (SYMBOLS: forall id b, Genv.find_symbol ge id = Some b -> b < bound)
- (FUNCTIONS: forall b fd, Genv.find_funct_ptr ge b = Some fd -> b < bound)
- (VARINFOS: forall b gv, Genv.find_var_info ge b = Some gv -> b < bound).
-
(** Matching of call stacks imply:
- matching of environments for each of the frames
- matching of the global environments
@@ -697,13 +473,6 @@ Inductive match_globalenvs (f: meminj) (bound: Z): Prop :=
that are not images of C#minor local variable blocks.
*)
-Definition padding_freeable (f: meminj) (e: Csharpminor.env) (tm: mem) (sp: block) (sz: Z) : Prop :=
- forall ofs,
- 0 <= ofs < sz ->
- Mem.perm tm sp ofs Cur Freeable
- \/ exists id, exists b, exists lv, exists delta,
- e!id = Some(b, lv) /\ f b = Some(sp, delta) /\ delta <= ofs < delta + sizeof lv.
-
Inductive match_callstack (f: meminj) (m: mem) (tm: mem):
callstack -> Z -> Z -> Prop :=
| mcs_nil:
@@ -715,7 +484,9 @@ Inductive match_callstack (f: meminj) (m: mem) (tm: mem):
forall cenv tf e le te sp lo hi cs bound tbound
(BOUND: hi <= bound)
(TBOUND: sp < tbound)
- (MENV: match_env f cenv e le m te sp lo hi)
+ (MTMP: match_temps f le te)
+ (MENV: match_env f cenv e sp lo hi)
+ (BOUND: match_bounds e m)
(PERM: padding_freeable f e tm sp tf.(fn_stackspace))
(MCS: match_callstack f m tm cs lo sp),
match_callstack f m tm (Frame cenv tf e le te sp lo hi :: cs) bound tbound.
@@ -730,130 +501,39 @@ Proof.
induction 1; eauto.
Qed.
-(** We now show invariance properties for [match_callstack] that
- generalize those for [match_env]. *)
-
-Lemma padding_freeable_invariant:
- forall f1 m1 tm1 sp sz cenv e le te lo hi f2 tm2,
- padding_freeable f1 e tm1 sp sz ->
- match_env f1 cenv e le m1 te sp lo hi ->
- (forall ofs, Mem.perm tm1 sp ofs Cur Freeable -> Mem.perm tm2 sp ofs Cur Freeable) ->
- (forall b, b < hi -> f2 b = f1 b) ->
- padding_freeable f2 e tm2 sp sz.
-Proof.
- intros; red; intros.
- exploit H; eauto. intros [A | [id [b [lv [delta [A [B C]]]]]]].
- left; auto.
- exploit me_bounded; eauto. intros [D E].
- right; exists id; exists b; exists lv; exists delta; split.
- auto.
- rewrite H2; auto.
-Qed.
-
-Lemma match_callstack_store_mapped:
- forall f m tm chunk b b' delta ofs ofs' v tv m' tm',
- f b = Some(b', delta) ->
- Mem.store chunk m b ofs v = Some m' ->
- Mem.store chunk tm b' ofs' tv = Some tm' ->
- forall cs lo hi,
- match_callstack f m tm cs lo hi ->
- match_callstack f m' tm' cs lo hi.
-Proof.
- induction 4.
- econstructor; eauto.
- constructor; auto.
- eapply match_env_store_mapped; eauto. congruence.
- eapply padding_freeable_invariant; eauto.
- intros; eauto with mem.
-Qed.
-
-Lemma match_callstack_storev_mapped:
- forall f m tm chunk a ta v tv m' tm',
- val_inject f a ta ->
- Mem.storev chunk m a v = Some m' ->
- Mem.storev chunk tm ta tv = Some tm' ->
- forall cs lo hi,
- match_callstack f m tm cs lo hi ->
- match_callstack f m' tm' cs lo hi.
-Proof.
- intros. destruct a; simpl in H0; try discriminate.
- inv H. simpl in H1.
- eapply match_callstack_store_mapped; eauto.
-Qed.
+(** Invariance properties for [match_callstack]. *)
Lemma match_callstack_invariant:
- forall f m tm cs bound tbound,
- match_callstack f m tm cs bound tbound ->
- forall m' tm',
- (forall cenv e le te sp lo hi,
- hi <= bound ->
- match_env f cenv e le m te sp lo hi ->
- match_env f cenv e le m' te sp lo hi) ->
- (forall b ofs k p,
- b < tbound -> Mem.perm tm b ofs k p -> Mem.perm tm' b ofs k p) ->
- match_callstack f m' tm' cs bound tbound.
+ forall f1 m1 tm1 f2 m2 tm2 cs bound tbound,
+ match_callstack f1 m1 tm1 cs bound tbound ->
+ inject_incr f1 f2 ->
+ (forall b ofs p, b < bound -> Mem.perm m2 b ofs Max p -> Mem.perm m1 b ofs Max p) ->
+ (forall sp ofs, sp < tbound -> Mem.perm tm1 sp ofs Cur Freeable -> Mem.perm tm2 sp ofs Cur Freeable) ->
+ (forall b, b < bound -> f2 b = f1 b) ->
+ (forall b b' delta, f2 b = Some(b', delta) -> b' < tbound -> f1 b = Some(b', delta)) ->
+ match_callstack f2 m2 tm2 cs bound tbound.
Proof.
induction 1; intros.
+ (* base case *)
econstructor; eauto.
- constructor; auto.
- eapply padding_freeable_invariant; eauto.
+ inv H. constructor; intros; eauto.
+ eapply IMAGE; eauto. eapply H6; eauto. omega.
+ (* inductive case *)
+ assert (lo <= hi) by (eapply me_low_high; eauto).
+ econstructor; eauto.
+ eapply match_temps_invariant; eauto.
+ eapply match_env_invariant; eauto.
+ intros. apply H3. omega.
+ eapply match_bounds_invariant; eauto.
+ intros. eapply H1; eauto.
+ exploit me_bounded; eauto. omega.
+ eapply padding_freeable_invariant; eauto.
+ intros. apply H3. omega.
eapply IHmatch_callstack; eauto.
- intros. eapply H0; eauto. inv MENV; omega.
- intros. apply H1; auto. inv MENV; omega.
-Qed.
-
-Lemma match_callstack_store_local:
- forall f cenv e le te sp lo hi cs bound tbound m1 m2 tm tf id b chunk v tv,
- e!id = Some(b, Vscalar chunk) ->
- val_normalized v chunk ->
- val_inject f v tv ->
- Mem.store chunk m1 b 0 v = Some m2 ->
- match_callstack f m1 tm (Frame cenv tf e le te sp lo hi :: cs) bound tbound ->
- match_callstack f m2 tm (Frame cenv tf e le (PTree.set (for_var id) tv te) sp lo hi :: cs) bound tbound.
-Proof.
- intros. inv H3. constructor; auto.
- eapply match_env_store_local; eauto.
- eapply match_callstack_invariant; eauto.
- intros. apply match_env_invariant with m1; auto.
- intros. rewrite <- H6. eapply Mem.load_store_other; eauto.
- left. inv MENV. exploit me_bounded0; eauto. unfold block in *; omega.
- intros. eauto with mem.
-Qed.
-
-(** A variant of [match_callstack_store_local] where the Cminor environment
- [te] already associates to [id] a value that matches the assigned value.
- In this case, [match_callstack] is preserved even if no assignment
- takes place on the Cminor side. *)
-
-Lemma match_callstack_store_local_unchanged:
- forall f cenv e le te sp lo hi cs bound tbound m1 m2 id b chunk v tv tf tm,
- e!id = Some(b, Vscalar chunk) ->
- val_normalized v chunk ->
- val_inject f v tv ->
- Mem.store chunk m1 b 0 v = Some m2 ->
- te!(for_var id) = Some tv ->
- match_callstack f m1 tm (Frame cenv tf e le te sp lo hi :: cs) bound tbound ->
- match_callstack f m2 tm (Frame cenv tf e le te sp lo hi :: cs) bound tbound.
-Proof.
-Opaque for_var.
- intros. exploit match_callstack_store_local; eauto. intro MCS.
- inv MCS. constructor; auto. eapply match_env_extensional; eauto.
- intros. rewrite PTree.gsspec.
-Transparent for_var.
- case (peq (for_var id0) (for_var id)); intros.
- unfold for_var in e0. congruence.
- auto.
- intros. rewrite PTree.gso; auto. unfold for_temp, for_var; congruence.
-Qed.
-
-Lemma match_callstack_set_temp:
- forall f cenv e le te sp lo hi cs bound tbound m tm tf id v tv,
- val_inject f v tv ->
- match_callstack f m tm (Frame cenv tf e le te sp lo hi :: cs) bound tbound ->
- match_callstack f m tm (Frame cenv tf e (PTree.set id v le) (PTree.set (for_temp id) tv te) sp lo hi :: cs) bound tbound.
-Proof.
- intros. inv H0. constructor; auto.
- eapply match_env_set_temp; eauto.
+ intros. eapply H1; eauto. omega.
+ intros. eapply H2; eauto. omega.
+ intros. eapply H3; eauto. omega.
+ intros. eapply H4; eauto. omega.
Qed.
Lemma match_callstack_incr_bound:
@@ -867,28 +547,40 @@ Proof.
constructor; auto. omega. omega.
Qed.
+(** Assigning a temporary variable. *)
+
+Lemma match_callstack_set_temp:
+ forall f cenv e le te sp lo hi cs bound tbound m tm tf id v tv,
+ val_inject f v tv ->
+ match_callstack f m tm (Frame cenv tf e le te sp lo hi :: cs) bound tbound ->
+ match_callstack f m tm (Frame cenv tf e (PTree.set id v le) (PTree.set id tv te) sp lo hi :: cs) bound tbound.
+Proof.
+ intros. inv H0. constructor; auto.
+ eapply match_temps_assign; eauto.
+Qed.
+
(** Preservation of [match_callstack] by freeing all blocks allocated
- for local variables at function entry (on the Csharpminor side)
+ for local variables at function entry (on the C#minor side)
and simultaneously freeing the Cminor stack data block. *)
Lemma in_blocks_of_env:
- forall e id b lv,
- e!id = Some(b, lv) -> In (b, 0, sizeof lv) (blocks_of_env e).
+ forall e id b sz,
+ e!id = Some(b, sz) -> In (b, 0, sz) (blocks_of_env e).
Proof.
unfold blocks_of_env; intros.
- change (b, 0, sizeof lv) with (block_of_binding (id, (b, lv))).
+ change (b, 0, sz) with (block_of_binding (id, (b, sz))).
apply List.in_map. apply PTree.elements_correct. auto.
Qed.
Lemma in_blocks_of_env_inv:
forall b lo hi e,
In (b, lo, hi) (blocks_of_env e) ->
- exists id, exists lv, e!id = Some(b, lv) /\ lo = 0 /\ hi = sizeof lv.
+ exists id, e!id = Some(b, hi) /\ lo = 0.
Proof.
unfold blocks_of_env; intros.
- exploit list_in_map_inv; eauto. intros [[id [b' lv]] [A B]].
+ exploit list_in_map_inv; eauto. intros [[id [b' sz]] [A B]].
unfold block_of_binding in A. inv A.
- exists id; exists lv; intuition. apply PTree.elements_complete. auto.
+ exists id; intuition. apply PTree.elements_complete. auto.
Qed.
Lemma match_callstack_freelist:
@@ -905,177 +597,26 @@ Proof.
assert ({tm' | Mem.free tm sp 0 (fn_stackspace tf) = Some tm'}).
apply Mem.range_perm_free.
red; intros.
- exploit PERM; eauto. intros [A | [id [b [lv [delta [A [B C]]]]]]].
+ exploit PERM; eauto. intros [A | A].
auto.
- assert (Mem.range_perm m b 0 (sizeof lv) Cur Freeable).
+ inv A. assert (Mem.range_perm m b 0 sz Cur Freeable).
eapply free_list_freeable; eauto. eapply in_blocks_of_env; eauto.
replace ofs with ((ofs - delta) + delta) by omega.
- eapply Mem.perm_inject; eauto. apply H0. omega.
+ eapply Mem.perm_inject; eauto. apply H3. omega.
destruct X as [tm' FREE].
exploit nextblock_freelist; eauto. intro NEXT.
exploit Mem.nextblock_free; eauto. intro NEXT'.
exists tm'. split. auto. split.
rewrite NEXT; rewrite NEXT'.
apply match_callstack_incr_bound with lo sp; try omega.
- apply match_callstack_invariant with m tm; auto.
- intros. apply match_env_invariant with m; auto.
- intros. rewrite <- H2. eapply load_freelist; eauto.
- intros. exploit in_blocks_of_env_inv; eauto.
- intros [id [lv [A [B C]]]].
- exploit me_bounded0; eauto. unfold block; omega.
+ apply match_callstack_invariant with f m tm; auto.
intros. eapply perm_freelist; eauto.
intros. eapply Mem.perm_free_1; eauto. left; unfold block; omega.
eapply Mem.free_inject; eauto.
- intros. exploit me_inv0; eauto. intros [id [lv A]].
- exists 0; exists (sizeof lv); split.
+ intros. exploit me_inv0; eauto. intros [id [sz A]].
+ exists 0; exists sz; split.
eapply in_blocks_of_env; eauto.
- eapply me_bounds0; eauto. eapply Mem.perm_max. eauto.
-Qed.
-
-(** Preservation of [match_callstack] by allocations. *)
-
-Lemma match_callstack_alloc_below:
- forall f1 m1 tm sz m2 b f2,
- Mem.alloc m1 0 sz = (m2, b) ->
- inject_incr f1 f2 ->
- (forall b', b' <> b -> f2 b' = f1 b') ->
- forall cs bound tbound,
- match_callstack f1 m1 tm cs bound tbound ->
- bound <= b ->
- match f2 b with None => True | Some(b',ofs) => tbound <= b' end ->
- match_callstack f2 m2 tm cs bound tbound.
-Proof.
- induction 4; intros.
- apply mcs_nil with hi; auto.
- inv H2. constructor; auto.
- intros. destruct (eq_block b1 b). subst. rewrite H2 in H6. omegaContradiction.
- rewrite H1 in H2; eauto.
- constructor; auto.
- eapply match_env_alloc_other; eauto. omega. destruct (f2 b); auto. destruct p; omega.
- eapply padding_freeable_invariant; eauto.
- intros. apply H1. unfold block; omega.
- apply IHmatch_callstack.
- inv MENV; omega.
- destruct (f2 b); auto. destruct p; omega.
-Qed.
-
-Lemma match_callstack_alloc_left:
- forall f1 m1 tm cenv tf e le te sp lo cs lv m2 b f2 info id tv,
- match_callstack f1 m1 tm
- (Frame cenv tf e le te sp lo (Mem.nextblock m1) :: cs)
- (Mem.nextblock m1) (Mem.nextblock tm) ->
- Mem.alloc m1 0 (sizeof lv) = (m2, b) ->
- inject_incr f1 f2 ->
- alloc_condition info lv sp (f2 b) ->
- (forall b', b' <> b -> f2 b' = f1 b') ->
- te!(for_var id) = Some tv ->
- e!id = None ->
- match_callstack f2 m2 tm
- (Frame (PMap.set id info cenv) tf (PTree.set id (b, lv) e) le te sp lo (Mem.nextblock m2) :: cs)
- (Mem.nextblock m2) (Mem.nextblock tm).
-Proof.
- intros until tv; intros MCS ALLOC INCR ACOND OTHER TE E.
- inv MCS.
- exploit Mem.alloc_result; eauto. intro RESULT.
- exploit Mem.nextblock_alloc; eauto. intro NEXT.
- constructor.
- omega. auto.
- eapply match_env_alloc_same; eauto.
- red; intros. exploit PERM; eauto. intros [A | [id' [b' [lv' [delta' [A [B C]]]]]]].
- left; auto.
- right; exists id'; exists b'; exists lv'; exists delta'.
- split. rewrite PTree.gso; auto. congruence.
- split. apply INCR; auto.
- auto.
- eapply match_callstack_alloc_below; eauto.
- inv MENV. unfold block in *; omega.
- inv ACOND. auto. omega. omega.
-Qed.
-
-Lemma match_callstack_alloc_right:
- forall f le m tm cs tf sp tm' te,
- match_callstack f m tm cs (Mem.nextblock m) (Mem.nextblock tm) ->
- Mem.alloc tm 0 tf.(fn_stackspace) = (tm', sp) ->
- Mem.inject f m tm ->
- (forall id v, le!id = Some v -> exists v', te!(for_temp id) = Some v' /\ val_inject f v v') ->
- match_callstack f m tm'
- (Frame gce tf empty_env le te sp (Mem.nextblock m) (Mem.nextblock m) :: cs)
- (Mem.nextblock m) (Mem.nextblock tm').
-Proof.
- intros.
- exploit Mem.alloc_result; eauto. intro RES.
- exploit Mem.nextblock_alloc; eauto. intro NEXT.
- constructor. omega. unfold block in *; omega.
-(* match env *)
- constructor.
-(* vars *)
- intros. generalize (global_compilenv_charact id); intro.
- destruct (gce!!id); try contradiction.
- constructor. apply PTree.gempty. auto.
- constructor. apply PTree.gempty.
-(* temps *)
- assumption.
-(* low high *)
- omega.
-(* bounded *)
- intros. rewrite PTree.gempty in H3. congruence.
-(* inj *)
- intros. rewrite PTree.gempty in H3. congruence.
-(* inv *)
- intros.
- assert (sp <> sp). apply Mem.valid_not_valid_diff with tm.
- eapply Mem.valid_block_inject_2; eauto. eauto with mem.
- tauto.
-(* incr *)
- intros. rewrite RES. change (Mem.valid_block tm tb).
- eapply Mem.valid_block_inject_2; eauto.
-(* bounds *)
- unfold empty_env; intros. rewrite PTree.gempty in H3. congruence.
-(* padding freeable *)
- red; intros. left. eapply Mem.perm_alloc_2; eauto.
-(* previous call stack *)
- rewrite RES. apply match_callstack_invariant with m tm; auto.
- intros. eapply Mem.perm_alloc_1; eauto.
-Qed.
-
-(** Decidability of the predicate "this is not a padding location" *)
-
-Definition is_reachable (f: meminj) (e: Csharpminor.env) (sp: block) (ofs: Z) : Prop :=
- exists id, exists b, exists lv, exists delta,
- e!id = Some(b, lv) /\ f b = Some(sp, delta) /\ delta <= ofs < delta + sizeof lv.
-
-Lemma is_reachable_dec:
- forall f e sp ofs, is_reachable f e sp ofs \/ ~is_reachable f e sp ofs.
-Proof.
- intros.
- set (pred := fun id_b_lv : ident * (block * var_kind) =>
- match id_b_lv with
- | (id, (b, lv)) =>
- match f b with
- | None => false
- | Some(sp', delta) =>
- if eq_block sp sp'
- then zle delta ofs && zlt ofs (delta + sizeof lv)
- else false
- end
- end).
- destruct (List.existsb pred (PTree.elements e)) as []_eqn.
- rewrite List.existsb_exists in Heqb.
- destruct Heqb as [[id [b lv]] [A B]].
- simpl in B. destruct (f b) as [[sp' delta] |]_eqn; try discriminate.
- destruct (eq_block sp sp'); try discriminate.
- destruct (andb_prop _ _ B).
- left; red. exists id; exists b; exists lv; exists delta.
- split. apply PTree.elements_complete; auto.
- split. congruence.
- split; eapply proj_sumbool_true; eauto.
- right; red. intros [id [b [lv [delta [A [B C]]]]]].
- assert (existsb pred (PTree.elements e) = true).
- rewrite List.existsb_exists. exists (id, (b, lv)); split.
- apply PTree.elements_correct; auto.
- simpl. rewrite B. rewrite dec_eq_true.
- unfold proj_sumbool. destruct C. rewrite zle_true; auto. rewrite zlt_true; auto.
- congruence.
+ eapply BOUND0; eauto. eapply Mem.perm_max. eauto.
Qed.
(** Preservation of [match_callstack] by external calls. *)
@@ -1104,42 +645,613 @@ Proof.
intro EQ. exploit SEPARATED; eauto. intros [A B]. elim B. red. omega.
(* inductive case *)
constructor. auto. auto.
- eapply match_env_external_call; eauto. omega. omega.
+ eapply match_temps_invariant; eauto.
+ eapply match_env_invariant; eauto.
+ red in SEPARATED. intros. destruct (f1 b) as [[b' delta']|]_eqn.
+ exploit INCR; eauto. congruence.
+ exploit SEPARATED; eauto. intros [A B]. elim B. red. omega.
+ intros. assert (lo <= hi) by (eapply me_low_high; eauto).
+ destruct (f1 b) as [[b' delta']|]_eqn.
+ apply INCR; auto.
+ destruct (f2 b) as [[b' delta']|]_eqn; auto.
+ exploit SEPARATED; eauto. intros [A B]. elim A. red. omega.
+ eapply match_bounds_invariant; eauto.
+ intros. eapply MAXPERMS; eauto. red. exploit me_bounded; eauto. omega.
(* padding-freeable *)
red; intros.
- destruct (is_reachable_dec f1 e sp ofs).
- destruct H3 as [id [b [lv [delta [A [B C]]]]]].
- right; exists id; exists b; exists lv; exists delta.
- split. auto. split. apply INCR; auto. auto.
- exploit PERM; eauto. intros [A|A]; try contradiction. left.
- apply OUTOFREACH1; auto. red; intros.
+ destruct (is_reachable_from_env_dec f1 e sp ofs).
+ inv H3. right. apply is_reachable_intro with id b sz delta; auto.
+ exploit PERM; eauto. intros [A|A]; try contradiction.
+ left. apply OUTOFREACH1; auto. red; intros.
red; intros; elim H3.
exploit me_inv; eauto. intros [id [lv B]].
- exploit me_bounds; eauto. intros C.
- red. exists id; exists b0; exists lv; exists delta. intuition omega.
+ exploit BOUND0; eauto. intros C.
+ apply is_reachable_intro with id b0 lv delta; auto; omega.
(* induction *)
eapply IHmatch_callstack; eauto. inv MENV; omega. omega.
Qed.
-Remark external_call_nextblock_incr:
- forall ef vargs m1 t vres m2,
- external_call ef ge vargs m1 t vres m2 ->
- Mem.nextblock m1 <= Mem.nextblock m2.
+(** [match_callstack] and allocations *)
+
+Lemma match_callstack_alloc_right:
+ forall f m tm cs tf tm' sp le te cenv,
+ match_callstack f m tm cs (Mem.nextblock m) (Mem.nextblock tm) ->
+ Mem.alloc tm 0 tf.(fn_stackspace) = (tm', sp) ->
+ Mem.inject f m tm ->
+ match_temps f le te ->
+ (forall id, cenv!id = None) ->
+ match_callstack f m tm'
+ (Frame cenv tf empty_env le te sp (Mem.nextblock m) (Mem.nextblock m) :: cs)
+ (Mem.nextblock m) (Mem.nextblock tm').
+Proof.
+ intros.
+ exploit Mem.nextblock_alloc; eauto. intros NEXTBLOCK.
+ exploit Mem.alloc_result; eauto. intros RES.
+ constructor.
+ omega.
+ unfold block in *; omega.
+ auto.
+ constructor; intros.
+ rewrite H3. rewrite PTree.gempty. constructor.
+ omega.
+ rewrite PTree.gempty in H4; discriminate.
+ eelim Mem.fresh_block_alloc; eauto. eapply Mem.valid_block_inject_2; eauto.
+ rewrite RES. change (Mem.valid_block tm tb). eapply Mem.valid_block_inject_2; eauto.
+ red; intros. rewrite PTree.gempty in H4. discriminate.
+ red; intros. left. eapply Mem.perm_alloc_2; eauto.
+ eapply match_callstack_invariant with (tm1 := tm); eauto.
+ rewrite RES; auto.
+ intros. eapply Mem.perm_alloc_1; eauto.
+Qed.
+
+Lemma match_callstack_alloc_left:
+ forall f1 m1 tm id cenv tf e le te sp lo cs sz m2 b f2 ofs,
+ match_callstack f1 m1 tm
+ (Frame (PTree.remove id cenv) tf e le te sp lo (Mem.nextblock m1) :: cs)
+ (Mem.nextblock m1) (Mem.nextblock tm) ->
+ Mem.alloc m1 0 sz = (m2, b) ->
+ cenv!id = Some ofs ->
+ inject_incr f1 f2 ->
+ f2 b = Some(sp, ofs) ->
+ (forall b', b' <> b -> f2 b' = f1 b') ->
+ e!id = None ->
+ match_callstack f2 m2 tm
+ (Frame cenv tf (PTree.set id (b, sz) e) le te sp lo (Mem.nextblock m2) :: cs)
+ (Mem.nextblock m2) (Mem.nextblock tm).
+Proof.
+ intros. inv H.
+ exploit Mem.nextblock_alloc; eauto. intros NEXTBLOCK.
+ exploit Mem.alloc_result; eauto. intros RES.
+ assert (LO: lo <= Mem.nextblock m1) by (eapply me_low_high; eauto).
+ constructor.
+ omega.
+ auto.
+ eapply match_temps_invariant; eauto.
+ eapply match_env_alloc; eauto.
+ red; intros. rewrite PTree.gsspec in H. destruct (peq id0 id).
+ inversion H. subst b0 sz0 id0. eapply Mem.perm_alloc_3; eauto.
+ eapply BOUND0; eauto. eapply Mem.perm_alloc_4; eauto.
+ exploit me_bounded; eauto. unfold block in *; omega.
+ red; intros. exploit PERM; eauto. intros [A|A]. auto. right.
+ inv A. apply is_reachable_intro with id0 b0 sz0 delta; auto.
+ rewrite PTree.gso. auto. congruence.
+ eapply match_callstack_invariant with (m1 := m1); eauto.
+ intros. eapply Mem.perm_alloc_4; eauto.
+ unfold block in *; omega.
+ intros. apply H4. unfold block in *; omega.
+ intros. destruct (zeq b0 b).
+ subst b0. rewrite H3 in H. inv H. omegaContradiction.
+ rewrite H4 in H; auto.
+Qed.
+
+(** * Correctness of stack allocation of local variables *)
+
+(** This section shows the correctness of the translation of Csharpminor
+ local variables as sub-blocks of the Cminor stack data. This is the most difficult part of the proof. *)
+
+Definition cenv_remove (cenv: compilenv) (vars: list (ident * Z)) : compilenv :=
+ fold_right (fun id_lv ce => PTree.remove (fst id_lv) ce) cenv vars.
+
+Remark cenv_remove_gso:
+ forall id vars cenv,
+ ~In id (map fst vars) ->
+ PTree.get id (cenv_remove cenv vars) = PTree.get id cenv.
+Proof.
+ induction vars; simpl; intros.
+ auto.
+ rewrite PTree.gro. apply IHvars. intuition. intuition.
+Qed.
+
+Remark cenv_remove_gss:
+ forall id vars cenv,
+ In id (map fst vars) ->
+ PTree.get id (cenv_remove cenv vars) = None.
+Proof.
+ induction vars; simpl; intros.
+ contradiction.
+ rewrite PTree.grspec. destruct (PTree.elt_eq id (fst a)). auto.
+ destruct H. intuition. eauto.
+Qed.
+
+Definition cenv_compat (cenv: compilenv) (vars: list (ident * Z)) (tsz: Z) : Prop :=
+ forall id sz,
+ In (id, sz) vars ->
+ exists ofs,
+ PTree.get id cenv = Some ofs
+ /\ Mem.inj_offset_aligned ofs sz
+ /\ 0 <= ofs
+ /\ ofs + Zmax 0 sz <= tsz.
+
+Definition cenv_separated (cenv: compilenv) (vars: list (ident * Z)) : Prop :=
+ forall id1 sz1 ofs1 id2 sz2 ofs2,
+ In (id1, sz1) vars -> In (id2, sz2) vars ->
+ PTree.get id1 cenv = Some ofs1 -> PTree.get id2 cenv = Some ofs2 ->
+ id1 <> id2 ->
+ ofs1 + sz1 <= ofs2 \/ ofs2 + sz2 <= ofs1.
+
+Definition cenv_mem_separated (cenv: compilenv) (vars: list (ident * Z)) (f: meminj) (sp: block) (m: mem) : Prop :=
+ forall id sz ofs b delta ofs' k p,
+ In (id, sz) vars -> PTree.get id cenv = Some ofs ->
+ f b = Some (sp, delta) ->
+ Mem.perm m b ofs' k p ->
+ ofs <= ofs' + delta < sz + ofs -> False.
+
+Lemma match_callstack_alloc_variables_rec:
+ forall tm sp tf cenv le te lo cs,
+ Mem.valid_block tm sp ->
+ fn_stackspace tf <= Int.max_unsigned ->
+ (forall ofs k p, Mem.perm tm sp ofs k p -> 0 <= ofs < fn_stackspace tf) ->
+ (forall ofs k p, 0 <= ofs < fn_stackspace tf -> Mem.perm tm sp ofs k p) ->
+ forall e1 m1 vars e2 m2,
+ alloc_variables e1 m1 vars e2 m2 ->
+ forall f1,
+ list_norepet (map fst vars) ->
+ cenv_compat cenv vars (fn_stackspace tf) ->
+ cenv_separated cenv vars ->
+ cenv_mem_separated cenv vars f1 sp m1 ->
+ (forall id sz, In (id, sz) vars -> e1!id = None) ->
+ match_callstack f1 m1 tm
+ (Frame (cenv_remove cenv vars) tf e1 le te sp lo (Mem.nextblock m1) :: cs)
+ (Mem.nextblock m1) (Mem.nextblock tm) ->
+ Mem.inject f1 m1 tm ->
+ exists f2,
+ match_callstack f2 m2 tm
+ (Frame cenv tf e2 le te sp lo (Mem.nextblock m2) :: cs)
+ (Mem.nextblock m2) (Mem.nextblock tm)
+ /\ Mem.inject f2 m2 tm.
+Proof.
+ intros until cs; intros VALID REPRES STKSIZE STKPERMS.
+ induction 1; intros f1 NOREPET COMPAT SEP1 SEP2 UNBOUND MCS MINJ.
+ (* base case *)
+ simpl in MCS. exists f1; auto.
+ (* inductive case *)
+ simpl in NOREPET. inv NOREPET.
+(* exploit Mem.alloc_result; eauto. intros RES.
+ exploit Mem.nextblock_alloc; eauto. intros NB.*)
+ exploit (COMPAT id sz). auto with coqlib. intros [ofs [CENV [ALIGNED [LOB HIB]]]].
+ exploit Mem.alloc_left_mapped_inject.
+ eexact MINJ.
+ eexact H.
+ eexact VALID.
+ instantiate (1 := ofs). zify. omega.
+ intros. exploit STKSIZE; eauto. omega.
+ intros. apply STKPERMS. zify. omega.
+ replace (sz - 0) with sz by omega. auto.
+ intros. eapply SEP2. eauto with coqlib. eexact CENV. eauto. eauto. omega.
+ intros [f2 [A [B [C D]]]].
+ exploit (IHalloc_variables f2); eauto.
+ red; intros. eapply COMPAT. auto with coqlib.
+ red; intros. eapply SEP1; eauto with coqlib.
+ red; intros. exploit Mem.perm_alloc_inv; eauto. destruct (zeq b b1); intros P.
+ subst b. rewrite C in H5; inv H5.
+ exploit SEP1. eapply in_eq. eapply in_cons; eauto. eauto. eauto.
+ red; intros; subst id0. elim H3. change id with (fst (id, sz0)). apply in_map; auto.
+ omega.
+ eapply SEP2. apply in_cons; eauto. eauto.
+ rewrite D in H5; eauto. eauto. auto.
+ intros. rewrite PTree.gso. eapply UNBOUND; eauto with coqlib.
+ red; intros; subst id0. elim H3. change id with (fst (id, sz0)). apply in_map; auto.
+ eapply match_callstack_alloc_left; eauto.
+ rewrite cenv_remove_gso; auto.
+ apply UNBOUND with sz; auto with coqlib.
+Qed.
+
+Lemma match_callstack_alloc_variables:
+ forall tm1 sp tm2 m1 vars e m2 cenv f1 cs fn le te,
+ Mem.alloc tm1 0 (fn_stackspace fn) = (tm2, sp) ->
+ fn_stackspace fn <= Int.max_unsigned ->
+ alloc_variables empty_env m1 vars e m2 ->
+ list_norepet (map fst vars) ->
+ cenv_compat cenv vars (fn_stackspace fn) ->
+ cenv_separated cenv vars ->
+ (forall id ofs, cenv!id = Some ofs -> In id (map fst vars)) ->
+ Mem.inject f1 m1 tm1 ->
+ match_callstack f1 m1 tm1 cs (Mem.nextblock m1) (Mem.nextblock tm1) ->
+ match_temps f1 le te ->
+ exists f2,
+ match_callstack f2 m2 tm2 (Frame cenv fn e le te sp (Mem.nextblock m1) (Mem.nextblock m2) :: cs)
+ (Mem.nextblock m2) (Mem.nextblock tm2)
+ /\ Mem.inject f2 m2 tm2.
+Proof.
+ intros.
+ eapply match_callstack_alloc_variables_rec; eauto.
+ eapply Mem.valid_new_block; eauto.
+ intros. eapply Mem.perm_alloc_3; eauto.
+ intros. apply Mem.perm_implies with Freeable; auto with mem. eapply Mem.perm_alloc_2; eauto.
+ instantiate (1 := f1). red; intros. eelim Mem.fresh_block_alloc; eauto.
+ eapply Mem.valid_block_inject_2; eauto.
+ intros. apply PTree.gempty.
+ eapply match_callstack_alloc_right; eauto.
+ intros. destruct (In_dec peq id (map fst vars)).
+ apply cenv_remove_gss; auto.
+ rewrite cenv_remove_gso; auto.
+ destruct (cenv!id) as [ofs|]_eqn; auto. elim n; eauto.
+ eapply Mem.alloc_right_inject; eauto.
+Qed.
+
+(** Properties of the compilation environment produced by [build_compilenv] *)
+
+Remark block_alignment_pos:
+ forall sz, block_alignment sz > 0.
+Proof.
+ unfold block_alignment; intros.
+ destruct (zlt sz 2). omega.
+ destruct (zlt sz 4). omega.
+ destruct (zlt sz 8); omega.
+Qed.
+
+Remark assign_variable_incr:
+ forall id sz cenv stksz cenv' stksz',
+ assign_variable (cenv, stksz) (id, sz) = (cenv', stksz') -> stksz <= stksz'.
+Proof.
+ simpl; intros. inv H.
+ generalize (align_le stksz (block_alignment sz) (block_alignment_pos sz)).
+ assert (0 <= Zmax 0 sz). apply Zmax_bound_l. omega.
+ omega.
+Qed.
+
+Remark assign_variables_incr:
+ forall vars cenv sz cenv' sz',
+ assign_variables (cenv, sz) vars = (cenv', sz') -> sz <= sz'.
+Proof.
+ induction vars; intros until sz'.
+ simpl; intros. inv H. omega.
+Opaque assign_variable.
+ destruct a as [id s]. simpl. intros.
+ destruct (assign_variable (cenv, sz) (id, s)) as [cenv1 sz1]_eqn.
+ apply Zle_trans with sz1. eapply assign_variable_incr; eauto. eauto.
+Transparent assign_variable.
+Qed.
+
+Remark inj_offset_aligned_block:
+ forall stacksize sz,
+ Mem.inj_offset_aligned (align stacksize (block_alignment sz)) sz.
+Proof.
+ intros; red; intros.
+ apply Zdivides_trans with (block_alignment sz).
+ unfold align_chunk. unfold block_alignment.
+ generalize Zone_divide; intro.
+ generalize Zdivide_refl; intro.
+ assert (2 | 4). exists 2; auto.
+ assert (2 | 8). exists 4; auto.
+ assert (4 | 8). exists 2; auto.
+ destruct (zlt sz 2).
+ destruct chunk; simpl in *; auto; omegaContradiction.
+ destruct (zlt sz 4).
+ destruct chunk; simpl in *; auto; omegaContradiction.
+ destruct (zlt sz 8).
+ destruct chunk; simpl in *; auto; omegaContradiction.
+ destruct chunk; simpl; auto.
+ apply align_divides. apply block_alignment_pos.
+Qed.
+
+Remark inj_offset_aligned_block':
+ forall stacksize sz,
+ Mem.inj_offset_aligned (align stacksize (block_alignment sz)) (Zmax 0 sz).
Proof.
intros.
- generalize (@external_call_valid_block _ _ _ _ _ _ _ _ _ (Mem.nextblock m1 - 1) H).
- unfold Mem.valid_block. omega.
+ replace (block_alignment sz) with (block_alignment (Zmax 0 sz)).
+ apply inj_offset_aligned_block.
+ rewrite Zmax_spec. destruct (zlt sz 0); auto.
+ transitivity 1. reflexivity. unfold block_alignment. rewrite zlt_true. auto. omega.
+Qed.
+
+Lemma assign_variable_sound:
+ forall cenv1 sz1 id sz cenv2 sz2 vars,
+ assign_variable (cenv1, sz1) (id, sz) = (cenv2, sz2) ->
+ ~In id (map fst vars) ->
+ 0 <= sz1 ->
+ cenv_compat cenv1 vars sz1 ->
+ cenv_separated cenv1 vars ->
+ cenv_compat cenv2 (vars ++ (id, sz) :: nil) sz2
+ /\ cenv_separated cenv2 (vars ++ (id, sz) :: nil).
+Proof.
+ unfold assign_variable; intros until vars; intros ASV NOREPET POS COMPAT SEP.
+ inv ASV.
+ assert (LE: sz1 <= align sz1 (block_alignment sz)). apply align_le. apply block_alignment_pos.
+ assert (EITHER: forall id' sz',
+ In (id', sz') (vars ++ (id, sz) :: nil) ->
+ In (id', sz') vars /\ id' <> id \/ (id', sz') = (id, sz)).
+ intros. rewrite in_app in H. destruct H.
+ left; split; auto. red; intros; subst id'. elim NOREPET.
+ change id with (fst (id, sz')). apply in_map; auto.
+ simpl in H. destruct H. auto. contradiction.
+ split; red; intros.
+ apply EITHER in H. destruct H as [[P Q] | P].
+ exploit COMPAT; eauto. intros [ofs [A [B [C D]]]].
+ exists ofs.
+ split. rewrite PTree.gso; auto.
+ split. auto. split. auto. zify; omega.
+ inv P. exists (align sz1 (block_alignment sz)).
+ split. apply PTree.gss.
+ split. apply inj_offset_aligned_block.
+ split. omega.
+ omega.
+ apply EITHER in H; apply EITHER in H0.
+ destruct H as [[P Q] | P]; destruct H0 as [[R S] | R].
+ rewrite PTree.gso in *; auto. eapply SEP; eauto.
+ inv R. rewrite PTree.gso in H1; auto. rewrite PTree.gss in H2; inv H2.
+ exploit COMPAT; eauto. intros [ofs [A [B [C D]]]].
+ assert (ofs = ofs1) by congruence. subst ofs.
+ left. zify; omega.
+ inv P. rewrite PTree.gso in H2; auto. rewrite PTree.gss in H1; inv H1.
+ exploit COMPAT; eauto. intros [ofs [A [B [C D]]]].
+ assert (ofs = ofs2) by congruence. subst ofs.
+ right. zify; omega.
+ congruence.
Qed.
-Remark inj_preserves_globals:
- forall f hi,
- match_globalenvs f hi ->
- meminj_preserves_globals ge f.
+Lemma assign_variables_sound:
+ forall vars' cenv1 sz1 cenv2 sz2 vars,
+ assign_variables (cenv1, sz1) vars' = (cenv2, sz2) ->
+ list_norepet (map fst vars' ++ map fst vars) ->
+ 0 <= sz1 ->
+ cenv_compat cenv1 vars sz1 ->
+ cenv_separated cenv1 vars ->
+ cenv_compat cenv2 (vars ++ vars') sz2 /\ cenv_separated cenv2 (vars ++ vars').
+Proof.
+ induction vars'; simpl; intros.
+ rewrite app_nil_r. inv H; auto.
+ destruct a as [id sz].
+ simpl in H0. inv H0. rewrite in_app in H6.
+ rewrite list_norepet_app in H7. destruct H7 as [P [Q R]].
+ destruct (assign_variable (cenv1, sz1) (id, sz)) as [cenv' sz']_eqn.
+ exploit assign_variable_sound.
+ eauto.
+ instantiate (1 := vars). tauto.
+ auto. auto. auto.
+ intros [A B].
+ exploit IHvars'.
+ eauto.
+ instantiate (1 := vars ++ ((id, sz) :: nil)).
+ rewrite list_norepet_app. split. auto.
+ split. rewrite map_app. apply list_norepet_append_commut. simpl. constructor; auto.
+ rewrite map_app. simpl. red; intros. rewrite in_app in H4. destruct H4.
+ eauto. simpl in H4. destruct H4. subst y. red; intros; subst x. tauto. tauto.
+ generalize (assign_variable_incr _ _ _ _ _ _ Heqp). omega.
+ auto. auto.
+ rewrite app_ass. auto.
+Qed.
+
+Remark permutation_norepet:
+ forall (A: Type) (l l': list A), Permutation l l' -> list_norepet l -> list_norepet l'.
Proof.
- intros. inv H.
- split. intros. apply DOMAIN. eapply SYMBOLS. eauto.
- split. intros. apply DOMAIN. eapply VARINFOS. eauto.
- intros. symmetry. eapply IMAGE; eauto.
+ induction 1; intros.
+ constructor.
+ inv H0. constructor; auto. red; intros; elim H3. apply Permutation_in with l'; auto. apply Permutation_sym; auto.
+ inv H. simpl in H2. inv H3. constructor. simpl; intuition. constructor. intuition. auto.
+ eauto.
+Qed.
+
+Lemma build_compilenv_sound:
+ forall f cenv sz,
+ build_compilenv f = (cenv, sz) ->
+ list_norepet (map fst (Csharpminor.fn_vars f)) ->
+ cenv_compat cenv (Csharpminor.fn_vars f) sz /\ cenv_separated cenv (Csharpminor.fn_vars f).
+Proof.
+ unfold build_compilenv; intros.
+ set (vars1 := Csharpminor.fn_vars f) in *.
+ generalize (VarSort.Permuted_sort vars1). intros P.
+ set (vars2 := VarSort.sort vars1) in *.
+ assert (cenv_compat cenv vars2 sz /\ cenv_separated cenv vars2).
+ change vars2 with (nil ++ vars2).
+ eapply assign_variables_sound.
+ eexact H.
+ simpl. rewrite app_nil_r. apply permutation_norepet with (map fst vars1); auto.
+ apply Permutation_map. auto.
+ omega.
+ red; intros. contradiction.
+ red; intros. contradiction.
+ destruct H1 as [A B]. split.
+ red; intros. apply A. apply Permutation_in with vars1; auto.
+ red; intros. eapply B; eauto; apply Permutation_in with vars1; auto.
+Qed.
+
+Lemma assign_variables_domain:
+ forall id vars cesz,
+ (fst (assign_variables cesz vars))!id <> None ->
+ (fst cesz)!id <> None \/ In id (map fst vars).
+Proof.
+ induction vars; simpl; intros.
+ auto.
+ exploit IHvars; eauto. unfold assign_variable. destruct a as [id1 sz1].
+ destruct cesz as [cenv stksz]. simpl.
+ rewrite PTree.gsspec. destruct (peq id id1). auto. tauto.
+Qed.
+
+Lemma build_compilenv_domain:
+ forall f cenv sz id ofs,
+ build_compilenv f = (cenv, sz) ->
+ cenv!id = Some ofs -> In id (map fst (Csharpminor.fn_vars f)).
+Proof.
+ unfold build_compilenv; intros.
+ set (vars1 := Csharpminor.fn_vars f) in *.
+ generalize (VarSort.Permuted_sort vars1). intros P.
+ set (vars2 := VarSort.sort vars1) in *.
+ generalize (assign_variables_domain id vars2 (PTree.empty Z, 0)).
+ rewrite H. simpl. intros. destruct H1. congruence.
+ rewrite PTree.gempty in H1. congruence.
+ apply Permutation_in with (map fst vars2); auto.
+ apply Permutation_map. apply Permutation_sym; auto.
+Qed.
+
+(** Initialization of C#minor temporaries and Cminor local variables. *)
+
+Lemma create_undef_temps_val:
+ forall id v temps, (create_undef_temps temps)!id = Some v -> In id temps /\ v = Vundef.
+Proof.
+ induction temps; simpl; intros.
+ rewrite PTree.gempty in H. congruence.
+ rewrite PTree.gsspec in H. destruct (peq id a).
+ split. auto. congruence.
+ exploit IHtemps; eauto. tauto.
+Qed.
+
+Fixpoint set_params' (vl: list val) (il: list ident) (te: Cminor.env) : Cminor.env :=
+ match il, vl with
+ | i1 :: is, v1 :: vs => set_params' vs is (PTree.set i1 v1 te)
+ | i1 :: is, nil => set_params' nil is (PTree.set i1 Vundef te)
+ | _, _ => te
+ end.
+
+Lemma bind_parameters_agree_rec:
+ forall f vars vals tvals le1 le2 te,
+ bind_parameters vars vals le1 = Some le2 ->
+ val_list_inject f vals tvals ->
+ match_temps f le1 te ->
+ match_temps f le2 (set_params' tvals vars te).
+Proof.
+Opaque PTree.set.
+ induction vars; simpl; intros.
+ destruct vals; try discriminate. inv H. auto.
+ destruct vals; try discriminate. inv H0.
+ simpl. eapply IHvars; eauto.
+ red; intros. rewrite PTree.gsspec in *. destruct (peq id a).
+ inv H0. exists v'; auto.
+ apply H1; auto.
+Qed.
+
+Lemma set_params'_outside:
+ forall id il vl te, ~In id il -> (set_params' vl il te)!id = te!id.
+Proof.
+ induction il; simpl; intros. auto.
+ destruct vl; rewrite IHil.
+ apply PTree.gso. intuition. intuition.
+ apply PTree.gso. intuition. intuition.
+Qed.
+
+Lemma set_params'_inside:
+ forall id il vl te1 te2,
+ In id il ->
+ (set_params' vl il te1)!id = (set_params' vl il te2)!id.
+Proof.
+ induction il; simpl; intros.
+ contradiction.
+ destruct vl; destruct (List.in_dec peq id il); auto;
+ repeat rewrite set_params'_outside; auto;
+ assert (a = id) by intuition; subst a; repeat rewrite PTree.gss; auto.
+Qed.
+
+Lemma set_params_set_params':
+ forall il vl id,
+ list_norepet il ->
+ (set_params vl il)!id = (set_params' vl il (PTree.empty val))!id.
+Proof.
+ induction il; simpl; intros.
+ auto.
+ inv H. destruct vl.
+ rewrite PTree.gsspec. destruct (peq id a).
+ subst a. rewrite set_params'_outside; auto. rewrite PTree.gss; auto.
+ rewrite IHil; auto.
+ destruct (List.in_dec peq id il). apply set_params'_inside; auto.
+ repeat rewrite set_params'_outside; auto. rewrite PTree.gso; auto.
+ rewrite PTree.gsspec. destruct (peq id a).
+ subst a. rewrite set_params'_outside; auto. rewrite PTree.gss; auto.
+ rewrite IHil; auto.
+ destruct (List.in_dec peq id il). apply set_params'_inside; auto.
+ repeat rewrite set_params'_outside; auto. rewrite PTree.gso; auto.
+Qed.
+
+Lemma set_locals_outside:
+ forall e id il,
+ ~In id il -> (set_locals il e)!id = e!id.
+Proof.
+ induction il; simpl; intros.
+ auto.
+ rewrite PTree.gso. apply IHil. tauto. intuition.
+Qed.
+
+Lemma set_locals_inside:
+ forall e id il,
+ In id il -> (set_locals il e)!id = Some Vundef.
+Proof.
+ induction il; simpl; intros.
+ contradiction.
+ destruct H. subst a. apply PTree.gss.
+ rewrite PTree.gsspec. destruct (peq id a). auto. auto.
+Qed.
+
+Lemma set_locals_set_params':
+ forall vars vals params id,
+ list_norepet params ->
+ list_disjoint params vars ->
+ (set_locals vars (set_params vals params)) ! id =
+ (set_params' vals params (set_locals vars (PTree.empty val))) ! id.
+Proof.
+ intros. destruct (in_dec peq id vars).
+ assert (~In id params). apply list_disjoint_notin with vars; auto. apply list_disjoint_sym; auto.
+ rewrite set_locals_inside; auto. rewrite set_params'_outside; auto. rewrite set_locals_inside; auto.
+ rewrite set_locals_outside; auto. rewrite set_params_set_params'; auto.
+ destruct (in_dec peq id params).
+ apply set_params'_inside; auto.
+ repeat rewrite set_params'_outside; auto.
+ rewrite set_locals_outside; auto.
+Qed.
+
+Lemma bind_parameters_agree:
+ forall f params temps vals tvals le,
+ bind_parameters params vals (create_undef_temps temps) = Some le ->
+ val_list_inject f vals tvals ->
+ list_norepet params ->
+ list_disjoint params temps ->
+ match_temps f le (set_locals temps (set_params tvals params)).
+Proof.
+ intros; red; intros.
+ exploit bind_parameters_agree_rec; eauto.
+ instantiate (1 := set_locals temps (PTree.empty val)).
+ red; intros. exploit create_undef_temps_val; eauto. intros [A B]. subst v0.
+ exists Vundef; split. apply set_locals_inside; auto. auto.
+ intros [v' [A B]]. exists v'; split; auto.
+ rewrite <- A. apply set_locals_set_params'; auto.
+Qed.
+
+(** The main result in this section. *)
+
+Theorem match_callstack_function_entry:
+ forall fn cenv tf m e m' tm tm' sp f cs args targs le,
+ build_compilenv fn = (cenv, tf.(fn_stackspace)) ->
+ tf.(fn_stackspace) <= Int.max_unsigned ->
+ list_norepet (map fst (Csharpminor.fn_vars fn)) ->
+ list_norepet (Csharpminor.fn_params fn) ->
+ list_disjoint (Csharpminor.fn_params fn) (Csharpminor.fn_temps fn) ->
+ alloc_variables Csharpminor.empty_env m (Csharpminor.fn_vars fn) e m' ->
+ bind_parameters (Csharpminor.fn_params fn) args (create_undef_temps fn.(fn_temps)) = Some le ->
+ val_list_inject f args targs ->
+ Mem.alloc tm 0 tf.(fn_stackspace) = (tm', sp) ->
+ match_callstack f m tm cs (Mem.nextblock m) (Mem.nextblock tm) ->
+ Mem.inject f m tm ->
+ let te := set_locals (Csharpminor.fn_temps fn) (set_params targs (Csharpminor.fn_params fn)) in
+ exists f',
+ match_callstack f' m' tm'
+ (Frame cenv tf e le te sp (Mem.nextblock m) (Mem.nextblock m') :: cs)
+ (Mem.nextblock m') (Mem.nextblock tm')
+ /\ Mem.inject f' m' tm'.
+Proof.
+ intros.
+ exploit build_compilenv_sound; eauto. intros [C1 C2].
+ eapply match_callstack_alloc_variables; eauto.
+ intros. eapply build_compilenv_domain; eauto.
+ eapply bind_parameters_agree; eauto.
Qed.
(** * Properties of compile-time approximations of values *)
@@ -1840,801 +1952,29 @@ Proof.
inv D. auto. inv B. auto.
Qed.
-(** Correctness of the variable accessors [var_get], [var_addr],
- and [var_set]. *)
-
-Lemma var_get_correct:
- forall cenv id a app f tf e le te sp lo hi m cs tm b chunk v,
- var_get cenv id = OK (a, app) ->
- match_callstack f m tm (Frame cenv tf e le te sp lo hi :: cs) (Mem.nextblock m) (Mem.nextblock tm) ->
- Mem.inject f m tm ->
- eval_var_ref ge e id b chunk ->
- Mem.load chunk m b 0 = Some v ->
- exists tv,
- eval_expr tge (Vptr sp Int.zero) te tm a tv
- /\ val_inject f v tv
- /\ val_match_approx app v.
-Proof.
- unfold var_get; intros.
- assert (match_var f id e m te sp cenv!!id). inv H0. inv MENV. auto.
- inv H4; rewrite <- H5 in H; inv H; inv H2; try congruence.
- (* var_local *)
- rewrite H in H6; inv H6.
- exists v'; split.
- apply eval_Evar. auto.
- split. congruence. eapply approx_of_chunk_sound; eauto.
- (* var_stack_scalar *)
- assert (b0 = b). congruence. subst b0.
- assert (chunk0 = chunk). congruence. subst chunk0.
- exploit Mem.loadv_inject; eauto.
- unfold Mem.loadv. eexact H3.
- intros [tv [LOAD INJ]].
- exists tv; split.
- eapply eval_Eload; eauto. eapply make_stackaddr_correct; eauto.
- split. auto. eapply approx_of_chunk_sound; eauto.
- (* var_global_scalar *)
- simpl in *.
- exploit match_callstack_match_globalenvs; eauto. intros [bnd MG]. inv MG.
- assert (chunk0 = chunk). exploit H7; eauto. congruence. subst chunk0.
- assert (val_inject f (Vptr b Int.zero) (Vptr b Int.zero)).
- econstructor; eauto.
- exploit Mem.loadv_inject; eauto. simpl. eauto.
- intros [tv [LOAD INJ]].
- exists tv; split.
- eapply eval_Eload; eauto. eapply make_globaladdr_correct; eauto.
- rewrite symbols_preserved; auto.
- split. auto. eapply approx_of_chunk_sound; eauto.
-Qed.
+(** Correctness of the variable accessor [var_addr] *)
Lemma var_addr_correct:
- forall cenv id a app f tf e le te sp lo hi m cs tm b,
+ forall cenv id f tf e le te sp lo hi m cs tm b,
match_callstack f m tm (Frame cenv tf e le te sp lo hi :: cs) (Mem.nextblock m) (Mem.nextblock tm) ->
- var_addr cenv id = OK (a, app) ->
eval_var_addr ge e id b ->
exists tv,
- eval_expr tge (Vptr sp Int.zero) te tm a tv
- /\ val_inject f (Vptr b Int.zero) tv
- /\ val_match_approx app (Vptr b Int.zero).
+ eval_expr tge (Vptr sp Int.zero) te tm (var_addr cenv id) tv
+ /\ val_inject f (Vptr b Int.zero) tv.
Proof.
unfold var_addr; intros.
- assert (match_var f id e m te sp cenv!!id).
- inv H. inv MENV. auto.
- inv H2; rewrite <- H3 in H0; inv H0; inv H1; try congruence.
- (* var_stack_scalar *)
+ assert (match_var f sp e!id cenv!id).
+ inv H. inv MENV. auto.
+ inv H1; inv H0; try congruence.
+ (* local *)
exists (Vptr sp (Int.repr ofs)); split.
eapply make_stackaddr_correct.
- split. congruence. exact I.
- (* var_stack_array *)
- exists (Vptr sp (Int.repr ofs)); split.
- eapply make_stackaddr_correct. split. congruence. exact I.
- (* var_global_scalar *)
- exploit match_callstack_match_globalenvs; eauto. intros [bnd MG]. inv MG.
- exists (Vptr b Int.zero); split.
- eapply make_globaladdr_correct; eauto. rewrite symbols_preserved; auto.
- split. econstructor; eauto. exact I.
- (* var_global_array *)
+ congruence.
+ (* global *)
exploit match_callstack_match_globalenvs; eauto. intros [bnd MG]. inv MG.
exists (Vptr b Int.zero); split.
eapply make_globaladdr_correct; eauto. rewrite symbols_preserved; auto.
- split. econstructor; eauto. exact I.
-Qed.
-
-Lemma var_set_correct:
- forall cenv id rhs a f tf e le te sp lo hi m cs tm tv v m' fn k,
- var_set cenv id rhs = OK a ->
- match_callstack f m tm (Frame cenv tf e le te sp lo hi :: cs) (Mem.nextblock m) (Mem.nextblock tm) ->
- eval_expr tge (Vptr sp Int.zero) te tm rhs tv ->
- val_inject f v tv ->
- Mem.inject f m tm ->
- exec_assign ge e m id v m' ->
- exists te', exists tm',
- step tge (State fn a k (Vptr sp Int.zero) te tm)
- E0 (State fn Sskip k (Vptr sp Int.zero) te' tm') /\
- Mem.inject f m' tm' /\
- match_callstack f m' tm' (Frame cenv tf e le te' sp lo hi :: cs) (Mem.nextblock m') (Mem.nextblock tm') /\
- (forall id', id' <> for_var id -> te'!id' = te!id').
-Proof.
- intros until k.
- intros VS MCS EVAL VINJ MINJ ASG.
- unfold var_set in VS. inv ASG.
- assert (NEXTBLOCK: Mem.nextblock m' = Mem.nextblock m).
- eapply Mem.nextblock_store; eauto.
- assert (MV: match_var f id e m te sp cenv!!id).
- inv MCS. inv MENV. auto.
- revert VS; inv MV; intro VS; inv VS; inv H; try congruence.
- (* var_local *)
- assert (b0 = b) by congruence. subst b0.
- assert (chunk0 = chunk) by congruence. subst chunk0.
- exists (PTree.set (for_var id) tv te); exists tm.
- split. eapply step_assign. eauto.
- split. eapply Mem.store_unmapped_inject; eauto.
- split. rewrite NEXTBLOCK. eapply match_callstack_store_local; eauto.
- intros. apply PTree.gso; auto.
- (* var_stack_scalar *)
- assert (b0 = b) by congruence. subst b0.
- assert (chunk0 = chunk) by congruence. subst chunk0.
- assert (Mem.storev chunk m (Vptr b Int.zero) v = Some m'). assumption.
- exploit make_store_correct.
- eapply make_stackaddr_correct.
- eauto. eauto. eauto. eauto. eauto.
- intros [tm' [tvrhs' [EVAL' [STORE' MEMINJ]]]].
- exists te; exists tm'.
- split. eauto. split. auto.
- split. rewrite NEXTBLOCK. rewrite (nextblock_storev _ _ _ _ _ STORE').
- eapply match_callstack_storev_mapped; eauto.
- auto.
- (* var_global_scalar *)
- simpl in *.
- assert (chunk0 = chunk). exploit H4; eauto. congruence. subst chunk0.
- assert (Mem.storev chunk m (Vptr b Int.zero) v = Some m'). assumption.
- exploit match_callstack_match_globalenvs; eauto. intros [bnd MG]. inv MG.
- exploit make_store_correct.
- eapply make_globaladdr_correct; eauto.
- rewrite symbols_preserved; eauto. eauto. eauto. eauto. eauto. auto.
- intros [tm' [tvrhs' [EVAL' [STORE' TNEXTBLOCK]]]].
- exists te; exists tm'.
- split. eauto. split. auto.
- split. rewrite NEXTBLOCK. rewrite (nextblock_storev _ _ _ _ _ STORE').
- eapply match_callstack_store_mapped; eauto.
- auto.
-Qed.
-
-Lemma match_callstack_extensional:
- forall f cenv tf e le te1 te2 sp lo hi cs bound tbound m tm,
- (forall id chunk, cenv!!id = Var_local chunk -> te2!(for_var id) = te1!(for_var id)) ->
- (forall id v, le!id = Some v -> te2!(for_temp id) = te1!(for_temp id)) ->
- match_callstack f m tm (Frame cenv tf e le te1 sp lo hi :: cs) bound tbound ->
- match_callstack f m tm (Frame cenv tf e le te2 sp lo hi :: cs) bound tbound.
-Proof.
- intros. inv H1. constructor; auto.
- apply match_env_extensional with te1; auto.
-Qed.
-
-Lemma var_set_self_correct_scalar:
- forall cenv id s a f tf e le te sp lo hi m cs tm tv v m' fn k,
- var_set_self cenv id s = OK a ->
- match_callstack f m tm (Frame cenv tf e le te sp lo hi :: cs) (Mem.nextblock m) (Mem.nextblock tm) ->
- val_inject f v tv ->
- Mem.inject f m tm ->
- exec_assign ge e m id v m' ->
- te!(for_var id) = Some tv ->
- exists tm',
- star step tge (State fn a k (Vptr sp Int.zero) te tm)
- E0 (State fn s k (Vptr sp Int.zero) te tm') /\
- Mem.inject f m' tm' /\
- match_callstack f m' tm' (Frame cenv tf e le te sp lo hi :: cs) (Mem.nextblock m') (Mem.nextblock tm').
-Proof.
- intros until k.
- intros VS MCS VINJ MINJ ASG VAL.
- unfold var_set_self in VS. inv ASG.
- assert (NEXTBLOCK: Mem.nextblock m' = Mem.nextblock m).
- eapply Mem.nextblock_store; eauto.
- assert (MV: match_var f id e m te sp cenv!!id).
- inv MCS. inv MENV. auto.
- assert (EVAR: eval_expr tge (Vptr sp Int.zero) te tm (Evar (for_var id)) tv).
- constructor. auto.
- revert VS; inv MV; intro VS; inv VS; inv H; try congruence.
- (* var_local *)
- assert (b0 = b) by congruence. subst b0.
- assert (chunk0 = chunk) by congruence. subst chunk0.
- exists tm.
- split. apply star_refl.
- split. eapply Mem.store_unmapped_inject; eauto.
- rewrite NEXTBLOCK.
- apply match_callstack_extensional with (PTree.set (for_var id) tv te).
- intros. repeat rewrite PTree.gsspec.
- destruct (peq (for_var id0) (for_var id)). congruence. auto.
- intros. rewrite PTree.gso; auto. unfold for_temp, for_var; congruence.
- eapply match_callstack_store_local; eauto.
- (* var_stack_scalar *)
- assert (b0 = b) by congruence. subst b0.
- assert (chunk0 = chunk) by congruence. subst chunk0.
- assert (Mem.storev chunk m (Vptr b Int.zero) v = Some m'). assumption.
- exploit make_store_correct.
- eapply make_stackaddr_correct.
- eauto. eauto. eauto. eauto. eauto.
- intros [tm' [tvrhs' [EVAL' [STORE' MEMINJ]]]].
- exists tm'.
- split. eapply star_three. constructor. eauto. constructor. traceEq.
- split. auto.
- rewrite NEXTBLOCK. rewrite (nextblock_storev _ _ _ _ _ STORE').
- eapply match_callstack_storev_mapped; eauto.
-Qed.
-
-Lemma var_set_self_correct_array:
- forall cenv id s a f tf e le te sp lo hi m cs tm tv b v sz al m' fn k,
- var_set_self cenv id s = OK a ->
- match_callstack f m tm (Frame cenv tf e le te sp lo hi :: cs) (Mem.nextblock m) (Mem.nextblock tm) ->
- val_inject f v tv ->
- Mem.inject f m tm ->
- PTree.get id e = Some(b, Varray sz al) ->
- extcall_memcpy_sem sz al ge (Vptr b Int.zero :: v :: nil) m E0 Vundef m' ->
- te!(for_var id) = Some tv ->
- exists f', exists tm',
- star step tge (State fn a k (Vptr sp Int.zero) te tm)
- E0 (State fn s k (Vptr sp Int.zero) te tm') /\
- Mem.inject f' m' tm' /\
- match_callstack f' m' tm' (Frame cenv tf e le te sp lo hi :: cs) (Mem.nextblock m') (Mem.nextblock tm') /\
- inject_incr f f'.
-Proof.
- intros until k.
- intros VS MCS VINJ MINJ KIND MEMCPY VAL.
- assert (MV: match_var f id e m te sp cenv!!id).
- inv MCS. inv MENV. auto.
- inv MV; try congruence. rewrite KIND in H0; inv H0.
- (* var_stack_array *)
- unfold var_set_self in VS. rewrite <- H in VS. inv VS.
- exploit match_callstack_match_globalenvs; eauto. intros [hi' MG].
- assert (external_call (EF_memcpy sz0 al0) ge (Vptr b0 Int.zero :: v :: nil) m E0 Vundef m').
- assumption.
- exploit external_call_mem_inject; eauto.
- eapply inj_preserves_globals; eauto.
- intros [f' [vres' [tm' [EC' [VINJ' [MINJ' [UNMAPPED [OUTOFREACH [INCR SEPARATED]]]]]]]]].
- exists f'; exists tm'.
- split. eapply star_step. constructor.
- eapply star_step. econstructor; eauto.
- constructor. apply make_stackaddr_correct. constructor. constructor. eauto. constructor.
- eapply external_call_symbols_preserved_2; eauto.
- exact symbols_preserved.
- eexact var_info_translated.
- eexact var_info_rev_translated.
- apply star_one. constructor. reflexivity. traceEq.
- split. auto.
- split. apply match_callstack_incr_bound with (Mem.nextblock m) (Mem.nextblock tm).
- eapply match_callstack_external_call; eauto.
- intros. eapply external_call_max_perm; eauto.
- omega. omega.
- eapply external_call_nextblock_incr; eauto.
- eapply external_call_nextblock_incr; eauto.
- auto.
-Qed.
-
-(** * Correctness of stack allocation of local variables *)
-
-(** This section shows the correctness of the translation of Csharpminor
- local variables, either as Cminor local variables or as sub-blocks
- of the Cminor stack data. This is the most difficult part of the proof. *)
-
-Remark array_alignment_pos:
- forall sz, array_alignment sz > 0.
-Proof.
- unfold array_alignment; intros.
- destruct (zlt sz 2). omega.
- destruct (zlt sz 4). omega.
- destruct (zlt sz 8); omega.
-Qed.
-
-Remark assign_variable_incr:
- forall atk id lv cenv sz cenv' sz',
- assign_variable atk (id, lv) (cenv, sz) = (cenv', sz') -> sz <= sz'.
-Proof.
- intros until sz'; simpl.
- destruct lv. case (Identset.mem id atk); intros.
- inv H. generalize (size_chunk_pos chunk). intro.
- generalize (align_le sz (size_chunk chunk) H). omega.
- inv H. omega.
- intros. inv H.
- generalize (align_le sz (array_alignment sz0) (array_alignment_pos sz0)).
- assert (0 <= Zmax 0 sz0). apply Zmax_bound_l. omega.
- omega.
-Qed.
-
-Remark assign_variables_incr:
- forall atk vars cenv sz cenv' sz',
- assign_variables atk vars (cenv, sz) = (cenv', sz') -> sz <= sz'.
-Proof.
- induction vars; intros until sz'.
- simpl; intros. replace sz' with sz. omega. congruence.
-Opaque assign_variable.
- destruct a as [id lv]. simpl.
- case_eq (assign_variable atk (id, lv) (cenv, sz)). intros cenv1 sz1 EQ1 EQ2.
- apply Zle_trans with sz1. eapply assign_variable_incr; eauto. eauto.
-Transparent assign_variable.
-Qed.
-
-Remark inj_offset_aligned_array:
- forall stacksize sz,
- Mem.inj_offset_aligned (align stacksize (array_alignment sz)) sz.
-Proof.
- intros; red; intros.
- apply Zdivides_trans with (array_alignment sz).
- unfold align_chunk. unfold array_alignment.
- generalize Zone_divide; intro.
- generalize Zdivide_refl; intro.
- assert (2 | 4). exists 2; auto.
- assert (2 | 8). exists 4; auto.
- assert (4 | 8). exists 2; auto.
- destruct (zlt sz 2).
- destruct chunk; simpl in *; auto; omegaContradiction.
- destruct (zlt sz 4).
- destruct chunk; simpl in *; auto; omegaContradiction.
- destruct (zlt sz 8).
- destruct chunk; simpl in *; auto; omegaContradiction.
- destruct chunk; simpl; auto.
- apply align_divides. apply array_alignment_pos.
-Qed.
-
-Remark inj_offset_aligned_array':
- forall stacksize sz,
- Mem.inj_offset_aligned (align stacksize (array_alignment sz)) (Zmax 0 sz).
-Proof.
- intros.
- replace (array_alignment sz) with (array_alignment (Zmax 0 sz)).
- apply inj_offset_aligned_array.
- rewrite Zmax_spec. destruct (zlt sz 0); auto.
- transitivity 1. reflexivity. unfold array_alignment. rewrite zlt_true. auto. omega.
-Qed.
-
-Remark inj_offset_aligned_var:
- forall stacksize chunk,
- Mem.inj_offset_aligned (align stacksize (size_chunk chunk)) (size_chunk chunk).
-Proof.
- intros.
- replace (align stacksize (size_chunk chunk))
- with (align stacksize (array_alignment (size_chunk chunk))).
- apply inj_offset_aligned_array.
- decEq. destruct chunk; reflexivity.
-Qed.
-
-Lemma match_callstack_alloc_variable:
- forall atk id lv cenv sz cenv' sz' tm sp e tf m m' b te le lo cs f tv,
- assign_variable atk (id, lv) (cenv, sz) = (cenv', sz') ->
- Mem.valid_block tm sp ->
- (forall ofs k p,
- Mem.perm tm sp ofs k p -> 0 <= ofs < tf.(fn_stackspace)) ->
- Mem.range_perm tm sp 0 tf.(fn_stackspace) Cur Freeable ->
- tf.(fn_stackspace) <= Int.max_unsigned ->
- Mem.alloc m 0 (sizeof lv) = (m', b) ->
- match_callstack f m tm
- (Frame cenv tf e le te sp lo (Mem.nextblock m) :: cs)
- (Mem.nextblock m) (Mem.nextblock tm) ->
- Mem.inject f m tm ->
- 0 <= sz -> sz' <= tf.(fn_stackspace) ->
- (forall b delta ofs k p,
- f b = Some(sp, delta) -> Mem.perm m b ofs k p -> ofs + delta < sz) ->
- e!id = None ->
- te!(for_var id) = Some tv ->
- exists f',
- inject_incr f f'
- /\ Mem.inject f' m' tm
- /\ match_callstack f' m' tm
- (Frame cenv' tf (PTree.set id (b, lv) e) le te sp lo (Mem.nextblock m') :: cs)
- (Mem.nextblock m') (Mem.nextblock tm)
- /\ (forall b delta ofs k p,
- f' b = Some(sp, delta) -> Mem.perm m' b ofs k p -> ofs + delta < sz').
-Proof.
- intros until tv. intros ASV VALID BOUNDS PERMS NOOV ALLOC MCS INJ LO HI RANGE E TE.
- generalize ASV. unfold assign_variable.
- caseEq lv.
- (* 1. lv = LVscalar chunk *)
- intros chunk LV. case (Identset.mem id atk).
- (* 1.1 info = Var_stack_scalar chunk ofs *)
- set (ofs := align sz (size_chunk chunk)).
- intro EQ; injection EQ; intros; clear EQ. rewrite <- H0.
- generalize (size_chunk_pos chunk); intro SIZEPOS.
- generalize (align_le sz (size_chunk chunk) SIZEPOS). fold ofs. intro SZOFS.
- exploit Mem.alloc_left_mapped_inject.
- eauto. eauto. eauto.
- instantiate (1 := ofs). omega.
- intros. exploit BOUNDS; eauto. omega.
- intros. apply Mem.perm_implies with Freeable; auto with mem. apply Mem.perm_cur.
- apply PERMS. rewrite LV in H1. simpl in H1. omega.
- rewrite LV; simpl. rewrite Zminus_0_r. unfold ofs.
- apply inj_offset_aligned_var.
- intros. generalize (RANGE _ _ _ _ _ H1 H2). omega.
- intros [f1 [MINJ1 [INCR1 [SAME OTHER]]]].
- exists f1; split. auto. split. auto. split.
- eapply match_callstack_alloc_left; eauto.
- rewrite <- LV; auto.
- rewrite SAME; constructor.
- intros. exploit Mem.perm_alloc_inv; eauto. destruct (zeq b0 b).
- subst b0. assert (delta = ofs) by congruence. subst delta.
- rewrite LV. simpl. omega.
- intro. rewrite OTHER in H1; eauto. generalize (RANGE _ _ _ _ _ H1 H3). omega.
- (* 1.2 info = Var_local chunk *)
- intro EQ; injection EQ; intros; clear EQ. subst sz'. rewrite <- H0.
- exploit Mem.alloc_left_unmapped_inject; eauto.
- intros [f1 [MINJ1 [INCR1 [SAME OTHER]]]].
- exists f1; split. auto. split. auto. split.
- eapply match_callstack_alloc_left; eauto.
- rewrite <- LV; auto.
- rewrite SAME; constructor.
- intros. exploit Mem.perm_alloc_inv; eauto. destruct (zeq b0 b).
- subst b0. congruence.
- rewrite OTHER in H; eauto.
- (* 2 info = Var_stack_array ofs *)
- intros dim al LV EQ. injection EQ; clear EQ; intros. rewrite <- H.
- assert (0 <= Zmax 0 dim). apply Zmax1.
- generalize (align_le sz (array_alignment dim) (array_alignment_pos dim)). intro.
- set (ofs := align sz (array_alignment dim)) in *.
- exploit Mem.alloc_left_mapped_inject. eauto. eauto. eauto.
- instantiate (1 := ofs).
- generalize Int.min_signed_neg. omega.
- intros. exploit BOUNDS; eauto. generalize Int.min_signed_neg. omega.
- intros. apply Mem.perm_implies with Freeable; auto with mem. apply Mem.perm_cur.
- apply PERMS. rewrite LV in H3. simpl in H3. omega.
- rewrite LV; simpl. rewrite Zminus_0_r. unfold ofs.
- apply inj_offset_aligned_array'.
- intros. generalize (RANGE _ _ _ _ _ H3 H4). omega.
- intros [f1 [MINJ1 [INCR1 [SAME OTHER]]]].
- exists f1; split. auto. split. auto. split.
- subst cenv'. eapply match_callstack_alloc_left; eauto.
- rewrite <- LV; auto.
- rewrite SAME; constructor.
- intros. exploit Mem.perm_alloc_inv; eauto. destruct (zeq b0 b).
- subst b0. assert (delta = ofs) by congruence. subst delta.
- rewrite LV. simpl. omega.
- intro. rewrite OTHER in H3; eauto. generalize (RANGE _ _ _ _ _ H3 H5). omega.
-Qed.
-
-Lemma match_callstack_alloc_variables_rec:
- forall tm sp cenv' tf le te lo cs atk,
- Mem.valid_block tm sp ->
- (forall ofs k p,
- Mem.perm tm sp ofs k p -> 0 <= ofs < tf.(fn_stackspace)) ->
- Mem.range_perm tm sp 0 tf.(fn_stackspace) Cur Freeable ->
- tf.(fn_stackspace) <= Int.max_unsigned ->
- forall e m vars e' m',
- alloc_variables e m vars e' m' ->
- forall f cenv sz,
- assign_variables atk vars (cenv, sz) = (cenv', tf.(fn_stackspace)) ->
- match_callstack f m tm
- (Frame cenv tf e le te sp lo (Mem.nextblock m) :: cs)
- (Mem.nextblock m) (Mem.nextblock tm) ->
- Mem.inject f m tm ->
- 0 <= sz ->
- (forall b delta ofs k p,
- f b = Some(sp, delta) -> Mem.perm m b ofs k p -> ofs + delta < sz) ->
- (forall id lv, In (id, lv) vars -> te!(for_var id) <> None) ->
- list_norepet (List.map (@fst ident var_kind) vars) ->
- (forall id lv, In (id, lv) vars -> e!id = None) ->
- exists f',
- inject_incr f f'
- /\ Mem.inject f' m' tm
- /\ match_callstack f' m' tm
- (Frame cenv' tf e' le te sp lo (Mem.nextblock m') :: cs)
- (Mem.nextblock m') (Mem.nextblock tm).
-Proof.
- intros until atk. intros VALID BOUNDS PERM NOOV.
- induction 1.
- (* base case *)
- intros. simpl in H. inversion H; subst cenv sz.
- exists f. split. apply inject_incr_refl. split. auto. auto.
- (* inductive case *)
- intros until sz.
- change (assign_variables atk ((id, lv) :: vars) (cenv, sz))
- with (assign_variables atk vars (assign_variable atk (id, lv) (cenv, sz))).
- caseEq (assign_variable atk (id, lv) (cenv, sz)).
- intros cenv1 sz1 ASV1 ASVS MATCH MINJ SZPOS BOUND DEFINED NOREPET UNDEFINED.
- assert (DEFINED1: forall id0 lv0, In (id0, lv0) vars -> te!(for_var id0) <> None).
- intros. eapply DEFINED. simpl. right. eauto.
- assert (exists tv, te!(for_var id) = Some tv).
- assert (te!(for_var id) <> None). eapply DEFINED. simpl; left; auto.
- destruct (te!(for_var id)). exists v; auto. congruence.
- destruct H1 as [tv TEID].
- assert (sz1 <= fn_stackspace tf). eapply assign_variables_incr; eauto.
- exploit match_callstack_alloc_variable; eauto with coqlib.
- intros [f1 [INCR1 [INJ1 [MCS1 BOUND1]]]].
- exploit IHalloc_variables; eauto.
- apply Zle_trans with sz; auto. eapply assign_variable_incr; eauto.
- inv NOREPET; auto.
- intros. rewrite PTree.gso. eapply UNDEFINED; eauto with coqlib.
- simpl in NOREPET. inversion NOREPET. red; intro; subst id0.
- elim H5. change id with (fst (id, lv0)). apply List.in_map. auto.
- intros [f2 [INCR2 [INJ2 MCS2]]].
- exists f2; intuition. eapply inject_incr_trans; eauto.
-Qed.
-
-Lemma set_params_defined:
- forall params args id,
- In id params -> (set_params args params)!id <> None.
-Proof.
- induction params; simpl; intros.
- elim H.
- destruct args.
- rewrite PTree.gsspec. case (peq id a); intro.
- congruence. eapply IHparams. elim H; intro. congruence. auto.
- rewrite PTree.gsspec. case (peq id a); intro.
- congruence. eapply IHparams. elim H; intro. congruence. auto.
-Qed.
-
-Lemma set_locals_defined:
- forall e vars id,
- In id vars \/ e!id <> None -> (set_locals vars e)!id <> None.
-Proof.
- induction vars; simpl; intros.
- tauto.
- rewrite PTree.gsspec. case (peq id a); intro.
- congruence.
- apply IHvars. assert (a <> id). congruence. tauto.
-Qed.
-
-Lemma set_locals_params_defined:
- forall args params vars id,
- In id (params ++ vars) ->
- (set_locals vars (set_params args params))!id <> None.
-Proof.
- intros. apply set_locals_defined.
- elim (in_app_or _ _ _ H); intro.
- right. apply set_params_defined; auto.
- left; auto.
-Qed.
-
-Lemma create_undef_temps_val:
- forall id v temps, (create_undef_temps temps)!id = Some v -> In id temps /\ v = Vundef.
-Proof.
- induction temps; simpl; intros.
- rewrite PTree.gempty in H. congruence.
- rewrite PTree.gsspec in H. destruct (peq id a).
- split. auto. congruence.
- exploit IHtemps; eauto. tauto.
-Qed.
-
-(** Preservation of [match_callstack] by simultaneous allocation
- of Csharpminor local variables and of the Cminor stack data block. *)
-
-Lemma match_callstack_alloc_variables:
- forall fn cenv tf m e m' tm tm' sp f cs targs,
- build_compilenv gce fn = (cenv, tf.(fn_stackspace)) ->
- tf.(fn_stackspace) <= Int.max_unsigned ->
- list_norepet (fn_params_names fn ++ fn_vars_names fn) ->
- alloc_variables Csharpminor.empty_env m (fn_variables fn) e m' ->
- Mem.alloc tm 0 tf.(fn_stackspace) = (tm', sp) ->
- match_callstack f m tm cs (Mem.nextblock m) (Mem.nextblock tm) ->
- Mem.inject f m tm ->
- let tparams := List.map for_var (fn_params_names fn) in
- let tvars := List.map for_var (fn_vars_names fn) in
- let ttemps := List.map for_temp (Csharpminor.fn_temps fn) in
- let te := set_locals (tvars ++ ttemps) (set_params targs tparams) in
- exists f',
- inject_incr f f'
- /\ Mem.inject f' m' tm'
- /\ match_callstack f' m' tm'
- (Frame cenv tf e (create_undef_temps (Csharpminor.fn_temps fn)) te sp (Mem.nextblock m) (Mem.nextblock m') :: cs)
- (Mem.nextblock m') (Mem.nextblock tm').
-Proof.
- intros.
- unfold build_compilenv in H.
- eapply match_callstack_alloc_variables_rec; eauto with mem.
- red; intros. eapply Mem.perm_alloc_2; eauto.
- eapply match_callstack_alloc_right; eauto.
- intros. exploit create_undef_temps_val; eauto. intros [A B]. subst v.
- assert (te!(for_temp id) <> None).
- unfold te. apply set_locals_defined. left.
- apply in_or_app. right. apply in_map. auto.
- destruct (te!(for_temp id)). exists v; auto. congruence.
- eapply Mem.alloc_right_inject; eauto. omega.
- intros. elim (Mem.valid_not_valid_diff tm sp sp); eauto with mem.
- eapply Mem.valid_block_inject_2; eauto.
- intros. unfold te. apply set_locals_params_defined.
- elim (in_app_or _ _ _ H6); intros.
- apply in_or_app; left. unfold tparams. apply List.in_map.
- change id with (fst (id, lv)). apply List.in_map. auto.
- apply in_or_app; right. apply in_or_app; left. unfold tvars. apply List.in_map.
- change id with (fst (id, lv)). apply List.in_map; auto.
- (* norepet *)
- unfold fn_variables. rewrite List.map_app. assumption.
- (* undef *)
- intros. unfold empty_env. apply PTree.gempty.
-Qed.
-
-(** Correctness of the code generated by [store_parameters]
- to store in memory the values of parameters that are stack-allocated. *)
-
-Inductive vars_vals_match (f:meminj):
- list (ident * var_kind) -> list val -> env -> Prop :=
- | vars_vals_nil:
- forall te,
- vars_vals_match f nil nil te
- | vars_vals_scalar:
- forall te id chunk vars v vals tv,
- te!(for_var id) = Some tv ->
- val_inject f v tv ->
- val_normalized v chunk ->
- vars_vals_match f vars vals te ->
- vars_vals_match f ((id, Vscalar chunk) :: vars) (v :: vals) te
- | vars_vals_array:
- forall te id sz al vars v vals tv,
- te!(for_var id) = Some tv ->
- val_inject f v tv ->
- vars_vals_match f vars vals te ->
- vars_vals_match f ((id, Varray sz al) :: vars) (v :: vals) te.
-
-Lemma vars_vals_match_extensional:
- forall f vars vals te,
- vars_vals_match f vars vals te ->
- forall te',
- (forall id lv, In (id, lv) vars -> te'!(for_var id) = te!(for_var id)) ->
- vars_vals_match f vars vals te'.
-Proof.
- induction 1; intros.
- constructor.
- econstructor; eauto.
- rewrite <- H. eauto with coqlib.
- apply IHvars_vals_match. intros. eapply H3; eauto with coqlib.
- econstructor; eauto.
- rewrite <- H. eauto with coqlib.
- apply IHvars_vals_match. intros. eapply H2; eauto with coqlib.
-Qed.
-
-Lemma vars_vals_match_incr:
- forall f f', inject_incr f f' ->
- forall vars vals te,
- vars_vals_match f vars vals te ->
- vars_vals_match f' vars vals te.
-Proof.
- induction 2; intros; econstructor; eauto.
-Qed.
-
-Lemma store_parameters_correct:
- forall e le te m1 params vl m2,
- bind_parameters ge e m1 params vl m2 ->
- forall s f cenv tf sp lo hi cs tm1 fn k,
- vars_vals_match f params vl te ->
- list_norepet (List.map variable_name params) ->
- Mem.inject f m1 tm1 ->
- match_callstack f m1 tm1 (Frame cenv tf e le te sp lo hi :: cs) (Mem.nextblock m1) (Mem.nextblock tm1) ->
- store_parameters cenv params = OK s ->
- exists f', exists tm2,
- star step tge (State fn s k (Vptr sp Int.zero) te tm1)
- E0 (State fn Sskip k (Vptr sp Int.zero) te tm2)
- /\ Mem.inject f' m2 tm2
- /\ match_callstack f' m2 tm2 (Frame cenv tf e le te sp lo hi :: cs) (Mem.nextblock m2) (Mem.nextblock tm2)
- /\ inject_incr f f'.
-Proof.
- induction 1.
- (* base case *)
- intros; simpl. monadInv H3.
- exists f; exists tm1. split. constructor. auto.
- (* scalar case *)
- intros until k. intros VVM NOREPET MINJ MATCH STOREP.
- monadInv STOREP. inv VVM. inv NOREPET.
- exploit var_set_self_correct_scalar; eauto.
- econstructor; eauto. econstructor; eauto.
- intros [tm2 [EXEC1 [MINJ1 MATCH1]]].
- exploit IHbind_parameters; eauto.
- intros [f' [tm3 [EXEC2 [MINJ2 [MATCH2 INCR2]]]]].
- exists f'; exists tm3.
- split. eapply star_trans; eauto.
- auto.
- (* array case *)
- intros until k. intros VVM NOREPET MINJ MATCH STOREP.
- monadInv STOREP. inv VVM. inv NOREPET.
- exploit var_set_self_correct_array; eauto.
- intros [f2 [tm2 [EXEC1 [MINJ1 [MATCH1 INCR1]]]]].
- exploit IHbind_parameters. eapply vars_vals_match_incr; eauto. auto. eauto. eauto. eauto.
- intros [f3 [tm3 [EXEC2 [MINJ2 [MATCH2 INCR2]]]]].
- exists f3; exists tm3.
- split. eapply star_trans; eauto.
- split. auto. split. auto. eapply inject_incr_trans; eauto.
-Qed.
-
-Definition val_normalized' (v: val) (vk: var_kind) : Prop :=
- match vk with
- | Vscalar chunk => val_normalized v chunk
- | Varray _ _ => True
- end.
-
-Lemma vars_vals_match_holds_1:
- forall f params args targs,
- list_norepet (List.map variable_name params) ->
- val_list_inject f args targs ->
- list_forall2 val_normalized' args (List.map variable_kind params) ->
- vars_vals_match f params args
- (set_params targs (List.map for_var (List.map variable_name params))).
-Proof.
-Opaque for_var.
- induction params; simpl; intros.
- inv H1. constructor.
- inv H. inv H1. inv H0.
- destruct a as [id vk]; simpl in *.
- assert (R: vars_vals_match f params al
- (PTree.set (for_var id) v'
- (set_params vl' (map for_var (map variable_name params))))).
- apply vars_vals_match_extensional
- with (set_params vl' (map for_var (map variable_name params))).
- eapply IHparams; eauto.
-Transparent for_var.
- intros. apply PTree.gso. unfold for_var; red; intros. inv H0.
- elim H4. change id with (variable_name (id, lv)). apply List.in_map; auto.
-
- destruct vk; red in H6.
- econstructor. rewrite PTree.gss. reflexivity. auto. auto. auto.
- econstructor. rewrite PTree.gss. reflexivity. auto. auto.
-Qed.
-
-Lemma vars_vals_match_holds_2:
- forall f params args e,
- vars_vals_match f params args e ->
- forall vl,
- (forall id1 id2, In id1 (List.map variable_name params) -> In id2 vl -> for_var id1 <> id2) ->
- vars_vals_match f params args (set_locals vl e).
-Proof.
- induction vl; simpl; intros.
- auto.
- apply vars_vals_match_extensional with (set_locals vl e); auto.
- intros. apply PTree.gso. apply H0.
- change id with (variable_name (id, lv)). apply List.in_map. auto.
- auto.
-Qed.
-
-Lemma vars_vals_match_holds:
- forall f params args targs vars temps,
- list_norepet (List.map variable_name params ++ vars) ->
- val_list_inject f args targs ->
- list_forall2 val_normalized' args (List.map variable_kind params) ->
- vars_vals_match f params args
- (set_locals (List.map for_var vars ++ List.map for_temp temps)
- (set_params targs (List.map for_var (List.map variable_name params)))).
-Proof.
- intros. rewrite list_norepet_app in H. destruct H as [A [B C]].
- apply vars_vals_match_holds_2; auto. apply vars_vals_match_holds_1; auto.
- intros.
- destruct (in_app_or _ _ _ H2).
- exploit list_in_map_inv. eexact H3. intros [x2 [J K]].
- subst. assert (id1 <> x2). apply C; auto. unfold for_var; congruence.
- exploit list_in_map_inv. eexact H3. intros [x2 [J K]].
- subst id2. unfold for_var, for_temp; congruence.
-Qed.
-
-Remark bind_parameters_normalized:
- forall e m params args m',
- bind_parameters ge e m params args m' ->
- list_forall2 val_normalized' args (List.map variable_kind params).
-Proof.
- induction 1; simpl.
- constructor.
- constructor; auto.
- constructor; auto. red; auto.
-Qed.
-
-(** The main result in this section: the behaviour of function entry
- in the generated Cminor code (allocate stack data block and store
- parameters whose address is taken) simulates what happens at function
- entry in the original Csharpminor (allocate one block per local variable
- and initialize the blocks corresponding to function parameters). *)
-
-Lemma function_entry_ok:
- forall fn m e m1 vargs m2 f cs tm cenv tf tm1 sp tvargs s fn' k,
- list_norepet (fn_params_names fn ++ fn_vars_names fn) ->
- alloc_variables empty_env m (fn_variables fn) e m1 ->
- bind_parameters ge e m1 fn.(Csharpminor.fn_params) vargs m2 ->
- match_callstack f m tm cs (Mem.nextblock m) (Mem.nextblock tm) ->
- build_compilenv gce fn = (cenv, tf.(fn_stackspace)) ->
- tf.(fn_stackspace) <= Int.max_unsigned ->
- Mem.alloc tm 0 tf.(fn_stackspace) = (tm1, sp) ->
- let tparams := List.map for_var (fn_params_names fn) in
- let tvars := List.map for_var (fn_vars_names fn) in
- let ttemps := List.map for_temp (Csharpminor.fn_temps fn) in
- let te := set_locals (tvars ++ ttemps) (set_params tvargs tparams) in
- val_list_inject f vargs tvargs ->
- Mem.inject f m tm ->
- store_parameters cenv fn.(Csharpminor.fn_params) = OK s ->
- exists f2, exists tm2,
- star step tge (State fn' s k (Vptr sp Int.zero) te tm1)
- E0 (State fn' Sskip k (Vptr sp Int.zero) te tm2)
- /\ Mem.inject f2 m2 tm2
- /\ inject_incr f f2
- /\ match_callstack f2 m2 tm2
- (Frame cenv tf e (create_undef_temps (Csharpminor.fn_temps fn)) te sp (Mem.nextblock m) (Mem.nextblock m1) :: cs)
- (Mem.nextblock m2) (Mem.nextblock tm2).
-Proof.
- intros.
- exploit match_callstack_alloc_variables; eauto.
- intros [f1 [INCR1 [MINJ1 MATCH1]]].
- exploit vars_vals_match_holds.
- eexact H.
- apply val_list_inject_incr with f. eauto. eauto.
- eapply bind_parameters_normalized; eauto.
- instantiate (1 := Csharpminor.fn_temps fn).
- fold tvars. fold ttemps. fold (fn_params_names fn). fold tparams. fold te.
- intro VVM.
- exploit store_parameters_correct.
- eauto. eauto. eapply list_norepet_append_left; eauto.
- eexact MINJ1. eexact MATCH1. eauto.
- intros [f2 [tm2 [EXEC [MINJ2 [MATCH2 INCR2]]]]].
- exists f2; exists tm2.
- split; eauto. split; auto. split; auto. eapply inject_incr_trans; eauto.
+ econstructor; eauto.
Qed.
(** * Semantic preservation for the translation *)
@@ -2649,8 +1989,8 @@ Qed.
e, m2, out --------------- sp, te2, tm2, tout
>>
where [ts] is the Cminor statement obtained by translating the
- Csharpminor statement [s]. The left vertical arrow is an execution
- of a Csharpminor statement. The right vertical arrow is an execution
+ C#minor statement [s]. The left vertical arrow is an execution
+ of a C#minor statement. The right vertical arrow is an execution
of a Cminor statement. The precondition (top vertical bar)
includes a [mem_inject] relation between the memory states [m1] and [tm1],
and a [match_callstack] relation for any callstack having
@@ -2700,13 +2040,12 @@ Lemma transl_expr_correct:
/\ val_match_approx app v.
Proof.
induction 3; intros; simpl in TR; try (monadInv TR).
- (* Evar *)
- eapply var_get_correct; eauto.
(* Etempvar *)
- inv MATCH. inv MENV. exploit me_temps0; eauto. intros [tv [A B]].
+ inv MATCH. exploit MTMP; eauto. intros [tv [A B]].
exists tv; split. constructor; auto. split. auto. exact I.
(* Eaddrof *)
- eapply var_addr_correct; eauto.
+ exploit var_addr_correct; eauto. intros [tv [A B]].
+ exists tv; split. auto. split. auto. red. auto.
(* Econst *)
exploit transl_constant_correct; eauto.
destruct (transl_constant cst) as [tcst a]; inv TR.
@@ -2758,70 +2097,70 @@ Qed.
(** ** Semantic preservation for statements and functions *)
-Inductive match_cont: Csharpminor.cont -> Cminor.cont -> option typ -> compilenv -> exit_env -> callstack -> Prop :=
- | match_Kstop: forall ty cenv xenv,
- match_cont Csharpminor.Kstop Kstop ty cenv xenv nil
- | match_Kseq: forall s k ts tk ty cenv xenv cs,
- transl_stmt ty cenv xenv s = OK ts ->
- match_cont k tk ty cenv xenv cs ->
- match_cont (Csharpminor.Kseq s k) (Kseq ts tk) ty cenv xenv cs
- | match_Kseq2: forall s1 s2 k ts1 tk ty cenv xenv cs,
- transl_stmt ty cenv xenv s1 = OK ts1 ->
- match_cont (Csharpminor.Kseq s2 k) tk ty cenv xenv cs ->
+Inductive match_cont: Csharpminor.cont -> Cminor.cont -> compilenv -> exit_env -> callstack -> Prop :=
+ | match_Kstop: forall cenv xenv,
+ match_cont Csharpminor.Kstop Kstop cenv xenv nil
+ | match_Kseq: forall s k ts tk cenv xenv cs,
+ transl_stmt cenv xenv s = OK ts ->
+ match_cont k tk cenv xenv cs ->
+ match_cont (Csharpminor.Kseq s k) (Kseq ts tk) cenv xenv cs
+ | match_Kseq2: forall s1 s2 k ts1 tk cenv xenv cs,
+ transl_stmt cenv xenv s1 = OK ts1 ->
+ match_cont (Csharpminor.Kseq s2 k) tk cenv xenv cs ->
match_cont (Csharpminor.Kseq (Csharpminor.Sseq s1 s2) k)
- (Kseq ts1 tk) ty cenv xenv cs
- | match_Kblock: forall k tk ty cenv xenv cs,
- match_cont k tk ty cenv xenv cs ->
- match_cont (Csharpminor.Kblock k) (Kblock tk) ty cenv (true :: xenv) cs
- | match_Kblock2: forall k tk ty cenv xenv cs,
- match_cont k tk ty cenv xenv cs ->
- match_cont k (Kblock tk) ty cenv (false :: xenv) cs
- | match_Kcall: forall optid fn e le k tfn sp te tk ty cenv xenv lo hi cs sz cenv',
+ (Kseq ts1 tk) cenv xenv cs
+ | match_Kblock: forall k tk cenv xenv cs,
+ match_cont k tk cenv xenv cs ->
+ match_cont (Csharpminor.Kblock k) (Kblock tk) cenv (true :: xenv) cs
+ | match_Kblock2: forall k tk cenv xenv cs,
+ match_cont k tk cenv xenv cs ->
+ match_cont k (Kblock tk) cenv (false :: xenv) cs
+ | match_Kcall: forall optid fn e le k tfn sp te tk cenv xenv lo hi cs sz cenv',
transl_funbody cenv sz fn = OK tfn ->
- match_cont k tk fn.(fn_return) cenv xenv cs ->
+ match_cont k tk cenv xenv cs ->
match_cont (Csharpminor.Kcall optid fn e le k)
- (Kcall (option_map for_temp optid) tfn (Vptr sp Int.zero) te tk)
- ty cenv' nil
+ (Kcall optid tfn (Vptr sp Int.zero) te tk)
+ cenv' nil
(Frame cenv tfn e le te sp lo hi :: cs).
Inductive match_states: Csharpminor.state -> Cminor.state -> Prop :=
| match_state:
forall fn s k e le m tfn ts tk sp te tm cenv xenv f lo hi cs sz
(TRF: transl_funbody cenv sz fn = OK tfn)
- (TR: transl_stmt fn.(fn_return) cenv xenv s = OK ts)
+ (TR: transl_stmt cenv xenv s = OK ts)
(MINJ: Mem.inject f m tm)
(MCS: match_callstack f m tm
(Frame cenv tfn e le te sp lo hi :: cs)
(Mem.nextblock m) (Mem.nextblock tm))
- (MK: match_cont k tk fn.(fn_return) cenv xenv cs),
+ (MK: match_cont k tk cenv xenv cs),
match_states (Csharpminor.State fn s k e le m)
(State tfn ts tk (Vptr sp Int.zero) te tm)
| match_state_seq:
forall fn s1 s2 k e le m tfn ts1 tk sp te tm cenv xenv f lo hi cs sz
(TRF: transl_funbody cenv sz fn = OK tfn)
- (TR: transl_stmt fn.(fn_return) cenv xenv s1 = OK ts1)
+ (TR: transl_stmt cenv xenv s1 = OK ts1)
(MINJ: Mem.inject f m tm)
(MCS: match_callstack f m tm
(Frame cenv tfn e le te sp lo hi :: cs)
(Mem.nextblock m) (Mem.nextblock tm))
- (MK: match_cont (Csharpminor.Kseq s2 k) tk fn.(fn_return) cenv xenv cs),
+ (MK: match_cont (Csharpminor.Kseq s2 k) tk cenv xenv cs),
match_states (Csharpminor.State fn (Csharpminor.Sseq s1 s2) k e le m)
(State tfn ts1 tk (Vptr sp Int.zero) te tm)
| match_callstate:
forall fd args k m tfd targs tk tm f cs cenv
- (TR: transl_fundef gce fd = OK tfd)
+ (TR: transl_fundef fd = OK tfd)
(MINJ: Mem.inject f m tm)
(MCS: match_callstack f m tm cs (Mem.nextblock m) (Mem.nextblock tm))
- (MK: match_cont k tk (Csharpminor.funsig fd).(sig_res) cenv nil cs)
+ (MK: match_cont k tk cenv nil cs)
(ISCC: Csharpminor.is_call_cont k)
(ARGSINJ: val_list_inject f args targs),
match_states (Csharpminor.Callstate fd args k m)
(Callstate tfd targs tk tm)
| match_returnstate:
- forall v k m tv tk tm f cs ty cenv
+ forall v k m tv tk tm f cs cenv
(MINJ: Mem.inject f m tm)
(MCS: match_callstack f m tm cs (Mem.nextblock m) (Mem.nextblock tm))
- (MK: match_cont k tk ty cenv nil cs)
+ (MK: match_cont k tk cenv nil cs)
(RESINJ: val_inject f v tv),
match_states (Csharpminor.Returnstate v k m)
(Returnstate tv tk tm).
@@ -2840,22 +2179,22 @@ Proof.
Qed.
Lemma match_call_cont:
- forall k tk ty cenv xenv cs,
- match_cont k tk ty cenv xenv cs ->
- match_cont (Csharpminor.call_cont k) (call_cont tk) ty cenv nil cs.
+ forall k tk cenv xenv cs,
+ match_cont k tk cenv xenv cs ->
+ match_cont (Csharpminor.call_cont k) (call_cont tk) cenv nil cs.
Proof.
induction 1; simpl; auto; econstructor; eauto.
Qed.
Lemma match_is_call_cont:
- forall tfn te sp tm k tk ty cenv xenv cs,
- match_cont k tk ty cenv xenv cs ->
+ forall tfn te sp tm k tk cenv xenv cs,
+ match_cont k tk cenv xenv cs ->
Csharpminor.is_call_cont k ->
exists tk',
star step tge (State tfn Sskip tk sp te tm)
E0 (State tfn Sskip tk' sp te tm)
/\ is_call_cont tk'
- /\ match_cont k tk' ty cenv nil cs.
+ /\ match_cont k tk' cenv nil cs.
Proof.
induction 1; simpl; intros; try contradiction.
econstructor; split. apply star_refl. split. exact I. econstructor; eauto.
@@ -2882,20 +2221,20 @@ Proof.
induction sl; intros; simpl. auto. decEq; auto.
Qed.
-Inductive transl_lblstmt_cont (ty: option typ) (cenv: compilenv) (xenv: exit_env): lbl_stmt -> cont -> cont -> Prop :=
+Inductive transl_lblstmt_cont(cenv: compilenv) (xenv: exit_env): lbl_stmt -> cont -> cont -> Prop :=
| tlsc_default: forall s k ts,
- transl_stmt ty cenv (switch_env (LSdefault s) xenv) s = OK ts ->
- transl_lblstmt_cont ty cenv xenv (LSdefault s) k (Kblock (Kseq ts k))
+ transl_stmt cenv (switch_env (LSdefault s) xenv) s = OK ts ->
+ transl_lblstmt_cont cenv xenv (LSdefault s) k (Kblock (Kseq ts k))
| tlsc_case: forall i s ls k ts k',
- transl_stmt ty cenv (switch_env (LScase i s ls) xenv) s = OK ts ->
- transl_lblstmt_cont ty cenv xenv ls k k' ->
- transl_lblstmt_cont ty cenv xenv (LScase i s ls) k (Kblock (Kseq ts k')).
+ transl_stmt cenv (switch_env (LScase i s ls) xenv) s = OK ts ->
+ transl_lblstmt_cont cenv xenv ls k k' ->
+ transl_lblstmt_cont cenv xenv (LScase i s ls) k (Kblock (Kseq ts k')).
Lemma switch_descent:
- forall ty cenv xenv k ls body s,
- transl_lblstmt ty cenv (switch_env ls xenv) ls body = OK s ->
+ forall cenv xenv k ls body s,
+ transl_lblstmt cenv (switch_env ls xenv) ls body = OK s ->
exists k',
- transl_lblstmt_cont ty cenv xenv ls k k'
+ transl_lblstmt_cont cenv xenv ls k k'
/\ (forall f sp e m,
plus step tge (State f s k sp e m) E0 (State f body k' sp e m)).
Proof.
@@ -2912,14 +2251,14 @@ Proof.
Qed.
Lemma switch_ascent:
- forall f n sp e m ty cenv xenv k ls k1,
+ forall f n sp e m cenv xenv k ls k1,
let tbl := switch_table ls O in
let ls' := select_switch n ls in
- transl_lblstmt_cont ty cenv xenv ls k k1 ->
+ transl_lblstmt_cont cenv xenv ls k k1 ->
exists k2,
star step tge (State f (Sexit (switch_target n (length tbl) tbl)) k1 sp e m)
E0 (State f (Sexit O) k2 sp e m)
- /\ transl_lblstmt_cont ty cenv xenv ls' k k2.
+ /\ transl_lblstmt_cont cenv xenv ls' k k2.
Proof.
induction ls; intros; unfold tbl, ls'; simpl.
inv H. econstructor; split. apply star_refl. econstructor; eauto.
@@ -2936,10 +2275,10 @@ Proof.
Qed.
Lemma switch_match_cont:
- forall ty cenv xenv k cs tk ls tk',
- match_cont k tk ty cenv xenv cs ->
- transl_lblstmt_cont ty cenv xenv ls tk tk' ->
- match_cont (Csharpminor.Kseq (seq_of_lbl_stmt ls) k) tk' ty cenv (false :: switch_env ls xenv) cs.
+ forall cenv xenv k cs tk ls tk',
+ match_cont k tk cenv xenv cs ->
+ transl_lblstmt_cont cenv xenv ls tk tk' ->
+ match_cont (Csharpminor.Kseq (seq_of_lbl_stmt ls) k) tk' cenv (false :: switch_env ls xenv) cs.
Proof.
induction ls; intros; simpl.
inv H0. apply match_Kblock2. econstructor; eauto.
@@ -2947,11 +2286,11 @@ Proof.
Qed.
Lemma transl_lblstmt_suffix:
- forall n ty cenv xenv ls body ts,
- transl_lblstmt ty cenv (switch_env ls xenv) ls body = OK ts ->
+ forall n cenv xenv ls body ts,
+ transl_lblstmt cenv (switch_env ls xenv) ls body = OK ts ->
let ls' := select_switch n ls in
exists body', exists ts',
- transl_lblstmt ty cenv (switch_env ls' xenv) ls' body' = OK ts'.
+ transl_lblstmt cenv (switch_env ls' xenv) ls' body' = OK ts'.
Proof.
induction ls; simpl; intros.
monadInv H.
@@ -2965,13 +2304,13 @@ Qed.
Lemma switch_match_states:
forall fn k e le m tfn ts tk sp te tm cenv xenv f lo hi cs sz ls body tk'
(TRF: transl_funbody cenv sz fn = OK tfn)
- (TR: transl_lblstmt (fn_return fn) cenv (switch_env ls xenv) ls body = OK ts)
+ (TR: transl_lblstmt cenv (switch_env ls xenv) ls body = OK ts)
(MINJ: Mem.inject f m tm)
(MCS: match_callstack f m tm
(Frame cenv tfn e le te sp lo hi :: cs)
(Mem.nextblock m) (Mem.nextblock tm))
- (MK: match_cont k tk (fn_return fn) cenv xenv cs)
- (TK: transl_lblstmt_cont (fn_return fn) cenv xenv ls tk tk'),
+ (MK: match_cont k tk cenv xenv cs)
+ (TK: transl_lblstmt_cont cenv xenv ls tk tk'),
exists S,
plus step tge (State tfn (Sexit O) tk' (Vptr sp Int.zero) te tm) E0 S
/\ match_states (Csharpminor.State fn (seq_of_lbl_stmt ls) k e le m) S.
@@ -2991,32 +2330,13 @@ Qed.
Section FIND_LABEL.
Variable lbl: label.
-Variable ty: option typ.
Variable cenv: compilenv.
Variable cs: callstack.
-Remark find_label_var_set:
- forall id e s k,
- var_set cenv id e = OK s ->
- find_label lbl s k = None.
-Proof.
- intros. unfold var_set in H.
- destruct (cenv!!id); try (monadInv H; reflexivity).
-Qed.
-
-Remark find_label_var_set_self:
- forall id s0 s k,
- var_set_self cenv id s0 = OK s ->
- find_label lbl s k = find_label lbl s0 k.
-Proof.
- intros. unfold var_set_self in H.
- destruct (cenv!!id); try (monadInv H; reflexivity).
-Qed.
-
Lemma transl_lblstmt_find_label_context:
forall xenv ls body ts tk1 tk2 ts' tk',
- transl_lblstmt ty cenv (switch_env ls xenv) ls body = OK ts ->
- transl_lblstmt_cont ty cenv xenv ls tk1 tk2 ->
+ transl_lblstmt cenv (switch_env ls xenv) ls body = OK ts ->
+ transl_lblstmt_cont cenv xenv ls tk1 tk2 ->
find_label lbl body tk2 = Some (ts', tk') ->
find_label lbl ts tk1 = Some (ts', tk').
Proof.
@@ -3029,35 +2349,33 @@ Qed.
Lemma transl_find_label:
forall s k xenv ts tk,
- transl_stmt ty cenv xenv s = OK ts ->
- match_cont k tk ty cenv xenv cs ->
+ transl_stmt cenv xenv s = OK ts ->
+ match_cont k tk cenv xenv cs ->
match Csharpminor.find_label lbl s k with
| None => find_label lbl ts tk = None
| Some(s', k') =>
exists ts', exists tk', exists xenv',
find_label lbl ts tk = Some(ts', tk')
- /\ transl_stmt ty cenv xenv' s' = OK ts'
- /\ match_cont k' tk' ty cenv xenv' cs
+ /\ transl_stmt cenv xenv' s' = OK ts'
+ /\ match_cont k' tk' cenv xenv' cs
end
with transl_lblstmt_find_label:
forall ls xenv body k ts tk tk1,
- transl_lblstmt ty cenv (switch_env ls xenv) ls body = OK ts ->
- match_cont k tk ty cenv xenv cs ->
- transl_lblstmt_cont ty cenv xenv ls tk tk1 ->
+ transl_lblstmt cenv (switch_env ls xenv) ls body = OK ts ->
+ match_cont k tk cenv xenv cs ->
+ transl_lblstmt_cont cenv xenv ls tk tk1 ->
find_label lbl body tk1 = None ->
match Csharpminor.find_label_ls lbl ls k with
| None => find_label lbl ts tk = None
| Some(s', k') =>
exists ts', exists tk', exists xenv',
find_label lbl ts tk = Some(ts', tk')
- /\ transl_stmt ty cenv xenv' s' = OK ts'
- /\ match_cont k' tk' ty cenv xenv' cs
+ /\ transl_stmt cenv xenv' s' = OK ts'
+ /\ match_cont k' tk' cenv xenv' cs
end.
Proof.
intros. destruct s; try (monadInv H); simpl; auto.
- (* assign *)
- eapply find_label_var_set; eauto.
(* seq *)
exploit (transl_find_label s1). eauto. eapply match_Kseq. eexact EQ1. eauto.
destruct (Csharpminor.find_label lbl s1 (Csharpminor.Kseq s2 k)) as [[s' k'] | ].
@@ -3101,30 +2419,19 @@ Proof.
simpl. replace x with ts0 by congruence. rewrite H2. auto.
Qed.
-Remark find_label_store_parameters:
- forall vars s k,
- store_parameters cenv vars = OK s -> find_label lbl s k = None.
-Proof.
- induction vars; intros.
- monadInv H. auto.
- simpl in H. destruct a as [id lv]. monadInv H.
- transitivity (find_label lbl x k). eapply find_label_var_set_self; eauto. eauto.
-Qed.
-
End FIND_LABEL.
Lemma transl_find_label_body:
forall cenv xenv size f tf k tk cs lbl s' k',
transl_funbody cenv size f = OK tf ->
- match_cont k tk (fn_return f) cenv xenv cs ->
+ match_cont k tk cenv xenv cs ->
Csharpminor.find_label lbl f.(Csharpminor.fn_body) (Csharpminor.call_cont k) = Some (s', k') ->
exists ts', exists tk', exists xenv',
find_label lbl tf.(fn_body) (call_cont tk) = Some(ts', tk')
- /\ transl_stmt (fn_return f) cenv xenv' s' = OK ts'
- /\ match_cont k' tk' (fn_return f) cenv xenv' cs.
+ /\ transl_stmt cenv xenv' s' = OK ts'
+ /\ match_cont k' tk' cenv xenv' cs.
Proof.
intros. monadInv H. simpl.
- rewrite (find_label_store_parameters lbl cenv (Csharpminor.fn_params f)); auto.
exploit transl_find_label. eexact EQ. eapply match_call_cont. eexact H0.
instantiate (1 := lbl). rewrite H1. auto.
Qed.
@@ -3177,17 +2484,7 @@ Proof.
exploit match_is_call_cont; eauto. intros [tk' [A [B C]]].
exploit match_callstack_freelist; eauto. intros [tm' [P [Q R]]].
econstructor; split.
- eapply plus_right. eexact A. apply step_skip_call. auto.
- rewrite (sig_preserved_body _ _ _ _ TRF). auto. eauto. traceEq.
- econstructor; eauto.
-
-(* assign *)
- monadInv TR.
- exploit transl_expr_correct; eauto. intros [tv [EVAL [VINJ APP]]].
- exploit var_set_correct; eauto.
- intros [te' [tm' [EXEC [MINJ' [MCS' OTHER]]]]].
- left; econstructor; split.
- apply plus_one. eexact EXEC.
+ eapply plus_right. eexact A. apply step_skip_call. auto. eauto. traceEq.
econstructor; eauto.
(* set *)
@@ -3209,10 +2506,12 @@ Proof.
left; econstructor; split.
apply plus_one. eexact EXEC.
econstructor; eauto.
- eapply match_callstack_storev_mapped. eexact VINJ1. eauto. eauto.
- rewrite (nextblock_storev _ _ _ _ _ H1).
- rewrite (nextblock_storev _ _ _ _ _ STORE').
- eauto.
+ inv VINJ1; simpl in H1; try discriminate. unfold Mem.storev in STORE'.
+ rewrite (Mem.nextblock_store _ _ _ _ _ _ H1).
+ rewrite (Mem.nextblock_store _ _ _ _ _ _ STORE').
+ eapply match_callstack_invariant with f0 m tm; eauto.
+ intros. eapply Mem.perm_store_2; eauto.
+ intros. eapply Mem.perm_store_1; eauto.
(* call *)
simpl in H1. exploit functions_translated; eauto. intros [tfd [FIND TRANS]].
@@ -3241,10 +2540,8 @@ Proof.
intros [f' [vres' [tm' [EC [VINJ [MINJ' [UNMAPPED [OUTOFREACH [INCR SEPARATED]]]]]]]]].
left; econstructor; split.
apply plus_one. econstructor. eauto.
- eapply external_call_symbols_preserved_2; eauto.
- exact symbols_preserved.
- eexact var_info_translated.
- eexact var_info_rev_translated.
+ eapply external_call_symbols_preserved; eauto.
+ exact symbols_preserved. eexact varinfo_preserved.
assert (MCS': match_callstack f' m' tm'
(Frame cenv tfn e le te sp lo hi :: cs)
(Mem.nextblock m') (Mem.nextblock tm')).
@@ -3252,8 +2549,8 @@ Proof.
eapply match_callstack_external_call; eauto.
intros. eapply external_call_max_perm; eauto.
omega. omega.
- eapply external_call_nextblock_incr; eauto.
- eapply external_call_nextblock_incr; eauto.
+ eapply external_call_nextblock; eauto.
+ eapply external_call_nextblock; eauto.
econstructor; eauto.
Opaque PTree.set.
unfold set_optvar. destruct optid; simpl.
@@ -3370,26 +2667,21 @@ Opaque PTree.set.
(* internal call *)
monadInv TR. generalize EQ; clear EQ; unfold transl_function.
- caseEq (build_compilenv gce f). intros ce sz BC.
+ caseEq (build_compilenv f). intros ce sz BC.
destruct (zle sz Int.max_unsigned); try congruence.
intro TRBODY.
generalize TRBODY; intro TMP. monadInv TMP.
set (tf := mkfunction (Csharpminor.fn_sig f)
- (List.map for_var (fn_params_names f))
- (List.map for_var (fn_vars_names f)
- ++ List.map for_temp (Csharpminor.fn_temps f))
+ (Csharpminor.fn_params f)
+ (Csharpminor.fn_temps f)
sz
- (Sseq x1 x0)) in *.
+ x0) in *.
caseEq (Mem.alloc tm 0 (fn_stackspace tf)). intros tm' sp ALLOC'.
- exploit function_entry_ok; eauto; simpl; auto.
- intros [f2 [tm2 [EXEC [MINJ2 [IINCR MCS2]]]]].
+ exploit match_callstack_function_entry; eauto. simpl; eauto. simpl; auto.
+ intros [f2 [MCS2 MINJ2]].
left; econstructor; split.
- eapply plus_left. constructor; simpl; eauto.
- simpl. eapply star_left. constructor.
- eapply star_right. eexact EXEC. constructor.
- reflexivity. reflexivity. traceEq.
- econstructor. eexact TRBODY. eauto. eexact MINJ2.
- eexact MCS2.
+ apply plus_one. constructor; simpl; eauto.
+ econstructor. eexact TRBODY. eauto. eexact MINJ2. eexact MCS2.
inv MK; simpl in ISCC; contradiction || econstructor; eauto.
(* external call *)
@@ -3400,23 +2692,21 @@ Opaque PTree.set.
intros [f' [vres' [tm' [EC [VINJ [MINJ' [UNMAPPED [OUTOFREACH [INCR SEPARATED]]]]]]]]].
left; econstructor; split.
apply plus_one. econstructor.
- eapply external_call_symbols_preserved_2; eauto.
- exact symbols_preserved.
- eexact var_info_translated.
- eexact var_info_rev_translated.
+ eapply external_call_symbols_preserved; eauto.
+ exact symbols_preserved. eexact varinfo_preserved.
econstructor; eauto.
apply match_callstack_incr_bound with (Mem.nextblock m) (Mem.nextblock tm).
eapply match_callstack_external_call; eauto.
intros. eapply external_call_max_perm; eauto.
omega. omega.
- eapply external_call_nextblock_incr; eauto.
- eapply external_call_nextblock_incr; eauto.
+ eapply external_call_nextblock; eauto.
+ eapply external_call_nextblock; eauto.
(* return *)
inv MK. simpl.
left; econstructor; split.
apply plus_one. econstructor; eauto.
- unfold set_optvar. destruct optid; simpl option_map; econstructor; eauto.
+ unfold set_optvar. destruct optid; simpl; econstructor; eauto.
eapply match_callstack_set_temp; eauto.
Qed.
@@ -3443,19 +2733,19 @@ Proof.
exploit function_ptr_translated; eauto. intros [tf [FIND TR]].
econstructor; split.
econstructor.
- apply (Genv.init_mem_transf_partial2 _ _ _ TRANSL). eauto.
+ apply (Genv.init_mem_transf_partial _ _ TRANSL). eauto.
simpl. fold tge. rewrite symbols_preserved.
replace (prog_main tprog) with (prog_main prog). eexact H0.
symmetry. unfold transl_program in TRANSL.
- eapply transform_partial_program2_main; eauto.
+ eapply transform_partial_program_main; eauto.
eexact FIND.
rewrite <- H2. apply sig_preserved; auto.
- eapply match_callstate with (f := Mem.flat_inj (Mem.nextblock m0)) (cs := @nil frame).
+ eapply match_callstate with (f := Mem.flat_inj (Mem.nextblock m0)) (cs := @nil frame) (cenv := PTree.empty Z).
auto.
eapply Genv.initmem_inject; eauto.
apply mcs_nil with (Mem.nextblock m0). apply match_globalenvs_init; auto. omega. omega.
- instantiate (1 := gce). constructor.
- red; auto. constructor.
+ constructor. red; auto.
+ constructor.
Qed.
Lemma transl_final_states:
diff --git a/cfrontend/Csem.v b/cfrontend/Csem.v
index 44a7325..0f9b3f8 100644
--- a/cfrontend/Csem.v
+++ b/cfrontend/Csem.v
@@ -706,7 +706,6 @@ Inductive sstep: state -> trace -> state -> Prop :=
E0 (Returnstate v2 (call_cont k) m')
| step_skip_call: forall f k e m m',
is_call_cont k ->
- f.(fn_return) = Tvoid ->
Mem.free_list m (blocks_of_env e) = Some m' ->
sstep (State f Sskip k e m)
E0 (Returnstate Vundef k m')
diff --git a/cfrontend/Csharpminor.v b/cfrontend/Csharpminor.v
index b267891..d0bd9f4 100644
--- a/cfrontend/Csharpminor.v
+++ b/cfrontend/Csharpminor.v
@@ -28,14 +28,8 @@ Require Import Smallstep.
(** Csharpminor is a low-level imperative language structured in expressions,
statements, functions and programs. Expressions include
- reading global or local variables, reading store locations,
- arithmetic operations, function calls, and conditional expressions
- (similar to [e1 ? e2 : e3] in C).
-
- Unlike in Cminor (the next intermediate language of the back-end),
- Csharpminor local variables reside in memory, and their addresses can
- be taken using [Eaddrof] expressions.
-*)
+ reading temporary variables, taking the address of a variable,
+ constants, arithmetic operations, and dereferencing addresses. *)
Inductive constant : Type :=
| Ointconst: int -> constant (**r integer constant *)
@@ -45,15 +39,14 @@ Definition unary_operation : Type := Cminor.unary_operation.
Definition binary_operation : Type := Cminor.binary_operation.
Inductive expr : Type :=
- | Evar : ident -> expr (**r reading a scalar variable *)
- | Etempvar : ident -> expr (**r reading a temporary variable *)
+ | Evar : ident -> expr (**r reading a temporary variable *)
| Eaddrof : ident -> expr (**r taking the address of a variable *)
| Econst : constant -> expr (**r constants *)
| Eunop : unary_operation -> expr -> expr (**r unary operation *)
| Ebinop : binary_operation -> expr -> expr -> expr (**r binary operation *)
| Eload : memory_chunk -> expr -> expr. (**r memory read *)
-(** Statements include expression evaluation, variable assignment,
+(** Statements include expression evaluation, temporary variable assignment,
memory stores, function calls, an if/then/else conditional,
infinite loops, blocks and early block exits, and early function returns.
[Sexit n] terminates prematurely the execution of the [n+1] enclosing
@@ -63,7 +56,6 @@ Definition label := ident.
Inductive stmt : Type :=
| Sskip: stmt
- | Sassign : ident -> expr -> stmt
| Sset : ident -> expr -> stmt
| Sstore : memory_chunk -> expr -> expr -> stmt
| Scall : option ident -> signature -> expr -> list expr -> stmt
@@ -82,50 +74,21 @@ with lbl_stmt : Type :=
| LSdefault: stmt -> lbl_stmt
| LScase: int -> stmt -> lbl_stmt -> lbl_stmt.
-(** The variables can be either scalar variables
- (whose type, size and signedness are given by a [memory_chunk]
- or array variables (of the indicated sizes and alignment).
- The only operation permitted on an array variable is taking its address. *)
-
-Inductive var_kind : Type :=
- | Vscalar(chunk: memory_chunk)
- | Varray(sz al: Z).
-
-Definition sizeof (lv: var_kind) : Z :=
- match lv with
- | Vscalar chunk => size_chunk chunk
- | Varray sz al => Zmax 0 sz
- end.
-
-Definition type_of_kind (lv: var_kind) : typ :=
- match lv with
- | Vscalar chunk => type_of_chunk chunk
- | Varray _ _ => Tint
- end.
-
-(** Functions are composed of a return type, a list of parameter names
- with associated [var_kind] descriptions, a list of
- local variables with associated [var_kind] descriptions, and a
- statement representing the function body. *)
-
-Definition variable_name (v: ident * var_kind) := fst v.
-Definition variable_kind (v: ident * var_kind) := snd v.
+(** Functions are composed of a return type, a list of parameter names,
+ a list of local variables with their sizes, a list of temporary variables,
+ and a statement representing the function body. *)
Record function : Type := mkfunction {
- fn_return: option typ;
- fn_params: list (ident * var_kind);
- fn_vars: list (ident * var_kind);
+ fn_sig: signature;
+ fn_params: list ident;
+ fn_vars: list (ident * Z);
fn_temps: list ident;
fn_body: stmt
}.
Definition fundef := AST.fundef function.
-Definition program : Type := AST.program fundef var_kind.
-
-Definition fn_sig (f: function) :=
- mksignature (List.map type_of_kind (List.map variable_kind f.(fn_params)))
- f.(fn_return).
+Definition program : Type := AST.program fundef unit.
Definition funsig (fd: fundef) :=
match fd with
@@ -133,27 +96,23 @@ Definition funsig (fd: fundef) :=
| External ef => ef_sig ef
end.
-Definition fn_variables (f: function) := f.(fn_params) ++ f.(fn_vars).
-
-Definition fn_params_names (f: function) := List.map variable_name f.(fn_params).
-Definition fn_vars_names (f: function) := List.map variable_name f.(fn_vars).
-
(** * Operational semantics *)
(** Three evaluation environments are involved:
- [genv]: global environments, map symbols and functions to memory blocks,
and maps symbols to variable informations (type [var_kind])
- [env]: local environments, map local variables
- to pairs (memory block, variable information)
+ to pairs (memory block, size)
- [temp_env]: local environments, map temporary variables to
their current values.
*)
-Definition genv := Genv.t fundef var_kind.
-Definition env := PTree.t (block * var_kind).
+Definition genv := Genv.t fundef unit.
+Definition env := PTree.t (block * Z).
Definition temp_env := PTree.t val.
-Definition empty_env : env := PTree.empty (block * var_kind).
+Definition empty_env : env := PTree.empty (block * Z).
+Definition empty_temp_env : temp_env := PTree.empty val.
(** Initialization of temporary variables *)
@@ -163,6 +122,16 @@ Fixpoint create_undef_temps (temps: list ident) : temp_env :=
| id :: temps' => PTree.set id Vundef (create_undef_temps temps')
end.
+(** Initialization of temporaries that are parameters. *)
+
+Fixpoint bind_parameters (formals: list ident) (args: list val)
+ (le: temp_env) : option temp_env :=
+ match formals, args with
+ | nil, nil => Some le
+ | id :: xl, v :: vl => bind_parameters xl vl (PTree.set id v le)
+ | _, _ => None
+ end.
+
(** Continuations *)
Inductive cont: Type :=
@@ -263,7 +232,6 @@ with find_label_ls (lbl: label) (sl: lbl_stmt) (k: cont)
end
end.
-
(** Evaluation of operator applications. *)
Definition eval_constant (cst: constant) : option val :=
@@ -280,21 +248,21 @@ Definition eval_binop := Cminor.eval_binop.
bound to the reference to a fresh block of the appropriate size. *)
Inductive alloc_variables: env -> mem ->
- list (ident * var_kind) ->
+ list (ident * Z) ->
env -> mem -> Prop :=
| alloc_variables_nil:
forall e m,
alloc_variables e m nil e m
| alloc_variables_cons:
- forall e m id lv vars m1 b1 m2 e2,
- Mem.alloc m 0 (sizeof lv) = (m1, b1) ->
- alloc_variables (PTree.set id (b1, lv) e) m1 vars e2 m2 ->
- alloc_variables e m ((id, lv) :: vars) e2 m2.
+ forall e m id sz vars m1 b1 m2 e2,
+ Mem.alloc m 0 sz = (m1, b1) ->
+ alloc_variables (PTree.set id (b1, sz) e) m1 vars e2 m2 ->
+ alloc_variables e m ((id, sz) :: vars) e2 m2.
(** List of blocks mentioned in an environment, with low and high bounds *)
-Definition block_of_binding (id_b_lv: ident * (block * var_kind)) :=
- match id_b_lv with (id, (b, lv)) => (b, 0, sizeof lv) end.
+Definition block_of_binding (id_b_sz: ident * (block * Z)) :=
+ match id_b_sz with (id, (b, sz)) => (b, 0, sz) end.
Definition blocks_of_env (e: env) : list (block * Z * Z) :=
List.map block_of_binding (PTree.elements e).
@@ -303,43 +271,14 @@ Section RELSEM.
Variable ge: genv.
-(** Initialization of local variables that are parameters. The value
- of the corresponding argument is stored into the memory block
- bound to the parameter. *)
-
-Definition val_normalized (v: val) (chunk: memory_chunk) : Prop :=
- Val.load_result chunk v = v.
-
-Inductive bind_parameters: env ->
- mem -> list (ident * var_kind) -> list val ->
- mem -> Prop :=
- | bind_parameters_nil:
- forall e m,
- bind_parameters e m nil nil m
- | bind_parameters_scalar:
- forall e m id chunk params v1 vl b m1 m2,
- PTree.get id e = Some (b, Vscalar chunk) ->
- val_normalized v1 chunk ->
- Mem.store chunk m b 0 v1 = Some m1 ->
- bind_parameters e m1 params vl m2 ->
- bind_parameters e m ((id, Vscalar chunk) :: params) (v1 :: vl) m2
- | bind_parameters_array:
- forall e m id sz al params v1 vl b m1 m2,
- PTree.get id e = Some (b, Varray sz al) ->
- extcall_memcpy_sem sz al
- ge (Vptr b Int.zero :: v1 :: nil) m E0 Vundef m1 ->
- bind_parameters e m1 params vl m2 ->
- bind_parameters e m ((id, Varray sz al) :: params) (v1 :: vl) m2.
-
-
(* Evaluation of the address of a variable:
[eval_var_addr prg ge e id b] states that variable [id]
in environment [e] evaluates to block [b]. *)
Inductive eval_var_addr: env -> ident -> block -> Prop :=
| eval_var_addr_local:
- forall e id b vi,
- PTree.get id e = Some (b, vi) ->
+ forall e id b sz,
+ PTree.get id e = Some (b, sz) ->
eval_var_addr e id b
| eval_var_addr_global:
forall e id b,
@@ -347,24 +286,6 @@ Inductive eval_var_addr: env -> ident -> block -> Prop :=
Genv.find_symbol ge id = Some b ->
eval_var_addr e id b.
-(* Evaluation of a reference to a scalar variable:
- [eval_var_ref prg ge e id b chunk] states
- that variable [id] in environment [e] evaluates to block [b]
- and is associated with the memory chunk [chunk]. *)
-
-Inductive eval_var_ref: env -> ident -> block -> memory_chunk -> Prop :=
- | eval_var_ref_local:
- forall e id b chunk,
- PTree.get id e = Some (b, Vscalar chunk) ->
- eval_var_ref e id b chunk
- | eval_var_ref_global:
- forall e id b gv chunk,
- PTree.get id e = None ->
- Genv.find_symbol ge id = Some b ->
- Genv.find_var_info ge b = Some gv ->
- gvar_info gv = Vscalar chunk ->
- eval_var_ref e id b chunk.
-
(** Evaluation of an expression: [eval_expr prg e m a v] states
that expression [a], in initial memory state [m] and local
environment [e], evaluates to value [v]. *)
@@ -376,13 +297,9 @@ Variable le: temp_env.
Variable m: mem.
Inductive eval_expr: expr -> val -> Prop :=
- | eval_Evar: forall id b chunk v,
- eval_var_ref e id b chunk ->
- Mem.load chunk m b 0 = Some v ->
- eval_expr (Evar id) v
- | eval_Etempvar: forall id v,
+ | eval_Evar: forall id v,
le!id = Some v ->
- eval_expr (Etempvar id) v
+ eval_expr (Evar id) v
| eval_Eaddrof: forall id b,
eval_var_addr e id b ->
eval_expr (Eaddrof id) (Vptr b Int.zero)
@@ -417,14 +334,6 @@ Inductive eval_exprlist: list expr -> list val -> Prop :=
End EVAL_EXPR.
-(** Execution of an assignment to a variable. *)
-
-Inductive exec_assign: env -> mem -> ident -> val -> mem -> Prop :=
- exec_assign_intro: forall e m id v b chunk m',
- eval_var_ref e id b chunk ->
- val_normalized v chunk ->
- Mem.store chunk m b 0 v = Some m' ->
- exec_assign e m id v m'.
(** One step of execution *)
@@ -438,17 +347,10 @@ Inductive step: state -> trace -> state -> Prop :=
E0 (State f Sskip k e le m)
| step_skip_call: forall f k e le m m',
is_call_cont k ->
- f.(fn_return) = None ->
Mem.free_list m (blocks_of_env e) = Some m' ->
step (State f Sskip k e le m)
E0 (Returnstate Vundef k m')
- | step_assign: forall f id a k e le m m' v,
- eval_expr e le m a v ->
- exec_assign e m id v m' ->
- step (State f (Sassign id a) k e le m)
- E0 (State f Sskip k e le m')
-
| step_set: forall f id a k e le m v,
eval_expr e le m a v ->
step (State f (Sset id a) k e le m)
@@ -526,12 +428,14 @@ Inductive step: state -> trace -> state -> Prop :=
step (State f (Sgoto lbl) k e le m)
E0 (State f s' k' e le m)
- | step_internal_function: forall f vargs k m m1 m2 e,
- list_norepet (fn_params_names f ++ fn_vars_names f) ->
- alloc_variables empty_env m (fn_variables f) e m1 ->
- bind_parameters e m1 f.(fn_params) vargs m2 ->
+ | step_internal_function: forall f vargs k m m1 e le,
+ list_norepet (map fst f.(fn_vars)) ->
+ list_norepet f.(fn_params) ->
+ list_disjoint f.(fn_params) f.(fn_temps) ->
+ alloc_variables empty_env m (fn_vars f) e m1 ->
+ bind_parameters f.(fn_params) vargs (create_undef_temps f.(fn_temps)) = Some le ->
step (Callstate (Internal f) vargs k m)
- E0 (State f f.(fn_body) k e (create_undef_temps f.(fn_temps)) m2)
+ E0 (State f f.(fn_body) k e le m1)
| step_external_function: forall ef vargs k m t vres m',
external_call ef ge vargs m t vres m' ->
diff --git a/cfrontend/Cshmgen.v b/cfrontend/Cshmgen.v
index a459297..9d518cb 100644
--- a/cfrontend/Cshmgen.v
+++ b/cfrontend/Cshmgen.v
@@ -34,36 +34,6 @@ Require Import Csharpminor.
Open Local Scope string_scope.
Open Local Scope error_monad_scope.
-(** * Operations on C types *)
-
-Definition chunk_of_type (ty: type): res memory_chunk :=
- match access_mode ty with
- | By_value chunk => OK chunk
- | _ => Error (msg "Cshmgen.chunk_of_type")
- end.
-
-(** [var_kind_of_type ty] returns the Csharpminor ``variable kind''
- (scalar or array) that corresponds to the given Clight type [ty]. *)
-
-Definition var_kind_of_type (ty: type): res var_kind :=
- match ty with
- | Tint I8 Signed _ => OK(Vscalar Mint8signed)
- | Tint I8 Unsigned _ => OK(Vscalar Mint8unsigned)
- | Tint I16 Signed _ => OK(Vscalar Mint16signed)
- | Tint I16 Unsigned _ => OK(Vscalar Mint16unsigned)
- | Tint I32 _ _ => OK(Vscalar Mint32)
- | Tint IBool _ _ => OK(Vscalar Mint8unsigned)
- | Tfloat F32 _ => OK(Vscalar Mfloat32)
- | Tfloat F64 _ => OK(Vscalar Mfloat64)
- | Tvoid => Error (msg "Cshmgen.var_kind_of_type(void)")
- | Tpointer _ _ => OK(Vscalar Mint32)
- | Tarray _ _ _ => OK(Varray (Ctypes.sizeof ty) (Ctypes.alignof ty))
- | Tfunction _ _ => Error (msg "Cshmgen.var_kind_of_type(function)")
- | Tstruct _ fList _ => OK(Varray (Ctypes.sizeof ty) (Ctypes.alignof ty))
- | Tunion _ fList _ => OK(Varray (Ctypes.sizeof ty) (Ctypes.alignof ty))
- | Tcomp_ptr _ _ => OK(Vscalar Mint32)
-end.
-
(** * Csharpminor constructors *)
(** The following functions build Csharpminor expressions that compute
@@ -284,42 +254,6 @@ Definition make_store (addr: expr) (ty: type) (rhs: expr) :=
| _ => Error (msg "Cshmgen.make_store")
end.
-(** * Reading and writing variables *)
-
-(** Determine if a C expression is a variable *)
-
-Definition is_variable (e: Clight.expr) : option ident :=
- match e with
- | Clight.Evar id _ => Some id
- | _ => None
- end.
-
-(** [var_get id ty] returns Csharpminor code that evaluates to the
- value of C variable [id] with type [ty]. Note that
- C variables of array or function type evaluate to the address
- of the corresponding Clight memory block, while variables of other types
- evaluate to the contents of the corresponding C memory block.
-*)
-
-Definition var_get (id: ident) (ty: type) :=
- match access_mode ty with
- | By_value chunk => OK (Evar id)
- | By_reference => OK (Eaddrof id)
- | By_copy => OK (Eaddrof id)
- | _ => Error (MSG "Cshmgen.var_get " :: CTX id :: nil)
- end.
-
-(** Likewise, [var_set id ty rhs] stores the value of the Csharpminor
- expression [rhs] into the Clight variable [id] of type [ty].
-*)
-
-Definition var_set (id: ident) (ty: type) (rhs: expr) :=
- match access_mode ty with
- | By_value chunk => OK (Sassign id rhs)
- | By_copy => OK (make_memcpy (Eaddrof id) rhs ty)
- | _ => Error (MSG "Cshmgen.var_set " :: CTX id :: nil)
- end.
-
(** ** Translation of operators *)
Definition transl_unop (op: Cop.unary_operation) (a: expr) (ta: type) : res expr :=
@@ -364,12 +298,12 @@ Fixpoint transl_expr (a: Clight.expr) {struct a} : res expr :=
| Clight.Econst_float n _ =>
OK(make_floatconst n)
| Clight.Evar id ty =>
- var_get id ty
+ make_load (Eaddrof id) ty
| Clight.Etempvar id ty =>
- OK(Etempvar id)
- | Clight.Ederef b _ =>
+ OK(Evar id)
+ | Clight.Ederef b ty =>
do tb <- transl_expr b;
- make_load tb (typeof a)
+ make_load tb ty
| Clight.Eaddrof b _ =>
transl_lvalue b
| Clight.Eunop op b _ =>
@@ -472,15 +406,9 @@ Fixpoint transl_statement (tyret: type) (nbrk ncnt: nat)
| Clight.Sskip =>
OK Sskip
| Clight.Sassign b c =>
- match is_variable b with
- | Some id =>
- do tc <- transl_expr c;
- var_set id (typeof b) (make_cast (typeof c) (typeof b) tc)
- | None =>
- do tb <- transl_lvalue b;
- do tc <- transl_expr c;
- make_store tb (typeof b) (make_cast (typeof c) (typeof b) tc)
- end
+ do tb <- transl_lvalue b;
+ do tc <- transl_expr c;
+ make_store tb (typeof b) (make_cast (typeof c) (typeof b) tc)
| Clight.Sset x b =>
do tb <- transl_expr b;
OK(Sset x tb)
@@ -543,29 +471,19 @@ with transl_lbl_stmt (tyret: type) (nbrk ncnt: nat)
(*** Translation of functions *)
-Definition prefix_var_name (id: ident) : errmsg :=
- MSG "In local variable " :: CTX id :: MSG ": " :: nil.
-
-Fixpoint transl_vars (l: list (ident * type)) : res (list (ident * var_kind)) :=
- match l with
- | nil => OK nil
- | (id, ty) :: l' =>
- match var_kind_of_type ty with
- | Error msg => Error (MSG "In local variable " :: CTX id :: MSG ": " :: msg)
- | OK vk =>
- do tl' <- transl_vars l'; OK ((id, vk) :: tl')
- end
- end.
+Definition transl_var (v: ident * type) := (fst v, sizeof (snd v)).
+
+Definition signature_of_function (f: Clight.function) :=
+ mksignature (map typ_of_type (map snd (Clight.fn_params f)))
+ (opttyp_of_type (Clight.fn_return f)).
Definition transl_function (f: Clight.function) : res function :=
- do tparams <- transl_vars (Clight.fn_params f);
- do tvars <- transl_vars (Clight.fn_vars f);
do tbody <- transl_statement f.(Clight.fn_return) 1%nat 0%nat (Clight.fn_body f);
OK (mkfunction
- (opttyp_of_type (Clight.fn_return f))
- tparams
- tvars
- (List.map (@fst ident type) f.(Clight.fn_temps))
+ (signature_of_function f)
+ (map fst (Clight.fn_params f))
+ (map transl_var (Clight.fn_vars f))
+ (map fst (Clight.fn_temps f))
tbody).
Definition list_typ_eq:
@@ -587,7 +505,7 @@ Definition transl_fundef (f: Clight.fundef) : res fundef :=
(** ** Translation of programs *)
-Definition transl_globvar (ty: type) := var_kind_of_type ty.
+Definition transl_globvar (ty: type) := OK tt.
Definition transl_program (p: Clight.program) : res program :=
transform_partial_program2 transl_fundef transl_globvar p.
diff --git a/cfrontend/Cshmgenproof.v b/cfrontend/Cshmgenproof.v
index 2f319d0..42eae5d 100644
--- a/cfrontend/Cshmgenproof.v
+++ b/cfrontend/Cshmgenproof.v
@@ -32,24 +32,11 @@ Require Import Cshmgen.
(** * Properties of operations over types *)
-Remark type_of_kind_of_type:
- forall t k,
- var_kind_of_type t = OK k -> type_of_kind k = typ_of_type t.
-Proof.
- intros. destruct t; try (monadInv H); auto.
- destruct i; destruct s; monadInv H; auto.
- destruct f; monadInv H; auto.
-Qed.
-
Remark transl_params_types:
- forall p tp,
- transl_vars p = OK tp ->
- map type_of_kind (map variable_kind tp) = typlist_of_typelist (type_of_params p).
+ forall params,
+ map typ_of_type (map snd params) = typlist_of_typelist (type_of_params params).
Proof.
- induction p; simpl; intros.
- inv H. auto.
- destruct a as [id ty]. destruct (var_kind_of_type ty) as []_eqn; monadInv H.
- simpl. f_equal; auto. apply type_of_kind_of_type; auto.
+ induction params; simpl. auto. destruct a as [id ty]; simpl. f_equal; auto.
Qed.
Lemma transl_fundef_sig1:
@@ -60,8 +47,8 @@ Lemma transl_fundef_sig1:
Proof.
intros. destruct f; simpl in *.
monadInv H. monadInv EQ. simpl. inversion H0.
- unfold fn_sig; simpl. unfold signature_of_type. f_equal.
- apply transl_params_types; auto.
+ unfold signature_of_function, signature_of_type.
+ f_equal. apply transl_params_types.
destruct (list_typ_eq (sig_args (ef_sig e)) (typlist_of_typelist t)); simpl in H.
destruct (opt_typ_eq (sig_res (ef_sig e)) (opttyp_of_type t0)); simpl in H.
inv H. simpl. destruct (ef_sig e); simpl in *. inv H0.
@@ -80,6 +67,7 @@ Proof.
rewrite H0; reflexivity.
Qed.
+(*
Lemma var_kind_by_value:
forall ty chunk,
access_mode ty = By_value chunk ->
@@ -113,7 +101,8 @@ Proof.
destruct ty; try (destruct i; try destruct s); try (destruct f);
simpl; intro EQ; inversion EQ; subst vk; auto.
Qed.
-
+*)
+(****
Remark cast_int_int_normalized:
forall sz si a chunk n,
access_mode (Tint sz si a) = By_value chunk ->
@@ -212,58 +201,13 @@ Proof.
split. exists v1; exists (typeof a); auto. eauto.
Qed.
-(** * Properties of the translation functions *)
-
-Lemma transl_vars_names:
- forall vars tvars,
- transl_vars vars = OK tvars ->
- List.map variable_name tvars = var_names vars.
-Proof.
- induction vars; simpl; intros.
- monadInv H. auto.
- destruct a as [id ty]. destruct (var_kind_of_type ty); monadInv H.
- simpl. decEq; auto.
-Qed.
-
-Lemma transl_names_norepet:
- forall params vars sg tparams tvars temps body,
- list_norepet (var_names params ++ var_names vars) ->
- transl_vars params = OK tparams ->
- transl_vars vars = OK tvars ->
- let f := Csharpminor.mkfunction sg tparams tvars temps body in
- list_norepet (fn_params_names f ++ fn_vars_names f).
-Proof.
- intros. unfold fn_params_names, fn_vars_names; simpl.
- rewrite (transl_vars_names _ _ H0).
- rewrite (transl_vars_names _ _ H1).
- auto.
-Qed.
+*******)
-Lemma transl_vars_append:
- forall l1 l2 tl1 tl2,
- transl_vars l1 = OK tl1 -> transl_vars l2 = OK tl2 ->
- transl_vars (l1 ++ l2) = OK (tl1 ++ tl2).
-Proof.
- induction l1; simpl; intros.
- inv H. auto.
- destruct a as [id ty]. destruct (var_kind_of_type ty); monadInv H.
- erewrite IHl1; eauto. simpl. auto.
-Qed.
-
-Lemma transl_fn_variables:
- forall params vars sg tparams tvars temps body,
- transl_vars params = OK tparams ->
- transl_vars vars = OK tvars ->
- let f := Csharpminor.mkfunction sg tparams tvars temps body in
- transl_vars (params ++ vars) = OK (fn_variables f).
-Proof.
- intros.
- rewrite (transl_vars_append _ _ _ _ H H0).
- reflexivity.
-Qed.
+(** * Properties of the translation functions *)
(** Transformation of expressions and statements. *)
+(*
Lemma is_variable_correct:
forall a id,
is_variable a = Some id ->
@@ -272,29 +216,28 @@ Proof.
intros until id. unfold is_variable; destruct a; intros; try discriminate.
simpl. congruence.
Qed.
+*)
Lemma transl_expr_lvalue:
forall ge e le m a loc ofs ta,
Clight.eval_lvalue ge e le m a loc ofs ->
transl_expr a = OK ta ->
- (exists id, exists ty, a = Clight.Evar id ty /\ var_get id ty = OK ta) \/
- (exists tb, transl_lvalue a = OK tb /\
- make_load tb (typeof a) = OK ta).
+ (exists tb, transl_lvalue a = OK tb /\ make_load tb (typeof a) = OK ta).
Proof.
- intros until ta; intros EVAL TR. inv EVAL.
+ intros until ta; intros EVAL TR. inv EVAL; simpl in TR.
(* var local *)
- left; exists id; exists ty; auto.
+ exists (Eaddrof id); auto.
(* var global *)
- left; exists id; exists ty; auto.
+ exists (Eaddrof id); auto.
(* deref *)
- monadInv TR. right. exists x; split; auto.
+ monadInv TR. exists x; auto.
(* field struct *)
- simpl in TR. rewrite H0 in TR. monadInv TR.
- right. econstructor; split. simpl. rewrite H0.
+ rewrite H0 in TR. monadInv TR.
+ econstructor; split. simpl. rewrite H0.
rewrite EQ; rewrite EQ1; simpl; eauto. auto.
(* field union *)
- simpl in TR. rewrite H0 in TR. monadInv TR.
- right. econstructor; split. simpl. rewrite H0. rewrite EQ; simpl; eauto. auto.
+ rewrite H0 in TR. monadInv TR.
+ econstructor; split. simpl. rewrite H0. rewrite EQ; simpl; eauto. auto.
Qed.
(** Properties of labeled statements *)
@@ -806,34 +749,20 @@ Record match_env (e: Clight.env) (te: Csharpminor.env) : Prop :=
mk_match_env {
me_local:
forall id b ty,
- e!id = Some (b, ty) ->
- exists vk, var_kind_of_type ty = OK vk /\ te!id = Some (b, vk);
+ e!id = Some (b, ty) -> te!id = Some(b, sizeof ty);
me_local_inv:
- forall id b vk,
- te!id = Some (b, vk) -> exists ty, e!id = Some(b, ty)
+ forall id b sz,
+ te!id = Some (b, sz) -> exists ty, e!id = Some(b, ty)
}.
Lemma match_env_globals:
- forall e te id l ty,
+ forall e te id,
match_env e te ->
e!id = None ->
- Genv.find_symbol ge id = Some l ->
- type_of_global ge l = Some ty ->
- te!id = None /\
- (forall chunk, access_mode ty = By_value chunk ->
- exists gv, Genv.find_var_info tge l = Some gv /\ gvar_info gv = Vscalar chunk).
+ te!id = None.
Proof.
- intros.
- case_eq (te!id). intros [b' vk] EQ.
- exploit me_local_inv; eauto. intros [ty' EQ']. congruence.
- intros. split; auto; intros.
- revert H2; unfold type_of_global.
- case_eq (Genv.find_var_info ge l). intros. inv H5.
- exploit var_info_translated; eauto. intros [gv [A B]]. monadInv B. unfold transl_globvar in EQ.
- econstructor; split. eauto. simpl.
- exploit var_kind_by_value; eauto. congruence.
- intros. destruct (Genv.find_funct_ptr ge l); intros; inv H5.
- destruct f; simpl in H4; discriminate.
+ intros. destruct (te!id) as [[b sz] | ]_eqn; auto.
+ exploit me_local_inv; eauto. intros [ty EQ]. congruence.
Qed.
Lemma match_env_same_blocks:
@@ -842,29 +771,25 @@ Lemma match_env_same_blocks:
blocks_of_env te = Clight.blocks_of_env e.
Proof.
intros.
- set (R := fun (x: (block * type)) (y: (block * var_kind)) =>
+ set (R := fun (x: (block * type)) (y: (block * Z)) =>
match x, y with
- | (b1, ty), (b2, vk) => b2 = b1 /\ var_kind_of_type ty = OK vk
+ | (b1, ty), (b2, sz) => b2 = b1 /\ sz = sizeof ty
end).
assert (list_forall2
(fun i_x i_y => fst i_x = fst i_y /\ R (snd i_x) (snd i_y))
(PTree.elements e) (PTree.elements te)).
apply PTree.elements_canonical_order.
- intros id [b ty] GET. exploit me_local; eauto. intros [vk [A B]].
- exists (b, vk); split; auto. red. auto.
- intros id [b vk] GET.
- exploit me_local_inv; eauto. intros [ty A].
- exploit me_local; eauto. intros [vk' [B C]].
- assert (vk' = vk) by congruence. subst vk'.
- exists (b, ty); split; auto. red. auto.
+ intros id [b ty] GET. exists (b, sizeof ty); split. eapply me_local; eauto. red; auto.
+ intros id [b sz] GET. exploit me_local_inv; eauto. intros [ty EQ].
+ exploit me_local; eauto. intros EQ1.
+ exists (b, ty); split. auto. red; split; congruence.
unfold blocks_of_env, Clight.blocks_of_env.
generalize H0. induction 1. auto.
simpl. f_equal; auto.
unfold block_of_binding, Clight.block_of_binding.
- destruct a1 as [id1 [blk1 ty1]]. destruct b1 as [id2 [blk2 vk2]].
- simpl in *. destruct H1 as [A [B C]]. subst blk2 id2. f_equal.
- apply sizeof_var_kind_of_type. auto.
+ destruct a1 as [id1 [blk1 ty1]]. destruct b1 as [id2 [blk2 sz2]].
+ simpl in *. destruct H1 as [A [B C]]. congruence.
Qed.
Lemma match_env_free_blocks:
@@ -881,8 +806,8 @@ Lemma match_env_empty:
Proof.
unfold Clight.empty_env, Csharpminor.empty_env.
constructor.
- intros until b. repeat rewrite PTree.gempty. congruence.
- intros until vk. rewrite PTree.gempty. congruence.
+ intros until ty. repeat rewrite PTree.gempty. congruence.
+ intros until sz. rewrite PTree.gempty. congruence.
Qed.
(** The following lemmas establish the [match_env] invariant at
@@ -892,177 +817,42 @@ Qed.
Lemma match_env_alloc_variables:
forall e1 m1 vars e2 m2,
Clight.alloc_variables e1 m1 vars e2 m2 ->
- forall te1 tvars,
+ forall te1,
match_env e1 te1 ->
- transl_vars vars = OK tvars ->
exists te2,
- Csharpminor.alloc_variables te1 m1 tvars te2 m2
+ Csharpminor.alloc_variables te1 m1 (map transl_var vars) te2 m2
/\ match_env e2 te2.
Proof.
- induction 1; intros.
- monadInv H0.
+ induction 1; intros; simpl.
exists te1; split. constructor. auto.
- generalize H2. simpl.
- caseEq (var_kind_of_type ty); simpl; [intros vk VK | congruence].
- caseEq (transl_vars vars); simpl; [intros tvrs TVARS | congruence].
- intro EQ; inversion EQ; subst tvars; clear EQ.
- set (te2 := PTree.set id (b1, vk) te1).
- assert (match_env (PTree.set id (b1, ty) e) te2).
- inversion H1. unfold te2. constructor.
+ exploit (IHalloc_variables (PTree.set id (b1, sizeof ty) te1)).
+ constructor.
(* me_local *)
- intros until ty0. simpl. repeat rewrite PTree.gsspec.
- destruct (peq id0 id); intros.
- inv H3. exists vk; intuition.
- auto.
+ intros until ty0. repeat rewrite PTree.gsspec.
+ destruct (peq id0 id); intros. congruence. eapply me_local; eauto.
(* me_local_inv *)
- intros until vk0. repeat rewrite PTree.gsspec.
- destruct (peq id0 id); intros. exists ty; congruence. eauto.
- destruct (IHalloc_variables _ _ H3 TVARS) as [te3 [ALLOC MENV]].
- exists te3; split.
- econstructor; eauto.
- rewrite (sizeof_var_kind_of_type _ _ VK). eauto.
- auto.
+ intros until sz. repeat rewrite PTree.gsspec.
+ destruct (peq id0 id); intros. exists ty; congruence. eapply me_local_inv; eauto.
+ intros [te2 [ALLOC MENV]].
+ exists te2; split. econstructor; eauto. auto.
Qed.
-Lemma bind_parameters_match:
- forall e m1 vars vals m2,
- Clight.bind_parameters e m1 vars vals m2 ->
- forall te tvars,
- val_casted_list vals (type_of_params vars) ->
- match_env e te ->
- transl_vars vars = OK tvars ->
- Csharpminor.bind_parameters tge te m1 tvars vals m2.
-Proof.
- induction 1; intros.
-(* base case *)
- monadInv H1. constructor.
-(* inductive case *)
- simpl in H2. destruct H2.
- simpl in H4. destruct (var_kind_of_type ty) as [vk|]_eqn; monadInv H4.
- inv H0.
- (* scalar case *)
- assert (vk = Vscalar chunk). exploit var_kind_by_value; eauto. congruence.
- subst vk.
- apply bind_parameters_scalar with b m1.
- exploit me_local; eauto. intros [vk [A B]]. congruence.
- eapply val_casted_normalized; eauto.
- assumption.
- apply IHbind_parameters; auto.
- (* struct case *)
- exploit var_kind_by_reference; eauto. intros; subst vk.
- apply bind_parameters_array with b m1.
- exploit me_local; eauto. intros [vk [A B]]. congruence.
- econstructor; eauto.
- apply alignof_1248.
- apply sizeof_pos.
- apply sizeof_alignof_compat.
- apply IHbind_parameters; auto.
-Qed.
-
Lemma create_undef_temps_match:
forall temps,
- create_undef_temps (List.map (@fst ident type) temps) = Clight.create_undef_temps temps.
+ create_undef_temps (map fst temps) = Clight.create_undef_temps temps.
Proof.
induction temps; simpl. auto.
destruct a as [id ty]. simpl. decEq. auto.
Qed.
-(* ** Correctness of variable accessors *)
-
-(** Correctness of the code generated by [var_get]. *)
-
-Lemma var_get_correct:
- forall e le m id ty loc ofs v code te,
- Clight.eval_lvalue ge e le m (Clight.Evar id ty) loc ofs ->
- deref_loc ty m loc ofs v ->
- var_get id ty = OK code ->
- match_env e te ->
- eval_expr tge te le m code v.
-Proof.
- unfold var_get; intros.
- inv H0.
- (* access mode By_value *)
- rewrite H3 in H1. inv H1. inv H.
- (* local variable *)
- exploit me_local; eauto. intros [vk [A B]].
- assert (vk = Vscalar chunk).
- exploit var_kind_by_value; eauto. congruence.
- subst vk.
- eapply eval_Evar.
- eapply eval_var_ref_local. eauto. assumption.
- (* global variable *)
- exploit match_env_globals; eauto. intros [A B].
- exploit B; eauto. intros [gv [C D]].
- eapply eval_Evar.
- eapply eval_var_ref_global. auto.
- rewrite symbols_preserved. eauto.
- eauto. eauto.
- assumption.
- (* access mode By_reference *)
- rewrite H3 in H1. inv H1. inv H.
- (* local variable *)
- exploit me_local; eauto. intros [vk [A B]].
- eapply eval_Eaddrof.
- eapply eval_var_addr_local. eauto.
- (* global variable *)
- exploit match_env_globals; eauto. intros [A B].
- eapply eval_Eaddrof.
- eapply eval_var_addr_global. auto.
- rewrite symbols_preserved. eauto.
- (* access mode By_copy *)
- rewrite H3 in H1. inv H1. inv H.
- (* local variable *)
- exploit me_local; eauto. intros [vk [A B]].
- eapply eval_Eaddrof.
- eapply eval_var_addr_local. eauto.
- (* global variable *)
- exploit match_env_globals; eauto. intros [A B].
- eapply eval_Eaddrof.
- eapply eval_var_addr_global. auto.
- rewrite symbols_preserved. eauto.
-Qed.
-
-(** Correctness of the code generated by [var_set]. *)
-
-Lemma var_set_correct:
- forall e le m id ty loc ofs v m' code te rhs f k,
- Clight.eval_lvalue ge e le m (Clight.Evar id ty) loc ofs ->
- val_casted v ty ->
- assign_loc ty m loc ofs v m' ->
- var_set id ty rhs = OK code ->
- match_env e te ->
- eval_expr tge te le m rhs v ->
- step tge (State f code k te le m) E0 (State f Sskip k te le m').
+Lemma bind_parameter_temps_match:
+ forall vars vals le1 le2,
+ Clight.bind_parameter_temps vars vals le1 = Some le2 ->
+ bind_parameters (map fst vars) vals le1 = Some le2.
Proof.
- intros. unfold var_set in H2.
- inversion H1; subst; rewrite H5 in H2; inv H2.
- (* scalar, non volatile *)
- inv H.
- (* local variable *)
- exploit me_local; eauto. intros [vk [A B]].
- assert (vk = Vscalar chunk).
- exploit var_kind_by_value; eauto. congruence.
- subst vk.
- eapply step_assign. eauto.
- econstructor. eapply eval_var_ref_local. eauto.
- eapply val_casted_normalized; eauto. assumption.
- (* global variable *)
- exploit match_env_globals; eauto. intros [A B].
- exploit B; eauto. intros [gv [C D]].
- eapply step_assign. eauto.
- econstructor. eapply eval_var_ref_global. auto.
- rewrite symbols_preserved. eauto.
- eauto. eauto.
- eapply val_casted_normalized; eauto. assumption.
- (* struct *)
- assert (eval_expr tge te le m (Eaddrof id) (Vptr loc ofs)).
- inv H.
- exploit me_local; eauto. intros [vk [A B]].
- constructor. eapply eval_var_addr_local; eauto.
- exploit match_env_globals; eauto. intros [A B].
- constructor. eapply eval_var_addr_global; eauto.
- rewrite symbols_preserved. eauto.
- eapply make_memcpy_correct; eauto.
+ induction vars; simpl; intros.
+ destruct vals; inv H. auto.
+ destruct a as [id ty]. destruct vals; try discriminate. auto.
Qed.
(** * Proof of semantic preservation *)
@@ -1123,19 +913,14 @@ Proof.
(* cast *)
eapply make_cast_correct; eauto.
(* rvalue out of lvalue *)
- exploit transl_expr_lvalue; eauto.
- intros [[id [ty [EQ VARGET]]] | [tb [TRLVAL MKLOAD]]].
- (* Case a is a variable *)
- subst a. eapply var_get_correct; eauto.
- (* Case a is another lvalue *)
+ exploit transl_expr_lvalue; eauto. intros [tb [TRLVAL MKLOAD]].
eapply make_load_correct; eauto.
(* var local *)
- exploit (me_local _ _ MENV); eauto.
- intros [vk [A B]].
+ exploit (me_local _ _ MENV); eauto. intros EQ.
econstructor. eapply eval_var_addr_local. eauto.
(* var global *)
- exploit match_env_globals; eauto. intros [A B].
- econstructor. eapply eval_var_addr_global. eauto.
+ econstructor. eapply eval_var_addr_global.
+ eapply match_env_globals; eauto.
rewrite symbols_preserved. auto.
(* deref *)
simpl in TR. eauto.
@@ -1261,8 +1046,7 @@ Inductive match_states: Clight.state -> Csharpminor.state -> Prop :=
(TR: transl_fundef fd = OK tfd)
(MK: match_cont Tvoid 0%nat 0%nat k tk)
(ISCC: Clight.is_call_cont k)
- (TY: type_of_fundef fd = Tfunction targs tres)
- (VCAST: val_casted_list args targs),
+ (TY: type_of_fundef fd = Tfunction targs tres),
match_states (Clight.Callstate fd args k m)
(Callstate tfd args tk m)
| match_returnstate:
@@ -1318,10 +1102,6 @@ Proof.
(* skip *)
auto.
(* assign *)
- simpl in TR.
- destruct (is_variable e); monadInv TR.
- unfold var_set, make_memcpy in EQ0.
- destruct (access_mode (typeof e)); inv EQ0; auto.
unfold make_store, make_memcpy in EQ2.
destruct (access_mode (typeof e)); inv EQ2; auto.
(* set *)
@@ -1405,26 +1185,14 @@ Qed.
(** The simulation proof *)
Lemma transl_step:
- forall S1 t S2, Clight.step ge S1 t S2 ->
+ forall S1 t S2, Clight.step2 ge S1 t S2 ->
forall T1, match_states S1 T1 ->
exists T2, plus step tge T1 t T2 /\ match_states S2 T2.
Proof.
induction 1; intros T1 MST; inv MST.
(* assign *)
- simpl in TR.
- destruct (is_variable a1) as []_eqn; monadInv TR.
- (* a variable *)
- assert (SAME: ts' = ts /\ tk' = tk).
- inversion MTR. auto.
- subst ts. unfold var_set, make_memcpy in EQ0. destruct (access_mode (typeof a1)); congruence.
- destruct SAME; subst ts' tk'.
- exploit is_variable_correct; eauto. intro EQ1. rewrite EQ1 in H.
- econstructor; split.
- apply plus_one. eapply var_set_correct; eauto. exists v2; exists (typeof a2); auto.
- eapply make_cast_correct; eauto. eapply transl_expr_correct; eauto.
- eapply match_states_skip; eauto.
- (* not a variable *)
+ monadInv TR.
assert (SAME: ts' = ts /\ tk' = tk).
inversion MTR. auto.
subst ts. unfold make_store, make_memcpy in EQ2. destruct (access_mode (typeof a1)); congruence.
@@ -1454,7 +1222,6 @@ Proof.
econstructor; eauto.
econstructor; eauto.
simpl. auto.
- eapply eval_exprlist_casted; eauto.
(* builtin *)
monadInv TR. inv MTR.
@@ -1569,7 +1336,6 @@ Proof.
exploit match_cont_is_call_cont; eauto. intros [A B].
econstructor; split.
apply plus_one. apply step_skip_call. auto.
- monadInv TRF. simpl. rewrite H0. auto.
eapply match_env_free_blocks; eauto.
constructor. eauto.
@@ -1608,7 +1374,7 @@ Proof.
(* goto *)
monadInv TR. inv MTR.
generalize TRF. unfold transl_function. intro TRF'. monadInv TRF'.
- exploit (transl_find_label lbl). eexact EQ0. eapply match_cont_call_cont. eauto.
+ exploit (transl_find_label lbl). eexact EQ. eapply match_cont_call_cont. eauto.
rewrite H.
intros [ts' [tk'' [nbrk' [ncnt' [A [B C]]]]]].
econstructor; split.
@@ -1616,20 +1382,20 @@ Proof.
econstructor; eauto. constructor.
(* internal function *)
- monadInv TR. monadInv EQ.
+ inv H. monadInv TR. monadInv EQ.
exploit match_cont_is_call_cont; eauto. intros [A B].
exploit match_env_alloc_variables; eauto.
apply match_env_empty.
- eapply transl_fn_variables; eauto.
intros [te1 [C D]].
econstructor; split.
- apply plus_one. econstructor.
- eapply transl_names_norepet; eauto.
- eexact C. eapply bind_parameters_match; eauto.
- simpl in TY. unfold type_of_function in TY. congruence.
- simpl. rewrite (create_undef_temps_match (Clight.fn_temps f)).
- econstructor; eauto.
- unfold transl_function. rewrite EQ0; simpl. rewrite EQ; simpl. rewrite EQ1; auto.
+ apply plus_one. eapply step_internal_function.
+ simpl. rewrite list_map_compose. simpl. assumption.
+ simpl. auto.
+ simpl. auto.
+ simpl. eauto.
+ simpl. rewrite create_undef_temps_match. eapply bind_parameter_temps_match; eauto.
+ simpl. econstructor; eauto.
+ unfold transl_function. rewrite EQ0; simpl. auto.
constructor.
(* external function *)
@@ -1667,7 +1433,7 @@ Proof.
eapply transl_fundef_sig2; eauto.
econstructor; split.
econstructor; eauto. eapply Genv.init_mem_transf_partial2; eauto.
- econstructor; eauto. constructor; auto. exact I. red; auto.
+ econstructor; eauto. constructor; auto. exact I.
Qed.
Lemma transl_final_states:
@@ -1678,7 +1444,7 @@ Proof.
Qed.
Theorem transl_program_correct:
- forward_simulation (Clight.semantics prog) (Csharpminor.semantics tprog).
+ forward_simulation (Clight.semantics2 prog) (Csharpminor.semantics tprog).
Proof.
eapply forward_simulation_plus.
eexact symbols_preserved.
diff --git a/cfrontend/ExportClight.ml b/cfrontend/ExportClight.ml
new file mode 100644
index 0000000..e456d6e
--- /dev/null
+++ b/cfrontend/ExportClight.ml
@@ -0,0 +1,534 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(** Export Clight as a Coq file *)
+
+open Format
+open Camlcoq
+open Datatypes
+open Values
+open AST
+open Ctypes
+open Cop
+open Clight
+
+(* Options, lists, pairs *)
+
+let print_option fn p = function
+ | None -> fprintf p "None"
+ | Some x -> fprintf p "(Some %a)" fn x
+
+let print_pair fn1 fn2 p (x1, x2) =
+ fprintf p "@[<hov 1>(%a,@ %a)@]" fn1 x1 fn2 x2
+
+let print_list fn p l =
+ match l with
+ | [] ->
+ fprintf p "nil"
+ | hd :: tl ->
+ fprintf p "@[<hov 1>(";
+ let rec plist = function
+ | [] -> fprintf p "nil"
+ | hd :: tl -> fprintf p "%a ::@ " fn hd; plist tl
+ in plist l;
+ fprintf p ")@]"
+
+(* Identifiers *)
+
+exception Not_an_identifier
+
+let sanitize s =
+ let s' = String.create (String.length s) in
+ for i = 0 to String.length s - 1 do
+ s'.[i] <-
+ match s.[i] with
+ | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' as c -> c
+ | ' ' | '$' -> '_'
+ | _ -> raise Not_an_identifier
+ done;
+ s'
+
+let ident p id =
+ try
+ let s = Hashtbl.find string_of_atom id in
+ fprintf p "_%s" (sanitize s)
+ with Not_found | Not_an_identifier ->
+ fprintf p "%ld%%positive" (camlint_of_positive id)
+
+let define_idents p =
+ Hashtbl.iter
+ (fun id name ->
+ try
+ fprintf p "Definition _%s : ident := %ld%%positive.@ "
+ (sanitize name) (camlint_of_positive id)
+ with Not_an_identifier ->
+ ())
+ string_of_atom;
+ fprintf p "@ "
+
+(* Numbers *)
+
+let coqint p n =
+ let n = camlint_of_coqint n in
+ if n >= 0l
+ then fprintf p "(Int.repr %ld)" n
+ else fprintf p "(Int.repr (%ld))" n
+
+let coqfloat p n =
+ let n = camlint64_of_coqint(Floats.Float.bits_of_double n) in
+ if n >= 0L
+ then fprintf p "(Float.double_of_bits (Int64.repr %Ld))" n
+ else fprintf p "(Float.double_of_bits (Int64.repr (%Ld)))" n
+
+(* Types *)
+
+let use_struct_names = ref true
+
+let rec typ p t =
+ let a = attr_of_type t in
+ if a (*.attr_volatile*)
+ then fprintf p "(tvolatile %a)" rtyp t
+ else rtyp p t
+
+and rtyp p = function
+ | Tvoid -> fprintf p "tvoid"
+ | Tint(sz, sg, _) ->
+ fprintf p "%s" (
+ match sz, sg with
+ | I8, Signed -> "tschar"
+ | I8, Unsigned -> "tuchar"
+ | I16, Signed -> "tshort"
+ | I16, Unsigned -> "tushort"
+ | I32, Signed -> "tint"
+ | I32, Unsigned -> "tuint"
+ | IBool, _ -> "tbool")
+ | Tfloat(sz, _) ->
+ fprintf p "%s" (
+ match sz with
+ | F32 -> "tfloat"
+ | F64 -> "tdouble")
+ | Tpointer(t, _) ->
+ fprintf p "(tptr %a)" typ t
+ | Tarray(t, sz, _) ->
+ fprintf p "(tarray %a %ld)" typ t (camlint_of_z sz)
+ | Tfunction(targs, tres) ->
+ fprintf p "@[<hov 2>(Tfunction@ %a@ %a)@]" typlist targs typ tres
+ | Tstruct(id, flds, _) ->
+ if !use_struct_names
+ then fprintf p "t%a" ident id
+ else fprintf p "@[<hov 2>(Tstruct %a@ %a@ noattr)@]" ident id fieldlist flds
+ | Tunion(id, flds, _) ->
+ if !use_struct_names
+ then fprintf p "t%a" ident id
+ else fprintf p "@[<hov 2>(Tunion %a@ %a@ noattr)@]" ident id fieldlist flds
+ | Tcomp_ptr(id, _) ->
+ fprintf p "(Tcomp_ptr %a noattr)" ident id
+
+and typlist p = function
+ | Tnil ->
+ fprintf p "Tnil"
+ | Tcons(t, tl) ->
+ fprintf p "@[<hov 2>(Tcons@ %a@ %a)@]" typ t typlist tl
+
+and fieldlist p = function
+ | Fnil ->
+ fprintf p "Fnil"
+ | Fcons(id, t, fl) ->
+ fprintf p "@[<hov 2>(Fcons %a@ %a@ %a)@]" ident id typ t fieldlist fl
+
+(* External functions *)
+
+let asttype p t =
+ fprintf p "%s" (match t with AST.Tint -> "AST.Tint" | AST.Tfloat -> "AST.Tfloat")
+
+let name_of_chunk = function
+ | Mint8signed -> "Mint8signed"
+ | Mint8unsigned -> "Mint8unsigned"
+ | Mint16signed -> "Mint16signed"
+ | Mint16unsigned -> "Mint16unsigned"
+ | Mint32 -> "Mint32"
+ | Mfloat32 -> "Mfloat32"
+ | Mfloat64 -> "Mfloat64"
+ | Mfloat64al32 -> "Mfloat64al32"
+
+let signatur p sg =
+ fprintf p "@[<hov 2>(mksignature@ %a@ %a)@]" (print_list asttype) sg.sig_args (print_option asttype) sg.sig_res
+
+let assertions = ref ([]: (ident * typ list) list)
+
+let external_function p = function
+ | EF_external(name, sg) ->
+ fprintf p "@[<hov 2>(EF_external %a@ %a)@]" ident name signatur sg
+ | EF_builtin(name, sg) ->
+ fprintf p "@[<hov 2>(EF_builtin %a@ %a)@]" ident name signatur sg
+ | EF_vload chunk ->
+ fprintf p "(EF_vload %s)" (name_of_chunk chunk)
+ | EF_vstore chunk ->
+ fprintf p "(EF_vstore %s)" (name_of_chunk chunk)
+ | EF_vload_global(chunk, id, ofs) ->
+ fprintf p "(EF_vload_global %s %a %a)" (name_of_chunk chunk) ident id coqint ofs
+ | EF_vstore_global(chunk, id, ofs) ->
+ fprintf p "(EF_vstore_global %s %a %a)" (name_of_chunk chunk) ident id coqint ofs
+ | EF_malloc -> fprintf p "EF_malloc"
+ | EF_free -> fprintf p "EF_free"
+ | EF_memcpy(sz, al) ->
+ fprintf p "(EF_memcpy %ld %ld)" (camlint_of_z sz) (camlint_of_z al)
+ | EF_annot(text, targs) ->
+ assertions := (text, targs) :: !assertions;
+ fprintf p "(EF_annot %ld%%positive %a)" (camlint_of_positive text) (print_list asttype) targs
+ | EF_annot_val(text, targ) ->
+ assertions := (text, [targ]) :: !assertions;
+ fprintf p "(EF_annot_val %ld%%positive %a)" (camlint_of_positive text) asttype targ
+ | EF_inline_asm(text) ->
+ fprintf p "(EF_inline_asm %ld%%positive)" (camlint_of_positive text)
+
+(* Expressions *)
+
+let name_unop = function
+ | Onotbool -> "Onotbool"
+ | Onotint -> "Onotint"
+ | Oneg -> "Oneg"
+
+let name_binop = function
+ | Oadd -> "Oadd"
+ | Osub -> "Osub"
+ | Omul -> "Omul"
+ | Odiv -> "Odiv"
+ | Omod -> "Omod"
+ | Oand -> "Oand"
+ | Oor -> "Oor"
+ | Oxor -> "Oxor"
+ | Oshl -> "Oshl"
+ | Oshr -> "Oshr"
+ | Oeq -> "Oeq"
+ | One -> "One"
+ | Olt -> "Olt"
+ | Ogt -> "Ogt"
+ | Ole -> "Ole"
+ | Oge -> "Oge"
+
+let rec expr p = function
+ | Evar(id, t) ->
+ fprintf p "(Evar %a %a)" ident id typ t
+ | Etempvar(id, t) ->
+ fprintf p "(Etempvar %a %a)" ident id typ t
+ | Ederef(a1, t) ->
+ fprintf p "@[<hov 2>(Ederef@ %a@ %a)@]" expr a1 typ t
+ | Efield(a1, f, t) ->
+ fprintf p "@[<hov 2>(Efield@ %a@ %a@ %a)@]" expr a1 ident f typ t
+ | Econst_int(n, t) ->
+ fprintf p "(Econst_int %a %a)" coqint n typ t
+ | Econst_float(n, t) ->
+ fprintf p "(Econst_float %a %a)" coqfloat n typ t
+ | Eunop(op, a1, t) ->
+ fprintf p "@[<hov 2>(Eunop %s@ %a@ %a)@]"
+ (name_unop op) expr a1 typ t
+ | Eaddrof(a1, t) ->
+ fprintf p "@[<hov 2>(Eaddrof@ %a@ %a)@]" expr a1 typ t
+ | Ebinop(op, a1, a2, t) ->
+ fprintf p "@[<hov 2>(Ebinop %s@ %a@ %a@ %a)@]"
+ (name_binop op) expr a1 expr a2 typ t
+ | Ecast(a1, t) ->
+ fprintf p "@[<hov 2>(Ecast@ %a@ %a)@]" expr a1 typ t
+
+(* Statements *)
+
+let rec stmt p = function
+ | Sskip ->
+ fprintf p "Sskip"
+ | Sassign(e1, e2) ->
+ fprintf p "@[<hov 2>(Sassign@ %a@ %a)@]" expr e1 expr e2
+ | Sset(id, e2) ->
+ fprintf p "@[<hov 2>(Sset %a@ %a)@]" ident id expr e2
+ | Scall(optid, e1, el) ->
+ fprintf p "@[<hov 2>(Scall %a@ %a@ %a)@]"
+ (print_option ident) optid expr e1 (print_list expr) el
+ | Sbuiltin(optid, ef, tyl, el) ->
+ fprintf p "@[<hov 2>(Sbuiltin %a@ %a@ %a@ %a)@]"
+ (print_option ident) optid
+ external_function ef
+ typlist tyl
+ (print_list expr) el
+ | Ssequence(Sskip, s2) ->
+ stmt p s2
+ | Ssequence(s1, Sskip) ->
+ stmt p s1
+ | Ssequence(s1, s2) ->
+ fprintf p "@[<hov 2>(Ssequence@ %a@ %a)@]" stmt s1 stmt s2
+ | Sifthenelse(e, s1, s2) ->
+ fprintf p "@[<v 2>(Sifthenelse %a@ %a@ %a)@]" expr e stmt s1 stmt s2
+ | Sloop(s1, s2) ->
+ fprintf p "@[<v 2>(Sloop %a@ %a)@]" stmt s1 stmt s2
+ | Sbreak ->
+ fprintf p "Sbreak"
+ | Scontinue ->
+ fprintf p "Scontinue"
+ | Sswitch(e, cases) ->
+ fprintf p "@[<v 2>(Sswitch %a@ %a)@]" expr e lblstmts cases
+ | Sreturn e ->
+ fprintf p "@[<hov 2>(Sreturn %a)@]" (print_option expr) e
+ | Slabel(lbl, s1) ->
+ fprintf p "@[<hov 2>(Slabel %a@ %a)@]" ident lbl stmt s1
+ | Sgoto lbl ->
+ fprintf p "(Sgoto %a)" ident lbl
+
+and lblstmts p = function
+ | LSdefault s ->
+ fprintf p "@[<hov 2>(LSdefault@ %a)@]" stmt s
+ | LScase(lbl, s, ls) ->
+ fprintf p "@[<hov 2>(LScase %a@ %a@ %a)@]" coqint lbl stmt s lblstmts ls
+
+let print_function p (id, f) =
+ fprintf p "Definition f_%s := {|@ " (extern_atom id);
+ fprintf p " fn_return := %a;@ " typ f.fn_return;
+ fprintf p " fn_params := %a;@ " (print_list (print_pair ident typ)) f.fn_params;
+ fprintf p " fn_vars := %a;@ " (print_list (print_pair ident typ)) f.fn_vars;
+ fprintf p " fn_temps := %a;@ " (print_list (print_pair ident typ)) f.fn_temps;
+ fprintf p " fn_body :=@ ";
+ stmt p f.fn_body;
+ fprintf p "@ |}.@ @ "
+
+let init_data p = function
+ | Init_int8 n -> fprintf p "Init_int8 %a" coqint n
+ | Init_int16 n -> fprintf p "Init_int16 %a" coqint n
+ | Init_int32 n -> fprintf p "Init_int32 %a" coqint n
+ | Init_float32 n -> fprintf p "Init_float32 %a" coqfloat n
+ | Init_float64 n -> fprintf p "Init_float64 %a" coqfloat n
+ | Init_space n -> fprintf p "Init_space %ld" (camlint_of_z n)
+ | Init_addrof(id,ofs) -> fprintf p "Init_addrof %a %a" ident id coqint ofs
+
+let print_variable p (id, v) =
+ fprintf p "Definition v_%s := {|@ " (extern_atom id);
+ fprintf p " gvar_info := %a;@ " typ v.gvar_info;
+ fprintf p " gvar_init := %a;@ " (print_list init_data) v.gvar_init;
+ fprintf p " gvar_readonly := %B;@ " v.gvar_readonly;
+ fprintf p " gvar_volatile := %B@ " v.gvar_volatile;
+ fprintf p "|}.@ @ "
+
+let print_globdef p (id, gd) =
+ match gd with
+ | Gfun(Internal f) -> print_function p (id, f)
+ | Gfun(External _) -> ()
+ | Gvar v -> print_variable p (id, v)
+
+let print_ident_globdef p = function
+ | (id, Gfun(Internal f)) ->
+ fprintf p "(%a, Gfun(Internal f_%s))" ident id (extern_atom id)
+ | (id, Gfun(External(ef, targs, tres))) ->
+ fprintf p "@[<hov 2>(%a,@ @[<hov 2>Gfun(External %a@ %a@ %a))@]@]"
+ ident id external_function ef typlist targs typ tres
+ | (id, Gvar v) ->
+ fprintf p "(%a, Gvar v_%s)" ident id (extern_atom id)
+
+(* Collecting the names and fields of structs and unions *)
+
+module TypeSet = Set.Make(struct
+ type t = coq_type
+ let compare = Pervasives.compare
+end)
+
+let struct_unions = ref TypeSet.empty
+
+let register_struct_union ty =
+ struct_unions := TypeSet.add ty !struct_unions
+
+let rec collect_type = function
+ | Tvoid -> ()
+ | Tint _ -> ()
+ | Tfloat _ -> ()
+ | Tpointer(t, _) -> collect_type t
+ | Tarray(t, _, _) -> collect_type t
+ | Tfunction(args, res) -> collect_type_list args; collect_type res
+ | Tstruct(id, fld, _) ->
+ register_struct_union (Tstruct(id, fld, noattr)) (*; collect_fields fld*)
+ | Tunion(id, fld, _) ->
+ register_struct_union (Tunion(id, fld, noattr)) (*; collect_fields fld*)
+ | Tcomp_ptr _ -> ()
+
+and collect_type_list = function
+ | Tnil -> ()
+ | Tcons(hd, tl) -> collect_type hd; collect_type_list tl
+
+and collect_fields = function
+ | Fnil -> ()
+ | Fcons(id, hd, tl) -> collect_type hd; collect_fields tl
+
+let rec collect_expr e =
+ collect_type (typeof e);
+ match e with
+ | Econst_int _ -> ()
+ | Econst_float _ -> ()
+ | Evar _ -> ()
+ | Etempvar _ -> ()
+ | Ederef(r, _) -> collect_expr r
+ | Efield(l, _, _) -> collect_expr l
+ | Eaddrof(l, _) -> collect_expr l
+ | Eunop(_, r, _) -> collect_expr r
+ | Ebinop(_, r1, r2, _) -> collect_expr r1; collect_expr r2
+ | Ecast(r, _) -> collect_expr r
+
+let rec collect_exprlist = function
+ | [] -> ()
+ | r1 :: rl -> collect_expr r1; collect_exprlist rl
+
+let rec collect_stmt = function
+ | Sskip -> ()
+ | Sassign(e1, e2) -> collect_expr e1; collect_expr e2
+ | Sset(id, e2) -> collect_expr e2
+ | Scall(optid, e1, el) -> collect_expr e1; collect_exprlist el
+ | Sbuiltin(optid, ef, tyl, el) -> collect_exprlist el
+ | Ssequence(s1, s2) -> collect_stmt s1; collect_stmt s2
+ | Sifthenelse(e, s1, s2) -> collect_expr e; collect_stmt s1; collect_stmt s2
+ | Sloop(s1, s2) -> collect_stmt s1; collect_stmt s2
+ | Sbreak -> ()
+ | Scontinue -> ()
+ | Sswitch(e, cases) -> collect_expr e; collect_cases cases
+ | Sreturn None -> ()
+ | Sreturn (Some e) -> collect_expr e
+ | Slabel(lbl, s) -> collect_stmt s
+ | Sgoto lbl -> ()
+
+and collect_cases = function
+ | LSdefault s -> collect_stmt s
+ | LScase(lbl, s, rem) -> collect_stmt s; collect_cases rem
+
+let collect_function f =
+ collect_type f.fn_return;
+ List.iter (fun (id, ty) -> collect_type ty) f.fn_params;
+ List.iter (fun (id, ty) -> collect_type ty) f.fn_vars;
+ List.iter (fun (id, ty) -> collect_type ty) f.fn_temps;
+ collect_stmt f.fn_body
+
+let collect_globdef (id, gd) =
+ match gd with
+ | Gfun(External(_, args, res)) -> collect_type_list args; collect_type res
+ | Gfun(Internal f) -> collect_function f
+ | Gvar v -> collect_type v.gvar_info
+
+let define_struct p ty =
+ match ty with
+ | Tstruct(id, _, _) | Tunion(id, _, _) ->
+ fprintf p "@[<hv 2>Definition t%a :=@ %a.@]@ " ident id typ ty
+ | _ -> assert false
+
+let define_structs p prog =
+ struct_unions := TypeSet.empty;
+ List.iter collect_globdef prog.prog_defs;
+ use_struct_names := false;
+ TypeSet.iter (define_struct p) !struct_unions;
+ use_struct_names := true;
+ fprintf p "@ "
+
+(* Assertion processing *)
+
+let re_annot_param = Str.regexp "%%\\|%[1-9][0-9]*"
+
+type fragment = Text of string | Param of int
+
+let print_assertion p (txt, targs) =
+ let frags =
+ List.map
+ (function
+ | Str.Text s -> Text s
+ | Str.Delim "%%" -> Text "%"
+ | Str.Delim s -> Param(int_of_string(String.sub s 1 (String.length s - 1))))
+ (Str.full_split re_annot_param (extern_atom txt)) in
+ let max_param = ref 0 in
+ List.iter
+ (function
+ | Text _ -> ()
+ | Param n -> max_param := max n !max_param)
+ frags;
+ fprintf p " | %ld%%positive, " (camlint_of_positive txt);
+ for i = 1 to !max_param do
+ fprintf p "_x%d :: " i
+ done;
+ fprintf p "nil =>@ ";
+ fprintf p " ";
+ List.iter
+ (function
+ | Text s -> fprintf p "%s" s
+ | Param n -> fprintf p "_x%d" n)
+ frags;
+ fprintf p "@ "
+
+let print_assertions p =
+ if !assertions <> [] then begin
+ fprintf p "Definition assertions (id: ident) args : Prop :=@ ";
+ fprintf p " match id, args with@ ";
+ List.iter (print_assertion p) !assertions;
+ fprintf p " | _, _ => False@ ";
+ fprintf p " end.@ @ "
+ end
+
+(* The prologue *)
+
+let prologue = "\
+Require Import List.
+Require Import ZArith.
+Require Import Integers.
+Require Import Floats.
+Require Import AST.
+Require Import Ctypes.
+Require Import Cop.
+Require Import Clight.
+
+Local Open Scope Z_scope.
+
+Definition tvoid := Tvoid.
+Definition tschar := Tint I8 Signed noattr.
+Definition tuchar := Tint I8 Unsigned noattr.
+Definition tshort := Tint I16 Signed noattr.
+Definition tushort := Tint I16 Unsigned noattr.
+Definition tint := Tint I32 Signed noattr.
+Definition tuint := Tint I32 Unsigned noattr.
+Definition tbool := Tint IBool Unsigned noattr.
+Definition tfloat := Tfloat F32 noattr.
+Definition tdouble := Tfloat F64 noattr.
+Definition tptr (t: type) := Tpointer t noattr.
+Definition tarray (t: type) (sz: Z) := Tarray t sz noattr.
+
+Definition volatile_attr := {| attr_volatile := true |}.
+
+Definition tvolatile (ty: type) :=
+ match ty with
+ | Tvoid => Tvoid
+ | Tint sz si a => Tint sz si volatile_attr
+ | Tfloat sz a => Tfloat sz volatile_attr
+ | Tpointer elt a => Tpointer elt volatile_attr
+ | Tarray elt sz a => Tarray elt sz volatile_attr
+ | Tfunction args res => Tfunction args res
+ | Tstruct id fld a => Tstruct id fld volatile_attr
+ | Tunion id fld a => Tunion id fld volatile_attr
+ | Tcomp_ptr id a => Tcomp_ptr id volatile_attr
+ end.
+
+"
+
+(* All together *)
+
+let print_program p prog =
+ fprintf p "@[<v 0>";
+ fprintf p "%s" prologue;
+ define_idents p;
+ define_structs p prog;
+ List.iter (print_globdef p) prog.prog_defs;
+ fprintf p "Definition prog : Clight.program := {|@ ";
+ fprintf p "prog_defs :=@ %a;@ " (print_list print_ident_globdef) prog.prog_defs;
+ fprintf p "prog_main := %a@ " ident prog.prog_main;
+ fprintf p "|}.@ ";
+ print_assertions p;
+ fprintf p "@]@."
+
diff --git a/cfrontend/SimplExpr.v b/cfrontend/SimplExpr.v
index 159ba99..153f177 100644
--- a/cfrontend/SimplExpr.v
+++ b/cfrontend/SimplExpr.v
@@ -83,8 +83,10 @@ Notation "'do' ( X , Y ) <- A ; B" := (bind2 A (fun X Y => B))
Local Open Scope gensym_monad_scope.
-Definition initial_generator : generator :=
- mkgenerator 1%positive nil.
+Parameter first_unused_ident: unit -> ident.
+
+Definition initial_generator (x: unit) : generator :=
+ mkgenerator (first_unused_ident x) nil.
Definition gensym (ty: type): mon ident :=
fun (g: generator) =>
@@ -397,7 +399,8 @@ Definition transl_expr_stmt (r: C.expr) : mon statement :=
(*
Definition transl_if (r: C.expr) (s1 s2: statement) : mon statement :=
- do (sl, a) <- transl_expr (For_test nil s1 s2) r; ret (makeseq sl).
+ do (sl, a) <- transl_expr For_val r;
+ ret (makeseq (sl ++ makeif a s1 s2 :: nil)).
*)
Definition transl_if (r: C.expr) (s1 s2: statement) : mon statement :=
@@ -414,24 +417,6 @@ Proof.
destruct s; ((left; reflexivity) || (right; congruence)).
Defined.
-(** There are two possible translations for an "if then else" statement.
- One is more efficient if the condition contains "?" constructors
- but can duplicate the "then" and "else" branches.
- The other produces no code duplication. We choose between the
- two based on the shape of the "then" and "else" branches. *)
-(*
-Fixpoint small_stmt (s: statement) : bool :=
- match s with
- | Sskip => true
- | Sbreak => true
- | Scontinue => true
- | Sgoto _ => true
- | Sreturn None => true
- | Ssequence s1 s2 => small_stmt s1 && small_stmt s2
- | _ => false
- end.
-*)
-
Fixpoint transl_stmt (s: C.statement) : mon statement :=
match s with
| C.Sskip => ret Sskip
@@ -496,7 +481,7 @@ with transl_lblstmt (ls: C.labeled_statements) : mon labeled_statements :=
(** Translation of a function *)
Definition transl_function (f: C.function) : res function :=
- match transl_stmt f.(C.fn_body) initial_generator with
+ match transl_stmt f.(C.fn_body) (initial_generator tt) with
| Err msg =>
Error msg
| Res tbody g i =>
diff --git a/cfrontend/SimplExprproof.v b/cfrontend/SimplExprproof.v
index 40177f3..7fc0a46 100644
--- a/cfrontend/SimplExprproof.v
+++ b/cfrontend/SimplExprproof.v
@@ -91,7 +91,7 @@ Lemma function_return_preserved:
fn_return tf = C.fn_return f.
Proof.
intros. unfold transl_function in H.
- destruct (transl_stmt (C.fn_body f) initial_generator); inv H.
+ destruct (transl_stmt (C.fn_body f) (initial_generator tt)); inv H.
auto.
Qed.
@@ -751,7 +751,7 @@ Lemma step_makeif:
forall f a s1 s2 k e le m v1 b,
eval_expr tge e le m a v1 ->
bool_val v1 (typeof a) = Some b ->
- star step tge (State f (makeif a s1 s2) k e le m)
+ star step1 tge (State f (makeif a s1 s2) k e le m)
E0 (State f (if b then s1 else s2) k e le m).
Proof.
intros. functional induction (makeif a s1 s2).
@@ -768,8 +768,8 @@ Lemma step_make_set:
Csem.deref_loc ge ty m b ofs t v ->
eval_lvalue tge e le m a b ofs ->
typeof a = ty ->
- step tge (State f (make_set id a) k e le m)
- t (State f Sskip k e (PTree.set id v le) m).
+ step1 tge (State f (make_set id a) k e le m)
+ t (State f Sskip k e (PTree.set id v le) m).
Proof.
intros. exploit deref_loc_translated; eauto. rewrite <- H1.
unfold make_set. destruct (chunk_for_volatile_type (typeof a)) as [chunk|].
@@ -789,8 +789,8 @@ Lemma step_make_assign:
eval_expr tge e le m a2 v2 ->
sem_cast v2 (typeof a2) ty = Some v ->
typeof a1 = ty ->
- step tge (State f (make_assign a1 a2) k e le m)
- t (State f Sskip k e le m').
+ step1 tge (State f (make_assign a1 a2) k e le m)
+ t (State f Sskip k e le m').
Proof.
intros. exploit assign_loc_translated; eauto. rewrite <- H3.
unfold make_assign. destruct (chunk_for_volatile_type (typeof a1)) as [chunk|].
@@ -819,8 +819,8 @@ Qed.
Lemma push_seq:
forall f sl k e le m,
- star step tge (State f (makeseq sl) k e le m)
- E0 (State f Sskip (Kseqlist sl k) e le m).
+ star step1 tge (State f (makeseq sl) k e le m)
+ E0 (State f Sskip (Kseqlist sl k) e le m).
Proof.
intros. unfold makeseq. generalize Sskip. revert sl k.
induction sl; simpl; intros.
@@ -835,8 +835,8 @@ Lemma step_tr_rvalof:
tr_rvalof ty a sl a' tmp ->
typeof a = ty ->
exists le',
- star step tge (State f Sskip (Kseqlist sl k) e le m)
- t (State f Sskip k e le' m)
+ star step1 tge (State f Sskip (Kseqlist sl k) e le m)
+ t (State f Sskip k e le' m)
/\ eval_expr tge e le' m a' v
/\ typeof a' = typeof a
/\ forall x, ~In x tmp -> le'!x = le!x.
@@ -1349,8 +1349,8 @@ Lemma estep_simulation:
forall S1 t S2, Cstrategy.estep ge S1 t S2 ->
forall S1' (MS: match_states S1 S1'),
exists S2',
- (plus step tge S1' t S2' \/
- (star step tge S1' t S2' /\ measure S2 < measure S1)%nat)
+ (plus step1 tge S1' t S2' \/
+ (star step1 tge S1' t S2' /\ measure S2 < measure S1)%nat)
/\ match_states S2 S2'.
Proof.
induction 1; intros; inv MS.
@@ -1909,8 +1909,8 @@ Lemma sstep_simulation:
forall S1 t S2, Csem.sstep ge S1 t S2 ->
forall S1' (MS: match_states S1 S1'),
exists S2',
- (plus step tge S1' t S2' \/
- (star step tge S1' t S2' /\ measure S2 < measure S1)%nat)
+ (plus step1 tge S1' t S2' \/
+ (star step1 tge S1' t S2' /\ measure S2 < measure S1)%nat)
/\ match_states S2 S2'.
Proof.
induction 1; intros; inv MS.
@@ -2094,11 +2094,10 @@ Proof.
eauto. traceEq.
constructor. apply match_cont_call; auto.
(* skip return *)
- inv H9.
- assert (is_call_cont tk). inv H10; simpl in *; auto.
+ inv H8.
+ assert (is_call_cont tk). inv H9; simpl in *; auto.
econstructor; split.
left. apply plus_one. apply step_skip_call; eauto.
- rewrite <- H0. apply function_return_preserved; auto.
constructor. auto.
(* switch *)
@@ -2146,10 +2145,11 @@ Proof.
monadInv H7.
exploit transl_function_spec; eauto. intros [A [B [C D]]].
econstructor; split.
- left; apply plus_one. eapply step_internal_function.
+ left; apply plus_one. eapply step_internal_function. econstructor.
rewrite C; rewrite D; auto.
rewrite C; rewrite D. eapply alloc_variables_preserved; eauto.
rewrite C. eapply bind_parameters_preserved; eauto.
+ eauto.
constructor; auto.
(* external function *)
@@ -2173,8 +2173,8 @@ Theorem simulation:
forall S1 t S2, Cstrategy.step ge S1 t S2 ->
forall S1' (MS: match_states S1 S1'),
exists S2',
- (plus step tge S1' t S2' \/
- (star step tge S1' t S2' /\ measure S2 < measure S1)%nat)
+ (plus step1 tge S1' t S2' \/
+ (star step1 tge S1' t S2' /\ measure S2 < measure S1)%nat)
/\ match_states S2 S2'.
Proof.
intros S1 t S2 STEP. destruct STEP.
@@ -2209,7 +2209,7 @@ Proof.
Qed.
Theorem transl_program_correct:
- forward_simulation (Cstrategy.semantics prog) (Clight.semantics tprog).
+ forward_simulation (Cstrategy.semantics prog) (Clight.semantics1 tprog).
Proof.
eapply forward_simulation_star_wf with (order := ltof _ measure).
eexact symbols_preserved.
diff --git a/cfrontend/SimplExprspec.v b/cfrontend/SimplExprspec.v
index 5df0398..1485dd1 100644
--- a/cfrontend/SimplExprspec.v
+++ b/cfrontend/SimplExprspec.v
@@ -1062,7 +1062,7 @@ Theorem transl_function_spec:
/\ fn_vars tf = C.fn_vars f.
Proof.
intros until tf. unfold transl_function.
- case_eq (transl_stmt (C.fn_body f) initial_generator); intros; inv H0.
+ case_eq (transl_stmt (C.fn_body f) (initial_generator tt)); intros; inv H0.
simpl. intuition. eapply transl_stmt_meets_spec; eauto.
Qed.
diff --git a/cfrontend/SimplLocals.v b/cfrontend/SimplLocals.v
new file mode 100644
index 0000000..2a472f7
--- /dev/null
+++ b/cfrontend/SimplLocals.v
@@ -0,0 +1,234 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(** Pulling local scalar variables whose address is not taken
+ into temporary variables. *)
+
+Require Import FSets.
+Require FSetAVL.
+Require Import Coqlib.
+Require Import Ordered.
+Require Import Errors.
+Require Import AST.
+Require Import Ctypes.
+Require Import Cop.
+Require Import Clight.
+
+Open Scope error_monad_scope.
+Open Scope string_scope.
+
+Module VSet := FSetAVL.Make(OrderedPositive).
+
+(** The set of local variables that can be lifted to temporaries,
+ because they are scalar and their address is not taken. *)
+
+Definition compilenv := VSet.t.
+
+Definition is_liftable_var (cenv: compilenv) (a: expr) : option ident :=
+ match a with
+ | Evar id ty => if VSet.mem id cenv then Some id else None
+ | _ => None
+ end.
+
+(** Rewriting of expressions and statements. *)
+
+Fixpoint simpl_expr (cenv: compilenv) (a: expr) : expr :=
+ match a with
+ | Econst_int _ _ => a
+ | Econst_float _ _ => a
+ | Evar id ty => if VSet.mem id cenv then Etempvar id ty else Evar id ty
+ | Etempvar id ty => Etempvar id ty
+ | Ederef a1 ty => Ederef (simpl_expr cenv a1) ty
+ | Eaddrof a1 ty => Eaddrof (simpl_expr cenv a1) ty
+ | Eunop op a1 ty => Eunop op (simpl_expr cenv a1) ty
+ | Ebinop op a1 a2 ty => Ebinop op (simpl_expr cenv a1) (simpl_expr cenv a2) ty
+ | Ecast a1 ty => Ecast (simpl_expr cenv a1) ty
+ | Efield a1 fld ty => Efield (simpl_expr cenv a1) fld ty
+ end.
+
+Definition simpl_exprlist (cenv: compilenv) (al: list expr) : list expr :=
+ List.map (simpl_expr cenv) al.
+
+Definition check_temp (cenv: compilenv) (id: ident) : res unit :=
+ if VSet.mem id cenv
+ then Error (MSG "bad temporary " :: CTX id :: nil)
+ else OK tt.
+
+Definition check_opttemp (cenv: compilenv) (optid: option ident) : res unit :=
+ match optid with
+ | Some id => check_temp cenv id
+ | None => OK tt
+ end.
+
+Fixpoint simpl_stmt (cenv: compilenv) (s: statement) : res statement :=
+ match s with
+ | Sskip => OK Sskip
+ | Sassign a1 a2 =>
+ match is_liftable_var cenv a1 with
+ | Some id =>
+ OK (Sset id (Ecast (simpl_expr cenv a2) (typeof a1)))
+ | None =>
+ OK (Sassign (simpl_expr cenv a1) (simpl_expr cenv a2))
+ end
+ | Sset id a =>
+ do x <- check_temp cenv id;
+ OK (Sset id (simpl_expr cenv a))
+ | Scall optid a al =>
+ do x <- check_opttemp cenv optid;
+ OK (Scall optid (simpl_expr cenv a) (simpl_exprlist cenv al))
+ | Sbuiltin optid ef tyargs al =>
+ do x <- check_opttemp cenv optid;
+ OK (Sbuiltin optid ef tyargs (simpl_exprlist cenv al))
+ | Ssequence s1 s2 =>
+ do s1' <- simpl_stmt cenv s1;
+ do s2' <- simpl_stmt cenv s2;
+ OK (Ssequence s1' s2')
+ | Sifthenelse a s1 s2 =>
+ do s1' <- simpl_stmt cenv s1;
+ do s2' <- simpl_stmt cenv s2;
+ OK (Sifthenelse (simpl_expr cenv a) s1' s2')
+ | Sloop s1 s2 =>
+ do s1' <- simpl_stmt cenv s1;
+ do s2' <- simpl_stmt cenv s2;
+ OK (Sloop s1' s2')
+ | Sbreak => OK Sbreak
+ | Scontinue => OK Scontinue
+ | Sreturn opta => OK (Sreturn (option_map (simpl_expr cenv) opta))
+ | Sswitch a ls =>
+ do ls' <- simpl_lblstmt cenv ls;
+ OK (Sswitch (simpl_expr cenv a) ls')
+ | Slabel lbl s =>
+ do s' <- simpl_stmt cenv s;
+ OK (Slabel lbl s')
+ | Sgoto lbl => OK (Sgoto lbl)
+ end
+
+with simpl_lblstmt (cenv: compilenv) (ls: labeled_statements) : res labeled_statements :=
+ match ls with
+ | LSdefault s =>
+ do s' <- simpl_stmt cenv s;
+ OK (LSdefault s')
+ | LScase n s ls1 =>
+ do s' <- simpl_stmt cenv s;
+ do ls1' <- simpl_lblstmt cenv ls1;
+ OK (LScase n s' ls1')
+ end.
+
+(** Function parameters that are not lifted to temporaries must be
+ stored in the corresponding local variable at function entry. *)
+
+Fixpoint store_params (cenv: compilenv) (params: list (ident * type))
+ (s: statement): statement :=
+ match params with
+ | nil => s
+ | (id, ty) :: params' =>
+ if VSet.mem id cenv
+ then store_params cenv params' s
+ else Ssequence (Sassign (Evar id ty) (Etempvar id ty))
+ (store_params cenv params' s)
+ end.
+
+(** Compute the set of variables whose address is taken *)
+
+Fixpoint addr_taken_expr (a: expr): VSet.t :=
+ match a with
+ | Econst_int _ _ => VSet.empty
+ | Econst_float _ _ => VSet.empty
+ | Evar id ty => VSet.empty
+ | Etempvar id ty => VSet.empty
+ | Ederef a1 ty => addr_taken_expr a1
+ | Eaddrof (Evar id ty1) ty => VSet.singleton id
+ | Eaddrof a1 ty => addr_taken_expr a1
+ | Eunop op a1 ty => addr_taken_expr a1
+ | Ebinop op a1 a2 ty => VSet.union (addr_taken_expr a1) (addr_taken_expr a2)
+ | Ecast a1 ty => addr_taken_expr a1
+ | Efield a1 fld ty => addr_taken_expr a1
+ end.
+
+Fixpoint addr_taken_exprlist (l: list expr) : VSet.t :=
+ match l with
+ | nil => VSet.empty
+ | a :: l' => VSet.union (addr_taken_expr a) (addr_taken_exprlist l')
+ end.
+
+Fixpoint addr_taken_stmt (s: statement) : VSet.t :=
+ match s with
+ | Sskip => VSet.empty
+ | Sassign a b => VSet.union (addr_taken_expr a) (addr_taken_expr b)
+ | Sset id a => addr_taken_expr a
+ | Scall optid a bl => VSet.union (addr_taken_expr a) (addr_taken_exprlist bl)
+ | Sbuiltin optid ef tyargs bl => addr_taken_exprlist bl
+ | Ssequence s1 s2 => VSet.union (addr_taken_stmt s1) (addr_taken_stmt s2)
+ | Sifthenelse a s1 s2 =>
+ VSet.union (addr_taken_expr a) (VSet.union (addr_taken_stmt s1) (addr_taken_stmt s2))
+ | Sloop s1 s2 => VSet.union (addr_taken_stmt s1) (addr_taken_stmt s2)
+ | Sbreak => VSet.empty
+ | Scontinue => VSet.empty
+ | Sreturn None => VSet.empty
+ | Sreturn (Some a) => addr_taken_expr a
+ | Sswitch a ls => VSet.union (addr_taken_expr a) (addr_taken_lblstmt ls)
+ | Slabel lbl s => addr_taken_stmt s
+ | Sgoto lbl => VSet.empty
+ end
+
+with addr_taken_lblstmt (ls: labeled_statements) : VSet.t :=
+ match ls with
+ | LSdefault s => addr_taken_stmt s
+ | LScase n s ls' => VSet.union (addr_taken_stmt s) (addr_taken_lblstmt ls')
+ end.
+
+(** The compilation environment for a function is the set of local variables
+ that are scalars and whose addresses are not taken. *)
+
+Definition add_local_variable (atk: VSet.t) (id_ty: ident * type)
+ (cenv: compilenv) : compilenv :=
+ let (id, ty) := id_ty in
+ match access_mode ty with
+ | By_value chunk => if VSet.mem id atk then cenv else VSet.add id cenv
+ | _ => cenv
+ end.
+
+Definition cenv_for (f: function) : compilenv :=
+ let atk := addr_taken_stmt f.(fn_body) in
+ List.fold_right (add_local_variable atk) VSet.empty (f.(fn_params) ++ f.(fn_vars)).
+
+(** Transform a function *)
+
+Definition remove_lifted (cenv: compilenv) (vars: list (ident * type)) :=
+ List.filter (fun id_ty => negb (VSet.mem (fst id_ty) cenv)) vars.
+
+Definition add_lifted (cenv: compilenv) (vars1 vars2: list (ident * type)) :=
+ List.filter (fun id_ty => VSet.mem (fst id_ty) cenv) vars1 ++ vars2.
+
+Definition transf_function (f: function) : res function :=
+ let cenv := cenv_for f in
+ do x <- assertion (list_disjoint_dec ident_eq (var_names f.(fn_params))
+ (var_names f.(fn_temps)));
+ do body' <- simpl_stmt cenv f.(fn_body);
+ OK {| fn_return := f.(fn_return);
+ fn_params := f.(fn_params);
+ fn_vars := remove_lifted cenv (f.(fn_params) ++ f.(fn_vars));
+ fn_temps := add_lifted cenv f.(fn_vars) f.(fn_temps);
+ fn_body := store_params cenv f.(fn_params) body' |}.
+
+(** Whole-program transformation *)
+
+Definition transf_fundef (fd: fundef) : res fundef :=
+ match fd with
+ | Internal f => do tf <- transf_function f; OK (Internal tf)
+ | External ef targs tres => OK (External ef targs tres)
+ end.
+
+Definition transf_program (p: program) : res program :=
+ AST.transform_partial_program transf_fundef p.
+
+
diff --git a/cfrontend/SimplLocalsproof.v b/cfrontend/SimplLocalsproof.v
new file mode 100644
index 0000000..e08ae49
--- /dev/null
+++ b/cfrontend/SimplLocalsproof.v
@@ -0,0 +1,2277 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(** Semantic preservation for the SimplLocals pass. *)
+
+Require Import FSets.
+Require FSetAVL.
+Require Import Coqlib.
+Require Import Errors.
+Require Import Ordered.
+Require Import AST.
+Require Import Maps.
+Require Import Integers.
+Require Import Floats.
+Require Import Values.
+Require Import Memory.
+Require Import Globalenvs.
+Require Import Events.
+Require Import Smallstep.
+Require Import Ctypes.
+Require Import Cop.
+Require Import Clight.
+Require Import SimplLocals.
+
+Module VSF := FSetFacts.Facts(VSet).
+Module VSP := FSetProperties.Properties(VSet).
+
+Section PRESERVATION.
+
+Variable prog: program.
+Variable tprog: program.
+Hypothesis TRANSF: transf_program prog = OK tprog.
+Let ge := Genv.globalenv prog.
+Let tge := Genv.globalenv tprog.
+
+Lemma symbols_preserved:
+ forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s.
+Proof.
+ exact (Genv.find_symbol_transf_partial _ _ TRANSF).
+Qed.
+
+Lemma varinfo_preserved:
+ forall b, Genv.find_var_info tge b = Genv.find_var_info ge b.
+Proof.
+ exact (Genv.find_var_info_transf_partial _ _ TRANSF).
+Qed.
+
+Lemma functions_translated:
+ forall (v: val) (f: fundef),
+ Genv.find_funct ge v = Some f ->
+ exists tf, Genv.find_funct tge v = Some tf /\ transf_fundef f = OK tf.
+Proof.
+ exact (Genv.find_funct_transf_partial _ _ TRANSF).
+Qed.
+
+Lemma function_ptr_translated:
+ forall (b: block) (f: fundef),
+ Genv.find_funct_ptr ge b = Some f ->
+ exists tf, Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = OK tf.
+Proof.
+ exact (Genv.find_funct_ptr_transf_partial _ _ TRANSF).
+Qed.
+
+Lemma type_of_fundef_preserved:
+ forall fd tfd,
+ transf_fundef fd = OK tfd -> type_of_fundef tfd = type_of_fundef fd.
+Proof.
+ intros. destruct fd; monadInv H; auto.
+ monadInv EQ. simpl; unfold type_of_function; simpl. auto.
+Qed.
+
+Lemma type_of_global_preserved:
+ forall id ty, type_of_global ge id = Some ty -> type_of_global tge id = Some ty.
+Proof.
+ unfold type_of_global; intros.
+ rewrite varinfo_preserved. destruct (Genv.find_var_info ge id). auto.
+ destruct (Genv.find_funct_ptr ge id) as [fd|]_eqn; inv H.
+ exploit function_ptr_translated; eauto. intros [tf [A B]]. rewrite A.
+ decEq. apply type_of_fundef_preserved; auto.
+Qed.
+
+(** Matching between environments before and after *)
+
+Inductive match_var (f: meminj) (cenv: compilenv) (e: env) (m: mem) (te: env) (tle: temp_env) (id: ident) : Prop :=
+ | match_var_lifted: forall b ty chunk v tv
+ (ENV: e!id = Some(b, ty))
+ (TENV: te!id = None)
+ (LIFTED: VSet.mem id cenv = true)
+ (MAPPED: f b = None)
+ (MODE: access_mode ty = By_value chunk)
+ (LOAD: Mem.load chunk m b 0 = Some v)
+ (TLENV: tle!(id) = Some tv)
+ (VINJ: val_inject f v tv),
+ match_var f cenv e m te tle id
+ | match_var_not_lifted: forall b ty b'
+ (ENV: e!id = Some(b, ty))
+ (TENV: te!id = Some(b', ty))
+ (LIFTED: VSet.mem id cenv = false)
+ (MAPPED: f b = Some(b', 0)),
+ match_var f cenv e m te tle id
+ | match_var_not_local: forall
+ (ENV: e!id = None)
+ (TENV: te!id = None)
+ (LIFTED: VSet.mem id cenv = false),
+ match_var f cenv e m te tle id.
+
+Record match_envs (f: meminj) (cenv: compilenv)
+ (e: env) (le: temp_env) (m: mem) (lo hi: Z)
+ (te: env) (tle: temp_env) (tlo thi: Z) : Prop :=
+ mk_match_envs {
+ me_vars:
+ forall id, match_var f cenv e m te tle id;
+ me_temps:
+ forall id v,
+ le!id = Some v ->
+ (exists tv, tle!id = Some tv /\ val_inject f v tv)
+ /\ (VSet.mem id cenv = true -> v = Vundef);
+ me_inj:
+ forall id1 b1 ty1 id2 b2 ty2, e!id1 = Some(b1, ty1) -> e!id2 = Some(b2, ty2) -> id1 <> id2 -> b1 <> b2;
+ me_range:
+ forall id b ty, e!id = Some(b, ty) -> lo <= b < hi;
+ me_trange:
+ forall id b ty, te!id = Some(b, ty) -> tlo <= b < thi;
+ me_mapped:
+ forall id b' ty,
+ te!id = Some(b', ty) -> exists b, f b = Some(b', 0) /\ e!id = Some(b, ty);
+ me_flat:
+ forall id b' ty b delta,
+ te!id = Some(b', ty) -> f b = Some(b', delta) -> e!id = Some(b, ty) /\ delta = 0;
+ me_incr:
+ lo <= hi;
+ me_tincr:
+ tlo <= thi
+ }.
+
+(** Invariance by change of memory and injection *)
+
+Lemma match_envs_invariant:
+ forall f cenv e le m lo hi te tle tlo thi f' m',
+ match_envs f cenv e le m lo hi te tle tlo thi ->
+ (forall b chunk v,
+ f b = None -> lo <= b < hi -> Mem.load chunk m b 0 = Some v -> Mem.load chunk m' b 0 = Some v) ->
+ inject_incr f f' ->
+ (forall b, lo <= b < hi -> f' b = f b) ->
+ (forall b b' delta, f' b = Some(b', delta) -> tlo <= b' < thi -> f' b = f b) ->
+ match_envs f' cenv e le m' lo hi te tle tlo thi.
+Proof.
+ intros until m'; intros ME LD INCR INV1 INV2.
+ destruct ME; constructor; eauto.
+(* vars *)
+ intros. generalize (me_vars0 id); intros MV; inv MV.
+ eapply match_var_lifted; eauto.
+ rewrite <- MAPPED; eauto.
+ eapply match_var_not_lifted; eauto.
+ eapply match_var_not_local; eauto.
+(* temps *)
+ intros. exploit me_temps0; eauto. intros [[v' [A B]] C]. split; auto. exists v'; eauto.
+(* mapped *)
+ intros. exploit me_mapped0; eauto. intros [b [A B]]. exists b; split; auto.
+(* flat *)
+ intros. eapply me_flat0; eauto. rewrite <- H0. symmetry. eapply INV2; eauto.
+Qed.
+
+(** Invariance by external call *)
+
+Lemma match_envs_extcall:
+ forall f cenv e le m lo hi te tle tlo thi tm f' m',
+ match_envs f cenv e le m lo hi te tle tlo thi ->
+ mem_unchanged_on (loc_unmapped f) m m' ->
+ inject_incr f f' ->
+ inject_separated f f' m tm ->
+ hi <= Mem.nextblock m -> thi <= Mem.nextblock tm ->
+ match_envs f' cenv e le m' lo hi te tle tlo thi.
+Proof.
+ intros. eapply match_envs_invariant; eauto.
+ intros. destruct H0. eapply H8. intros; red. auto. auto.
+ red in H2. intros. destruct (f b) as [[b' delta]|]_eqn.
+ eapply H1; eauto.
+ destruct (f' b) as [[b' delta]|]_eqn; auto.
+ exploit H2; eauto. unfold Mem.valid_block. intros [A B].
+ omegaContradiction.
+ intros. destruct (f b) as [[b'' delta']|]_eqn. eauto.
+ exploit H2; eauto. unfold Mem.valid_block. intros [A B].
+ omegaContradiction.
+Qed.
+
+(** Properties of values obtained by casting to a given type. *)
+
+Inductive val_casted: val -> type -> Prop :=
+ | val_casted_int: forall sz si attr n,
+ cast_int_int sz si n = n ->
+ val_casted (Vint n) (Tint sz si attr)
+ | val_casted_float: forall sz attr n,
+ cast_float_float sz n = n ->
+ val_casted (Vfloat n) (Tfloat sz attr)
+ | val_casted_ptr_ptr: forall b ofs ty attr,
+ val_casted (Vptr b ofs) (Tpointer ty attr)
+ | val_casted_int_ptr: forall n ty attr,
+ val_casted (Vint n) (Tpointer ty attr)
+ | val_casted_ptr_int: forall b ofs si attr,
+ val_casted (Vptr b ofs) (Tint I32 si attr)
+ | val_casted_struct: forall id fld attr v,
+ val_casted v (Tstruct id fld attr)
+ | val_casted_union: forall id fld attr v,
+ val_casted v (Tunion id fld attr)
+ | val_casted_void: forall v,
+ val_casted v Tvoid.
+
+Remark cast_int_int_idem:
+ forall sz sg i, cast_int_int sz sg (cast_int_int sz sg i) = cast_int_int sz sg i.
+Proof.
+ intros. destruct sz; simpl; auto.
+ destruct sg; [apply Int.sign_ext_idem|apply Int.zero_ext_idem]; compute; auto.
+ destruct sg; [apply Int.sign_ext_idem|apply Int.zero_ext_idem]; compute; auto.
+ destruct (Int.eq i Int.zero); auto.
+Qed.
+
+Remark cast_float_float_idem:
+ forall sz f, cast_float_float sz (cast_float_float sz f) = cast_float_float sz f.
+Proof.
+ intros; destruct sz; simpl.
+ apply Float.singleoffloat_idem; auto.
+ auto.
+Qed.
+
+Lemma cast_val_is_casted:
+ forall v ty ty' v', sem_cast v ty ty' = Some v' -> val_casted v' ty'.
+Proof.
+ unfold sem_cast; intros. destruct ty'; simpl in *.
+(* void *)
+ constructor.
+(* int *)
+ destruct i; destruct ty; simpl in H; try discriminate; destruct v; inv H.
+ constructor. apply (cast_int_int_idem I8 s).
+ destruct (cast_float_int s f0); inv H1. constructor. apply (cast_int_int_idem I8 s).
+ constructor. apply (cast_int_int_idem I16 s).
+ destruct (cast_float_int s f0); inv H1. constructor. apply (cast_int_int_idem I16 s).
+ constructor. auto.
+ constructor.
+ destruct (cast_float_int s f0); inv H1. constructor. auto.
+ constructor. auto.
+ constructor.
+ constructor; auto.
+ constructor.
+ constructor; auto.
+ constructor; auto.
+ constructor. simpl. destruct (Int.eq i0 Int.zero); auto.
+ constructor. simpl. destruct (Float.cmp Ceq f0 Float.zero); auto.
+ constructor. simpl. destruct (Int.eq i Int.zero); auto.
+ constructor; auto.
+ constructor. simpl. destruct (Int.eq i Int.zero); auto.
+ constructor; auto.
+ constructor. simpl. destruct (Int.eq i Int.zero); auto.
+ constructor; auto.
+(* float *)
+ destruct ty; simpl in H; try discriminate; destruct v; inv H.
+ constructor. apply cast_float_float_idem.
+ constructor. apply cast_float_float_idem.
+(* pointer *)
+ destruct ty; simpl in H; try discriminate; destruct v; inv H; try constructor.
+(* impossible cases *)
+ discriminate.
+ discriminate.
+(* structs,unions *)
+ constructor.
+ constructor.
+(* impossible cases *)
+ discriminate.
+Qed.
+
+Lemma val_casted_load_result:
+ forall v ty chunk,
+ val_casted v ty -> access_mode ty = By_value chunk ->
+ Val.load_result chunk v = v.
+Proof.
+ intros. inversion H; clear H; subst v ty; simpl in H0.
+ destruct sz.
+ destruct si; inversion H0; clear H0; subst chunk; simpl in *; congruence.
+ destruct si; inversion H0; clear H0; subst chunk; simpl in *; congruence.
+ clear H1. inv H0. auto.
+ inversion H0; clear H0; subst chunk. simpl in *.
+ destruct (Int.eq n Int.zero); subst n; auto.
+ destruct sz; inversion H0; clear H0; subst chunk; simpl in *; congruence.
+ inv H0; auto.
+ inv H0; auto.
+ inv H0; auto.
+ discriminate.
+ discriminate.
+ discriminate.
+Qed.
+
+Lemma cast_val_casted:
+ forall v ty, val_casted v ty -> sem_cast v ty ty = Some v.
+Proof.
+ intros. inversion H; clear H; subst v ty; unfold sem_cast; simpl.
+ destruct sz; congruence.
+ congruence.
+ auto.
+ auto.
+ auto.
+ unfold proj_sumbool; repeat rewrite dec_eq_true; auto.
+ unfold proj_sumbool; repeat rewrite dec_eq_true; auto.
+ auto.
+Qed.
+
+Lemma val_casted_inject:
+ forall f v v' ty,
+ val_inject f v v' -> val_casted v ty -> val_casted v' ty.
+Proof.
+ intros. inv H.
+ auto.
+ auto.
+ inv H0; constructor.
+ inv H0; constructor.
+Qed.
+
+Inductive val_casted_list: list val -> typelist -> Prop :=
+ | vcl_nil:
+ val_casted_list nil Tnil
+ | vcl_cons: forall v1 vl ty1 tyl,
+ val_casted v1 ty1 -> val_casted_list vl tyl ->
+ val_casted_list (v1 :: vl) (Tcons ty1 tyl).
+
+Lemma val_casted_list_params:
+ forall params vl,
+ val_casted_list vl (type_of_params params) ->
+ list_forall2 val_casted vl (map snd params).
+Proof.
+ induction params; simpl; intros.
+ inv H. constructor.
+ destruct a as [id ty]. inv H. constructor; auto.
+Qed.
+
+(** Preservation by assignment to lifted variable. *)
+
+Lemma match_envs_assign_lifted:
+ forall f cenv e le m lo hi te tle tlo thi b ty v m' id tv,
+ match_envs f cenv e le m lo hi te tle tlo thi ->
+ e!id = Some(b, ty) ->
+ val_casted v ty ->
+ val_inject f v tv ->
+ assign_loc ty m b Int.zero v m' ->
+ VSet.mem id cenv = true ->
+ match_envs f cenv e le m' lo hi te (PTree.set id tv tle) tlo thi.
+Proof.
+ intros. destruct H. generalize (me_vars0 id); intros MV; inv MV; try congruence.
+ rewrite ENV in H0; inv H0. inv H3; try congruence.
+ unfold Mem.storev in H0. rewrite Int.unsigned_zero in H0.
+ constructor; eauto; intros.
+(* vars *)
+ destruct (peq id0 id). subst id0.
+ eapply match_var_lifted with (v := v); eauto.
+ exploit Mem.load_store_same; eauto. erewrite val_casted_load_result; eauto.
+ apply PTree.gss.
+ generalize (me_vars0 id0); intros MV; inv MV.
+ eapply match_var_lifted; eauto.
+ rewrite <- LOAD0. eapply Mem.load_store_other; eauto.
+ rewrite PTree.gso; auto.
+ eapply match_var_not_lifted; eauto.
+ eapply match_var_not_local; eauto.
+(* temps *)
+ exploit me_temps0; eauto. intros [[tv1 [A B]] C]. split; auto.
+ rewrite PTree.gsspec. destruct (peq id0 id).
+ subst id0. exists tv; split; auto. rewrite C; auto.
+ exists tv1; auto.
+Qed.
+
+(** Preservation by assignment to a temporary *)
+
+Lemma match_envs_set_temp:
+ forall f cenv e le m lo hi te tle tlo thi id v tv x,
+ match_envs f cenv e le m lo hi te tle tlo thi ->
+ val_inject f v tv ->
+ check_temp cenv id = OK x ->
+ match_envs f cenv e (PTree.set id v le) m lo hi te (PTree.set id tv tle) tlo thi.
+Proof.
+ intros. unfold check_temp in H1.
+ destruct (VSet.mem id cenv) as []_eqn; monadInv H1.
+ destruct H. constructor; eauto; intros.
+(* vars *)
+ generalize (me_vars0 id0); intros MV; inv MV.
+ eapply match_var_lifted; eauto. rewrite PTree.gso. eauto. congruence.
+ eapply match_var_not_lifted; eauto.
+ eapply match_var_not_local; eauto.
+(* temps *)
+ rewrite PTree.gsspec in *. destruct (peq id0 id).
+ inv H. split. exists tv; auto. intros; congruence.
+ eapply me_temps0; eauto.
+Qed.
+
+Lemma match_envs_set_opttemp:
+ forall f cenv e le m lo hi te tle tlo thi optid v tv x,
+ match_envs f cenv e le m lo hi te tle tlo thi ->
+ val_inject f v tv ->
+ check_opttemp cenv optid = OK x ->
+ match_envs f cenv e (set_opttemp optid v le) m lo hi te (set_opttemp optid tv tle) tlo thi.
+Proof.
+ intros. unfold set_opttemp. destruct optid; simpl in H1.
+ eapply match_envs_set_temp; eauto.
+ auto.
+Qed.
+
+(** Extensionality with respect to temporaries *)
+
+Lemma match_envs_temps_exten:
+ forall f cenv e le m lo hi te tle tlo thi tle',
+ match_envs f cenv e le m lo hi te tle tlo thi ->
+ (forall id, tle'!id = tle!id) ->
+ match_envs f cenv e le m lo hi te tle' tlo thi.
+Proof.
+ intros. destruct H. constructor; auto; intros.
+ (* vars *)
+ generalize (me_vars0 id); intros MV; inv MV.
+ eapply match_var_lifted; eauto. rewrite H0; auto.
+ eapply match_var_not_lifted; eauto.
+ eapply match_var_not_local; eauto.
+ (* temps *)
+ rewrite H0. eauto.
+Qed.
+
+(** Invariance by assignment to an irrelevant temporary *)
+
+Lemma match_envs_change_temp:
+ forall f cenv e le m lo hi te tle tlo thi id v,
+ match_envs f cenv e le m lo hi te tle tlo thi ->
+ le!id = None -> VSet.mem id cenv = false ->
+ match_envs f cenv e le m lo hi te (PTree.set id v tle) tlo thi.
+Proof.
+ intros. destruct H. constructor; auto; intros.
+ (* vars *)
+ generalize (me_vars0 id0); intros MV; inv MV.
+ eapply match_var_lifted; eauto. rewrite PTree.gso; auto. congruence.
+ eapply match_var_not_lifted; eauto.
+ eapply match_var_not_local; eauto.
+ (* temps *)
+ rewrite PTree.gso. eauto. congruence.
+Qed.
+
+(** Properties of [cenv_for]. *)
+
+Definition cenv_for_gen (atk: VSet.t) (vars: list (ident * type)) : compilenv :=
+ List.fold_right (add_local_variable atk) VSet.empty vars.
+
+Remark add_local_variable_charact:
+ forall id ty atk cenv id1,
+ VSet.In id1 (add_local_variable atk (id, ty) cenv) <->
+ VSet.In id1 cenv \/ exists chunk, access_mode ty = By_value chunk /\ id = id1 /\ VSet.mem id atk = false.
+Proof.
+ intros. unfold add_local_variable. split; intros.
+ destruct (access_mode ty) as []_eqn; auto.
+ destruct (VSet.mem id atk) as []_eqn; auto.
+ rewrite VSF.add_iff in H. destruct H; auto. right; exists m; auto.
+ destruct H as [A | [chunk [A [B C]]]].
+ destruct (access_mode ty); auto. destruct (VSet.mem id atk); auto. rewrite VSF.add_iff; auto.
+ rewrite A. rewrite <- B. rewrite C. apply VSet.add_1; auto.
+Qed.
+
+Lemma cenv_for_gen_domain:
+ forall atk id vars, VSet.In id (cenv_for_gen atk vars) -> In id (var_names vars).
+Proof.
+ induction vars; simpl; intros.
+ rewrite VSF.empty_iff in H. auto.
+ destruct a as [id1 ty1]. rewrite add_local_variable_charact in H.
+ destruct H as [A | [chunk [A [B C]]]]; auto.
+Qed.
+
+Lemma cenv_for_gen_by_value:
+ forall atk id ty vars,
+ In (id, ty) vars ->
+ list_norepet (var_names vars) ->
+ VSet.In id (cenv_for_gen atk vars) ->
+ exists chunk, access_mode ty = By_value chunk.
+Proof.
+ induction vars; simpl; intros.
+ contradiction.
+ destruct a as [id1 ty1]. simpl in H0. inv H0.
+ rewrite add_local_variable_charact in H1.
+ destruct H; destruct H1 as [A | [chunk [A [B C]]]].
+ inv H. elim H4. eapply cenv_for_gen_domain; eauto.
+ inv H. exists chunk; auto.
+ eauto.
+ subst id1. elim H4. change id with (fst (id, ty)). apply in_map; auto.
+Qed.
+
+Lemma cenv_for_gen_compat:
+ forall atk id vars,
+ VSet.In id (cenv_for_gen atk vars) -> VSet.mem id atk = false.
+Proof.
+ induction vars; simpl; intros.
+ rewrite VSF.empty_iff in H. contradiction.
+ destruct a as [id1 ty1]. rewrite add_local_variable_charact in H.
+ destruct H as [A | [chunk [A [B C]]]].
+ auto.
+ congruence.
+Qed.
+
+(** Compatibility between a compilation environment and an address-taken set. *)
+
+Definition compat_cenv (atk: VSet.t) (cenv: compilenv) : Prop :=
+ forall id, VSet.In id atk -> VSet.In id cenv -> False.
+
+Lemma compat_cenv_for:
+ forall f, compat_cenv (addr_taken_stmt f.(fn_body)) (cenv_for f).
+Proof.
+ intros; red; intros.
+ assert (VSet.mem id (addr_taken_stmt (fn_body f)) = false).
+ eapply cenv_for_gen_compat. eexact H0.
+ rewrite VSF.mem_iff in H. congruence.
+Qed.
+
+Lemma compat_cenv_union_l:
+ forall atk1 atk2 cenv,
+ compat_cenv (VSet.union atk1 atk2) cenv -> compat_cenv atk1 cenv.
+Proof.
+ intros; red; intros. eapply H; eauto. apply VSet.union_2; auto.
+Qed.
+
+Lemma compat_cenv_union_r:
+ forall atk1 atk2 cenv,
+ compat_cenv (VSet.union atk1 atk2) cenv -> compat_cenv atk2 cenv.
+Proof.
+ intros; red; intros. eapply H; eauto. apply VSet.union_3; auto.
+Qed.
+
+Lemma compat_cenv_empty:
+ forall cenv, compat_cenv VSet.empty cenv.
+Proof.
+ intros; red; intros. eapply VSet.empty_1; eauto.
+Qed.
+
+Hint Resolve compat_cenv_union_l compat_cenv_union_r compat_cenv_empty: compat.
+
+(** Allocation and initialization of parameters *)
+
+Lemma alloc_variables_nextblock:
+ forall e m vars e' m',
+ alloc_variables e m vars e' m' -> Mem.nextblock m <= Mem.nextblock m'.
+Proof.
+ induction 1.
+ omega.
+ exploit Mem.nextblock_alloc; eauto. unfold block. omega.
+Qed.
+
+Lemma alloc_variables_range:
+ forall id b ty e m vars e' m',
+ alloc_variables e m vars e' m' ->
+ e'!id = Some(b, ty) -> e!id = Some(b, ty) \/ Mem.nextblock m <= b < Mem.nextblock m'.
+Proof.
+ induction 1; intros.
+ auto.
+ exploit IHalloc_variables; eauto. rewrite PTree.gsspec. intros [A|A].
+ destruct (peq id id0). inv A.
+ right. exploit Mem.alloc_result; eauto. exploit Mem.nextblock_alloc; eauto. unfold block.
+ generalize (alloc_variables_nextblock _ _ _ _ _ H0). omega.
+ auto.
+ right. exploit Mem.nextblock_alloc; eauto. unfold block. omega.
+Qed.
+
+Lemma alloc_variables_injective:
+ forall id1 b1 ty1 id2 b2 ty2 e m vars e' m',
+ alloc_variables e m vars e' m' ->
+ (e!id1 = Some(b1, ty1) -> e!id2 = Some(b2, ty2) -> id1 <> id2 -> b1 <> b2) ->
+ (forall id b ty, e!id = Some(b, ty) -> b < Mem.nextblock m) ->
+ (e'!id1 = Some(b1, ty1) -> e'!id2 = Some(b2, ty2) -> id1 <> id2 -> b1 <> b2).
+Proof.
+ induction 1; intros.
+ eauto.
+ eapply IHalloc_variables; eauto.
+ repeat rewrite PTree.gsspec; intros.
+ destruct (peq id1 id); destruct (peq id2 id).
+ congruence.
+ inv H6. exploit Mem.alloc_result; eauto. exploit H2; eauto. unfold block; omega.
+ inv H7. exploit Mem.alloc_result; eauto. exploit H2; eauto. unfold block; omega.
+ eauto.
+ intros. rewrite PTree.gsspec in H6. destruct (peq id0 id). inv H6.
+ exploit Mem.alloc_result; eauto. exploit Mem.nextblock_alloc; eauto. unfold block; omega.
+ exploit H2; eauto. exploit Mem.nextblock_alloc; eauto. unfold block; omega.
+Qed.
+
+Lemma match_alloc_variables:
+ forall cenv e m vars e' m',
+ alloc_variables e m vars e' m' ->
+ forall j tm te,
+ list_norepet (var_names vars) ->
+ Mem.inject j m tm ->
+ exists j', exists te', exists tm',
+ alloc_variables te tm (remove_lifted cenv vars) te' tm'
+ /\ Mem.inject j' m' tm'
+ /\ inject_incr j j'
+ /\ (forall b, Mem.valid_block m b -> j' b = j b)
+ /\ (forall b b' delta, j' b = Some(b', delta) -> Mem.valid_block tm b' -> j' b = j b)
+ /\ (forall b b' delta, j' b = Some(b', delta) -> ~Mem.valid_block tm b' ->
+ exists id, exists ty, e'!id = Some(b, ty) /\ te'!id = Some(b', ty) /\ delta = 0)
+ /\ (forall id ty, In (id, ty) vars ->
+ exists b,
+ e'!id = Some(b, ty)
+ /\ if VSet.mem id cenv
+ then te'!id = te!id /\ j' b = None
+ else exists tb, te'!id = Some(tb, ty) /\ j' b = Some(tb, 0))
+ /\ (forall id, ~In id (var_names vars) -> e'!id = e!id /\ te'!id = te!id).
+Proof.
+ induction 1; intros.
+ (* base case *)
+ exists j; exists te; exists tm. simpl.
+ split. constructor.
+ split. auto. split. auto. split. auto. split. auto.
+ split. intros. elim H2. eapply Mem.mi_mappedblocks; eauto.
+ split. tauto. auto.
+
+ (* inductive case *)
+ simpl in H1. inv H1. simpl.
+ destruct (VSet.mem id cenv) as []_eqn. simpl.
+ (* variable is lifted out of memory *)
+ exploit Mem.alloc_left_unmapped_inject; eauto.
+ intros [j1 [A [B [C D]]]].
+ exploit IHalloc_variables; eauto. instantiate (1 := te).
+ intros [j' [te' [tm' [J [K [L [M [N [Q [O P]]]]]]]]]].
+ exists j'; exists te'; exists tm'.
+ split. auto.
+ split. auto.
+ split. eapply inject_incr_trans; eauto.
+ split. intros. transitivity (j1 b). apply M. eapply Mem.valid_block_alloc; eauto.
+ apply D. apply Mem.valid_not_valid_diff with m; auto. eapply Mem.fresh_block_alloc; eauto.
+ split. intros. transitivity (j1 b). eapply N; eauto.
+ destruct (eq_block b b1); auto. subst.
+ assert (j' b1 = j1 b1). apply M. eapply Mem.valid_new_block; eauto.
+ congruence.
+ split. exact Q.
+ split. intros. destruct (ident_eq id0 id).
+ (* same var *)
+ subst id0.
+ assert (ty0 = ty).
+ destruct H1. congruence. elim H5. unfold var_names. change id with (fst (id, ty0)). apply in_map; auto.
+ subst ty0.
+ exploit P; eauto. intros [X Y]. rewrite Heqb. rewrite X. rewrite Y.
+ exists b1. split. apply PTree.gss.
+ split. auto.
+ rewrite M. auto. eapply Mem.valid_new_block; eauto.
+ (* other vars *)
+ eapply O; eauto. destruct H1. congruence. auto.
+ intros. exploit (P id0). tauto. intros [X Y]. rewrite X; rewrite Y.
+ split; auto. apply PTree.gso. intuition.
+
+ (* variable is not lifted out of memory *)
+ exploit Mem.alloc_parallel_inject.
+ eauto. eauto. apply Zle_refl. apply Zle_refl.
+ intros [j1 [tm1 [tb1 [A [B [C [D E]]]]]]].
+ exploit IHalloc_variables; eauto. instantiate (1 := PTree.set id (tb1, ty) te).
+ intros [j' [te' [tm' [J [K [L [M [N [Q [O P]]]]]]]]]].
+ exists j'; exists te'; exists tm'.
+ split. simpl. econstructor; eauto.
+ split. auto.
+ split. eapply inject_incr_trans; eauto.
+ split. intros. transitivity (j1 b). apply M. eapply Mem.valid_block_alloc; eauto.
+ apply E. apply Mem.valid_not_valid_diff with m; auto. eapply Mem.fresh_block_alloc; eauto.
+ split. intros. transitivity (j1 b). eapply N; eauto. eapply Mem.valid_block_alloc; eauto.
+ destruct (eq_block b b1); auto. subst.
+ assert (j' b1 = j1 b1). apply M. eapply Mem.valid_new_block; eauto.
+ rewrite H4 in H1. rewrite D in H1. inv H1. eelim Mem.fresh_block_alloc; eauto.
+ split. intros. destruct (zeq b' tb1).
+ subst b'. rewrite (N _ _ _ H1) in H1.
+ destruct (zeq b b1). subst b. rewrite D in H1; inv H1.
+ exploit (P id); auto. intros [X Y]. exists id; exists ty.
+ rewrite X; rewrite Y. repeat rewrite PTree.gss. auto.
+ rewrite E in H1; auto. elim H3. eapply Mem.mi_mappedblocks; eauto.
+ eapply Mem.valid_new_block; eauto.
+ eapply Q; eauto. unfold Mem.valid_block in *.
+ exploit Mem.nextblock_alloc. eexact A. exploit Mem.alloc_result. eexact A.
+ unfold block; omega.
+ split. intros. destruct (ident_eq id0 id).
+ (* same var *)
+ subst id0.
+ assert (ty0 = ty).
+ destruct H1. congruence. elim H5. unfold var_names. change id with (fst (id, ty0)). apply in_map; auto.
+ subst ty0.
+ exploit P; eauto. intros [X Y]. rewrite Heqb. rewrite X. rewrite Y.
+ exists b1. split. apply PTree.gss.
+ exists tb1; split.
+ apply PTree.gss.
+ rewrite M. auto. eapply Mem.valid_new_block; eauto.
+ (* other vars *)
+ exploit (O id0 ty0). destruct H1. congruence. auto.
+ rewrite PTree.gso; auto.
+ intros. exploit (P id0). tauto. intros [X Y]. rewrite X; rewrite Y.
+ split; apply PTree.gso; intuition.
+Qed.
+
+Lemma alloc_variables_load:
+ forall e m vars e' m',
+ alloc_variables e m vars e' m' ->
+ forall chunk b ofs v,
+ Mem.load chunk m b ofs = Some v ->
+ Mem.load chunk m' b ofs = Some v.
+Proof.
+ induction 1; intros.
+ auto.
+ apply IHalloc_variables. eapply Mem.load_alloc_other; eauto.
+Qed.
+
+Lemma sizeof_by_value:
+ forall ty chunk,
+ access_mode ty = By_value chunk -> sizeof ty = size_chunk chunk.
+Proof.
+ unfold access_mode; intros.
+ destruct ty; try destruct i; try destruct s; try destruct f; inv H; auto.
+Qed.
+
+Definition env_initial_value (e: env) (m: mem) :=
+ forall id b ty chunk,
+ e!id = Some(b, ty) -> access_mode ty = By_value chunk -> Mem.load chunk m b 0 = Some Vundef.
+
+Lemma alloc_variables_initial_value:
+ forall e m vars e' m',
+ alloc_variables e m vars e' m' ->
+ env_initial_value e m ->
+ env_initial_value e' m'.
+Proof.
+ induction 1; intros.
+ auto.
+ apply IHalloc_variables. red; intros. rewrite PTree.gsspec in H2.
+ destruct (peq id0 id). inv H2.
+ eapply Mem.load_alloc_same'; eauto.
+ omega. erewrite sizeof_by_value; eauto. omega.
+ apply Zdivide_0.
+ eapply Mem.load_alloc_other; eauto.
+Qed.
+
+Lemma create_undef_temps_charact:
+ forall id ty vars, In (id, ty) vars -> (create_undef_temps vars)!id = Some Vundef.
+Proof.
+ induction vars; simpl; intros.
+ contradiction.
+ destruct H. subst a. apply PTree.gss.
+ destruct a as [id1 ty1]. rewrite PTree.gsspec. destruct (peq id id1); auto.
+Qed.
+
+Lemma create_undef_temps_inv:
+ forall vars id v, (create_undef_temps vars)!id = Some v -> v = Vundef /\ In id (var_names vars).
+Proof.
+ induction vars; simpl; intros.
+ rewrite PTree.gempty in H; congruence.
+ destruct a as [id1 ty1]. rewrite PTree.gsspec in H. destruct (peq id id1).
+ inv H. auto.
+ exploit IHvars; eauto. tauto.
+Qed.
+
+Lemma create_undef_temps_exten:
+ forall id l1 l2,
+ (In id (var_names l1) <-> In id (var_names l2)) ->
+ (create_undef_temps l1)!id = (create_undef_temps l2)!id.
+Proof.
+ assert (forall id l1 l2,
+ (In id (var_names l1) -> In id (var_names l2)) ->
+ (create_undef_temps l1)!id = None \/ (create_undef_temps l1)!id = (create_undef_temps l2)!id).
+ intros. destruct ((create_undef_temps l1)!id) as [v1|]_eqn; auto.
+ exploit create_undef_temps_inv; eauto. intros [A B]. subst v1.
+ exploit list_in_map_inv. unfold var_names in H. apply H. eexact B.
+ intros [[id1 ty1] [P Q]]. simpl in P; subst id1.
+ right; symmetry; eapply create_undef_temps_charact; eauto.
+ intros.
+ exploit (H id l1 l2). tauto.
+ exploit (H id l2 l1). tauto.
+ intuition congruence.
+Qed.
+
+Remark var_names_app:
+ forall vars1 vars2, var_names (vars1 ++ vars2) = var_names vars1 ++ var_names vars2.
+Proof.
+ intros. apply map_app.
+Qed.
+
+Remark filter_app:
+ forall (A: Type) (f: A -> bool) l1 l2,
+ List.filter f (l1 ++ l2) = List.filter f l1 ++ List.filter f l2.
+Proof.
+ induction l1; simpl; intros.
+ auto.
+ destruct (f a). simpl. decEq; auto. auto.
+Qed.
+
+Remark filter_charact:
+ forall (A: Type) (f: A -> bool) x l,
+ In x (List.filter f l) <-> In x l /\ f x = true.
+Proof.
+ induction l; simpl. tauto.
+ destruct (f a) as []_eqn.
+ simpl. rewrite IHl. intuition congruence.
+ intuition congruence.
+Qed.
+
+Remark filter_norepet:
+ forall (A: Type) (f: A -> bool) l,
+ list_norepet l -> list_norepet (List.filter f l).
+Proof.
+ induction 1; simpl. constructor.
+ destruct (f hd); auto. constructor; auto. rewrite filter_charact. tauto.
+Qed.
+
+Remark filter_map:
+ forall (A B: Type) (f: A -> B) (pa: A -> bool) (pb: B -> bool),
+ (forall a, pb (f a) = pa a) ->
+ forall l, List.map f (List.filter pa l) = List.filter pb (List.map f l).
+Proof.
+ induction l; simpl.
+ auto.
+ rewrite H. destruct (pa a); simpl; congruence.
+Qed.
+
+Lemma create_undef_temps_lifted:
+ forall id f,
+ ~ In id (var_names (fn_params f)) ->
+ (create_undef_temps (add_lifted (cenv_for f) (fn_vars f) (fn_temps f))) ! id =
+ (create_undef_temps (add_lifted (cenv_for f) (fn_params f ++ fn_vars f) (fn_temps f))) ! id.
+Proof.
+ intros. apply create_undef_temps_exten.
+ unfold add_lifted. rewrite filter_app.
+ unfold var_names in *.
+ repeat rewrite map_app. repeat rewrite in_app. intuition.
+ exploit list_in_map_inv; eauto. intros [[id1 ty1] [P Q]]. simpl in P. subst id.
+ rewrite filter_charact in Q. destruct Q.
+ elim H. change id1 with (fst (id1, ty1)). apply List.in_map. auto.
+Qed.
+
+Lemma vars_and_temps_properties:
+ forall cenv params vars temps,
+ list_norepet (var_names params ++ var_names vars) ->
+ list_disjoint (var_names params) (var_names temps) ->
+ list_norepet (var_names params)
+ /\ list_norepet (var_names (remove_lifted cenv (params ++ vars)))
+ /\ list_disjoint (var_names params) (var_names (add_lifted cenv vars temps)).
+Proof.
+ intros. rewrite list_norepet_app in H. destruct H as [A [B C]].
+ split. auto.
+ split. unfold remove_lifted. unfold var_names. erewrite filter_map.
+ instantiate (1 := fun a => negb (VSet.mem a cenv)). 2: auto.
+ apply filter_norepet. rewrite map_app. apply list_norepet_append; assumption.
+ unfold add_lifted. rewrite var_names_app.
+ unfold var_names at 2. erewrite filter_map.
+ instantiate (1 := fun a => VSet.mem a cenv). 2: auto.
+ change (map fst vars) with (var_names vars).
+ red; intros.
+ rewrite in_app in H1. destruct H1.
+ rewrite filter_charact in H1. destruct H1. apply C; auto.
+ apply H0; auto.
+Qed.
+
+Theorem match_envs_alloc_variables:
+ forall cenv m vars e m' temps j tm,
+ alloc_variables empty_env m vars e m' ->
+ list_norepet (var_names vars) ->
+ Mem.inject j m tm ->
+ (forall id ty, In (id, ty) vars -> VSet.mem id cenv = true ->
+ exists chunk, access_mode ty = By_value chunk) ->
+ (forall id, VSet.mem id cenv = true -> In id (var_names vars)) ->
+ exists j', exists te, exists tm',
+ alloc_variables empty_env tm (remove_lifted cenv vars) te tm'
+ /\ match_envs j' cenv e (create_undef_temps temps) m' (Mem.nextblock m) (Mem.nextblock m')
+ te (create_undef_temps (add_lifted cenv vars temps)) (Mem.nextblock tm) (Mem.nextblock tm')
+ /\ Mem.inject j' m' tm'
+ /\ inject_incr j j'
+ /\ (forall b, Mem.valid_block m b -> j' b = j b)
+ /\ (forall b b' delta, j' b = Some(b', delta) -> Mem.valid_block tm b' -> j' b = j b).
+Proof.
+ intros.
+ exploit (match_alloc_variables cenv); eauto. instantiate (1 := empty_env).
+ intros [j' [te [tm' [A [B [C [D [E [K [F G]]]]]]]]]].
+ exists j'; exists te; exists tm'.
+ split. auto. split; auto.
+ constructor; intros.
+ (* vars *)
+ destruct (In_dec ident_eq id (var_names vars)).
+ unfold var_names in i. exploit list_in_map_inv; eauto.
+ intros [[id' ty] [EQ IN]]; simpl in EQ; subst id'.
+ exploit F; eauto. intros [b [P R]].
+ destruct (VSet.mem id cenv) as []_eqn.
+ (* local var, lifted *)
+ destruct R as [U V]. exploit H2; eauto. intros [chunk X].
+ eapply match_var_lifted with (v := Vundef) (tv := Vundef); eauto.
+ rewrite U; apply PTree.gempty.
+ eapply alloc_variables_initial_value; eauto.
+ red. unfold empty_env; intros. rewrite PTree.gempty in H4; congruence.
+ apply create_undef_temps_charact with ty.
+ unfold add_lifted. apply in_or_app. left.
+ rewrite filter_In. auto.
+ (* local var, not lifted *)
+ destruct R as [tb [U V]].
+ eapply match_var_not_lifted; eauto.
+ (* non-local var *)
+ exploit G; eauto. unfold empty_env. rewrite PTree.gempty. intros [U V].
+ eapply match_var_not_local; eauto.
+ destruct (VSet.mem id cenv) as []_eqn; auto.
+ elim n; eauto.
+
+ (* temps *)
+ exploit create_undef_temps_inv; eauto. intros [P Q]. subst v.
+ unfold var_names in Q. exploit list_in_map_inv; eauto.
+ intros [[id1 ty] [EQ IN]]; simpl in EQ; subst id1.
+ split; auto. exists Vundef; split; auto.
+ apply create_undef_temps_charact with ty. unfold add_lifted.
+ apply in_or_app; auto.
+
+ (* injective *)
+ eapply alloc_variables_injective. eexact H.
+ rewrite PTree.gempty. congruence.
+ intros. rewrite PTree.gempty in H7. congruence.
+ eauto. eauto. auto.
+
+ (* range *)
+ exploit alloc_variables_range. eexact H. eauto.
+ rewrite PTree.gempty. intuition congruence.
+
+ (* trange *)
+ exploit alloc_variables_range. eexact A. eauto.
+ rewrite PTree.gempty. intuition congruence.
+
+ (* mapped *)
+ destruct (In_dec ident_eq id (var_names vars)).
+ unfold var_names in i. exploit list_in_map_inv; eauto.
+ intros [[id' ty'] [EQ IN]]; simpl in EQ; subst id'.
+ exploit F; eauto. intros [b [P Q]].
+ destruct (VSet.mem id cenv).
+ rewrite PTree.gempty in Q. destruct Q; congruence.
+ destruct Q as [tb [U V]]. exists b; split; congruence.
+ exploit G; eauto. rewrite PTree.gempty. intuition congruence.
+
+ (* flat *)
+ exploit alloc_variables_range. eexact A. eauto.
+ rewrite PTree.gempty. intros [P|P]. congruence.
+ exploit K; eauto. unfold Mem.valid_block. omega.
+ intros [id0 [ty0 [U [V W]]]]. split; auto.
+ destruct (ident_eq id id0). congruence.
+ assert (b' <> b').
+ eapply alloc_variables_injective with (e' := te) (id1 := id) (id2 := id0); eauto.
+ rewrite PTree.gempty; congruence.
+ intros until ty1; rewrite PTree.gempty; congruence.
+ congruence.
+
+ (* incr *)
+ eapply alloc_variables_nextblock; eauto.
+ eapply alloc_variables_nextblock; eauto.
+Qed.
+
+Lemma assign_loc_inject:
+ forall f ty m loc ofs v m' tm loc' ofs' v',
+ assign_loc ty m loc ofs v m' ->
+ val_inject f (Vptr loc ofs) (Vptr loc' ofs') ->
+ val_inject f v v' ->
+ Mem.inject f m tm ->
+ exists tm',
+ assign_loc ty tm loc' ofs' v' tm'
+ /\ Mem.inject f m' tm'
+ /\ (forall b chunk v,
+ f b = None -> Mem.load chunk m b 0 = Some v -> Mem.load chunk m' b 0 = Some v).
+Proof.
+ intros. inv H.
+ (* by value *)
+ exploit Mem.storev_mapped_inject; eauto. intros [tm' [A B]].
+ exists tm'; split. eapply assign_loc_value; eauto.
+ split. auto.
+ intros. rewrite <- H5. eapply Mem.load_store_other; eauto.
+ left. inv H0. congruence.
+ (* by copy *)
+ inv H0. inv H1.
+ rename b' into bsrc. rename ofs'0 into osrc.
+ rename loc into bdst. rename ofs into odst.
+ rename loc' into bdst'. rename b2 into bsrc'.
+ exploit Mem.loadbytes_length; eauto. intros LEN.
+ assert (SZPOS: sizeof ty > 0) by apply sizeof_pos.
+ assert (RPSRC: Mem.range_perm m bsrc (Int.unsigned osrc) (Int.unsigned osrc + sizeof ty) Cur Nonempty).
+ eapply Mem.range_perm_implies. eapply Mem.loadbytes_range_perm; eauto. auto with mem.
+ assert (RPDST: Mem.range_perm m bdst (Int.unsigned odst) (Int.unsigned odst + sizeof ty) Cur Nonempty).
+ replace (sizeof ty) with (Z_of_nat (length bytes)).
+ eapply Mem.range_perm_implies. eapply Mem.storebytes_range_perm; eauto. auto with mem.
+ rewrite LEN. apply nat_of_Z_eq. omega.
+ assert (PSRC: Mem.perm m bsrc (Int.unsigned osrc) Cur Nonempty).
+ apply RPSRC. omega.
+ assert (PDST: Mem.perm m bdst (Int.unsigned odst) Cur Nonempty).
+ apply RPDST. omega.
+ exploit Mem.address_inject. eauto. apply Mem.perm_cur_max. eexact PSRC. eauto. intros EQ1.
+ exploit Mem.address_inject. eauto. apply Mem.perm_cur_max. eexact PDST. eauto. intros EQ2.
+ exploit Mem.loadbytes_inject; eauto. intros [bytes2 [A B]].
+ exploit Mem.storebytes_mapped_inject; eauto. intros [tm' [C D]].
+ exists tm'.
+ split. eapply assign_loc_copy; try rewrite EQ1; try rewrite EQ2; eauto.
+ eapply Mem.aligned_area_inject with (m := m); eauto. apply alignof_1248.
+ apply sizeof_alignof_compat.
+ eapply Mem.aligned_area_inject with (m := m); eauto. apply alignof_1248.
+ apply sizeof_alignof_compat.
+ eapply Mem.disjoint_or_equal_inject with (m := m); eauto.
+ apply Mem.range_perm_max with Cur; auto.
+ apply Mem.range_perm_max with Cur; auto.
+ split. auto.
+ intros. rewrite <- H0. eapply Mem.load_storebytes_other; eauto.
+ left. congruence.
+Qed.
+
+Remark bind_parameter_temps_inv:
+ forall id params args le le',
+ bind_parameter_temps params args le = Some le' ->
+ ~In id (var_names params) ->
+ le'!id = le!id.
+Proof.
+ induction params; simpl; intros.
+ destruct args; inv H. auto.
+ destruct a as [id1 ty1]. destruct args; try discriminate.
+ transitivity ((PTree.set id1 v le)!id).
+ eapply IHparams; eauto. apply PTree.gso. intuition.
+Qed.
+
+Lemma assign_loc_nextblock:
+ forall ty m b ofs v m',
+ assign_loc ty m b ofs v m' -> Mem.nextblock m' = Mem.nextblock m.
+Proof.
+ induction 1.
+ simpl in H0. eapply Mem.nextblock_store; eauto.
+ eapply Mem.nextblock_storebytes; eauto.
+Qed.
+
+Theorem store_params_correct:
+ forall j f k cenv le lo hi te tlo thi e m params args m',
+ bind_parameters e m params args m' ->
+ forall s tm tle1 tle2 targs,
+ list_norepet (var_names params) ->
+ list_forall2 val_casted args (map snd params) ->
+ val_list_inject j args targs ->
+ match_envs j cenv e le m lo hi te tle1 tlo thi ->
+ Mem.inject j m tm ->
+ (forall id, ~In id (var_names params) -> tle2!id = tle1!id) ->
+ (forall id, In id (var_names params) -> le!id = None) ->
+ exists tle, exists tm',
+ star step2 tge (State f (store_params cenv params s) k te tle tm)
+ E0 (State f s k te tle tm')
+ /\ bind_parameter_temps params targs tle2 = Some tle
+ /\ Mem.inject j m' tm'
+ /\ match_envs j cenv e le m' lo hi te tle tlo thi
+ /\ Mem.nextblock tm' = Mem.nextblock tm.
+Proof.
+ induction 1; simpl; intros until targs; intros NOREPET CASTED VINJ MENV MINJ TLE LE.
+ (* base case *)
+ inv VINJ. exists tle2; exists tm; split. apply star_refl. split. auto. split. auto.
+ split. apply match_envs_temps_exten with tle1; auto. auto.
+ (* inductive case *)
+ inv NOREPET. inv CASTED. inv VINJ.
+ exploit me_vars; eauto. instantiate (1 := id); intros MV.
+ destruct (VSet.mem id cenv) as []_eqn.
+ (* lifted to temp *)
+ eapply IHbind_parameters with (tle1 := PTree.set id v' tle1); eauto.
+ eapply match_envs_assign_lifted; eauto.
+ inv MV; try congruence. rewrite ENV in H; inv H.
+ inv H0; try congruence.
+ unfold Mem.storev in H2. eapply Mem.store_unmapped_inject; eauto.
+ intros. repeat rewrite PTree.gsspec. destruct (peq id0 id). auto.
+ apply TLE. intuition.
+ (* still in memory *)
+ inv MV; try congruence. rewrite ENV in H; inv H.
+ exploit assign_loc_inject; eauto.
+ intros [tm1 [A [B C]]].
+ exploit IHbind_parameters. eauto. eauto. eauto.
+ instantiate (1 := PTree.set id v' tle1).
+ apply match_envs_change_temp.
+ eapply match_envs_invariant; eauto.
+ apply LE; auto. auto.
+ eauto.
+ instantiate (1 := PTree.set id v' tle2).
+ intros. repeat rewrite PTree.gsspec. destruct (peq id0 id). auto.
+ apply TLE. intuition.
+ intros. apply LE. auto.
+ instantiate (1 := s).
+ intros [tle [tm' [U [V [X [Y Z]]]]]].
+ exists tle; exists tm'; split.
+ eapply star_trans.
+ eapply star_left. econstructor.
+ eapply star_left. econstructor.
+ eapply eval_Evar_local. eauto.
+ eapply eval_Etempvar. erewrite bind_parameter_temps_inv; eauto.
+ apply PTree.gss.
+ simpl. instantiate (1 := v'). apply cast_val_casted.
+ eapply val_casted_inject with (v := v1); eauto.
+ simpl. eexact A.
+ apply star_one. constructor.
+ reflexivity. reflexivity.
+ eexact U.
+ traceEq.
+ rewrite (assign_loc_nextblock _ _ _ _ _ _ A) in Z. auto.
+Qed.
+
+Lemma bind_parameters_nextblock:
+ forall e m params args m',
+ bind_parameters e m params args m' -> Mem.nextblock m' = Mem.nextblock m.
+Proof.
+ induction 1.
+ auto.
+ rewrite IHbind_parameters. eapply assign_loc_nextblock; eauto.
+Qed.
+
+Lemma bind_parameters_load:
+ forall e chunk b ofs,
+ (forall id b' ty, e!id = Some(b', ty) -> b <> b') ->
+ forall m params args m',
+ bind_parameters e m params args m' ->
+ Mem.load chunk m' b ofs = Mem.load chunk m b ofs.
+Proof.
+ induction 2.
+ auto.
+ rewrite IHbind_parameters.
+ assert (b <> b0) by eauto.
+ inv H1.
+ simpl in H5. eapply Mem.load_store_other; eauto.
+ eapply Mem.load_storebytes_other; eauto.
+Qed.
+
+(** Freeing of local variables *)
+
+Lemma free_blocks_of_env_perm_1:
+ forall m e m' id b ty ofs k p,
+ Mem.free_list m (blocks_of_env e) = Some m' ->
+ e!id = Some(b, ty) ->
+ Mem.perm m' b ofs k p ->
+ 0 <= ofs < sizeof ty ->
+ False.
+Proof.
+ intros. exploit Mem.perm_free_list; eauto. intros [A B].
+ apply B with 0 (sizeof ty); auto.
+ unfold blocks_of_env. change (b, 0, sizeof ty) with (block_of_binding (id, (b, ty))).
+ apply in_map. apply PTree.elements_correct. auto.
+Qed.
+
+Lemma free_list_perm':
+ forall b lo hi l m m',
+ Mem.free_list m l = Some m' ->
+ In (b, lo, hi) l ->
+ Mem.range_perm m b lo hi Cur Freeable.
+Proof.
+ induction l; simpl; intros.
+ contradiction.
+ destruct a as [[b1 lo1] hi1].
+ destruct (Mem.free m b1 lo1 hi1) as [m1|]_eqn; try discriminate.
+ destruct H0. inv H0. eapply Mem.free_range_perm; eauto.
+ red; intros. eapply Mem.perm_free_3; eauto. eapply IHl; eauto.
+Qed.
+
+Lemma free_blocks_of_env_perm_2:
+ forall m e m' id b ty,
+ Mem.free_list m (blocks_of_env e) = Some m' ->
+ e!id = Some(b, ty) ->
+ Mem.range_perm m b 0 (sizeof ty) Cur Freeable.
+Proof.
+ intros. eapply free_list_perm'; eauto.
+ unfold blocks_of_env. change (b, 0, sizeof ty) with (block_of_binding (id, (b, ty))).
+ apply in_map. apply PTree.elements_correct. auto.
+Qed.
+
+Lemma can_free_list:
+ forall l m,
+ (forall b lo hi, In (b, lo, hi) l -> Mem.range_perm m b lo hi Cur Freeable) ->
+ list_norepet (map (fun b_lo_hi => fst(fst b_lo_hi)) l) ->
+ exists m', Mem.free_list m l = Some m'.
+Proof.
+ induction l; simpl; intros.
+ exists m; auto.
+ destruct a as [[b lo] hi]. simpl in H0. inv H0.
+ destruct (Mem.range_perm_free m b lo hi) as [m1 A]; auto.
+ rewrite A. apply IHl; auto. intros.
+ red; intros. eapply Mem.perm_free_1; eauto.
+ left; red; intros. subst b0. elim H3.
+ set (F := fun b_lo_hi : block * Z * Z => fst (fst b_lo_hi)).
+ change b with (F (b,lo0,hi0)). eapply in_map; auto.
+ eapply H; eauto.
+Qed.
+
+Lemma free_list_right_inject:
+ forall j m1 l m2 m2',
+ Mem.inject j m1 m2 ->
+ Mem.free_list m2 l = Some m2' ->
+ (forall b1 b2 delta lo hi ofs k p,
+ j b1 = Some(b2, delta) -> In (b2, lo, hi) l ->
+ Mem.perm m1 b1 ofs k p -> lo <= ofs + delta < hi -> False) ->
+ Mem.inject j m1 m2'.
+Proof.
+ induction l; simpl; intros.
+ congruence.
+ destruct a as [[b lo] hi]. destruct (Mem.free m2 b lo hi) as [m21|]_eqn; try discriminate.
+ eapply IHl with (m2 := m21); eauto.
+ eapply Mem.free_right_inject; eauto.
+Qed.
+
+Theorem match_envs_free_blocks:
+ forall j cenv e le m lo hi te tle tlo thi m' tm,
+ match_envs j cenv e le m lo hi te tle tlo thi ->
+ Mem.inject j m tm ->
+ Mem.free_list m (blocks_of_env e) = Some m' ->
+ exists tm',
+ Mem.free_list tm (blocks_of_env te) = Some tm'
+ /\ Mem.inject j m' tm'.
+Proof.
+ intros.
+ assert (exists tm', Mem.free_list tm (blocks_of_env te) = Some tm').
+ apply can_free_list.
+ intros. unfold blocks_of_env in H2.
+ exploit list_in_map_inv; eauto. intros [[id [b' ty]] [EQ IN]].
+ simpl in EQ; inv EQ.
+ exploit me_mapped; eauto. eapply PTree.elements_complete; eauto.
+ intros [b [A B]].
+ change 0 with (0 + 0). replace (sizeof ty) with (sizeof ty + 0) by omega.
+ eapply Mem.range_perm_inject; eauto.
+ eapply free_blocks_of_env_perm_2; eauto.
+ (* no repetitions *)
+ set (F := fun id => match te!id with Some(b, ty) => b | None => 0 end).
+ replace (map (fun b_lo_hi : block * Z * Z => fst (fst b_lo_hi)) (blocks_of_env te))
+ with (map F (map (fun x => fst x) (PTree.elements te))).
+ apply list_map_norepet. apply PTree.elements_keys_norepet.
+ intros.
+ exploit list_in_map_inv. eexact H2. intros [[id1 [b1' ty1]] [EQ1 IN1]].
+ exploit list_in_map_inv. eexact H3. intros [[id2 [b2' ty2]] [EQ2 IN2]].
+ simpl in *. subst x y.
+ assert (te!id1 = Some(b1', ty1)) by (apply PTree.elements_complete; auto).
+ assert (te!id2 = Some(b2', ty2)) by (apply PTree.elements_complete; auto).
+ exploit me_mapped. eauto. eexact H5. intros [b1 [P1 Q1]].
+ exploit me_mapped. eauto. eexact H6. intros [b2 [P2 Q2]].
+ assert (b1 <> b2) by (eapply me_inj; eauto).
+ exploit Mem.mi_no_overlap; eauto.
+ instantiate (1 := 0). apply Mem.perm_cur_max. apply Mem.perm_implies with Freeable; auto with mem.
+ eapply free_blocks_of_env_perm_2; eauto. generalize (sizeof_pos ty1); omega.
+ instantiate (1 := 0). apply Mem.perm_cur_max. apply Mem.perm_implies with Freeable; auto with mem.
+ eapply free_blocks_of_env_perm_2; eauto. generalize (sizeof_pos ty2); omega.
+ intros [A | A]; try omegaContradiction.
+ unfold F. rewrite H5; rewrite H6. auto.
+ unfold blocks_of_env. repeat rewrite list_map_compose. apply list_map_exten; intros.
+ unfold F. destruct x as [id [b ty]]. simpl. erewrite PTree.elements_complete; eauto. auto.
+ destruct H2 as [tm' FREE].
+ exists tm'; split; auto.
+ eapply free_list_right_inject; eauto.
+ eapply Mem.free_list_left_inject; eauto.
+ intros. unfold blocks_of_env in H3. exploit list_in_map_inv; eauto.
+ intros [[id [b' ty]] [EQ IN]]. simpl in EQ. inv EQ.
+ exploit me_flat; eauto. apply PTree.elements_complete; eauto.
+ intros [P Q]. subst delta. eapply free_blocks_of_env_perm_1 with (m := m); eauto.
+ omega.
+Qed.
+
+(** Matching global environments *)
+
+Inductive match_globalenvs (f: meminj) (bound: Z): Prop :=
+ | mk_match_globalenvs
+ (POS: bound > 0)
+ (DOMAIN: forall b, b < bound -> f b = Some(b, 0))
+ (IMAGE: forall b1 b2 delta, f b1 = Some(b2, delta) -> b2 < bound -> b1 = b2)
+ (SYMBOLS: forall id b, Genv.find_symbol ge id = Some b -> b < bound)
+ (FUNCTIONS: forall b fd, Genv.find_funct_ptr ge b = Some fd -> b < bound)
+ (VARINFOS: forall b gv, Genv.find_var_info ge b = Some gv -> b < bound).
+
+Lemma match_globalenvs_preserves_globals:
+ forall f,
+ (exists bound, match_globalenvs f bound) ->
+ meminj_preserves_globals ge f.
+Proof.
+ intros. destruct H as [bound MG]. inv MG.
+ split; intros. eauto. split; intros. eauto. symmetry. eapply IMAGE; eauto.
+Qed.
+
+(** Evaluation of expressions *)
+
+Section EVAL_EXPR.
+
+Variables e te: env.
+Variables le tle: temp_env.
+Variables m tm: mem.
+Variable f: meminj.
+Variable cenv: compilenv.
+Variables lo hi tlo thi: Z.
+Hypothesis MATCH: match_envs f cenv e le m lo hi te tle tlo thi.
+Hypothesis MEMINJ: Mem.inject f m tm.
+Hypothesis GLOB: exists bound, match_globalenvs f bound.
+
+Lemma typeof_simpl_expr:
+ forall a, typeof (simpl_expr cenv a) = typeof a.
+Proof.
+ destruct a; simpl; auto. destruct (VSet.mem i cenv); auto.
+Qed.
+
+Lemma deref_loc_inject:
+ forall ty loc ofs v loc' ofs',
+ deref_loc ty m loc ofs v ->
+ val_inject f (Vptr loc ofs) (Vptr loc' ofs') ->
+ exists tv, deref_loc ty tm loc' ofs' tv /\ val_inject f v tv.
+Proof.
+ intros. inv H.
+ (* by value *)
+ exploit Mem.loadv_inject; eauto. intros [tv [A B]].
+ exists tv; split; auto. eapply deref_loc_value; eauto.
+ (* by reference *)
+ exists (Vptr loc' ofs'); split; auto. eapply deref_loc_reference; eauto.
+ (* by copy *)
+ exists (Vptr loc' ofs'); split; auto. eapply deref_loc_copy; eauto.
+Qed.
+
+Remark val_inject_vtrue: forall f, val_inject f Vtrue Vtrue.
+Proof. unfold Vtrue; auto. Qed.
+
+Remark val_inject_vfalse: forall f, val_inject f Vfalse Vfalse.
+Proof. unfold Vfalse; auto. Qed.
+
+Remark val_inject_of_bool: forall f b, val_inject f (Val.of_bool b) (Val.of_bool b).
+Proof. intros. unfold Val.of_bool. destruct b; [apply val_inject_vtrue|apply val_inject_vfalse].
+Qed.
+
+Hint Resolve val_inject_vtrue val_inject_vfalse val_inject_of_bool.
+
+Ltac TrivialInject :=
+ match goal with
+ | |- exists v', Some ?v = Some v' /\ _ => exists v; split; auto
+(*
+ | |- exists v', _ /\ val_inject _ (Vint ?n) _ => exists (Vint n); split; auto
+ | |- exists v', _ /\ val_inject _ (Vfloat ?n) _ => exists (Vfloat n); split; auto
+ | |- exists v', _ /\ val_inject _ Vtrue _ => exists Vtrue; split; auto
+ | |- exists v', _ /\ val_inject _ Vfalse _ => exists Vfalse; split; auto
+ | |- exists v', _ /\ val_inject _ (Val.of_bool ?b) _ => exists (Val.of_bool b); split; auto
+*)
+ | _ => idtac
+ end.
+
+Lemma sem_unary_operation_inject:
+ forall op v1 ty v tv1,
+ sem_unary_operation op v1 ty = Some v ->
+ val_inject f v1 tv1 ->
+ exists tv, sem_unary_operation op tv1 ty = Some tv /\ val_inject f v tv.
+Proof.
+ unfold sem_unary_operation; intros. destruct op.
+ (* notbool *)
+ unfold sem_notbool in *; destruct (classify_bool ty); inv H0; inv H; TrivialInject.
+ (* notint *)
+ unfold sem_notint in *; destruct (classify_notint ty); inv H0; inv H; TrivialInject.
+ (* neg *)
+ unfold sem_neg in *; destruct (classify_neg ty); inv H0; inv H; TrivialInject.
+Qed.
+
+Lemma sem_cmp_inject:
+ forall cmp v1 tv1 ty1 v2 tv2 ty2 v,
+ sem_cmp cmp v1 ty1 v2 ty2 m = Some v ->
+ val_inject f v1 tv1 ->
+ val_inject f v2 tv2 ->
+ exists tv, sem_cmp cmp tv1 ty1 tv2 ty2 tm = Some tv /\ val_inject f v tv.
+Proof.
+ unfold sem_cmp; intros.
+ assert (MM: sem_cmp_mismatch cmp = Some v ->
+ exists tv, sem_cmp_mismatch cmp = Some tv /\ val_inject f v tv).
+ intros. exists v; split; auto.
+ destruct cmp; simpl in H2; inv H2; auto.
+
+ destruct (classify_cmp ty1 ty2); try destruct s; inv H0; try discriminate; inv H1; inv H; TrivialInject.
+ destruct (Int.eq i Int.zero); try discriminate; auto.
+ destruct (Int.eq i Int.zero); try discriminate; auto.
+ destruct (Mem.valid_pointer m b1 (Int.unsigned ofs1)) as []_eqn; try discriminate.
+ destruct (Mem.valid_pointer m b0 (Int.unsigned ofs0)) as []_eqn; try discriminate.
+ simpl in H3.
+ rewrite (Mem.valid_pointer_inject_val _ _ _ _ _ _ _ MEMINJ Heqb).
+ rewrite (Mem.valid_pointer_inject_val _ _ _ _ _ _ _ MEMINJ Heqb0).
+ simpl.
+ destruct (zeq b1 b0). subst b1. rewrite H0 in H2; inv H2. rewrite zeq_true.
+ replace (Int.cmpu cmp (Int.add ofs1 (Int.repr delta))
+ (Int.add ofs0 (Int.repr delta)))
+ with (Int.cmpu cmp ofs1 ofs0).
+ inv H3; TrivialInject.
+ symmetry. apply Int.translate_cmpu.
+ eapply Mem.valid_pointer_inject_no_overflow; eauto.
+ eapply Mem.valid_pointer_inject_no_overflow; eauto.
+ destruct (zeq b2 b3).
+ exploit Mem.different_pointers_inject; eauto. intros [A|A]. contradiction.
+ destruct cmp; simpl in H3; inv H3.
+ simpl. unfold Int.eq. rewrite zeq_false; auto.
+ simpl. unfold Int.eq. rewrite zeq_false; auto.
+ auto.
+ econstructor; eauto. econstructor; eauto.
+Qed.
+
+Lemma sem_binary_operation_inject:
+ forall op v1 ty1 v2 ty2 v tv1 tv2,
+ sem_binary_operation op v1 ty1 v2 ty2 m = Some v ->
+ val_inject f v1 tv1 -> val_inject f v2 tv2 ->
+ exists tv, sem_binary_operation op tv1 ty1 tv2 ty2 tm = Some tv /\ val_inject f v tv.
+Proof.
+ unfold sem_binary_operation; intros. destruct op.
+(* add *)
+ unfold sem_add in *; destruct (classify_add ty1 ty2); inv H0; try discriminate; inv H1; inv H; TrivialInject.
+ econstructor. eauto. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut.
+ econstructor. eauto. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut.
+(* sub *)
+ unfold sem_sub in *; destruct (classify_sub ty1 ty2); inv H0; try discriminate; inv H1; inv H; TrivialInject.
+ econstructor. eauto. rewrite Int.sub_add_l. auto.
+ destruct (zeq b1 b0); try discriminate. subst b1. rewrite H0 in H2; inv H2.
+ rewrite zeq_true. destruct (Int.eq (Int.repr (sizeof ty)) Int.zero); inv H3.
+ rewrite Int.sub_shifted. TrivialInject.
+(* mul *)
+ unfold sem_mul in *; destruct (classify_mul ty1 ty2); inv H0; try discriminate; inv H1; inv H; TrivialInject.
+(* div *)
+ unfold sem_div in *; destruct (classify_div ty1 ty2); try destruct s; inv H0; try discriminate; inv H1; inv H; TrivialInject.
+ destruct ( Int.eq i0 Int.zero
+ || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H1; TrivialInject.
+ destruct (Int.eq i0 Int.zero); inv H1; TrivialInject.
+(* mod *)
+ unfold sem_mod in *; destruct (classify_binint ty1 ty2); try destruct s; inv H0; try discriminate; inv H1; inv H; TrivialInject.
+ destruct ( Int.eq i0 Int.zero
+ || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H1; TrivialInject.
+ destruct (Int.eq i0 Int.zero); inv H1; TrivialInject.
+(* and *)
+ unfold sem_and in *; destruct (classify_binint ty1 ty2); inv H0; try discriminate; inv H1; inv H; TrivialInject.
+(* or *)
+ unfold sem_or in *; destruct (classify_binint ty1 ty2); inv H0; try discriminate; inv H1; inv H; TrivialInject.
+(* xor *)
+ unfold sem_xor in *; destruct (classify_binint ty1 ty2); inv H0; try discriminate; inv H1; inv H; TrivialInject.
+(* shl *)
+ unfold sem_shl in *; destruct (classify_shift ty1 ty2); inv H0; try discriminate; inv H1; inv H; TrivialInject.
+ destruct (Int.ltu i0 Int.iwordsize); inv H1; TrivialInject.
+(* shr *)
+ unfold sem_shr in *; destruct (classify_shift ty1 ty2); try destruct s; inv H0; try discriminate; inv H1; inv H; TrivialInject.
+ destruct (Int.ltu i0 Int.iwordsize); inv H1; TrivialInject.
+ destruct (Int.ltu i0 Int.iwordsize); inv H1; TrivialInject.
+(* comparisons *)
+ eapply sem_cmp_inject; eauto.
+ eapply sem_cmp_inject; eauto.
+ eapply sem_cmp_inject; eauto.
+ eapply sem_cmp_inject; eauto.
+ eapply sem_cmp_inject; eauto.
+ eapply sem_cmp_inject; eauto.
+Qed.
+
+Lemma sem_cast_inject:
+ forall v1 ty1 ty v tv1,
+ sem_cast v1 ty1 ty = Some v ->
+ val_inject f v1 tv1 ->
+ exists tv, sem_cast tv1 ty1 ty = Some tv /\ val_inject f v tv.
+Proof.
+ unfold sem_cast; intros.
+ destruct (classify_cast ty1 ty); try discriminate.
+ inv H0; inv H; TrivialInject. econstructor; eauto.
+ inv H0; inv H; TrivialInject.
+ inv H0; inv H; TrivialInject.
+ inv H0; inv H; TrivialInject.
+ inv H0; try discriminate. destruct (cast_float_int si2 f0); inv H. TrivialInject.
+ inv H0; inv H. TrivialInject.
+ inv H0; inv H. TrivialInject.
+ TrivialInject.
+ destruct (ident_eq id1 id2 && fieldlist_eq fld1 fld2); inv H. TrivialInject.
+ destruct (ident_eq id1 id2 && fieldlist_eq fld1 fld2); inv H. TrivialInject.
+ inv H; TrivialInject.
+Qed.
+
+Lemma bool_val_inject:
+ forall v ty b tv,
+ bool_val v ty = Some b ->
+ val_inject f v tv ->
+ bool_val tv ty = Some b.
+Proof.
+ unfold bool_val; intros.
+ destruct (classify_bool ty); inv H0; congruence.
+Qed.
+
+Lemma eval_simpl_expr:
+ forall a v,
+ eval_expr ge e le m a v ->
+ compat_cenv (addr_taken_expr a) cenv ->
+ exists tv, eval_expr tge te tle tm (simpl_expr cenv a) tv /\ val_inject f v tv
+
+with eval_simpl_lvalue:
+ forall a b ofs,
+ eval_lvalue ge e le m a b ofs ->
+ compat_cenv (addr_taken_expr a) cenv ->
+ match a with Evar id ty => VSet.mem id cenv = false | _ => True end ->
+ exists b', exists ofs', eval_lvalue tge te tle tm (simpl_expr cenv a) b' ofs' /\ val_inject f (Vptr b ofs) (Vptr b' ofs').
+
+Proof.
+ destruct 1; simpl; intros.
+(* const *)
+ exists (Vint i); split; auto. constructor.
+ exists (Vfloat f0); split; auto. constructor.
+(* tempvar *)
+ exploit me_temps; eauto. intros [[tv [A B]] C].
+ exists tv; split; auto. constructor; auto.
+(* addrof *)
+ exploit eval_simpl_lvalue; eauto.
+ destruct a; auto with compat.
+ destruct a; auto. destruct (VSet.mem i cenv) as []_eqn; auto.
+ elim (H0 i). apply VSet.singleton_2. auto. apply VSet.mem_2. auto.
+ intros [b' [ofs' [A B]]].
+ exists (Vptr b' ofs'); split; auto. constructor; auto.
+(* unop *)
+ exploit eval_simpl_expr; eauto. intros [tv1 [A B]].
+ exploit sem_unary_operation_inject; eauto. intros [tv [C D]].
+ exists tv; split; auto. econstructor; eauto. rewrite typeof_simpl_expr; auto.
+(* binop *)
+ exploit eval_simpl_expr. eexact H. eauto with compat. intros [tv1 [A B]].
+ exploit eval_simpl_expr. eexact H0. eauto with compat. intros [tv2 [C D]].
+ exploit sem_binary_operation_inject; eauto. intros [tv [E F]].
+ exists tv; split; auto. econstructor; eauto. repeat rewrite typeof_simpl_expr; auto.
+(* cast *)
+ exploit eval_simpl_expr; eauto. intros [tv1 [A B]].
+ exploit sem_cast_inject; eauto. intros [tv2 [C D]].
+ exists tv2; split; auto. econstructor. eauto. rewrite typeof_simpl_expr; auto.
+(* rval *)
+ assert (EITHER: (exists id, exists ty, a = Evar id ty /\ VSet.mem id cenv = true)
+ \/ (match a with Evar id _ => VSet.mem id cenv = false | _ => True end)).
+ destruct a; auto. destruct (VSet.mem i cenv) as []_eqn; auto. left; exists i; exists t; auto.
+ destruct EITHER as [ [id [ty [EQ OPT]]] | NONOPT ].
+ (* a variable pulled out of memory *)
+ subst a. simpl. rewrite OPT.
+ exploit me_vars; eauto. instantiate (1 := id). intros MV.
+ inv H; inv MV; try congruence.
+ rewrite ENV in H6; inv H6.
+ inv H0; try congruence.
+ assert (chunk0 = chunk). simpl in H. congruence. subst chunk0.
+ assert (v0 = v). unfold Mem.loadv in H2. rewrite Int.unsigned_zero in H2. congruence. subst v0.
+ exists tv; split; auto. constructor; auto.
+ simpl in H; congruence.
+ simpl in H; congruence.
+ (* any other l-value *)
+ exploit eval_simpl_lvalue; eauto. intros [loc' [ofs' [A B]]].
+ exploit deref_loc_inject; eauto. intros [tv [C D]].
+ exists tv; split; auto. econstructor. eexact A. rewrite typeof_simpl_expr; auto.
+
+(* lvalues *)
+ destruct 1; simpl; intros.
+(* local var *)
+ rewrite H1.
+ exploit me_vars; eauto. instantiate (1 := id). intros MV. inv MV; try congruence.
+ rewrite ENV in H; inv H.
+ exists b'; exists Int.zero; split.
+ apply eval_Evar_local; auto.
+ econstructor; eauto.
+(* global var *)
+ rewrite H3.
+ exploit me_vars; eauto. instantiate (1 := id). intros MV. inv MV; try congruence.
+ exists l; exists Int.zero; split.
+ apply eval_Evar_global. auto. rewrite <- H0. apply symbols_preserved.
+ eapply type_of_global_preserved; eauto.
+ destruct GLOB as [bound GLOB1]. inv GLOB1.
+ econstructor; eauto.
+(* deref *)
+ exploit eval_simpl_expr; eauto. intros [tv [A B]].
+ inversion B. subst.
+ econstructor; econstructor; split; eauto. econstructor; eauto.
+(* field struct *)
+ exploit eval_simpl_expr; eauto. intros [tv [A B]].
+ inversion B. subst.
+ econstructor; econstructor; split.
+ eapply eval_Efield_struct; eauto. rewrite typeof_simpl_expr; eauto.
+ econstructor; eauto. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut.
+(* field union *)
+ exploit eval_simpl_expr; eauto. intros [tv [A B]].
+ inversion B. subst.
+ econstructor; econstructor; split.
+ eapply eval_Efield_union; eauto. rewrite typeof_simpl_expr; eauto. auto.
+Qed.
+
+Lemma eval_simpl_exprlist:
+ forall al tyl vl,
+ eval_exprlist ge e le m al tyl vl ->
+ compat_cenv (addr_taken_exprlist al) cenv ->
+ val_casted_list vl tyl /\
+ exists tvl,
+ eval_exprlist tge te tle tm (simpl_exprlist cenv al) tyl tvl
+ /\ val_list_inject f vl tvl.
+Proof.
+ induction 1; simpl; intros.
+ split. constructor. econstructor; split. constructor. auto.
+ exploit eval_simpl_expr; eauto with compat. intros [tv1 [A B]].
+ exploit sem_cast_inject; eauto. intros [tv2 [C D]].
+ exploit IHeval_exprlist; eauto with compat. intros [E [tvl [F G]]].
+ split. constructor; auto. eapply cast_val_is_casted; eauto.
+ exists (tv2 :: tvl); split. econstructor; eauto.
+ rewrite typeof_simpl_expr; auto.
+ econstructor; eauto.
+Qed.
+
+End EVAL_EXPR.
+
+(** Matching continuations *)
+
+Inductive match_cont (f: meminj): compilenv -> cont -> cont -> mem -> Z -> Z -> Prop :=
+ | match_Kstop: forall cenv m bound tbound hi,
+ match_globalenvs f hi -> hi <= bound -> hi <= tbound ->
+ match_cont f cenv Kstop Kstop m bound tbound
+ | match_Kseq: forall cenv s k ts tk m bound tbound,
+ simpl_stmt cenv s = OK ts ->
+ match_cont f cenv k tk m bound tbound ->
+ compat_cenv (addr_taken_stmt s) cenv ->
+ match_cont f cenv (Kseq s k) (Kseq ts tk) m bound tbound
+ | match_Kloop1: forall cenv s1 s2 k ts1 ts2 tk m bound tbound,
+ simpl_stmt cenv s1 = OK ts1 ->
+ simpl_stmt cenv s2 = OK ts2 ->
+ match_cont f cenv k tk m bound tbound ->
+ compat_cenv (VSet.union (addr_taken_stmt s1) (addr_taken_stmt s2)) cenv ->
+ match_cont f cenv (Kloop1 s1 s2 k) (Kloop1 ts1 ts2 tk) m bound tbound
+ | match_Kloop2: forall cenv s1 s2 k ts1 ts2 tk m bound tbound,
+ simpl_stmt cenv s1 = OK ts1 ->
+ simpl_stmt cenv s2 = OK ts2 ->
+ match_cont f cenv k tk m bound tbound ->
+ compat_cenv (VSet.union (addr_taken_stmt s1) (addr_taken_stmt s2)) cenv ->
+ match_cont f cenv (Kloop2 s1 s2 k) (Kloop2 ts1 ts2 tk) m bound tbound
+ | match_Kswitch: forall cenv k tk m bound tbound,
+ match_cont f cenv k tk m bound tbound ->
+ match_cont f cenv (Kswitch k) (Kswitch tk) m bound tbound
+ | match_Kcall: forall cenv optid fn e le k tfn te tle tk m hi thi lo tlo bound tbound x,
+ transf_function fn = OK tfn ->
+ match_envs f (cenv_for fn) e le m lo hi te tle tlo thi ->
+ match_cont f (cenv_for fn) k tk m lo tlo ->
+ check_opttemp (cenv_for fn) optid = OK x ->
+ hi <= bound -> thi <= tbound ->
+ match_cont f cenv (Kcall optid fn e le k)
+ (Kcall optid tfn te tle tk) m bound tbound.
+
+(** Invariance property by change of memory and injection *)
+
+Lemma match_cont_invariant:
+ forall f' m' f cenv k tk m bound tbound,
+ match_cont f cenv k tk m bound tbound ->
+ (forall b chunk v,
+ f b = None -> b < bound -> Mem.load chunk m b 0 = Some v -> Mem.load chunk m' b 0 = Some v) ->
+ inject_incr f f' ->
+ (forall b, b < bound -> f' b = f b) ->
+ (forall b b' delta, f' b = Some(b', delta) -> b' < tbound -> f' b = f b) ->
+ match_cont f' cenv k tk m' bound tbound.
+Proof.
+ induction 1; intros LOAD INCR INJ1 INJ2; econstructor; eauto.
+(* globalenvs *)
+ inv H. constructor; intros; eauto.
+ assert (f b1 = Some (b2, delta)). rewrite <- H; symmetry; eapply INJ2; eauto. omega.
+ eapply IMAGE; eauto.
+(* call *)
+ eapply match_envs_invariant; eauto.
+ intros. apply LOAD; auto. omega.
+ intros. apply INJ1; auto; omega.
+ intros. eapply INJ2; eauto; omega.
+ eapply IHmatch_cont; eauto.
+ intros; apply LOAD; auto. inv H0; omega.
+ intros; apply INJ1. inv H0; omega.
+ intros; eapply INJ2; eauto. inv H0; omega.
+Qed.
+
+(** Invariance by assignment to location "above" *)
+
+Lemma match_cont_assign_loc:
+ forall f cenv k tk m bound tbound ty loc ofs v m',
+ match_cont f cenv k tk m bound tbound ->
+ assign_loc ty m loc ofs v m' ->
+ bound <= loc ->
+ match_cont f cenv k tk m' bound tbound.
+Proof.
+ intros. eapply match_cont_invariant; eauto.
+ intros. rewrite <- H4. inv H0.
+ (* scalar *)
+ simpl in H6. eapply Mem.load_store_other; eauto. left. unfold block; omega.
+ (* block copy *)
+ eapply Mem.load_storebytes_other; eauto. left. unfold block; omega.
+Qed.
+
+(** Invariance by external calls *)
+
+Lemma match_cont_extcall:
+ forall f cenv k tk m bound tbound tm f' m',
+ match_cont f cenv k tk m bound tbound ->
+ mem_unchanged_on (loc_unmapped f) m m' ->
+ inject_incr f f' ->
+ inject_separated f f' m tm ->
+ bound <= Mem.nextblock m -> tbound <= Mem.nextblock tm ->
+ match_cont f' cenv k tk m' bound tbound.
+Proof.
+ intros. eapply match_cont_invariant; eauto.
+ destruct H0. intros. eapply H5; eauto.
+ red in H2. intros. destruct (f b) as [[b' delta] | ]_eqn. auto.
+ destruct (f' b) as [[b' delta] | ]_eqn; auto.
+ exploit H2; eauto. unfold Mem.valid_block. intros [A B]. omegaContradiction.
+ red in H2. intros. destruct (f b) as [[b'' delta''] | ]_eqn. auto.
+ exploit H2; eauto. unfold Mem.valid_block. intros [A B]. omegaContradiction.
+Qed.
+
+(** Invariance by change of bounds *)
+
+Lemma match_cont_incr_bounds:
+ forall f cenv k tk m bound tbound,
+ match_cont f cenv k tk m bound tbound ->
+ forall bound' tbound',
+ bound <= bound' -> tbound <= tbound' ->
+ match_cont f cenv k tk m bound' tbound'.
+Proof.
+ induction 1; intros; econstructor; eauto; omega.
+Qed.
+
+(** [match_cont] and call continuations. *)
+
+Lemma match_cont_change_cenv:
+ forall f cenv k tk m bound tbound cenv',
+ match_cont f cenv k tk m bound tbound ->
+ is_call_cont k ->
+ match_cont f cenv' k tk m bound tbound.
+Proof.
+ intros. inv H; simpl in H0; try contradiction; econstructor; eauto.
+Qed.
+
+Lemma match_cont_is_call_cont:
+ forall f cenv k tk m bound tbound,
+ match_cont f cenv k tk m bound tbound ->
+ is_call_cont k ->
+ is_call_cont tk.
+Proof.
+ intros. inv H; auto.
+Qed.
+
+Lemma match_cont_call_cont:
+ forall f cenv k tk m bound tbound,
+ match_cont f cenv k tk m bound tbound ->
+ forall cenv',
+ match_cont f cenv' (call_cont k) (call_cont tk) m bound tbound.
+Proof.
+ induction 1; simpl; auto; intros; econstructor; eauto.
+Qed.
+
+(** [match_cont] and freeing of environment blocks *)
+
+Remark free_list_nextblock:
+ forall l m m',
+ Mem.free_list m l = Some m' -> Mem.nextblock m' = Mem.nextblock m.
+Proof.
+ induction l; simpl; intros.
+ congruence.
+ destruct a. destruct p. destruct (Mem.free m b z0 z) as [m1|]_eqn; try discriminate.
+ transitivity (Mem.nextblock m1). eauto. eapply Mem.nextblock_free; eauto.
+Qed.
+
+Remark free_list_load:
+ forall chunk b' l m m',
+ Mem.free_list m l = Some m' ->
+ (forall b lo hi, In (b, lo, hi) l -> b' < b) ->
+ Mem.load chunk m' b' 0 = Mem.load chunk m b' 0.
+Proof.
+ induction l; simpl; intros.
+ inv H; auto.
+ destruct a. destruct p. destruct (Mem.free m b z0 z) as [m1|]_eqn; try discriminate.
+ transitivity (Mem.load chunk m1 b' 0). eauto.
+ eapply Mem.load_free. eauto. left. assert (b' < b) by eauto. unfold block; omega.
+Qed.
+
+Lemma match_cont_free_env:
+ forall f cenv e le m lo hi te tle tm tlo thi k tk m' tm',
+ match_envs f cenv e le m lo hi te tle tlo thi ->
+ match_cont f cenv k tk m lo tlo ->
+ hi <= Mem.nextblock m ->
+ thi <= Mem.nextblock tm ->
+ Mem.free_list m (blocks_of_env e) = Some m' ->
+ Mem.free_list tm (blocks_of_env te) = Some tm' ->
+ match_cont f cenv k tk m' (Mem.nextblock m') (Mem.nextblock tm').
+Proof.
+ intros. apply match_cont_incr_bounds with lo tlo.
+ eapply match_cont_invariant; eauto.
+ intros. rewrite <- H7. eapply free_list_load; eauto.
+ unfold blocks_of_env; intros. exploit list_in_map_inv; eauto.
+ intros [[id [b1 ty]] [P Q]]. simpl in P. inv P.
+ exploit me_range; eauto. eapply PTree.elements_complete; eauto. omega.
+ rewrite (free_list_nextblock _ _ _ H3). inv H; omega.
+ rewrite (free_list_nextblock _ _ _ H4). inv H; omega.
+Qed.
+
+(** Matching of global environments *)
+
+Lemma match_cont_globalenv:
+ forall f cenv k tk m bound tbound,
+ match_cont f cenv k tk m bound tbound ->
+ exists bound, match_globalenvs f bound.
+Proof.
+ induction 1; auto. exists hi; auto.
+Qed.
+
+Hint Resolve match_cont_globalenv: compat.
+
+Lemma match_cont_find_funct:
+ forall f cenv k tk m bound tbound vf fd tvf,
+ match_cont f cenv k tk m bound tbound ->
+ Genv.find_funct ge vf = Some fd ->
+ val_inject f vf tvf ->
+ exists tfd, Genv.find_funct tge tvf = Some tfd /\ transf_fundef fd = OK tfd.
+Proof.
+ intros. exploit match_cont_globalenv; eauto. intros [bound1 MG]. destruct MG.
+ inv H1; simpl in H0; try discriminate. destruct (Int.eq_dec ofs1 Int.zero); try discriminate.
+ subst ofs1.
+ assert (f b1 = Some(b1, 0)).
+ apply DOMAIN. eapply FUNCTIONS; eauto.
+ rewrite H1 in H2; inv H2.
+ rewrite Int.add_zero. simpl. rewrite dec_eq_true. apply function_ptr_translated; auto.
+Qed.
+
+(** Relating execution states *)
+
+Inductive match_states: state -> state -> Prop :=
+ | match_regular_states:
+ forall f s k e le m tf ts tk te tle tm j lo hi tlo thi
+ (TRF: transf_function f = OK tf)
+ (TRS: simpl_stmt (cenv_for f) s = OK ts)
+ (MENV: match_envs j (cenv_for f) e le m lo hi te tle tlo thi)
+ (MCONT: match_cont j (cenv_for f) k tk m lo tlo)
+ (MINJ: Mem.inject j m tm)
+ (COMPAT: compat_cenv (addr_taken_stmt s) (cenv_for f))
+ (BOUND: hi <= Mem.nextblock m)
+ (TBOUND: thi <= Mem.nextblock tm),
+ match_states (State f s k e le m)
+ (State tf ts tk te tle tm)
+ | match_call_state:
+ forall fd vargs k m tfd tvargs tk tm j targs tres
+ (TRFD: transf_fundef fd = OK tfd)
+ (MCONT: forall cenv, match_cont j cenv k tk m (Mem.nextblock m) (Mem.nextblock tm))
+ (MINJ: Mem.inject j m tm)
+ (AINJ: val_list_inject j vargs tvargs)
+ (FUNTY: type_of_fundef fd = Tfunction targs tres)
+ (ANORM: val_casted_list vargs targs),
+ match_states (Callstate fd vargs k m)
+ (Callstate tfd tvargs tk tm)
+ | match_return_state:
+ forall v k m tv tk tm j
+ (MCONT: forall cenv, match_cont j cenv k tk m (Mem.nextblock m) (Mem.nextblock tm))
+ (MINJ: Mem.inject j m tm)
+ (RINJ: val_inject j v tv),
+ match_states (Returnstate v k m)
+ (Returnstate tv tk tm).
+
+(** The simulation diagrams *)
+
+Remark is_liftable_var_charact:
+ forall cenv a,
+ match is_liftable_var cenv a with
+ | Some id => exists ty, a = Evar id ty /\ VSet.mem id cenv = true
+ | None => match a with Evar id ty => VSet.mem id cenv = false | _ => True end
+ end.
+Proof.
+ intros. destruct a; simpl; auto.
+ destruct (VSet.mem i cenv) as []_eqn.
+ exists t; auto.
+ auto.
+Qed.
+
+Remark simpl_select_switch:
+ forall cenv n ls tls,
+ simpl_lblstmt cenv ls = OK tls ->
+ simpl_lblstmt cenv (select_switch n ls) = OK (select_switch n tls).
+Proof.
+ induction ls; simpl; intros.
+ monadInv H. rewrite EQ; auto.
+ monadInv H. simpl. destruct (Int.eq i n).
+ simpl. rewrite EQ; rewrite EQ1. auto.
+ eauto.
+Qed.
+
+Remark simpl_seq_of_labeled_statement:
+ forall cenv ls tls,
+ simpl_lblstmt cenv ls = OK tls ->
+ simpl_stmt cenv (seq_of_labeled_statement ls) = OK (seq_of_labeled_statement tls).
+Proof.
+ induction ls; simpl; intros.
+ monadInv H. auto.
+ monadInv H. rewrite EQ; simpl. erewrite IHls; eauto. simpl. auto.
+Qed.
+
+Remark compat_cenv_select_switch:
+ forall cenv n ls,
+ compat_cenv (addr_taken_lblstmt ls) cenv ->
+ compat_cenv (addr_taken_lblstmt (select_switch n ls)) cenv.
+Proof.
+ induction ls; simpl; intros. auto. destruct (Int.eq i n); simpl; eauto with compat.
+Qed.
+
+Remark addr_taken_seq_of_labeled_statement:
+ forall ls, addr_taken_stmt (seq_of_labeled_statement ls) = addr_taken_lblstmt ls.
+Proof.
+ induction ls; simpl; congruence.
+Qed.
+
+Section FIND_LABEL.
+
+Variable f: meminj.
+Variable cenv: compilenv.
+Variable m: mem.
+Variables bound tbound: block.
+Variable lbl: ident.
+
+Lemma simpl_find_label:
+ forall s k ts tk,
+ simpl_stmt cenv s = OK ts ->
+ match_cont f cenv k tk m bound tbound ->
+ compat_cenv (addr_taken_stmt s) cenv ->
+ match find_label lbl s k with
+ | None =>
+ find_label lbl ts tk = None
+ | Some(s', k') =>
+ exists ts', exists tk',
+ find_label lbl ts tk = Some(ts', tk')
+ /\ compat_cenv (addr_taken_stmt s') cenv
+ /\ simpl_stmt cenv s' = OK ts'
+ /\ match_cont f cenv k' tk' m bound tbound
+ end
+
+with simpl_find_label_ls:
+ forall ls k tls tk,
+ simpl_lblstmt cenv ls = OK tls ->
+ match_cont f cenv k tk m bound tbound ->
+ compat_cenv (addr_taken_lblstmt ls) cenv ->
+ match find_label_ls lbl ls k with
+ | None =>
+ find_label_ls lbl tls tk = None
+ | Some(s', k') =>
+ exists ts', exists tk',
+ find_label_ls lbl tls tk = Some(ts', tk')
+ /\ compat_cenv (addr_taken_stmt s') cenv
+ /\ simpl_stmt cenv s' = OK ts'
+ /\ match_cont f cenv k' tk' m bound tbound
+ end.
+
+Proof.
+ induction s; simpl; intros until tk; intros TS MC COMPAT; auto.
+ (* skip *)
+ monadInv TS; auto.
+ (* var *)
+ destruct (is_liftable_var cenv e); monadInv TS; auto.
+ (* set *)
+ monadInv TS; auto.
+ (* call *)
+ monadInv TS; auto.
+ (* builtin *)
+ monadInv TS; auto.
+ (* seq *)
+ monadInv TS.
+ exploit (IHs1 (Kseq s2 k) x (Kseq x0 tk)); eauto with compat.
+ constructor; eauto with compat.
+ destruct (find_label lbl s1 (Kseq s2 k)) as [[s' k']|].
+ intros [ts' [tk' [P [Q [R S]]]]]. exists ts'; exists tk'. simpl. rewrite P. auto.
+ intros E. simpl. rewrite E. eapply IHs2; eauto with compat.
+ (* ifthenelse *)
+ monadInv TS.
+ exploit (IHs1 k x tk); eauto with compat.
+ destruct (find_label lbl s1 k) as [[s' k']|].
+ intros [ts' [tk' [P [Q [R S]]]]]. exists ts'; exists tk'. simpl. rewrite P. auto.
+ intros E. simpl. rewrite E. eapply IHs2; eauto with compat.
+ (* loop *)
+ monadInv TS.
+ exploit (IHs1 (Kloop1 s1 s2 k) x (Kloop1 x x0 tk)); eauto with compat.
+ constructor; eauto with compat.
+ destruct (find_label lbl s1 (Kloop1 s1 s2 k)) as [[s' k']|].
+ intros [ts' [tk' [P [Q [R S]]]]]. exists ts'; exists tk'. simpl; rewrite P. auto.
+ intros E. simpl; rewrite E. eapply IHs2; eauto with compat. econstructor; eauto with compat.
+ (* break *)
+ monadInv TS; auto.
+ (* continue *)
+ monadInv TS; auto.
+ (* return *)
+ monadInv TS; auto.
+ (* switch *)
+ monadInv TS. simpl.
+ eapply simpl_find_label_ls; eauto with compat. constructor; auto.
+ (* label *)
+ monadInv TS. simpl.
+ destruct (ident_eq lbl l).
+ exists x; exists tk; auto.
+ eapply IHs; eauto.
+ (* goto *)
+ monadInv TS; auto.
+
+ induction ls; simpl; intros.
+ (* default *)
+ monadInv H. apply simpl_find_label; auto.
+ (* case *)
+ monadInv H.
+ exploit (simpl_find_label s (Kseq (seq_of_labeled_statement ls) k)).
+ eauto. constructor. eapply simpl_seq_of_labeled_statement; eauto. eauto.
+ rewrite addr_taken_seq_of_labeled_statement. eauto with compat.
+ eauto with compat.
+ destruct (find_label lbl s (Kseq (seq_of_labeled_statement ls) k)) as [[s' k']|].
+ intros [ts' [tk' [P [Q [R S]]]]]. exists ts'; exists tk'; split. simpl; rewrite P. auto. auto.
+ intros E. simpl; rewrite E. eapply IHls; eauto with compat.
+Qed.
+
+Lemma find_label_store_params:
+ forall lbl s k params, find_label lbl (store_params cenv params s) k = find_label lbl s k.
+Proof.
+ induction params; simpl. auto.
+ destruct a as [id ty]. destruct (VSet.mem id cenv); auto.
+Qed.
+
+End FIND_LABEL.
+
+
+Lemma step_simulation:
+ forall S1 t S2, step1 ge S1 t S2 ->
+ forall S1' (MS: match_states S1 S1'), exists S2', plus step2 tge S1' t S2' /\ match_states S2 S2'.
+Proof.
+ induction 1; simpl; intros; inv MS; simpl in *; try (monadInv TRS).
+
+(* assign *)
+ generalize (is_liftable_var_charact (cenv_for f) a1); destruct (is_liftable_var (cenv_for f) a1) as [id|]; monadInv TRS.
+ (* liftable *)
+ intros [ty [P Q]]; subst a1; simpl in *.
+ exploit eval_simpl_expr; eauto with compat. intros [tv2 [A B]].
+ exploit sem_cast_inject; eauto. intros [tv [C D]].
+ exploit me_vars; eauto. instantiate (1 := id). intros MV.
+ inv H.
+ (* local variable *)
+ econstructor; split.
+ apply plus_one. econstructor. econstructor. eexact A. rewrite typeof_simpl_expr. eexact C.
+ econstructor; eauto with compat.
+ eapply match_envs_assign_lifted; eauto. eapply cast_val_is_casted; eauto.
+ eapply match_cont_assign_loc; eauto. exploit me_range; eauto. omega.
+ inv MV; try congruence. inv H2; try congruence. unfold Mem.storev in H3.
+ eapply Mem.store_unmapped_inject; eauto. congruence.
+ erewrite assign_loc_nextblock; eauto.
+ (* global variable *)
+ inv MV; congruence.
+ (* not liftable *)
+ intros P.
+ exploit eval_simpl_lvalue; eauto with compat. intros [tb [tofs [E F]]].
+ exploit eval_simpl_expr; eauto with compat. intros [tv2 [A B]].
+ exploit sem_cast_inject; eauto. intros [tv [C D]].
+ exploit assign_loc_inject; eauto. intros [tm' [X [Y Z]]].
+ econstructor; split.
+ apply plus_one. econstructor. eexact E. eexact A. repeat rewrite typeof_simpl_expr. eexact C.
+ rewrite typeof_simpl_expr; auto. eexact X.
+ econstructor; eauto with compat.
+ eapply match_envs_invariant; eauto.
+ eapply match_cont_invariant; eauto.
+ erewrite assign_loc_nextblock; eauto.
+ erewrite assign_loc_nextblock; eauto.
+
+(* set temporary *)
+ exploit eval_simpl_expr; eauto with compat. intros [tv [A B]].
+ econstructor; split.
+ apply plus_one. econstructor. eauto.
+ econstructor; eauto with compat.
+ eapply match_envs_set_temp; eauto.
+
+(* call *)
+ exploit eval_simpl_expr; eauto with compat. intros [tvf [A B]].
+ exploit eval_simpl_exprlist; eauto with compat. intros [CASTED [tvargs [C D]]].
+ exploit match_cont_find_funct; eauto. intros [tfd [P Q]].
+ econstructor; split.
+ apply plus_one. eapply step_call with (fd := tfd).
+ rewrite typeof_simpl_expr. eauto.
+ eauto. eauto. eauto.
+ erewrite type_of_fundef_preserved; eauto.
+ econstructor; eauto.
+ intros. econstructor; eauto.
+
+(* builtin *)
+ exploit eval_simpl_exprlist; eauto with compat. intros [CASTED [tvargs [C D]]].
+ exploit external_call_mem_inject; eauto. apply match_globalenvs_preserves_globals; eauto with compat.
+ intros [j' [tvres [tm' [P [Q [R [S [T [U V]]]]]]]]].
+ econstructor; split.
+ apply plus_one. econstructor; eauto. eapply external_call_symbols_preserved; eauto.
+ exact symbols_preserved. exact varinfo_preserved.
+ econstructor; eauto with compat.
+ eapply match_envs_set_opttemp; eauto.
+ eapply match_envs_extcall; eauto.
+ eapply match_cont_extcall; eauto.
+ inv MENV; omega. inv MENV; omega.
+ eapply Zle_trans; eauto. eapply external_call_nextblock; eauto.
+ eapply Zle_trans; eauto. eapply external_call_nextblock; eauto.
+
+(* sequence *)
+ econstructor; split. apply plus_one. econstructor.
+ econstructor; eauto with compat. econstructor; eauto with compat.
+
+(* skip sequence *)
+ inv MCONT. econstructor; split. apply plus_one. econstructor. econstructor; eauto.
+
+(* continue sequence *)
+ inv MCONT. econstructor; split. apply plus_one. econstructor. econstructor; eauto.
+
+(* break sequence *)
+ inv MCONT. econstructor; split. apply plus_one. econstructor. econstructor; eauto.
+
+(* ifthenelse *)
+ exploit eval_simpl_expr; eauto with compat. intros [tv [A B]].
+ econstructor; split.
+ apply plus_one. apply step_ifthenelse with (v1 := tv) (b := b). auto.
+ rewrite typeof_simpl_expr. eapply bool_val_inject; eauto.
+ destruct b; econstructor; eauto with compat.
+
+(* loop *)
+ econstructor; split. apply plus_one. econstructor. econstructor; eauto with compat. econstructor; eauto with compat.
+
+(* skip-or-continue loop *)
+ inv MCONT. econstructor; split.
+ apply plus_one. econstructor. destruct H; subst x; simpl in *; intuition congruence.
+ econstructor; eauto with compat. econstructor; eauto with compat.
+
+(* break loop1 *)
+ inv MCONT. econstructor; split. apply plus_one. eapply step_break_loop1.
+ econstructor; eauto.
+
+(* skip loop2 *)
+ inv MCONT. econstructor; split. apply plus_one. eapply step_skip_loop2.
+ econstructor; eauto with compat. simpl; rewrite H2; rewrite H4; auto.
+
+(* break loop2 *)
+ inv MCONT. econstructor; split. apply plus_one. eapply step_break_loop2.
+ econstructor; eauto.
+
+(* return none *)
+ exploit match_envs_free_blocks; eauto. intros [tm' [P Q]].
+ econstructor; split. apply plus_one. econstructor; eauto.
+ econstructor; eauto.
+ intros. eapply match_cont_call_cont. eapply match_cont_free_env; eauto.
+
+(* return some *)
+ exploit eval_simpl_expr; eauto with compat. intros [tv [A B]].
+ exploit sem_cast_inject; eauto. intros [tv' [C D]].
+ exploit match_envs_free_blocks; eauto. intros [tm' [P Q]].
+ econstructor; split. apply plus_one. econstructor; eauto.
+ rewrite typeof_simpl_expr. monadInv TRF; simpl. eauto.
+ econstructor; eauto.
+ intros. eapply match_cont_call_cont. eapply match_cont_free_env; eauto.
+
+(* skip call *)
+ exploit match_envs_free_blocks; eauto. intros [tm' [P Q]].
+ econstructor; split. apply plus_one. econstructor; eauto.
+ eapply match_cont_is_call_cont; eauto.
+ monadInv TRF; auto.
+ econstructor; eauto.
+ intros. apply match_cont_change_cenv with (cenv_for f); auto. eapply match_cont_free_env; eauto.
+
+(* switch *)
+ exploit eval_simpl_expr; eauto with compat. intros [tv [A B]]. inv B.
+ econstructor; split. apply plus_one. econstructor; eauto.
+ econstructor; eauto.
+ erewrite simpl_seq_of_labeled_statement. reflexivity.
+ eapply simpl_select_switch; eauto.
+ econstructor; eauto. rewrite addr_taken_seq_of_labeled_statement.
+ apply compat_cenv_select_switch. eauto with compat.
+
+(* skip-break switch *)
+ inv MCONT. econstructor; split.
+ apply plus_one. eapply step_skip_break_switch. destruct H; subst x; simpl in *; intuition congruence.
+ econstructor; eauto with compat.
+
+(* continue switch *)
+ inv MCONT. econstructor; split.
+ apply plus_one. eapply step_continue_switch.
+ econstructor; eauto with compat.
+
+(* label *)
+ econstructor; split. apply plus_one. econstructor. econstructor; eauto.
+
+(* goto *)
+ generalize TRF; intros TRF'. monadInv TRF'.
+ exploit (simpl_find_label j (cenv_for f) m lo tlo lbl (fn_body f) (call_cont k) x0 (call_cont tk)).
+ eauto. eapply match_cont_call_cont. eauto.
+ apply compat_cenv_for.
+ rewrite H. intros [ts' [tk' [A [B [C D]]]]].
+ econstructor; split.
+ apply plus_one. econstructor; eauto. simpl. rewrite find_label_store_params. eexact A.
+ econstructor; eauto.
+
+(* internal function *)
+ monadInv TRFD. inv H.
+ generalize EQ; intro EQ'; monadInv EQ'.
+ assert (list_norepet (var_names (fn_params f ++ fn_vars f))).
+ unfold var_names. rewrite map_app. auto.
+ assert (list_disjoint (var_names (fn_params f)) (var_names (fn_temps f))).
+ monadInv EQ0. auto.
+ exploit match_envs_alloc_variables; eauto.
+ instantiate (1 := cenv_for_gen (addr_taken_stmt f.(fn_body)) (fn_params f ++ fn_vars f)).
+ intros. eapply cenv_for_gen_by_value; eauto. rewrite VSF.mem_iff. eexact H5.
+ intros. eapply cenv_for_gen_domain. rewrite VSF.mem_iff. eexact H4.
+ intros [j' [te [tm0 [A [B [C [D [E F]]]]]]]].
+ exploit store_params_correct.
+ eauto.
+ eapply list_norepet_append_left; eauto.
+ apply val_casted_list_params. unfold type_of_function in FUNTY. congruence.
+ apply val_list_inject_incr with j'; eauto.
+ eexact B. eexact C.
+ intros. apply (create_undef_temps_lifted id f). auto.
+ intros. destruct (create_undef_temps (fn_temps f))!id as [v|]_eqn; auto.
+ exploit create_undef_temps_inv; eauto. intros [P Q]. elim (H3 id id); auto.
+ intros [tel [tm1 [P [Q [R [S T]]]]]].
+ change (cenv_for_gen (addr_taken_stmt (fn_body f)) (fn_params f ++ fn_vars f))
+ with (cenv_for f) in *.
+ generalize (vars_and_temps_properties (cenv_for f) (fn_params f) (fn_vars f) (fn_temps f)).
+ intros [X [Y Z]]. auto. auto.
+ econstructor; split.
+ eapply plus_left. econstructor.
+ econstructor. exact Y. exact X. exact Z. simpl. eexact A. simpl. eexact Q.
+ simpl. eexact P.
+ traceEq.
+ econstructor; eauto.
+ eapply match_cont_invariant; eauto.
+ intros. transitivity (Mem.load chunk m0 b 0).
+ eapply bind_parameters_load; eauto. intros.
+ exploit alloc_variables_range. eexact H1. eauto.
+ unfold empty_env. rewrite PTree.gempty. intros [?|?]. congruence.
+ red; intros; subst b'. omega.
+ eapply alloc_variables_load; eauto.
+ apply compat_cenv_for.
+ rewrite (bind_parameters_nextblock _ _ _ _ _ H2). omega.
+ rewrite T; omega.
+
+(* external function *)
+ monadInv TRFD. inv FUNTY.
+ exploit external_call_mem_inject; eauto. apply match_globalenvs_preserves_globals.
+ eapply match_cont_globalenv. eexact (MCONT VSet.empty).
+ intros [j' [tvres [tm' [P [Q [R [S [T [U V]]]]]]]]].
+ econstructor; split.
+ apply plus_one. econstructor; eauto. eapply external_call_symbols_preserved; eauto.
+ exact symbols_preserved. exact varinfo_preserved.
+ econstructor; eauto.
+ intros. apply match_cont_incr_bounds with (Mem.nextblock m) (Mem.nextblock tm).
+ eapply match_cont_extcall; eauto. omega. omega.
+ eapply external_call_nextblock; eauto.
+ eapply external_call_nextblock; eauto.
+
+(* return *)
+ specialize (MCONT (cenv_for f)). inv MCONT.
+ econstructor; split.
+ apply plus_one. econstructor.
+ econstructor; eauto with compat.
+ eapply match_envs_set_opttemp; eauto.
+Qed.
+
+Lemma initial_states_simulation:
+ forall S, initial_state prog S ->
+ exists R, initial_state tprog R /\ match_states S R.
+Proof.
+ intros. inv H.
+ exploit function_ptr_translated; eauto. intros [tf [A B]].
+ econstructor; split.
+ econstructor.
+ eapply Genv.init_mem_transf_partial; eauto.
+ rewrite (transform_partial_program_main _ _ TRANSF).
+ instantiate (1 := b). rewrite <- H1. apply symbols_preserved.
+ eauto.
+ rewrite <- H3; apply type_of_fundef_preserved; auto.
+ econstructor; eauto.
+ intros. instantiate (1 := Mem.flat_inj (Mem.nextblock m0)).
+ econstructor. instantiate (1 := Mem.nextblock m0).
+ constructor; intros.
+ apply Mem.nextblock_pos.
+ unfold Mem.flat_inj. apply zlt_true; auto.
+ unfold Mem.flat_inj in H. destruct (zlt b1 (Mem.nextblock m0)); inv H. auto.
+ eapply Genv.find_symbol_not_fresh; eauto.
+ eapply Genv.find_funct_ptr_not_fresh; eauto.
+ eapply Genv.find_var_info_not_fresh; eauto.
+ omega. omega.
+ eapply Genv.initmem_inject; eauto.
+ constructor.
+Qed.
+
+Lemma final_states_simulation:
+ forall S R r,
+ match_states S R -> final_state S r -> final_state R r.
+Proof.
+ intros. inv H0. inv H.
+ specialize (MCONT VSet.empty). inv MCONT.
+ inv RINJ. constructor.
+Qed.
+
+Theorem transf_program_correct:
+ forward_simulation (semantics1 prog) (semantics2 tprog).
+Proof.
+ eapply forward_simulation_plus.
+ eexact symbols_preserved.
+ eexact initial_states_simulation.
+ eexact final_states_simulation.
+ eexact step_simulation.
+Qed.
+
+End PRESERVATION.
diff --git a/common/Errors.v b/common/Errors.v
index a70ea6e..6b863a0 100644
--- a/common/Errors.v
+++ b/common/Errors.v
@@ -31,7 +31,7 @@ Set Implicit Arguments.
Inductive errcode: Type :=
| MSG: string -> errcode
| CTX: positive -> errcode (* a top-level identifier *)
- | CTXL: positive -> errcode. (* an encoded local identifier *)
+ | POS: positive -> errcode. (* a positive integer, e.g. a PC *)
Definition errmsg: Type := list errcode.
diff --git a/driver/Clightgen.ml b/driver/Clightgen.ml
new file mode 100644
index 0000000..1805573
--- /dev/null
+++ b/driver/Clightgen.ml
@@ -0,0 +1,282 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+open Printf
+open Clflags
+
+(* Location of the compatibility library *)
+
+let stdlib_path = ref(
+ try
+ Sys.getenv "COMPCERT_LIBRARY"
+ with Not_found ->
+ Configuration.stdlib_path)
+
+let command cmd =
+ if !option_v then begin
+ prerr_string "+ "; prerr_string cmd; prerr_endline ""
+ end;
+ Sys.command cmd
+
+let quote_options opts =
+ String.concat " " (List.rev_map Filename.quote opts)
+
+let safe_remove file =
+ try Sys.remove file with Sys_error _ -> ()
+
+(* Printing of error messages *)
+
+let print_error oc msg =
+ let print_one_error = function
+ | Errors.MSG s -> output_string oc (Camlcoq.camlstring_of_coqstring s)
+ | Errors.CTX i -> output_string oc (Camlcoq.extern_atom i)
+ | Errors.POS i -> fprintf oc "%ld" (Camlcoq.camlint_of_positive i)
+ in
+ List.iter print_one_error msg;
+ output_char oc '\n'
+
+(* From C to preprocessed C *)
+
+let preprocess ifile ofile =
+ let output =
+ if ofile = "-" then "" else sprintf "> %s" ofile in
+ let cmd =
+ sprintf "%s -D__COMPCERT__ %s %s %s %s"
+ Configuration.prepro
+ (if Configuration.has_runtime_lib
+ then sprintf "-I%s" !stdlib_path
+ else "")
+ (quote_options !prepro_options)
+ ifile output in
+ if command cmd <> 0 then begin
+ if ofile <> "-" then safe_remove ofile;
+ eprintf "Error during preprocessing.\n";
+ exit 2
+ end
+
+(* From preprocessed C to Csyntax *)
+
+let parse_c_file sourcename ifile =
+ Sections.initialize();
+ (* Simplification options *)
+ let simplifs =
+ "b" (* blocks: mandatory *)
+ ^ (if !option_fstruct_return then "s" else "")
+ ^ (if !option_fbitfields then "f" else "")
+ ^ (if !option_fpacked_structs then "p" else "")
+ in
+ (* Parsing and production of a simplified C AST *)
+ let ast =
+ match Parse.preprocessed_file simplifs sourcename ifile with
+ | None -> exit 2
+ | Some p -> p in
+ (* Remove preprocessed file (always a temp file) *)
+ safe_remove ifile;
+ (* Save C AST if requested *)
+ if !option_dparse then begin
+ let ofile = Filename.chop_suffix sourcename ".c" ^ ".parsed.c" in
+ let oc = open_out ofile in
+ Cprint.program (Format.formatter_of_out_channel oc) ast;
+ close_out oc
+ end;
+ (* Conversion to Csyntax *)
+ let csyntax =
+ match C2C.convertProgram ast with
+ | None -> exit 2
+ | Some p -> p in
+ flush stderr;
+ (* Save CompCert C AST if requested *)
+ if !option_dcmedium then begin
+ let ofile = Filename.chop_suffix sourcename ".c" ^ ".compcert.c" in
+ let oc = open_out ofile in
+ PrintCsyntax.print_program (Format.formatter_of_out_channel oc) csyntax;
+ close_out oc
+ end;
+ csyntax
+
+(* From CompCert C AST to Clight *)
+
+let compile_c_ast sourcename csyntax ofile =
+ let clight =
+ match SimplExpr.transl_program csyntax with
+ | Errors.OK p ->
+ begin match SimplLocals.transf_program p with
+ | Errors.OK p' -> p'
+ | Errors.Error msg ->
+ print_error stderr msg;
+ exit 2
+ end
+ | Errors.Error msg ->
+ print_error stderr msg;
+ exit 2 in
+ (* Dump Clight in C syntax if requested *)
+ if !option_dclight then begin
+ let ofile = Filename.chop_suffix sourcename ".c" ^ ".light.c" in
+ let oc = open_out ofile in
+ PrintClight.print_program (Format.formatter_of_out_channel oc) clight;
+ close_out oc
+ end;
+ (* Print Clight in Coq syntax *)
+ let oc = open_out ofile in
+ ExportClight.print_program (Format.formatter_of_out_channel oc) clight;
+ close_out oc
+
+(* From C source to Clight *)
+
+let compile_c_file sourcename ifile ofile =
+ compile_c_ast sourcename (parse_c_file sourcename ifile) ofile
+
+(* Processing of a .c file *)
+
+let process_c_file sourcename =
+ let prefixname = Filename.chop_suffix sourcename ".c" in
+ if !option_E then begin
+ preprocess sourcename "-"
+ end else begin
+ let preproname = Filename.temp_file "compcert" ".i" in
+ preprocess sourcename preproname;
+ compile_c_file sourcename preproname (prefixname ^ ".v")
+ end
+
+(* Command-line parsing *)
+
+let explode_comma_option s =
+ match Str.split (Str.regexp ",") s with
+ | [] -> assert false
+ | hd :: tl -> tl
+
+type action =
+ | Set of bool ref
+ | Unset of bool ref
+ | Self of (string -> unit)
+ | String of (string -> unit)
+ | Integer of (int -> unit)
+
+let rec find_action s = function
+ | [] -> None
+ | (re, act) :: rem ->
+ if Str.string_match re s 0 then Some act else find_action s rem
+
+let parse_cmdline spec usage =
+ let acts = List.map (fun (pat, act) -> (Str.regexp pat, act)) spec in
+ let error () =
+ eprintf "%s" usage;
+ exit 2 in
+ let rec parse i =
+ if i < Array.length Sys.argv then begin
+ let s = Sys.argv.(i) in
+ match find_action s acts with
+ | None ->
+ if s <> "-help" && s <> "--help"
+ then eprintf "Unknown argument `%s'\n" s;
+ error ()
+ | Some(Set r) ->
+ r := true; parse (i+1)
+ | Some(Unset r) ->
+ r := false; parse (i+1)
+ | Some(Self fn) ->
+ fn s; parse (i+1)
+ | Some(String fn) ->
+ if i + 1 < Array.length Sys.argv then begin
+ fn Sys.argv.(i+1); parse (i+2)
+ end else begin
+ eprintf "Option `%s' expects an argument\n" s; error()
+ end
+ | Some(Integer fn) ->
+ if i + 1 < Array.length Sys.argv then begin
+ let n =
+ try
+ int_of_string Sys.argv.(i+1)
+ with Failure _ ->
+ eprintf "Argument to option `%s' must be an integer\n" s;
+ error()
+ in
+ fn n; parse (i+2)
+ end else begin
+ eprintf "Option `%s' expects an argument\n" s; error()
+ end
+ end
+ in parse 1
+
+let usage_string =
+"The CompCert Clight generator
+Usage: clightgen [options] <source files>
+Recognized source files:
+ .c C source file
+Processing options:
+ -E Preprocess only, send result to standard output
+Preprocessing options:
+ -I<dir> Add <dir> to search path for #include files
+ -D<symb>=<val> Define preprocessor symbol
+ -U<symb> Undefine preprocessor symbol
+ -Wp,<opt> Pass option <opt> to the preprocessor
+Language support options (use -fno-<opt> to turn off -f<opt>) :
+ -fbitfields Emulate bit fields in structs [off]
+ -flonglong Partial emulation of 'long long' types [on]
+ -flongdouble Treat 'long double' as 'double' [off]
+ -fstruct-return Emulate returning structs and unions by value [off]
+ -fvararg-calls Emulate calls to variable-argument functions [on]
+ -fpacked-structs Emulate packed structs [off]
+ -fall Activate all language support options above
+ -fnone Turn off all language support options above
+Tracing options:
+ -dparse Save C file after parsing and elaboration in <file>.parse.c
+ -dc Save generated Compcert C in <file>.compcert.c
+ -dclight Save generated Clight in <file>.light.c
+General options:
+ -v Print external commands before invoking them
+"
+
+let language_support_options = [
+ option_fbitfields; option_flonglong; option_flongdouble;
+ option_fstruct_return; option_fvararg_calls; option_fpacked_structs
+]
+
+let cmdline_actions =
+ let f_opt name ref =
+ ["-f" ^ name ^ "$", Set ref; "-fno-" ^ name ^ "$", Unset ref] in
+ [
+ "-I$", String(fun s -> prepro_options := s :: "-I" :: !prepro_options);
+ "-D$", String(fun s -> prepro_options := s :: "-D" :: !prepro_options);
+ "-U$", String(fun s -> prepro_options := s :: "-U" :: !prepro_options);
+ "-[IDU].", Self(fun s -> prepro_options := s :: !prepro_options);
+ "-dparse$", Set option_dparse;
+ "-dc$", Set option_dcmedium;
+ "-dclight$", Set option_dclight;
+ "-E$", Set option_E;
+ ".*\\.c$", Self (fun s -> process_c_file s);
+ "-Wp,", Self (fun s ->
+ prepro_options := List.rev_append (explode_comma_option s) !prepro_options);
+ "-fall$", Self (fun _ ->
+ List.iter (fun r -> r := true) language_support_options);
+ "-fnone$", Self (fun _ ->
+ List.iter (fun r -> r := false) language_support_options);
+ ]
+ @ f_opt "longlong" option_flonglong
+ @ f_opt "longdouble" option_flongdouble
+ @ f_opt "struct-return" option_fstruct_return
+ @ f_opt "bitfields" option_fbitfields
+ @ f_opt "vararg-calls" option_fvararg_calls
+ @ f_opt "packed-structs" option_fpacked_structs
+
+let _ =
+ Gc.set { (Gc.get()) with Gc.minor_heap_size = 524288 };
+ Machine.config :=
+ begin match Configuration.arch with
+ | "powerpc" -> Machine.ppc_32_bigendian
+ | "arm" -> Machine.arm_littleendian
+ | "ia32" -> Machine.x86_32
+ | _ -> assert false
+ end;
+ Builtins.set C2C.builtins_generic;
+ CPragmas.initialize();
+ parse_cmdline cmdline_actions usage_string
diff --git a/driver/Compiler.v b/driver/Compiler.v
index e6e8cc2..37f7bc2 100644
--- a/driver/Compiler.v
+++ b/driver/Compiler.v
@@ -39,6 +39,7 @@ Require Asm.
(** Translation passes. *)
Require Initializers.
Require SimplExpr.
+Require SimplLocals.
Require Cshmgen.
Require Cminorgen.
Require Selection.
@@ -64,6 +65,7 @@ Require Lineartyping.
Require Machtyping.
(** Proofs of semantic preservation and typing preservation. *)
Require SimplExprproof.
+Require SimplLocalsproof.
Require Cshmgenproof.
Require Cminorgenproof.
Require Selectionproof.
@@ -161,6 +163,7 @@ Definition transf_cminor_program (p: Cminor.program) : res Asm.program :=
Definition transf_clight_program (p: Clight.program) : res Asm.program :=
OK p
@@ print print_Clight
+ @@@ SimplLocals.transf_program
@@@ Cshmgen.transl_program
@@@ Cminorgen.transl_program
@@@ transf_cminor_program.
@@ -288,16 +291,18 @@ Qed.
Theorem transf_clight_program_correct:
forall p tp,
transf_clight_program p = OK tp ->
- forward_simulation (Clight.semantics p) (Asm.semantics tp)
- * backward_simulation (Clight.semantics p) (Asm.semantics tp).
+ forward_simulation (Clight.semantics1 p) (Asm.semantics tp)
+ * backward_simulation (Clight.semantics1 p) (Asm.semantics tp).
Proof.
intros.
- assert (F: forward_simulation (Clight.semantics p) (Asm.semantics tp)).
+ assert (F: forward_simulation (Clight.semantics1 p) (Asm.semantics tp)).
revert H; unfold transf_clight_program; simpl.
rewrite print_identity.
- caseEq (Cshmgen.transl_program p); simpl; try congruence; intros p1 EQ1.
+ caseEq (SimplLocals.transf_program p); simpl; try congruence; intros p0 EQ0.
+ caseEq (Cshmgen.transl_program p0); simpl; try congruence; intros p1 EQ1.
caseEq (Cminorgen.transl_program p1); simpl; try congruence; intros p2 EQ2.
intros EQ3.
+ eapply compose_forward_simulation. apply SimplLocalsproof.transf_program_correct. eauto.
eapply compose_forward_simulation. apply Cshmgenproof.transl_program_correct. eauto.
eapply compose_forward_simulation. apply Cminorgenproof.transl_program_correct. eauto.
exact (fst (transf_cminor_program_correct _ _ EQ3)).
diff --git a/driver/Driver.ml b/driver/Driver.ml
index 7fe3f64..ca703fd 100644
--- a/driver/Driver.ml
+++ b/driver/Driver.ml
@@ -35,19 +35,11 @@ let safe_remove file =
(* Printing of error messages *)
-(* Locally named idents are encoded as in Cminorgen.
- This function should live somewhere more central. *)
-let ident_name id =
- match id with
- | BinPos.Coq_xO n -> Camlcoq.extern_atom n
- | BinPos.Coq_xI n -> Printf.sprintf "$%ld" (Camlcoq.camlint_of_positive n)
- | BinPos.Coq_xH -> "$0"
-
let print_error oc msg =
let print_one_error = function
| Errors.MSG s -> output_string oc (Camlcoq.camlstring_of_coqstring s)
| Errors.CTX i -> output_string oc (Camlcoq.extern_atom i)
- | Errors.CTXL i -> output_string oc (ident_name i)
+ | Errors.POS i -> fprintf oc "%ld" (Camlcoq.camlint_of_positive i)
in
List.iter print_one_error msg;
output_char oc '\n'
diff --git a/extraction/extraction.v b/extraction/extraction.v
index b68c3a8..26cdb6d 100644
--- a/extraction/extraction.v
+++ b/extraction/extraction.v
@@ -20,7 +20,6 @@ Require Constprop.
Require Coloring.
Require Allocation.
Require Compiler.
-Require Initializers.
(* Standard lib *)
Require Import ExtrOcamlBasic.
@@ -70,6 +69,7 @@ Extract Constant Coloring.graph_coloring => "Coloringaux.graph_coloring".
Extract Constant Linearize.enumerate_aux => "Linearizeaux.enumerate_aux".
(* SimplExpr *)
+Extract Constant SimplExpr.first_unused_ident => "Camlcoq.first_unused_ident".
Extraction Inline SimplExpr.ret SimplExpr.error SimplExpr.bind SimplExpr.bind2.
(* Compiler *)
diff --git a/lib/Camlcoq.ml b/lib/Camlcoq.ml
index 57b1b56..00c2103 100644
--- a/lib/Camlcoq.ml
+++ b/lib/Camlcoq.ml
@@ -106,7 +106,9 @@ let extern_atom a =
try
Hashtbl.find string_of_atom a
with Not_found ->
- Printf.sprintf "<unknown atom %ld>" (camlint_of_positive a)
+ Printf.sprintf "$%ld" (camlint_of_positive a)
+
+let first_unused_ident () = !next_atom
(* Strings *)