diff options
| author |  xleroy <xleroy@fca1b0fc-160b-0410-b1d3-a4f43f01ea2e> | 2012-12-29 16:55:38 +0000 |
|---|---|---|
| committer | xleroy <xleroy@fca1b0fc-160b-0410-b1d3-a4f43f01ea2e> | 2012-12-29 16:55:38 +0000 |
| commit | 8539759095f95f2fbb680efc7633d868099114c8 (patch) | |
| tree | 3401d7cd91686026090a21f600cf70ea4372ebf3 | |
| parent | 7e9c6fc9a51adc5e488c590d83c1e8ef5a256c9f (diff) | |
Merge of the clightgen branch:
- Alternate semantics for Clight where function parameters are temporaries,
not variables
- New pass SimplLocals that turns non-addressed local variables into
temporaries
- Simplified Csharpminor, Cshmgen and Cminorgen accordingly
- SimplExpr starts its temporaries above variable names, therefoe
Cminorgen no longer needs to encode variable names and temps names.
- Simplified Cminor parser & printer, as well as Errors, accordingly.
- New tool clightgen to produce Clight AST in Coq-parsable .v files.
- Removed side condition "return type is void" on rules skip_seq
in the semantics of CompCert C, Clight, C#minor, Cminor.
- Adapted RTLgenproof accordingly (now uses a memory extension).
git-svn-id: https://yquem.inria.fr/compcert/svn/compcert/trunk@2083 fca1b0fc-160b-0410-b1d3-a4f43f01ea2e
34 files changed, 4800 insertions, 2718 deletions
@@ -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 @@ -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 @@ -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 *) |