diff options
| author |  xleroy <xleroy@fca1b0fc-160b-0410-b1d3-a4f43f01ea2e> | 2012-02-04 19:14:14 +0000 |
|---|---|---|
| committer | xleroy <xleroy@fca1b0fc-160b-0410-b1d3-a4f43f01ea2e> | 2012-02-04 19:14:14 +0000 |
| commit | 25b9b003178002360d666919f2e49e7f5f4a36e2 (patch) | |
| tree | d5f7fb317f34f3a7ac9383c21b0eb143317c30f8 | |
| parent | 145b32ec504541e98f73b2c87ff2d8181b5e7968 (diff) | |
Merge of the "volatile" branch:
- native treatment of volatile accesses in CompCert C's semantics
- translation of volatile accesses to built-ins in SimplExpr
- native treatment of struct assignment and passing struct parameter by value
- only passing struct result by value remains emulated
- in cparser, remove emulations that are no longer used
- added C99's type _Bool and used it to express || and && more efficiently.
git-svn-id: https://yquem.inria.fr/compcert/svn/compcert/trunk@1814 fca1b0fc-160b-0410-b1d3-a4f43f01ea2e
64 files changed, 4356 insertions, 3627 deletions
@@ -33,12 +33,12 @@ SUPPORTED PLATFORMS: natively at full speed on PowerPC-based Macs, and runs under software emulation at reduced speed on Intel-based Macs. -- PowerPC / Linux [somewhat experimental] +- PowerPC / Linux [stable] For PowerPC machines running the Linux operating system. -- IA32 / Linux or MacOS or Windows+Cygwin [experimental] +- IA32 / Linux or MacOS or Windows+Cygwin [stable] For Intel/AMD x86 processors with SSE2 extensions - (i.e. Pentium 4 and later), running either Linux, MacOS 10.6, + (i.e. Pentium 4 and later), running either Linux, MacOS 10.6 or 10.7, or Windows with the Cygwin environment (http://www.cygwin.com/). - ARM / Linux [experimental] @@ -60,7 +60,7 @@ PREREQUISITES: * The Caml functional language, version 3.10 or later. Caml is free software, available from http://caml.inria.fr/ -* Under MacOS 10.5 and 10.6, some standard C include files in /usr/include/ +* Under MacOS, some standard C include files in /usr/include/ contain gcc-isms that cause errors when compiling with CompCert. Symptoms include: - references to undefined types uint16_t and uint32_t @@ -84,6 +84,8 @@ where <target> is one of: ppc-macosx (PowerPC, MacOS X) ppc-linux (PowerPC, Linux) + ppc-eabi-unix (PowerPC, EABI with Unix tools) + ppc-eabi-diab (PowerPC, EABI with Diab tools) arm-linux (ARM, Linux) ia32-linux (x86 SSE2 32 bits, Linux) ia32-macosx (x86 SSE2 32 bits, MacOS X) @@ -172,9 +174,12 @@ Preprocessing options: 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] - -fstruct-passing Emulate passing structs and unions by value [off] - -fstruct-assign Emulate assignment between structs or unions [off] + -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 Code generation options: -fmadd Use fused multiply-add and multiply-sub instructions -fsmall-data <n> Set maximal size <n> for allocation in small data area @@ -750,7 +750,7 @@ Ltac Equalities := exploit external_call_determ. eexact H3. eexact H8. intros [A B]. split. auto. intros. destruct B; auto. subst. auto. (* trace length *) - inv H; simpl. + red; intros; inv H; simpl. omega. eapply external_call_trace_length; eauto. eapply external_call_trace_length; eauto. diff --git a/arm/SelectOp.vp b/arm/SelectOp.vp index 432db94..7b8851c 100644 --- a/arm/SelectOp.vp +++ b/arm/SelectOp.vp @@ -68,11 +68,24 @@ Nondetfunction notint (e: expr) := | _ => Eop Onot (e:::Enil) end. -(** ** Boolean negation *) +(** ** Boolean value and boolean negation *) + +Fixpoint boolval (e: expr) {struct e} : expr := + let default := Eop (Ocmp (Ccompuimm Cne Int.zero)) (e ::: Enil) in + match e with + | Eop (Ointconst n) Enil => + Eop (Ointconst (if Int.eq n Int.zero then Int.zero else Int.one)) Enil + | Eop (Ocmp cond) args => + Eop (Ocmp cond) args + | Econdition e1 e2 e3 => + Econdition e1 (boolval e2) (boolval e3) + | _ => + default + end. Fixpoint notbool (e: expr) {struct e} : expr := let default := Eop (Ocmp (Ccompuimm Ceq Int.zero)) (e ::: Enil) in - match e with + match e with | Eop (Ointconst n) Enil => Eop (Ointconst (if Int.eq n Int.zero then Int.one else Int.zero)) Enil | Eop (Ocmp cond) args => diff --git a/arm/SelectOpproof.v b/arm/SelectOpproof.v index fa41682..0a5ee64 100644 --- a/arm/SelectOpproof.v +++ b/arm/SelectOpproof.v @@ -141,6 +141,31 @@ Proof. TrivialExists. Qed. +Theorem eval_boolval: unary_constructor_sound boolval Val.boolval. +Proof. + assert (DFL: + forall le a x, + eval_expr ge sp e m le a x -> + exists v, eval_expr ge sp e m le (Eop (Ocmp (Ccompuimm Cne Int.zero)) (a ::: Enil)) v + /\ Val.lessdef (Val.boolval x) v). + intros. TrivialExists. simpl. destruct x; simpl; auto. + + red. induction a; simpl; intros; eauto. destruct o; eauto. +(* intconst *) + destruct e0; eauto. InvEval. TrivialExists. simpl. destruct (Int.eq i Int.zero); auto. +(* cmp *) + inv H. simpl in H5. + destruct (eval_condition c vl m) as []_eqn. + TrivialExists. simpl. inv H5. rewrite Heqo. destruct b; auto. + simpl in H5. inv H5. + exists Vundef; split; auto. EvalOp; simpl. rewrite Heqo; auto. + +(* condition *) + inv H. destruct v1. + exploit IHa1; eauto. intros [v [A B]]. exists v; split; auto. eapply eval_Econdition; eauto. + exploit IHa2; eauto. intros [v [A B]]. exists v; split; auto. eapply eval_Econdition; eauto. +Qed. + Theorem eval_notbool: unary_constructor_sound notbool Val.notbool. Proof. assert (DFL: diff --git a/backend/CMtypecheck.ml b/backend/CMtypecheck.ml index e3a6f70..244a73f 100644 --- a/backend/CMtypecheck.ml +++ b/backend/CMtypecheck.ml @@ -90,6 +90,7 @@ let type_unary_operation = function | Ocast8unsigned -> tint, tint | Ocast16unsigned -> tint, tint | Onegint -> tint, tint + | Oboolval -> tint, tint | Onotbool -> tint, tint | Onotint -> tint, tint | Onegf -> tfloat, tfloat @@ -134,6 +135,7 @@ let name_of_unary_operation = function | Ocast8unsigned -> "cast8unsigned" | Ocast16unsigned -> "cast16unsigned" | Onegint -> "negint" + | Oboolval -> "notbool" | Onotbool -> "notbool" | Onotint -> "notint" | Onegf -> "negf" @@ -293,6 +295,22 @@ let rec type_stmt env blk ret s = with Error s -> raise (Error (sprintf "In call:\n%s" s)) end + | Sbuiltin(optid, ef, el) -> + let sg = ef_sig ef in + let tel = type_exprlist env [] el in + begin try + unify_list (ty_of_sig_args sg.sig_args) tel; + let ty_res = + match sg.sig_res with + | None -> tint (*???*) + | Some t -> ty_of_typ t in + begin match optid with + | None -> () + | Some id -> unify (type_var env id) ty_res + end + with Error s -> + raise (Error (sprintf "In builtin call:\n%s" s)) + end | Sseq(s1, s2) -> type_stmt env blk ret s1; type_stmt env blk ret s2 diff --git a/backend/Cminor.v b/backend/Cminor.v index c9ee5b5..6d288a9 100644 --- a/backend/Cminor.v +++ b/backend/Cminor.v @@ -44,6 +44,7 @@ Inductive unary_operation : Type := | Ocast8signed: unary_operation (**r 8-bit sign extension *) | Ocast16unsigned: unary_operation (**r 16-bit zero extension *) | Ocast16signed: unary_operation (**r 16-bit sign extension *) + | Oboolval: unary_operation (**r 0 if null, 1 if non-null *) | Onegint: unary_operation (**r integer opposite *) | Onotbool: unary_operation (**r boolean negation *) | Onotint: unary_operation (**r bitwise complement *) @@ -103,6 +104,7 @@ Inductive stmt : Type := | Sstore : memory_chunk -> expr -> expr -> stmt | Scall : option ident -> signature -> expr -> list expr -> stmt | Stailcall: signature -> expr -> list expr -> stmt + | Sbuiltin : option ident -> external_function -> list expr -> stmt | Sseq: stmt -> stmt -> stmt | Sifthenelse: expr -> stmt -> stmt -> stmt | Sloop: stmt -> stmt @@ -228,6 +230,7 @@ Definition eval_unop (op: unary_operation) (arg: val) : option val := | Ocast8signed => Some (Val.sign_ext 8 arg) | Ocast16unsigned => Some (Val.zero_ext 16 arg) | Ocast16signed => Some (Val.sign_ext 16 arg) + | Oboolval => Some(Val.boolval arg) | Onegint => Some (Val.negint arg) | Onotbool => Some (Val.notbool arg) | Onotint => Some (Val.notint arg) @@ -401,6 +404,12 @@ Inductive step: state -> trace -> state -> Prop := step (State f (Stailcall sig a bl) k (Vptr sp Int.zero) e m) E0 (Callstate fd vargs (call_cont k) m') + | step_builtin: forall f optid ef bl k sp e m vargs t vres m', + eval_exprlist sp e m bl vargs -> + external_call ef ge vargs m t vres m' -> + step (State f (Sbuiltin optid ef bl) k sp e m) + t (State f Sskip k sp (set_optvar optid vres e) m') + | step_seq: forall f s1 s2 k sp e m, step (State f (Sseq s1 s2) k sp e m) E0 (State f s1 (Kseq s2 k) sp e m) @@ -505,9 +514,11 @@ Proof. intros. subst. inv H0. exists s1; auto. inversion H; subst; auto. exploit external_call_receptive; eauto. intros [vres2 [m2 EC2]]. + exists (State f Sskip k sp (set_optvar optid vres2 e) m2). econstructor; eauto. + exploit external_call_receptive; eauto. intros [vres2 [m2 EC2]]. exists (Returnstate vres2 k m2). econstructor; eauto. (* trace length *) - inv H; simpl; try omega. eapply external_call_trace_length; eauto. + red; intros; inv H; simpl; try omega; eapply external_call_trace_length; eauto. Qed. (** * Alternate operational semantics (big-step) *) @@ -608,6 +619,12 @@ with exec_stmt: eval_funcall m fd vargs t m' vres -> e' = set_optvar optid vres e -> exec_stmt f sp e m (Scall optid sig a bl) t e' m' Out_normal + | exec_Sbuiltin: + forall f sp e m optid ef bl t m' vargs vres e', + eval_exprlist ge sp e m bl vargs -> + external_call ef ge vargs m t vres m' -> + e' = set_optvar optid vres e -> + exec_stmt f sp e m (Sbuiltin optid ef bl) t e' m' Out_normal | exec_Sifthenelse: forall f sp e m a s1 s2 v b t e' m' out, eval_expr ge sp e m a v -> @@ -884,6 +901,11 @@ Proof. constructor. reflexivity. traceEq. subst e'. constructor. +(* builtin *) + econstructor; split. + apply star_one. econstructor; eauto. + subst e'. constructor. + (* ifthenelse *) destruct (H2 k) as [S [A B]]. exists S; split. diff --git a/backend/PrintCminor.ml b/backend/PrintCminor.ml index 30884b1..110e735 100644 --- a/backend/PrintCminor.ml +++ b/backend/PrintCminor.ml @@ -21,6 +21,7 @@ open Datatypes open BinPos open Integers open AST +open PrintAST open Cminor (* Precedences and associativity -- like those of C *) @@ -57,6 +58,7 @@ let name_of_unop = function | Ocast16unsigned -> "int16u" | Ocast16signed -> "int16s" | Onegint -> "-" + | Oboolval -> "(_Bool)" | Onotbool -> "!" | Onotint -> "~" | Onegf -> "-f" @@ -193,6 +195,15 @@ let rec print_stmt p s = print_expr e1 print_expr_list (true, el) print_sig sg + | Sbuiltin(None, ef, el) -> + fprintf p "@[<hv 2>builtin %s@,(@[<hov 0>%a@])@;@]" + (name_of_external ef) + print_expr_list (true, el) + | Sbuiltin(Some id, ef, el) -> + fprintf p "@[<hv 2>%s =@ builtin %s@,(@[<hov 0>%a@]);@]@]" + (ident_name id) + (name_of_external ef) + print_expr_list (true, el) | Sseq(Sskip, s2) -> print_stmt p s2 | Sseq(s1, Sskip) -> diff --git a/backend/RTL.v b/backend/RTL.v index 6a20941..9b27a17 100644 --- a/backend/RTL.v +++ b/backend/RTL.v @@ -360,7 +360,7 @@ Proof. exploit external_call_receptive; eauto. intros [vres2 [m2 EC2]]. exists (Returnstate s0 vres2 m2). econstructor; eauto. (* trace length *) - inv H; simpl; try omega. + red; intros; inv H; simpl; try omega. eapply external_call_trace_length; eauto. eapply external_call_trace_length; eauto. Qed. diff --git a/backend/Selection.v b/backend/Selection.v index 9c037b8..2d6c901 100644 --- a/backend/Selection.v +++ b/backend/Selection.v @@ -112,6 +112,7 @@ Definition sel_unop (op: Cminor.unary_operation) (arg: expr) : expr := | Cminor.Ocast16unsigned => cast16unsigned arg | Cminor.Ocast16signed => cast16signed arg | Cminor.Onegint => negint arg + | Cminor.Oboolval => boolval arg | Cminor.Onotbool => notbool arg | Cminor.Onotint => notint arg | Cminor.Onegf => negf arg @@ -202,6 +203,8 @@ Fixpoint sel_stmt (ge: Cminor.genv) (s: Cminor.stmt) : stmt := | None => Scall optid sg (sel_expr fn) (sel_exprlist args) | Some ef => Sbuiltin optid ef (sel_exprlist args) end + | Cminor.Sbuiltin optid ef args => + Sbuiltin optid ef (sel_exprlist args) | Cminor.Stailcall sg fn args => Stailcall sg (sel_expr fn) (sel_exprlist args) | Cminor.Sseq s1 s2 => Sseq (sel_stmt ge s1) (sel_stmt ge s2) diff --git a/backend/Selectionproof.v b/backend/Selectionproof.v index 54d59b1..9681c66 100644 --- a/backend/Selectionproof.v +++ b/backend/Selectionproof.v @@ -212,6 +212,7 @@ Proof. apply eval_cast8signed; auto. apply eval_cast16unsigned; auto. apply eval_cast16signed; auto. + apply eval_boolval; auto. apply eval_negint; auto. apply eval_notbool; auto. apply eval_notint; auto. @@ -619,6 +620,15 @@ Proof. eapply functions_translated; eauto. apply sig_function_translated. constructor; auto. apply call_cont_commut; auto. + (* Sbuiltin *) + exploit sel_exprlist_correct; eauto. intros [vargs' [P Q]]. + exploit external_call_mem_extends; eauto. + intros [vres' [m2 [A [B [C D]]]]]. + left; econstructor; split. + econstructor. eauto. eapply external_call_symbols_preserved; eauto. + exact symbols_preserved. exact varinfo_preserved. + constructor; auto. + destruct optid; simpl; auto. apply set_var_lessdef; auto. (* Seq *) left; econstructor; split. constructor. constructor; auto. constructor; auto. (* Sifthenelse *) diff --git a/cfrontend/C2C.ml b/cfrontend/C2C.ml index ee51914..d4faa2b 100644 --- a/cfrontend/C2C.ml +++ b/cfrontend/C2C.ml @@ -122,7 +122,9 @@ let name_for_string_literal env s = id let typeStringLiteral s = - Tarray(Tint(I8, Unsigned), z_of_camlint(Int32.of_int(String.length s + 1))) + Tarray(Tint(I8, Unsigned, noattr), + z_of_camlint(Int32.of_int(String.length s + 1)), + noattr) let global_for_string s id = let init = ref [] in @@ -162,8 +164,8 @@ let register_stub_function name tres targs = | Tcons(_, tl) -> "i" :: letters_of_type tl in let rec types_of_types = function | Tnil -> Tnil - | Tcons(Tfloat _, tl) -> Tcons(Tfloat F64, types_of_types tl) - | Tcons(_, tl) -> Tcons(Tpointer Tvoid, types_of_types tl) in + | Tcons(Tfloat _, tl) -> Tcons(Tfloat(F64, noattr), types_of_types tl) + | Tcons(_, tl) -> Tcons(Tpointer(Tvoid, noattr), types_of_types tl) in let stub_name = name ^ "$" ^ String.concat "" (letters_of_type targs) in let targs = types_of_types targs in @@ -204,7 +206,8 @@ let register_inlined_memcpy sz al = let al = if al <= 4l then al else 4l in (* max alignment supported by CompCert *) let name = Printf.sprintf "__builtin_memcpy_sz%ld_al%ld" sz al in - let targs = Tcons(Tpointer Tvoid, Tcons(Tpointer Tvoid, Tnil)) + let targs = Tcons(Tpointer(Tvoid, noattr), + Tcons(Tpointer(Tvoid, noattr), Tnil)) and tres = Tvoid and ef = EF_memcpy(coqint_of_camlint sz, coqint_of_camlint al) in register_special_external name ef targs tres; @@ -233,10 +236,14 @@ let make_builtin_memcpy args = let convertInt n = coqint_of_camlint(Int64.to_int32 n) +(** Attributes *) + +let convertAttr a = List.mem AVolatile a + (** Types *) let convertIkind = function - | C.IBool -> unsupported "'_Bool' type"; (Unsigned, I8) + | C.IBool -> (Unsigned, IBool) | C.IChar -> ((if (!Cparser.Machine.config).Cparser.Machine.char_signed then Signed else Unsigned), I8) | C.ISChar -> (Signed, I8) @@ -258,12 +265,13 @@ let convertFkind = function if not !Clflags.option_flongdouble then unsupported "'long double' type"; F64 -let int64_struct = - let ty = Tint(I32,Unsigned) in +let int64_struct a = + let ty = Tint(I32,Unsigned,noattr) in Tstruct(intern_string "struct __int64", - if Memdataaux.big_endian - then Fcons(intern_string "hi", ty, Fcons(intern_string "lo", ty, Fnil)) - else Fcons(intern_string "lo", ty, Fcons(intern_string "hi", ty, Fnil))) + (if Memdataaux.big_endian + then Fcons(intern_string "hi", ty, Fcons(intern_string "lo", ty, Fnil)) + else Fcons(intern_string "lo", ty, Fcons(intern_string "hi", ty, Fnil))), + a) let convertTyp env t = @@ -271,27 +279,27 @@ let convertTyp env t = match Cutil.unroll env t with | C.TVoid a -> Tvoid | C.TInt((C.ILongLong|C.IULongLong), a) when !Clflags.option_flonglong -> - int64_struct + int64_struct (convertAttr a) | C.TInt(ik, a) -> - let (sg, sz) = convertIkind ik in Tint(sz, sg) + let (sg, sz) = convertIkind ik in Tint(sz, sg, convertAttr a) | C.TFloat(fk, a) -> - Tfloat(convertFkind fk) + Tfloat(convertFkind fk, convertAttr a) | C.TPtr(ty, a) -> begin match Cutil.unroll env ty with | C.TStruct(id, _) when List.mem id seen -> - Tcomp_ptr(intern_string ("struct " ^ id.name)) + Tcomp_ptr(intern_string ("struct " ^ id.name), convertAttr a) | C.TUnion(id, _) when List.mem id seen -> - Tcomp_ptr(intern_string ("union " ^ id.name)) + Tcomp_ptr(intern_string ("union " ^ id.name), convertAttr a) | _ -> - Tpointer(convertTyp seen ty) + Tpointer(convertTyp seen ty, convertAttr a) end | C.TArray(ty, None, a) -> (* Cparser verified that the type ty[] occurs only in contexts that are safe for Clight, so just treat as ty[0]. *) (* warning "array type of unspecified size"; *) - Tarray(convertTyp seen ty, coqint_of_camlint 0l) + Tarray(convertTyp seen ty, coqint_of_camlint 0l, convertAttr a) | C.TArray(ty, Some sz, a) -> - Tarray(convertTyp seen ty, convertInt sz) + Tarray(convertTyp seen ty, convertInt sz, convertAttr a) | C.TFun(tres, targs, va, a) -> if va then unsupported "variadic function type"; if Cutil.is_composite_type env tres then @@ -309,20 +317,18 @@ let convertTyp env t = convertFields (id :: seen) (Env.find_struct env id) with Env.Error e -> error (Env.error_message e); Fnil in - Tstruct(intern_string("struct " ^ id.name), flds) + Tstruct(intern_string("struct " ^ id.name), flds, convertAttr a) | C.TUnion(id, a) -> let flds = try convertFields (id :: seen) (Env.find_union env id) with Env.Error e -> error (Env.error_message e); Fnil in - Tunion(intern_string("union " ^ id.name), flds) + Tunion(intern_string("union " ^ id.name), flds, convertAttr a) and convertParams seen = function | [] -> Tnil | (id, ty) :: rem -> - if Cutil.is_composite_type env ty then - unsupported "function parameter of struct or union type"; Tcons(convertTyp seen ty, convertParams seen rem) and convertFields seen ci = @@ -358,10 +364,10 @@ let string_of_type ty = let first_class_value env ty = match Cutil.unroll env ty with | C.TInt((C.ILongLong|C.IULongLong), _) -> false - | C.TStruct _ -> false - | C.TUnion _ -> false | _ -> true +(************ REMOVED + (* Handling of volatile *) let is_volatile_access env e = @@ -398,16 +404,15 @@ let volatile_write_fun ty = let name = "__builtin_volatile_write_" ^ suffix in register_special_external name (EF_vstore chunk) targs Tvoid; Evalof(Evar(intern_string name, Tfunction(targs, Tvoid)), Tfunction(targs, Tvoid)) +****************************) (** Expressions *) -let ezero = Eval(Vint(coqint_of_camlint 0l), Tint(I32, Signed)) +let ezero = Eval(Vint(coqint_of_camlint 0l), type_int32s) let check_assignop msg env e = if not (first_class_value env e.etyp) then - unsupported (msg ^ " on a l-value of type " ^ string_of_type e.etyp); - if is_volatile_access env e then - unsupported (msg ^ " on a volatile l-value") + unsupported (msg ^ " on a l-value of type " ^ string_of_type e.etyp) let rec convertExpr env e = let ty = convertTyp env e.etyp in @@ -418,12 +423,7 @@ let rec convertExpr env e = let l = convertLvalue env e in if not (first_class_value env e.etyp) then unsupported ("r-value of type " ^ string_of_type e.etyp); - if is_volatile_access env e then - Ecall(volatile_read_fun (typeof l), - Econs(Eaddrof(l, Tpointer(typeof l)), Enil), - ty) - else - Evalof(l, ty) + Evalof(l, ty) | C.EConst(C.CInt(i, k, _)) -> if k = C.ILongLong || k = C.IULongLong then @@ -492,14 +492,8 @@ let rec convertExpr env e = | C.EBinop(C.Oassign, e1, e2, _) -> let e1' = convertLvalue env e1 in let e2' = convertExpr env e2 in - if not (first_class_value env e1.etyp) then - unsupported ("assignment to a l-value of type " ^ string_of_type e1.etyp); - if is_volatile_access env e1 then - Ecall(volatile_write_fun (typeof e1'), - Econs(Eaddrof(e1', Tpointer(typeof e1')), Econs(e2', Enil)), - Tvoid) (* SimplVolatile guarantees that ret. value is unused *) - else - Eassign(e1', e2', ty) + check_assignop "assignment" env e1; + Eassign(e1', e2', ty) | C.EBinop((C.Oadd_assign|C.Osub_assign|C.Omul_assign|C.Odiv_assign| C.Omod_assign|C.Oand_assign|C.Oor_assign|C.Oxor_assign| C.Oshl_assign|C.Oshr_assign) as op, @@ -599,7 +593,7 @@ and convertLvalue env e = let e1' = convertExpr env e1 in let ty1 = match typeof e1' with - | Tpointer t -> t + | Tpointer(t, _) -> t | _ -> error ("wrong type for ->" ^ id ^ " access"); Tvoid in Efield(Ederef(e1', ty1), intern_string id, ty) | C.EBinop(C.Oindex, e1, e2, _) -> @@ -723,8 +717,6 @@ let convertFundef env fd = let params = List.map (fun (id, ty) -> - if Cutil.is_composite_type env ty then - unsupported "function parameter of struct or union type"; (intern_string id.name, convertTyp env ty)) fd.fd_params in let vars = diff --git a/cfrontend/Cexec.v b/cfrontend/Cexec.v index 4bce535..b3c3f6b 100644 --- a/cfrontend/Cexec.v +++ b/cfrontend/Cexec.v @@ -13,6 +13,7 @@ (** Animating the CompCert C semantics *) Require Import Axioms. +Require Import Classical. Require Import Coqlib. Require Import Errors. Require Import Maps. @@ -28,28 +29,20 @@ Require Import Csyntax. Require Import Csem. Require Cstrategy. -Lemma type_eq: forall (ty1 ty2: type), {ty1=ty2} + {ty1<>ty2} -with typelist_eq: forall (tyl1 tyl2: typelist), {tyl1=tyl2} + {tyl1<>tyl2} -with fieldlist_eq: forall (fld1 fld2: fieldlist), {fld1=fld2} + {fld1<>fld2}. -Proof. - assert (forall (x y: intsize), {x=y} + {x<>y}). decide equality. - assert (forall (x y: signedness), {x=y} + {x<>y}). decide equality. - assert (forall (x y: floatsize), {x=y} + {x<>y}). decide equality. - generalize ident_eq zeq. intros E1 E2. - decide equality. - decide equality. - generalize ident_eq. intros E1. - decide equality. -Defined. - -Opaque type_eq. - (** Error monad with options or lists *) Notation "'do' X <- A ; B" := (match A with Some X => B | None => None end) (at level 200, X ident, A at level 100, B at level 200) : option_monad_scope. +Notation "'do' X , Y <- A ; B" := (match A with Some (X, Y) => B | None => None end) + (at level 200, X ident, Y ident, A at level 100, B at level 200) + : option_monad_scope. + +Notation "'do' X , Y , Z <- A ; B" := (match A with Some (X, Y, Z) => B | None => None end) + (at level 200, X ident, Y ident, Z ident, A at level 100, B at level 200) + : option_monad_scope. + Notation " 'check' A ; B" := (if A then B else None) (at level 200, A at level 100, B at level 200) : option_monad_scope. @@ -99,20 +92,558 @@ Proof. destruct s; (left; congruence) || (right; congruence). Qed. -(** * Reduction of expressions *) +(** * Events, volatile memory accesses, and external functions. *) Section EXEC. Variable ge: genv. +Definition eventval_of_val (v: val) (t: typ) : option eventval := + match v, t with + | Vint i, AST.Tint => Some (EVint i) + | Vfloat f, AST.Tfloat => Some (EVfloat f) + | Vptr b ofs, AST.Tint => do id <- Genv.invert_symbol ge b; Some (EVptr_global id ofs) + | _, _ => None + end. + +Fixpoint list_eventval_of_val (vl: list val) (tl: list typ) : option (list eventval) := + match vl, tl with + | nil, nil => Some nil + | v1::vl, t1::tl => + do ev1 <- eventval_of_val v1 t1; + do evl <- list_eventval_of_val vl tl; + Some (ev1 :: evl) + | _, _ => None + end. + +Definition val_of_eventval (ev: eventval) (t: typ) : option val := + match ev, t with + | EVint i, AST.Tint => Some (Vint i) + | EVfloat f, AST.Tfloat => Some (Vfloat f) + | EVptr_global id ofs, AST.Tint => do b <- Genv.find_symbol ge id; Some (Vptr b ofs) + | _, _ => None + end. + +Lemma eventval_of_val_sound: + forall v t ev, eventval_of_val v t = Some ev -> eventval_match ge ev t v. +Proof. + intros. destruct v; destruct t; simpl in H; inv H. + constructor. + constructor. + destruct (Genv.invert_symbol ge b) as [id|]_eqn; inv H1. + constructor. apply Genv.invert_find_symbol; auto. +Qed. + +Lemma eventval_of_val_complete: + forall ev t v, eventval_match ge ev t v -> eventval_of_val v t = Some ev. +Proof. + induction 1; simpl; auto. + rewrite (Genv.find_invert_symbol _ _ H). auto. +Qed. + +Lemma list_eventval_of_val_sound: + forall vl tl evl, list_eventval_of_val vl tl = Some evl -> eventval_list_match ge evl tl vl. +Proof with try discriminate. + induction vl; destruct tl; simpl; intros; inv H. + constructor. + destruct (eventval_of_val a t) as [ev1|]_eqn... + destruct (list_eventval_of_val vl tl) as [evl'|]_eqn... + inv H1. constructor. apply eventval_of_val_sound; auto. eauto. +Qed. + +Lemma list_eventval_of_val_complete: + forall evl tl vl, eventval_list_match ge evl tl vl -> list_eventval_of_val vl tl = Some evl. +Proof. + induction 1; simpl. auto. + rewrite (eventval_of_val_complete _ _ _ H). rewrite IHeventval_list_match. auto. +Qed. + +Lemma val_of_eventval_sound: + forall ev t v, val_of_eventval ev t = Some v -> eventval_match ge ev t v. +Proof. + intros. destruct ev; destruct t; simpl in H; inv H. + constructor. + constructor. + destruct (Genv.find_symbol ge i) as [b|]_eqn; inv H1. + constructor. auto. +Qed. + +Lemma val_of_eventval_complete: + forall ev t v, eventval_match ge ev t v -> val_of_eventval ev t = Some v. +Proof. + induction 1; simpl; auto. rewrite H; auto. +Qed. + +(** Volatile memory accesses. *) + +Definition do_volatile_load (w: world) (chunk: memory_chunk) (m: mem) (b: block) (ofs: int) + : option (world * trace * val) := + if block_is_volatile ge b then + do id <- Genv.invert_symbol ge b; + match nextworld_vload w chunk id ofs with + | None => None + | Some(res, w') => + do vres <- val_of_eventval res (type_of_chunk chunk); + Some(w', Event_vload chunk id ofs res :: nil, Val.load_result chunk vres) + end + else + do v <- Mem.load chunk m b (Int.unsigned ofs); + Some(w, E0, v). + +Definition do_volatile_store (w: world) (chunk: memory_chunk) (m: mem) (b: block) (ofs: int) (v: val) + : option (world * trace * mem) := + if block_is_volatile ge b then + do id <- Genv.invert_symbol ge b; + do ev <- eventval_of_val v (type_of_chunk chunk); + do w' <- nextworld_vstore w chunk id ofs ev; + Some(w', Event_vstore chunk id ofs ev :: nil, m) + else + do m' <- Mem.store chunk m b (Int.unsigned ofs) v; + Some(w, E0, m'). + +Ltac mydestr := + match goal with + | [ |- None = Some _ -> _ ] => intro X; discriminate + | [ |- Some _ = Some _ -> _ ] => intro X; inv X + | [ |- match ?x with Some _ => _ | None => _ end = Some _ -> _ ] => destruct x as []_eqn; mydestr + | [ |- match ?x with true => _ | false => _ end = Some _ -> _ ] => destruct x as []_eqn; mydestr + | [ |- match ?x with left _ => _ | right _ => _ end = Some _ -> _ ] => destruct x; mydestr + | _ => idtac + end. + +Lemma do_volatile_load_sound: + forall w chunk m b ofs w' t v, + do_volatile_load w chunk m b ofs = Some(w', t, v) -> + volatile_load ge chunk m b ofs t v /\ possible_trace w t w'. +Proof. + intros until v. unfold do_volatile_load. mydestr. + destruct p as [ev w'']. mydestr. + split. constructor; auto. apply Genv.invert_find_symbol; auto. + apply val_of_eventval_sound; auto. + econstructor. constructor; eauto. constructor. + split. constructor; auto. constructor. +Qed. + +Lemma do_volatile_load_complete: + forall w chunk m b ofs w' t v, + volatile_load ge chunk m b ofs t v -> possible_trace w t w' -> + do_volatile_load w chunk m b ofs = Some(w', t, v). +Proof. + unfold do_volatile_load; intros. inv H. + rewrite H1. rewrite (Genv.find_invert_symbol _ _ H2). inv H0. inv H8. inv H6. rewrite H9. + rewrite (val_of_eventval_complete _ _ _ H3). auto. + rewrite H1. rewrite H2. inv H0. auto. +Qed. + +Lemma do_volatile_store_sound: + forall w chunk m b ofs v w' t m', + do_volatile_store w chunk m b ofs v = Some(w', t, m') -> + volatile_store ge chunk m b ofs v t m' /\ possible_trace w t w'. +Proof. + intros until m'. unfold do_volatile_store. mydestr. + split. constructor; auto. apply Genv.invert_find_symbol; auto. + apply eventval_of_val_sound; auto. + econstructor. constructor; eauto. constructor. + split. constructor; auto. constructor. +Qed. + +Lemma do_volatile_store_complete: + forall w chunk m b ofs v w' t m', + volatile_store ge chunk m b ofs v t m' -> possible_trace w t w' -> + do_volatile_store w chunk m b ofs v = Some(w', t, m'). +Proof. + unfold do_volatile_store; intros. inv H. + rewrite H1. rewrite (Genv.find_invert_symbol _ _ H2). + rewrite (eventval_of_val_complete _ _ _ H3). + inv H0. inv H8. inv H6. rewrite H9. auto. + rewrite H1. rewrite H2. inv H0. auto. +Qed. + +(** Accessing locations *) + +Definition do_deref_loc (w: world) (ty: type) (m: mem) (b: block) (ofs: int) : option (world * trace * val) := + match access_mode ty with + | By_value chunk => + match type_is_volatile ty with + | false => do v <- Mem.loadv chunk m (Vptr b ofs); Some(w, E0, v) + | true => do_volatile_load w chunk m b ofs + end + | By_reference => Some(w, E0, Vptr b ofs) + | By_copy => Some(w, E0, Vptr b ofs) + | _ => None + end. + +Definition assign_copy_ok (ty: type) (b: block) (ofs: int) (b': block) (ofs': int) : Prop := + (alignof ty | Int.unsigned ofs') /\ (alignof ty | Int.unsigned ofs) /\ + (b' <> b \/ Int.unsigned ofs' = Int.unsigned ofs + \/ Int.unsigned ofs' + sizeof ty <= Int.unsigned ofs + \/ Int.unsigned ofs + sizeof ty <= Int.unsigned ofs'). + +Remark check_assign_copy: + forall (ty: type) (b: block) (ofs: int) (b': block) (ofs': int), + { assign_copy_ok ty b ofs b' ofs' } + {~ assign_copy_ok ty b ofs b' ofs' }. +Proof with try (right; intuition omega). + intros. unfold assign_copy_ok. + assert (alignof ty > 0). apply alignof_pos; auto. + destruct (Zdivide_dec (alignof ty) (Int.unsigned ofs')); auto... + destruct (Zdivide_dec (alignof ty) (Int.unsigned ofs)); auto... + assert (Y: {b' <> b \/ + Int.unsigned ofs' = Int.unsigned ofs \/ + Int.unsigned ofs' + sizeof ty <= Int.unsigned ofs \/ + Int.unsigned ofs + sizeof ty <= Int.unsigned ofs'} + + {~(b' <> b \/ + Int.unsigned ofs' = Int.unsigned ofs \/ + Int.unsigned ofs' + sizeof ty <= Int.unsigned ofs \/ + Int.unsigned ofs + sizeof ty <= Int.unsigned ofs')}). + destruct (eq_block b' b); auto. + destruct (zeq (Int.unsigned ofs') (Int.unsigned ofs)); auto. + destruct (zle (Int.unsigned ofs' + sizeof ty) (Int.unsigned ofs)); auto. + destruct (zle (Int.unsigned ofs + sizeof ty) (Int.unsigned ofs')); auto. + right; intuition omega. + destruct Y... left; intuition omega. +Qed. + +Definition do_assign_loc (w: world) (ty: type) (m: mem) (b: block) (ofs: int) (v: val): option (world * trace * mem) := + match access_mode ty with + | By_value chunk => + match type_is_volatile ty with + | false => do m' <- Mem.storev chunk m (Vptr b ofs) v; Some(w, E0, m') + | true => do_volatile_store w chunk m b ofs v + end + | By_copy => + match v with + | Vptr b' ofs' => + if check_assign_copy ty b ofs b' ofs' then + do bytes <- Mem.loadbytes m b' (Int.unsigned ofs') (sizeof ty); + do m' <- Mem.storebytes m b (Int.unsigned ofs) bytes; + Some(w, E0, m') + else None + | _ => None + end + | _ => None + end. + +Lemma do_deref_loc_sound: + forall w ty m b ofs w' t v, + do_deref_loc w ty m b ofs = Some(w', t, v) -> + deref_loc ge ty m b ofs t v /\ possible_trace w t w'. +Proof. + unfold do_deref_loc; intros until v. + destruct (access_mode ty) as []_eqn; mydestr. + intros. exploit do_volatile_load_sound; eauto. intuition. eapply deref_loc_volatile; eauto. + split. eapply deref_loc_value; eauto. constructor. + split. eapply deref_loc_reference; eauto. constructor. + split. eapply deref_loc_copy; eauto. constructor. +Qed. + +Lemma do_deref_loc_complete: + forall w ty m b ofs w' t v, + deref_loc ge ty m b ofs t v -> possible_trace w t w' -> + do_deref_loc w ty m b ofs = Some(w', t, v). +Proof. + unfold do_deref_loc; intros. inv H. + inv H0. rewrite H1; rewrite H2; rewrite H3; auto. + rewrite H1; rewrite H2. apply do_volatile_load_complete; auto. + inv H0. rewrite H1. auto. + inv H0. rewrite H1. auto. +Qed. + +Lemma do_assign_loc_sound: + forall w ty m b ofs v w' t m', + do_assign_loc w ty m b ofs v = Some(w', t, m') -> + assign_loc ge ty m b ofs v t m' /\ possible_trace w t w'. +Proof. + unfold do_assign_loc; intros until m'. + destruct (access_mode ty) as []_eqn; mydestr. + intros. exploit do_volatile_store_sound; eauto. intuition. eapply assign_loc_volatile; eauto. + split. eapply assign_loc_value; eauto. constructor. + destruct v; mydestr. destruct a as [P [Q R]]. + split. eapply assign_loc_copy; eauto. constructor. +Qed. + +Lemma do_assign_loc_complete: + forall w ty m b ofs v w' t m', + assign_loc ge ty m b ofs v t m' -> possible_trace w t w' -> + do_assign_loc w ty m b ofs v = Some(w', t, m'). +Proof. + unfold do_assign_loc; intros. inv H. + inv H0. rewrite H1; rewrite H2; rewrite H3; auto. + rewrite H1; rewrite H2. apply do_volatile_store_complete; auto. + rewrite H1. destruct (check_assign_copy ty b ofs b' ofs'). + inv H0. rewrite H5; rewrite H6; auto. + elim n. red; tauto. +Qed. + +(** System calls and library functions *) + +Definition do_ef_external (name: ident) (sg: signature) + (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := + do args <- list_eventval_of_val vargs (sig_args sg); + match nextworld_io w name args with + | None => None + | Some(res, w') => + do vres <- val_of_eventval res (proj_sig_res sg); + Some(w', Event_syscall name args res :: E0, vres, m) + end. + +Definition do_ef_volatile_load (chunk: memory_chunk) + (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := + match vargs with + | Vptr b ofs :: nil => do w',t,v <- do_volatile_load w chunk m b ofs; Some(w',t,v,m) + | _ => None + end. + +Definition do_ef_volatile_store (chunk: memory_chunk) + (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := + match vargs with + | Vptr b ofs :: v :: nil => do w',t,m' <- do_volatile_store w chunk m b ofs v; Some(w',t,Vundef,m') + | _ => None + end. + +Definition do_ef_volatile_load_global (chunk: memory_chunk) (id: ident) (ofs: int) + (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := + do b <- Genv.find_symbol ge id; do_ef_volatile_load chunk w (Vptr b ofs :: vargs) m. + +Definition do_ef_volatile_store_global (chunk: memory_chunk) (id: ident) (ofs: int) + (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := + do b <- Genv.find_symbol ge id; do_ef_volatile_store chunk w (Vptr b ofs :: vargs) m. + +Definition do_ef_malloc + (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := + match vargs with + | Vint n :: nil => + let (m', b) := Mem.alloc m (-4) (Int.unsigned n) in + do m'' <- Mem.store Mint32 m' b (-4) (Vint n); + Some(w, E0, Vptr b Int.zero, m'') + | _ => None + end. + +Definition do_ef_free + (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := + match vargs with + | Vptr b lo :: nil => + do vsz <- Mem.load Mint32 m b (Int.unsigned lo - 4); + match vsz with + | Vint sz => + check (zlt 0 (Int.unsigned sz)); + do m' <- Mem.free m b (Int.unsigned lo - 4) (Int.unsigned lo + Int.unsigned sz); + Some(w, E0, Vundef, m') + | _ => None + end + | _ => None + end. + +Definition memcpy_args_ok + (sz al: Z) (bdst: block) (odst: Z) (bsrc: block) (osrc: Z) : Prop := + (al = 1 \/ al = 2 \/ al = 4) + /\ sz > 0 + /\ (al | sz) /\ (al | osrc) /\ (al | odst) + /\ (bsrc <> bdst \/ osrc = odst \/ osrc + sz <= odst \/ odst + sz <= osrc). + +Remark memcpy_check_args: + forall sz al bdst odst bsrc osrc, + {memcpy_args_ok sz al bdst odst bsrc osrc} + {~memcpy_args_ok sz al bdst odst bsrc osrc}. +Proof with try (right; intuition omega). + intros. + assert (X: {al = 1 \/ al = 2 \/ al = 4} + {~(al = 1 \/ al = 2 \/ al = 4)}). + destruct (zeq al 1); auto. destruct (zeq al 2); auto. destruct (zeq al 4); auto... + unfold memcpy_args_ok. destruct X... + assert (al > 0) by (intuition omega). + destruct (zlt 0 sz)... + destruct (Zdivide_dec al sz); auto... + destruct (Zdivide_dec al osrc); auto... + destruct (Zdivide_dec al odst); auto... + assert (Y: {bsrc <> bdst \/ osrc = odst \/ osrc + sz <= odst \/ odst + sz <= osrc} + +{~(bsrc <> bdst \/ osrc = odst \/ osrc + sz <= odst \/ odst + sz <= osrc)}). + destruct (eq_block bsrc bdst); auto. + destruct (zeq osrc odst); auto. + destruct (zle (osrc + sz) odst); auto. + destruct (zle (odst + sz) osrc); auto. + right; intuition omega. + destruct Y... left; intuition omega. +Qed. + +Definition do_ef_memcpy (sz al: Z) + (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := + match vargs with + | Vptr bdst odst :: Vptr bsrc osrc :: nil => + if memcpy_check_args sz al bdst (Int.unsigned odst) bsrc (Int.unsigned osrc) then + do bytes <- Mem.loadbytes m bsrc (Int.unsigned osrc) sz; + do m' <- Mem.storebytes m bdst (Int.unsigned odst) bytes; + Some(w, E0, Vundef, m') + else None + | _ => None + end. + +Definition do_ef_annot (text: ident) (targs: list typ) + (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := + do args <- list_eventval_of_val vargs targs; + Some(w, Event_annot text args :: E0, Vundef, m). + +Definition do_ef_annot_val (text: ident) (targ: typ) + (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := + match vargs with + | varg :: nil => + do arg <- eventval_of_val varg targ; + Some(w, Event_annot text (arg :: nil) :: E0, varg, m) + | _ => None + end. + +Definition do_external (ef: external_function): + world -> list val -> mem -> option (world * trace * val * mem) := + match ef with + | EF_external name sg => do_ef_external name sg + | EF_builtin name sg => do_ef_external name sg + | EF_vload chunk => do_ef_volatile_load chunk + | EF_vstore chunk => do_ef_volatile_store chunk + | EF_vload_global chunk id ofs => do_ef_volatile_load_global chunk id ofs + | EF_vstore_global chunk id ofs => do_ef_volatile_store_global chunk id ofs + | EF_malloc => do_ef_malloc + | EF_free => do_ef_free + | EF_memcpy sz al => do_ef_memcpy sz al + | EF_annot text targs => do_ef_annot text targs + | EF_annot_val text targ => do_ef_annot_val text targ + end. + +Lemma do_ef_external_sound: + forall ef w vargs m w' t vres m', + do_external ef w vargs m = Some(w', t, vres, m') -> + external_call ef ge vargs m t vres m' /\ possible_trace w t w'. +Proof with try congruence. + intros until m'. + assert (IO: forall name sg, + do_ef_external name sg w vargs m = Some(w', t, vres, m') -> + extcall_io_sem name sg ge vargs m t vres m' /\ possible_trace w t w'). + intros until sg. unfold do_ef_external. mydestr. destruct p as [res w'']; mydestr. + split. econstructor. apply list_eventval_of_val_sound; auto. + apply val_of_eventval_sound; auto. + econstructor. constructor; eauto. constructor. + + assert (VLOAD: forall chunk vargs, + do_ef_volatile_load chunk w vargs m = Some (w', t, vres, m') -> + volatile_load_sem chunk ge vargs m t vres m' /\ possible_trace w t w'). + intros chunk vargs'. + unfold do_ef_volatile_load. destruct vargs'... destruct v... destruct vargs'... + mydestr. destruct p as [[w'' t''] v]; mydestr. + exploit do_volatile_load_sound; eauto. intuition. econstructor; eauto. + + assert (VSTORE: forall chunk vargs, + do_ef_volatile_store chunk w vargs m = Some (w', t, vres, m') -> + volatile_store_sem chunk ge vargs m t vres m' /\ possible_trace w t w'). + intros chunk vargs'. + unfold do_ef_volatile_store. destruct vargs'... destruct v... destruct vargs'... destruct vargs'... + mydestr. destruct p as [[w'' t''] m'']. mydestr. + exploit do_volatile_store_sound; eauto. intuition. econstructor; eauto. + + destruct ef; simpl. +(* EF_external *) + auto. +(* EF_builtin *) + auto. +(* EF_vload *) + auto. +(* EF_vstore *) + auto. +(* EF_vload_global *) + rewrite volatile_load_global_charact. + unfold do_ef_volatile_load_global. destruct (Genv.find_symbol ge)... + intros. exploit VLOAD; eauto. intros [A B]. split; auto. exists b; auto. +(* EF_vstore_global *) + rewrite volatile_store_global_charact. + unfold do_ef_volatile_store_global. destruct (Genv.find_symbol ge)... + intros. exploit VSTORE; eauto. intros [A B]. split; auto. exists b; auto. +(* EF_malloc *) + unfold do_ef_malloc. destruct vargs... destruct v... destruct vargs... + destruct (Mem.alloc m (-4) (Int.unsigned i)) as [m1 b]_eqn. mydestr. + split. econstructor; eauto. constructor. +(* EF_free *) + unfold do_ef_free. destruct vargs... destruct v... destruct vargs... + mydestr. destruct v... mydestr. + split. econstructor; eauto. omega. constructor. +(* EF_memcpy *) + unfold do_ef_memcpy. destruct vargs... destruct v... destruct vargs... + destruct v... destruct vargs... mydestr. red in m0. + split. econstructor; eauto; tauto. constructor. +(* EF_annot *) + unfold do_ef_annot. mydestr. + split. constructor. apply list_eventval_of_val_sound; auto. + econstructor. constructor; eauto. constructor. +(* EF_annot_val *) + unfold do_ef_annot_val. destruct vargs... destruct vargs... mydestr. + split. constructor. apply eventval_of_val_sound; auto. + econstructor. constructor; eauto. constructor. +Qed. + +Lemma do_ef_external_complete: + forall ef w vargs m w' t vres m', + external_call ef ge vargs m t vres m' -> possible_trace w t w' -> + do_external ef w vargs m = Some(w', t, vres, m'). +Proof. + intros. + assert (IO: forall name sg, + extcall_io_sem name sg ge vargs m t vres m' -> + do_ef_external name sg w vargs m = Some (w', t, vres, m')). + intros. inv H1. inv H0. inv H8. inv H6. + unfold do_ef_external. rewrite (list_eventval_of_val_complete _ _ _ H2). rewrite H8. + rewrite (val_of_eventval_complete _ _ _ H3). auto. + + assert (VLOAD: forall chunk vargs, + volatile_load_sem chunk ge vargs m t vres m' -> + do_ef_volatile_load chunk w vargs m = Some (w', t, vres, m')). + intros. inv H1; unfold do_ef_volatile_load. + exploit do_volatile_load_complete; eauto. intros EQ; rewrite EQ; auto. + + assert (VSTORE: forall chunk vargs, + volatile_store_sem chunk ge vargs m t vres m' -> + do_ef_volatile_store chunk w vargs m = Some (w', t, vres, m')). + intros. inv H1; unfold do_ef_volatile_store. + exploit do_volatile_store_complete; eauto. intros EQ; rewrite EQ; auto. + + destruct ef; simpl in *. +(* EF_external *) + auto. +(* EF_builtin *) + auto. +(* EF_vload *) + auto. +(* EF_vstore *) + auto. +(* EF_vload_global *) + rewrite volatile_load_global_charact in H. destruct H as [b [P Q]]. + unfold do_ef_volatile_load_global. rewrite P. auto. +(* EF_vstore *) + rewrite volatile_store_global_charact in H. destruct H as [b [P Q]]. + unfold do_ef_volatile_store_global. rewrite P. auto. +(* EF_malloc *) + inv H; unfold do_ef_malloc. + inv H0. rewrite H1. rewrite H2. auto. +(* EF_free *) + inv H; unfold do_ef_free. + inv H0. rewrite H1. rewrite zlt_true. rewrite H3. auto. omega. +(* EF_memcpy *) + inv H; unfold do_ef_memcpy. + inv H0. rewrite pred_dec_true. rewrite H7; rewrite H8; auto. + red. tauto. +(* EF_annot *) + inv H; unfold do_ef_annot. inv H0. inv H6. inv H4. + rewrite (list_eventval_of_val_complete _ _ _ H1). auto. +(* EF_annot_val *) + inv H; unfold do_ef_annot_val. inv H0. inv H6. inv H4. + rewrite (eventval_of_val_complete _ _ _ H1). auto. +Qed. + +(** * Reduction of expressions *) + Inductive reduction: Type := | Lred (l': expr) (m': mem) - | Rred (r': expr) (m': mem) - | Callred (fd: fundef) (args: list val) (tyres: type) (m': mem). + | Rred (r': expr) (m': mem) (t: trace) + | Callred (fd: fundef) (args: list val) (tyres: type) (m': mem) + | Stuckred. Section EXPRS. Variable e: env. +Variable w: world. Fixpoint sem_cast_arguments (vtl: list (val * type)) (tl: typelist) : option (list val) := match vtl, tl with @@ -122,41 +653,51 @@ Fixpoint sem_cast_arguments (vtl: list (val * type)) (tl: typelist) : option (li | _, _ => None end. -(** The result of stepping an expression can be -- [None] denoting that the expression is stuck; -- [Some nil] meaning that the expression is fully reduced - (it's [Eval] for a r-value and [Eloc] for a l-value); -- [Some ll] meaning that the expression can reduce to any of - the elements of [ll]. Each element is a pair of a context - and a reduction inside this context (see type [reduction] above). +(** The result of stepping an expression is a list [ll] of possible reducts. + Each element of [ll] is a pair of a context and the result of reducing + inside this context (see type [reduction] above). + The list [ll] is empty if the expression is fully reduced + (it's [Eval] for a r-value and [Eloc] for a l-value). *) -Definition reducts (A: Type): Type := option (list ((expr -> A) * reduction)). +Definition reducts (A: Type): Type := list ((expr -> A) * reduction). Definition topred (r: reduction) : reducts expr := - Some (((fun (x: expr) => x), r) :: nil). + ((fun (x: expr) => x), r) :: nil. -Definition incontext {A B: Type} (ctx: A -> B) (r: reducts A) : reducts B := - match r with - | None => None - | Some l => Some (map (fun z => ((fun (x: expr) => ctx(fst z x)), snd z)) l) - end. +Definition stuck : reducts expr := + ((fun (x: expr) => x), Stuckred) :: nil. + +Definition incontext {A B: Type} (ctx: A -> B) (ll: reducts A) : reducts B := + map (fun z => ((fun (x: expr) => ctx(fst z x)), snd z)) ll. Definition incontext2 {A1 A2 B: Type} - (ctx1: A1 -> B) (r1: reducts A1) - (ctx2: A2 -> B) (r2: reducts A2) : reducts B := - match r1, r2 with - | None, _ => None - | _, None => None - | Some l1, Some l2 => - Some (map (fun z => ((fun (x: expr) => ctx1(fst z x)), snd z)) l1 - ++ map (fun z => ((fun (x: expr) => ctx2(fst z x)), snd z)) l2) - end. + (ctx1: A1 -> B) (ll1: reducts A1) + (ctx2: A2 -> B) (ll2: reducts A2) : reducts B := + incontext ctx1 ll1 ++ incontext ctx2 ll2. + +Notation "'do' X <- A ; B" := (match A with Some X => B | None => stuck end) + (at level 200, X ident, A at level 100, B at level 200) + : reducts_monad_scope. + +Notation "'do' X , Y <- A ; B" := (match A with Some (X, Y) => B | None => stuck end) + (at level 200, X ident, Y ident, A at level 100, B at level 200) + : reducts_monad_scope. + +Notation "'do' X , Y , Z <- A ; B" := (match A with Some (X, Y, Z) => B | None => stuck end) + (at level 200, X ident, Y ident, Z ident, A at level 100, B at level 200) + : reducts_monad_scope. + +Notation " 'check' A ; B" := (if A then B else stuck) + (at level 200, A at level 100, B at level 200) + : reducts_monad_scope. + +Local Open Scope reducts_monad_scope. Fixpoint step_expr (k: kind) (a: expr) (m: mem): reducts expr := match k, a with | LV, Eloc b ofs ty => - Some nil + nil | LV, Evar x ty => match e!x with | Some(b, ty') => @@ -173,47 +714,49 @@ Fixpoint step_expr (k: kind) (a: expr) (m: mem): reducts expr := | Some(Vptr b ofs, ty') => topred (Lred (Eloc b ofs ty) m) | Some _ => - None + stuck | None => incontext (fun x => Ederef x ty) (step_expr RV r m) end - | LV, Efield l f ty => - match is_loc l with - | Some(b, ofs, ty') => + | LV, Efield r f ty => + match is_val r with + | Some(Vptr b ofs, ty') => match ty' with - | Tstruct id fList => + | Tstruct id fList _ => match field_offset f fList with - | Error _ => None + | Error _ => stuck | OK delta => topred (Lred (Eloc b (Int.add ofs (Int.repr delta)) ty) m) end - | Tunion id fList => + | Tunion id fList _ => topred (Lred (Eloc b ofs ty) m) - | _ => None + | _ => stuck end + | Some _ => + stuck | None => - incontext (fun x => Efield x f ty) (step_expr LV l m) + incontext (fun x => Efield x f ty) (step_expr RV r m) end | RV, Eval v ty => - Some nil + nil | RV, Evalof l ty => match is_loc l with | Some(b, ofs, ty') => check type_eq ty ty'; - do v <- load_value_of_type ty m b ofs; - topred (Rred (Eval v ty) m) + do w',t,v <- do_deref_loc w ty m b ofs; + topred (Rred (Eval v ty) m t) | None => incontext (fun x => Evalof x ty) (step_expr LV l m) end | RV, Eaddrof l ty => match is_loc l with - | Some(b, ofs, ty') => topred (Rred (Eval (Vptr b ofs) ty) m) + | Some(b, ofs, ty') => topred (Rred (Eval (Vptr b ofs) ty) m E0) | None => incontext (fun x => Eaddrof x ty) (step_expr LV l m) end | RV, Eunop op r1 ty => match is_val r1 with | Some(v1, ty1) => do v <- sem_unary_operation op v1 ty1; - topred (Rred (Eval v ty) m) + topred (Rred (Eval v ty) m E0) | None => incontext (fun x => Eunop op x ty) (step_expr RV r1 m) end @@ -221,7 +764,7 @@ Fixpoint step_expr (k: kind) (a: expr) (m: mem): reducts expr := match is_val r1, is_val r2 with | Some(v1, ty1), Some(v2, ty2) => do v <- sem_binary_operation op v1 ty1 v2 ty2 m; - topred (Rred (Eval v ty) m) + topred (Rred (Eval v ty) m E0) | _, _ => incontext2 (fun x => Ebinop op x r2 ty) (step_expr RV r1 m) (fun x => Ebinop op r1 x ty) (step_expr RV r2 m) @@ -230,7 +773,7 @@ Fixpoint step_expr (k: kind) (a: expr) (m: mem): reducts expr := match is_val r1 with | Some(v1, ty1) => do v <- sem_cast v1 ty1 ty; - topred (Rred (Eval v ty) m) + topred (Rred (Eval v ty) m E0) | None => incontext (fun x => Ecast x ty) (step_expr RV r1 m) end @@ -238,19 +781,19 @@ Fixpoint step_expr (k: kind) (a: expr) (m: mem): reducts expr := match is_val r1 with | Some(v1, ty1) => do b <- bool_val v1 ty1; - topred (Rred (Eparen (if b then r2 else r3) ty) m) + topred (Rred (Eparen (if b then r2 else r3) ty) m E0) | None => incontext (fun x => Econdition x r2 r3 ty) (step_expr RV r1 m) end | RV, Esizeof ty' ty => - topred (Rred (Eval (Vint (Int.repr (sizeof ty'))) ty) m) + topred (Rred (Eval (Vint (Int.repr (sizeof ty'))) ty) m E0) | RV, Eassign l1 r2 ty => match is_loc l1, is_val r2 with | Some(b, ofs, ty1), Some(v2, ty2) => check type_eq ty1 ty; do v <- sem_cast v2 ty2 ty1; - do m' <- store_value_of_type ty1 m b ofs v; - topred (Rred (Eval v ty) m') + do w',t,m' <- do_assign_loc w ty1 m b ofs v; + topred (Rred (Eval v ty) m' t) | _, _ => incontext2 (fun x => Eassign x r2 ty) (step_expr LV l1 m) (fun x => Eassign l1 x ty) (step_expr RV r2 m) @@ -259,11 +802,10 @@ Fixpoint step_expr (k: kind) (a: expr) (m: mem): reducts expr := match is_loc l1, is_val r2 with | Some(b, ofs, ty1), Some(v2, ty2) => check type_eq ty1 ty; - do v1 <- load_value_of_type ty1 m b ofs; - do v <- sem_binary_operation op v1 ty1 v2 ty2 m; - do v' <- sem_cast v tyres ty1; - do m' <- store_value_of_type ty1 m b ofs v'; - topred (Rred (Eval v' ty) m') + do w',t,v1 <- do_deref_loc w ty1 m b ofs; + let r' := Eassign (Eloc b ofs ty1) + (Ebinop op (Eval v1 ty1) (Eval v2 ty2) tyres) ty1 in + topred (Rred r' m t) | _, _ => incontext2 (fun x => Eassignop op x r2 tyres ty) (step_expr LV l1 m) (fun x => Eassignop op l1 x tyres ty) (step_expr RV r2 m) @@ -272,11 +814,14 @@ Fixpoint step_expr (k: kind) (a: expr) (m: mem): reducts expr := match is_loc l with | Some(b, ofs, ty1) => check type_eq ty1 ty; - do v1 <- load_value_of_type ty m b ofs; - do v2 <- sem_incrdecr id v1 ty; - do v3 <- sem_cast v2 (typeconv ty) ty; - do m' <- store_value_of_type ty m b ofs v3; - topred (Rred (Eval v1 ty) m') + do w',t, v1 <- do_deref_loc w ty m b ofs; + let op := match id with Incr => Oadd | Decr => Osub end in + let r' := + Ecomma (Eassign (Eloc b ofs ty) + (Ebinop op (Eval v1 ty) (Eval (Vint Int.one) type_int32s) (typeconv ty)) + ty) + (Eval v1 ty) ty in + topred (Rred r' m t) | None => incontext (fun x => Epostincr id x ty) (step_expr LV l m) end @@ -284,7 +829,7 @@ Fixpoint step_expr (k: kind) (a: expr) (m: mem): reducts expr := match is_val r1 with | Some _ => check type_eq (typeof r2) ty; - topred (Rred r2 m) + topred (Rred r2 m E0) | None => incontext (fun x => Ecomma x r2 ty) (step_expr RV r1 m) end @@ -292,7 +837,7 @@ Fixpoint step_expr (k: kind) (a: expr) (m: mem): reducts expr := match is_val r1 with | Some (v1, ty1) => do v <- sem_cast v1 ty1 ty; - topred (Rred (Eval v ty) m) + topred (Rred (Eval v ty) m E0) | None => incontext (fun x => Eparen x ty) (step_expr RV r1 m) end @@ -305,24 +850,224 @@ Fixpoint step_expr (k: kind) (a: expr) (m: mem): reducts expr := do vargs <- sem_cast_arguments vtl tyargs; check type_eq (type_of_fundef fd) (Tfunction tyargs tyres); topred (Callred fd vargs ty m) - | _ => None + | _ => stuck end | _, _ => incontext2 (fun x => Ecall x rargs ty) (step_expr RV r1 m) (fun x => Ecall r1 x ty) (step_exprlist rargs m) end - | _, _ => None + | _, _ => stuck end with step_exprlist (rl: exprlist) (m: mem): reducts exprlist := match rl with | Enil => - Some nil + nil | Econs r1 rs => incontext2 (fun x => Econs x rs) (step_expr RV r1 m) (fun x => Econs r1 x) (step_exprlist rs m) end. +(** Technical properties on safe expressions. *) + +Inductive imm_safe_t: kind -> expr -> mem -> Prop := + | imm_safe_t_val: forall v ty m, + imm_safe_t RV (Eval v ty) m + | imm_safe_t_loc: forall b ofs ty m, + imm_safe_t LV (Eloc b ofs ty) m + | imm_safe_t_lred: forall to C l m l' m', + lred ge e l m l' m' -> + context LV to C -> + imm_safe_t to (C l) m + | imm_safe_t_rred: forall to C r m t r' m' w', + rred ge r m t r' m' -> possible_trace w t w' -> + context RV to C -> + imm_safe_t to (C r) m + | imm_safe_t_callred: forall to C r m fd args ty, + callred ge r fd args ty -> + context RV to C -> + imm_safe_t to (C r) m. + +Remark imm_safe_t_imm_safe: + forall k a m, imm_safe_t k a m -> imm_safe ge e k a m. +Proof. + induction 1. + constructor. + constructor. + eapply imm_safe_lred; eauto. + eapply imm_safe_rred; eauto. + eapply imm_safe_callred; eauto. +Qed. + +(* +Definition not_stuck (a: expr) (m: mem) := + forall a' k C, context k RV C -> a = C a' -> imm_safe_t k a' m. + +Lemma safe_expr_kind: + forall k C a m, + context k RV C -> + not_stuck (C a) m -> + k = Cstrategy.expr_kind a. +Proof. + intros. + symmetry. eapply Cstrategy.imm_safe_kind. eapply imm_safe_t_imm_safe. eauto. +Qed. +*) + +Fixpoint exprlist_all_values (rl: exprlist) : Prop := + match rl with + | Enil => True + | Econs (Eval v ty) rl' => exprlist_all_values rl' + | Econs _ _ => False + end. + +Definition invert_expr_prop (a: expr) (m: mem) : Prop := + match a with + | Eloc b ofs ty => False + | Evar x ty => + exists b, + e!x = Some(b, ty) + \/ (e!x = None /\ Genv.find_symbol ge x = Some b /\ type_of_global ge b = Some ty) + | Ederef (Eval v ty1) ty => + exists b, exists ofs, v = Vptr b ofs + | Efield (Eval v ty1) f ty => + exists b, exists ofs, v = Vptr b ofs /\ + match ty1 with + | Tstruct _ fList _ => exists delta, field_offset f fList = Errors.OK delta + | Tunion _ _ _ => True + | _ => False + end + | Eval v ty => False + | Evalof (Eloc b ofs ty') ty => + ty' = ty /\ exists t, exists v, exists w', deref_loc ge ty m b ofs t v /\ possible_trace w t w' + | Eunop op (Eval v1 ty1) ty => + exists v, sem_unary_operation op v1 ty1 = Some v + | Ebinop op (Eval v1 ty1) (Eval v2 ty2) ty => + exists v, sem_binary_operation op v1 ty1 v2 ty2 m = Some v + | Ecast (Eval v1 ty1) ty => + exists v, sem_cast v1 ty1 ty = Some v + | Econdition (Eval v1 ty1) r1 r2 ty => + exists b, bool_val v1 ty1 = Some b + | Eassign (Eloc b ofs ty1) (Eval v2 ty2) ty => + exists v, exists m', exists t, exists w', + ty = ty1 /\ sem_cast v2 ty2 ty1 = Some v /\ assign_loc ge ty1 m b ofs v t m' /\ possible_trace w t w' + | Eassignop op (Eloc b ofs ty1) (Eval v2 ty2) tyres ty => + exists t, exists v1, exists w', + ty = ty1 /\ deref_loc ge ty1 m b ofs t v1 /\ possible_trace w t w' + | Epostincr id (Eloc b ofs ty1) ty => + exists t, exists v1, exists w', + ty = ty1 /\ deref_loc ge ty m b ofs t v1 /\ possible_trace w t w' + | Ecomma (Eval v ty1) r2 ty => + typeof r2 = ty + | Eparen (Eval v1 ty1) ty => + exists v, sem_cast v1 ty1 ty = Some v + | Ecall (Eval vf tyf) rargs ty => + exprlist_all_values rargs -> + exists tyargs, exists tyres, exists fd, exists vl, + classify_fun tyf = fun_case_f tyargs tyres + /\ Genv.find_funct ge vf = Some fd + /\ cast_arguments rargs tyargs vl + /\ type_of_fundef fd = Tfunction tyargs tyres + | _ => True + end. + +Lemma lred_invert: + forall l m l' m', lred ge e l m l' m' -> invert_expr_prop l m. +Proof. + induction 1; red; auto. + exists b; auto. + exists b; auto. + exists b; exists ofs; auto. + exists b; exists ofs; split; auto. exists delta; auto. + exists b; exists ofs; auto. +Qed. + +Lemma rred_invert: + forall w' r m t r' m', rred ge r m t r' m' -> possible_trace w t w' -> invert_expr_prop r m. +Proof. + induction 1; intros; red; auto. + split; auto; exists t; exists v; exists w'; auto. + exists v; auto. + exists v; auto. + exists v; auto. + exists b; auto. + exists v; exists m'; exists t; exists w'; auto. + exists t; exists v1; exists w'; auto. + exists t; exists v1; exists w'; auto. + exists v; auto. +Qed. + +Lemma callred_invert: + forall r fd args ty m, + callred ge r fd args ty -> + invert_expr_prop r m. +Proof. + intros. inv H. simpl. + intros. exists tyargs; exists tyres; exists fd; exists args; auto. +Qed. + +Scheme context_ind2 := Minimality for context Sort Prop + with contextlist_ind2 := Minimality for contextlist Sort Prop. +Combined Scheme context_contextlist_ind from context_ind2, contextlist_ind2. + +Lemma invert_expr_context: + (forall from to C, context from to C -> + forall a m, + invert_expr_prop a m -> + invert_expr_prop (C a) m) +/\(forall from C, contextlist from C -> + forall a m, + invert_expr_prop a m -> + ~exprlist_all_values (C a)). +Proof. + apply context_contextlist_ind; intros; try (exploit H0; [eauto|intros]); simpl. + auto. + destruct (C a); auto; contradiction. + destruct (C a); auto; contradiction. + destruct (C a); auto; contradiction. + auto. + destruct (C a); auto; contradiction. + destruct (C a); auto; contradiction. + destruct e1; auto; destruct (C a); auto; contradiction. + destruct (C a); auto; contradiction. + destruct (C a); auto; contradiction. + destruct (C a); auto; contradiction. + destruct e1; auto; destruct (C a); auto; contradiction. + destruct (C a); auto; contradiction. + destruct e1; auto; destruct (C a); auto; contradiction. + destruct (C a); auto; contradiction. + destruct (C a); auto; contradiction. + destruct e1; auto. intros. elim (H0 a m); auto. + destruct (C a); auto; contradiction. + destruct (C a); auto; contradiction. + red; intros. destruct (C a); auto. + red; intros. destruct e1; auto. elim (H0 a m); auto. +Qed. + +Lemma imm_safe_t_inv: + forall k a m, + imm_safe_t k a m -> + match a with + | Eloc _ _ _ => True + | Eval _ _ => True + | _ => invert_expr_prop a m + end. +Proof. + destruct invert_expr_context as [A B]. + intros. inv H. + auto. + auto. + assert (invert_expr_prop (C l) m). + eapply A; eauto. eapply lred_invert; eauto. + red in H. destruct (C l); auto; contradiction. + assert (invert_expr_prop (C r) m). + eapply A; eauto. eapply rred_invert; eauto. + red in H. destruct (C r); auto; contradiction. + assert (invert_expr_prop (C r) m). + eapply A; eauto. eapply callred_invert; eauto. + red in H. destruct (C r); auto; contradiction. +Qed. + (** Soundness: if [step_expr] returns [Some ll], then every element of [ll] is a reduct. *) @@ -343,19 +1088,27 @@ Qed. Hint Constructors context contextlist. Hint Resolve context_compose contextlist_compose. -Definition reduction_ok (a: expr) (m: mem) (rd: reduction) : Prop := - match rd with - | Lred l' m' => lred ge e a m l' m' - | Rred r' m' => rred a m r' m' - | Callred fd args tyres m' => callred ge a fd args tyres /\ m' = m +Definition reduction_ok (k: kind) (a: expr) (m: mem) (rd: reduction) : Prop := + match k, rd with + | LV, Lred l' m' => lred ge e a m l' m' + | RV, Rred r' m' t => rred ge a m t r' m' /\ exists w', possible_trace w t w' + | RV, Callred fd args tyres m' => callred ge a fd args tyres /\ m' = m + | LV, Stuckred => ~imm_safe_t k a m + | RV, Stuckred => ~imm_safe_t k a m + | _, _ => False end. -Definition reduction_kind (rd: reduction): kind := - match rd with - | Lred l' m' => LV - | Rred r' m' => RV - | Callred fd args tyres m' => RV - end. +Definition reducts_ok (k: kind) (a: expr) (m: mem) (ll: reducts expr) : Prop := + (forall C rd, + In (C, rd) ll -> + exists a', exists k', context k' k C /\ a = C a' /\ reduction_ok k' a' m rd) + /\ (ll = nil -> match k with LV => is_loc a <> None | RV => is_val a <> None end). + +Definition list_reducts_ok (al: exprlist) (m: mem) (ll: reducts exprlist) : Prop := + (forall C rd, + In (C, rd) ll -> + exists a', exists k', contextlist k' C /\ al = C a' /\ reduction_ok k' a' m rd) + /\ (ll = nil -> is_val_list al <> None). Ltac monadInv := match goal with @@ -378,36 +1131,59 @@ Proof. inv H0. rewrite (is_val_inv _ _ _ Heqo). constructor. auto. eauto. Qed. -Definition reducts_ok (k: kind) (a: expr) (m: mem) (res: reducts expr) : Prop := - match res with - | None => True - | Some nil => match k with LV => is_loc a <> None | RV => is_val a <> None end - | Some ll => - forall C rd, - In (C, rd) ll -> - context (reduction_kind rd) k C /\ exists a', a = C a' /\ reduction_ok a' m rd - end. - -Definition list_reducts_ok (al: exprlist) (m: mem) (res: reducts exprlist) : Prop := - match res with - | None => True - | Some nil => is_val_list al <> None - | Some ll => - forall C rd, - In (C, rd) ll -> - contextlist (reduction_kind rd) C /\ exists a', al = C a' /\ reduction_ok a' m rd - end. +Lemma sem_cast_arguments_complete: + forall al tyl vl, + cast_arguments al tyl vl -> + exists vtl, is_val_list al = Some vtl /\ sem_cast_arguments vtl tyl = Some vl. +Proof. + induction 1. + exists (@nil (val * type)); auto. + destruct IHcast_arguments as [vtl [A B]]. + exists ((v, ty) :: vtl); simpl. rewrite A; rewrite B; rewrite H. auto. +Qed. Lemma topred_ok: forall k a m rd, - reduction_ok a m rd -> - k = reduction_kind rd -> + reduction_ok k a m rd -> reducts_ok k a m (topred rd). Proof. - intros. unfold topred; red. simpl; intros. destruct H1; try contradiction. - inv H1. split. auto. exists a; auto. + intros. unfold topred; split; simpl; intros. + destruct H0; try contradiction. inv H0. exists a; exists k; auto. + congruence. +Qed. + +Lemma stuck_ok: + forall k a m, + ~imm_safe_t k a m -> + reducts_ok k a m stuck. +Proof. + intros. unfold stuck; split; simpl; intros. + destruct H0; try contradiction. inv H0. exists a; exists k; intuition. red. destruct k; auto. + congruence. Qed. +Lemma wrong_kind_ok: + forall k a m, + k <> Cstrategy.expr_kind a -> + reducts_ok k a m stuck. +Proof. + intros. apply stuck_ok. red; intros. exploit Cstrategy.imm_safe_kind; eauto. + eapply imm_safe_t_imm_safe; eauto. +Qed. + +Lemma not_invert_ok: + forall k a m, + match a with + | Eloc _ _ _ => False + | Eval _ _ => False + | _ => invert_expr_prop a m -> False + end -> + reducts_ok k a m stuck. +Proof. + intros. apply stuck_ok. red; intros. + exploit imm_safe_t_inv; eauto. destruct a; auto. +Qed. + Lemma incontext_ok: forall k a m C res k' a', reducts_ok k' a' m res -> @@ -416,48 +1192,11 @@ Lemma incontext_ok: match k' with LV => is_loc a' = None | RV => is_val a' = None end -> reducts_ok k a m (incontext C res). Proof. - unfold reducts_ok; intros. destruct res; simpl. destruct l. -(* res = Some nil *) - destruct k'; congruence. -(* res = Some nonempty-list *) - simpl map at 1. hnf. intros. + unfold reducts_ok, incontext; intros. destruct H. split; intros. exploit list_in_map_inv; eauto. intros [[C1 rd1] [P Q]]. inv P. - exploit H; eauto. intros [U [a'' [V W]]]. - split. eapply context_compose; eauto. exists a''; split; auto. congruence. -(* res = None *) - auto. -Qed. - -Remark incontext2_inv: - forall {A1 A2 B: Type} (C1: A1 -> B) res1 (C2: A2 -> B) res2, - match incontext2 C1 res1 C2 res2 with - | None => res1 = None \/ res2 = None - | Some nil => res1 = Some nil /\ res2 = Some nil - | Some ll => - exists ll1, exists ll2, - res1 = Some ll1 /\ res2 = Some ll2 /\ - forall C rd, In (C, rd) ll -> - (exists C', C = (fun x => C1(C' x)) /\ In (C', rd) ll1) - \/ (exists C', C = (fun x => C2(C' x)) /\ In (C', rd) ll2) - end. -Proof. - intros. unfold incontext2. destruct res1 as [ll1|]; auto. destruct res2 as [ll2|]; auto. - set (ll := map - (fun z : (expr -> A1) * reduction => - (fun x : expr => C1 (fst z x), snd z)) ll1 ++ - map - (fun z : (expr -> A2) * reduction => - (fun x : expr => C2 (fst z x), snd z)) ll2). - destruct ll as []_eqn. - destruct (app_eq_nil _ _ Heql). - split. destruct ll1; auto || discriminate. destruct ll2; auto || discriminate. - rewrite <- Heql. exists ll1; exists ll2. split. auto. split. auto. - unfold ll; intros. - rewrite in_app in H. destruct H. - exploit list_in_map_inv; eauto. intros [[C' rd'] [P Q]]. inv P. - left; exists C'; auto. - exploit list_in_map_inv; eauto. intros [[C' rd'] [P Q]]. inv P. - right; exists C'; auto. + exploit H; eauto. intros [a'' [k'' [U [V W]]]]. + exists a''; exists k''. split. eapply context_compose; eauto. rewrite V; auto. + destruct res; simpl in H4; try congruence. destruct k'; intuition congruence. Qed. Lemma incontext2_ok: @@ -470,17 +1209,16 @@ Lemma incontext2_ok: \/ match k2 with LV => is_loc a2 = None | RV => is_val a2 = None end -> reducts_ok k a m (incontext2 C1 res1 C2 res2). Proof. - unfold reducts_ok; intros. - generalize (incontext2_inv C1 res1 C2 res2). - destruct (incontext2 C1 res1 C2 res2) as [ll|]; auto. - destruct ll. - intros [EQ1 EQ2]. subst. destruct H5. destruct k1; congruence. destruct k2; congruence. - intros [ll1 [ll2 [EQ1 [EQ2 IN]]]]. subst. intros. - exploit IN; eauto. intros [[C' [P Q]] | [C' [P Q]]]; subst. - destruct ll1; try contradiction. exploit H; eauto. - intros [U [a' [V W]]]. split. eauto. exists a'; split. congruence. auto. - destruct ll2; try contradiction. exploit H0; eauto. - intros [U [a' [V W]]]. split. eauto. exists a'; split. congruence. auto. + unfold reducts_ok, incontext2, incontext; intros. destruct H; destruct H0; split; intros. + destruct (in_app_or _ _ _ H8). + exploit list_in_map_inv; eauto. intros [[C' rd'] [P Q]]. inv P. + exploit H; eauto. intros [a'' [k'' [U [V W]]]]. + exists a''; exists k''. split. eapply context_compose; eauto. rewrite V; auto. + exploit list_in_map_inv; eauto. intros [[C' rd'] [P Q]]. inv P. + exploit H0; eauto. intros [a'' [k'' [U [V W]]]]. + exists a''; exists k''. split. eapply context_compose; eauto. rewrite H2; rewrite V; auto. + destruct res1; simpl in H8; try congruence. destruct res2; simpl in H8; try congruence. + destruct H5. destruct k1; intuition congruence. destruct k2; intuition congruence. Qed. Lemma incontext2_list_ok: @@ -492,18 +1230,16 @@ Lemma incontext2_list_ok: (incontext2 (fun x => Ecall x a2 ty) res1 (fun x => Ecall a1 x ty) res2). Proof. - unfold reducts_ok, list_reducts_ok; intros. - set (C1 := fun x => Ecall x a2 ty). set (C2 := fun x => Ecall a1 x ty). - generalize (incontext2_inv C1 res1 C2 res2). - destruct (incontext2 C1 res1 C2 res2) as [ll|]; auto. - destruct ll. - intros [EQ1 EQ2]. subst. intuition congruence. - intros [ll1 [ll2 [EQ1 [EQ2 IN]]]]. subst. intros. - exploit IN; eauto. intros [[C' [P Q]] | [C' [P Q]]]; subst. - destruct ll1; try contradiction. exploit H; eauto. - intros [U [a' [V W]]]. split. unfold C1. auto. exists a'; split. unfold C1; congruence. auto. - destruct ll2; try contradiction. exploit H0; eauto. - intros [U [a' [V W]]]. split. unfold C2. auto. exists a'; split. unfold C2; congruence. auto. + unfold reducts_ok, incontext2, incontext; intros. destruct H; destruct H0; split; intros. + destruct (in_app_or _ _ _ H4). + exploit list_in_map_inv; eauto. intros [[C' rd'] [P Q]]. inv P. + exploit H; eauto. intros [a'' [k'' [U [V W]]]]. + exists a''; exists k''. split. eauto. rewrite V; auto. + exploit list_in_map_inv; eauto. intros [[C' rd'] [P Q]]. inv P. + exploit H0; eauto. intros [a'' [k'' [U [V W]]]]. + exists a''; exists k''. split. eauto. rewrite V; auto. + destruct res1; simpl in H4; try congruence. destruct res2; simpl in H4; try congruence. + tauto. Qed. Lemma incontext2_list_ok': @@ -514,165 +1250,201 @@ Lemma incontext2_list_ok': (incontext2 (fun x => Econs x a2) res1 (fun x => Econs a1 x) res2). Proof. - unfold reducts_ok, list_reducts_ok; intros. - set (C1 := fun x => Econs x a2). set (C2 := fun x => Econs a1 x). - generalize (incontext2_inv C1 res1 C2 res2). - destruct (incontext2 C1 res1 C2 res2) as [ll|]; auto. - destruct ll. - intros [EQ1 EQ2]. subst. - simpl. destruct (is_val a1); try congruence. destruct (is_val_list a2); congruence. - intros [ll1 [ll2 [EQ1 [EQ2 IN]]]]. subst. intros. - exploit IN; eauto. intros [[C' [P Q]] | [C' [P Q]]]; subst. - destruct ll1; try contradiction. exploit H; eauto. - intros [U [a' [V W]]]. split. unfold C1. auto. exists a'; split. unfold C1; congruence. auto. - destruct ll2; try contradiction. exploit H0; eauto. - intros [U [a' [V W]]]. split. unfold C2. auto. exists a'; split. unfold C2; congruence. auto. -Qed. - -Ltac mysimpl := + unfold reducts_ok, list_reducts_ok, incontext2, incontext; intros. + destruct H; destruct H0. split; intros. + destruct (in_app_or _ _ _ H3). + exploit list_in_map_inv; eauto. intros [[C' rd'] [P Q]]. inv P. + exploit H; eauto. intros [a'' [k'' [U [V W]]]]. + exists a''; exists k''. split. eauto. rewrite V; auto. + exploit list_in_map_inv; eauto. intros [[C' rd'] [P Q]]. inv P. + exploit H0; eauto. intros [a'' [k'' [U [V W]]]]. + exists a''; exists k''. split. eauto. rewrite V; auto. + destruct res1; simpl in H3; try congruence. destruct res2; simpl in H3; try congruence. + simpl. destruct (is_val a1). destruct (is_val_list a2). congruence. intuition congruence. intuition congruence. +Qed. + +Lemma is_val_list_all_values: + forall al vtl, is_val_list al = Some vtl -> exprlist_all_values al. +Proof. + induction al; simpl; intros. auto. + destruct (is_val r1) as [[v ty]|]_eqn; try discriminate. + destruct (is_val_list al) as [vtl'|]_eqn; try discriminate. + rewrite (is_val_inv _ _ _ Heqo). eauto. +Qed. + +Ltac myinv := match goal with - | [ |- reducts_ok _ _ _ (match ?x with Some _ => _ | None => None end) ] => - destruct x as []_eqn; [mysimpl|exact I] - | [ |- reducts_ok _ _ _ (match ?x with left _ => _ | right _ => None end) ] => - destruct x as []_eqn; [subst;mysimpl|exact I] - | _ => - idtac + | [ H: False |- _ ] => destruct H + | [ H: _ /\ _ |- _ ] => destruct H; myinv + | [ H: exists _, _ |- _ ] => destruct H; myinv + | _ => idtac end. Theorem step_expr_sound: forall a k m, reducts_ok k a m (step_expr k a m) with step_exprlist_sound: forall al m, list_reducts_ok al m (step_exprlist al m). -Proof with try (exact I). - induction a; destruct k; intros; simpl... +Proof with (try (apply not_invert_ok; simpl; intro; myinv; intuition congruence; fail)). + induction a; intros; simpl; destruct k; try (apply wrong_kind_ok; simpl; congruence). (* Eval *) - congruence. + split; intros. tauto. simpl; congruence. (* Evar *) - destruct (e!x) as [[b ty'] | ]_eqn; mysimpl. - apply topred_ok; auto. apply red_var_local; auto. - apply topred_ok; auto. apply red_var_global; auto. + destruct (e!x) as [[b ty']|]_eqn. + destruct (type_eq ty ty')... + subst. apply topred_ok; auto. apply red_var_local; auto. + destruct (Genv.find_symbol ge x) as [b|]_eqn... + destruct (type_of_global ge b) as [ty'|]_eqn... + destruct (type_eq ty ty')... + subst. apply topred_ok; auto. apply red_var_global; auto. (* Efield *) - destruct (is_loc a) as [[[b ofs] ty'] | ]_eqn. + destruct (is_val a) as [[v ty'] | ]_eqn. + rewrite (is_val_inv _ _ _ Heqo). + destruct v... destruct ty'... (* top struct *) destruct (field_offset f f0) as [delta|]_eqn... - rewrite (is_loc_inv _ _ _ _ Heqo). apply topred_ok; auto. apply red_field_struct; auto. + apply topred_ok; auto. apply red_field_struct; auto. (* top union *) - rewrite (is_loc_inv _ _ _ _ Heqo). apply topred_ok; auto. apply red_field_union; auto. + apply topred_ok; auto. apply red_field_union; auto. (* in depth *) eapply incontext_ok; eauto. (* Evalof *) - destruct (is_loc a) as [[[b ofs] ty'] | ]_eqn. + destruct (is_loc a) as [[[b ofs] ty'] | ]_eqn. rewrite (is_loc_inv _ _ _ _ Heqo). (* top *) - mysimpl. apply topred_ok; auto. rewrite (is_loc_inv _ _ _ _ Heqo). apply red_rvalof; auto. + destruct (type_eq ty ty')... subst ty'. + destruct (do_deref_loc w ty m b ofs) as [[[w' t] v] | ]_eqn. + exploit do_deref_loc_sound; eauto. intros [A B]. + apply topred_ok; auto. red. split. apply red_rvalof; auto. exists w'; auto. + apply not_invert_ok; simpl; intros; myinv. exploit do_deref_loc_complete; eauto. congruence. (* depth *) eapply incontext_ok; eauto. (* Ederef *) - destruct (is_val a) as [[v ty'] | ]_eqn. + destruct (is_val a) as [[v ty'] | ]_eqn. rewrite (is_val_inv _ _ _ Heqo). (* top *) - destruct v... mysimpl. apply topred_ok; auto. rewrite (is_val_inv _ _ _ Heqo). apply red_deref; auto. + destruct v... apply topred_ok; auto. apply red_deref; auto. (* depth *) eapply incontext_ok; eauto. (* Eaddrof *) - destruct (is_loc a) as [[[b ofs] ty'] | ]_eqn. + destruct (is_loc a) as [[[b ofs] ty'] | ]_eqn. rewrite (is_loc_inv _ _ _ _ Heqo). (* top *) - apply topred_ok; auto. rewrite (is_loc_inv _ _ _ _ Heqo). apply red_addrof; auto. + apply topred_ok; auto. split. apply red_addrof; auto. exists w; constructor. (* depth *) eapply incontext_ok; eauto. (* unop *) - destruct (is_val a) as [[v ty'] | ]_eqn. + destruct (is_val a) as [[v ty'] | ]_eqn. rewrite (is_val_inv _ _ _ Heqo). (* top *) - mysimpl. apply topred_ok; auto. rewrite (is_val_inv _ _ _ Heqo). apply red_unop; auto. + destruct (sem_unary_operation op v ty') as [v'|]_eqn... + apply topred_ok; auto. split. apply red_unop; auto. exists w; constructor. (* depth *) eapply incontext_ok; eauto. (* binop *) - destruct (is_val a1) as [[v1 ty1] | ]_eqn. + destruct (is_val a1) as [[v1 ty1] | ]_eqn. destruct (is_val a2) as [[v2 ty2] | ]_eqn. + rewrite (is_val_inv _ _ _ Heqo). rewrite (is_val_inv _ _ _ Heqo0). (* top *) - mysimpl. apply topred_ok; auto. - rewrite (is_val_inv _ _ _ Heqo). rewrite (is_val_inv _ _ _ Heqo0). apply red_binop; auto. + destruct (sem_binary_operation op v1 ty1 v2 ty2 m) as [v|]_eqn... + apply topred_ok; auto. split. apply red_binop; auto. exists w; constructor. (* depth *) eapply incontext2_ok; eauto. eapply incontext2_ok; eauto. (* cast *) - destruct (is_val a) as [[v ty'] | ]_eqn. + destruct (is_val a) as [[v ty'] | ]_eqn. rewrite (is_val_inv _ _ _ Heqo). (* top *) - mysimpl. apply topred_ok; auto. - rewrite (is_val_inv _ _ _ Heqo). apply red_cast; auto. + destruct (sem_cast v ty' ty) as [v'|]_eqn... + apply topred_ok; auto. split. apply red_cast; auto. exists w; constructor. (* depth *) eapply incontext_ok; eauto. (* condition *) - destruct (is_val a1) as [[v ty'] | ]_eqn. + destruct (is_val a1) as [[v ty'] | ]_eqn. rewrite (is_val_inv _ _ _ Heqo). (* top *) - mysimpl. apply topred_ok; auto. - rewrite (is_val_inv _ _ _ Heqo). eapply red_condition; eauto. + destruct (bool_val v ty') as [v'|]_eqn... + apply topred_ok; auto. split. eapply red_condition; eauto. exists w; constructor. (* depth *) eapply incontext_ok; eauto. (* sizeof *) - apply topred_ok; auto. apply red_sizeof. + apply topred_ok; auto. split. apply red_sizeof. exists w; constructor. (* assign *) - destruct (is_loc a1) as [[[b ofs] ty1] | ]_eqn. - destruct (is_val a2) as [[v2 ty2] | ]_eqn. + destruct (is_loc a1) as [[[b ofs] ty1] | ]_eqn. + destruct (is_val a2) as [[v2 ty2] | ]_eqn. + rewrite (is_loc_inv _ _ _ _ Heqo). rewrite (is_val_inv _ _ _ Heqo0). (* top *) - mysimpl. apply topred_ok; auto. - rewrite (is_loc_inv _ _ _ _ Heqo). rewrite (is_val_inv _ _ _ Heqo0). apply red_assign; auto. + destruct (type_eq ty1 ty)... subst ty1. + destruct (sem_cast v2 ty2 ty) as [v|]_eqn... + destruct (do_assign_loc w ty m b ofs v) as [[[w' t] m']|]_eqn. + exploit do_assign_loc_sound; eauto. intros [P Q]. + apply topred_ok; auto. split. apply red_assign; auto. exists w'; auto. + apply not_invert_ok; simpl; intros; myinv. exploit do_assign_loc_complete; eauto. congruence. (* depth *) eapply incontext2_ok; eauto. eapply incontext2_ok; eauto. (* assignop *) - destruct (is_loc a1) as [[[b ofs] ty1] | ]_eqn. - destruct (is_val a2) as [[v2 ty2] | ]_eqn. + destruct (is_loc a1) as [[[b ofs] ty1] | ]_eqn. + destruct (is_val a2) as [[v2 ty2] | ]_eqn. + rewrite (is_loc_inv _ _ _ _ Heqo). rewrite (is_val_inv _ _ _ Heqo0). (* top *) - mysimpl. apply topred_ok; auto. - rewrite (is_loc_inv _ _ _ _ Heqo). rewrite (is_val_inv _ _ _ Heqo0). eapply red_assignop; eauto. + destruct (type_eq ty1 ty)... subst ty1. + destruct (do_deref_loc w ty m b ofs) as [[[w' t] v] | ]_eqn. + exploit do_deref_loc_sound; eauto. intros [A B]. + apply topred_ok; auto. red. split. apply red_assignop; auto. exists w'; auto. + apply not_invert_ok; simpl; intros; myinv. exploit do_deref_loc_complete; eauto. congruence. (* depth *) eapply incontext2_ok; eauto. eapply incontext2_ok; eauto. (* postincr *) - destruct (is_loc a) as [[[b ofs] ty'] | ]_eqn. + destruct (is_loc a) as [[[b ofs] ty'] | ]_eqn. rewrite (is_loc_inv _ _ _ _ Heqo). (* top *) - mysimpl. apply topred_ok; auto. - rewrite (is_loc_inv _ _ _ _ Heqo). eapply red_postincr; eauto. + destruct (type_eq ty' ty)... subst ty'. + destruct (do_deref_loc w ty m b ofs) as [[[w' t] v] | ]_eqn. + exploit do_deref_loc_sound; eauto. intros [A B]. + apply topred_ok; auto. red. split. apply red_postincr; auto. exists w'; auto. + apply not_invert_ok; simpl; intros; myinv. exploit do_deref_loc_complete; eauto. congruence. (* depth *) eapply incontext_ok; eauto. (* comma *) - destruct (is_val a1) as [[v ty'] | ]_eqn. + destruct (is_val a1) as [[v ty'] | ]_eqn. rewrite (is_val_inv _ _ _ Heqo). (* top *) - mysimpl. apply topred_ok; auto. - rewrite (is_val_inv _ _ _ Heqo). apply red_comma; auto. + destruct (type_eq (typeof a2) ty)... subst ty. + apply topred_ok; auto. split. apply red_comma; auto. exists w; constructor. (* depth *) eapply incontext_ok; eauto. (* call *) - destruct (is_val a) as [[vf tyf] | ]_eqn. - destruct (is_val_list rargs) as [vtl | ]_eqn. + destruct (is_val a) as [[vf tyf] | ]_eqn. + destruct (is_val_list rargs) as [vtl | ]_eqn. + rewrite (is_val_inv _ _ _ Heqo). exploit is_val_list_all_values; eauto. intros ALLVAL. (* top *) destruct (classify_fun tyf) as [tyargs tyres|]_eqn... - mysimpl. apply topred_ok; auto. - rewrite (is_val_inv _ _ _ Heqo). red. split; auto. eapply red_Ecall; eauto. - eapply sem_cast_arguments_sound; eauto. + destruct (Genv.find_funct ge vf) as [fd|]_eqn... + destruct (sem_cast_arguments vtl tyargs) as [vargs|]_eqn... + destruct (type_eq (type_of_fundef fd) (Tfunction tyargs tyres))... + apply topred_ok; auto. red. split; auto. eapply red_Ecall; eauto. + eapply sem_cast_arguments_sound; eauto. + apply not_invert_ok; simpl; intros; myinv. specialize (H ALLVAL). myinv. congruence. + apply not_invert_ok; simpl; intros; myinv. specialize (H ALLVAL). myinv. + exploit sem_cast_arguments_complete; eauto. intros [vtl' [P Q]]. congruence. + apply not_invert_ok; simpl; intros; myinv. specialize (H ALLVAL). myinv. congruence. + apply not_invert_ok; simpl; intros; myinv. specialize (H ALLVAL). myinv. congruence. (* depth *) eapply incontext2_list_ok; eauto. eapply incontext2_list_ok; eauto. (* loc *) - congruence. + split; intros. tauto. simpl; congruence. (* paren *) - destruct (is_val a) as [[v ty'] | ]_eqn. + destruct (is_val a) as [[v ty'] | ]_eqn. rewrite (is_val_inv _ _ _ Heqo). (* top *) - mysimpl. apply topred_ok; auto. - rewrite (is_val_inv _ _ _ Heqo). apply red_paren; auto. + destruct (sem_cast v ty' ty) as [v'|]_eqn... + apply topred_ok; auto. split. apply red_paren; auto. exists w; constructor. (* depth *) eapply incontext_ok; eauto. induction al; simpl; intros. (* nil *) - congruence. + split; intros. tauto. simpl; congruence. (* cons *) eapply incontext2_list_ok'; eauto. Qed. - Lemma step_exprlist_val_list: - forall m al, is_val_list al <> None -> step_exprlist al m = Some nil. + forall m al, is_val_list al <> None -> step_exprlist al m = nil. Proof. induction al; simpl; intros. auto. @@ -682,8 +1454,7 @@ Proof. rewrite IHal. auto. congruence. Qed. -(** Completeness, part 1: if [step_expr] returns [Some ll], - then [ll] contains all possible reducts. *) +(** Completeness part 1: [step_expr] contains all possible non-error reducts. *) Lemma lred_topred: forall l1 m1 l2 m2, @@ -704,46 +1475,35 @@ Proof. Qed. Lemma rred_topred: - forall r1 m1 r2 m2, - rred r1 m1 r2 m2 -> - step_expr RV r1 m1 = topred (Rred r2 m2). + forall w' r1 m1 t r2 m2, + rred ge r1 m1 t r2 m2 -> possible_trace w t w' -> + step_expr RV r1 m1 = topred (Rred r2 m2 t). Proof. - induction 1; simpl. + induction 1; simpl; intros. (* valof *) - rewrite dec_eq_true; auto. rewrite H; auto. + rewrite dec_eq_true; auto. rewrite (do_deref_loc_complete _ _ _ _ _ _ _ _ H H0). auto. (* addrof *) - auto. + inv H. auto. (* unop *) - rewrite H; auto. + inv H0. rewrite H; auto. (* binop *) - rewrite H; auto. + inv H0. rewrite H; auto. (* cast *) - rewrite H; auto. + inv H0. rewrite H; auto. (* condition *) - rewrite H; auto. + inv H0. rewrite H; auto. (* sizeof *) - auto. + inv H. auto. (* assign *) - rewrite dec_eq_true; auto. rewrite H; rewrite H0; auto. + rewrite dec_eq_true; auto. rewrite H. rewrite (do_assign_loc_complete _ _ _ _ _ _ _ _ _ H0 H1). auto. (* assignop *) - rewrite dec_eq_true; auto. rewrite H; rewrite H0; rewrite H1; rewrite H2; auto. + rewrite dec_eq_true; auto. rewrite (do_deref_loc_complete _ _ _ _ _ _ _ _ H H0). auto. (* postincr *) - rewrite dec_eq_true; auto. rewrite H; rewrite H0; rewrite H1; rewrite H2; auto. + rewrite dec_eq_true; auto. subst. rewrite (do_deref_loc_complete _ _ _ _ _ _ _ _ H H1). auto. (* comma *) - rewrite H; rewrite dec_eq_true; auto. + inv H0. rewrite dec_eq_true; auto. (* paren *) - rewrite H; auto. -Qed. - -Lemma sem_cast_arguments_complete: - forall al tyl vl, - cast_arguments al tyl vl -> - exists vtl, is_val_list al = Some vtl /\ sem_cast_arguments vtl tyl = Some vl. -Proof. - induction 1. - exists (@nil (val * type)); auto. - destruct IHcast_arguments as [vtl [A B]]. - exists ((v, ty) :: vtl); simpl. rewrite A; rewrite B; rewrite H. auto. + inv H0. rewrite H; auto. Qed. Lemma callred_topred: @@ -757,12 +1517,7 @@ Proof. Qed. Definition reducts_incl {A B: Type} (C: A -> B) (res1: reducts A) (res2: reducts B) : Prop := - match res1, res2 with - | Some ll1, Some ll2 => - forall C1 rd, In (C1, rd) ll1 -> In ((fun x => C(C1 x)), rd) ll2 - | None, Some ll2 => False - | _, None => True - end. + forall C1 rd, In (C1, rd) res1 -> In ((fun x => C(C1 x)), rd) res2. Lemma reducts_incl_trans: forall (A1 A2: Type) (C: A1 -> A2) res1 res2, reducts_incl C res1 res2 -> @@ -770,14 +1525,14 @@ Lemma reducts_incl_trans: reducts_incl C' res2 res3 -> reducts_incl (fun x => C'(C x)) res1 res3. Proof. - unfold reducts_incl; intros. destruct res1; destruct res2; destruct res3; auto. contradiction. + unfold reducts_incl; intros. auto. Qed. Lemma reducts_incl_nil: forall (A B: Type) (C: A -> B) res, - reducts_incl C (Some nil) res. + reducts_incl C nil res. Proof. - intros; red. destruct res; auto. intros; contradiction. + intros; red. intros; contradiction. Qed. Lemma reducts_incl_val: @@ -805,29 +1560,29 @@ Lemma reducts_incl_incontext: forall (A B: Type) (C: A -> B) res, reducts_incl C res (incontext C res). Proof. - intros; unfold reducts_incl. destruct res; simpl; auto. - intros. set (f := fun z : (expr -> A) * reduction => (fun x : expr => C (fst z x), snd z)). - change (In (f (C1, rd)) (map f l)). apply in_map. auto. + unfold reducts_incl, incontext. intros. + set (f := fun z : (expr -> A) * reduction => (fun x : expr => C (fst z x), snd z)). + change (In (f (C1, rd)) (map f res)). apply in_map. auto. Qed. Lemma reducts_incl_incontext2_left: forall (A1 A2 B: Type) (C1: A1 -> B) res1 (C2: A2 -> B) res2, reducts_incl C1 res1 (incontext2 C1 res1 C2 res2). Proof. - intros. destruct res1; simpl; auto. destruct res2; auto. - intros. rewrite in_app_iff. left. + unfold reducts_incl, incontext2, incontext. intros. + rewrite in_app_iff. left. set (f := fun z : (expr -> A1) * reduction => (fun x : expr => C1 (fst z x), snd z)). - change (In (f (C0, rd)) (map f l)). apply in_map; auto. + change (In (f (C0, rd)) (map f res1)). apply in_map; auto. Qed. Lemma reducts_incl_incontext2_right: forall (A1 A2 B: Type) (C1: A1 -> B) res1 (C2: A2 -> B) res2, reducts_incl C2 res2 (incontext2 C1 res1 C2 res2). Proof. - intros. destruct res1; destruct res2; simpl; auto. - intros. rewrite in_app_iff. right. + unfold reducts_incl, incontext2, incontext. intros. + rewrite in_app_iff. right. set (f := fun z : (expr -> A2) * reduction => (fun x : expr => C2 (fst z x), snd z)). - change (In (f (C0, rd)) (map f l0)). apply in_map; auto. + change (In (f (C0, rd)) (map f res2)). apply in_map; auto. Qed. Hint Resolve reducts_incl_val reducts_incl_loc reducts_incl_listval @@ -849,7 +1604,7 @@ Proof. destruct (is_val (C a)) as [[v ty']|]_eqn; eauto. (* field *) eapply reducts_incl_trans with (C' := fun x => Efield x f ty); eauto. - destruct (is_loc (C a)) as [[[b ofs] ty']|]_eqn; eauto. + destruct (is_val (C a)) as [[v ty']|]_eqn; eauto. (* valof *) eapply reducts_incl_trans with (C' := fun x => Evalof x ty); eauto. destruct (is_loc (C a)) as [[[b ofs] ty']|]_eqn; eauto. @@ -912,625 +1667,83 @@ Proof. apply step_exprlist_context; eauto. eauto. Qed. -(** Completeness, part 2: given a safe expression, [step_expr] does not return [None]. *) +(** Completeness part 2: if we can reduce to [Stuckstate], [step_expr] + contains at least one [Stuckred] reduction. *) -Lemma topred_none: - forall rd, topred rd <> None. +Lemma not_stuckred_imm_safe: + forall m a k, + (forall C, ~In (C, Stuckred) (step_expr k a m)) -> imm_safe_t k a m. Proof. - intros; unfold topred; congruence. + intros. generalize (step_expr_sound a k m). intros [A B]. + destruct (step_expr k a m) as [|[C rd] res]_eqn. + specialize (B (refl_equal _)). destruct k. + destruct a; simpl in B; try congruence. constructor. + destruct a; simpl in B; try congruence. constructor. + assert (NOTSTUCK: rd <> Stuckred). + red; intros. elim (H C); subst rd; auto with coqlib. + exploit A. eauto with coqlib. intros [a' [k' [P [Q R]]]]. + destruct k'; destruct rd; simpl in R; intuition. + subst a. eapply imm_safe_t_lred; eauto. + subst a. destruct H1 as [w' PT]. eapply imm_safe_t_rred; eauto. + subst. eapply imm_safe_t_callred; eauto. Qed. -Lemma incontext_none: - forall (A B: Type) (C: A -> B) rds, - rds <> None -> incontext C rds <> None. -Proof. - unfold incontext; intros. destruct rds; congruence. -Qed. - -Lemma incontext2_none: - forall (A1 A2 B: Type) (C1: A1 -> B) rds1 (C2: A2 -> B) rds2, - rds1 <> None -> rds2 <> None -> incontext2 C1 rds1 C2 rds2 <> None. -Proof. - unfold incontext2; intros. destruct rds1; destruct rds2; congruence. -Qed. - -Lemma safe_expr_kind: - forall k C a m, - context k RV C -> - not_stuck ge e (C a) m -> - k = Cstrategy.expr_kind a. -Proof. - intros. - symmetry. eapply Cstrategy.not_imm_stuck_kind; eauto. -Qed. - -Lemma safe_inversion: - forall k C a m, +Lemma not_imm_safe_stuck_red: + forall m a k C, context k RV C -> - not_stuck ge e (C a) m -> - match a with - | Eloc _ _ _ => True - | Eval _ _ => True - | _ => Cstrategy.invert_expr_prop ge e a m - end. + ~imm_safe_t k a m -> + exists C', In (C', Stuckred) (step_expr RV (C a) m). Proof. - intros. eapply Cstrategy.not_imm_stuck_inv; eauto. -Qed. - -Lemma is_val_list_all_values: - forall al vtl, is_val_list al = Some vtl -> Cstrategy.exprlist_all_values al. -Proof. - induction al; simpl; intros. auto. - destruct (is_val r1) as [[v ty]|]_eqn; try discriminate. - destruct (is_val_list al) as [vtl'|]_eqn; try discriminate. - rewrite (is_val_inv _ _ _ Heqo). eauto. -Qed. - -Theorem step_expr_defined: - forall a k m C, - context k RV C -> - not_stuck ge e (C a) m -> - step_expr k a m <> None -with step_exprlist_defined: - forall al m C, - Cstrategy.contextlist' C -> - not_stuck ge e (C al) m -> - step_exprlist al m <> None. -Proof. - induction a; intros k m C CTX NS; - rewrite (safe_expr_kind _ _ _ _ CTX NS); - rewrite (safe_expr_kind _ _ _ _ CTX NS) in CTX; - simpl in *; - generalize (safe_inversion _ _ _ _ CTX NS); intro INV. -(* val *) - congruence. -(* var *) - red in INV. destruct INV as [b [P | [P [Q R]]]]. - rewrite P; rewrite dec_eq_true. apply topred_none. - rewrite P; rewrite Q; rewrite R; rewrite dec_eq_true. apply topred_none. -(* field *) - destruct (is_loc a) as [[[b ofs] ty']|]_eqn. - rewrite (is_loc_inv _ _ _ _ Heqo) in INV. red in INV. - destruct ty'; try contradiction. destruct INV as [delta EQ]. rewrite EQ. apply topred_none. - apply topred_none. - apply incontext_none. apply IHa with (C := fun x => C(Efield x f ty)); eauto. -(* valof *) - destruct (is_loc a) as [[[b ofs] ty']|]_eqn. - rewrite (is_loc_inv _ _ _ _ Heqo) in INV. red in INV. destruct INV as [EQ [v LD]]. subst. - rewrite dec_eq_true; rewrite LD; apply topred_none. - apply incontext_none. apply IHa with (C := fun x => C(Evalof x ty)); eauto. -(* deref *) - destruct (is_val a) as [[v ty']|]_eqn. - rewrite (is_val_inv _ _ _ Heqo) in INV. red in INV. destruct INV as [b [ofs EQ]]. subst. - apply topred_none. - apply incontext_none. apply IHa with (C := fun x => C(Ederef x ty)); eauto. -(* addrof *) - destruct (is_loc a) as [[[b ofs] ty']|]_eqn. - apply topred_none. - apply incontext_none. apply IHa with (C := fun x => C(Eaddrof x ty)); eauto. -(* unop *) - destruct (is_val a) as [[v1 ty1]|]_eqn. - rewrite (is_val_inv _ _ _ Heqo) in INV. red in INV. destruct INV as [v EQ]. - rewrite EQ; apply topred_none. - apply incontext_none. apply IHa with (C := fun x => C(Eunop op x ty)); eauto. -(* binop *) - destruct (is_val a1) as [[v1 ty1]|]_eqn. - destruct (is_val a2) as [[v2 ty2]|]_eqn. - rewrite (is_val_inv _ _ _ Heqo) in INV. - rewrite (is_val_inv _ _ _ Heqo0) in INV. red in INV. destruct INV as [v EQ]. - rewrite EQ; apply topred_none. - apply incontext2_none. apply IHa1 with (C := fun x => C(Ebinop op x a2 ty)); eauto. apply IHa2 with (C := fun x => C(Ebinop op a1 x ty)); eauto. - apply incontext2_none. apply IHa1 with (C := fun x => C(Ebinop op x a2 ty)); eauto. apply IHa2 with (C := fun x => C(Ebinop op a1 x ty)); eauto. -(* cast *) - destruct (is_val a) as [[v1 ty1]|]_eqn. - rewrite (is_val_inv _ _ _ Heqo) in INV. red in INV. destruct INV as [v EQ]. - rewrite EQ; apply topred_none. - apply incontext_none. apply IHa with (C := fun x => C(Ecast x ty)); eauto. -(* condition *) - destruct (is_val a1) as [[v1 ty1]|]_eqn. - rewrite (is_val_inv _ _ _ Heqo) in INV. red in INV. destruct INV as [v EQ]. - rewrite EQ; apply topred_none. - apply incontext_none. apply IHa1 with (C := fun x => C(Econdition x a2 a3 ty)); eauto. -(* sizeof *) - apply topred_none. -(* assign *) - destruct (is_loc a1) as [[[b ofs] ty1]|]_eqn. - destruct (is_val a2) as [[v2 ty2]|]_eqn. - rewrite (is_loc_inv _ _ _ _ Heqo) in INV. - rewrite (is_val_inv _ _ _ Heqo0) in INV. red in INV. - destruct INV as [v [m' [P [Q R]]]]. - subst. rewrite dec_eq_true; rewrite Q; rewrite R; apply topred_none. - apply incontext2_none. apply IHa1 with (C := fun x => C(Eassign x a2 ty)); eauto. apply IHa2 with (C := fun x => C(Eassign a1 x ty)); eauto. - apply incontext2_none. apply IHa1 with (C := fun x => C(Eassign x a2 ty)); eauto. apply IHa2 with (C := fun x => C(Eassign a1 x ty)); eauto. -(* assignop *) - destruct (is_loc a1) as [[[b ofs] ty1]|]_eqn. - destruct (is_val a2) as [[v2 ty2]|]_eqn. - rewrite (is_loc_inv _ _ _ _ Heqo) in INV. - rewrite (is_val_inv _ _ _ Heqo0) in INV. red in INV. - destruct INV as [v1 [v [v' [m' [P [Q [R [S T]]]]]]]]. - subst. rewrite dec_eq_true; rewrite Q; rewrite R; rewrite S; rewrite T; apply topred_none. - apply incontext2_none. apply IHa1 with (C := fun x => C(Eassignop op x a2 tyres ty)); eauto. apply IHa2 with (C := fun x => C(Eassignop op a1 x tyres ty)); eauto. - apply incontext2_none. apply IHa1 with (C := fun x => C(Eassignop op x a2 tyres ty)); eauto. apply IHa2 with (C := fun x => C(Eassignop op a1 x tyres ty)); eauto. -(* postincr *) - destruct (is_loc a) as [[[b ofs] ty1]|]_eqn. - rewrite (is_loc_inv _ _ _ _ Heqo) in INV. red in INV. - destruct INV as [v1 [v2 [v3 [m' [P [Q [R [S T]]]]]]]]. - subst. rewrite dec_eq_true; rewrite Q; rewrite R; rewrite S; rewrite T; apply topred_none. - apply incontext_none. apply IHa with (C := fun x => C(Epostincr id x ty)); eauto. -(* comma *) - destruct (is_val a1) as [[v1 ty1]|]_eqn. - rewrite (is_val_inv _ _ _ Heqo) in INV. red in INV. rewrite INV. - rewrite dec_eq_true; apply topred_none. - apply incontext_none. apply IHa1 with (C := fun x => C(Ecomma x a2 ty)); eauto. -(* call *) - destruct (is_val a) as [[vf tyf]|]_eqn. - destruct (is_val_list rargs) as [vtl|]_eqn. - rewrite (is_val_inv _ _ _ Heqo) in INV. red in INV. - destruct INV as [tyargs [tyres [fd [vl [P [Q [R S]]]]]]]. - eapply is_val_list_all_values; eauto. - rewrite P; rewrite Q. - exploit sem_cast_arguments_complete; eauto. intros [vtl' [U V]]. - assert (vtl' = vtl) by congruence. subst. rewrite V. rewrite S. rewrite dec_eq_true. - apply topred_none. - apply incontext2_none. apply IHa with (C := fun x => C(Ecall x rargs ty)); eauto. - apply step_exprlist_defined with (C := fun x => C(Ecall a x ty)); auto. - apply Cstrategy.contextlist'_intro with (rl0 := Enil). auto. - apply incontext2_none. apply IHa with (C := fun x => C(Ecall x rargs ty)); eauto. - apply step_exprlist_defined with (C := fun x => C(Ecall a x ty)); auto. - apply Cstrategy.contextlist'_intro with (rl0 := Enil). auto. -(* loc *) - congruence. -(* paren *) - destruct (is_val a) as [[v1 ty1]|]_eqn. - rewrite (is_val_inv _ _ _ Heqo) in INV. red in INV. destruct INV as [v EQ]. - rewrite EQ; apply topred_none. - apply incontext_none. apply IHa with (C := fun x => C(Eparen x ty)); eauto. - - induction al; intros; simpl. -(* nil *) - congruence. -(* cons *) - apply incontext2_none. - apply step_expr_defined with (C := fun x => C(Econs x al)); eauto. - apply Cstrategy.contextlist'_head; auto. - apply IHal with (C := fun x => C(Econs r1 x)); auto. - apply Cstrategy.contextlist'_tail; auto. + intros. + assert (exists C', In (C', Stuckred) (step_expr k a m)). + destruct (classic (exists C', In (C', Stuckred) (step_expr k a m))); auto. + elim H0. apply not_stuckred_imm_safe. apply not_ex_all_not. auto. + destruct H1 as [C' IN]. + specialize (step_expr_context _ _ _ H a m). unfold reducts_incl. + intro. + exists (fun x => (C (C' x))). apply H1; auto. Qed. -(** Connections between [not_stuck] and [step_expr]. *) +(** Connections between [imm_safe_t] and [imm_safe] *) -Lemma step_expr_not_imm_stuck: +Lemma imm_safe_imm_safe_t: forall k a m, - step_expr k a m <> None -> - not_imm_stuck ge e k a m. -Proof. - intros. generalize (step_expr_sound a k m). unfold reducts_ok. - destruct (step_expr k a m) as [ll|]. destruct ll. -(* value or location *) - destruct k; destruct a; simpl; intros; try congruence. - apply not_stuck_loc. - apply Csem.not_stuck_val. -(* reducible *) - intros R. destruct p as [C1 rd1]. destruct (R C1 rd1) as [P [a' [U V]]]; auto with coqlib. - subst a. red in V. destruct rd1. - eapply not_stuck_lred; eauto. - eapply not_stuck_rred; eauto. - destruct V. subst m'. eapply not_stuck_callred; eauto. -(* stuck *) - congruence. -Qed. - -Lemma step_expr_not_stuck: - forall a m, - step_expr RV a m <> None -> - not_stuck ge e a m. -Proof. - intros; red; intros. subst a. - apply step_expr_not_imm_stuck. - generalize (step_expr_context _ _ C H0 e' m). unfold reducts_incl. - destruct (step_expr k e' m). congruence. - destruct (step_expr RV (C e') m). tauto. congruence. -Qed. - -Lemma not_stuck_step_expr: - forall a m, - not_stuck ge e a m -> - step_expr RV a m <> None. -Proof. - intros. apply step_expr_defined with (C := fun x => x); auto. -Qed. - -End EXPRS. - -(** * External functions and events. *) - -Section EVENTS. - -Variable F V: Type. -Variable genv: Genv.t F V. - -Definition eventval_of_val (v: val) (t: typ) : option eventval := - match v, t with - | Vint i, AST.Tint => Some (EVint i) - | Vfloat f, AST.Tfloat => Some (EVfloat f) - | Vptr b ofs, AST.Tint => do id <- Genv.invert_symbol genv b; Some (EVptr_global id ofs) - | _, _ => None - end. - -Fixpoint list_eventval_of_val (vl: list val) (tl: list typ) : option (list eventval) := - match vl, tl with - | nil, nil => Some nil - | v1::vl, t1::tl => - do ev1 <- eventval_of_val v1 t1; - do evl <- list_eventval_of_val vl tl; - Some (ev1 :: evl) - | _, _ => None - end. - -Definition val_of_eventval (ev: eventval) (t: typ) : option val := - match ev, t with - | EVint i, AST.Tint => Some (Vint i) - | EVfloat f, AST.Tfloat => Some (Vfloat f) - | EVptr_global id ofs, AST.Tint => do b <- Genv.find_symbol genv id; Some (Vptr b ofs) - | _, _ => None - end. - -Lemma eventval_of_val_sound: - forall v t ev, eventval_of_val v t = Some ev -> eventval_match genv ev t v. -Proof. - intros. destruct v; destruct t; simpl in H; inv H. - constructor. - constructor. - destruct (Genv.invert_symbol genv b) as [id|]_eqn; inv H1. - constructor. apply Genv.invert_find_symbol; auto. -Qed. - -Lemma eventval_of_val_complete: - forall ev t v, eventval_match genv ev t v -> eventval_of_val v t = Some ev. + imm_safe ge e k a m -> + imm_safe_t k a m \/ + exists C, exists a1, exists t, exists a1', exists m', + context RV k C /\ a = C a1 /\ rred ge a1 m t a1' m' /\ forall w', ~possible_trace w t w'. Proof. - induction 1; simpl; auto. - rewrite (Genv.find_invert_symbol _ _ H). auto. -Qed. - -Lemma list_eventval_of_val_sound: - forall vl tl evl, list_eventval_of_val vl tl = Some evl -> eventval_list_match genv evl tl vl. -Proof with try discriminate. - induction vl; destruct tl; simpl; intros; inv H. - constructor. - destruct (eventval_of_val a t) as [ev1|]_eqn... - destruct (list_eventval_of_val vl tl) as [evl'|]_eqn... - inv H1. constructor. apply eventval_of_val_sound; auto. eauto. -Qed. - -Lemma list_eventval_of_val_complete: - forall evl tl vl, eventval_list_match genv evl tl vl -> list_eventval_of_val vl tl = Some evl. -Proof. - induction 1; simpl. auto. - rewrite (eventval_of_val_complete _ _ _ H). rewrite IHeventval_list_match. auto. -Qed. - -Lemma val_of_eventval_sound: - forall ev t v, val_of_eventval ev t = Some v -> eventval_match genv ev t v. -Proof. - intros. destruct ev; destruct t; simpl in H; inv H. - constructor. - constructor. - destruct (Genv.find_symbol genv i) as [b|]_eqn; inv H1. - constructor. auto. -Qed. - -Lemma val_of_eventval_complete: - forall ev t v, eventval_match genv ev t v -> val_of_eventval ev t = Some v. -Proof. - induction 1; simpl; auto. rewrite H; auto. -Qed. - -(** System calls and library functions *) - -Definition do_ef_external (name: ident) (sg: signature) - (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := - do args <- list_eventval_of_val vargs (sig_args sg); - match nextworld_io w name args with - | None => None - | Some(res, w') => - do vres <- val_of_eventval res (proj_sig_res sg); - Some(w', Event_syscall name args res :: E0, vres, m) - end. - -Definition do_ef_volatile_load (chunk: memory_chunk) - (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := - match vargs with - | Vptr b ofs :: nil => - if block_is_volatile genv b then - do id <- Genv.invert_symbol genv b; - match nextworld_vload w chunk id ofs with - | None => None - | Some(res, w') => - do vres <- val_of_eventval res (type_of_chunk chunk); - Some(w', Event_vload chunk id ofs res :: nil, Val.load_result chunk vres, m) - end - else - do v <- Mem.load chunk m b (Int.unsigned ofs); - Some(w, E0, v, m) - | _ => None - end. - -Definition do_ef_volatile_store (chunk: memory_chunk) - (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := - match vargs with - | Vptr b ofs :: v :: nil => - if block_is_volatile genv b then - do id <- Genv.invert_symbol genv b; - do ev <- eventval_of_val v (type_of_chunk chunk); - do w' <- nextworld_vstore w chunk id ofs ev; - Some(w', Event_vstore chunk id ofs ev :: nil, Vundef, m) - else - do m' <- Mem.store chunk m b (Int.unsigned ofs) v; - Some(w, E0, Vundef, m') - | _ => None - end. - -Definition do_ef_volatile_load_global (chunk: memory_chunk) (id: ident) (ofs: int) - (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := - match Genv.find_symbol genv id with - | Some b => do_ef_volatile_load chunk w (Vptr b ofs :: vargs) m - | None => None - end. - -Definition do_ef_volatile_store_global (chunk: memory_chunk) (id: ident) (ofs: int) - (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := - match Genv.find_symbol genv id with - | Some b => do_ef_volatile_store chunk w (Vptr b ofs :: vargs) m - | None => None - end. - -Definition do_ef_malloc - (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := - match vargs with - | Vint n :: nil => - let (m', b) := Mem.alloc m (-4) (Int.unsigned n) in - do m'' <- Mem.store Mint32 m' b (-4) (Vint n); - Some(w, E0, Vptr b Int.zero, m'') - | _ => None - end. - -Definition do_ef_free - (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := - match vargs with - | Vptr b lo :: nil => - do vsz <- Mem.load Mint32 m b (Int.unsigned lo - 4); - match vsz with - | Vint sz => - check (zlt 0 (Int.unsigned sz)); - do m' <- Mem.free m b (Int.unsigned lo - 4) (Int.unsigned lo + Int.unsigned sz); - Some(w, E0, Vundef, m') - | _ => None - end - | _ => None - end. - -Definition memcpy_args_ok - (sz al: Z) (bdst: block) (odst: Z) (bsrc: block) (osrc: Z) : Prop := - (al = 1 \/ al = 2 \/ al = 4) - /\ sz > 0 - /\ (al | sz) /\ (al | osrc) /\ (al | odst) - /\ (bsrc <> bdst \/ osrc = odst \/ osrc + sz <= odst \/ odst + sz <= osrc). - -Remark memcpy_check_args: - forall sz al bdst odst bsrc osrc, - {memcpy_args_ok sz al bdst odst bsrc osrc} + {~memcpy_args_ok sz al bdst odst bsrc osrc}. -Proof with try (right; intuition omega). - intros. - assert (X: {al = 1 \/ al = 2 \/ al = 4} + {~(al = 1 \/ al = 2 \/ al = 4)}). - destruct (zeq al 1); auto. destruct (zeq al 2); auto. destruct (zeq al 4); auto... - unfold memcpy_args_ok. destruct X... - assert (al > 0) by (intuition omega). - destruct (zlt 0 sz)... - destruct (Zdivide_dec al sz); auto... - destruct (Zdivide_dec al osrc); auto... - destruct (Zdivide_dec al odst); auto... - assert (Y: {bsrc <> bdst \/ osrc = odst \/ osrc + sz <= odst \/ odst + sz <= osrc} - +{~(bsrc <> bdst \/ osrc = odst \/ osrc + sz <= odst \/ odst + sz <= osrc)}). - destruct (eq_block bsrc bdst); auto. - destruct (zeq osrc odst); auto. - destruct (zle (osrc + sz) odst); auto. - destruct (zle (odst + sz) osrc); auto. - right; intuition omega. - destruct Y... left; intuition omega. + intros. inv H. + left. apply imm_safe_t_val. + left. apply imm_safe_t_loc. + left. eapply imm_safe_t_lred; eauto. + destruct (classic (exists w', possible_trace w t w')) as [[w' A] | A]. + left. eapply imm_safe_t_rred; eauto. + right. exists C; exists e0; exists t; exists e'; exists m'; intuition. apply A; exists w'; auto. + left. eapply imm_safe_t_callred; eauto. Qed. -Definition do_ef_memcpy (sz al: Z) - (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := - match vargs with - | Vptr bdst odst :: Vptr bsrc osrc :: nil => - if memcpy_check_args sz al bdst (Int.unsigned odst) bsrc (Int.unsigned osrc) then - do bytes <- Mem.loadbytes m bsrc (Int.unsigned osrc) sz; - do m' <- Mem.storebytes m bdst (Int.unsigned odst) bytes; - Some(w, E0, Vundef, m') - else None - | _ => None - end. - -Definition do_ef_annot (text: ident) (targs: list typ) - (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := - do args <- list_eventval_of_val vargs targs; - Some(w, Event_annot text args :: E0, Vundef, m). - -Definition do_ef_annot_val (text: ident) (targ: typ) - (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) := - match vargs with - | varg :: nil => - do arg <- eventval_of_val varg targ; - Some(w, Event_annot text (arg :: nil) :: E0, varg, m) - | _ => None - end. - -Definition do_external (ef: external_function): - world -> list val -> mem -> option (world * trace * val * mem) := - match ef with - | EF_external name sg => do_ef_external name sg - | EF_builtin name sg => do_ef_external name sg - | EF_vload chunk => do_ef_volatile_load chunk - | EF_vstore chunk => do_ef_volatile_store chunk - | EF_vload_global chunk id ofs => do_ef_volatile_load_global chunk id ofs - | EF_vstore_global chunk id ofs => do_ef_volatile_store_global chunk id ofs - | EF_malloc => do_ef_malloc - | EF_free => do_ef_free - | EF_memcpy sz al => do_ef_memcpy sz al - | EF_annot text targs => do_ef_annot text targs - | EF_annot_val text targ => do_ef_annot_val text targ - end. - -Ltac mydestr := - match goal with - | [ |- None = Some _ -> _ ] => intro X; discriminate - | [ |- Some _ = Some _ -> _ ] => intro X; inv X - | [ |- match ?x with Some _ => _ | None => _ end = Some _ -> _ ] => destruct x as []_eqn; mydestr - | [ |- match ?x with true => _ | false => _ end = Some _ -> _ ] => destruct x as []_eqn; mydestr - | [ |- match ?x with left _ => _ | right _ => _ end = Some _ -> _ ] => destruct x; mydestr - | _ => idtac - end. - -Lemma do_ef_external_sound: - forall ef w vargs m w' t vres m', - do_external ef w vargs m = Some(w', t, vres, m') -> - external_call ef genv vargs m t vres m' /\ possible_trace w t w'. -Proof with try congruence. - intros until m'. - assert (IO: forall name sg, - do_ef_external name sg w vargs m = Some(w', t, vres, m') -> - extcall_io_sem name sg genv vargs m t vres m' /\ possible_trace w t w'). - intros until sg. unfold do_ef_external. mydestr. destruct p as [res w'']; mydestr. - split. econstructor. apply list_eventval_of_val_sound; auto. - apply val_of_eventval_sound; auto. - econstructor. constructor; eauto. constructor. - - assert (VLOAD: forall chunk vargs, - do_ef_volatile_load chunk w vargs m = Some (w', t, vres, m') -> - volatile_load_sem chunk genv vargs m t vres m' /\ possible_trace w t w'). - intros chunk vargs'. - unfold do_ef_volatile_load. destruct vargs'... destruct v... destruct vargs'... - mydestr. destruct p as [res w'']; mydestr. - split. constructor. apply Genv.invert_find_symbol; auto. auto. - apply val_of_eventval_sound; auto. - econstructor. constructor; eauto. constructor. - split. constructor; auto. constructor. +(** A state can "crash the world" if it can make an observable transition + whose trace is not accepted by the external world. *) - assert (VSTORE: forall chunk vargs, - do_ef_volatile_store chunk w vargs m = Some (w', t, vres, m') -> - volatile_store_sem chunk genv vargs m t vres m' /\ possible_trace w t w'). - intros chunk vargs'. - unfold do_ef_volatile_store. destruct vargs'... destruct v... destruct vargs'... destruct vargs'... - mydestr. - split. constructor. apply Genv.invert_find_symbol; auto. auto. - apply eventval_of_val_sound; auto. - econstructor. constructor; eauto. constructor. - split. constructor; auto. constructor. +Definition can_crash_world (w: world) (S: state) : Prop := + exists t, exists S', Csem.step ge S t S' /\ forall w', ~possible_trace w t w'. - destruct ef; simpl. -(* EF_external *) - auto. -(* EF_builtin *) - auto. -(* EF_vload *) - auto. -(* EF_vstore *) - auto. -(* EF_vload_global *) - rewrite volatile_load_global_charact. - unfold do_ef_volatile_load_global. destruct (Genv.find_symbol genv)... - intros. exploit VLOAD; eauto. intros [A B]. split; auto. exists b; auto. -(* EF_vstore_global *) - rewrite volatile_store_global_charact. - unfold do_ef_volatile_store_global. destruct (Genv.find_symbol genv)... - intros. exploit VSTORE; eauto. intros [A B]. split; auto. exists b; auto. -(* EF_malloc *) - unfold do_ef_malloc. destruct vargs... destruct v... destruct vargs... - destruct (Mem.alloc m (-4) (Int.unsigned i)) as [m1 b]_eqn. mydestr. - split. econstructor; eauto. constructor. -(* EF_free *) - unfold do_ef_free. destruct vargs... destruct v... destruct vargs... - mydestr. destruct v... mydestr. - split. econstructor; eauto. omega. constructor. -(* EF_memcpy *) - unfold do_ef_memcpy. destruct vargs... destruct v... destruct vargs... - destruct v... destruct vargs... mydestr. red in m0. - split. econstructor; eauto; tauto. constructor. -(* EF_annot *) - unfold do_ef_annot. mydestr. - split. constructor. apply list_eventval_of_val_sound; auto. - econstructor. constructor; eauto. constructor. -(* EF_annot_val *) - unfold do_ef_annot_val. destruct vargs... destruct vargs... mydestr. - split. constructor. apply eventval_of_val_sound; auto. - econstructor. constructor; eauto. constructor. -Qed. - -Lemma do_ef_external_complete: - forall ef w vargs m w' t vres m', - external_call ef genv vargs m t vres m' -> possible_trace w t w' -> - do_external ef w vargs m = Some(w', t, vres, m'). +Theorem not_imm_safe_t: + forall K C a m f k, + context K RV C -> + ~imm_safe_t K a m -> + Csem.step ge (ExprState f (C a) k e m) E0 Stuckstate \/ can_crash_world w (ExprState f (C a) k e m). Proof. - intros. - assert (IO: forall name sg, - extcall_io_sem name sg genv vargs m t vres m' -> - do_ef_external name sg w vargs m = Some (w', t, vres, m')). - intros. inv H1. inv H0. inv H8. inv H6. - unfold do_ef_external. rewrite (list_eventval_of_val_complete _ _ _ H2). rewrite H8. - rewrite (val_of_eventval_complete _ _ _ H3). auto. - - assert (VLOAD: forall chunk vargs, - volatile_load_sem chunk genv vargs m t vres m' -> - do_ef_volatile_load chunk w vargs m = Some (w', t, vres, m')). - intros. inv H1; unfold do_ef_volatile_load. - inv H0. inv H9. inv H7. - rewrite H3. rewrite (Genv.find_invert_symbol _ _ H2). rewrite H10. - rewrite (val_of_eventval_complete _ _ _ H4). auto. - inv H0. rewrite H2. rewrite H3. auto. - - assert (VSTORE: forall chunk vargs, - volatile_store_sem chunk genv vargs m t vres m' -> - do_ef_volatile_store chunk w vargs m = Some (w', t, vres, m')). - intros. inv H1; unfold do_ef_volatile_store. - inv H0. inv H9. inv H7. - rewrite H3. rewrite (Genv.find_invert_symbol _ _ H2). - rewrite (eventval_of_val_complete _ _ _ H4). rewrite H10. auto. - inv H0. rewrite H2. rewrite H3. auto. - - destruct ef; simpl in *. -(* EF_external *) - auto. -(* EF_builtin *) - auto. -(* EF_vload *) - auto. -(* EF_vstore *) - auto. -(* EF_vload_global *) - rewrite volatile_load_global_charact in H. destruct H as [b [P Q]]. - unfold do_ef_volatile_load_global. rewrite P. auto. -(* EF_vstore *) - rewrite volatile_store_global_charact in H. destruct H as [b [P Q]]. - unfold do_ef_volatile_store_global. rewrite P. auto. -(* EF_malloc *) - inv H; unfold do_ef_malloc. - inv H0. rewrite H1. rewrite H2. auto. -(* EF_free *) - inv H; unfold do_ef_free. - inv H0. rewrite H1. rewrite zlt_true. rewrite H3. auto. omega. -(* EF_memcpy *) - inv H; unfold do_ef_memcpy. - inv H0. rewrite pred_dec_true. rewrite H7; rewrite H8; auto. - red. tauto. -(* EF_annot *) - inv H; unfold do_ef_annot. inv H0. inv H6. inv H4. - rewrite (list_eventval_of_val_complete _ _ _ H1). auto. -(* EF_annot_val *) - inv H; unfold do_ef_annot_val. inv H0. inv H6. inv H4. - rewrite (eventval_of_val_complete _ _ _ H1). auto. + intros. destruct (classic (imm_safe ge e K a m)). + exploit imm_safe_imm_safe_t; eauto. + intros [A | [C1 [a1 [t [a1' [m' [A [B [D E]]]]]]]]]. contradiction. + right. red. exists t; econstructor; split; auto. + left. rewrite B. eapply step_rred with (C := fun x => C(C1 x)). eauto. eauto. + left. left. eapply step_stuck; eauto. Qed. -End EVENTS. +End EXPRS. (** * Transitions over states. *) @@ -1560,7 +1773,7 @@ Proof. rewrite H; rewrite IHalloc_variables; auto. Qed. -Function sem_bind_parameters (e: env) (m: mem) (l: list (ident * type)) (lv: list val) +Function sem_bind_parameters (w: world) (e: env) (m: mem) (l: list (ident * type)) (lv: list val) {struct l} : option mem := match l, lv with | nil, nil => Some m @@ -1568,37 +1781,39 @@ Function sem_bind_parameters (e: env) (m: mem) (l: list (ident * type)) (lv: lis match PTree.get id e with | Some (b, ty') => check (type_eq ty ty'); - do m1 <- store_value_of_type ty m b Int.zero v1; - sem_bind_parameters e m1 params lv + do w', t, m1 <- do_assign_loc w ty m b Int.zero v1; + match t with nil => sem_bind_parameters w e m1 params lv | _ => None end | None => None end | _, _ => None end. -Lemma sem_bind_parameters_sound : forall e m l lv m', - sem_bind_parameters e m l lv = Some m' -> - bind_parameters e m l lv m'. +Lemma sem_bind_parameters_sound : forall w e m l lv m', + sem_bind_parameters w e m l lv = Some m' -> + bind_parameters ge e m l lv m'. Proof. - intros; functional induction (sem_bind_parameters e m l lv); try discriminate. - inversion H; constructor; auto. - econstructor; eauto. + intros; functional induction (sem_bind_parameters w e m l lv); try discriminate. + inversion H; constructor; auto. + exploit do_assign_loc_sound; eauto. intros [A B]. econstructor; eauto. Qed. -Lemma sem_bind_parameters_complete : forall e m l lv m', - bind_parameters e m l lv m' -> - sem_bind_parameters e m l lv = Some m'. +Lemma sem_bind_parameters_complete : forall w e m l lv m', + bind_parameters ge e m l lv m' -> + sem_bind_parameters w e m l lv = Some m'. Proof. induction 1; simpl; auto. - rewrite H. rewrite dec_eq_true. - destruct (store_value_of_type ty m b Int.zero v1); try discriminate. - inv H0; auto. + rewrite H. rewrite dec_eq_true. + assert (possible_trace w E0 w) by constructor. + rewrite (do_assign_loc_complete _ _ _ _ _ _ _ _ _ H0 H2). + simpl. auto. Qed. Definition expr_final_state (f: function) (k: cont) (e: env) (C_rd: (expr -> expr) * reduction) := match snd C_rd with | Lred a m => (E0, ExprState f (fst C_rd a) k e m) - | Rred a m => (E0, ExprState f (fst C_rd a) k e m) + | Rred a m t => (t, ExprState f (fst C_rd a) k e m) | Callred fd vargs ty m => (E0, Callstate fd vargs (Kcall f e (fst C_rd) ty k) m) + | Stuck => (E0, Stuckstate) end. Local Open Scope list_monad_scope. @@ -1637,10 +1852,7 @@ Definition do_step (w: world) (s: state) : list (trace * state) := end | None => - match step_expr e RV a m with - | None => nil - | Some ll => map (expr_final_state f k e) ll - end + map (expr_final_state f k e) (step_expr e w RV a m) end | State f (Sdo x) k e m => ret(ExprState f x (Kdo k) e m) @@ -1674,9 +1886,9 @@ 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') + check type_eq (f.(fn_return)) Tvoid; + do m' <- Mem.free_list m (blocks_of_env e); + ret (Returnstate Vundef k m') | State f (Sswitch x sl) k e m => ret (ExprState f x (Kswitch1 sl k) e m) | State f (Sskip|Sbreak) (Kswitch2 k) e m => ret (State f Sskip k e m) @@ -1692,10 +1904,10 @@ Definition do_step (w: world) (s: state) : list (trace * state) := | Callstate (Internal f) vargs k m => check (list_norepet_dec ident_eq (var_names (fn_params f) ++ var_names (fn_vars f))); let (e,m1) := do_alloc_variables empty_env m (f.(fn_params) ++ f.(fn_vars)) in - do m2 <- sem_bind_parameters e m1 f.(fn_params) vargs; + do m2 <- sem_bind_parameters w e m1 f.(fn_params) vargs; ret (State f f.(fn_body) k e m2) | Callstate (External ef _ _) vargs k m => - match do_external _ _ ge ef w vargs m with + match do_external ef w vargs m with | None => nil | Some(w',t,v,m') => (t, Returnstate v k m') :: nil end @@ -1721,9 +1933,11 @@ Ltac myinv := Hint Extern 3 => exact I. -Lemma do_step_sound: - forall w S t S', In (t, S') (do_step w S) -> Csem.step ge S t S'. -Proof with try (right; econstructor; eauto; fail). +Theorem do_step_sound: + forall w S t S', + In (t, S') (do_step w S) -> + Csem.step ge S t S' \/ (t = E0 /\ S' = Stuckstate /\ can_crash_world w S). +Proof with try (left; right; econstructor; eauto; fail). intros until S'. destruct S; simpl. (* State *) destruct s; myinv... @@ -1742,82 +1956,87 @@ Proof with try (right; econstructor; eauto; fail). destruct k; myinv... destruct v; myinv... (* expression reduces *) - destruct (step_expr e RV r m) as [ll|]_eqn; try contradiction. intros. - exploit list_in_map_inv; eauto. intros [[C rd] [A B]]. - generalize (step_expr_sound e r RV m). unfold reducts_ok. rewrite Heqr0. - destruct ll; try contradiction. intros SOUND. - exploit SOUND; eauto. intros [CTX [a [EQ RD]]]. subst r. - unfold expr_final_state in A. simpl in A. left. - destruct rd; inv A; simpl in RD. - apply step_lred. auto. apply step_expr_not_stuck; congruence. auto. - apply step_rred. auto. apply step_expr_not_stuck; congruence. auto. - destruct RD; subst m'. apply Csem.step_call. auto. apply step_expr_not_stuck; congruence. auto. + intros. exploit list_in_map_inv; eauto. intros [[C rd] [A B]]. + generalize (step_expr_sound e w r RV m). unfold reducts_ok. intros [P Q]. + exploit P; eauto. intros [a' [k' [CTX [EQ RD]]]]. + unfold expr_final_state in A. simpl in A. + destruct k'; destruct rd; inv A; simpl in RD; try contradiction. + (* lred *) + left; left; apply step_lred; auto. + (* stuck lred *) + exploit not_imm_safe_t; eauto. intros [R | R]; eauto. + (* rred *) + destruct RD. left; left; apply step_rred; auto. + (* callred *) + destruct RD; subst m'. left; left; apply step_call; eauto. + (* stuck rred *) + exploit not_imm_safe_t; eauto. intros [R | R]; eauto. (* callstate *) destruct fd; myinv. (* internal *) destruct (do_alloc_variables empty_env m (fn_params f ++ fn_vars f)) as [e m1]_eqn. - myinv. right; apply step_internal_function with m1. auto. + myinv. left; right; apply step_internal_function with m1. auto. change e with (fst (e,m1)). change m1 with (snd (e,m1)) at 2. rewrite <- Heqp. - apply do_alloc_variables_sound. apply sem_bind_parameters_sound; auto. + apply do_alloc_variables_sound. eapply sem_bind_parameters_sound; eauto. (* external *) - destruct p as [[[w' tr] v] m']. myinv. right; constructor. + destruct p as [[[w' tr] v] m']. myinv. left; right; constructor. eapply do_ef_external_sound; eauto. (* returnstate *) destruct k; myinv... +(* stuckstate *) + contradiction. Qed. Remark estep_not_val: forall f a k e m t S, estep ge (ExprState f a k e m) t S -> is_val a = None. Proof. intros. - assert (forall b from to C, context from to C -> (C = fun x => x) \/ is_val (C b) = None). + assert (forall b from to C, context from to C -> (from = to /\ C = fun x => x) \/ is_val (C b) = None). induction 1; simpl; auto. inv H. - destruct (H0 a0 _ _ _ H10). subst. inv H8; auto. auto. - destruct (H0 a0 _ _ _ H10). subst. inv H8; auto. auto. - destruct (H0 a0 _ _ _ H10). subst. inv H8; auto. auto. + destruct (H0 a0 _ _ _ H9) as [[A B] | A]. subst. inv H8; auto. auto. + destruct (H0 a0 _ _ _ H9) as [[A B] | A]. subst. inv H8; auto. auto. + destruct (H0 a0 _ _ _ H9) as [[A B] | A]. subst. inv H8; auto. auto. + destruct (H0 a0 _ _ _ H8) as [[A B] | A]. subst. destruct a0; auto. elim H9. constructor. auto. Qed. -Lemma do_step_complete: +Theorem do_step_complete: forall w S t S' w', possible_trace w t w' -> Csem.step ge S t S' -> In (t, S') (do_step w S). Proof with (unfold ret; auto with coqlib). - intros until w'; intro PT; intros. + intros until w'; intros PT H. destruct H. (* Expression step *) inversion H; subst; exploit estep_not_val; eauto; intro NOTVAL. (* lred *) unfold do_step; rewrite NOTVAL. - destruct (step_expr e RV (C a) m) as [ll|]_eqn. change (E0, ExprState f (C a') k e m') with (expr_final_state f k e (C, Lred a' m')). apply in_map. - generalize (step_expr_context e _ _ _ H2 a m). unfold reducts_incl. - rewrite Heqr. destruct (step_expr e LV a m) as [ll'|]_eqn; try tauto. - intro. replace C with (fun x => C x). apply H3. - rewrite (lred_topred _ _ _ _ _ H0) in Heqr0. inv Heqr0. auto with coqlib. + generalize (step_expr_context e w _ _ _ H1 a m). unfold reducts_incl. + intro. replace C with (fun x => C x). apply H2. + rewrite (lred_topred _ _ _ _ _ _ H0). unfold topred; auto with coqlib. apply extensionality; auto. - exploit not_stuck_step_expr; eauto. (* rred *) unfold do_step; rewrite NOTVAL. - destruct (step_expr e RV (C a) m) as [ll|]_eqn. - change (E0, ExprState f (C a') k e m') with (expr_final_state f k e (C, Rred a' m')). + change (t, ExprState f (C a') k e m') with (expr_final_state f k e (C, Rred a' m' t)). apply in_map. - generalize (step_expr_context e _ _ _ H2 a m). unfold reducts_incl. - rewrite Heqr. destruct (step_expr e RV a m) as [ll'|]_eqn; try tauto. - intro. replace C with (fun x => C x). apply H3. - rewrite (rred_topred _ _ _ _ _ H0) in Heqr0. inv Heqr0. auto with coqlib. + generalize (step_expr_context e w _ _ _ H1 a m). unfold reducts_incl. + intro. replace C with (fun x => C x). apply H2. + rewrite (rred_topred _ _ _ _ _ _ _ _ H0 PT). unfold topred; auto with coqlib. apply extensionality; auto. - exploit not_stuck_step_expr; eauto. (* callred *) unfold do_step; rewrite NOTVAL. - destruct (step_expr e RV (C a) m) as [ll|]_eqn. change (E0, Callstate fd vargs (Kcall f e C ty k) m) with (expr_final_state f k e (C, Callred fd vargs ty m)). apply in_map. - generalize (step_expr_context e _ _ _ H2 a m). unfold reducts_incl. - rewrite Heqr. destruct (step_expr e RV a m) as [ll'|]_eqn; try tauto. - intro. replace C with (fun x => C x). apply H3. - rewrite (callred_topred _ _ _ _ _ _ H0) in Heqr0. inv Heqr0. auto with coqlib. + generalize (step_expr_context e w _ _ _ H1 a m). unfold reducts_incl. + intro. replace C with (fun x => C x). apply H2. + rewrite (callred_topred _ _ _ _ _ _ _ H0). unfold topred; auto with coqlib. apply extensionality; auto. - exploit not_stuck_step_expr; eauto. +(* stuck *) + exploit not_imm_safe_stuck_red. eauto. red; intros; elim H1. eapply imm_safe_t_imm_safe. eauto. + instantiate (1 := w). intros [C' IN]. + simpl do_step. rewrite NOTVAL. + change (E0, Stuckstate) with (expr_final_state f k e (C', Stuckred)). + apply in_map. auto. (* Statement step *) inv H; simpl... @@ -1835,13 +2054,13 @@ Proof with (unfold ret; auto with coqlib). destruct H0; subst x... rewrite H0... rewrite H0; rewrite H1... - rewrite pred_dec_true; auto. rewrite H2. red in H0. destruct k; try contradiction... + rewrite H1. rewrite dec_eq_true. rewrite H2. red in H0. destruct k; try contradiction... destruct H0; subst x... rewrite H0... (* Call step *) rewrite pred_dec_true; auto. rewrite (do_alloc_variables_complete _ _ _ _ _ H1). - rewrite (sem_bind_parameters_complete _ _ _ _ _ H2)... + rewrite (sem_bind_parameters_complete _ _ _ _ _ _ H2)... exploit do_ef_external_complete; eauto. intro EQ; rewrite EQ. auto with coqlib. Qed. @@ -1854,7 +2073,7 @@ Definition do_initial_state (p: program): option (genv * state) := do m0 <- Genv.init_mem p; do b <- Genv.find_symbol ge p.(prog_main); do f <- Genv.find_funct_ptr ge b; - check (type_eq (type_of_fundef f) (Tfunction Tnil (Tint I32 Signed))); + check (type_eq (type_of_fundef f) (Tfunction Tnil type_int32s)); Some (ge, Callstate f nil Kstop m0). Definition at_final_state (S: state): option int := diff --git a/cfrontend/Clight.v b/cfrontend/Clight.v index 76f6ff6..f0073a1 100644 --- a/cfrontend/Clight.v +++ b/cfrontend/Clight.v @@ -91,6 +91,7 @@ Inductive statement : Type := | Sskip : statement (**r do nothing *) | Sassign : expr -> expr -> statement (**r assignment [lvalue = rvalue] *) | Sset : ident -> expr -> statement (**r assignment [tempvar = rvalue] *) + | Svolread : ident -> expr -> statement (**r volatile read [tempvar = volatile lvalue] *) | Scall: option ident -> expr -> list expr -> statement (**r function call *) | Ssequence : statement -> statement -> statement (**r sequence *) | Sifthenelse : expr -> statement -> statement -> statement (**r conditional *) @@ -179,7 +180,6 @@ Definition empty_env: env := (PTree.empty (block * type)). Definition temp_env := PTree.t val. - (** Selection of the appropriate case of a [switch], given the value [n] of the selector expression. *) @@ -260,8 +260,8 @@ Inductive eval_expr: expr -> val -> Prop := sem_cast v1 (typeof a) ty = Some v -> eval_expr (Ecast a ty) v | eval_Elvalue: forall a loc ofs v, - eval_lvalue a loc ofs -> - load_value_of_type (typeof a) m loc ofs = Some v -> + eval_lvalue a loc ofs -> type_is_volatile (typeof a) = false -> + deref_loc ge (typeof a) m loc ofs E0 v -> eval_expr a v (** [eval_lvalue ge e m a b ofs] defines the evaluation of expression [a] @@ -280,14 +280,14 @@ with eval_lvalue: expr -> block -> int -> Prop := | eval_Ederef: forall a ty l ofs, eval_expr a (Vptr l ofs) -> eval_lvalue (Ederef a ty) l ofs - | eval_Efield_struct: forall a i ty l ofs id fList delta, - eval_lvalue a l ofs -> - typeof a = Tstruct id fList -> + | eval_Efield_struct: forall a i ty l ofs id fList att delta, + eval_expr a (Vptr l ofs) -> + typeof a = Tstruct id fList att -> field_offset i fList = OK delta -> eval_lvalue (Efield a i ty) l (Int.add ofs (Int.repr delta)) - | eval_Efield_union: forall a i ty l ofs id fList, - eval_lvalue a l ofs -> - typeof a = Tunion id fList -> + | eval_Efield_union: forall a i ty l ofs id fList att, + eval_expr a (Vptr l ofs) -> + typeof a = Tunion id fList att -> eval_lvalue (Efield a i ty) l ofs. Scheme eval_expr_ind2 := Minimality for eval_expr Sort Prop @@ -415,19 +415,26 @@ with find_label_ls (lbl: label) (sl: labeled_statements) (k: cont) Inductive step: state -> trace -> state -> Prop := - | step_assign: forall f a1 a2 k e le m loc ofs v2 v m', + | step_assign: forall f a1 a2 k e le m loc ofs v2 v t m', eval_lvalue e le m a1 loc ofs -> eval_expr e le m a2 v2 -> sem_cast v2 (typeof a2) (typeof a1) = Some v -> - store_value_of_type (typeof a1) m loc ofs v = Some m' -> + assign_loc ge (typeof a1) m loc ofs v t m' -> step (State f (Sassign a1 a2) k e le m) - E0 (State f Sskip k e le m') + t (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) E0 (State f Sskip k e (PTree.set id v le) m) + | step_vol_read: forall f id a k e le m loc ofs t v, + eval_lvalue e le m a loc ofs -> + deref_loc ge (typeof a) m loc ofs t v -> + type_is_volatile (typeof a) = true -> + step (State f (Svolread id a) k e le m) + t (State f Sskip k e (PTree.set id v le) m) + | step_call: forall f optid a al k e le m tyargs tyres vf vargs fd, classify_fun (typeof a) = fun_case_f tyargs tyres -> eval_expr e le m a vf -> @@ -558,7 +565,7 @@ Inductive step: state -> trace -> state -> Prop := | 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 -> + bind_parameters ge e m1 f.(fn_params) vargs m2 -> step (Callstate (Internal f) vargs k m) E0 (State f f.(fn_body) k e (PTree.empty val) m2) @@ -622,17 +629,23 @@ Inductive exec_stmt: env -> temp_env -> mem -> statement -> trace -> temp_env -> | exec_Sskip: forall e le m, exec_stmt e le m Sskip E0 le m Out_normal - | exec_Sassign: forall e le m a1 a2 loc ofs v2 v m', + | exec_Sassign: forall e le m a1 a2 loc ofs v2 v t m', eval_lvalue e le m a1 loc ofs -> eval_expr e le m a2 v2 -> sem_cast v2 (typeof a2) (typeof a1) = Some v -> - store_value_of_type (typeof a1) m loc ofs v = Some m' -> + assign_loc ge (typeof a1) m loc ofs v t m' -> exec_stmt e le m (Sassign a1 a2) - E0 le m' Out_normal + t le m' Out_normal | exec_Sset: forall e le m id a v, eval_expr e le m a v -> exec_stmt e le m (Sset id a) - E0 (PTree.set id v le) m Out_normal + E0 (PTree.set id v le) m Out_normal + | exec_Svol_read: forall e le m id a loc ofs t v, + eval_lvalue e le m a loc ofs -> + type_is_volatile (typeof a) = true -> + deref_loc ge (typeof a) m loc ofs t v -> + exec_stmt e le m (Svolread id a) + t (PTree.set id v le) m Out_normal | exec_Scall_none: forall e le m a al tyargs tyres vf vargs f t m' vres, classify_fun (typeof a) = fun_case_f tyargs tyres -> eval_expr e le m a vf -> @@ -756,7 +769,7 @@ with eval_funcall: mem -> fundef -> list val -> trace -> mem -> val -> Prop := | eval_funcall_internal: forall le m f vargs t e m1 m2 m3 out vres m4, alloc_variables empty_env m (f.(fn_params) ++ f.(fn_vars)) e m1 -> list_norepet (var_names f.(fn_params) ++ var_names f.(fn_vars)) -> - bind_parameters e m1 f.(fn_params) vargs m2 -> + bind_parameters ge e m1 f.(fn_params) vargs m2 -> exec_stmt e (PTree.empty val) m2 f.(fn_body) t le m3 out -> outcome_result_value out f.(fn_return) vres -> Mem.free_list m3 (blocks_of_env e) = Some m4 -> @@ -858,7 +871,7 @@ with evalinf_funcall: mem -> fundef -> list val -> traceinf -> Prop := | evalinf_funcall_internal: forall m f vargs t e m1 m2, alloc_variables empty_env m (f.(fn_params) ++ f.(fn_vars)) e m1 -> list_norepet (var_names f.(fn_params) ++ var_names f.(fn_vars)) -> - bind_parameters e m1 f.(fn_params) vargs m2 -> + bind_parameters ge e m1 f.(fn_params) vargs m2 -> execinf_stmt e (PTree.empty val) m2 f.(fn_body) t -> evalinf_funcall m (Internal f) vargs t. @@ -877,7 +890,7 @@ Inductive initial_state (p: program): state -> Prop := Genv.init_mem p = Some m0 -> Genv.find_symbol ge p.(prog_main) = Some b -> Genv.find_funct_ptr ge b = Some f -> - type_of_fundef f = Tfunction Tnil (Tint I32 Signed) -> + type_of_fundef f = Tfunction Tnil type_int32s -> initial_state p (Callstate f nil Kstop m0). (** A final state is a [Returnstate] with an empty continuation. *) @@ -901,10 +914,19 @@ Proof. assert (t1 = E0 -> exists s2, step (Genv.globalenv p) s t2 s2). intros. subst. inv H0. exists s1; auto. inversion H; subst; auto. + (* assign *) + inv H5; auto. exploit volatile_store_receptive; eauto. intros EQ. subst t2; econstructor; eauto. + (* volatile read *) + inv H3; auto. exploit volatile_load_receptive; eauto. intros [v2 LD]. + econstructor. eapply step_vol_read; eauto. eapply deref_loc_volatile; eauto. + (* external *) exploit external_call_receptive; eauto. intros [vres2 [m2 EC2]]. exists (Returnstate vres2 k m2). econstructor; eauto. (* trace length *) - inv H; simpl; try omega. eapply external_call_trace_length; eauto. + red; intros. inv H; simpl; try omega. + inv H3; simpl; try omega. inv H5; simpl; omega. + inv H1; simpl; try omega. inv H4; simpl; omega. + eapply external_call_trace_length; eauto. Qed. (** Big-step execution of a whole program. *) @@ -915,7 +937,7 @@ Inductive bigstep_program_terminates (p: program): trace -> int -> Prop := Genv.init_mem p = Some m0 -> Genv.find_symbol ge p.(prog_main) = Some b -> Genv.find_funct_ptr ge b = Some f -> - type_of_fundef f = Tfunction Tnil (Tint I32 Signed) -> + type_of_fundef f = Tfunction Tnil type_int32s -> eval_funcall ge m0 f nil t m1 (Vint r) -> bigstep_program_terminates p t r. @@ -925,7 +947,7 @@ Inductive bigstep_program_diverges (p: program): traceinf -> Prop := Genv.init_mem p = Some m0 -> Genv.find_symbol ge p.(prog_main) = Some b -> Genv.find_funct_ptr ge b = Some f -> - type_of_fundef f = Tfunction Tnil (Tint I32 Signed) -> + type_of_fundef f = Tfunction Tnil type_int32s -> evalinf_funcall ge m0 f nil t -> bigstep_program_diverges p t. @@ -942,9 +964,9 @@ Let ge : genv := Genv.globalenv prog. Definition exec_stmt_eval_funcall_ind (PS: env -> temp_env -> mem -> statement -> trace -> temp_env -> mem -> outcome -> Prop) (PF: mem -> fundef -> list val -> trace -> mem -> val -> Prop) := - fun a b c d e f g h i j k l m n o p q r s t u v w x => - conj (exec_stmt_ind2 ge PS PF a b c d e f g h i j k l m n o p q r s t u v w x) - (eval_funcall_ind2 ge PS PF a b c d e f g h i j k l m n o p q r s t u v w x). + fun a b c d e f g h i j k l m n o p q r s t u v w x y => + conj (exec_stmt_ind2 ge PS PF a b c d e f g h i j k l m n o p q r s t u v w x y) + (eval_funcall_ind2 ge PS PF a b c d e f g h i j k l m n o p q r s t u v w x y). Inductive outcome_state_match (e: env) (le: temp_env) (m: mem) (f: function) (k: cont): outcome -> state -> Prop := @@ -994,6 +1016,9 @@ Proof. (* set *) econstructor; split. apply star_one. econstructor; eauto. constructor. +(* set volatile *) + econstructor; split. apply star_one. econstructor; eauto. constructor. + (* call none *) econstructor; split. eapply star_left. econstructor; eauto. diff --git a/cfrontend/Cminorgen.v b/cfrontend/Cminorgen.v index 3a8b857..a849a9a 100644 --- a/cfrontend/Cminorgen.v +++ b/cfrontend/Cminorgen.v @@ -62,11 +62,11 @@ Definition for_temp (id: ident) : ident := xI id. global variables, stored in the global symbols with the same names. *) Inductive var_info: Type := - | Var_local: memory_chunk -> var_info - | Var_stack_scalar: memory_chunk -> Z -> var_info - | Var_stack_array: Z -> var_info - | Var_global_scalar: memory_chunk -> var_info - | Var_global_array: var_info. + | 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. @@ -140,6 +140,7 @@ Definition make_unop (op: unary_operation) (e: expr): expr := Inductive approx : Type := | Any (**r any value *) + | Int1 (**r [0] or [1] *) | Int7 (**r [[0,127]] *) | Int8s (**r [[-128,127]] *) | Int8u (**r [[0,255]] *) @@ -153,41 +154,51 @@ Module Approx. Definition bge (x y: approx) : bool := match x, y with | Any, _ => true - | Int7, Int7 => true - | Int8s, (Int7 | Int8s) => true - | Int8u, (Int7 | Int8u) => true - | Int15, (Int7 | Int8u | Int15) => true - | Int16s, (Int7 | Int8s | Int8u | Int15 | Int16s) => true - | Int16u, (Int7 | Int8u | Int15 | Int16u) => true + | Int1, Int1 => true + | Int7, (Int1 | Int7) => true + | Int8s, (Int1 | Int7 | Int8s) => true + | Int8u, (Int1 | Int7 | Int8u) => true + | Int15, (Int1 | Int7 | Int8u | Int15) => true + | Int16s, (Int1 | Int7 | Int8s | Int8u | Int15 | Int16s) => true + | Int16u, (Int1 | Int7 | Int8u | Int15 | Int16u) => true | Float32, Float32 => true | _, _ => false end. Definition lub (x y: approx) : approx := match x, y with + | Int1, Int1 => Int1 + | Int1, Int7 => Int7 + | Int1, Int8u => Int8u + | Int1, Int8s => Int8s + | Int1, Int15 => Int15 + | Int1, Int16u => Int16u + | Int1, Int16s => Int16s + | Int7, Int1 => Int7 | Int7, Int7 => Int7 | Int7, Int8u => Int8u | Int7, Int8s => Int8s | Int7, Int15 => Int15 | Int7, Int16u => Int16u | Int7, Int16s => Int16s - | Int8u, (Int7|Int8u) => Int8u + | Int8u, (Int1|Int7|Int8u) => Int8u | Int8u, Int15 => Int15 | Int8u, Int16u => Int16u | Int8u, Int16s => Int16s - | Int8s, (Int7|Int8s) => Int8s + | Int8s, (Int1|Int7|Int8s) => Int8s | Int8s, (Int15|Int16s) => Int16s - | Int15, (Int7|Int8u|Int15) => Int15 + | Int15, (Int1|Int7|Int8u|Int15) => Int15 | Int15, Int16u => Int16u | Int15, (Int8s|Int16s) => Int16s - | Int16u, (Int7|Int8u|Int15|Int16u) => Int16u - | Int16s, (Int7|Int8u|Int8s|Int15|Int16s) => Int16s + | Int16u, (Int1|Int7|Int8u|Int15|Int16u) => Int16u + | Int16s, (Int1|Int7|Int8u|Int8s|Int15|Int16s) => Int16s | Float32, Float32 => Float32 | _, _ => Any end. Definition of_int (n: int) := - if Int.eq_dec n (Int.zero_ext 7 n) then Int7 + if Int.eq_dec n Int.zero || Int.eq_dec n Int.one then Int1 + else if Int.eq_dec n (Int.zero_ext 7 n) then Int7 else if Int.eq_dec n (Int.zero_ext 8 n) then Int8u else if Int.eq_dec n (Int.sign_ext 8 n) then Int8s else if Int.eq_dec n (Int.zero_ext 15 n) then Int15 @@ -216,7 +227,8 @@ Definition unop (op: unary_operation) (a: approx) := | Ocast16unsigned => Int16u | Ocast16signed => Int16s | Osingleoffloat => Float32 - | Onotbool => Int7 + | Oboolval => Int1 + | Onotbool => Int1 | _ => Any end. @@ -226,17 +238,20 @@ Definition unop_is_redundant (op: unary_operation) (a: approx) := | Ocast8signed => bge Int8s a | Ocast16unsigned => bge Int16u a | Ocast16signed => bge Int16s a + | Oboolval => bge Int1 a | Osingleoffloat => bge Float32 a | _ => false end. Definition bitwise_and (a1 a2: approx) := - if bge Int8u a1 || bge Int8u a2 then Int8u + if bge Int1 a1 || bge Int1 a2 then Int1 + else if bge Int8u a1 || bge Int8u a2 then Int8u else if bge Int16u a1 || bge Int16u a2 then Int16u else Any. Definition bitwise_or (a1 a2: approx) := - if bge Int8u a1 && bge Int8u a2 then Int8u + if bge Int1 a1 && bge Int1 a2 then Int1 + else if bge Int8u a1 && bge Int8u a2 then Int8u else if bge Int16u a1 && bge Int16u a2 then Int16u else Any. @@ -244,9 +259,9 @@ Definition binop (op: binary_operation) (a1 a2: approx) := match op with | Oand => bitwise_and a1 a2 | Oor | Oxor => bitwise_or a1 a2 - | Ocmp _ => Int7 - | Ocmpu _ => Int7 - | Ocmpf _ => Int7 + | Ocmp _ => Int1 + | Ocmpu _ => Int1 + | Ocmpf _ => Int1 | _ => Any end. @@ -275,7 +290,7 @@ 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 => OK (make_stackaddr ofs, Any) + | Var_stack_array ofs sz al => OK (make_stackaddr ofs, Any) | _ => OK (make_globaladdr id, Any) end. @@ -299,16 +314,17 @@ Definition var_set (cenv: compilenv) (** 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) (ty: typ) (k: stmt): res stmt := +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_global_scalar chunk => - OK (Sseq (make_store chunk (make_globaladdr id) (Evar (for_var id))) k) + | Var_stack_array ofs sz al => + OK (Sseq (Sbuiltin None (EF_memcpy sz (Zmin al 4)) + (make_stackaddr ofs :: Evar (for_var id) :: nil)) k) | _ => - Error(msg "Cminorgen.var_set_self.2") + Error(msg "Cminorgen.var_set_self") end. (** Translation of constants. *) @@ -432,6 +448,9 @@ Fixpoint transl_stmt (ret: option typ) (cenv: compilenv) do (te, a) <- transl_expr cenv e; do tel <- transl_exprlist cenv el; OK (Scall (option_map for_temp optid) sig te tel) + | Csharpminor.Sbuiltin optid ef el => + do tel <- transl_exprlist cenv el; + OK (Sbuiltin (option_map for_temp optid) ef tel) | Csharpminor.Sseq s1 s2 => do ts1 <- transl_stmt ret cenv xenv s1; do ts2 <- transl_stmt ret cenv xenv s2; @@ -515,6 +534,8 @@ Fixpoint addr_taken_stmt (s: Csharpminor.stmt): Identset.t := 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 => @@ -554,9 +575,9 @@ Definition assign_variable (cenv_stacksize: compilenv * Z) : compilenv * Z := let (cenv, stacksize) := cenv_stacksize in match id_lv with - | (id, Varray sz) => + | (id, Varray sz al) => let ofs := align stacksize (array_alignment sz) in - (PMap.set id (Var_stack_array ofs) cenv, ofs + Zmax 0 sz) + (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 @@ -589,7 +610,7 @@ Definition assign_global_variable match info with | (id, mkglobvar vk _ _ _) => PMap.set id (match vk with Vscalar chunk => Var_global_scalar chunk - | Varray _ => Var_global_array + | Varray _ _ => Var_global_array end) ce end. @@ -605,13 +626,13 @@ Definition build_global_compilenv (p: Csharpminor.program) : compilenv := local variables.) *) Fixpoint store_parameters - (cenv: compilenv) (params: list (ident * memory_chunk)) + (cenv: compilenv) (params: list (ident * var_kind)) {struct params} : res stmt := match params with | nil => OK Sskip - | (id, chunk) :: rem => + | (id, vk) :: rem => do s <- store_parameters cenv rem; - var_set_self cenv id (type_of_chunk chunk) s + var_set_self cenv id s end. (** Translation of a Csharpminor function. We must check that the diff --git a/cfrontend/Cminorgenproof.v b/cfrontend/Cminorgenproof.v index a6656e0..1a66ec9 100644 --- a/cfrontend/Cminorgenproof.v +++ b/cfrontend/Cminorgenproof.v @@ -61,6 +61,18 @@ Lemma functions_translated: 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). +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 sig_preserved_body: forall f tf cenv size, transl_funbody cenv size f = OK tf -> @@ -245,10 +257,10 @@ Inductive match_var (f: meminj) (id: ident) 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 b, - PTree.get id e = Some (b, Varray sz) -> + forall ofs sz al b, + PTree.get id e = Some (b, Varray sz al) -> val_inject f (Vptr b Int.zero) (Vptr sp (Int.repr ofs)) -> - match_var f id e m te sp (Var_stack_array 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 -> @@ -463,8 +475,8 @@ Inductive alloc_condition: var_info -> var_kind -> block -> option (block * Z) - 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 sp, - alloc_condition (Var_stack_array pos) (Varray sz) 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, @@ -1156,6 +1168,7 @@ Qed. Definition val_match_approx (a: approx) (v: val) : Prop := match a with + | Int1 => v = Val.zero_ext 1 v | Int7 => v = Val.zero_ext 8 v /\ v = Val.sign_ext 8 v | Int8u => v = Val.zero_ext 8 v | Int8s => v = Val.sign_ext 8 v @@ -1187,8 +1200,16 @@ Proof. intros. rewrite H. destruct v; simpl; auto. decEq. symmetry. apply Int.sign_zero_ext_widen. compute; auto. split. omega. compute; auto. + assert (D: forall v, v = Val.zero_ext 1 v -> v = Val.zero_ext 8 v). + intros. rewrite H. + destruct v; simpl; auto. decEq. symmetry. + apply Int.zero_ext_widen. compute; auto. split. omega. compute; auto. + assert (E: forall v, v = Val.zero_ext 1 v -> v = Val.sign_ext 8 v). + intros. rewrite H. + destruct v; simpl; auto. decEq. symmetry. + apply Int.sign_zero_ext_widen. compute; auto. split. omega. compute; auto. intros. - unfold Approx.bge in H; destruct a1; try discriminate; destruct a2; simpl in *; try discriminate; intuition; auto. + unfold Approx.bge in H; destruct a1; try discriminate; destruct a2; simpl in *; try discriminate; intuition. Qed. Lemma approx_lub_ge_left: @@ -1206,7 +1227,9 @@ Qed. Lemma approx_of_int_sound: forall n, val_match_approx (Approx.of_int n) (Vint n). Proof. - unfold Approx.of_int; intros. + unfold Approx.of_int; intros. + destruct (Int.eq_dec n Int.zero); simpl. subst; auto. + destruct (Int.eq_dec n Int.one); simpl. subst; auto. destruct (Int.eq_dec n (Int.zero_ext 7 n)). simpl. split. decEq. rewrite e. symmetry. apply Int.zero_ext_widen. compute; auto. split. omega. compute; auto. @@ -1249,7 +1272,8 @@ Proof. destruct v1; simpl; auto. rewrite Int.sign_ext_idem; auto. compute; auto. destruct v1; simpl; auto. rewrite Int.zero_ext_idem; auto. compute; auto. destruct v1; simpl; auto. rewrite Int.sign_ext_idem; auto. compute; auto. - destruct v1; simpl; auto. destruct (Int.eq i Int.zero); auto. + destruct v1; simpl; auto. destruct (Int.eq i Int.zero); simpl; auto. + destruct v1; simpl; auto. destruct (Int.eq i Int.zero); simpl; auto. destruct v1; simpl; auto. rewrite Float.singleoffloat_idem; auto. Qed. @@ -1273,7 +1297,13 @@ Proof. assert (Q: forall a v, val_match_approx a v -> Approx.bge Int16u a = true -> v = Val.zero_ext 16 v). intros. apply (val_match_approx_increasing Int16u a v); auto. + assert (R: forall a v, val_match_approx a v -> Approx.bge Int1 a = true -> + v = Val.zero_ext 1 v). + intros. apply (val_match_approx_increasing Int1 a v); auto. + intros; unfold Approx.bitwise_and. + destruct (Approx.bge Int1 a1) as []_eqn. simpl. apply Y; eauto. compute; auto. + destruct (Approx.bge Int1 a2) as []_eqn. simpl. apply X; eauto. compute; auto. destruct (Approx.bge Int8u a1) as []_eqn. simpl. apply Y; eauto. compute; auto. destruct (Approx.bge Int8u a2) as []_eqn. simpl. apply X; eauto. compute; auto. destruct (Approx.bge Int16u a1) as []_eqn. simpl. apply Y; eauto. compute; auto. @@ -1298,14 +1328,21 @@ Proof. simpl. rewrite Int.and_idem. auto. unfold Approx.bitwise_or. - destruct (Approx.bge Int8u a1 && Approx.bge Int8u a2) as []_eqn. + + destruct (Approx.bge Int1 a1 && Approx.bge Int1 a2) as []_eqn. destruct (andb_prop _ _ Heqb). simpl. apply X. compute; auto. + apply (val_match_approx_increasing Int1 a1 v1); auto. + apply (val_match_approx_increasing Int1 a2 v2); auto. + + destruct (Approx.bge Int8u a1 && Approx.bge Int8u a2) as []_eqn. + destruct (andb_prop _ _ Heqb0). + simpl. apply X. compute; auto. apply (val_match_approx_increasing Int8u a1 v1); auto. apply (val_match_approx_increasing Int8u a2 v2); auto. destruct (Approx.bge Int16u a1 && Approx.bge Int16u a2) as []_eqn. - destruct (andb_prop _ _ Heqb0). + destruct (andb_prop _ _ Heqb1). simpl. apply X. compute; auto. apply (val_match_approx_increasing Int16u a1 v1); auto. apply (val_match_approx_increasing Int16u a2 v2); auto. @@ -1319,7 +1356,7 @@ Lemma approx_of_binop_sound: val_match_approx a1 v1 -> val_match_approx a2 v2 -> val_match_approx (Approx.binop op a1 a2) v. Proof. - assert (OB: forall ob, val_match_approx Int7 (Val.of_optbool ob)). + assert (OB: forall ob, val_match_approx Int1 (Val.of_optbool ob)). destruct ob; simpl. destruct b; auto. auto. destruct op; intros; simpl Approx.binop; simpl in H; try (exact I); inv H. @@ -1356,6 +1393,20 @@ Proof. (* cast16signed *) assert (V: val_match_approx Int16s v) by (eapply val_match_approx_increasing; eauto). simpl in *. congruence. +(* boolval *) + assert (V: val_match_approx Int1 v) by (eapply val_match_approx_increasing; eauto). + simpl in *. + assert (v = Vundef \/ v = Vzero \/ v = Vone). + rewrite V. destruct v; simpl; auto. + assert (0 <= Int.unsigned (Int.zero_ext 1 i) < 2). + apply Int.zero_ext_range. compute; auto. + assert (Int.unsigned(Int.zero_ext 1 i) = 0 \/ Int.unsigned(Int.zero_ext 1 i) = 1) by omega. + destruct H2. + assert (Int.repr (Int.unsigned (Int.zero_ext 1 i)) = Int.repr 0) by congruence. + rewrite Int.repr_unsigned in H3. rewrite H3; auto. + assert (Int.repr (Int.unsigned (Int.zero_ext 1 i)) = Int.repr 1) by congruence. + rewrite Int.repr_unsigned in H3. rewrite H3; auto. + intuition; subst v; auto. (* singleoffloat *) assert (V: val_match_approx Float32 v) by (eapply val_match_approx_increasing; eauto). simpl in *. congruence. @@ -1401,6 +1452,7 @@ Proof. inv H; inv H0; simpl; TrivialExists. inv H; inv H0; simpl; TrivialExists. inv H; inv H0; simpl; TrivialExists. + inv H; inv H0; simpl; TrivialExists. apply val_inject_val_of_bool. inv H; inv H0; simpl; TrivialExists. inv H; inv H0; simpl; TrivialExists. apply val_inject_val_of_bool. inv H; inv H0; simpl; TrivialExists. @@ -1946,9 +1998,9 @@ Proof. apply match_env_extensional with te1; auto. Qed. -Lemma var_set_self_correct: - forall cenv id ty s a f tf e le te sp lo hi m cs tm tv v m' fn k, - var_set_self cenv id ty s = OK a -> +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 -> @@ -1995,20 +2047,55 @@ Proof. split. auto. rewrite NEXTBLOCK. rewrite (nextblock_storev _ _ _ _ _ STORE'). eapply match_callstack_storev_mapped; eauto. - (* 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. 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_store_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 (Zmin al 4) 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 (Zmin al0 4)) 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_bounds; eauto. + omega. omega. + eapply external_call_nextblock_incr; eauto. + eapply external_call_nextblock_incr; eauto. + auto. Qed. (** * Correctness of stack allocation of local variables *) @@ -2032,16 +2119,15 @@ Remark assign_variable_incr: Proof. intros until sz'; simpl. destruct lv. case (Identset.mem id atk); intros. - inv H. generalize (size_chunk_pos m). intro. - generalize (align_le sz (size_chunk m) H). omega. + 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 z) (array_alignment_pos z)). - assert (0 <= Zmax 0 z). apply Zmax_bound_l. omega. + 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'. @@ -2166,7 +2252,7 @@ Proof. subst b0. congruence. rewrite OTHER in H; eauto. (* 2 info = Var_stack_array ofs *) - intros dim LV EQ. injection EQ; clear EQ; intros. rewrite <- H0. + 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 *. @@ -2181,7 +2267,7 @@ Proof. intros. generalize (RANGE _ _ H3). omega. intros [f1 [MINJ1 [INCR1 [SAME OTHER]]]]. exists f1; split. auto. split. auto. split. - eapply match_callstack_alloc_left; eauto. + subst cenv'. eapply match_callstack_alloc_left; eauto. rewrite <- LV; auto. rewrite SAME; constructor. intros. rewrite (Mem.bounds_alloc _ _ _ _ _ ALLOC). @@ -2317,14 +2403,12 @@ Proof. eapply Mem.valid_block_inject_2; eauto. intros. unfold te. apply set_locals_params_defined. elim (in_app_or _ _ _ H6); intros. - elim (list_in_map_inv _ _ _ H7). intros x [A B]. - apply in_or_app; left. unfold tparams. apply List.in_map. inversion A. apply List.in_map. auto. + 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. rewrite list_map_compose. simpl. - assumption. + unfold fn_variables. rewrite List.map_app. assumption. (* undef *) intros. unfold empty_env. apply PTree.gempty. Qed. @@ -2333,17 +2417,23 @@ Qed. to store in memory the values of parameters that are stack-allocated. *) Inductive vars_vals_match (f:meminj): - list (ident * memory_chunk) -> list val -> env -> Prop := + list (ident * var_kind) -> list val -> env -> Prop := | vars_vals_nil: forall te, vars_vals_match f nil nil te - | vars_vals_cons: + | 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, chunk) :: vars) (v :: 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, @@ -2357,88 +2447,120 @@ Proof. 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 e 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 param_name params) -> + 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 tm2, + 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). + /\ 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 tm1. split. constructor. tauto. - (* inductive case *) + 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; eauto. + 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 [tm3 [EXEC2 [MINJ2 MATCH2]]]. - exists tm3. + intros [f' [tm3 [EXEC2 [MINJ2 [MATCH2 INCR2]]]]]. + exists f'; exists tm3. split. eapply star_trans; eauto. auto. -Qed. + (* 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 param_name params) -> + list_norepet (List.map variable_name params) -> val_list_inject f args targs -> - list_forall2 val_normalized args (List.map param_chunk params) -> + 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 param_name params))). + (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 chunk]; simpl in *. econstructor. - rewrite PTree.gss. reflexivity. - auto. auto. + 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 param_name params))). + 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 (param_name (id, lv)). apply List.in_map; auto. + 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 param_name params) -> In id2 vl -> for_var id1 <> id2) -> + (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 (param_name (id, lv)). apply List.in_map. auto. + 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 param_name params ++ vars) -> + list_norepet (List.map variable_name params ++ vars) -> val_list_inject f args targs -> - list_forall2 val_normalized args (List.map param_chunk params) -> + 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 param_name params)))). + (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. @@ -2452,12 +2574,13 @@ Qed. Remark bind_parameters_normalized: forall e m params args m', - bind_parameters e m params args m' -> - list_forall2 val_normalized args (List.map param_chunk params). + 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 @@ -2470,7 +2593,7 @@ 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 e m1 fn.(Csharpminor.fn_params) vargs m2 -> + 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 -> @@ -2504,8 +2627,9 @@ Proof. exploit store_parameters_correct. eauto. eauto. eapply list_norepet_append_left; eauto. eexact MINJ1. eexact MATCH1. eauto. - intros [tm2 [EXEC [MINJ2 MATCH2]]]. - exists f1; exists tm2. eauto. + intros [f2 [tm2 [EXEC [MINJ2 [MATCH2 INCR2]]]]]. + exists f2; exists tm2. + split; eauto. split; auto. split; auto. eapply inject_incr_trans; eauto. Qed. (** * Semantic preservation for the translation *) @@ -2888,8 +3012,8 @@ Proof. Qed. Remark find_label_var_set_self: - forall id ty s0 s k, - var_set_self cenv id ty s0 = OK s -> + 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. @@ -3114,6 +3238,35 @@ Proof. eapply match_Kcall with (cenv' := cenv); eauto. red; auto. +(* builtin *) + monadInv TR. + exploit transl_exprlist_correct; eauto. + intros [tvargs [EVAL2 VINJ2]]. + exploit match_callstack_match_globalenvs; eauto. intros [hi' MG]. + exploit external_call_mem_inject; eauto. + eapply inj_preserves_globals; eauto. + 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. + assert (MCS': match_callstack f' m' tm' + (Frame cenv tfn e le te sp lo hi :: cs) + (Mem.nextblock m') (Mem.nextblock tm')). + apply match_callstack_incr_bound with (Mem.nextblock m) (Mem.nextblock tm). + eapply match_callstack_external_call; eauto. + intros. eapply external_call_bounds; eauto. + omega. omega. + eapply external_call_nextblock_incr; eauto. + eapply external_call_nextblock_incr; eauto. + econstructor; eauto. +Opaque PTree.set. + unfold set_optvar. destruct optid; simpl. + eapply match_callstack_set_temp; eauto. + auto. + (* seq *) monadInv TR. left; econstructor; split. @@ -3256,8 +3409,8 @@ Proof. apply plus_one. econstructor. eapply external_call_symbols_preserved_2; eauto. exact symbols_preserved. - eexact (Genv.find_var_info_transf_partial2 (transl_fundef gce) transl_globvar _ TRANSL). - eexact (Genv.find_var_info_rev_transf_partial2 (transl_fundef gce) transl_globvar _ TRANSL). + eexact var_info_translated. + eexact var_info_rev_translated. econstructor; eauto. apply match_callstack_incr_bound with (Mem.nextblock m) (Mem.nextblock tm). eapply match_callstack_external_call; eauto. diff --git a/cfrontend/Cparser.mlpack b/cfrontend/Cparser.mlpack index e6bbdc6..b59e30f 100644 --- a/cfrontend/Cparser.mlpack +++ b/cfrontend/Cparser.mlpack @@ -16,12 +16,8 @@ cparser/Elab cparser/Rename cparser/Transform cparser/Unblock -cparser/SimplExpr -cparser/AddCasts -cparser/StructByValue -cparser/StructAssign +cparser/StructReturn cparser/Bitfields cparser/PackedStructs -cparser/SimplVolatile cparser/Parse diff --git a/cfrontend/Csem.v b/cfrontend/Csem.v index 426a753..49b2062 100644 --- a/cfrontend/Csem.v +++ b/cfrontend/Csem.v @@ -41,6 +41,7 @@ Definition cast_int_int (sz: intsize) (sg: signedness) (i: int) : int := | I16, Signed => Int.sign_ext 16 i | I16, Unsigned => Int.zero_ext 16 i | I32, _ => i + | IBool, _ => if Int.eq i Int.zero then Int.zero else Int.one end. Definition cast_int_float (si : signedness) (i: int) : float := @@ -92,6 +93,22 @@ Function sem_cast (v: val) (t1 t2: type) : option val := end | _ => None end + | cast_case_ip2bool => + match v with + | Vint i => Some (Vint (cast_int_int IBool Signed i)) + | Vptr _ _ => Some (Vint Int.one) + | _ => None + end + | cast_case_f2bool => + match v with + | Vfloat f => + Some(Vint(if Float.cmp Ceq f Float.zero then Int.zero else Int.one)) + | _ => None + end + | cast_case_struct id1 fld1 id2 fld2 => + if ident_eq id1 id2 && fieldlist_eq fld1 fld2 then Some v else None + | cast_case_union id1 fld1 id2 fld2 => + if ident_eq id1 id2 && fieldlist_eq fld1 fld2 then Some v else None | cast_case_void => Some v | cast_case_default => @@ -105,11 +122,9 @@ Function sem_cast (v: val) (t1 t2: type) : option val := Function bool_val (v: val) (t: type) : option bool := match v, t with - | Vint n, Tint sz sg => Some (negb (Int.eq n Int.zero)) - | Vint n, Tpointer t' => Some (negb (Int.eq n Int.zero)) - | Vptr b ofs, Tint sz sg => Some true - | Vptr b ofs, Tpointer t' => Some true - | Vfloat f, Tfloat sz => Some (negb(Float.cmp Ceq f Float.zero)) + | Vint n, (Tint _ _ _ | Tpointer _ _ | Tarray _ _ _ | Tfunction _ _) => Some (negb (Int.eq n Int.zero)) + | Vptr b ofs, (Tint _ _ _ | Tpointer _ _ | Tarray _ _ _ | Tfunction _ _) => Some true + | Vfloat f, Tfloat sz _ => Some (negb(Float.cmp Ceq f Float.zero)) | _, _ => None end. @@ -193,13 +208,13 @@ Function sem_add (v1:val) (t1:type) (v2: val) (t2:type) : option val := | Vfloat n1, Vint n2 => Some (Vfloat (Float.add n1 (cast_int_float sg n2))) | _, _ => None end - | add_case_pi ty => (**r pointer plus integer *) + | add_case_pi ty _ => (**r pointer plus integer *) match v1,v2 with | Vptr b1 ofs1, Vint n2 => Some (Vptr b1 (Int.add ofs1 (Int.mul (Int.repr (sizeof ty)) n2))) | _, _ => None end - | add_case_ip ty => (**r integer plus pointer *) + | add_case_ip ty _ => (**r integer plus pointer *) match v1,v2 with | Vint n1, Vptr b2 ofs2 => Some (Vptr b2 (Int.add ofs2 (Int.mul (Int.repr (sizeof ty)) n1))) @@ -472,10 +487,40 @@ Definition sem_binary_operation Definition sem_incrdecr (id: incr_or_decr) (v: val) (ty: type) := match id with - | Incr => sem_add v ty (Vint Int.one) (Tint I32 Signed) - | Decr => sem_sub v ty (Vint Int.one) (Tint I32 Signed) + | Incr => sem_add v ty (Vint Int.one) type_int32s + | Decr => sem_sub v ty (Vint Int.one) type_int32s end. +(** Common-sense relations between boolean operators *) + +Lemma cast_bool_bool_val: + forall v t, + sem_cast v t (Tint IBool Signed noattr) = + match bool_val v t with None => None | Some b => Some(Val.of_bool b) end. +Proof. + intros. unfold sem_cast, bool_val. destruct t; simpl; destruct v; auto. + destruct (Int.eq i0 Int.zero); auto. + destruct (Float.cmp Ceq f0 Float.zero); auto. + destruct (Int.eq i Int.zero); auto. + destruct (Int.eq i Int.zero); auto. + destruct (Int.eq i Int.zero); auto. +Qed. + +Lemma notbool_bool_val: + forall v t, + sem_notbool v t = + match bool_val v t with None => None | Some b => Some(Val.of_bool (negb b)) end. +Proof. + assert (CB: forall i s a, classify_bool (Tint i s a) = bool_case_ip). + intros. destruct i; auto. destruct s; auto. + intros. unfold sem_notbool, bool_val. destruct t; try rewrite CB; simpl; destruct v; auto. + destruct (Int.eq i0 Int.zero); auto. + destruct (Float.cmp Ceq f0 Float.zero); auto. + destruct (Int.eq i Int.zero); auto. + destruct (Int.eq i Int.zero); auto. + destruct (Int.eq i Int.zero); auto. +Qed. + (** * Operational semantics *) (** The semantics uses two environments. The global environment @@ -492,30 +537,58 @@ Definition env := PTree.t (block * type). (* map variable -> location & type *) Definition empty_env: env := (PTree.empty (block * type)). -(** [load_value_of_type ty m b ofs] computes the value of a datum +(** [deref_loc ty m b ofs t v] computes the value of a datum of type [ty] residing in memory [m] at block [b], offset [ofs]. If the type [ty] indicates an access by value, the corresponding memory load is performed. If the type [ty] indicates an access by - reference, the pointer [Vptr b ofs] is returned. *) - -Definition load_value_of_type (ty: type) (m: mem) (b: block) (ofs: int) : option val := - match access_mode ty with - | By_value chunk => Mem.loadv chunk m (Vptr b ofs) - | By_reference => Some (Vptr b ofs) - | By_nothing => None - end. - -(** Symmetrically, [store_value_of_type ty m b ofs v] returns the + reference, the pointer [Vptr b ofs] is returned. [v] is the value + returned, and [t] the trace of observables (nonempty if this is + a volatile access). *) + +Inductive deref_loc {F V: Type} (ge: Genv.t F V) (ty: type) (m: mem) (b: block) (ofs: int) : trace -> val -> Prop := + | deref_loc_value: forall chunk v, + access_mode ty = By_value chunk -> + type_is_volatile ty = false -> + Mem.loadv chunk m (Vptr b ofs) = Some v -> + deref_loc ge ty m b ofs E0 v + | deref_loc_volatile: forall chunk t v, + access_mode ty = By_value chunk -> type_is_volatile ty = true -> + volatile_load ge chunk m b ofs t v -> + deref_loc ge ty m b ofs t v + | deref_loc_reference: + access_mode ty = By_reference -> + deref_loc ge ty m b ofs E0 (Vptr b ofs) + | deref_loc_copy: + access_mode ty = By_copy -> + deref_loc ge ty m b ofs E0 (Vptr b ofs). + +(** Symmetrically, [assign_loc ty m b ofs v t m'] returns the memory state after storing the value [v] in the datum of type [ty] residing in memory [m] at block [b], offset [ofs]. - This is allowed only if [ty] indicates an access by value. *) - -Definition store_value_of_type (ty_dest: type) (m: mem) (loc: block) (ofs: int) (v: val) : option mem := - match access_mode ty_dest with - | By_value chunk => Mem.storev chunk m (Vptr loc ofs) v - | By_reference => None - | By_nothing => None - end. + This is allowed only if [ty] indicates an access by value or by copy. + [m'] is the updated memory state and [t] the trace of observables + (nonempty if this is a volatile store). *) + +Inductive assign_loc {F V: Type} (ge: Genv.t F V) (ty: type) (m: mem) (b: block) (ofs: int): + val -> trace -> mem -> Prop := + | assign_loc_value: forall v chunk m', + access_mode ty = By_value chunk -> + type_is_volatile ty = false -> + Mem.storev chunk m (Vptr b ofs) v = Some m' -> + assign_loc ge ty m b ofs v E0 m' + | assign_loc_volatile: forall v chunk t m', + access_mode ty = By_value chunk -> type_is_volatile ty = true -> + volatile_store ge chunk m b ofs v t m' -> + assign_loc ge ty m b ofs v t m' + | assign_loc_copy: forall b' ofs' bytes m', + access_mode ty = By_copy -> + (alignof ty | Int.unsigned ofs') -> (alignof ty | Int.unsigned ofs) -> + b' <> b \/ Int.unsigned ofs' = Int.unsigned ofs + \/ Int.unsigned ofs' + sizeof ty <= Int.unsigned ofs + \/ Int.unsigned ofs + sizeof ty <= Int.unsigned ofs' -> + Mem.loadbytes m b' (Int.unsigned ofs') (sizeof ty) = Some bytes -> + Mem.storebytes m b (Int.unsigned ofs) bytes = Some m' -> + assign_loc ge ty m b ofs (Vptr b' ofs') E0 m'. (** Allocation of function-local variables. [alloc_variables e1 m1 vars e2 m2] allocates one memory block @@ -541,18 +614,18 @@ Inductive alloc_variables: env -> mem -> in the memory blocks corresponding to the variables [params]. [m1] is the initial memory state and [m2] the final memory state. *) -Inductive bind_parameters: env -> +Inductive bind_parameters {F V: Type} (ge: Genv.t F V) (e: env): mem -> list (ident * type) -> list val -> mem -> Prop := | bind_parameters_nil: - forall e m, - bind_parameters e m nil nil m + forall m, + bind_parameters ge e m nil nil m | bind_parameters_cons: - forall e m id ty params v1 vl b m1 m2, + forall m id ty params v1 vl b m1 m2, PTree.get id e = Some(b, ty) -> - store_value_of_type ty m b Int.zero v1 = Some m1 -> - bind_parameters e m1 params vl m2 -> - bind_parameters e m ((id, ty) :: params) (v1 :: vl) m2. + assign_loc ge ty m b Int.zero v1 E0 m1 -> + bind_parameters ge e m1 params vl m2 -> + bind_parameters ge e m ((id, ty) :: params) (v1 :: vl) m2. (** Return the list of blocks in the codomain of [e], with low and high bounds. *) @@ -624,70 +697,69 @@ Inductive lred: expr -> mem -> expr -> mem -> Prop := | red_deref: forall b ofs ty1 ty m, lred (Ederef (Eval (Vptr b ofs) ty1) ty) m (Eloc b ofs ty) m - | red_field_struct: forall b ofs id fList f ty m delta, + | red_field_struct: forall b ofs id fList a f ty m delta, field_offset f fList = OK delta -> - lred (Efield (Eloc b ofs (Tstruct id fList)) f ty) m + lred (Efield (Eval (Vptr b ofs) (Tstruct id fList a)) f ty) m (Eloc b (Int.add ofs (Int.repr delta)) ty) m - | red_field_union: forall b ofs id fList f ty m, - lred (Efield (Eloc b ofs (Tunion id fList)) f ty) m + | red_field_union: forall b ofs id fList a f ty m, + lred (Efield (Eval (Vptr b ofs) (Tunion id fList a)) f ty) m (Eloc b ofs ty) m. (** Head reductions for r-values *) -Inductive rred: expr -> mem -> expr -> mem -> Prop := - | red_rvalof: forall b ofs ty m v, - load_value_of_type ty m b ofs = Some v -> +Inductive rred: expr -> mem -> trace -> expr -> mem -> Prop := + | red_rvalof: forall b ofs ty m t v, + deref_loc ge ty m b ofs t v -> rred (Evalof (Eloc b ofs ty) ty) m - (Eval v ty) m + t (Eval v ty) m | red_addrof: forall b ofs ty1 ty m, rred (Eaddrof (Eloc b ofs ty1) ty) m - (Eval (Vptr b ofs) ty) m + E0 (Eval (Vptr b ofs) ty) m | red_unop: forall op v1 ty1 ty m v, sem_unary_operation op v1 ty1 = Some v -> rred (Eunop op (Eval v1 ty1) ty) m - (Eval v ty) m + E0 (Eval v ty) m | red_binop: forall op v1 ty1 v2 ty2 ty m v, sem_binary_operation op v1 ty1 v2 ty2 m = Some v -> rred (Ebinop op (Eval v1 ty1) (Eval v2 ty2) ty) m - (Eval v ty) m + E0 (Eval v ty) m | red_cast: forall ty v1 ty1 m v, sem_cast v1 ty1 ty = Some v -> rred (Ecast (Eval v1 ty1) ty) m - (Eval v ty) m + E0 (Eval v ty) m | red_condition: forall v1 ty1 r1 r2 ty b m, bool_val v1 ty1 = Some b -> rred (Econdition (Eval v1 ty1) r1 r2 ty) m - (Eparen (if b then r1 else r2) ty) m + E0 (Eparen (if b then r1 else r2) ty) m | red_sizeof: forall ty1 ty m, rred (Esizeof ty1 ty) m - (Eval (Vint (Int.repr (sizeof ty1))) ty) m - | red_assign: forall b ofs ty1 v2 ty2 m v m', + E0 (Eval (Vint (Int.repr (sizeof ty1))) ty) m + | red_assign: forall b ofs ty1 v2 ty2 m v t m', sem_cast v2 ty2 ty1 = Some v -> - store_value_of_type ty1 m b ofs v = Some m' -> + assign_loc ge ty1 m b ofs v t m' -> rred (Eassign (Eloc b ofs ty1) (Eval v2 ty2) ty1) m - (Eval v ty1) m' - | red_assignop: forall op b ofs ty1 v2 ty2 tyres m v1 v v' m', - load_value_of_type ty1 m b ofs = Some v1 -> - sem_binary_operation op v1 ty1 v2 ty2 m = Some v -> - sem_cast v tyres ty1 = Some v' -> - store_value_of_type ty1 m b ofs v' = Some m' -> + t (Eval v ty1) m' + | red_assignop: forall op b ofs ty1 v2 ty2 tyres m t v1, + deref_loc ge ty1 m b ofs t v1 -> rred (Eassignop op (Eloc b ofs ty1) (Eval v2 ty2) tyres ty1) m - (Eval v' ty1) m' - | red_postincr: forall id b ofs ty m v1 v2 v3 m', - load_value_of_type ty m b ofs = Some v1 -> - sem_incrdecr id v1 ty = Some v2 -> - sem_cast v2 (typeconv ty) ty = Some v3 -> - store_value_of_type ty m b ofs v3 = Some m' -> + t (Eassign (Eloc b ofs ty1) + (Ebinop op (Eval v1 ty1) (Eval v2 ty2) tyres) ty1) m + | red_postincr: forall id b ofs ty m t v1 op, + deref_loc ge ty m b ofs t v1 -> + op = match id with Incr => Oadd | Decr => Osub end -> rred (Epostincr id (Eloc b ofs ty) ty) m - (Eval v1 ty) m' + t (Ecomma (Eassign (Eloc b ofs ty) + (Ebinop op (Eval v1 ty) (Eval (Vint Int.one) type_int32s) (typeconv ty)) + ty) + (Eval v1 ty) ty) m | red_comma: forall v ty1 r2 ty m, typeof r2 = ty -> rred (Ecomma (Eval v ty1) r2 ty) m - r2 m + E0 r2 m | red_paren: forall v1 ty1 ty m v, sem_cast v1 ty1 ty = Some v -> rred (Eparen (Eval v1 ty1) ty) m - (Eval v ty) m. + E0 (Eval v ty) m. (** Head reduction for function calls. (More exactly, identification of function calls that can reduce.) *) @@ -729,7 +801,7 @@ Inductive context: kind -> kind -> (expr -> expr) -> Prop := | ctx_deref: forall k C ty, context k RV C -> context k LV (fun x => Ederef (C x) ty) | ctx_field: forall k C f ty, - context k LV C -> context k LV (fun x => Efield (C x) f ty) + context k RV C -> context k LV (fun x => Efield (C x) f ty) | ctx_rvalof: forall k C ty, context k LV C -> context k RV (fun x => Evalof (C x) ty) | ctx_addrof: forall k C ty, @@ -789,31 +861,31 @@ with contextlist: kind -> (expr -> exprlist) -> Prop := is not immediately stuck if it is a value (of the appropriate kind) or it can reduce (at head or within). *) -Inductive not_imm_stuck: kind -> expr -> mem -> Prop := - | not_stuck_val: forall v ty m, - not_imm_stuck RV (Eval v ty) m - | not_stuck_loc: forall b ofs ty m, - not_imm_stuck LV (Eloc b ofs ty) m - | not_stuck_lred: forall to C e m e' m', +Inductive imm_safe: kind -> expr -> mem -> Prop := + | imm_safe_val: forall v ty m, + imm_safe RV (Eval v ty) m + | imm_safe_loc: forall b ofs ty m, + imm_safe LV (Eloc b ofs ty) m + | imm_safe_lred: forall to C e m e' m', lred e m e' m' -> context LV to C -> - not_imm_stuck to (C e) m - | not_stuck_rred: forall to C e m e' m', - rred e m e' m' -> + imm_safe to (C e) m + | imm_safe_rred: forall to C e m t e' m', + rred e m t e' m' -> context RV to C -> - not_imm_stuck to (C e) m - | not_stuck_callred: forall to C e m fd args ty, + imm_safe to (C e) m + | imm_safe_callred: forall to C e m fd args ty, callred e fd args ty -> context RV to C -> - not_imm_stuck to (C e) m. + imm_safe to (C e) m. (* An expression is not stuck if none of the potential redexes contained within is immediately stuck. *) - +(* Definition not_stuck (e: expr) (m: mem) : Prop := forall k C e' , context k RV C -> e = C e' -> not_imm_stuck k e' m. - +*) End EXPR. (** ** Transition semantics. *) @@ -899,7 +971,8 @@ Inductive state: Type := | Returnstate (**r returning from a function *) (res: val) (k: cont) - (m: mem) : state. + (m: mem) : state + | Stuckstate. (**r undefined behavior occurred *) (** Find the statement and manufacture the continuation corresponding to a label. *) @@ -959,24 +1032,26 @@ Inductive estep: state -> trace -> state -> Prop := | step_lred: forall C f a k e m a' m', lred e a m a' m' -> - not_stuck e (C a) m -> context LV RV C -> estep (ExprState f (C a) k e m) E0 (ExprState f (C a') k e m') - | step_rred: forall C f a k e m a' m', - rred a m a' m' -> - not_stuck e (C a) m -> + | step_rred: forall C f a k e m t a' m', + rred a m t a' m' -> context RV RV C -> estep (ExprState f (C a) k e m) - E0 (ExprState f (C a') k e m') + t (ExprState f (C a') k e m') | step_call: forall C f a k e m fd vargs ty, callred a fd vargs ty -> - not_stuck e (C a) m -> context RV RV C -> estep (ExprState f (C a) k e m) - E0 (Callstate fd vargs (Kcall f e C ty k) m). + E0 (Callstate fd vargs (Kcall f e C ty k) m) + + | step_stuck: forall C f a k e m K, + context K RV C -> ~(imm_safe e K a m) -> + estep (ExprState f (C a) k e m) + E0 Stuckstate. Inductive sstep: state -> trace -> state -> Prop := @@ -1117,7 +1192,7 @@ Inductive sstep: state -> trace -> state -> Prop := | step_internal_function: forall f vargs k m e m1 m2, list_norepet (var_names (fn_params f) ++ var_names (fn_vars f)) -> alloc_variables empty_env m (f.(fn_params) ++ f.(fn_vars)) e m1 -> - bind_parameters e m1 f.(fn_params) vargs m2 -> + bind_parameters ge e m1 f.(fn_params) vargs m2 -> sstep (Callstate (Internal f) vargs k m) E0 (State f f.(fn_body) k e m2) @@ -1148,7 +1223,7 @@ Inductive initial_state (p: program): state -> Prop := Genv.init_mem p = Some m0 -> Genv.find_symbol ge p.(prog_main) = Some b -> Genv.find_funct_ptr ge b = Some f -> - type_of_fundef f = Tfunction Tnil (Tint I32 Signed) -> + type_of_fundef f = Tfunction Tnil type_int32s -> initial_state p (Callstate f nil Kstop m0). (** A final state is a [Returnstate] with an empty continuation. *) @@ -1162,3 +1237,17 @@ Inductive final_state: state -> int -> Prop := Definition semantics (p: program) := Semantics step (initial_state p) final_state (Genv.globalenv p). +(** This semantics has the single-event property. *) + +Lemma semantics_single_events: + forall p, single_events (semantics p). +Proof. + intros; red; intros. destruct H. + set (ge := globalenv (semantics p)) in *. + assert (DEREF: forall chunk m b ofs t v, deref_loc ge chunk m b ofs t v -> (length t <= 1)%nat). + intros. inv H0; simpl; try omega. inv H3; simpl; try omega. + assert (ASSIGN: forall chunk m b ofs t v m', assign_loc ge chunk m b ofs v t m' -> (length t <= 1)%nat). + intros. inv H0; simpl; try omega. inv H3; simpl; try omega. + inv H; simpl; try omega. inv H0; eauto; simpl; try omega. + inv H; simpl; try omega. eapply external_call_trace_length; eauto. +Qed. diff --git a/cfrontend/Csharpminor.v b/cfrontend/Csharpminor.v index a1ed8b3..88eb3c7 100644 --- a/cfrontend/Csharpminor.v +++ b/cfrontend/Csharpminor.v @@ -68,6 +68,7 @@ Inductive stmt : Type := | Sset : ident -> expr -> stmt | Sstore : memory_chunk -> expr -> expr -> stmt | Scall : option ident -> signature -> expr -> list expr -> stmt + | Sbuiltin : option ident -> external_function -> list expr -> stmt | Sseq: stmt -> stmt -> stmt | Sifthenelse: expr -> stmt -> stmt -> stmt | Sloop: stmt -> stmt @@ -84,32 +85,36 @@ with lbl_stmt : Type := (** 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). The only operation - permitted on an array variable is taking its address. *) + 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: memory_chunk -> var_kind - | Varray: Z -> var_kind. + | Vscalar(chunk: memory_chunk) + | Varray(sz al: Z). Definition sizeof (lv: var_kind) : Z := match lv with | Vscalar chunk => size_chunk chunk - | Varray sz => Zmax 0 sz + | 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 memory chunks (parameters must be scalar), a list of - local variables with associated [var_kind] description, and a + with associated [var_kind] descriptions, a list of + local variables with associated [var_kind] descriptions, and a statement representing the function body. *) -Definition param_name (p: ident * memory_chunk) := fst p. -Definition param_chunk (p: ident * memory_chunk) := snd p. Definition variable_name (v: ident * var_kind) := fst v. Definition variable_kind (v: ident * var_kind) := snd v. Record function : Type := mkfunction { fn_return: option typ; - fn_params: list (ident * memory_chunk); + fn_params: list (ident * var_kind); fn_vars: list (ident * var_kind); fn_temps: list ident; fn_body: stmt @@ -120,7 +125,7 @@ Definition fundef := AST.fundef function. Definition program : Type := AST.program fundef var_kind. Definition fn_sig (f: function) := - mksignature (List.map type_of_chunk (List.map param_chunk f.(fn_params))) + mksignature (List.map type_of_kind (List.map variable_kind f.(fn_params))) f.(fn_return). Definition funsig (fd: fundef) := @@ -129,13 +134,9 @@ Definition funsig (fd: fundef) := | External ef => ef_sig ef end. -Definition var_of_param (p: ident * memory_chunk) : ident * var_kind := - (fst p, Vscalar (snd p)). - -Definition fn_variables (f: function) := - List.map var_of_param f.(fn_params) ++ f.(fn_vars). +Definition fn_variables (f: function) := f.(fn_params) ++ f.(fn_vars). -Definition fn_params_names (f: function) := List.map param_name f.(fn_params). +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 *) @@ -292,6 +293,10 @@ Definition block_of_binding (id_b_lv: ident * (block * var_kind)) := Definition blocks_of_env (e: env) : list (block * Z * Z) := List.map block_of_binding (PTree.elements e). +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. *) @@ -300,22 +305,26 @@ Definition val_normalized (v: val) (chunk: memory_chunk) : Prop := Val.load_result chunk v = v. Inductive bind_parameters: env -> - mem -> list (ident * memory_chunk) -> list val -> + mem -> list (ident * var_kind) -> list val -> mem -> Prop := | bind_parameters_nil: forall e m, bind_parameters e m nil nil m - | bind_parameters_cons: + | 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, chunk) :: params) (v1 :: vl) m2. - -Section RELSEM. + 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 (Zmin al 4) + 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. -Variable ge: genv. (* Evaluation of the address of a variable: [eval_var_addr prg ge e id b] states that variable [id] @@ -459,6 +468,12 @@ Inductive step: state -> trace -> state -> Prop := step (State f (Scall optid sig a bl) k e le m) E0 (Callstate fd vargs (Kcall optid f e le k) m) + | step_builtin: forall f optid ef bl k e le m vargs t vres m', + eval_exprlist e le m bl vargs -> + external_call ef ge vargs m t vres m' -> + step (State f (Sbuiltin optid ef bl) k e le m) + t (State f Sskip k e (Cminor.set_optvar optid vres le) m') + | step_seq: forall f s1 s2 k e le m, step (State f (Sseq s1 s2) k e le m) E0 (State f s1 (Kseq s2 k) e le m) diff --git a/cfrontend/Cshmgen.v b/cfrontend/Cshmgen.v index bbd4cfe..c17d79e 100644 --- a/cfrontend/Cshmgen.v +++ b/cfrontend/Cshmgen.v @@ -46,20 +46,21 @@ Definition chunk_of_type (ty: type): res memory_chunk := 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) - | Tfloat F32 => OK(Vscalar Mfloat32) - | Tfloat F64 => OK(Vscalar Mfloat64) + | 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 (Csyntax.sizeof ty)) + | Tpointer _ _ => OK(Vscalar Mint32) + | Tarray _ _ _ => OK(Varray (Csyntax.sizeof ty) (Csyntax.alignof ty)) | Tfunction _ _ => Error (msg "Cshmgen.var_kind_of_type(function)") - | Tstruct _ fList => OK(Varray (Csyntax.sizeof ty)) - | Tunion _ fList => OK(Varray (Csyntax.sizeof ty)) - | Tcomp_ptr _ => OK(Vscalar Mint32) + | Tstruct _ fList _ => OK(Varray (Csyntax.sizeof ty) (Csyntax.alignof ty)) + | Tunion _ fList _ => OK(Varray (Csyntax.sizeof ty) (Csyntax.alignof ty)) + | Tcomp_ptr _ _ => OK(Vscalar Mint32) end. (** * Csharpminor constructors *) @@ -101,7 +102,7 @@ Definition make_intoffloat (e: expr) (sg: signedness) := *) Definition make_boolean (e: expr) (ty: type) := match ty with - | Tfloat _ => Ebinop (Ocmpf Cne) e (make_floatconst Float.zero) + | Tfloat _ _ => Ebinop (Ocmpf Cne) e (make_floatconst Float.zero) | _ => e end. @@ -128,10 +129,10 @@ Definition make_add (e1: expr) (ty1: type) (e2: expr) (ty2: type) := | add_case_ff => OK (Ebinop Oaddf e1 e2) | add_case_if sg => OK (Ebinop Oaddf (make_floatofint e1 sg) e2) | add_case_fi sg => OK (Ebinop Oaddf e1 (make_floatofint e2 sg)) - | add_case_pi ty => + | add_case_pi ty _ => let n := make_intconst (Int.repr (Csyntax.sizeof ty)) in OK (Ebinop Oadd e1 (Ebinop Omul n e2)) - | add_case_ip ty => + | add_case_ip ty _ => let n := make_intconst (Int.repr (Csyntax.sizeof ty)) in OK (Ebinop Oadd e2 (Ebinop Omul n e1)) | add_default => Error (msg "Cshmgen.make_add") @@ -218,6 +219,7 @@ Definition make_cast_int (e: expr) (sz: intsize) (si: signedness) := | I16, Signed => Eunop Ocast16signed e | I16, Unsigned => Eunop Ocast16unsigned e | I32, _ => e + | IBool, _ => Eunop Oboolval e end. Definition make_cast_float (e: expr) (sz: floatsize) := @@ -233,6 +235,10 @@ Definition make_cast (from to: type) (e: expr) := | cast_case_f2f sz2 => make_cast_float e sz2 | cast_case_i2f si1 sz2 => make_cast_float (make_floatofint e si1) sz2 | cast_case_f2i sz2 si2 => make_cast_int (make_intoffloat e si2) sz2 si2 + | cast_case_ip2bool => Eunop Oboolval e + | cast_case_f2bool => Ebinop (Ocmpf Cne) e (make_floatconst Float.zero) + | cast_case_struct id1 fld1 id2 fld2 => e + | cast_case_union id1 fld1 id2 fld2 => e | cast_case_void => e | cast_case_default => e end. @@ -247,10 +253,30 @@ Definition make_load (addr: expr) (ty_res: type) := match (access_mode ty_res) with | By_value chunk => OK (Eload chunk addr) | By_reference => OK addr + | By_copy => OK addr | By_nothing => Error (msg "Cshmgen.make_load") end. -(** [make_store addr ty_res rhs ty_rhs] stores the value of the +(** [make_vol_load dst addr ty] loads a volatile value of type [ty] from + the memory location denoted by the Csharpminor expression [addr], + and stores its result in variable [dst]. *) + +Definition make_vol_load (dst: ident) (addr: expr) (ty: type) := + match (access_mode ty) with + | By_value chunk => OK (Sbuiltin (Some dst) (EF_vload chunk) (addr :: nil)) + | By_reference => OK (Sset dst addr) + | By_copy => OK (Sset dst addr) + | By_nothing => Error (msg "Cshmgen.make_vol_load") + end. + +(** [make_memcpy dst src ty] returns a [memcpy] builtin appropriate for + by-copy assignment of a value of Clight type [ty]. *) + +Definition make_memcpy (dst src: expr) (ty: type) := + Sbuiltin None (EF_memcpy (Csyntax.sizeof ty) (Zmin (Csyntax.alignof ty) 4)) + (dst :: src :: nil). + +(** [make_store addr ty rhs] stores the value of the Csharpminor expression [rhs] into the memory location denoted by the Csharpminor expression [addr]. [ty] is the type of the memory location. *) @@ -258,6 +284,17 @@ Definition make_load (addr: expr) (ty_res: type) := Definition make_store (addr: expr) (ty: type) (rhs: expr) := match access_mode ty with | By_value chunk => OK (Sstore chunk addr rhs) + | By_copy => OK (make_memcpy addr rhs ty) + | _ => Error (msg "Cshmgen.make_store") + end. + +(** [make_vol_store] is similar, but for a store to a location that + can be volatile. *) + +Definition make_vol_store (addr: expr) (ty: type) (rhs: expr) := + match access_mode ty with + | By_value chunk => OK (Sbuiltin None (EF_vstore chunk) (addr :: rhs :: nil)) + | By_copy => OK (make_memcpy addr rhs ty) | _ => Error (msg "Cshmgen.make_store") end. @@ -282,6 +319,7 @@ 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. @@ -292,6 +330,7 @@ Definition var_get (id: ident) (ty: type) := 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. @@ -368,14 +407,14 @@ Fixpoint transl_expr (a: Clight.expr) {struct a} : res expr := OK(make_intconst (Int.repr (Csyntax.sizeof ty))) | Clight.Efield b i ty => match typeof b with - | Tstruct _ fld => - do tb <- transl_lvalue b; + | Tstruct _ fld _ => + do tb <- transl_expr b; do ofs <- field_offset i fld; make_load (Ebinop Oadd tb (make_intconst (Int.repr ofs))) ty - | Tunion _ fld => - do tb <- transl_lvalue b; + | Tunion _ fld _ => + do tb <- transl_expr b; make_load tb ty | _ => Error(msg "Cshmgen.transl_expr(field)") @@ -395,12 +434,12 @@ with transl_lvalue (a: Clight.expr) {struct a} : res expr := transl_expr b | Clight.Efield b i ty => match typeof b with - | Tstruct _ fld => - do tb <- transl_lvalue b; + | Tstruct _ fld _ => + do tb <- transl_expr b; do ofs <- field_offset i fld; OK (Ebinop Oadd tb (make_intconst (Int.repr ofs))) - | Tunion _ fld => - transl_lvalue b + | Tunion _ fld _ => + transl_expr b | _ => Error(msg "Cshmgen.transl_lvalue(field)") end @@ -503,7 +542,11 @@ Fixpoint transl_statement (tyret: type) (nbrk ncnt: nat) | Clight.Sskip => OK Sskip | Clight.Sassign b c => - match is_variable b with + if type_is_volatile (typeof b) then + (do tb <- transl_lvalue b; + do tc <- transl_expr c; + make_vol_store tb (typeof b) (make_cast (typeof c) (typeof b) tc)) + else match is_variable b with | Some id => do tc <- transl_expr c; var_set id (typeof b) (make_cast (typeof c) (typeof b) tc) @@ -515,6 +558,9 @@ Fixpoint transl_statement (tyret: type) (nbrk ncnt: nat) | Clight.Sset x b => do tb <- transl_expr b; OK(Sset x tb) + | Clight.Svolread x b => + do tb <- transl_lvalue b; + make_vol_load x tb (typeof b) | Clight.Scall x b cl => match classify_fun (typeof b) with | fun_case_f args res => @@ -583,13 +629,11 @@ with transl_lbl_stmt (tyret: type) (nbrk ncnt: nat) Definition prefix_var_name (id: ident) : errmsg := MSG "In local variable " :: CTX id :: MSG ": " :: nil. -Definition transl_params (l: list (ident * type)) := - AST.map_partial prefix_var_name chunk_of_type l. Definition transl_vars (l: list (ident * type)) := AST.map_partial prefix_var_name var_kind_of_type l. Definition transl_function (f: Clight.function) : res function := - do tparams <- transl_params (Clight.fn_params f); + 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 diff --git a/cfrontend/Cshmgenproof.v b/cfrontend/Cshmgenproof.v index 0f7810d..1089b6b 100644 --- a/cfrontend/Cshmgenproof.v +++ b/cfrontend/Cshmgenproof.v @@ -32,27 +32,24 @@ Require Import Cshmgen. (** * Properties of operations over types *) -Remark type_of_chunk_of_type: - forall ty chunk, - chunk_of_type ty = OK chunk -> - type_of_chunk chunk = typ_of_type ty. +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. unfold chunk_of_type in H. destruct ty; simpl in H; try monadInv H. - destruct i; destruct s; monadInv H; reflexivity. - destruct f; monadInv H; reflexivity. - reflexivity. + 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_params p = OK tp -> - map type_of_chunk (map param_chunk tp) = typlist_of_typelist (type_of_params p). + transl_vars p = OK tp -> + map type_of_kind (map variable_kind tp) = typlist_of_typelist (type_of_params p). Proof. induction p; simpl; intros. inv H. auto. - destruct a as [id ty]. generalize H; clear H. case_eq (chunk_of_type ty); intros. - monadInv H0. simpl. f_equal; auto. apply type_of_chunk_of_type; auto. - inv H0. + 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. Qed. Lemma transl_fundef_sig1: @@ -93,13 +90,24 @@ Proof. destruct f; congruence. Qed. +Lemma var_kind_by_reference: + forall ty vk, + access_mode ty = By_reference \/ access_mode ty = By_copy -> + var_kind_of_type ty = OK vk -> + vk = Varray (Csyntax.sizeof ty) (Csyntax.alignof ty). +Proof. + intros ty vk; destruct ty; simpl; try intuition congruence. + destruct i; try congruence; destruct s; intuition congruence. + destruct f; intuition congruence. +Qed. + Lemma sizeof_var_kind_of_type: forall ty vk, var_kind_of_type ty = OK vk -> Csharpminor.sizeof vk = Csyntax.sizeof ty. Proof. intros ty vk. - assert (sizeof (Varray (Csyntax.sizeof ty)) = Csyntax.sizeof ty). + assert (sizeof (Varray (Csyntax.sizeof ty) (Csyntax.alignof ty)) = Csyntax.sizeof ty). simpl. rewrite Zmax_spec. apply zlt_false. generalize (Csyntax.sizeof_pos ty). omega. destruct ty; try (destruct i; try destruct s); try (destruct f); @@ -107,8 +115,8 @@ Proof. Qed. Remark cast_int_int_normalized: - forall sz si chunk n, - access_mode (Tint sz si) = By_value chunk -> + forall sz si a chunk n, + access_mode (Tint sz si a) = By_value chunk -> val_normalized (Vint (cast_int_int sz si n)) chunk. Proof. unfold access_mode, cast_int_int, val_normalized; intros. destruct sz. @@ -119,11 +127,12 @@ Proof. rewrite Int.sign_ext_idem; auto. compute; auto. rewrite Int.zero_ext_idem; auto. compute; auto. inv H. auto. + inv H. destruct (Int.eq n Int.zero); auto. Qed. Remark cast_float_float_normalized: - forall sz chunk n, - access_mode (Tfloat sz) = By_value chunk -> + forall sz a chunk n, + access_mode (Tfloat sz a) = By_value chunk -> val_normalized (Vfloat (cast_float_float sz n)) chunk. Proof. unfold access_mode, cast_float_float, val_normalized; intros. @@ -154,6 +163,16 @@ Proof. functional inversion H2; subst. eapply cast_float_float_normalized; eauto. functional inversion H2; subst. eapply cast_float_float_normalized; eauto. functional inversion H2; subst. eapply cast_int_int_normalized; eauto. + assert (chunk = Mint8unsigned). + functional inversion H2; subst; simpl in H0; try congruence. + subst chunk. destruct (Int.eq i Int.zero); red; auto. + assert (chunk = Mint8unsigned). + functional inversion H2; subst; simpl in H0; try congruence. + subst chunk. red; auto. + functional inversion H2; subst. simpl in H0. inv H0. red; auto. + functional inversion H2; subst. simpl in H0. inv H0. red; auto. + functional inversion H2; subst. simpl in H0. congruence. + functional inversion H2; subst. simpl in H0. congruence. functional inversion H5; subst. simpl in H0. congruence. Qed. @@ -213,14 +232,6 @@ Proof. inv H0. rewrite (IHl1 _ _ _ H H1). auto. Qed. -Lemma transl_params_names: - forall vars tvars, - transl_params vars = OK tvars -> - List.map param_name tvars = var_names vars. -Proof. - exact (map_partial_names _ _ chunk_of_type). -Qed. - Lemma transl_vars_names: forall vars tvars, transl_vars vars = OK tvars -> @@ -232,13 +243,13 @@ Qed. Lemma transl_names_norepet: forall params vars sg tparams tvars temps body, list_norepet (var_names params ++ var_names vars) -> - transl_params params = OK tparams -> + 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, f. simpl. - rewrite (transl_params_names _ _ H0). + intros. unfold fn_params_names, fn_vars_names; simpl. + rewrite (transl_vars_names _ _ H0). rewrite (transl_vars_names _ _ H1). auto. Qed. @@ -251,33 +262,15 @@ Proof. exact (map_partial_append _ _ var_kind_of_type). Qed. -Lemma transl_params_vars: - forall params tparams, - transl_params params = OK tparams -> - transl_vars params = - OK (List.map (fun id_chunk => (fst id_chunk, Vscalar (snd id_chunk))) tparams). -Proof. - induction params; intro tparams; simpl. - intros. inversion H. reflexivity. - destruct a as [id x]. - unfold chunk_of_type. caseEq (access_mode x); try congruence. - intros chunk AM. - caseEq (transl_params params); simpl; intros; try congruence. - inv H0. - rewrite (var_kind_by_value _ _ AM). - rewrite (IHparams _ H). reflexivity. -Qed. - Lemma transl_fn_variables: forall params vars sg tparams tvars temps body, - transl_params params = OK tparams -> + 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. - generalize (transl_params_vars _ _ H); intro. - rewrite (transl_vars_append _ _ _ _ H1 H0). + rewrite (transl_vars_append _ _ _ _ H H0). reflexivity. Qed. @@ -300,16 +293,20 @@ Lemma transl_expr_lvalue: (exists tb, transl_lvalue a = OK tb /\ make_load tb (typeof a) = OK ta). Proof. - intros. inversion H; subst; clear H; simpl in H0. + intros until ta; intros EVAL TR. inv EVAL. + (* var local *) left; exists id; exists ty; auto. + (* var global *) left; exists id; exists ty; auto. - monadInv H0. right. exists x; split; auto. - rewrite H2 in H0. monadInv H0. right. - exists (Ebinop Oadd x (make_intconst (Int.repr x0))). split; auto. - simpl. rewrite H2. rewrite EQ. rewrite EQ1. auto. - rewrite H2 in H0. monadInv H0. right. - exists x; split; auto. - simpl. rewrite H2. auto. + (* deref *) + monadInv TR. right. exists x; split; auto. + (* field struct *) + simpl in TR. rewrite H0 in TR. monadInv TR. + right. 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. Qed. (** Properties of labeled statements *) @@ -389,6 +386,7 @@ Proof. destruct si; eauto with cshm. destruct si; eauto with cshm. auto. + econstructor. eauto. simpl. destruct (Int.eq n Int.zero); auto. Qed. Lemma make_cast_float_correct: @@ -420,7 +418,19 @@ Proof. rewrite H2. auto with cshm. (* float -> int *) rewrite H2. eauto with cshm. - (* void *) + (* int/pointer -> bool *) + rewrite H2. econstructor; eauto. simpl. destruct (Int.eq i Int.zero); auto. + rewrite H2. econstructor; eauto. + (* float -> bool *) + rewrite H2. econstructor; eauto with cshm. + simpl. unfold Val.cmpf, Val.cmpf_bool. rewrite Float.cmp_ne_eq. rewrite H7; auto. + rewrite H2. econstructor; eauto with cshm. + simpl. unfold Val.cmpf, Val.cmpf_bool. rewrite Float.cmp_ne_eq. rewrite H7; auto. + (* struct -> struct *) + rewrite H2. auto. + (* union -> union *) + rewrite H2. auto. + (* any -> void *) rewrite H5. auto. Qed. @@ -439,6 +449,10 @@ Proof. intros. functional inversion H0; subst; simpl. exists (Vint n); split; auto. exists (Vint n); split; auto. + exists (Vint n); split; auto. + exists (Vint n); split; auto. + exists (Vptr b0 ofs); split; auto. constructor. + exists (Vptr b0 ofs); split; auto. constructor. exists (Vptr b0 ofs); split; auto. constructor. exists (Vptr b0 ofs); split; auto. constructor. rewrite <- Float.cmp_ne_eq. @@ -670,31 +684,128 @@ Lemma make_load_correct: forall addr ty code b ofs v e le m, make_load addr ty = OK code -> eval_expr ge e le m addr (Vptr b ofs) -> - load_value_of_type ty m b ofs = Some v -> + deref_loc ge ty m b ofs E0 v -> + type_is_volatile ty = false -> eval_expr ge e le m code v. Proof. - unfold make_load, load_value_of_type. - intros until m; intros MKLOAD EVEXP LDVAL. - destruct (access_mode ty); inversion MKLOAD. - (* access_mode ty = By_value m *) - apply eval_Eload with (Vptr b ofs); auto. - (* access_mode ty = By_reference *) - subst code. inversion LDVAL. auto. + unfold make_load; intros until m; intros MKLOAD EVEXP DEREF NONVOL. + inv DEREF. + (* nonvolatile scalar *) + rewrite H in MKLOAD. inv MKLOAD. apply eval_Eload with (Vptr b ofs); auto. + (* volatile scalar *) + congruence. + (* by reference *) + rewrite H in MKLOAD. inv MKLOAD. auto. + (* by copy *) + rewrite H in MKLOAD. inv MKLOAD. auto. +Qed. + +Lemma make_vol_load_correct: + forall id addr ty code b ofs t v e le m f k, + make_vol_load id addr ty = OK code -> + eval_expr ge e le m addr (Vptr b ofs) -> + deref_loc ge ty m b ofs t v -> + type_is_volatile ty = true -> + step ge (State f code k e le m) t (State f Sskip k e (PTree.set id v le) m). +Proof. + unfold make_vol_load; intros until k; intros MKLOAD EVEXP DEREF VOL. + inv DEREF. + (* nonvolatile scalar *) + congruence. +(** + rewrite H in MKLOAD. inv MKLOAD. + change (PTree.set id v le) with (Cminor.set_optvar (Some id) v le). + econstructor. constructor. eauto. constructor. constructor; auto. constructor; auto. +*) + (* volatile scalar *) + rewrite H in MKLOAD. inv MKLOAD. + change (PTree.set id v le) with (Cminor.set_optvar (Some id) v le). + econstructor. constructor. eauto. constructor. constructor; auto. + (* by reference *) + rewrite H in MKLOAD. inv MKLOAD. constructor; auto. + (* by copy *) + rewrite H in MKLOAD. inv MKLOAD. constructor; auto. +Qed. + +Remark capped_alignof_divides: + forall ty n, + (alignof ty | n) -> (Zmin (alignof ty) 4 | n). +Proof. + intros. generalize (alignof_1248 ty). + intros [A|[A|[A|A]]]; rewrite A in *; auto. + apply Zdivides_trans with 8; auto. exists 2; auto. Qed. +Remark capped_alignof_124: + forall ty, + Zmin (alignof ty) 4 = 1 \/ Zmin (alignof ty) 4 = 2 \/ Zmin (alignof ty) 4 = 4. +Proof. + intros. generalize (alignof_1248 ty). + intros [A|[A|[A|A]]]; rewrite A; auto. +Qed. + +Lemma make_memcpy_correct: + forall f dst src ty k e le m b ofs v t m', + eval_expr ge e le m dst (Vptr b ofs) -> + eval_expr ge e le m src v -> + assign_loc ge ty m b ofs v t m' -> + access_mode ty = By_copy -> + step ge (State f (make_memcpy dst src ty) k e le m) t (State f Sskip k e le m'). +Proof. + intros. inv H1; try congruence. + unfold make_memcpy. change le with (set_optvar None Vundef le) at 2. + econstructor. + econstructor. eauto. econstructor. eauto. constructor. + econstructor; eauto. + apply capped_alignof_124. + apply sizeof_pos. + apply capped_alignof_divides. apply sizeof_alignof_compat. + apply capped_alignof_divides; auto. + apply capped_alignof_divides; auto. +Qed. + Lemma make_store_correct: - forall addr ty rhs code e le m b ofs v m' f k, + forall addr ty rhs code e le m b ofs v t m' f k, make_store addr ty rhs = OK code -> eval_expr ge e le m addr (Vptr b ofs) -> eval_expr ge e le m rhs v -> - store_value_of_type ty m b ofs v = Some m' -> - step ge (State f code k e le m) E0 (State f Sskip k e le m'). + assign_loc ge ty m b ofs v t m' -> + type_is_volatile ty = false -> + step ge (State f code k e le m) t (State f Sskip k e le m'). +Proof. + unfold make_store. intros until k; intros MKSTORE EV1 EV2 ASSIGN NONVOL. + inversion ASSIGN; subst. + (* nonvolatile scalar *) + rewrite H in MKSTORE; inv MKSTORE. + econstructor; eauto. + (* volatile scalar *) + congruence. + (* by copy *) + rewrite H in MKSTORE; inv MKSTORE. + eapply make_memcpy_correct; eauto. +Qed. + +Lemma make_vol_store_correct: + forall addr ty rhs code e le m b ofs v t m' f k, + make_vol_store addr ty rhs = OK code -> + eval_expr ge e le m addr (Vptr b ofs) -> + eval_expr ge e le m rhs v -> + assign_loc ge ty m b ofs v t m' -> + type_is_volatile ty = true -> + step ge (State f code k e le m) t (State f Sskip k e le m'). Proof. - unfold make_store, store_value_of_type. - intros until k; intros MKSTORE EV1 EV2 STVAL. - destruct (access_mode ty); inversion MKSTORE. - (* access_mode ty = By_value m *) - eapply step_store; eauto. + unfold make_vol_store. intros until k; intros MKSTORE EV1 EV2 ASSIGN VOL. + inversion ASSIGN; subst. + (* nonvolatile scalar *) + congruence. + (* volatile scalar *) + rewrite H in MKSTORE; inv MKSTORE. + change le with (Cminor.set_optvar None Vundef le) at 2. + econstructor. constructor. eauto. constructor. eauto. constructor. + constructor. auto. + (* by copy *) + rewrite H in MKSTORE; inv MKSTORE. + eapply make_memcpy_correct; eauto. Qed. End CONSTRUCTORS. @@ -732,6 +843,49 @@ Lemma var_info_translated: 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 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 transl_globvar _ TRANSL). + +Lemma block_is_volatile_preserved: + forall b, block_is_volatile tge b = block_is_volatile ge b. +Proof. + intros. unfold block_is_volatile. + destruct (Genv.find_var_info ge b) as []_eqn. + exploit var_info_translated; eauto. intros [tv [A B]]. rewrite A. + unfold transf_globvar in B. monadInv B. auto. + destruct (Genv.find_var_info tge b) as []_eqn. + exploit var_info_rev_translated; eauto. intros [tv [A B]]. congruence. + auto. +Qed. + +Lemma deref_loc_preserved: + forall ty m b ofs t v, + deref_loc ge ty m b ofs t v -> deref_loc tge ty m b ofs t v. +Proof. + intros. inv H. + eapply deref_loc_value; eauto. + eapply deref_loc_volatile; eauto. + eapply volatile_load_preserved with (ge1 := ge); auto. + exact symbols_preserved. exact block_is_volatile_preserved. + eapply deref_loc_reference; eauto. + eapply deref_loc_copy; eauto. +Qed. + +Lemma assign_loc_preserved: + forall ty m b ofs v t m', + assign_loc ge ty m b ofs v t m' -> assign_loc tge ty m b ofs v t m'. +Proof. + intros. inv H. + eapply assign_loc_value; eauto. + eapply assign_loc_volatile; eauto. + eapply volatile_store_preserved with (ge1 := ge); auto. + exact symbols_preserved. exact block_is_volatile_preserved. + eapply assign_loc_copy; eauto. +Qed. + (** * Matching between environments *) (** In this section, we define a matching relation between @@ -861,32 +1015,43 @@ Qed. Lemma bind_parameters_match: forall e m1 vars vals m2, - Csem.bind_parameters e m1 vars vals m2 -> + Csem.bind_parameters ge e m1 vars vals m2 -> forall te tvars, val_casted_list vals (type_of_params vars) -> match_env e te -> - transl_params vars = OK tvars -> - Csharpminor.bind_parameters te m1 tvars vals m2. + 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. - revert H4; simpl. - caseEq (chunk_of_type ty); simpl; [intros chunk CHK | congruence]. - caseEq (transl_params params); simpl; [intros tparams TPARAMS | congruence]. - intro EQ; inversion EQ; clear EQ; subst tvars. - generalize CHK. unfold chunk_of_type. - caseEq (access_mode ty); intros; try discriminate. - inversion CHK0; clear CHK0; subst m0. - unfold store_value_of_type in H0. rewrite H4 in H0. - apply bind_parameters_cons with b m1. - exploit me_local; eauto. intros [vk [A B]]. - exploit var_kind_by_value; eauto. congruence. + simpl in H4. destruct (var_kind_of_type ty) as [vk|]_eqn; monadInv H4. + assert (A: (exists chunk, access_mode ty = By_value chunk /\ Mem.store chunk m b 0 v1 = Some m1) + \/ access_mode ty = By_copy). + inv H0; auto; left; econstructor; split; eauto. inv H7. auto. + destruct A as [[chunk [MODE STORE]] | MODE]. + (* 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. + (* array case *) + inv H0; try congruence. + 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 capped_alignof_124. + apply sizeof_pos. + apply capped_alignof_divides. apply sizeof_alignof_compat. + apply capped_alignof_divides; auto. + apply capped_alignof_divides; auto. + apply IHbind_parameters; auto. Qed. (* ** Correctness of variable accessors *) @@ -896,16 +1061,21 @@ Qed. 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 -> - load_value_of_type ty m loc ofs = Some v -> + deref_loc ge ty m loc ofs E0 v -> var_get id ty = OK code -> match_env e te -> eval_expr tge te le m code v. Proof. - intros. revert H0 H1. unfold load_value_of_type, var_get. - case_eq (access_mode ty). + unfold var_get; intros. + destruct (access_mode ty) as [chunk| | | ]_eqn. (* access mode By_value *) - intros chunk ACC LOAD EQ. inv EQ. - inv H. + assert (Mem.loadv chunk m (Vptr loc ofs) = Some v). + inv H0. + congruence. + inv H5. simpl. congruence. + congruence. + congruence. + inv H1. inv H. (* local variable *) exploit me_local; eauto. intros [vk [A B]]. assert (vk = Vscalar chunk). @@ -922,7 +1092,20 @@ Proof. eauto. eauto. assumption. (* access mode By_reference *) - intros ACC EQ1 EQ2. inv EQ1; inv EQ2; inv H. + assert (v = Vptr loc ofs). inv H0; congruence. + 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 *) + assert (v = Vptr loc ofs). inv H0; congruence. + inv H1. inv H. (* local variable *) exploit me_local; eauto. intros [vk [A B]]. eapply eval_Eaddrof. @@ -939,19 +1122,19 @@ 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, + forall e le m id ty loc ofs v t m' code te rhs f k, Clight.eval_lvalue ge e le m (Clight.Evar id ty) loc ofs -> val_casted v ty -> - store_value_of_type ty m loc ofs v = Some m' -> + assign_loc ge ty m loc ofs v t m' -> + type_is_volatile ty = false -> 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'). + step tge (State f code k te le m) t (State f Sskip k te le m'). Proof. - intros. revert H1 H2. unfold store_value_of_type, var_set. - caseEq (access_mode ty). - (* access mode By_value *) - intros chunk ACC STORE EQ. inv EQ. + intros. unfold var_set in H3. + inversion H1; subst; rewrite H6 in H3; inv H3. + (* scalar, non volatile *) inv H. (* local variable *) exploit me_local; eauto. intros [vk [A B]]. @@ -968,65 +1151,20 @@ Proof. econstructor. eapply eval_var_ref_global. auto. rewrite symbols_preserved. eauto. eauto. eauto. - eapply val_casted_normalized; eauto. assumption. - (* access mode By_reference *) - congruence. - (* access mode By_nothing *) + eapply val_casted_normalized; eauto. assumption. + (* scalar, volatile *) congruence. + (* array *) + 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. eapply assign_loc_preserved; eauto. Qed. -(**************************** -Lemma call_dest_correct: - forall e m lhs loc ofs optid te, - Csem.eval_lvalue ge e m lhs loc ofs -> - transl_lhs_call (Some lhs) = OK optid -> - match_env e te -> - exists id, - optid = Some id - /\ ofs = Int.zero - /\ match access_mode (typeof lhs) with - | By_value chunk => eval_var_ref tge te id loc chunk - | _ => True - end. -Proof. - intros. revert H0. simpl. caseEq (is_variable lhs); try congruence. - intros id ISV EQ. inv EQ. - exploit is_variable_correct; eauto. intro EQ. - rewrite EQ in H. clear EQ. - exists id. split; auto. - inv H. -(* local variable *) - split. auto. - exploit me_local; eauto. intros [vk [A B]]. - case_eq (access_mode (typeof lhs)); intros; auto. - assert (vk = Vscalar m0). - exploit var_kind_by_value; eauto. congruence. - subst vk. apply eval_var_ref_local; auto. -(* global variable *) - split. auto. - exploit match_env_globals; eauto. intros [A B]. - case_eq (access_mode (typeof lhs)); intros; auto. - exploit B; eauto. intros [gv [C D]]. - eapply eval_var_ref_global; eauto. - rewrite symbols_preserved. auto. -Qed. - -Lemma set_call_dest_correct: - forall ty m loc v m' e te id, - store_value_of_type ty m loc Int.zero v = Some m' -> - match access_mode ty with - | By_value chunk => eval_var_ref tge te id loc chunk - | _ => True - end -> - match_env e te -> - exec_opt_assign tge te m (Some id) v m'. -Proof. - intros. generalize H. unfold store_value_of_type. case_eq (access_mode ty); intros; try congruence. - rewrite H2 in H0. - constructor. econstructor. eauto. auto. -Qed. -**************************) - (** * Proof of semantic preservation *) (** ** Semantic preservation for expressions *) @@ -1097,7 +1235,7 @@ Proof. (* Case a is a variable *) subst a. eapply var_get_correct; eauto. (* Case a is another lvalue *) - eapply make_load_correct; eauto. + eapply make_load_correct; eauto. eapply deref_loc_preserved; eauto. (* var local *) exploit (me_local _ _ MENV); eauto. intros [vk [A B]]. @@ -1352,11 +1490,17 @@ Proof. (* skip *) auto. (* assign *) - simpl in TR. destruct (is_variable e); monadInv TR. - unfold var_set in EQ0. destruct (access_mode (typeof e)); inv EQ0. auto. - unfold make_store in EQ2. destruct (access_mode (typeof e)); inv EQ2. auto. + simpl in TR. destruct (type_is_volatile (typeof e)) as []_eqn. + monadInv TR. unfold make_vol_store, make_memcpy in EQ2. + destruct (access_mode (typeof e)); inv EQ2; auto. + 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 *) auto. +(* vol load *) + unfold make_vol_load in EQ0. destruct (access_mode (typeof e)); inv EQ0; auto. (* call *) simpl in TR. destruct (classify_fun (typeof e)); monadInv TR. auto. (* seq *) @@ -1451,25 +1595,39 @@ Proof. induction 1; intros T1 MST; inv MST. (* assign *) - revert TR. simpl. case_eq (is_variable a1); intros; monadInv TR. - exploit is_variable_correct; eauto. intro EQ1. rewrite EQ1 in H. - assert (ts' = ts /\ tk' = tk). + simpl in TR. destruct (type_is_volatile (typeof a1)) as []_eqn. + (* Case 1: volatile *) + monadInv TR. + assert (SAME: ts' = ts /\ tk' = tk). + inversion MTR. auto. + subst ts. unfold make_vol_store, make_memcpy in EQ2. + destruct (access_mode (typeof a1)); congruence. + destruct SAME; subst ts' tk'. + econstructor; split. + apply plus_one. eapply make_vol_store_correct; eauto. + eapply transl_lvalue_correct; eauto. eapply make_cast_correct; eauto. + eapply transl_expr_correct; eauto. eapply assign_loc_preserved; eauto. + eapply match_states_skip; eauto. + (* Case 2: variable *) + destruct (is_variable a1) as []_eqn; monadInv TR. + assert (SAME: ts' = ts /\ tk' = tk). inversion MTR. auto. - subst ts. unfold var_set in EQ0. destruct (access_mode (typeof a1)); congruence. - destruct H4; subst ts' tk'. + 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. - - assert (ts' = ts /\ tk' = tk). + (* Case 3: everything else *) + assert (SAME: ts' = ts /\ tk' = tk). inversion MTR. auto. - subst ts. unfold make_store in EQ2. destruct (access_mode (typeof a1)); congruence. - destruct H4; subst ts' tk'. + subst ts. unfold make_store, make_memcpy in EQ2. destruct (access_mode (typeof a1)); congruence. + destruct SAME; subst ts' tk'. econstructor; split. apply plus_one. eapply make_store_correct; eauto. - exploit transl_lvalue_correct; eauto. - eapply make_cast_correct; eauto. eapply transl_expr_correct; eauto. + eapply transl_lvalue_correct; eauto. eapply make_cast_correct; eauto. + eapply transl_expr_correct; eauto. eapply assign_loc_preserved; eauto. eapply match_states_skip; eauto. (* set *) @@ -1477,6 +1635,17 @@ Proof. apply plus_one. econstructor. eapply transl_expr_correct; eauto. eapply match_states_skip; eauto. +(* vol read *) + monadInv TR. + assert (SAME: ts' = ts /\ tk' = tk). + inversion MTR. auto. + subst ts. unfold make_vol_load in EQ0. destruct (access_mode (typeof a)); congruence. + destruct SAME; subst ts' tk'. + econstructor; split. + apply plus_one. eapply make_vol_load_correct; eauto. eapply transl_lvalue_correct; eauto. + eapply deref_loc_preserved; eauto. + eapply match_states_skip; eauto. + (* call *) revert TR. simpl. case_eq (classify_fun (typeof a)); try congruence. intros targs tres CF TR. monadInv TR. inv MTR. @@ -1759,8 +1928,8 @@ Proof. monadInv TR. monadInv EQ. exploit match_cont_is_call_cont; eauto. intros [A B]. exploit match_env_alloc_variables; eauto. - apply match_env_empty. - apply transl_fn_variables. eauto. eauto. + apply match_env_empty. + eapply transl_fn_variables; eauto. intros [te1 [C D]]. econstructor; split. apply plus_one. econstructor. @@ -1806,7 +1975,7 @@ Proof. rewrite symbols_preserved. replace (prog_main tprog) with (prog_main prog). auto. symmetry. unfold transl_program in TRANSL. eapply transform_partial_program2_main; eauto. - assert (funsig tf = signature_of_type Tnil (Tint I32 Signed)). + assert (funsig tf = signature_of_type Tnil type_int32s). eapply transl_fundef_sig2; eauto. econstructor; split. econstructor; eauto. eapply Genv.init_mem_transf_partial2; eauto. diff --git a/cfrontend/Cstrategy.v b/cfrontend/Cstrategy.v index 8b66ef9..e088c26 100644 --- a/cfrontend/Cstrategy.v +++ b/cfrontend/Cstrategy.v @@ -49,9 +49,9 @@ Fixpoint simple (a: expr) : Prop := | Eloc _ _ _ => True | Evar _ _ => True | Ederef r _ => simple r - | Efield l1 _ _ => simple l1 + | Efield r _ _ => simple r | Eval _ _ => True - | Evalof l _ => simple l + | Evalof l _ => simple l /\ type_is_volatile (typeof l) = false | Eaddrof l _ => simple l | Eunop _ r1 _ => simple r1 | Ebinop _ r1 r2 _ => simple r1 /\ simple r2 @@ -93,22 +93,22 @@ Inductive eval_simple_lvalue: expr -> block -> int -> Prop := | esl_deref: forall r ty b ofs, eval_simple_rvalue r (Vptr b ofs) -> eval_simple_lvalue (Ederef r ty) b ofs - | esl_field_struct: forall l f ty b ofs id fList delta, - eval_simple_lvalue l b ofs -> - typeof l = Tstruct id fList -> field_offset f fList = OK delta -> - eval_simple_lvalue (Efield l f ty) b (Int.add ofs (Int.repr delta)) - | esl_field_union: forall l f ty b ofs id fList, - eval_simple_lvalue l b ofs -> - typeof l = Tunion id fList -> - eval_simple_lvalue (Efield l f ty) b ofs + | esl_field_struct: forall r f ty b ofs id fList a delta, + eval_simple_rvalue r (Vptr b ofs) -> + typeof r = Tstruct id fList a -> field_offset f fList = OK delta -> + eval_simple_lvalue (Efield r f ty) b (Int.add ofs (Int.repr delta)) + | esl_field_union: forall r f ty b ofs id fList a, + eval_simple_rvalue r (Vptr b ofs) -> + typeof r = Tunion id fList a -> + eval_simple_lvalue (Efield r f ty) b ofs with eval_simple_rvalue: expr -> val -> Prop := | esr_val: forall v ty, eval_simple_rvalue (Eval v ty) v | esr_rvalof: forall b ofs l ty v, eval_simple_lvalue l b ofs -> - ty = typeof l -> - load_value_of_type ty m b ofs = Some v -> + ty = typeof l -> type_is_volatile ty = false -> + deref_loc ge ty m b ofs E0 v -> eval_simple_rvalue (Evalof l ty) v | esr_addrof: forall b ofs l ty, eval_simple_lvalue l b ofs -> @@ -151,7 +151,7 @@ Inductive leftcontext: kind -> kind -> (expr -> expr) -> Prop := | lctx_deref: forall k C ty, leftcontext k RV C -> leftcontext k LV (fun x => Ederef (C x) ty) | lctx_field: forall k C f ty, - leftcontext k LV C -> leftcontext k LV (fun x => Efield (C x) f ty) + leftcontext k RV C -> leftcontext k LV (fun x => Efield (C x) f ty) | lctx_rvalof: forall k C ty, leftcontext k LV C -> leftcontext k RV (fun x => Evalof (C x) ty) | lctx_addrof: forall k C ty, @@ -222,6 +222,14 @@ Inductive estep: state -> trace -> state -> Prop := estep (ExprState f r k e m) E0 (ExprState f (Eval v ty) k e m) + | step_rvalof_volatile: forall f C l ty k e m b ofs t v, + leftcontext RV RV C -> + eval_simple_lvalue e m l b ofs -> + deref_loc ge ty m b ofs t v -> + ty = typeof l -> type_is_volatile ty = true -> + estep (ExprState f (C (Evalof l ty)) k e m) + t (ExprState f (C (Eval v ty)) k e m) + | step_condition: forall f C r1 r2 r3 ty k e m v b, leftcontext RV RV C -> eval_simple_rvalue e m r1 v -> @@ -229,38 +237,73 @@ Inductive estep: state -> trace -> state -> Prop := estep (ExprState f (C (Econdition r1 r2 r3 ty)) k e m) E0 (ExprState f (C (Eparen (if b then r2 else r3) ty)) k e m) - | step_assign: forall f C l r ty k e m b ofs v v' m', + | step_assign: forall f C l r ty k e m b ofs v v' t m', leftcontext RV RV C -> eval_simple_lvalue e m l b ofs -> eval_simple_rvalue e m r v -> sem_cast v (typeof r) (typeof l) = Some v' -> - store_value_of_type (typeof l) m b ofs v' = Some m' -> + assign_loc ge (typeof l) m b ofs v' t m' -> ty = typeof l -> estep (ExprState f (C (Eassign l r ty)) k e m) - E0 (ExprState f (C (Eval v' ty)) k e m') + t (ExprState f (C (Eval v' ty)) k e m') - | step_assignop: forall f C op l r tyres ty k e m b ofs v1 v2 v3 v4 m', + | step_assignop: forall f C op l r tyres ty k e m b ofs v1 v2 v3 v4 t1 t2 m' t, leftcontext RV RV C -> eval_simple_lvalue e m l b ofs -> - load_value_of_type (typeof l) m b ofs = Some v1 -> + deref_loc ge (typeof l) m b ofs t1 v1 -> eval_simple_rvalue e m r v2 -> sem_binary_operation op v1 (typeof l) v2 (typeof r) m = Some v3 -> sem_cast v3 tyres (typeof l) = Some v4 -> - store_value_of_type (typeof l) m b ofs v4 = Some m' -> + assign_loc ge (typeof l) m b ofs v4 t2 m' -> ty = typeof l -> + t = t1 ** t2 -> estep (ExprState f (C (Eassignop op l r tyres ty)) k e m) - E0 (ExprState f (C (Eval v4 ty)) k e m') + t (ExprState f (C (Eval v4 ty)) k e m') - | step_postincr: forall f C id l ty k e m b ofs v1 v2 v3 m', + | step_assignop_stuck: forall f C op l r tyres ty k e m b ofs v1 v2 t, leftcontext RV RV C -> eval_simple_lvalue e m l b ofs -> - load_value_of_type ty m b ofs = Some v1 -> + deref_loc ge (typeof l) m b ofs t v1 -> + eval_simple_rvalue e m r v2 -> + match sem_binary_operation op v1 (typeof l) v2 (typeof r) m with + | None => True + | Some v3 => + match sem_cast v3 tyres (typeof l) with + | None => True + | Some v4 => forall t2 m', ~(assign_loc ge (typeof l) m b ofs v4 t2 m') + end + end -> + ty = typeof l -> + estep (ExprState f (C (Eassignop op l r tyres ty)) k e m) + t Stuckstate + + | step_postincr: forall f C id l ty k e m b ofs v1 v2 v3 t1 t2 m' t, + leftcontext RV RV C -> + eval_simple_lvalue e m l b ofs -> + deref_loc ge ty m b ofs t1 v1 -> sem_incrdecr id v1 ty = Some v2 -> sem_cast v2 (typeconv ty) ty = Some v3 -> - store_value_of_type ty m b ofs v3 = Some m' -> + assign_loc ge ty m b ofs v3 t2 m' -> + ty = typeof l -> + t = t1 ** t2 -> + estep (ExprState f (C (Epostincr id l ty)) k e m) + t (ExprState f (C (Eval v1 ty)) k e m') + + | step_postincr_stuck: forall f C id l ty k e m b ofs v1 t, + leftcontext RV RV C -> + eval_simple_lvalue e m l b ofs -> + deref_loc ge ty m b ofs t v1 -> + match sem_incrdecr id v1 ty with + | None => True + | Some v2 => + match sem_cast v2 (typeconv ty) ty with + | None => True + | Some v3 => forall t2 m', ~(assign_loc ge (typeof l) m b ofs v3 t2 m') + end + end -> ty = typeof l -> estep (ExprState f (C (Epostincr id l ty)) k e m) - E0 (ExprState f (C (Eval v1 ty)) k e m') + t Stuckstate | step_comma: forall f C r1 r2 ty k e m v, leftcontext RV RV C -> @@ -326,53 +369,37 @@ Proof. Qed. Lemma star_safe: - forall s1 s2 s3, - safe s1 -> star Csem.step ge s1 E0 s2 -> (safe s2 -> star Csem.step ge s2 E0 s3) -> - star Csem.step ge s1 E0 s3. + forall s1 s2 t s3, + safe s1 -> star Csem.step ge s1 E0 s2 -> (safe s2 -> star Csem.step ge s2 t s3) -> + star Csem.step ge s1 t s3. Proof. intros. eapply star_trans; eauto. apply H1. eapply safe_steps; eauto. auto. Qed. Lemma plus_safe: - forall s1 s2 s3, - safe s1 -> star Csem.step ge s1 E0 s2 -> (safe s2 -> plus Csem.step ge s2 E0 s3) -> - plus Csem.step ge s1 E0 s3. + forall s1 s2 t s3, + safe s1 -> star Csem.step ge s1 E0 s2 -> (safe s2 -> plus Csem.step ge s2 t s3) -> + plus Csem.step ge s1 t s3. Proof. intros. eapply star_plus_trans; eauto. apply H1. eapply safe_steps; eauto. auto. Qed. -Remark not_stuck_val: - forall e v ty m, - not_stuck ge e (Eval v ty) m. -Proof. - intros; red; intros. inv H; try congruence. subst e'. constructor. -Qed. - -Lemma safe_not_stuck: - forall f a k e m, - safe (ExprState f a k e m) -> - not_stuck ge e a m. -Proof. - intros. exploit H. apply star_refl. intros [[r FIN] | [t [s' STEP]]]. - inv FIN. - inv STEP. - inv H0; auto; apply not_stuck_val. - inv H0; apply not_stuck_val. -Qed. - -Hint Resolve safe_not_stuck. +Require Import Classical. -Lemma safe_not_imm_stuck: - forall k C f a K e m, - safe (ExprState f (C a) K e m) -> - context k RV C -> - not_imm_stuck ge e k a m. +Lemma safe_imm_safe: + forall f C a k e m K, + safe (ExprState f (C a) k e m) -> + context K RV C -> + imm_safe ge e K a m. Proof. - intros. exploit safe_not_stuck; eauto. + intros. destruct (classic (imm_safe ge e K a m)); auto. + destruct (H Stuckstate). + apply star_one. left. econstructor; eauto. + destruct H2 as [r F]. inv F. + destruct H2 as [t [s' S]]. inv S. inv H2. inv H2. Qed. -(** Simple, non-stuck expressions are well-formed with respect to - l-values and r-values. *) +(** Safe expressions are well-formed with respect to l-values and r-values. *) Definition expr_kind (a: expr) : kind := match a with @@ -390,7 +417,7 @@ Proof. Qed. Lemma rred_kind: - forall a m a' m', rred a m a' m' -> expr_kind a = RV. + forall a m t a' m', rred ge a m t a' m' -> expr_kind a = RV. Proof. induction 1; auto. Qed. @@ -407,8 +434,8 @@ Proof. induction 1; intros; simpl; auto. Qed. -Lemma not_imm_stuck_kind: - forall e k a m, not_imm_stuck ge e k a m -> expr_kind a = k. +Lemma imm_safe_kind: + forall e k a m, imm_safe ge e k a m -> expr_kind a = k. Proof. induction 1. auto. @@ -424,10 +451,10 @@ Lemma safe_expr_kind: safe (ExprState f (C a) k e m) -> expr_kind a = from. Proof. - intros. eapply not_imm_stuck_kind. eapply safe_not_imm_stuck; eauto. + intros. eapply imm_safe_kind. eapply safe_imm_safe; eauto. Qed. -(** Painful inversion lemmas on particular states that are not stuck. *) +(** Painful inversion lemmas on particular states that are safe. *) Section INVERSION_LEMMAS. @@ -449,15 +476,16 @@ Definition invert_expr_prop (a: expr) (m: mem) : Prop := \/ (e!x = None /\ Genv.find_symbol ge x = Some b /\ type_of_global ge b = Some ty) | Ederef (Eval v ty1) ty => exists b, exists ofs, v = Vptr b ofs - | Efield (Eloc b ofs ty1) f ty => + | Efield (Eval v ty1) f ty => + exists b, exists ofs, v = Vptr b ofs /\ match ty1 with - | Tstruct _ fList => exists delta, field_offset f fList = Errors.OK delta - | Tunion _ _ => True + | Tstruct _ fList _ => exists delta, field_offset f fList = Errors.OK delta + | Tunion _ _ _ => True | _ => False end | Eval v ty => False | Evalof (Eloc b ofs ty') ty => - ty' = ty /\ exists v, load_value_of_type ty m b ofs = Some v + ty' = ty /\ exists t, exists v, deref_loc ge ty m b ofs t v | Eunop op (Eval v1 ty1) ty => exists v, sem_unary_operation op v1 ty1 = Some v | Ebinop op (Eval v1 ty1) (Eval v2 ty2) ty => @@ -467,22 +495,16 @@ Definition invert_expr_prop (a: expr) (m: mem) : Prop := | Econdition (Eval v1 ty1) r1 r2 ty => exists b, bool_val v1 ty1 = Some b | Eassign (Eloc b ofs ty1) (Eval v2 ty2) ty => - exists v, exists m', - ty = ty1 /\ sem_cast v2 ty2 ty1 = Some v /\ store_value_of_type ty1 m b ofs v = Some m' + exists v, exists m', exists t, + ty = ty1 /\ sem_cast v2 ty2 ty1 = Some v /\ assign_loc ge ty1 m b ofs v t m' | Eassignop op (Eloc b ofs ty1) (Eval v2 ty2) tyres ty => - exists v1, exists v, exists v', exists m', - ty = ty1 - /\ load_value_of_type ty1 m b ofs = Some v1 - /\ sem_binary_operation op v1 ty1 v2 ty2 m = Some v - /\ sem_cast v tyres ty1 = Some v' - /\ store_value_of_type ty1 m b ofs v' = Some m' + exists t, exists v1, + ty = ty1 + /\ deref_loc ge ty1 m b ofs t v1 | Epostincr id (Eloc b ofs ty1) ty => - exists v1, exists v2, exists v3, exists m', + exists t, exists v1, ty = ty1 - /\ load_value_of_type ty m b ofs = Some v1 - /\ sem_incrdecr id v1 ty = Some v2 - /\ sem_cast v2 (typeconv ty) ty = Some v3 - /\ store_value_of_type ty m b ofs v3 = Some m' + /\ deref_loc ge ty m b ofs t v1 | Ecomma (Eval v ty1) r2 ty => typeof r2 = ty | Eparen (Eval v1 ty1) ty => @@ -504,21 +526,22 @@ Proof. exists b; auto. exists b; auto. exists b; exists ofs; auto. - exists delta; auto. + exists b; exists ofs; split; auto. exists delta; auto. + exists b; exists ofs; auto. Qed. Lemma rred_invert: - forall r m r' m', rred r m r' m' -> invert_expr_prop r m. + forall r m t r' m', rred ge r m t r' m' -> invert_expr_prop r m. Proof. induction 1; red; auto. - split; auto; exists v; auto. + split; auto; exists t; exists v; auto. exists v; auto. exists v; auto. exists v; auto. exists b; auto. - exists v; exists m'; auto. - exists v1; exists v; exists v'; exists m'; auto. - exists v1; exists v2; exists v3; exists m'; auto. + exists v; exists m'; exists t; auto. + exists t; exists v1; auto. + exists t; exists v1; auto. exists v; auto. Qed. @@ -569,9 +592,9 @@ Proof. red; intros. destruct e1; auto. elim (H0 a m); auto. Qed. -Lemma not_imm_stuck_inv: +Lemma imm_safe_inv: forall k a m, - not_imm_stuck ge e k a m -> + imm_safe ge e k a m -> match a with | Eloc _ _ _ => True | Eval _ _ => True @@ -603,7 +626,7 @@ Lemma safe_inv: | _ => invert_expr_prop a m end. Proof. - intros. eapply not_imm_stuck_inv; eauto. eapply safe_not_imm_stuck; eauto. + intros. eapply imm_safe_inv; eauto. eapply safe_imm_safe; eauto. Qed. End INVERSION_LEMMAS. @@ -619,16 +642,16 @@ Variable m: mem. Lemma eval_simple_steps: (forall a v, eval_simple_rvalue e m a v -> - forall C, context RV RV C -> safe (ExprState f (C a) k e m) -> + forall C, context RV RV C -> star Csem.step ge (ExprState f (C a) k e m) E0 (ExprState f (C (Eval v (typeof a))) k e m)) /\ (forall a b ofs, eval_simple_lvalue e m a b ofs -> - forall C, context LV RV C -> safe (ExprState f (C a) k e m) -> + forall C, context LV RV C -> star Csem.step ge (ExprState f (C a) k e m) E0 (ExprState f (C (Eloc b ofs (typeof a))) k e m)). Proof. -Ltac Steps REC C' := eapply star_safe; eauto; [apply (REC C'); eauto | intros]. +Ltac Steps REC C' := eapply star_trans; [apply (REC C'); eauto | idtac | simpl; reflexivity]. Ltac FinishR := apply star_one; left; apply step_rred; eauto; simpl; try (econstructor; eauto; fail). Ltac FinishL := apply star_one; left; apply step_lred; eauto; simpl; try (econstructor; eauto; fail). @@ -665,14 +688,14 @@ Qed. Lemma eval_simple_rvalue_steps: forall a v, eval_simple_rvalue e m a v -> - forall C, context RV RV C -> safe (ExprState f (C a) k e m) -> + forall C, context RV RV C -> star Csem.step ge (ExprState f (C a) k e m) E0 (ExprState f (C (Eval v (typeof a))) k e m). Proof (proj1 eval_simple_steps). Lemma eval_simple_lvalue_steps: forall a b ofs, eval_simple_lvalue e m a b ofs -> - forall C, context LV RV C -> safe (ExprState f (C a) k e m) -> + forall C, context LV RV C -> star Csem.step ge (ExprState f (C a) k e m) E0 (ExprState f (C (Eloc b ofs (typeof a))) k e m). Proof (proj2 eval_simple_steps). @@ -727,14 +750,16 @@ Ltac StepR REC C' a := exists b; exists Int.zero. intuition. apply esl_var_local; auto. apply esl_var_global; auto. (* field *) - StepL IHa (fun x => C(Efield x f0 ty)) a. - exploit safe_inv. eexact SAFE0. eauto. simpl. case_eq (typeof a); intros; try contradiction. - destruct H0 as [delta OFS]. exists b; exists (Int.add ofs (Int.repr delta)); econstructor; eauto. + StepR IHa (fun x => C(Efield x f0 ty)) a. + exploit safe_inv. eexact SAFE0. eauto. simpl. + intros [b [ofs [EQ TY]]]. subst v. destruct (typeof a) as []_eqn; try contradiction. + destruct TY as [delta OFS]. exists b; exists (Int.add ofs (Int.repr delta)); econstructor; eauto. exists b; exists ofs; econstructor; eauto. (* valof *) - StepL IHa (fun x => C(Evalof x ty)) a. - exploit safe_inv. eexact SAFE0. eauto. simpl. intros [TY [v LOAD]]. - exists v; econstructor; eauto. + destruct S. StepL IHa (fun x => C(Evalof x ty)) a. + exploit safe_inv. eexact SAFE0. eauto. simpl. intros [TY [t [v LOAD]]]. + assert (t = E0). inv LOAD; auto. congruence. subst t. + exists v; econstructor; eauto. congruence. (* deref *) StepR IHa (fun x => C(Ederef x ty)) a. exploit safe_inv. eexact SAFE0. eauto. simpl. intros [b [ofs EQ]]. @@ -875,7 +900,7 @@ Hint Resolve contextlist'_head contextlist'_tail. Lemma eval_simple_list_steps: forall rl vl, eval_simple_list' rl vl -> - forall C, contextlist' C -> safe (ExprState f (C rl) k e m) -> + forall C, contextlist' C -> star Csem.step ge (ExprState f (C rl) k e m) E0 (ExprState f (C (rval_list vl rl)) k e m). Proof. @@ -883,9 +908,10 @@ Proof. (* nil *) apply star_refl. (* cons *) - eapply star_safe. eauto. + eapply star_trans. eapply eval_simple_rvalue_steps with (C := fun x => C(Econs x rl)); eauto. - intros. apply IHeval_simple_list' with (C := fun x => C(Econs (Eval v (typeof r)) x)); auto. + apply IHeval_simple_list' with (C := fun x => C(Econs (Eval v (typeof r)) x)); auto. + auto. Qed. Lemma simple_list_can_eval: @@ -926,7 +952,8 @@ Variable m: mem. Definition simple_side_effect (r: expr) : Prop := match r with - | Econdition r1 r2 r3 ty => simple r1 + | Evalof l _ => simple l /\ type_is_volatile (typeof l) = true + | Econdition r1 r2 r3 _ => simple r1 | Eassign l1 r2 _ => simple l1 /\ simple r2 | Eassignop _ l1 r2 _ _ => simple l1 /\ simple r2 | Epostincr _ l1 _ => simple l1 @@ -964,9 +991,11 @@ Ltac Base := right; exists (fun x => x); econstructor; split; [eauto | simpl; auto]. (* field *) - Kind. Rec H LV C (fun x => Efield x f0 ty). + Kind. Rec H RV C (fun x => Efield x f0 ty). (* rvalof *) Kind. Rec H LV C (fun x => Evalof x ty). + destruct (type_is_volatile (typeof l)) as []_eqn. + Base. auto. (* deref *) Kind. Rec H RV C (fun x => Ederef x ty). (* addrof *) @@ -1020,95 +1049,185 @@ End DECOMPOSITION. Lemma estep_simulation: forall S t S', - estep S t S' -> safe S -> plus Csem.step ge S t S'. + estep S t S' -> plus Csem.step ge S t S'. Proof. intros. inv H. (* simple *) exploit eval_simple_rvalue_steps; eauto. simpl; intros STEPS. - exploit star_inv; eauto. intros [[EQ1 EQ2] | A]; auto. - inversion EQ1. rewrite <- H3 in H2; contradiction. + exploit star_inv; eauto. intros [[EQ1 EQ2] | A]; eauto. + inversion EQ1. rewrite <- H2 in H1; contradiction. +(* valof volatile *) + eapply plus_right. + eapply eval_simple_lvalue_steps with (C := fun x => C(Evalof x (typeof l))); eauto. + left. apply step_rred; eauto. econstructor; eauto. auto. (* condition *) - eapply plus_safe; eauto. + eapply plus_right. eapply eval_simple_rvalue_steps with (C := fun x => C(Econdition x r2 r3 ty)); eauto. - intros. apply plus_one. left; apply step_rred; eauto. constructor; auto. + left; apply step_rred; eauto. constructor; auto. auto. (* assign *) - eapply plus_safe; eauto. + eapply star_plus_trans. eapply eval_simple_lvalue_steps with (C := fun x => C(Eassign x r (typeof l))); eauto. - intros. eapply plus_safe; eauto. + eapply plus_right. eapply eval_simple_rvalue_steps with (C := fun x => C(Eassign (Eloc b ofs (typeof l)) x (typeof l))); eauto. - intros. apply plus_one; left; apply step_rred; eauto. econstructor; eauto. + left; apply step_rred; eauto. econstructor; eauto. + reflexivity. auto. (* assignop *) - eapply plus_safe; eauto. + eapply star_plus_trans. eapply eval_simple_lvalue_steps with (C := fun x => C(Eassignop op x r tyres (typeof l))); eauto. - intros. eapply plus_safe; eauto. + eapply star_plus_trans. eapply eval_simple_rvalue_steps with (C := fun x => C(Eassignop op (Eloc b ofs (typeof l)) x tyres (typeof l))); eauto. - intros. apply plus_one; left; apply step_rred; eauto. econstructor; eauto. + eapply plus_left. + left; apply step_rred; auto. econstructor; eauto. + eapply star_left. + left; apply step_rred with (C := fun x => C(Eassign (Eloc b ofs (typeof l)) x (typeof l))); eauto. econstructor; eauto. + apply star_one. + left; apply step_rred; auto. econstructor; eauto. + reflexivity. reflexivity. reflexivity. traceEq. +(* assignop stuck *) + eapply star_plus_trans. + eapply eval_simple_lvalue_steps with (C := fun x => C(Eassignop op x r tyres (typeof l))); eauto. + eapply star_plus_trans. + eapply eval_simple_rvalue_steps with (C := fun x => C(Eassignop op (Eloc b ofs (typeof l)) x tyres (typeof l))); eauto. + eapply plus_left. + left; apply step_rred; auto. econstructor; eauto. + destruct (sem_binary_operation op v1 (typeof l) v2 (typeof r) m) as [v3|]_eqn. + eapply star_left. + left; apply step_rred with (C := fun x => C(Eassign (Eloc b ofs (typeof l)) x (typeof l))); eauto. econstructor; eauto. + apply star_one. + left; eapply step_stuck; eauto. + red; intros. exploit imm_safe_inv; eauto. simpl. intros [v4' [m' [t' [A [B D]]]]]. + rewrite B in H4. eelim H4; eauto. + reflexivity. + apply star_one. + left; eapply step_stuck with (C := fun x => C(Eassign (Eloc b ofs (typeof l)) x (typeof l))); eauto. + red; intros. exploit imm_safe_inv; eauto. simpl. intros [v3 A]. congruence. + reflexivity. + reflexivity. traceEq. (* postincr *) - eapply plus_safe; eauto. + eapply star_plus_trans. + eapply eval_simple_lvalue_steps with (C := fun x => C(Epostincr id x (typeof l))); eauto. + eapply plus_left. + left; apply step_rred; auto. econstructor; eauto. + eapply star_left. + left; apply step_rred with (C := fun x => C (Ecomma (Eassign (Eloc b ofs (typeof l)) x (typeof l)) (Eval v1 (typeof l)) (typeof l))); eauto. + econstructor. instantiate (1 := v2). destruct id; assumption. + eapply star_left. + left; apply step_rred with (C := fun x => C (Ecomma x (Eval v1 (typeof l)) (typeof l))); eauto. + econstructor; eauto. + apply star_one. + left; apply step_rred; auto. econstructor; eauto. + reflexivity. reflexivity. reflexivity. traceEq. +(* postincr stuck *) + eapply star_plus_trans. eapply eval_simple_lvalue_steps with (C := fun x => C(Epostincr id x (typeof l))); eauto. - intros. apply plus_one; left; apply step_rred; eauto. econstructor; eauto. + eapply plus_left. + left; apply step_rred; auto. econstructor; eauto. + set (op := match id with Incr => Oadd | Decr => Osub end). + assert (SEM: sem_binary_operation op v1 (typeof l) (Vint Int.one) type_int32s m = + sem_incrdecr id v1 (typeof l)). + destruct id; auto. + destruct (sem_incrdecr id v1 (typeof l)) as [v2|]. + eapply star_left. + left; apply step_rred with (C := fun x => C (Ecomma (Eassign (Eloc b ofs (typeof l)) x (typeof l)) (Eval v1 (typeof l)) (typeof l))); eauto. + econstructor; eauto. + apply star_one. + left; eapply step_stuck with (C := fun x => C (Ecomma x (Eval v1 (typeof l)) (typeof l))); eauto. + red; intros. exploit imm_safe_inv; eauto. simpl. intros [v3 [m' [t' [A [B D]]]]]. + rewrite B in H3. eelim H3; eauto. + reflexivity. + apply star_one. + left; eapply step_stuck with (C := fun x => C (Ecomma (Eassign (Eloc b ofs (typeof l)) x (typeof l)) (Eval v1 (typeof l)) (typeof l))); eauto. + red; intros. exploit imm_safe_inv; eauto. simpl. intros [v2 A]. congruence. + reflexivity. + traceEq. (* comma *) - eapply plus_safe; eauto. + eapply plus_right. eapply eval_simple_rvalue_steps with (C := fun x => C(Ecomma x r2 (typeof r2))); eauto. - intros. apply plus_one; left; apply step_rred; eauto. econstructor; eauto. + left; apply step_rred; eauto. econstructor; eauto. auto. (* paren *) - eapply plus_safe; eauto. + eapply plus_right; eauto. eapply eval_simple_rvalue_steps with (C := fun x => C(Eparen x ty)); eauto. - intros. apply plus_one; left; apply step_rred; eauto. econstructor; eauto. + left; apply step_rred; eauto. econstructor; eauto. auto. (* call *) exploit eval_simple_list_implies; eauto. intros [vl' [A B]]. - eapply plus_safe; eauto. + eapply star_plus_trans. eapply eval_simple_rvalue_steps with (C := fun x => C(Ecall x rargs ty)); eauto. - intros. eapply plus_safe; eauto. + eapply plus_right. eapply eval_simple_list_steps with (C := fun x => C(Ecall (Eval vf (typeof rf)) x ty)); eauto. eapply contextlist'_intro with (rl0 := Enil); auto. - intros. apply plus_one; left; apply Csem.step_call; eauto. - econstructor; eauto. + left; apply Csem.step_call; eauto. econstructor; eauto. + traceEq. auto. Qed. Lemma can_estep: forall f a k e m, safe (ExprState f a k e m) -> match a with Eval _ _ => False | _ => True end -> - exists S, estep (ExprState f a k e m) E0 S. + exists t, exists S, estep (ExprState f a k e m) t S. Proof. intros. destruct (decompose_topexpr f k e m a H) as [A | [C [b [P [Q R]]]]]. (* simple expr *) exploit (simple_can_eval f k e m a RV (fun x => x)); auto. intros [v P]. - econstructor; eapply step_expr; eauto. + econstructor; econstructor; eapply step_expr; eauto. (* side effect *) clear H0. subst a. red in Q. destruct b; try contradiction. +(* valof volatile *) + destruct Q. + exploit (simple_can_eval_lval f k e m b (fun x => C(Evalof x ty))); eauto. + intros [b1 [ofs [E1 S1]]]. + exploit safe_inv. eexact S1. eauto. simpl. intros [A [t [v B]]]. + econstructor; econstructor; eapply step_rvalof_volatile; eauto. congruence. (* condition *) exploit (simple_can_eval_rval f k e m b1 (fun x => C(Econdition x b2 b3 ty))); eauto. intros [v1 [E1 S1]]. exploit safe_inv. eexact S1. eauto. simpl. intros [b BV]. - econstructor. eapply step_condition; eauto. + econstructor; econstructor. eapply step_condition; eauto. (* assign *) destruct Q. exploit (simple_can_eval_lval f k e m b1 (fun x => C(Eassign x b2 ty))); eauto. intros [b [ofs [E1 S1]]]. exploit (simple_can_eval_rval f k e m b2 (fun x => C(Eassign (Eloc b ofs (typeof b1)) x ty))); eauto. intros [v [E2 S2]]. - exploit safe_inv. eexact S2. eauto. simpl. intros [v' [m' [A [B D]]]]. - econstructor; eapply step_assign; eauto. + exploit safe_inv. eexact S2. eauto. simpl. intros [v' [m' [t [A [B D]]]]]. + econstructor; econstructor; eapply step_assign; eauto. (* assignop *) destruct Q. exploit (simple_can_eval_lval f k e m b1 (fun x => C(Eassignop op x b2 tyres ty))); eauto. intros [b [ofs [E1 S1]]]. exploit (simple_can_eval_rval f k e m b2 (fun x => C(Eassignop op (Eloc b ofs (typeof b1)) x tyres ty))); eauto. intros [v [E2 S2]]. - exploit safe_inv. eexact S2. eauto. simpl. intros [v1 [v2 [v3 [m' [A [B [D [E F]]]]]]]]. - econstructor; eapply step_assignop; eauto. + exploit safe_inv. eexact S2. eauto. simpl. intros [t1 [v1 [A B]]]. + destruct (sem_binary_operation op v1 (typeof b1) v (typeof b2) m) as [v3|]_eqn. + destruct (sem_cast v3 tyres (typeof b1)) as [v4|]_eqn. + destruct (classic (exists t2, exists m', assign_loc ge (typeof b1) m b ofs v4 t2 m')). + destruct H2 as [t2 [m' D]]. + econstructor; econstructor; eapply step_assignop; eauto. + econstructor; econstructor; eapply step_assignop_stuck; eauto. + rewrite Heqo. rewrite Heqo0. intros; red; intros. elim H2. exists t2; exists m'; auto. + econstructor; econstructor; eapply step_assignop_stuck; eauto. + rewrite Heqo. rewrite Heqo0. auto. + econstructor; econstructor; eapply step_assignop_stuck; eauto. + rewrite Heqo. auto. (* postincr *) exploit (simple_can_eval_lval f k e m b (fun x => C(Epostincr id x ty))); eauto. intros [b1 [ofs [E1 S1]]]. - exploit safe_inv. eexact S1. eauto. simpl. intros [v1 [v2 [v3 [m' [A [B [D [E F]]]]]]]]. - econstructor; eapply step_postincr; eauto. + exploit safe_inv. eexact S1. eauto. simpl. intros [t [v1 [A B]]]. + destruct (sem_incrdecr id v1 ty) as [v2|]_eqn. + destruct (sem_cast v2 (typeconv ty) ty) as [v3|]_eqn. + destruct (classic (exists t2, exists m', assign_loc ge ty m b1 ofs v3 t2 m')). + destruct H0 as [t2 [m' D]]. + econstructor; econstructor; eapply step_postincr; eauto. + econstructor; econstructor; eapply step_postincr_stuck; eauto. + rewrite Heqo. rewrite Heqo0. intros; red; intros. elim H0. exists t2; exists m'; congruence. + econstructor; econstructor; eapply step_postincr_stuck; eauto. + rewrite Heqo. rewrite Heqo0. auto. + econstructor; econstructor; eapply step_postincr_stuck; eauto. + rewrite Heqo. auto. (* comma *) exploit (simple_can_eval_rval f k e m b1 (fun x => C(Ecomma x b2 ty))); eauto. intros [v1 [E1 S1]]. exploit safe_inv. eexact S1. eauto. simpl. intros EQ. - econstructor; eapply step_comma; eauto. + econstructor; econstructor; eapply step_comma; eauto. (* call *) destruct Q. exploit (simple_can_eval_rval f k e m b (fun x => C(Ecall x rargs ty))); eauto. @@ -1122,19 +1241,19 @@ Proof. apply (eval_simple_list_steps f k e m rargs vl E2 C'); auto. simpl. intros X. exploit X. eapply rval_list_all_values. intros [tyargs [tyres [fd [vargs [P [Q [U V]]]]]]]. - econstructor; eapply step_call; eauto. eapply can_eval_simple_list; eauto. + econstructor; econstructor; eapply step_call; eauto. eapply can_eval_simple_list; eauto. (* paren *) exploit (simple_can_eval_rval f k e m b (fun x => C(Eparen x ty))); eauto. intros [v1 [E1 S1]]. exploit safe_inv. eexact S1. eauto. simpl. intros [v CAST]. - econstructor; eapply step_paren; eauto. + econstructor; econstructor; eapply step_paren; eauto. Qed. (** Simulation for all states *) Theorem step_simulation: forall S1 t S2, - step S1 t S2 -> safe S1 -> plus Csem.step ge S1 t S2. + step S1 t S2 -> plus Csem.step ge S1 t S2. Proof. intros. inv H. apply estep_simulation; auto. @@ -1150,16 +1269,19 @@ Proof. auto. right. destruct STEP. (* 2. Expression step. *) - assert (exists S', estep S E0 S'). + assert (exists t, exists S', estep S t S'). inv H0. (* lred *) - eapply can_estep; eauto. inv H3; auto. + eapply can_estep; eauto. inv H2; auto. (* rred *) - eapply can_estep; eauto. inv H3; auto. inv H1; auto. + eapply can_estep; eauto. inv H2; auto. inv H1; auto. (* callred *) - eapply can_estep; eauto. inv H3; auto. inv H1; auto. - destruct H1 as [S'' ESTEP]. - exists E0; exists S''; left; auto. + eapply can_estep; eauto. inv H2; auto. inv H1; auto. + (* stuck *) + exploit (H Stuckstate). apply star_one. left. econstructor; eauto. + intros [[r F] | [t [S' R]]]. inv F. inv R. inv H0. inv H0. + destruct H1 as [t' [S'' ESTEP]]. + exists t'; exists S''; left; auto. (* 3. Other step. *) exists t; exists S'; right; auto. Qed. @@ -1173,22 +1295,145 @@ Definition semantics (p: program) := (** This semantics is receptive to changes in events. *) -Lemma semantics_receptive: - forall p, receptive (semantics p). +Remark deref_loc_trace: + forall F V (ge: Genv.t F V) ty m b ofs t v, + deref_loc ge ty m b ofs t v -> + match t with nil => True | ev :: nil => True | _ => False end. +Proof. + intros. inv H; simpl; auto. inv H2; simpl; auto. +Qed. + +Remark deref_loc_receptive: + forall F V (ge: Genv.t F V) ty m b ofs ev1 t1 v ev2, + deref_loc ge ty m b ofs (ev1 :: t1) v -> + match_traces ge (ev1 :: nil) (ev2 :: nil) -> + t1 = nil /\ exists v', deref_loc ge ty m b ofs (ev2 :: nil) v'. +Proof. + intros. + assert (t1 = nil). exploit deref_loc_trace; eauto. destruct t1; simpl; tauto. + inv H. exploit volatile_load_receptive; eauto. intros [v' A]. + split; auto; exists v'; econstructor; eauto. +Qed. + +Remark assign_loc_trace: + forall F V (ge: Genv.t F V) ty m b ofs t v m', + assign_loc ge ty m b ofs v t m' -> + match t with nil => True | ev :: nil => output_event ev | _ => False end. +Proof. + intros. inv H; simpl; auto. inv H2; simpl; auto. +Qed. + +Remark assign_loc_receptive: + forall F V (ge: Genv.t F V) ty m b ofs ev1 t1 v m' ev2, + assign_loc ge ty m b ofs v (ev1 :: t1) m' -> + match_traces ge (ev1 :: nil) (ev2 :: nil) -> + ev1 :: t1 = ev2 :: nil. +Proof. + intros. + assert (t1 = nil). exploit assign_loc_trace; eauto. destruct t1; simpl; tauto. + inv H. eapply volatile_store_receptive; eauto. +Qed. + +Lemma semantics_strongly_receptive: + forall p, strongly_receptive (semantics p). Proof. intros. constructor; simpl; intros. (* receptiveness *) - assert (t1 = E0 -> exists s2, step (Genv.globalenv p) s t2 s2). - intros. subst. inv H0. exists s1; auto. inversion H; subst. - inv H2; auto. - inv H2; auto. + inv H1. + (* valof volatile *) + exploit deref_loc_receptive; eauto. intros [A [v' B]]. + econstructor; econstructor. left; eapply step_rvalof_volatile; eauto. + (* assign *) + exploit assign_loc_receptive; eauto. intro EQ; rewrite EQ in H. + econstructor; econstructor; eauto. + (* assignop *) + destruct t0 as [ | ev0 t0]; simpl in H10. + subst t2. exploit assign_loc_receptive; eauto. intros EQ; rewrite EQ in H. + econstructor; econstructor; eauto. + inv H10. exploit deref_loc_receptive; eauto. intros [EQ [v1' A]]. subst t0. + destruct (sem_binary_operation op v1' (typeof l) v2 (typeof r) m) as [v3'|]_eqn. + destruct (sem_cast v3' tyres (typeof l)) as [v4'|]_eqn. + destruct (classic (exists t2', exists m'', assign_loc (Genv.globalenv p) (typeof l) m b ofs v4' t2' m'')). + destruct H1 as [t2' [m'' P]]. + econstructor; econstructor. left; eapply step_assignop with (v1 := v1'); eauto. simpl; reflexivity. + econstructor; econstructor. left; eapply step_assignop_stuck with (v1 := v1'); eauto. + rewrite Heqo; rewrite Heqo0. intros; red; intros; elim H1. exists t0; exists m'0; auto. + econstructor; econstructor. left; eapply step_assignop_stuck with (v1 := v1'); eauto. + rewrite Heqo; rewrite Heqo0; auto. + econstructor; econstructor. left; eapply step_assignop_stuck with (v1 := v1'); eauto. + rewrite Heqo; auto. + (* assignop stuck *) + exploit deref_loc_receptive; eauto. intros [EQ [v1' A]]. subst t1. + destruct (sem_binary_operation op v1' (typeof l) v2 (typeof r) m) as [v3'|]_eqn. + destruct (sem_cast v3' tyres (typeof l)) as [v4'|]_eqn. + destruct (classic (exists t2', exists m'', assign_loc (Genv.globalenv p) (typeof l) m b ofs v4' t2' m'')). + destruct H1 as [t2' [m'' P]]. + econstructor; econstructor. left; eapply step_assignop with (v1 := v1'); eauto. simpl; reflexivity. + econstructor; econstructor. left; eapply step_assignop_stuck with (v1 := v1'); eauto. + rewrite Heqo; rewrite Heqo0. intros; red; intros; elim H1. exists t2; exists m'; auto. + econstructor; econstructor. left; eapply step_assignop_stuck with (v1 := v1'); eauto. + rewrite Heqo; rewrite Heqo0; auto. + econstructor; econstructor. left; eapply step_assignop_stuck with (v1 := v1'); eauto. + rewrite Heqo; auto. + (* postincr *) + destruct t0 as [ | ev0 t0]; simpl in H9. + subst t2. exploit assign_loc_receptive; eauto. intros EQ; rewrite EQ in H. + econstructor; econstructor; eauto. + inv H9. exploit deref_loc_receptive; eauto. intros [EQ [v1' A]]. subst t0. + destruct (sem_incrdecr id v1' (typeof l)) as [v2'|]_eqn. + destruct (sem_cast v2' (typeconv (typeof l)) (typeof l)) as [v3'|]_eqn. + destruct (classic (exists t2', exists m'', assign_loc (Genv.globalenv p) (typeof l) m b ofs v3' t2' m'')). + destruct H1 as [t2' [m'' P]]. + econstructor; econstructor. left; eapply step_postincr with (v1 := v1'); eauto. simpl; reflexivity. + econstructor; econstructor. left; eapply step_postincr_stuck with (v1 := v1'); eauto. + rewrite Heqo; rewrite Heqo0. intros; red; intros; elim H1. exists t0; exists m'0; auto. + econstructor; econstructor. left; eapply step_postincr_stuck with (v1 := v1'); eauto. + rewrite Heqo; rewrite Heqo0; auto. + econstructor; econstructor. left; eapply step_postincr_stuck with (v1 := v1'); eauto. + rewrite Heqo; auto. + (* postincr stuck *) + exploit deref_loc_receptive; eauto. intros [EQ [v1' A]]. subst t1. + destruct (sem_incrdecr id v1' (typeof l)) as [v2'|]_eqn. + destruct (sem_cast v2' (typeconv (typeof l)) (typeof l)) as [v3'|]_eqn. + destruct (classic (exists t2', exists m'', assign_loc (Genv.globalenv p) (typeof l) m b ofs v3' t2' m'')). + destruct H1 as [t2' [m'' P]]. + econstructor; econstructor. left; eapply step_postincr with (v1 := v1'); eauto. simpl; reflexivity. + econstructor; econstructor. left; eapply step_postincr_stuck with (v1 := v1'); eauto. + rewrite Heqo; rewrite Heqo0. intros; red; intros; elim H1. exists t2; exists m'; auto. + econstructor; econstructor. left; eapply step_postincr_stuck with (v1 := v1'); eauto. + rewrite Heqo; rewrite Heqo0; auto. + econstructor; econstructor. left; eapply step_postincr_stuck with (v1 := v1'); eauto. + rewrite Heqo; auto. + (* external calls *) + inv H1. + exploit external_call_trace_length; eauto. destruct t1; simpl; intros. exploit external_call_receptive; eauto. intros [vres2 [m2 EC2]]. - exists (Returnstate vres2 k m2). right; econstructor; eauto. -(* trace length *) - inv H. - inv H0; simpl; omega. - inv H0; simpl; try omega. eapply external_call_trace_length; eauto. + exists (Returnstate vres2 k m2); exists E0; right; econstructor; eauto. + omegaContradiction. +(* well-behaved traces *) + red; intros. inv H; inv H0; simpl; auto. + (* valof volatile *) + exploit deref_loc_trace; eauto. destruct t; auto. destruct t; tauto. + (* assign *) + exploit assign_loc_trace; eauto. destruct t; auto. destruct t; simpl; tauto. + (* assignop *) + exploit deref_loc_trace; eauto. exploit assign_loc_trace; eauto. + destruct t1. destruct t2. simpl; auto. destruct t2; simpl; tauto. + destruct t1. destruct t2. simpl; auto. destruct t2; simpl; tauto. + tauto. + (* assignop stuck *) + exploit deref_loc_trace; eauto. destruct t; auto. destruct t; tauto. + (* postincr *) + exploit deref_loc_trace; eauto. exploit assign_loc_trace; eauto. + destruct t1. destruct t2. simpl; auto. destruct t2; simpl; tauto. + destruct t1. destruct t2. simpl; auto. destruct t2; simpl; tauto. + tauto. + (* postincr stuck *) + exploit deref_loc_trace; eauto. destruct t; auto. destruct t; tauto. + (* external calls *) + exploit external_call_trace_length; eauto. + destruct t; simpl; auto. destruct t; simpl; auto. intros; omegaContradiction. Qed. (** The main simulation result. *) @@ -1200,8 +1445,6 @@ Proof. apply backward_simulation_plus with (match_states := fun (S1 S2: state) => S1 = S2); simpl. (* symbols *) auto. -(* trace length *) - intros. eapply sr_traces. apply semantics_receptive. simpl. eauto. (* initial states exist *) intros. exists s1; auto. (* initial states match *) @@ -1269,11 +1512,19 @@ with eval_expr: env -> mem -> kind -> expr -> trace -> mem -> expr -> Prop := | eval_var: forall e m x ty, eval_expr e m LV (Evar x ty) E0 m (Evar x ty) | eval_field: forall e m a t m' a' f ty, - eval_expr e m LV a t m' a' -> + eval_expr e m RV a t m' a' -> eval_expr e m LV (Efield a f ty) t m' (Efield a' f ty) | eval_valof: forall e m a t m' a' ty, + type_is_volatile (typeof a) = false -> eval_expr e m LV a t m' a' -> eval_expr e m RV (Evalof a ty) t m' (Evalof a' ty) + | eval_valof_volatile: forall e m a t1 m' a' ty b ofs t2 v, + type_is_volatile (typeof a) = true -> + eval_expr e m LV a t1 m' a' -> + eval_simple_lvalue ge e m' a' b ofs -> + deref_loc ge (typeof a) m' b ofs t2 v -> + ty = typeof a -> + eval_expr e m RV (Evalof a ty) (t1 ** t2) m' (Eval v ty) | eval_deref: forall e m a t m' a' ty, eval_expr e m RV a t m' a' -> eval_expr e m LV (Ederef a ty) t m' (Ederef a' ty) @@ -1297,34 +1548,34 @@ with eval_expr: env -> mem -> kind -> expr -> trace -> mem -> expr -> Prop := eval_expr e m RV (Econdition a1 a2 a3 ty) (t1**t2) m'' (Eval v ty) | eval_sizeof: forall e m ty' ty, eval_expr e m RV (Esizeof ty' ty) E0 m (Esizeof ty' ty) - | eval_assign: forall e m l r ty t1 m1 l' t2 m2 r' b ofs v v' m3, + | eval_assign: forall e m l r ty t1 m1 l' t2 m2 r' b ofs v v' t3 m3, eval_expr e m LV l t1 m1 l' -> eval_expr e m1 RV r t2 m2 r' -> eval_simple_lvalue ge e m2 l' b ofs -> eval_simple_rvalue ge e m2 r' v -> sem_cast v (typeof r) (typeof l) = Some v' -> - store_value_of_type (typeof l) m2 b ofs v' = Some m3 -> + assign_loc ge (typeof l) m2 b ofs v' t3 m3 -> ty = typeof l -> - eval_expr e m RV (Eassign l r ty) (t1**t2) m3 (Eval v' ty) + eval_expr e m RV (Eassign l r ty) (t1**t2**t3) m3 (Eval v' ty) | eval_assignop: forall e m op l r tyres ty t1 m1 l' t2 m2 r' b ofs - v1 v2 v3 v4 m3, + v1 v2 v3 v4 t3 t4 m3, eval_expr e m LV l t1 m1 l' -> eval_expr e m1 RV r t2 m2 r' -> eval_simple_lvalue ge e m2 l' b ofs -> - load_value_of_type (typeof l) m2 b ofs = Some v1 -> + deref_loc ge (typeof l) m2 b ofs t3 v1 -> eval_simple_rvalue ge e m2 r' v2 -> sem_binary_operation op v1 (typeof l) v2 (typeof r) m2 = Some v3 -> sem_cast v3 tyres (typeof l) = Some v4 -> - store_value_of_type (typeof l) m2 b ofs v4 = Some m3 -> + assign_loc ge (typeof l) m2 b ofs v4 t4 m3 -> ty = typeof l -> - eval_expr e m RV (Eassignop op l r tyres ty) (t1**t2) m3 (Eval v4 ty) - | eval_postincr: forall e m id l ty t m1 l' b ofs v1 v2 v3 m2, - eval_expr e m LV l t m1 l' -> + eval_expr e m RV (Eassignop op l r tyres ty) (t1**t2**t3**t4) m3 (Eval v4 ty) + | eval_postincr: forall e m id l ty t1 m1 l' b ofs v1 v2 v3 m2 t2 t3, + eval_expr e m LV l t1 m1 l' -> eval_simple_lvalue ge e m1 l' b ofs -> - load_value_of_type ty m1 b ofs = Some v1 -> + deref_loc ge ty m1 b ofs t2 v1 -> sem_incrdecr id v1 ty = Some v2 -> sem_cast v2 (typeconv ty) ty = Some v3 -> - store_value_of_type ty m1 b ofs v3 = Some m2 -> + assign_loc ge ty m1 b ofs v3 t3 m2 -> ty = typeof l -> - eval_expr e m RV (Epostincr id l ty) t m2 (Eval v1 ty) + eval_expr e m RV (Epostincr id l ty) (t1**t2**t3) m2 (Eval v1 ty) | eval_comma: forall e m r1 r2 ty t1 m1 r1' v1 t2 m2 r2', eval_expr e m RV r1 t1 m1 r1' -> eval_simple_rvalue ge e m1 r1' v1 -> @@ -1472,7 +1723,7 @@ with eval_funcall: mem -> fundef -> list val -> trace -> mem -> val -> Prop := | eval_funcall_internal: forall m f vargs t e m1 m2 m3 out vres m4, 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 -> + bind_parameters ge e m1 f.(fn_params) vargs m2 -> exec_stmt e m2 f.(fn_body) t m3 out -> outcome_result_value out f.(fn_return) vres -> Mem.free_list m3 (blocks_of_env e) = Some m4 -> @@ -1497,7 +1748,7 @@ Combined Scheme bigstep_induction from CoInductive evalinf_expr: env -> mem -> kind -> expr -> traceinf -> Prop := | evalinf_field: forall e m a t f ty, - evalinf_expr e m LV a t -> + evalinf_expr e m RV a t -> evalinf_expr e m LV (Efield a f ty) t | evalinf_valof: forall e m a t ty, evalinf_expr e m LV a t -> @@ -1677,7 +1928,7 @@ with evalinf_funcall: mem -> fundef -> list val -> traceinf -> Prop := | evalinf_funcall_internal: forall m f vargs t 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 -> + bind_parameters ge e m1 f.(fn_params) vargs m2 -> execinf_stmt e m2 f.(fn_body) t -> evalinf_funcall m (Internal f) vargs t. @@ -1780,9 +2031,16 @@ Proof. eapply leftcontext_compose; eauto. repeat constructor. intros [A [B D]]. simpl; intuition; eauto. (* valof *) - exploit (H0 (fun x => C(Evalof x ty))). + exploit (H1 (fun x => C(Evalof x ty))). eapply leftcontext_compose; eauto. repeat constructor. intros [A [B D]]. - simpl; intuition; eauto. + simpl; intuition; eauto. congruence. +(* valof volatile *) + exploit (H1 (fun x => C(Evalof x ty))). + eapply leftcontext_compose; eauto. repeat constructor. intros [A [B D]]. + simpl; intuition. + eapply star_right. eexact D. + left. eapply step_rvalof_volatile; eauto. rewrite H4; eauto. congruence. congruence. + traceEq. (* deref *) exploit (H0 (fun x => C(Ederef x ty))). eapply leftcontext_compose; eauto. repeat constructor. intros [A [B D]]. @@ -1825,7 +2083,7 @@ Proof. simpl; intuition. eapply star_trans. eexact D. eapply star_right. eexact G. - left. eapply step_assign; eauto. congruence. congruence. congruence. + left. eapply step_assign; eauto. congruence. rewrite B; eauto. congruence. reflexivity. traceEq. (* assignop *) exploit (H0 (fun x => C(Eassignop op x r tyres ty))). @@ -1836,7 +2094,7 @@ Proof. eapply star_trans. eexact D. eapply star_right. eexact G. left. eapply step_assignop; eauto. - rewrite B; eauto. rewrite B; rewrite F; eauto. congruence. congruence. congruence. + rewrite B; eauto. rewrite B; rewrite F; eauto. congruence. rewrite B; eauto. congruence. reflexivity. traceEq. (* postincr *) exploit (H0 (fun x => C(Epostincr id x ty))). @@ -2113,16 +2371,15 @@ Proof. (* Out_normal *) assert (fn_return f = Tvoid /\ vres = Vundef). destruct (fn_return f); auto || contradiction. - destruct H7. subst vres. right; apply step_skip_call; auto. + destruct H7 as [P Q]. subst vres. right; eapply step_skip_call; eauto. (* Out_return None *) assert (fn_return f = Tvoid /\ vres = Vundef). destruct (fn_return f); auto || contradiction. - destruct H8. subst vres. + destruct H8 as [P Q]. subst vres. rewrite <- (is_call_cont_call_cont k H6). rewrite <- H7. right; apply step_return_0; auto. (* Out_return Some *) - destruct H4. - rewrite <- (is_call_cont_call_cont k H6). rewrite <- H7. + destruct H4. rewrite <- (is_call_cont_call_cont k H6). rewrite <- H7. right; eapply step_return_2; eauto. reflexivity. traceEq. @@ -2510,7 +2767,7 @@ Inductive bigstep_program_terminates (p: program): trace -> int -> Prop := Genv.init_mem p = Some m0 -> Genv.find_symbol ge p.(prog_main) = Some b -> Genv.find_funct_ptr ge b = Some f -> - type_of_fundef f = Tfunction Tnil (Tint I32 Signed) -> + type_of_fundef f = Tfunction Tnil type_int32s -> eval_funcall ge m0 f nil t m1 (Vint r) -> bigstep_program_terminates p t r. @@ -2520,7 +2777,7 @@ Inductive bigstep_program_diverges (p: program): traceinf -> Prop := Genv.init_mem p = Some m0 -> Genv.find_symbol ge p.(prog_main) = Some b -> Genv.find_funct_ptr ge b = Some f -> - type_of_fundef f = Tfunction Tnil (Tint I32 Signed) -> + type_of_fundef f = Tfunction Tnil type_int32s -> evalinf_funcall ge m0 f nil t -> bigstep_program_diverges p t. diff --git a/cfrontend/Csyntax.v b/cfrontend/Csyntax.v index c76d9b9..ffe08bf 100644 --- a/cfrontend/Csyntax.v +++ b/cfrontend/Csyntax.v @@ -30,7 +30,8 @@ Require Import AST. pointers, arrays, function types, and composite types (struct and union). Numeric types (integers and floats) fully specify the bit size of the type. An integer type is a pair of a signed/unsigned - flag and a bit size: 8, 16 or 32 bits. *) + flag and a bit size: 8, 16, or 32 bits, or the special [IBool] size + standing for the C99 [_Bool] type. *) Inductive signedness : Type := | Signed: signedness @@ -39,7 +40,8 @@ Inductive signedness : Type := Inductive intsize : Type := | I8: intsize | I16: intsize - | I32: intsize. + | I32: intsize + | IBool: intsize. (** Float types come in two sizes: 32 bits (single precision) and 64-bit (double precision). *) @@ -48,6 +50,15 @@ Inductive floatsize : Type := | F32: floatsize | F64: floatsize. +(** Every type carries a set of attributes. Currently, only one + attribute is modeled: [volatile]. *) + +Record attr : Type := mk_attr { + attr_volatile: bool +}. + +Definition noattr := {| attr_volatile := false |}. + (** The syntax of type expressions. Some points to note: - Array types [Tarray n] carry the size [n] of the array. Arrays with unknown sizes are represented by pointer types. @@ -84,15 +95,15 @@ Inductive floatsize : Type := *) Inductive type : Type := - | Tvoid: type (**r the [void] type *) - | Tint: intsize -> signedness -> type (**r integer types *) - | Tfloat: floatsize -> type (**r floating-point types *) - | Tpointer: type -> type (**r pointer types ([*ty]) *) - | Tarray: type -> Z -> type (**r array types ([ty[len]]) *) - | Tfunction: typelist -> type -> type (**r function types *) - | Tstruct: ident -> fieldlist -> type (**r struct types *) - | Tunion: ident -> fieldlist -> type (**r union types *) - | Tcomp_ptr: ident -> type (**r pointer to named struct or union *) + | Tvoid: type (**r the [void] type *) + | Tint: intsize -> signedness -> attr -> type (**r integer types *) + | Tfloat: floatsize -> attr -> type (**r floating-point types *) + | Tpointer: type -> attr -> type (**r pointer types ([*ty]) *) + | Tarray: type -> Z -> attr -> type (**r array types ([ty[len]]) *) + | Tfunction: typelist -> type -> type (**r function types *) + | Tstruct: ident -> fieldlist -> attr -> type (**r struct types *) + | Tunion: ident -> fieldlist -> attr -> type (**r union types *) + | Tcomp_ptr: ident -> attr -> type (**r pointer to named struct or union *) with typelist : Type := | Tnil: typelist @@ -102,16 +113,51 @@ with fieldlist : Type := | Fnil: fieldlist | Fcons: ident -> type -> fieldlist -> fieldlist. +Lemma type_eq: forall (ty1 ty2: type), {ty1=ty2} + {ty1<>ty2} +with typelist_eq: forall (tyl1 tyl2: typelist), {tyl1=tyl2} + {tyl1<>tyl2} +with fieldlist_eq: forall (fld1 fld2: fieldlist), {fld1=fld2} + {fld1<>fld2}. +Proof. + assert (forall (x y: intsize), {x=y} + {x<>y}). decide equality. + assert (forall (x y: signedness), {x=y} + {x<>y}). decide equality. + assert (forall (x y: floatsize), {x=y} + {x<>y}). decide equality. + assert (forall (x y: attr), {x=y} + {x<>y}). decide equality. apply bool_dec. + generalize ident_eq zeq. intros E1 E2. + decide equality. + decide equality. + generalize ident_eq. intros E1. + decide equality. +Defined. + +Opaque type_eq typelist_eq fieldlist_eq. + +(** Extract the attributes of a type. *) + +Definition attr_of_type (ty: type) := + match ty with + | Tvoid => noattr + | Tint sz si a => a + | Tfloat sz a => a + | Tpointer elt a => a + | Tarray elt sz a => a + | Tfunction args res => noattr + | Tstruct id fld a => a + | Tunion id fld a => a + | Tcomp_ptr id a => a + end. + +Definition type_int32s := Tint I32 Signed noattr. +Definition type_bool := Tint IBool Signed noattr. + (** The usual unary conversion. Promotes small integer types to [signed int32] and degrades array types and function types to pointer types. *) Definition typeconv (ty: type) : type := match ty with - | Tint I32 Unsigned => ty - | Tint _ _ => Tint I32 Signed - | Tarray t sz => Tpointer t - | Tfunction _ _ => Tpointer ty - | _ => ty + | Tint I32 Unsigned _ => ty + | Tint _ _ a => Tint I32 Signed a + | Tarray t sz a => Tpointer t a + | Tfunction _ _ => Tpointer ty noattr + | _ => ty end. (** ** Expressions *) @@ -207,33 +253,31 @@ as [*(r1 + r2)]. *) Definition Eindex (r1 r2: expr) (ty: type) := - Ederef (Ebinop Oadd r1 r2 (Tpointer ty)) ty. + Ederef (Ebinop Oadd r1 r2 (Tpointer ty noattr)) ty. (** Pre-increment [++l] and pre-decrement [--l] are expressed as [l += 1] and [l -= 1], respectively. *) Definition Epreincr (id: incr_or_decr) (l: expr) (ty: type) := Eassignop (match id with Incr => Oadd | Decr => Osub end) - l (Eval (Vint Int.one) (Tint I32 Signed)) (typeconv ty) ty. + l (Eval (Vint Int.one) type_int32s) (typeconv ty) ty. -(** Sequential ``and'' [r1 && r2] is viewed as two conditionals - [r1 ? (r2 ? 1 : 0) : 0]. *) +(** Sequential ``and'' [r1 && r2] is viewed as a conditional and a cast: + [r1 ? (_Bool) r2 : 0]. *) Definition Eseqand (r1 r2: expr) (ty: type) := Econdition r1 - (Econdition r2 (Eval (Vint Int.one) (Tint I32 Signed)) - (Eval (Vint Int.zero) (Tint I32 Signed)) ty) - (Eval (Vint Int.zero) (Tint I32 Signed)) + (Ecast r2 type_bool) + (Eval (Vint Int.zero) type_int32s) ty. -(** Sequential ``or'' [r1 || r2] is viewed as two conditionals - [r1 ? 1 : (r2 ? 1 : 0)]. *) +(** Sequential ``or'' [r1 || r2] is viewed as a conditional and a cast: + [r1 ? 1 : (_Bool) r2]. *) Definition Eseqor (r1 r2: expr) (ty: type) := Econdition r1 - (Eval (Vint Int.one) (Tint I32 Signed)) - (Econdition r2 (Eval (Vint Int.one) (Tint I32 Signed)) - (Eval (Vint Int.zero) (Tint I32 Signed)) ty) + (Eval (Vint Int.one) type_int32s) + (Ecast r2 type_bool) ty. (** Extract the type part of a type-annotated expression. *) @@ -353,17 +397,18 @@ Definition type_of_fundef (f: fundef) : type := Fixpoint alignof (t: type) : Z := match t with | Tvoid => 1 - | Tint I8 _ => 1 - | Tint I16 _ => 2 - | Tint I32 _ => 4 - | Tfloat F32 => 4 - | Tfloat F64 => 8 - | Tpointer _ => 4 - | Tarray t' n => alignof t' + | Tint I8 _ _ => 1 + | Tint I16 _ _ => 2 + | Tint I32 _ _ => 4 + | Tint IBool _ _ => 1 + | Tfloat F32 _ => 4 + | Tfloat F64 _ => 8 + | Tpointer _ _ => 4 + | Tarray t' _ _ => alignof t' | Tfunction _ _ => 1 - | Tstruct _ fld => alignof_fields fld - | Tunion _ fld => alignof_fields fld - | Tcomp_ptr _ => 4 + | Tstruct _ fld _ => alignof_fields fld + | Tunion _ fld _ => alignof_fields fld + | Tcomp_ptr _ _ => 4 end with alignof_fields (f: fieldlist) : Z := @@ -375,90 +420,47 @@ with alignof_fields (f: fieldlist) : Z := Scheme type_ind2 := Induction for type Sort Prop with fieldlist_ind2 := Induction for fieldlist Sort Prop. -Lemma alignof_power_of_2: - forall t, exists n, alignof t = two_power_nat n -with alignof_fields_power_of_2: - forall f, exists n, alignof_fields f = two_power_nat n. +Lemma alignof_1248: + forall t, alignof t = 1 \/ alignof t = 2 \/ alignof t = 4 \/ alignof t = 8 +with alignof_fields_1248: + forall f, alignof_fields f = 1 \/ alignof_fields f = 2 \/ alignof_fields f = 4 \/ alignof_fields f = 8. Proof. - induction t; simpl. - exists 0%nat; auto. - destruct i. exists 0%nat; auto. exists 1%nat; auto. exists 2%nat; auto. - destruct f. exists 2%nat; auto. exists 3%nat; auto. - exists 2%nat; auto. - auto. - exists 0%nat; auto. - apply alignof_fields_power_of_2. - apply alignof_fields_power_of_2. - exists 2%nat; auto. - induction f; simpl. - exists 0%nat; auto. + induction t; simpl; auto. + destruct i; auto. + destruct f; auto. + induction f; simpl; auto. rewrite Zmax_spec. destruct (zlt (alignof_fields f) (alignof t)); auto. Qed. Lemma alignof_pos: forall t, alignof t > 0. Proof. - intros. destruct (alignof_power_of_2 t) as [p EQ]. rewrite EQ. apply two_power_nat_pos. + intros. generalize (alignof_1248 t). omega. Qed. Lemma alignof_fields_pos: forall f, alignof_fields f > 0. Proof. - intros. destruct (alignof_fields_power_of_2 f) as [p EQ]. rewrite EQ. apply two_power_nat_pos. -Qed. - -(* -Fixpoint In_fieldlist (id: ident) (ty: type) (f: fieldlist) : Prop := - match f with - | Fnil => False - | Fcons id1 ty1 f1 => (id1 = id /\ ty1 = ty) \/ In_fieldlist id ty f1 - end. - -Remark divides_max_pow_two: - forall a b, - (two_power_nat b | Zmax (two_power_nat a) (two_power_nat b)). -Proof. - intros. - rewrite Zmax_spec. destruct (zlt (two_power_nat b) (two_power_nat a)). - repeat rewrite two_power_nat_two_p in *. - destruct (zle (Z_of_nat a) (Z_of_nat b)). - assert (two_p (Z_of_nat a) <= two_p (Z_of_nat b)). apply two_p_monotone; omega. - omegaContradiction. - exists (two_p (Z_of_nat a - Z_of_nat b)). - rewrite <- two_p_is_exp. decEq. omega. omega. omega. - apply Zdivide_refl. + intros. generalize (alignof_fields_1248 f). omega. Qed. -Lemma alignof_each_field: - forall f id t, In_fieldlist id t f -> (alignof t | alignof_fields f). -Proof. - induction f; simpl; intros. - contradiction. - destruct (alignof_power_of_2 t) as [k1 EQ1]. - destruct (alignof_fields_power_of_2 f) as [k2 EQ2]. - destruct H as [[A B] | A]; subst; rewrite EQ1; rewrite EQ2. - rewrite Zmax_comm. apply divides_max_pow_two. - eapply Zdivide_trans. eapply IHf; eauto. - rewrite EQ2. apply divides_max_pow_two. -Qed. -*) - (** Size of a type, in bytes. *) Fixpoint sizeof (t: type) : Z := match t with | Tvoid => 1 - | Tint I8 _ => 1 - | Tint I16 _ => 2 - | Tint I32 _ => 4 - | Tfloat F32 => 4 - | Tfloat F64 => 8 - | Tpointer _ => 4 - | Tarray t' n => sizeof t' * Zmax 1 n + | Tint I8 _ _ => 1 + | Tint I16 _ _ => 2 + | Tint I32 _ _ => 4 + | Tint IBool _ _ => 1 + | Tfloat F32 _ => 4 + | Tfloat F64 _ => 8 + | Tpointer _ _ => 4 + | Tarray t' n _ => sizeof t' * Zmax 1 n | Tfunction _ _ => 1 - | Tstruct _ fld => align (Zmax 1 (sizeof_struct fld 0)) (alignof t) - | Tunion _ fld => align (Zmax 1 (sizeof_union fld)) (alignof t) - | Tcomp_ptr _ => 4 + | Tstruct _ fld _ => align (Zmax 1 (sizeof_struct fld 0)) (alignof t) + | Tunion _ fld _ => align (Zmax 1 (sizeof_union fld)) (alignof t) + | Tcomp_ptr _ _ => 4 end with sizeof_struct (fld: fieldlist) (pos: Z) {struct fld} : Z := @@ -557,9 +559,9 @@ Proof. Qed. Lemma field_offset_in_range: - forall sid fld fid ofs ty, + forall sid fld a fid ofs ty, field_offset fid fld = OK ofs -> field_type fid fld = OK ty -> - 0 <= ofs /\ ofs + sizeof ty <= sizeof (Tstruct sid fld). + 0 <= ofs /\ ofs + sizeof ty <= sizeof (Tstruct sid fld a). Proof. intros. exploit field_offset_rec_in_range; eauto. intros [A B]. split. auto. simpl. eapply Zle_trans. eauto. @@ -638,33 +640,47 @@ type must be accessed: - [By_value ch]: access by value, i.e. by loading from the address of the l-value using the memory chunk [ch]; - [By_reference]: access by reference, i.e. by just returning - the address of the l-value; + the address of the l-value (used for arrays and functions); +- [By_copy]: access is by reference, assignment is by copy + (used for [struct] and [union] types) - [By_nothing]: no access is possible, e.g. for the [void] type. *) Inductive mode: Type := | By_value: memory_chunk -> mode | By_reference: mode + | By_copy: mode | By_nothing: mode. Definition access_mode (ty: type) : mode := match ty with - | Tint I8 Signed => By_value Mint8signed - | Tint I8 Unsigned => By_value Mint8unsigned - | Tint I16 Signed => By_value Mint16signed - | Tint I16 Unsigned => By_value Mint16unsigned - | Tint I32 _ => By_value Mint32 - | Tfloat F32 => By_value Mfloat32 - | Tfloat F64 => By_value Mfloat64 + | Tint I8 Signed _ => By_value Mint8signed + | Tint I8 Unsigned _ => By_value Mint8unsigned + | Tint I16 Signed _ => By_value Mint16signed + | Tint I16 Unsigned _ => By_value Mint16unsigned + | Tint I32 _ _ => By_value Mint32 + | Tint IBool _ _ => By_value Mint8unsigned + | Tfloat F32 _ => By_value Mfloat32 + | Tfloat F64 _ => By_value Mfloat64 | Tvoid => By_nothing - | Tpointer _ => By_value Mint32 - | Tarray _ _ => By_reference + | Tpointer _ _ => By_value Mint32 + | Tarray _ _ _ => By_reference | Tfunction _ _ => By_reference - | Tstruct _ fList => By_nothing - | Tunion _ fList => By_nothing - | Tcomp_ptr _ => By_nothing + | Tstruct _ _ _ => By_copy + | Tunion _ _ _ => By_copy + | Tcomp_ptr _ _ => By_nothing end. +(** For the purposes of the semantics and the compiler, a type denotes + a volatile access if it carries the [volatile] attribute and it is + accessed by value. *) + +Definition type_is_volatile (ty: type) : bool := + match access_mode ty with + | By_value _ => attr_volatile (attr_of_type ty) + | _ => false + end. + (** Unroll the type of a structure or union field, substituting [Tcomp_ptr] by a pointer to the structure. *) @@ -676,14 +692,14 @@ Variable comp: type. Fixpoint unroll_composite (ty: type) : type := match ty with | Tvoid => ty - | Tint _ _ => ty - | Tfloat _ => ty - | Tpointer t1 => Tpointer (unroll_composite t1) - | Tarray t1 sz => Tarray (unroll_composite t1) sz + | Tint _ _ _ => ty + | Tfloat _ _ => ty + | Tpointer t1 a => Tpointer (unroll_composite t1) a + | Tarray t1 sz a => Tarray (unroll_composite t1) sz a | Tfunction t1 t2 => Tfunction (unroll_composite_list t1) (unroll_composite t2) - | Tstruct id fld => if ident_eq id cid then ty else Tstruct id (unroll_composite_fields fld) - | Tunion id fld => if ident_eq id cid then ty else Tunion id (unroll_composite_fields fld) - | Tcomp_ptr id => if ident_eq id cid then Tpointer comp else ty + | Tstruct id fld a => if ident_eq id cid then ty else Tstruct id (unroll_composite_fields fld) a + | Tunion id fld a => if ident_eq id cid then ty else Tunion id (unroll_composite_fields fld) a + | Tcomp_ptr id a => if ident_eq id cid then Tpointer comp a else ty end with unroll_composite_list (tl: typelist) : typelist := @@ -721,9 +737,9 @@ Opaque alignof. sizeof_struct (unroll_composite_fields fld) pos = sizeof_struct fld pos)); simpl; intros; auto. congruence. - destruct H. rewrite <- (alignof_unroll_composite (Tstruct i f)). + destruct H. rewrite <- (alignof_unroll_composite (Tstruct i f a)). simpl. destruct (ident_eq i cid); simpl. auto. rewrite H0; auto. - destruct H. rewrite <- (alignof_unroll_composite (Tunion i f)). + destruct H. rewrite <- (alignof_unroll_composite (Tunion i f a)). simpl. destruct (ident_eq i cid); simpl. auto. rewrite H; auto. destruct (ident_eq i cid); auto. destruct H0. split. congruence. @@ -750,9 +766,9 @@ Inductive classify_neg_cases : Type := Definition classify_neg (ty: type) : classify_neg_cases := match ty with - | Tint I32 Unsigned => neg_case_i Unsigned - | Tint _ _ => neg_case_i Signed - | Tfloat _ => neg_case_f + | Tint I32 Unsigned _ => neg_case_i Unsigned + | Tint _ _ _ => neg_case_i Signed + | Tfloat _ _ => neg_case_f | _ => neg_default end. @@ -762,8 +778,8 @@ Inductive classify_notint_cases : Type := Definition classify_notint (ty: type) : classify_notint_cases := match ty with - | Tint I32 Unsigned => notint_case_i Unsigned - | Tint _ _ => notint_case_i Signed + | Tint I32 Unsigned _ => notint_case_i Unsigned + | Tint _ _ _ => notint_case_i Signed | _ => notint_default end. @@ -778,9 +794,9 @@ Inductive classify_bool_cases : Type := Definition classify_bool (ty: type) : classify_bool_cases := match typeconv ty with - | Tint _ _ => bool_case_ip - | Tpointer _ => bool_case_ip - | Tfloat _ => bool_case_f + | Tint _ _ _ => bool_case_ip + | Tpointer _ _ => bool_case_ip + | Tfloat _ _ => bool_case_f | _ => bool_default end. @@ -789,20 +805,20 @@ Inductive classify_add_cases : Type := | add_case_ff (**r float, float *) | add_case_if(s: signedness) (**r int, float *) | add_case_fi(s: signedness) (**r float, int *) - | add_case_pi(ty: type) (**r pointer, int *) - | add_case_ip(ty: type) (**r int, pointer *) + | add_case_pi(ty: type)(a: attr) (**r pointer, int *) + | add_case_ip(ty: type)(a: attr) (**r int, pointer *) | add_default. Definition classify_add (ty1: type) (ty2: type) := match typeconv ty1, typeconv ty2 with - | Tint I32 Unsigned, Tint _ _ => add_case_ii Unsigned - | Tint _ _, Tint I32 Unsigned => add_case_ii Unsigned - | Tint _ _, Tint _ _ => add_case_ii Signed - | Tfloat _, Tfloat _ => add_case_ff - | Tint _ sg, Tfloat _ => add_case_if sg - | Tfloat _, Tint _ sg => add_case_fi sg - | Tpointer ty, Tint _ _ => add_case_pi ty - | Tint _ _, Tpointer ty => add_case_ip ty + | Tint I32 Unsigned _, Tint _ _ _ => add_case_ii Unsigned + | Tint _ _ _, Tint I32 Unsigned _ => add_case_ii Unsigned + | Tint _ _ _, Tint _ _ _ => add_case_ii Signed + | Tfloat _ _, Tfloat _ _ => add_case_ff + | Tint _ sg _, Tfloat _ _ => add_case_if sg + | Tfloat _ _, Tint _ sg _ => add_case_fi sg + | Tpointer ty a, Tint _ _ _ => add_case_pi ty a + | Tint _ _ _, Tpointer ty a => add_case_ip ty a | _, _ => add_default end. @@ -817,14 +833,14 @@ Inductive classify_sub_cases : Type := Definition classify_sub (ty1: type) (ty2: type) := match typeconv ty1, typeconv ty2 with - | Tint I32 Unsigned, Tint _ _ => sub_case_ii Unsigned - | Tint _ _, Tint I32 Unsigned => sub_case_ii Unsigned - | Tint _ _, Tint _ _ => sub_case_ii Signed - | Tfloat _ , Tfloat _ => sub_case_ff - | Tint _ sg, Tfloat _ => sub_case_if sg - | Tfloat _, Tint _ sg => sub_case_fi sg - | Tpointer ty , Tint _ _ => sub_case_pi ty - | Tpointer ty , Tpointer _ => sub_case_pp ty + | Tint I32 Unsigned _, Tint _ _ _ => sub_case_ii Unsigned + | Tint _ _ _, Tint I32 Unsigned _ => sub_case_ii Unsigned + | Tint _ _ _, Tint _ _ _ => sub_case_ii Signed + | Tfloat _ _ , Tfloat _ _ => sub_case_ff + | Tint _ sg _, Tfloat _ _ => sub_case_if sg + | Tfloat _ _, Tint _ sg _ => sub_case_fi sg + | Tpointer ty _, Tint _ _ _ => sub_case_pi ty + | Tpointer ty _ , Tpointer _ _ => sub_case_pp ty | _ ,_ => sub_default end. @@ -837,12 +853,12 @@ Inductive classify_mul_cases : Type:= Definition classify_mul (ty1: type) (ty2: type) := match typeconv ty1, typeconv ty2 with - | Tint I32 Unsigned, Tint _ _ => mul_case_ii Unsigned - | Tint _ _, Tint I32 Unsigned => mul_case_ii Unsigned - | Tint _ _, Tint _ _ => mul_case_ii Signed - | Tfloat _ , Tfloat _ => mul_case_ff - | Tint _ sg, Tfloat _ => mul_case_if sg - | Tfloat _, Tint _ sg => mul_case_fi sg + | Tint I32 Unsigned _, Tint _ _ _ => mul_case_ii Unsigned + | Tint _ _ _, Tint I32 Unsigned _ => mul_case_ii Unsigned + | Tint _ _ _, Tint _ _ _ => mul_case_ii Signed + | Tfloat _ _ , Tfloat _ _ => mul_case_ff + | Tint _ sg _, Tfloat _ _ => mul_case_if sg + | Tfloat _ _, Tint _ sg _ => mul_case_fi sg | _,_ => mul_default end. @@ -855,12 +871,12 @@ Inductive classify_div_cases : Type:= Definition classify_div (ty1: type) (ty2: type) := match typeconv ty1, typeconv ty2 with - | Tint I32 Unsigned, Tint _ _ => div_case_ii Unsigned - | Tint _ _, Tint I32 Unsigned => div_case_ii Unsigned - | Tint _ _, Tint _ _ => div_case_ii Signed - | Tfloat _ , Tfloat _ => div_case_ff - | Tint _ sg, Tfloat _ => div_case_if sg - | Tfloat _, Tint _ sg => div_case_fi sg + | Tint I32 Unsigned _, Tint _ _ _ => div_case_ii Unsigned + | Tint _ _ _, Tint I32 Unsigned _ => div_case_ii Unsigned + | Tint _ _ _, Tint _ _ _ => div_case_ii Signed + | Tfloat _ _ , Tfloat _ _ => div_case_ff + | Tint _ sg _, Tfloat _ _ => div_case_if sg + | Tfloat _ _, Tint _ sg _ => div_case_fi sg | _,_ => div_default end. @@ -873,9 +889,9 @@ Inductive classify_binint_cases : Type:= Definition classify_binint (ty1: type) (ty2: type) := match typeconv ty1, typeconv ty2 with - | Tint I32 Unsigned, Tint _ _ => binint_case_ii Unsigned - | Tint _ _, Tint I32 Unsigned => binint_case_ii Unsigned - | Tint _ _, Tint _ _ => binint_case_ii Signed + | Tint I32 Unsigned _, Tint _ _ _ => binint_case_ii Unsigned + | Tint _ _ _, Tint I32 Unsigned _ => binint_case_ii Unsigned + | Tint _ _ _, Tint _ _ _ => binint_case_ii Signed | _,_ => binint_default end. @@ -887,8 +903,8 @@ Inductive classify_shift_cases : Type:= Definition classify_shift (ty1: type) (ty2: type) := match typeconv ty1, typeconv ty2 with - | Tint I32 Unsigned, Tint _ _ => shift_case_ii Unsigned - | Tint _ _, Tint _ _ => shift_case_ii Signed + | Tint I32 Unsigned _, Tint _ _ _ => shift_case_ii Unsigned + | Tint _ _ _, Tint _ _ _ => shift_case_ii Signed | _,_ => shift_default end. @@ -902,15 +918,15 @@ Inductive classify_cmp_cases : Type:= Definition classify_cmp (ty1: type) (ty2: type) := match typeconv ty1, typeconv ty2 with - | Tint I32 Unsigned , Tint _ _ => cmp_case_ii Unsigned - | Tint _ _ , Tint I32 Unsigned => cmp_case_ii Unsigned - | Tint _ _ , Tint _ _ => cmp_case_ii Signed - | Tfloat _ , Tfloat _ => cmp_case_ff - | Tint _ sg, Tfloat _ => cmp_case_if sg - | Tfloat _, Tint _ sg => cmp_case_fi sg - | Tpointer _ , Tpointer _ => cmp_case_pp - | Tpointer _ , Tint _ _ => cmp_case_pp - | Tint _ _, Tpointer _ => cmp_case_pp + | Tint I32 Unsigned _ , Tint _ _ _ => cmp_case_ii Unsigned + | Tint _ _ _ , Tint I32 Unsigned _ => cmp_case_ii Unsigned + | Tint _ _ _ , Tint _ _ _ => cmp_case_ii Signed + | Tfloat _ _ , Tfloat _ _ => cmp_case_ff + | Tint _ sg _, Tfloat _ _ => cmp_case_if sg + | Tfloat _ _, Tint _ sg _ => cmp_case_fi sg + | Tpointer _ _ , Tpointer _ _ => cmp_case_pp + | Tpointer _ _ , Tint _ _ _ => cmp_case_pp + | Tint _ _ _, Tpointer _ _ => cmp_case_pp | _ , _ => cmp_default end. @@ -921,7 +937,7 @@ Inductive classify_fun_cases : Type:= Definition classify_fun (ty: type) := match ty with | Tfunction args res => fun_case_f args res - | Tpointer (Tfunction args res) => fun_case_f args res + | Tpointer (Tfunction args res) _ => fun_case_f args res | _ => fun_default end. @@ -931,17 +947,25 @@ Inductive classify_cast_cases : Type := | cast_case_f2f (sz2:floatsize) (**r float -> float *) | cast_case_i2f (si1:signedness) (sz2:floatsize) (**r int -> float *) | cast_case_f2i (sz2:intsize) (si2:signedness) (**r float -> int *) + | cast_case_ip2bool (**r int|pointer -> bool *) + | cast_case_f2bool (**r float -> bool *) + | cast_case_struct (id1: ident) (fld1: fieldlist) (id2: ident) (fld2: fieldlist) (**r struct -> struct *) + | cast_case_union (id1: ident) (fld1: fieldlist) (id2: ident) (fld2: fieldlist) (**r union -> union *) | cast_case_void (**r any -> void *) | cast_case_default. Function classify_cast (tfrom tto: type) : classify_cast_cases := match tto, tfrom with - | Tint I32 si2, (Tint _ _ | Tpointer _ | Tarray _ _ | Tfunction _ _) => cast_case_neutral - | Tint sz2 si2, Tint sz1 si1 => cast_case_i2i sz2 si2 - | Tint sz2 si2, Tfloat sz1 => cast_case_f2i sz2 si2 - | Tfloat sz2, Tfloat sz1 => cast_case_f2f sz2 - | Tfloat sz2, Tint sz1 si1 => cast_case_i2f si1 sz2 - | Tpointer _, (Tint _ _ | Tpointer _ | Tarray _ _ | Tfunction _ _) => cast_case_neutral + | Tint I32 si2 _, (Tint _ _ _ | Tpointer _ _ | Tarray _ _ _ | Tfunction _ _) => cast_case_neutral + | Tint IBool _ _, (Tint _ _ _ | Tpointer _ _ | Tarray _ _ _ | Tfunction _ _) => cast_case_ip2bool + | Tint IBool _ _, Tfloat _ _ => cast_case_f2bool + | Tint sz2 si2 _, Tint sz1 si1 _ => cast_case_i2i sz2 si2 + | Tint sz2 si2 _, Tfloat sz1 _ => cast_case_f2i sz2 si2 + | Tfloat sz2 _, Tfloat sz1 _ => cast_case_f2f sz2 + | Tfloat sz2 _, Tint sz1 si1 _ => cast_case_i2f si1 sz2 + | Tpointer _ _, (Tint _ _ _ | Tpointer _ _ | Tarray _ _ _ | Tfunction _ _) => cast_case_neutral + | Tstruct id2 fld2 _, Tstruct id1 fld1 _ => cast_case_struct id1 fld1 id2 fld2 + | Tunion id2 fld2 _, Tunion id1 fld1 _ => cast_case_union id1 fld1 id2 fld2 | Tvoid, _ => cast_case_void | _, _ => cast_case_default end. @@ -951,14 +975,14 @@ Function classify_cast (tfrom tto: type) : classify_cast_cases := Definition typ_of_type (t: type) : AST.typ := match t with - | Tfloat _ => AST.Tfloat + | Tfloat _ _ => AST.Tfloat | _ => AST.Tint end. Definition opttyp_of_type (t: type) : option AST.typ := match t with | Tvoid => None - | Tfloat _ => Some AST.Tfloat + | Tfloat _ _ => Some AST.Tfloat | _ => Some AST.Tint end. diff --git a/cfrontend/Initializers.v b/cfrontend/Initializers.v index 223d75c..e9c40a2 100644 --- a/cfrontend/Initializers.v +++ b/cfrontend/Initializers.v @@ -97,11 +97,11 @@ Fixpoint constval (a: expr) : res val := constval r | Efield l f ty => match typeof l with - | Tstruct id fList => + | Tstruct id fList _ => do delta <- field_offset f fList; do v <- constval l; OK (Val.add v (Vint (Int.repr delta))) - | Tunion id fList => + | Tunion id fList _ => constval l | _ => Error(msg "ill-typed field access") @@ -128,14 +128,14 @@ Definition transl_init_single (ty: type) (a: expr) : res init_data := do v1 <- constval a; do v2 <- do_cast v1 (typeof a) ty; match v2, ty with - | Vint n, Tint I8 sg => OK(Init_int8 n) - | Vint n, Tint I16 sg => OK(Init_int16 n) - | Vint n, Tint I32 sg => OK(Init_int32 n) - | Vint n, Tpointer _ => OK(Init_int32 n) - | Vfloat f, Tfloat F32 => OK(Init_float32 f) - | Vfloat f, Tfloat F64 => OK(Init_float64 f) - | Vptr (Zpos id) ofs, Tint I32 sg => OK(Init_addrof id ofs) - | Vptr (Zpos id) ofs, Tpointer _ => OK(Init_addrof id ofs) + | Vint n, Tint I8 sg _ => OK(Init_int8 n) + | Vint n, Tint I16 sg _ => OK(Init_int16 n) + | Vint n, Tint I32 sg _ => OK(Init_int32 n) + | Vint n, Tpointer _ _ => OK(Init_int32 n) + | Vfloat f, Tfloat F32 _ => OK(Init_float32 f) + | Vfloat f, Tfloat F64 _ => OK(Init_float64 f) + | Vptr (Zpos id) ofs, Tint I32 sg _ => OK(Init_addrof id ofs) + | Vptr (Zpos id) ofs, Tpointer _ _ => OK(Init_addrof id ofs) | Vundef, _ => Error(msg "undefined operation in initializer") | _, _ => Error (msg "type mismatch in initializer") end. @@ -152,17 +152,17 @@ Fixpoint transl_init (ty: type) (i: initializer) match i, ty with | Init_single a, _ => do d <- transl_init_single ty a; OK (d :: nil) - | Init_compound il, Tarray tyelt sz => + | Init_compound il, Tarray tyelt sz _ => if zle sz 0 then OK (Init_space(sizeof tyelt) :: nil) else transl_init_array tyelt il sz - | Init_compound il, Tstruct _ Fnil => + | Init_compound il, Tstruct _ Fnil _ => OK (Init_space (sizeof ty) :: nil) - | Init_compound il, Tstruct id fl => + | Init_compound il, Tstruct id fl _ => transl_init_struct id ty fl il 0 - | Init_compound il, Tunion _ Fnil => + | Init_compound il, Tunion _ Fnil _ => OK (Init_space (sizeof ty) :: nil) - | Init_compound il, Tunion id (Fcons _ ty1 _) => + | Init_compound il, Tunion id (Fcons _ ty1 _) _ => transl_init_union id ty ty1 il | _, _ => Error (msg "wrong type for compound initializer") diff --git a/cfrontend/Initializersproof.v b/cfrontend/Initializersproof.v index 6563a35..4d287bc 100644 --- a/cfrontend/Initializersproof.v +++ b/cfrontend/Initializersproof.v @@ -86,14 +86,14 @@ Inductive eval_simple_lvalue: expr -> block -> int -> Prop := | esl_deref: forall r ty b ofs, eval_simple_rvalue r (Vptr b ofs) -> eval_simple_lvalue (Ederef r ty) b ofs - | esl_field_struct: forall l f ty b ofs id fList delta, - eval_simple_lvalue l b ofs -> - typeof l = Tstruct id fList -> field_offset f fList = OK delta -> - eval_simple_lvalue (Efield l f ty) b (Int.add ofs (Int.repr delta)) - | esl_field_union: forall l f ty b ofs id fList, - eval_simple_lvalue l b ofs -> - typeof l = Tunion id fList -> - eval_simple_lvalue (Efield l f ty) b ofs + | esl_field_struct: forall r f ty b ofs id fList a delta, + eval_simple_rvalue r (Vptr b ofs) -> + typeof r = Tstruct id fList a -> field_offset f fList = OK delta -> + eval_simple_lvalue (Efield r f ty) b (Int.add ofs (Int.repr delta)) + | esl_field_union: forall r f ty b ofs id fList a, + eval_simple_rvalue r (Vptr b ofs) -> + typeof r = Tunion id fList a -> + eval_simple_lvalue (Efield r f ty) b ofs with eval_simple_rvalue: expr -> val -> Prop := | esr_val: forall v ty, @@ -101,7 +101,7 @@ with eval_simple_rvalue: expr -> val -> Prop := | esr_rvalof: forall b ofs l ty v, eval_simple_lvalue l b ofs -> ty = typeof l -> - load_value_of_type ty m b ofs = Some v -> + deref_loc ge ty m b ofs E0 v -> eval_simple_rvalue (Evalof l ty) v | esr_addrof: forall b ofs l ty, eval_simple_lvalue l b ofs -> @@ -166,17 +166,17 @@ Proof. Qed. Lemma rred_simple: - forall r m r' m', rred r m r' m' -> simple r -> simple r'. + forall r m t r' m', rred ge r m t r' m' -> simple r -> simple r'. Proof. induction 1; simpl; intuition. destruct b; auto. Qed. Lemma rred_compat: - forall e r m r' m', rred r m r' m' -> + forall e r m r' m', rred ge r m E0 r' m' -> simple r -> m = m' /\ compat_eval RV e r r' m. Proof. - induction 1; simpl; intro SIMP; try contradiction; split; auto; split; auto; intros vx EV. + intros until m'; intros RED SIMP. inv RED; simpl in SIMP; try contradiction; split; auto; split; auto; intros vx EV. inv EV. econstructor. constructor. auto. auto. inv EV. econstructor. constructor. inv EV. econstructor; eauto. constructor. @@ -227,12 +227,12 @@ Qed. Lemma simple_context_2: forall a a', simple a' -> forall from to C, context from to C -> simple (C a) -> simple (C a'). Proof. - induction 2; simpl; tauto. + induction 2; simpl; try tauto. Qed. Lemma compat_eval_steps: - forall f r e m w r' m', - star step ge (ExprState f r Kstop e m) w (ExprState f r' Kstop e m') -> + forall f r e m r' m', + star step ge (ExprState f r Kstop e m) E0 (ExprState f r' Kstop e m') -> simple r -> m' = m /\ compat_eval RV e r r' m. Proof. @@ -240,10 +240,10 @@ Proof. (* base case *) split. auto. red; auto. (* inductive case *) - destruct H. + destruct (app_eq_nil t1 t2); auto. subst. inv H. (* expression step *) assert (X: exists r1, s2 = ExprState f r1 Kstop e m /\ compat_eval RV e r r1 m /\ simple r1). - inv H. + inv H3. (* lred *) assert (S: simple a) by (eapply simple_context_1; eauto). exploit lred_compat; eauto. intros [A B]. subst m'0. @@ -258,17 +258,19 @@ Proof. eapply simple_context_2; eauto. eapply rred_simple; eauto. (* callred *) assert (S: simple a) by (eapply simple_context_1; eauto). - inv H10; simpl in S; contradiction. + inv H9; simpl in S; contradiction. + (* stuckred *) + inv H2. destruct H; inv H. destruct X as [r1 [A [B C]]]. subst s2. exploit IHstar; eauto. intros [D E]. split. auto. destruct B; destruct E. split. congruence. auto. (* statement steps *) - inv H. + inv H3. Qed. Theorem eval_simple_steps: - forall f r e m w v ty m', - star step ge (ExprState f r Kstop e m) w (ExprState f (Eval v ty) Kstop e m') -> + forall f r e m v ty m', + star step ge (ExprState f r Kstop e m) E0 (ExprState f (Eval v ty) Kstop e m') -> simple r -> m' = m /\ ty = typeof r /\ eval_simple_rvalue e m r v. Proof. @@ -406,6 +408,12 @@ Proof. rewrite H2 in H. inv H0. inv H. constructor. rewrite H2 in H. inv H0. inv H. constructor. rewrite H2 in H. inv H0. destruct (cast_float_int si2 f); inv H. inv H7. constructor. + rewrite H2 in H. inv H0. inv H. constructor. + rewrite H2 in H. inv H0. inv H. constructor. + rewrite H2 in H. inv H0. inv H. rewrite H7. constructor. + rewrite H2 in H. inv H0. inv H. rewrite H7. constructor. + rewrite H2 in H. destruct (ident_eq id1 id2 && fieldlist_eq fld1 fld2); inv H. auto. + rewrite H2 in H. destruct (ident_eq id1 id2 && fieldlist_eq fld1 fld2); inv H. auto. rewrite H5 in H. inv H. auto. Qed. @@ -437,8 +445,7 @@ Proof. (* val *) destruct v; monadInv CV; constructor. (* rval *) - unfold load_value_of_type in H1. destruct (access_mode ty); try congruence. inv H1. - eauto. + inv H1; rewrite H2 in CV; try congruence. eauto. (* addrof *) eauto. (* unop *) @@ -468,10 +475,10 @@ Proof. (* deref *) eauto. (* field struct *) - rewrite H0 in CV. monadInv CV. exploit IHeval_simple_lvalue; eauto. intro MV. inv MV. + rewrite H0 in CV. monadInv CV. exploit constval_rvalue; eauto. intro MV. inv MV. simpl. replace x with delta by congruence. constructor. auto. (* field union *) - rewrite H0 in CV. auto. + rewrite H0 in CV. eauto. Qed. Lemma constval_simple: @@ -487,8 +494,8 @@ Qed. (** Soundness of [constval] with respect to the reduction semantics. *) Theorem constval_steps: - forall f r m w v v' ty m', - star step ge (ExprState f r Kstop empty_env m) w (ExprState f (Eval v' ty) Kstop empty_env m') -> + forall f r m v v' ty m', + star step ge (ExprState f r Kstop empty_env m) E0 (ExprState f (Eval v' ty) Kstop empty_env m') -> constval r = OK v -> m' = m /\ ty = typeof r /\ match_val v v'. Proof. @@ -501,9 +508,9 @@ Qed. (** Soundness for single initializers. *) Theorem transl_init_single_steps: - forall ty a data f m w v1 ty1 m' v chunk b ofs m'', + forall ty a data f m v1 ty1 m' v chunk b ofs m'', transl_init_single ty a = OK data -> - star step ge (ExprState f a Kstop empty_env m) w (ExprState f (Eval v1 ty1) Kstop empty_env m') -> + star step ge (ExprState f a Kstop empty_env m) E0 (ExprState f (Eval v1 ty1) Kstop empty_env m') -> sem_cast v1 ty1 ty = Some v -> access_mode ty = By_value chunk -> Mem.store chunk m' b ofs v = Some m'' -> @@ -583,9 +590,9 @@ Proof. Qed. Remark sizeof_struct_eq: - forall id fl, + forall id fl a, fl <> Fnil -> - sizeof (Tstruct id fl) = align (sizeof_struct fl 0) (alignof (Tstruct id fl)). + sizeof (Tstruct id fl a) = align (sizeof_struct fl 0) (alignof (Tstruct id fl a)). Proof. intros. simpl. f_equal. rewrite Zmax_spec. apply zlt_false. destruct fl. congruence. simpl. @@ -595,9 +602,9 @@ Proof. Qed. Remark sizeof_union_eq: - forall id fl, + forall id fl a, fl <> Fnil -> - sizeof (Tunion id fl) = align (sizeof_union fl) (alignof (Tunion id fl)). + sizeof (Tunion id fl a) = align (sizeof_union fl) (alignof (Tunion id fl a)). Proof. intros. simpl. f_equal. rewrite Zmax_spec. apply zlt_false. destruct fl. congruence. simpl. @@ -705,15 +712,15 @@ Inductive exec_init: mem -> block -> Z -> type -> initializer -> mem -> Prop := access_mode ty = By_value chunk -> Mem.store chunk m' b ofs v = Some m'' -> exec_init m b ofs ty (Init_single a) m'' - | exec_init_compound_array: forall m b ofs ty sz il m', + | exec_init_compound_array: forall m b ofs ty sz a il m', exec_init_array m b ofs ty sz il m' -> - exec_init m b ofs (Tarray ty sz) (Init_compound il) m' - | exec_init_compound_struct: forall m b ofs id fl il m', - exec_init_list m b ofs (fields_of_struct id (Tstruct id fl) fl 0) il m' -> - exec_init m b ofs (Tstruct id fl) (Init_compound il) m' - | exec_init_compound_union: forall m b ofs id id1 ty1 fl i m', - exec_init m b ofs (unroll_composite id (Tunion id (Fcons id1 ty1 fl)) ty1) i m' -> - exec_init m b ofs (Tunion id (Fcons id1 ty1 fl)) (Init_compound (Init_cons i Init_nil)) m' + exec_init m b ofs (Tarray ty sz a) (Init_compound il) m' + | exec_init_compound_struct: forall m b ofs id fl a il m', + exec_init_list m b ofs (fields_of_struct id (Tstruct id fl a) fl 0) il m' -> + exec_init m b ofs (Tstruct id fl a) (Init_compound il) m' + | exec_init_compound_union: forall m b ofs id id1 ty1 fl a i m', + exec_init m b ofs (unroll_composite id (Tunion id (Fcons id1 ty1 fl) a) ty1) i m' -> + exec_init m b ofs (Tunion id (Fcons id1 ty1 fl) a) (Init_compound (Init_cons i Init_nil)) m' with exec_init_array: mem -> block -> Z -> type -> Z -> initializer_list -> mem -> Prop := | exec_init_array_nil: forall m b ofs ty, diff --git a/cfrontend/PrintClight.ml b/cfrontend/PrintClight.ml index 306224b..83a0747 100644 --- a/cfrontend/PrintClight.ml +++ b/cfrontend/PrintClight.ml @@ -128,6 +128,8 @@ let rec print_stmt p s = fprintf p "@[<hv 2>%a =@ %a;@]" print_expr e1 print_expr e2 | Sset(id, e2) -> fprintf p "@[<hv 2>%s =@ %a;@]" (temp_name id) print_expr e2 + | Svolread(id, e2) -> + fprintf p "@[<hv 2>%s =@ %a; /*volatile*/@]" (temp_name id) print_expr e2 | Scall(None, e1, el) -> fprintf p "@[<hv 2>%a@,(@[<hov 0>%a@]);@]" print_expr e1 @@ -251,25 +253,6 @@ let print_fundef p (id, fd) = (* Collect struct and union types *) -let rec collect_type = function - | Tvoid -> () - | Tint(sz, sg) -> () - | Tfloat sz -> () - | Tpointer t -> collect_type t - | Tarray(t, n) -> collect_type t - | Tfunction(args, res) -> collect_type_list args; collect_type res - | Tstruct(id, fld) -> register_struct_union id fld; collect_fields fld - | Tunion(id, fld) -> register_struct_union id fld; 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 = function | Econst_int _ -> () | Econst_float _ -> () @@ -293,6 +276,7 @@ let rec collect_stmt = function | Sskip -> () | Sassign(e1, e2) -> collect_expr e1; collect_expr e2 | Sset(id, e2) -> collect_expr e2 + | Svolread(id, e2) -> collect_expr e2 | Scall(optid, e1, el) -> collect_expr e1; 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 diff --git a/cfrontend/PrintCsyntax.ml b/cfrontend/PrintCsyntax.ml index f0e9ee5..d4e728e 100644 --- a/cfrontend/PrintCsyntax.ml +++ b/cfrontend/PrintCsyntax.ml @@ -15,6 +15,7 @@ (** Pretty-printer for Csyntax *) +open Printf open Format open Camlcoq open Datatypes @@ -53,6 +54,7 @@ let name_inttype sz sg = | I16, Unsigned -> "unsigned short" | I32, Signed -> "int" | I32, Unsigned -> "unsigned int" + | IBool, _ -> "_Bool" let name_floattype sz = match sz with @@ -73,31 +75,38 @@ let register_struct_union id fld = (* Declarator (identifier + type) *) +let attributes a = + if attr_volatile a then " volatile" else "" + let name_optid id = if id = "" then "" else " " ^ id +(* let parenthesize_if_pointer id = if String.length id > 0 && id.[0] = '*' then "(" ^ id ^ ")" else id +*) let rec name_cdecl id ty = match ty with | Tvoid -> "void" ^ name_optid id - | Tint(sz, sg) -> - name_inttype sz sg ^ name_optid id - | Tfloat sz -> - name_floattype sz ^ name_optid id - | Tpointer t -> - name_cdecl ("*" ^ id) t - | Tarray(t, n) -> - name_cdecl - (sprintf "%s[%ld]" (parenthesize_if_pointer id) (camlint_of_coqint n)) - t + | Tint(sz, sg, a) -> + name_inttype sz sg ^ attributes a ^ name_optid id + | Tfloat(sz, a) -> + name_floattype sz ^ attributes a ^ name_optid id + | Tpointer(t, a) -> + let id' = + match t with + | Tfunction _ | Tarray _ -> sprintf "(*%s%s)" (attributes a) id + | _ -> sprintf "*%s%s" (attributes a) id in + name_cdecl id' t + | Tarray(t, n, a) -> + name_cdecl (sprintf "%s[%ld]" id (camlint_of_coqint n)) t | Tfunction(args, res) -> let b = Buffer.create 20 in if id = "" then Buffer.add_string b "(*)" - else Buffer.add_string b (parenthesize_if_pointer id); + else Buffer.add_string b id; Buffer.add_char b '('; begin match args with | Tnil -> @@ -113,12 +122,12 @@ let rec name_cdecl id ty = end; Buffer.add_char b ')'; name_cdecl (Buffer.contents b) res - | Tstruct(name, fld) -> - extern_atom name ^ name_optid id - | Tunion(name, fld) -> - extern_atom name ^ name_optid id - | Tcomp_ptr name -> - extern_atom name ^ " *" ^ id + | Tstruct(name, fld, a) -> + extern_atom name ^ attributes a ^ name_optid id + | Tunion(name, fld, a) -> + extern_atom name ^ attributes a ^ name_optid id + | Tcomp_ptr(name, a) -> + extern_atom name ^ " *" ^ attributes a ^ id (* Type *) @@ -403,13 +412,13 @@ let print_globvar p (id, v) = let rec collect_type = function | Tvoid -> () - | Tint(sz, sg) -> () - | Tfloat sz -> () - | Tpointer t -> collect_type t - | Tarray(t, n) -> collect_type t + | 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 id fld; collect_fields fld - | Tunion(id, fld) -> register_struct_union id fld; collect_fields fld + | Tstruct(id, fld, _) -> register_struct_union id fld; collect_fields fld + | Tunion(id, fld, _) -> register_struct_union id fld; collect_fields fld | Tcomp_ptr _ -> () and collect_type_list = function diff --git a/cfrontend/SimplExpr.v b/cfrontend/SimplExpr.v index a2e810b..1dae78c 100644 --- a/cfrontend/SimplExpr.v +++ b/cfrontend/SimplExpr.v @@ -129,10 +129,35 @@ Function makeif (a: expr) (s1 s2: statement) : statement := Definition transl_incrdecr (id: incr_or_decr) (a: expr) (ty: type) : expr := match id with - | Incr => Ebinop Oadd a (Econst_int Int.one (Tint I32 Signed)) (typeconv ty) - | Decr => Ebinop Osub a (Econst_int Int.one (Tint I32 Signed)) (typeconv ty) + | Incr => Ebinop Oadd a (Econst_int Int.one type_int32s) (typeconv ty) + | Decr => Ebinop Osub a (Econst_int Int.one type_int32s) (typeconv ty) end. +(** Generate a [Sset] or [Svolread] operation as appropriate + to dereference a l-value [l] and store its result in temporary variable [id]. *) + +Definition make_set (id: ident) (l: expr) : statement := + if type_is_volatile (typeof l) + then Svolread id l + else Sset id l. + +(** Translation of a "valof" operation. + If the l-value accessed is of volatile type, we go through a temporary. *) + +Definition transl_valof (ty: type) (l: expr) : mon (list statement * expr) := + if type_is_volatile ty + then (do t <- gensym ty; ret (Svolread t l :: nil, Etempvar t ty)) + else ret (nil, l). +(* + match access_mode ty with + | By_value _ => + if type_is_volatile ty + then (do t <- gensym ty; ret (Sset t l :: nil, Etempvar t ty)) + else ret (nil, l) + | _ => ret (nil, l) + end. +*) + (** Translation of expressions. Return a pair [(sl, a)] of a list of statements [sl] and a pure expression [a]. - If the [dst] argument is [For_val], the statements [sl] @@ -152,7 +177,7 @@ Inductive destination : Type := | For_effects | For_test (tyl: list type) (s1 s2: statement). -Definition dummy_expr := Econst_int Int.zero (Tint I32 Signed). +Definition dummy_expr := Econst_int Int.zero type_int32s. Definition finish (dst: destination) (sl: list statement) (a: expr) := match dst with @@ -177,8 +202,8 @@ Fixpoint transl_expr (dst: destination) (a: C.expr) : mon (list statement * expr | C.Ederef r ty => do (sl, a) <- transl_expr For_val r; ret (finish dst sl (Ederef a ty)) - | C.Efield l1 f ty => - do (sl, a) <- transl_expr For_val l1; + | C.Efield r f ty => + do (sl, a) <- transl_expr For_val r; ret (finish dst sl (Efield a f ty)) | C.Eval (Vint n) ty => ret (finish dst nil (Econst_int n ty)) @@ -189,8 +214,9 @@ Fixpoint transl_expr (dst: destination) (a: C.expr) : mon (list statement * expr | C.Esizeof ty' ty => ret (finish dst nil (Esizeof ty' ty)) | C.Evalof l ty => - do (sl, a) <- transl_expr For_val l; - ret (finish dst sl a) + do (sl1, a1) <- transl_expr For_val l; + do (sl2, a2) <- transl_valof (C.typeof l) a1; + ret (finish dst (sl1 ++ sl2) a2) | C.Eaddrof l ty => do (sl, a) <- transl_expr For_val l; ret (finish dst sl (Eaddrof a ty)) @@ -234,33 +260,35 @@ Fixpoint transl_expr (dst: destination) (a: C.expr) : mon (list statement * expr dummy_expr) end | C.Eassignop op l1 r2 tyres ty => + let ty1 := C.typeof l1 in do (sl1, a1) <- transl_expr For_val l1; do (sl2, a2) <- transl_expr For_val r2; - let ty1 := C.typeof l1 in + do (sl3, a3) <- transl_valof ty1 a1; match dst with | For_val | For_test _ _ _ => do t <- gensym tyres; ret (finish dst - (sl1 ++ sl2 ++ - Sset t (Ebinop op a1 a2 tyres) :: + (sl1 ++ sl2 ++ sl3 ++ + Sset t (Ebinop op a3 a2 tyres) :: Sassign a1 (Etempvar t tyres) :: nil) (Ecast (Etempvar t tyres) ty1)) | For_effects => - ret (sl1 ++ sl2 ++ Sassign a1 (Ebinop op a1 a2 tyres) :: nil, + ret (sl1 ++ sl2 ++ sl3 ++ Sassign a1 (Ebinop op a3 a2 tyres) :: nil, dummy_expr) end | C.Epostincr id l1 ty => - do (sl1, a1) <- transl_expr For_val l1; let ty1 := C.typeof l1 in + do (sl1, a1) <- transl_expr For_val l1; match dst with | For_val | For_test _ _ _ => do t <- gensym ty1; ret (finish dst - (sl1 ++ Sset t a1 :: + (sl1 ++ make_set t a1 :: Sassign a1 (transl_incrdecr id (Etempvar t ty1) ty1) :: nil) (Etempvar t ty1)) | For_effects => - ret (sl1 ++ Sassign a1 (transl_incrdecr id a1 ty1) :: nil, + do (sl2, a2) <- transl_valof ty1 a1; + ret (sl1 ++ sl2 ++ Sassign a1 (transl_incrdecr id a2 ty1) :: nil, dummy_expr) end | C.Ecomma r1 r2 ty => @@ -303,7 +331,7 @@ Definition transl_if (r: C.expr) (s1 s2: statement) : mon statement := (** Translation of statements *) -Definition expr_true := Econst_int Int.one (Tint I32 Signed). +Definition expr_true := Econst_int Int.one type_int32s. Definition is_Sskip: forall s, {s = C.Sskip} + {s <> C.Sskip}. diff --git a/cfrontend/SimplExprproof.v b/cfrontend/SimplExprproof.v index 2372d02..4df5f03 100644 --- a/cfrontend/SimplExprproof.v +++ b/cfrontend/SimplExprproof.v @@ -68,6 +68,12 @@ Lemma varinfo_preserved: Proof (Genv.find_var_info_transf_partial transl_fundef _ TRANSL). +Lemma block_is_volatile_preserved: + forall b, block_is_volatile tge b = block_is_volatile ge b. +Proof. + intros. unfold block_is_volatile. rewrite varinfo_preserved. auto. +Qed. + Lemma type_of_fundef_preserved: forall f tf, transl_fundef f = OK tf -> type_of_fundef tf = C.type_of_fundef f. @@ -114,7 +120,7 @@ Proof. rewrite H0; auto. simpl; auto. rewrite H0; auto. simpl; auto. destruct H1; congruence. - rewrite H0; auto. simpl; auto. + destruct H6. inv H1; try congruence. rewrite H0; auto. simpl; auto. rewrite H0; auto. simpl; auto. rewrite H0; auto. simpl; auto. destruct H7. rewrite H0; auto. rewrite H2; auto. simpl; auto. @@ -134,6 +140,31 @@ Proof (proj2 tr_simple_nil). (** Evaluation of simple expressions and of their translation *) +Remark deref_loc_preserved: + forall ty m b ofs t v, + deref_loc ge ty m b ofs t v -> deref_loc tge ty m b ofs t v. +Proof. + intros. inv H. + eapply deref_loc_value; eauto. + eapply deref_loc_volatile; eauto. + eapply volatile_load_preserved with (ge1 := ge); auto. + exact symbols_preserved. exact block_is_volatile_preserved. + eapply deref_loc_reference; eauto. + eapply deref_loc_copy; eauto. +Qed. + +Remark assign_loc_preserved: + forall ty m b ofs v t m', + assign_loc ge ty m b ofs v t m' -> assign_loc tge ty m b ofs v t m'. +Proof. + intros. inv H. + eapply assign_loc_value; eauto. + eapply assign_loc_volatile; eauto. + eapply volatile_store_preserved with (ge1 := ge); auto. + exact symbols_preserved. exact block_is_volatile_preserved. + eapply assign_loc_copy; eauto. +Qed. + Lemma tr_simple: forall e m, (forall r v, @@ -163,9 +194,11 @@ Opaque makeif. auto. exists a0; auto. (* rvalof *) + inv H7; try congruence. exploit H0; eauto. intros [A [B C]]. subst sl1; simpl. - assert (eval_expr tge e le m a v). eapply eval_Elvalue. eauto. congruence. + assert (eval_expr tge e le m a v). + eapply eval_Elvalue. eauto. congruence. rewrite <- B. eapply deref_loc_preserved; eauto. destruct dst; auto. econstructor. split. simpl; eauto. auto. (* addrof *) @@ -346,9 +379,9 @@ Ltac TR := Ltac NOTIN := match goal with | [ H1: In ?x ?l, H2: list_disjoint ?l _ |- ~In ?x _ ] => - red; intro; elim (H2 x x); auto + red; intro; elim (H2 x x); auto; fail | [ H1: In ?x ?l, H2: list_disjoint _ ?l |- ~In ?x _ ] => - red; intro; elim (H2 x x); auto + red; intro; elim (H2 x x); auto; fail end. Ltac UNCHANGED := @@ -377,8 +410,9 @@ Ltac UNCHANGED := (* rvalof *) inv H1. exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [U [R S]]]]]]]]]. - TR. subst sl1; rewrite app_ass; eauto. auto. - intros. rewrite <- app_ass; econstructor; eauto. + TR. subst sl1; rewrite app_ass; eauto. red; eauto. + intros. rewrite <- app_ass; econstructor; eauto. + exploit typeof_context; eauto. congruence. (* addrof *) inv H1. exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [U [R S]]]]]]]]]. @@ -475,15 +509,16 @@ Ltac UNCHANGED := TR. subst sl1. rewrite app_ass. eauto. red; auto. intros. rewrite <- app_ass. econstructor. apply S; auto. - eapply tr_expr_invariant; eauto. UNCHANGED. - auto. auto. auto. + eapply tr_expr_invariant; eauto. UNCHANGED. + symmetry; eapply typeof_context; eauto. eauto. + auto. auto. auto. auto. auto. auto. (* for val *) exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [U [R S]]]]]]]]]. TR. subst sl1. rewrite app_ass. eauto. red; auto. intros. rewrite <- app_ass. econstructor. apply S; auto. - eapply tr_expr_invariant; eauto. UNCHANGED. - auto. auto. auto. auto. auto. auto. + eapply tr_expr_invariant; eauto. UNCHANGED. + eauto. auto. auto. auto. auto. auto. auto. auto. auto. auto. auto. eapply typeof_context; eauto. (* assignop right *) inv H2. @@ -492,25 +527,24 @@ Ltac UNCHANGED := exploit H1; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [U [R S]]]]]]]]]. TR. subst sl2. rewrite app_ass. eauto. red; auto. - intros. rewrite <- app_ass. change (sl3 ++ sl2') with (nil ++ sl3 ++ sl2'). rewrite app_ass. econstructor. + intros. rewrite <- app_ass. change (sl0 ++ sl2') with (nil ++ sl0 ++ sl2'). rewrite app_ass. econstructor. eapply tr_expr_invariant; eauto. UNCHANGED. - apply S; auto. auto. auto. auto. + apply S; auto. auto. eauto. auto. auto. auto. auto. auto. auto. (* for val *) assert (sl1 = nil) by (eapply tr_simple_expr_nil; eauto). subst sl1; simpl. exploit H1; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [U [R S]]]]]]]]]. TR. subst sl2. rewrite app_ass. eauto. red; auto. - intros. rewrite <- app_ass. change (sl3 ++ sl2') with (nil ++ sl3 ++ sl2'). rewrite app_ass. econstructor. + intros. rewrite <- app_ass. change (sl0 ++ sl2') with (nil ++ sl0 ++ sl2'). rewrite app_ass. econstructor. eapply tr_expr_invariant; eauto. UNCHANGED. - apply S; auto. auto. auto. auto. auto. auto. auto. auto. + apply S; auto. eauto. auto. auto. auto. auto. auto. auto. auto. auto. auto. auto. auto. (* postincr *) inv H1. (* for effects *) exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [U [R S]]]]]]]]]. TR. rewrite Q; rewrite app_ass; eauto. red; auto. - intros. replace (C.typeof (C e)) with (C.typeof (C e')). rewrite <- app_ass. - econstructor; eauto. - eapply typeof_context; eauto. + intros. rewrite <- app_ass. econstructor; eauto. + symmetry; eapply typeof_context; eauto. (* for val *) exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [U [R S]]]]]]]]]. TR. rewrite Q; rewrite app_ass; eauto. red; auto. @@ -706,7 +740,20 @@ Proof. apply star_one. eapply step_ifthenelse; eauto. Qed. -(** Matching between continuations *) +Lemma step_make_set: + forall id a ty m b ofs t v e le f k, + 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). +Proof. + intros. exploit deref_loc_preserved; eauto. rewrite <- H1. intros DEREF. + unfold make_set. destruct (type_is_volatile (typeof a)) as []_eqn. + econstructor; eauto. + assert (t = E0). inv H; congruence. subst t. + constructor. eapply eval_Elvalue; eauto. +Qed. Fixpoint Kseqlist (sl: list statement) (k: cont) := match sl with @@ -721,6 +768,40 @@ Proof. induction sl1; simpl; congruence. Qed. +(* +Axiom only_scalar_types_volatile: + forall ty, type_is_volatile ty = true -> exists chunk, access_mode ty = By_value chunk. +*) + +Lemma step_tr_rvalof: + forall ty m b ofs t v e le a sl a' tmp f k, + deref_loc ge ty m b ofs t v -> + eval_lvalue tge e le m a b ofs -> + 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) + /\ eval_expr tge e le' m a' v + /\ typeof a' = typeof a + /\ forall x, ~In x tmp -> le'!x = le!x. +Proof. + intros. inv H1. + (* non volatile *) + assert (t = E0). inv H; auto. congruence. subst t. + exists le; intuition. apply star_refl. + eapply eval_Elvalue; eauto. eapply deref_loc_preserved; eauto. + (* volatile *) + exists (PTree.set t0 v le); intuition. + simpl. eapply star_two. econstructor. eapply step_vol_read; eauto. + eapply deref_loc_preserved; eauto. traceEq. + constructor. apply PTree.gss. + apply PTree.gso. congruence. +Qed. + +(** Matching between continuations *) + + Inductive match_cont : Csem.cont -> cont -> Prop := | match_Kstop: match_cont Csem.Kstop Kstop @@ -853,7 +934,9 @@ Inductive match_states: Csem.state -> state -> Prop := | match_returnstates: forall res k m tk, match_cont k tk -> match_states (Csem.Returnstate res k m) - (Returnstate res tk m). + (Returnstate res tk m) + | match_stuckstate: forall S, + match_states Csem.Stuckstate S. Lemma push_seq: forall f sl k e le m, @@ -931,6 +1014,12 @@ Proof. red; simpl; intros. rewrite H; auto. Qed. +Lemma tr_rvalof_nolabel: + forall ty a sl a' tmp, tr_rvalof ty a sl a' tmp -> nolabel_list sl. +Proof. + destruct 1; simpl; intuition. red; simpl; auto. +Qed. + Definition nolabel_dest (dst: destination) : Prop := match dst with | For_val => True @@ -970,13 +1059,18 @@ Lemma tr_find_label_expr: /\(forall le rl sl al tmps, tr_exprlist le rl sl al tmps -> nolabel_list sl). Proof. apply tr_expr_exprlist; intros; NoLabelTac. - destruct H1. apply makeif_nolabel; auto. + destruct H1. apply makeif_nolabel; auto. + eapply tr_rvalof_nolabel; eauto. apply makeif_nolabel; NoLabelTac. rewrite (makeseq_nolabel sl2); auto. rewrite (makeseq_nolabel sl3); auto. apply makeif_nolabel; NoLabelTac. rewrite (makeseq_nolabel sl2). auto. apply H3. apply nolabel_dest_cast; auto. rewrite (makeseq_nolabel sl3). auto. apply H5. apply nolabel_dest_cast; auto. + eapply tr_rvalof_nolabel; eauto. + eapply tr_rvalof_nolabel; eauto. + eapply tr_rvalof_nolabel; eauto. + unfold make_set. destruct (type_is_volatile (typeof a1)); auto. apply nolabel_dest_cast; auto. Qed. @@ -1234,7 +1328,19 @@ Proof. exploit tr_simple_rvalue; eauto. destruct dest. intros [A [B C]]. subst sl. apply tr_top_val_val; auto. intros A. subst sl. apply tr_top_base. constructor. - intros [b [A [B C]]]. subst sl. apply tr_top_val_test; auto. + intros [b [A [B C]]]. subst sl. apply tr_top_val_test; auto. +(* rval volatile *) + exploit tr_top_leftcontext; eauto. clear H11. + intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [T [R S]]]]]]]]]. + inv P. inv H2. inv H7; try congruence. + exploit tr_simple_lvalue; eauto. intros [SL [TY EV]]. subst sl0; simpl. + econstructor; split. + left. eapply plus_two. constructor. eapply step_vol_read; eauto. + rewrite <- TY. eapply deref_loc_preserved; eauto. congruence. auto. + econstructor; eauto. change (final dst' (Etempvar t0 (C.typeof l)) ++ sl2) with (nil ++ (final dst' (Etempvar t0 (C.typeof l)) ++ sl2)). + apply S. apply tr_val_gen. auto. intros. constructor. rewrite H5; auto. apply PTree.gss. + intros. apply PTree.gso. red; intros; subst; elim H5; auto. + auto. (* condition true *) exploit tr_top_leftcontext; eauto. clear H9. intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [T [R S]]]]]]]]]. @@ -1297,14 +1403,14 @@ Proof. left. eapply plus_left. constructor. apply star_one. econstructor; eauto. rewrite <- TY1; rewrite <- TY2; eauto. - rewrite <- TY1; eauto. + rewrite <- TY1. eapply assign_loc_preserved; eauto. traceEq. econstructor. auto. change sl2 with (nil ++ sl2). apply S. constructor. auto. auto. auto. (* for value *) exploit tr_simple_rvalue; eauto. intros [SL2 [TY2 EV2]]. exploit tr_simple_lvalue. eauto. - eapply tr_expr_invariant with (le' := PTree.set t v le). eauto. + eapply tr_expr_invariant with (le' := PTree.set t0 v le). eauto. intros. apply PTree.gso. intuition congruence. intros [SL1 [TY1 EV1]]. subst; simpl Kseqlist. @@ -1314,7 +1420,7 @@ Proof. eapply star_left. constructor. apply star_one. econstructor; eauto. constructor. apply PTree.gss. simpl. rewrite <- TY1; eauto. - rewrite <- TY1; eauto. + rewrite <- TY1. eapply assign_loc_preserved; eauto. reflexivity. reflexivity. traceEq. econstructor. auto. apply S. apply tr_val_gen. auto. intros. econstructor; eauto. constructor. @@ -1322,62 +1428,100 @@ Proof. intros. apply PTree.gso. intuition congruence. auto. auto. (* assignop *) - exploit tr_top_leftcontext; eauto. clear H14. + exploit tr_top_leftcontext; eauto. clear H15. intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [T [R S]]]]]]]]]. inv P. inv H6. (* for effects *) - exploit tr_simple_rvalue; eauto. intros [SL2 [TY2 EV2]]. exploit tr_simple_lvalue; eauto. intros [SL1 [TY1 EV1]]. - subst; simpl Kseqlist. + exploit step_tr_rvalof; eauto. intros [le' [EXEC [EV3 [TY3 INV]]]]. + exploit tr_simple_lvalue. eauto. eapply tr_expr_invariant with (le := le) (le' := le'). eauto. + intros. apply INV. NOTIN. intros [? [? EV1']]. + exploit tr_simple_rvalue. eauto. eapply tr_expr_invariant with (le := le) (le' := le'). eauto. + intros. apply INV. NOTIN. simpl. intros [SL2 [TY2 EV2]]. + subst; simpl Kseqlist. econstructor; split. - left. eapply plus_left. constructor. - apply star_one. econstructor; eauto. - econstructor; eauto. eapply eval_Elvalue; eauto. rewrite <- TY1; eauto. - rewrite <- TY1; rewrite <- TY2; eauto. + left. eapply star_plus_trans. rewrite app_ass. rewrite Kseqlist_app. eexact EXEC. + eapply plus_two. simpl. econstructor. econstructor. eexact EV1'. + econstructor. eexact EV3. eexact EV2. + rewrite TY3; rewrite <- TY1; rewrite <- TY2; eauto. rewrite <- TY1; eauto. - rewrite <- TY1; eauto. - traceEq. + rewrite <- TY1. eapply assign_loc_preserved; eauto. + reflexivity. traceEq. econstructor. auto. change sl2 with (nil ++ sl2). apply S. constructor. auto. auto. auto. (* for value *) - exploit tr_simple_rvalue; eauto. intros [SL2 [TY2 EV2]]. exploit tr_simple_lvalue; eauto. intros [SL1 [TY1 EV1]]. - exploit tr_simple_lvalue. eauto. - eapply tr_expr_invariant with (le' := PTree.set t v3 le). eauto. - intros. apply PTree.gso. intuition congruence. - intros [SL3 [TY3 EV3]]. + exploit step_tr_rvalof; eauto. intros [le' [EXEC [EV3 [TY3 INV]]]]. + exploit tr_simple_lvalue. eauto. eapply tr_expr_invariant with (le := le) (le' := le'). eauto. + intros. apply INV. NOTIN. intros [? [? EV1']]. + exploit tr_simple_rvalue. eauto. eapply tr_expr_invariant with (le := le) (le' := le'). eauto. + intros. apply INV. NOTIN. simpl. intros [SL2 [TY2 EV2]]. + exploit tr_simple_lvalue. eauto. + eapply tr_expr_invariant with (le := le) (le' := PTree.set t v3 le'). eauto. + intros. rewrite PTree.gso. apply INV. NOTIN. intuition congruence. + intros [? [? EV1'']]. subst; simpl Kseqlist. econstructor; split. - left. eapply plus_left. constructor. - eapply star_left. constructor. - econstructor. eapply eval_Elvalue; eauto. rewrite <- TY1; eauto. eauto. - rewrite <- TY1; rewrite <- TY2. eauto. - eapply star_left. constructor. - apply star_one. econstructor. eauto. constructor. apply PTree.gss. - rewrite <- TY1. eauto. rewrite <- TY1. eauto. - reflexivity. reflexivity. traceEq. + left. rewrite app_ass. rewrite Kseqlist_app. + eapply star_plus_trans. eexact EXEC. + simpl. eapply plus_four. econstructor. econstructor. + econstructor. eexact EV3. eexact EV2. + rewrite TY3; rewrite <- TY1; rewrite <- TY2. eauto. + econstructor. econstructor. + eexact EV1''. constructor. apply PTree.gss. + simpl. rewrite <- TY1; eauto. + rewrite <- TY1. eapply assign_loc_preserved; eauto. + reflexivity. traceEq. econstructor. auto. apply S. apply tr_val_gen. auto. intros. econstructor; eauto. constructor. - rewrite H6; auto. apply PTree.gss. - intros. apply PTree.gso. intuition congruence. + rewrite H10; auto. apply PTree.gss. + intros. rewrite PTree.gso. apply INV. + red; intros; elim H10; auto. + intuition congruence. auto. auto. +(* assignop stuck *) + exploit tr_top_leftcontext; eauto. clear H12. + intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [T [R S]]]]]]]]]. + inv P. inv H4. + (* for effects *) + exploit tr_simple_lvalue; eauto. intros [SL1 [TY1 EV1]]. + exploit tr_simple_rvalue; eauto. intros [SL2 [TY2 EV2]]. + exploit step_tr_rvalof; eauto. intros [le' [EXEC [EV3 [TY3 INV]]]]. + subst; simpl Kseqlist. + econstructor; split. + right; split. rewrite app_ass. rewrite Kseqlist_app. eexact EXEC. + simpl. omega. + constructor. + (* for value *) + exploit tr_simple_lvalue; eauto. intros [SL1 [TY1 EV1]]. + exploit tr_simple_rvalue; eauto. intros [SL2 [TY2 EV2]]. + exploit step_tr_rvalof; eauto. intros [le' [EXEC [EV3 [TY3 INV]]]]. + subst; simpl Kseqlist. + econstructor; split. + right; split. rewrite app_ass. rewrite Kseqlist_app. eexact EXEC. + simpl. omega. + constructor. (* postincr *) - exploit tr_top_leftcontext; eauto. clear H13. + exploit tr_top_leftcontext; eauto. clear H14. intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [T [R S]]]]]]]]]. inv P. inv H5. (* for effects *) exploit tr_simple_lvalue; eauto. intros [SL1 [TY1 EV1]]. - assert (EV2: eval_expr tge e le m a1 v1). eapply eval_Elvalue; eauto. rewrite <- TY1; auto. + exploit step_tr_rvalof; eauto. intros [le' [EXEC [EV3 [TY3 INV]]]]. + exploit tr_simple_lvalue. eauto. eapply tr_expr_invariant with (le := le) (le' := le'). eauto. + intros. apply INV. NOTIN. intros [? [? EV1']]. subst; simpl Kseqlist. econstructor; split. - left. eapply plus_two. constructor. + left. rewrite app_ass; rewrite Kseqlist_app. + eapply star_plus_trans. eexact EXEC. + eapply plus_two. simpl. constructor. econstructor; eauto. unfold transl_incrdecr. destruct id; simpl in H2. - econstructor. eauto. constructor. simpl. rewrite <- TY1. eauto. - econstructor. eauto. constructor. simpl. rewrite <- TY1. eauto. + econstructor. eauto. constructor. simpl. rewrite TY3; rewrite <- TY1. eauto. + econstructor. eauto. constructor. simpl. rewrite TY3; rewrite <- TY1. eauto. rewrite <- TY1. instantiate (1 := v3). destruct id; auto. - rewrite <- TY1. eauto. - traceEq. + rewrite <- TY1. eapply assign_loc_preserved; eauto. + reflexivity. traceEq. econstructor. auto. change sl2 with (nil ++ sl2). apply S. constructor. auto. auto. auto. (* for value *) @@ -1388,21 +1532,40 @@ Proof. intros [SL2 [TY2 EV2]]. subst; simpl Kseqlist. econstructor; split. - left. eapply plus_four. constructor. - constructor. eapply eval_Elvalue; eauto. rewrite <- TY1; eauto. + left. eapply plus_four. constructor. + eapply step_make_set; eauto. constructor. econstructor. eauto. unfold transl_incrdecr. destruct id; simpl in H2. econstructor. constructor. apply PTree.gss. constructor. simpl. eauto. econstructor. constructor. apply PTree.gss. constructor. simpl. eauto. rewrite <- TY1. instantiate (1 := v3). destruct id; auto. - rewrite <- TY1. eauto. + rewrite <- TY1. eapply assign_loc_preserved; eauto. traceEq. econstructor. auto. apply S. apply tr_val_gen. auto. intros. econstructor; eauto. rewrite H5; auto. apply PTree.gss. intros. apply PTree.gso. intuition congruence. auto. auto. +(* postincr stuck *) + exploit tr_top_leftcontext; eauto. clear H11. + intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [T [R S]]]]]]]]]. + inv P. inv H3. + (* for effects *) + exploit tr_simple_lvalue; eauto. intros [SL1 [TY1 EV1]]. + exploit step_tr_rvalof; eauto. intros [le' [EXEC [EV3 [TY3 INV]]]]. + subst. simpl Kseqlist. + econstructor; split. + right; split. rewrite app_ass; rewrite Kseqlist_app. eexact EXEC. + simpl; omega. + constructor. + (* for value *) + exploit tr_simple_lvalue; eauto. intros [SL1 [TY1 EV1]]. + subst. simpl Kseqlist. + econstructor; split. + left. eapply plus_two. constructor. eapply step_make_set; eauto. + traceEq. + constructor. (* comma *) exploit tr_top_leftcontext; eauto. clear H9. intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [T [R S]]]]]]]]]. @@ -1510,6 +1673,14 @@ Proof. inv H0. exists a0; auto. Qed. +Lemma bind_parameters_preserved: + forall e m params args m', + bind_parameters ge e m params args m' -> + bind_parameters tge e m params args m'. +Proof. + induction 1; econstructor; eauto. eapply assign_loc_preserved; eauto. +Qed. + Lemma sstep_simulation: forall S1 t S2, Csem.sstep ge S1 t S2 -> forall S1' (MS: match_states S1 S1'), @@ -1766,7 +1937,7 @@ Proof. left; apply plus_one. eapply step_internal_function. rewrite C; rewrite D; auto. rewrite C; rewrite D; eauto. - rewrite C; eauto. + rewrite C. eapply bind_parameters_preserved; eauto. constructor; auto. (* external function *) diff --git a/cfrontend/SimplExprspec.v b/cfrontend/SimplExprspec.v index 1224ea9..b3efd7f 100644 --- a/cfrontend/SimplExprspec.v +++ b/cfrontend/SimplExprspec.v @@ -48,6 +48,14 @@ Definition final (dst: destination) (a: expr) : list statement := | For_test tyl s1 s2 => makeif (fold_left Ecast tyl a) s1 s2 :: nil end. +Inductive tr_rvalof: type -> expr -> list statement -> expr -> list ident -> Prop := + | tr_rvalof_nonvol: forall ty a tmp, + type_is_volatile ty = false -> + tr_rvalof ty a nil a tmp + | tr_rvalof_vol: forall ty a t tmp, + type_is_volatile ty = true -> In t tmp -> + tr_rvalof ty a (Svolread t a :: nil) (Etempvar t ty) tmp. + Inductive tr_expr: temp_env -> destination -> C.expr -> list statement -> expr -> list ident -> Prop := | tr_var: forall le dst id ty tmp, tr_expr le dst (C.Evar id ty) @@ -80,11 +88,13 @@ Inductive tr_expr: temp_env -> destination -> C.expr -> list statement -> expr - tr_expr le dst (C.Esizeof ty' ty) (final dst (Esizeof ty' ty)) (Esizeof ty' ty) tmp - | tr_valof: forall le dst e1 ty tmp sl1 a1, - tr_expr le For_val e1 sl1 a1 tmp -> + | tr_valof: forall le dst e1 ty tmp sl1 a1 tmp1 sl2 a2 tmp2, + tr_expr le For_val e1 sl1 a1 tmp1 -> + tr_rvalof (C.typeof e1) a1 sl2 a2 tmp2 -> + list_disjoint tmp1 tmp2 -> incl tmp1 tmp -> incl tmp2 tmp -> tr_expr le dst (C.Evalof e1 ty) - (sl1 ++ final dst a1) - a1 tmp + (sl1 ++ sl2 ++ final dst a2) + a2 tmp | tr_addrof: forall le dst e1 ty tmp sl1 a1, tr_expr le For_val e1 sl1 a1 tmp -> tr_expr le dst (C.Eaddrof e1 ty) @@ -153,38 +163,45 @@ Inductive tr_expr: temp_env -> destination -> C.expr -> list statement -> expr - Sassign a1 (Etempvar t ty2) :: final dst (Ecast (Etempvar t ty2) ty1)) (Ecast (Etempvar t ty2) ty1) tmp - | tr_assignop_effects: forall le op e1 e2 tyres ty sl1 a1 tmp1 sl2 a2 tmp2 any tmp, + | tr_assignop_effects: forall le op e1 e2 tyres ty ty1 sl1 a1 tmp1 sl2 a2 tmp2 sl3 a3 tmp3 any tmp, tr_expr le For_val e1 sl1 a1 tmp1 -> tr_expr le For_val e2 sl2 a2 tmp2 -> - list_disjoint tmp1 tmp2 -> - incl tmp1 tmp -> incl tmp2 tmp -> + ty1 = C.typeof e1 -> + tr_rvalof ty1 a1 sl3 a3 tmp3 -> + list_disjoint tmp1 tmp2 -> list_disjoint tmp1 tmp3 -> list_disjoint tmp2 tmp3 -> + incl tmp1 tmp -> incl tmp2 tmp -> incl tmp3 tmp -> tr_expr le For_effects (C.Eassignop op e1 e2 tyres ty) - (sl1 ++ sl2 ++ Sassign a1 (Ebinop op a1 a2 tyres) :: nil) + (sl1 ++ sl2 ++ sl3 ++ Sassign a1 (Ebinop op a3 a2 tyres) :: nil) any tmp - | tr_assignop_val: forall le dst op e1 e2 tyres ty sl1 a1 tmp1 sl2 a2 tmp2 t tmp ty1, + | tr_assignop_val: forall le dst op e1 e2 tyres ty sl1 a1 tmp1 sl2 a2 tmp2 sl3 a3 tmp3 t tmp ty1, tr_expr le For_val e1 sl1 a1 tmp1 -> tr_expr le For_val e2 sl2 a2 tmp2 -> - list_disjoint tmp1 tmp2 -> - incl tmp1 tmp -> incl tmp2 tmp -> - In t tmp -> ~In t tmp1 -> ~In t tmp2 -> + tr_rvalof ty1 a1 sl3 a3 tmp3 -> + list_disjoint tmp1 tmp2 -> list_disjoint tmp1 tmp3 -> list_disjoint tmp2 tmp3 -> + incl tmp1 tmp -> incl tmp2 tmp -> incl tmp3 tmp -> + In t tmp -> ~In t tmp1 -> ~In t tmp2 -> ~In t tmp3 -> ty1 = C.typeof e1 -> tr_expr le dst (C.Eassignop op e1 e2 tyres ty) - (sl1 ++ sl2 ++ - Sset t (Ebinop op a1 a2 tyres) :: + (sl1 ++ sl2 ++ sl3 ++ + Sset t (Ebinop op a3 a2 tyres) :: Sassign a1 (Etempvar t tyres) :: final dst (Ecast (Etempvar t tyres) ty1)) (Ecast (Etempvar t tyres) ty1) tmp - | tr_postincr_effects: forall le id e1 ty sl1 a1 tmp any, - tr_expr le For_val e1 sl1 a1 tmp -> + | tr_postincr_effects: forall le id e1 ty ty1 sl1 a1 tmp1 sl2 a2 tmp2 any tmp, + tr_expr le For_val e1 sl1 a1 tmp1 -> + tr_rvalof ty1 a1 sl2 a2 tmp2 -> + ty1 = C.typeof e1 -> + incl tmp1 tmp -> incl tmp2 tmp -> + list_disjoint tmp1 tmp2 -> tr_expr le For_effects (C.Epostincr id e1 ty) - (sl1 ++ Sassign a1 (transl_incrdecr id a1 (C.typeof e1)) :: nil) + (sl1 ++ sl2 ++ Sassign a1 (transl_incrdecr id a2 ty1) :: nil) any tmp | tr_postincr_val: forall le dst id e1 ty sl1 a1 tmp1 t ty1 tmp, tr_expr le For_val e1 sl1 a1 tmp1 -> incl tmp1 tmp -> In t tmp -> ~In t tmp1 -> ty1 = C.typeof e1 -> tr_expr le dst (C.Epostincr id e1 ty) - (sl1 ++ Sset t a1 :: + (sl1 ++ make_set t a1 :: Sassign a1 (transl_incrdecr id (Etempvar t ty1) ty1) :: final dst (Etempvar t ty1)) (Etempvar t ty1) tmp @@ -253,6 +270,13 @@ Proof. induction 1; intros; econstructor; eauto. Qed. +Lemma tr_rvalof_monotone: + forall ty a sl b tmps, tr_rvalof ty a sl b tmps -> + forall tmps', incl tmps tmps' -> tr_rvalof ty a sl b tmps'. +Proof. + induction 1; intros; econstructor; unfold incl in *; eauto. +Qed. + Lemma tr_expr_monotone: forall le dst r sl a tmps, tr_expr le dst r sl a tmps -> forall tmps', incl tmps tmps' -> tr_expr le dst r sl a tmps' @@ -260,6 +284,7 @@ with tr_exprlist_monotone: forall le rl sl al tmps, tr_exprlist le rl sl al tmps -> forall tmps', incl tmps tmps' -> tr_exprlist le rl sl al tmps'. Proof. + specialize tr_rvalof_monotone. intros RVALOF. induction 1; intros; econstructor; unfold incl in *; eauto. induction 1; intros; econstructor; unfold incl in *; eauto. Qed. @@ -572,6 +597,25 @@ Ltac UseFinish := repeat rewrite app_ass end. +Lemma transl_valof_meets_spec: + forall ty a g sl b g' I, + transl_valof ty a g = Res (sl, b) g' I -> + exists tmps, tr_rvalof ty a sl b tmps /\ contained tmps g g'. +Proof. + unfold transl_valof; intros. + destruct (type_is_volatile ty) as []_eqn; monadInv H. + exists (x :: nil); split; eauto with gensym. econstructor; eauto with coqlib. + exists (@nil ident); split; eauto with gensym. constructor; auto. +(* + destruct (access_mode ty) as []_eqn. + destruct (Csem.type_is_volatile ty) as []_eqn; monadInv H. + exists (x :: nil); split; eauto with gensym. econstructor; eauto with coqlib. + exists (@nil ident); split; eauto with gensym. constructor; auto. + monadInv H. exists (@nil ident); split; eauto with gensym. constructor; auto. + monadInv H. exists (@nil ident); split; eauto with gensym. constructor; auto. +*) +Qed. + Scheme expr_ind2 := Induction for C.expr Sort Prop with exprlist_ind2 := Induction for C.exprlist Sort Prop. Combined Scheme expr_exprlist_ind from expr_ind2, exprlist_ind2. @@ -603,9 +647,11 @@ Opaque makeif. monadInv H0. exploit H; eauto. intros [tmp [A B]]. UseFinish. econstructor; split; eauto. constructor; auto. (* valof *) - monadInv H0. exploit H; eauto. intros [tmp [A B]]. UseFinish. - econstructor; split. - econstructor; eauto. eauto with gensym. + monadInv H0. exploit H; eauto. intros [tmp1 [A B]]. + exploit transl_valof_meets_spec; eauto. intros [tmp2 [C D]]. UseFinish. + exists (tmp1 ++ tmp2); split. + econstructor; eauto with gensym. + eauto with gensym. (* deref *) monadInv H0. exploit H; eauto. intros [tmp [A B]]. UseFinish. econstructor; split; eauto. constructor; auto. @@ -668,18 +714,19 @@ Opaque makeif. (* assignop *) monadInv H1. exploit H; eauto. intros [tmp1 [A B]]. exploit H0; eauto. intros [tmp2 [C D]]. - destruct dst; monadInv EQ2. + exploit transl_valof_meets_spec; eauto. intros [tmp3 [E F]]. + destruct dst; monadInv EQ3. (* for value *) - exists (x1 :: tmp1 ++ tmp2); split. + exists (x2 :: tmp1 ++ tmp2 ++ tmp3); split. intros. eapply tr_assignop_val with (dst := For_val); eauto with gensym. apply contained_cons. eauto with gensym. apply contained_app; eauto with gensym. (* for effects *) - exists (tmp1 ++ tmp2); split. + exists (tmp1 ++ tmp2 ++ tmp3); split. econstructor; eauto with gensym. apply contained_app; eauto with gensym. (* for test *) - exists (x1 :: tmp1 ++ tmp2); split. + exists (x2 :: tmp1 ++ tmp2 ++ tmp3); split. repeat rewrite app_ass. simpl. intros. eapply tr_assignop_val with (dst := For_test tyl s1 s2); eauto with gensym. apply contained_cons. eauto with gensym. @@ -692,8 +739,10 @@ Opaque makeif. econstructor; eauto with gensym. apply contained_cons; eauto with gensym. (* for effects *) - exists tmp1; split. - econstructor; eauto with gensym. auto. + exploit transl_valof_meets_spec; eauto. intros [tmp2 [C D]]. + exists (tmp1 ++ tmp2); split. + econstructor; eauto with gensym. + eauto with gensym. (* for test *) repeat rewrite app_ass; simpl. exists (x0 :: tmp1); split. diff --git a/common/Behaviors.v b/common/Behaviors.v index ccb5749..454ea34 100644 --- a/common/Behaviors.v +++ b/common/Behaviors.v @@ -530,6 +530,156 @@ Qed. End BACKWARD_SIMULATIONS. +(** * Program behaviors for the "atomic" construction *) + +Section ATOMIC. + +Variable L: semantics. +Hypothesis Lwb: well_behaved_traces L. + +Remark atomic_finish: forall s t, output_trace t -> Star (atomic L) (t, s) t (E0, s). +Proof. + induction t; intros. + apply star_refl. + simpl in H; destruct H. eapply star_left; eauto. + simpl. apply atomic_step_continue; auto. simpl; auto. auto. +Qed. + +Lemma step_atomic_plus: + forall s1 t s2, Step L s1 t s2 -> Plus (atomic L) (E0,s1) t (E0,s2). +Proof. + intros. destruct t. + apply plus_one. simpl; apply atomic_step_silent; auto. + exploit Lwb; eauto. simpl; intros. + eapply plus_left. eapply atomic_step_start; eauto. eapply atomic_finish; eauto. auto. +Qed. + +Lemma star_atomic_star: + forall s1 t s2, Star L s1 t s2 -> Star (atomic L) (E0,s1) t (E0,s2). +Proof. + induction 1. apply star_refl. eapply star_trans with (s2 := (E0,s2)). + apply plus_star. eapply step_atomic_plus; eauto. eauto. auto. +Qed. + +Lemma atomic_forward_simulation: forward_simulation L (atomic L). +Proof. + set (ms := fun (s: state L) (ts: state (atomic L)) => ts = (E0,s)). + apply forward_simulation_plus with ms; intros. + auto. + exists (E0,s1); split. simpl; auto. red; auto. + red in H. subst s2. simpl; auto. + red in H0. subst s2. exists (E0,s1'); split. + apply step_atomic_plus; auto. red; auto. +Qed. + +Lemma atomic_star_star_gen: + forall ts1 t ts2, Star (atomic L) ts1 t ts2 -> + exists t', Star L (snd ts1) t' (snd ts2) /\ fst ts1 ** t' = t ** fst ts2. +Proof. + induction 1. + exists E0; split. apply star_refl. traceEq. + destruct IHstar as [t' [A B]]. + simpl in H; inv H; simpl in *. + exists t'; split. eapply star_left; eauto. auto. + exists (ev :: t0 ** t'); split. eapply star_left; eauto. rewrite B; auto. + exists t'; split. auto. rewrite B; auto. +Qed. + +Lemma atomic_star_star: + forall s1 t s2, Star (atomic L) (E0,s1) t (E0,s2) -> Star L s1 t s2. +Proof. + intros. exploit atomic_star_star_gen; eauto. intros [t' [A B]]. + simpl in *. replace t with t'. auto. subst; traceEq. +Qed. + +Lemma atomic_forever_silent_forever_silent: + forall s, Forever_silent (atomic L) s -> Forever_silent L (snd s). +Proof. + cofix COINDHYP; intros. inv H. inv H0. + apply forever_silent_intro with (snd (E0, s')). auto. apply COINDHYP; auto. +Qed. + +Remark star_atomic_output_trace: + forall s t t' s', + Star (atomic L) (E0, s) t (t', s') -> output_trace t'. +Proof. + assert (forall ts1 t ts2, Star (atomic L) ts1 t ts2 -> + output_trace (fst ts1) -> output_trace (fst ts2)). + induction 1; intros. auto. inv H; simpl in *. + apply IHstar. auto. + apply IHstar. exploit Lwb; eauto. + destruct H2. apply IHstar. auto. + intros. change t' with (fst (t',s')). eapply H; eauto. simpl; auto. +Qed. + +Lemma atomic_forever_reactive_forever_reactive: + forall s T, Forever_reactive (atomic L) (E0,s) T -> Forever_reactive L s T. +Proof. + assert (forall t s T, Forever_reactive (atomic L) (t,s) T -> + exists T', Forever_reactive (atomic L) (E0,s) T' /\ T = t *** T'). + induction t; intros. exists T; auto. + inv H. inv H0. congruence. simpl in H; inv H. + destruct (IHt s (t2***T0)) as [T' [A B]]. eapply star_forever_reactive; eauto. + exists T'; split; auto. simpl. congruence. + + cofix COINDHYP; intros. inv H0. destruct s2 as [t2 s2]. + destruct (H _ _ _ H3) as [T' [A B]]. + assert (Star (atomic L) (E0, s) (t**t2) (E0, s2)). + eapply star_trans. eauto. apply atomic_finish. eapply star_atomic_output_trace; eauto. auto. + replace (t *** T0) with ((t ** t2) *** T'). apply forever_reactive_intro with s2. + apply atomic_star_star; auto. destruct t; simpl in *; unfold E0 in *; congruence. + apply COINDHYP. auto. + subst T0; traceEq. +Qed. + +Theorem atomic_behaviors: + forall beh, program_behaves L beh <-> program_behaves (atomic L) beh. +Proof. + intros; split; intros. + (* L -> atomic L *) + exploit forward_simulation_behavior_improves. eapply atomic_forward_simulation. eauto. + intros [beh2 [A B]]. red in B. destruct B as [EQ | [t [C D]]]. + congruence. + subst beh. inv H. inv H1. + apply program_runs with (E0,s). simpl; auto. + apply state_goes_wrong with (E0,s'). apply star_atomic_star; auto. + red; intros; red; intros. inv H. eelim H3; eauto. eelim H3; eauto. + intros; red; intros. simpl in H. destruct H. eelim H4; eauto. + apply program_goes_initially_wrong. + intros; red; intros. simpl in H; destruct H. eelim H1; eauto. + (* atomic L -> L *) + inv H. + (* initial state defined *) + destruct s as [t s]. simpl in H0. destruct H0; subst t. + apply program_runs with s; auto. + inv H1. + (* termination *) + destruct s' as [t' s']. simpl in H2; destruct H2; subst t'. + econstructor. eapply atomic_star_star; eauto. auto. + (* silent divergence *) + destruct s' as [t' s']. + assert (t' = E0). inv H2. inv H1; auto. subst t'. + econstructor. eapply atomic_star_star; eauto. + change s' with (snd (E0,s')). apply atomic_forever_silent_forever_silent. auto. + (* reactive divergence *) + econstructor. apply atomic_forever_reactive_forever_reactive. auto. + (* going wrong *) + destruct s' as [t' s']. + assert (t' = E0). + destruct t'; auto. eelim H2. simpl. apply atomic_step_continue. + eapply star_atomic_output_trace; eauto. + subst t'. econstructor. apply atomic_star_star; eauto. + red; intros; red; intros. destruct t0. + elim (H2 E0 (E0,s'0)). constructor; auto. + elim (H2 (e::nil) (t0,s'0)). constructor; auto. + intros; red; intros. elim (H3 r). simpl; auto. + (* initial state undefined *) + apply program_goes_initially_wrong. + intros; red; intros. elim (H0 (E0,s)); simpl; auto. +Qed. + +End ATOMIC. + (** * Additional results about infinite reduction sequences *) (** We now show that any infinite sequence of reductions is either of diff --git a/common/Events.v b/common/Events.v index 018314e..3d082a7 100644 --- a/common/Events.v +++ b/common/Events.v @@ -490,6 +490,59 @@ Qed. End MATCH_TRACES_INV. +(** An output trace is a trace composed only of output events, + that is, events that do not take any result from the outside world. *) + +Definition output_event (ev: event) : Prop := + match ev with + | Event_syscall _ _ _ => False + | Event_vload _ _ _ _ => False + | Event_vstore _ _ _ _ => True + | Event_annot _ _ => True + end. + +Fixpoint output_trace (t: trace) : Prop := + match t with + | nil => True + | ev :: t' => output_event ev /\ output_trace t' + end. + +(** * Semantics of volatile memory accesses *) + +Definition block_is_volatile (F V: Type) (ge: Genv.t F V) (b: block) : bool := + match Genv.find_var_info ge b with + | None => false + | Some gv => gv.(gvar_volatile) + end. + +Inductive volatile_load (F V: Type) (ge: Genv.t F V): + memory_chunk -> mem -> block -> int -> trace -> val -> Prop := + | volatile_load_vol: forall chunk m b ofs id ev v, + block_is_volatile ge b = true -> + Genv.find_symbol ge id = Some b -> + eventval_match ge ev (type_of_chunk chunk) v -> + volatile_load ge chunk m b ofs + (Event_vload chunk id ofs ev :: nil) + (Val.load_result chunk v) + | volatile_load_nonvol: forall chunk m b ofs v, + block_is_volatile ge b = false -> + Mem.load chunk m b (Int.unsigned ofs) = Some v -> + volatile_load ge chunk m b ofs E0 v. + +Inductive volatile_store (F V: Type) (ge: Genv.t F V): + memory_chunk -> mem -> block -> int -> val -> trace -> mem -> Prop := + | volatile_store_vol: forall chunk m b ofs id ev v, + block_is_volatile ge b = true -> + Genv.find_symbol ge id = Some b -> + eventval_match ge ev (type_of_chunk chunk) v -> + volatile_store ge chunk m b ofs v + (Event_vstore chunk id ofs ev :: nil) + m + | volatile_store_nonvol: forall chunk m b ofs v m', + block_is_volatile ge b = false -> + Mem.store chunk m b (Int.unsigned ofs) v = Some m' -> + volatile_store ge chunk m b ofs v E0 m'. + (** * Semantics of external functions *) (** For each external function, its behavior is defined by a predicate relating: @@ -530,12 +583,6 @@ Definition inject_separated (f f': meminj) (m1 m2: mem): Prop := f b1 = None -> f' b1 = Some(b2, delta) -> ~Mem.valid_block m1 b1 /\ ~Mem.valid_block m2 b2. -Definition block_is_volatile (F V: Type) (ge: Genv.t F V) (b: block) : bool := - match Genv.find_var_info ge b with - | None => false - | Some gv => gv.(gvar_volatile) - end. - Record extcall_properties (sem: extcall_sem) (sg: signature) : Prop := mk_extcall_properties { @@ -624,20 +671,34 @@ Record extcall_properties (sem: extcall_sem) Inductive volatile_load_sem (chunk: memory_chunk) (F V: Type) (ge: Genv.t F V): list val -> mem -> trace -> val -> mem -> Prop := - | volatile_load_sem_vol: forall b ofs m id ev v, - Genv.find_symbol ge id = Some b -> block_is_volatile ge b = true -> - eventval_match ge ev (type_of_chunk chunk) v -> - volatile_load_sem chunk ge - (Vptr b ofs :: nil) m - (Event_vload chunk id ofs ev :: nil) - (Val.load_result chunk v) m - | volatile_load_sem_nonvol: forall b ofs m v, - block_is_volatile ge b = false -> - Mem.load chunk m b (Int.unsigned ofs) = Some v -> - volatile_load_sem chunk ge - (Vptr b ofs :: nil) m - E0 - v m. + | volatile_load_sem_intro: forall b ofs m t v, + volatile_load ge chunk m b ofs t v -> + volatile_load_sem chunk ge (Vptr b ofs :: nil) m t v m. + +Lemma volatile_load_preserved: + forall F1 V1 (ge1: Genv.t F1 V1) F2 V2 (ge2: Genv.t F2 V2) chunk m b ofs t v, + (forall id, Genv.find_symbol ge2 id = Genv.find_symbol ge1 id) -> + (forall b, block_is_volatile ge2 b = block_is_volatile ge1 b) -> + volatile_load ge1 chunk m b ofs t v -> + volatile_load ge2 chunk m b ofs t v. +Proof. + intros. inv H1; constructor; auto. + rewrite H0; auto. + rewrite H; auto. + eapply eventval_match_preserved; eauto. + rewrite H0; auto. +Qed. + +Lemma volatile_load_extends: + forall F V (ge: Genv.t F V) chunk m b ofs t v m', + volatile_load ge chunk m b ofs t v -> + Mem.extends m m' -> + exists v', volatile_load ge chunk m' b ofs t v' /\ Val.lessdef v v'. +Proof. + intros. inv H. + econstructor; split; eauto. econstructor; eauto. + exploit Mem.load_extends; eauto. intros [v' [A B]]. exists v'; split; auto. constructor; auto. +Qed. Remark meminj_preserves_block_is_volatile: forall F V (ge: Genv.t F V) f b1 b2 delta, @@ -653,6 +714,35 @@ Proof. auto. Qed. +Lemma volatile_load_inject: + forall F V (ge: Genv.t F V) f chunk m b ofs t v b' ofs' m', + meminj_preserves_globals ge f -> + volatile_load ge chunk m b ofs t v -> + val_inject f (Vptr b ofs) (Vptr b' ofs') -> + Mem.inject f m m' -> + exists v', volatile_load ge chunk m' b' ofs' t v' /\ val_inject f v v'. +Proof. + intros. inv H0. + inv H1. exploit (proj1 H); eauto. intros EQ; rewrite H8 in EQ; inv EQ. + rewrite Int.add_zero. exists (Val.load_result chunk v0); split. + constructor; auto. + apply val_load_result_inject. eapply eventval_match_inject_2; eauto. + exploit Mem.loadv_inject; eauto. simpl; eauto. simpl; intros [v' [A B]]. exists v'; split; auto. + constructor; auto. rewrite <- H3. inv H1. eapply meminj_preserves_block_is_volatile; eauto. +Qed. + +Lemma volatile_load_receptive: + forall F V (ge: Genv.t F V) chunk m b ofs t1 t2 v1, + volatile_load ge chunk m b ofs t1 v1 -> match_traces ge t1 t2 -> + exists v2, volatile_load ge chunk m b ofs t2 v2. +Proof. + intros. inv H; inv H0. + exploit eventval_match_valid; eauto. intros [A B]. + exploit eventval_valid_match. eexact H9. rewrite <- H10; eauto. + intros [v' EVM]. exists (Val.load_result chunk v'). constructor; auto. + exists v1; constructor; auto. +Qed. + Lemma volatile_load_ok: forall chunk, extcall_properties (volatile_load_sem chunk) @@ -660,64 +750,36 @@ Lemma volatile_load_ok: Proof. intros; constructor; intros. (* well typed *) - unfold proj_sig_res; simpl. destruct H. + unfold proj_sig_res; simpl. inv H. inv H0. destruct chunk; destruct v; simpl; constructor. eapply Mem.load_type; eauto. (* arity *) - destruct H; simpl; auto. + inv H; inv H0; auto. (* symbols *) - destruct H1. - econstructor; eauto. rewrite H; auto. eapply eventval_match_preserved; eauto. - econstructor; eauto. + inv H1. constructor. eapply volatile_load_preserved; eauto. (* valid blocks *) - destruct H; auto. + inv H; auto. (* bounds *) - destruct H; auto. + inv H; auto. (* mem extends *) - destruct H. - inv H1. inv H8. inv H6. - exists (Val.load_result chunk v); exists m1'; intuition. - constructor; auto. - red; auto. - inv H1. inv H7. inv H5. - exploit Mem.load_extends; eauto. intros [v' [A B]]. - exists v'; exists m1'; intuition. - econstructor; eauto. - red; auto. + inv H. inv H1. inv H6. inv H4. + exploit volatile_load_extends; eauto. intros [v' [A B]]. + exists v'; exists m1'; intuition. constructor; auto. red; auto. (* mem injects *) - destruct H0. - inv H2. inv H9. inv H7. - generalize H; intros [P [Q R]]. - exploit P; eauto. intro EQ; rewrite H6 in EQ; inv EQ. - exists f; exists (Val.load_result chunk v); exists m1'; intuition. - rewrite Int.add_zero. constructor; auto. - apply val_load_result_inject. eapply eventval_match_inject_2; eauto. - red; auto. - red; auto. - red; intros. congruence. - inv H2. inv H8. - exploit Mem.loadv_inject; eauto. simpl. eauto. intros [v1 [A B]]. - inv H6; simpl in *. - exists f; exists v1; exists m1'; intuition. - econstructor; eauto. - rewrite <- H0. eapply meminj_preserves_block_is_volatile; eauto. - red; auto. - red; auto. - red; intros. congruence. + inv H0. inv H2. inv H7. inversion H5; subst. + exploit volatile_load_inject; eauto. intros [v' [A B]]. + exists f; exists v'; exists m1'; intuition. constructor; auto. + red; auto. red; auto. red; intros. congruence. (* trace length *) - inv H; simpl; omega. + inv H; inv H0; simpl; omega. (* receptive *) - inv H; inv H0. - exploit eventval_match_valid; eauto. intros [A B]. - exploit eventval_valid_match. eexact H9. rewrite <- H10; eauto. - intros [v' EVM]. exists (Val.load_result chunk v'); exists m1. - eapply volatile_load_sem_vol; eauto. - exists vres1; exists m1; eapply volatile_load_sem_nonvol; eauto. + inv H. exploit volatile_load_receptive; eauto. intros [v2 A]. + exists v2; exists m1; constructor; auto. (* determ *) - inv H; inv H0; try congruence. + inv H; inv H0. inv H1; inv H7; try congruence. assert (id = id0) by (eapply Genv.genv_vars_inj; eauto). subst id0. - exploit eventval_match_valid. eexact H3. intros [V1 T1]. - exploit eventval_match_valid. eexact H11. intros [V2 T2]. + exploit eventval_match_valid. eexact H2. intros [V1 T1]. + exploit eventval_match_valid. eexact H4. intros [V2 T2]. split. constructor; auto. congruence. intros EQ; inv EQ. assert (v = v0) by (eapply eventval_match_determ_1; eauto). subst v0. @@ -728,31 +790,19 @@ Qed. Inductive volatile_load_global_sem (chunk: memory_chunk) (id: ident) (ofs: int) (F V: Type) (ge: Genv.t F V): list val -> mem -> trace -> val -> mem -> Prop := - | volatile_load_global_sem_vol: forall b m ev v, - Genv.find_symbol ge id = Some b -> block_is_volatile ge b = true -> - eventval_match ge ev (type_of_chunk chunk) v -> - volatile_load_global_sem chunk id ofs ge - nil m - (Event_vload chunk id ofs ev :: nil) - (Val.load_result chunk v) m - | volatile_load_global_sem_nonvol: forall b m v, - Genv.find_symbol ge id = Some b -> block_is_volatile ge b = false -> - Mem.load chunk m b (Int.unsigned ofs) = Some v -> - volatile_load_global_sem chunk id ofs ge - nil m - E0 - v m. + | volatile_load_global_sem_intro: forall b t v m, + Genv.find_symbol ge id = Some b -> + volatile_load ge chunk m b ofs t v -> + volatile_load_global_sem chunk id ofs ge nil m t v m. Remark volatile_load_global_charact: forall chunk id ofs (F V: Type) (ge: Genv.t F V) vargs m t vres m', volatile_load_global_sem chunk id ofs ge vargs m t vres m' <-> exists b, Genv.find_symbol ge id = Some b /\ volatile_load_sem chunk ge (Vptr b ofs :: vargs) m t vres m'. Proof. - intros; split. - intros. inv H; exists b; split; auto; constructor; auto. - intros [b [P Q]]. inv Q. - assert (id0 = id) by (eapply Genv.genv_vars_inj; eauto). subst id0. econstructor; eauto. - econstructor; eauto. + intros; split. + intros. inv H. exists b; split; auto. constructor; auto. + intros [b [P Q]]. inv Q. econstructor; eauto. Qed. Lemma volatile_load_global_ok: @@ -762,117 +812,79 @@ Lemma volatile_load_global_ok: Proof. intros; constructor; intros. (* well typed *) - unfold proj_sig_res; simpl. destruct H. + unfold proj_sig_res; simpl. inv H. inv H1. destruct chunk; destruct v; simpl; constructor. eapply Mem.load_type; eauto. (* arity *) - destruct H; simpl; auto. + inv H; inv H1; auto. (* symbols *) - destruct H1. - econstructor; eauto. rewrite H; auto. eapply eventval_match_preserved; eauto. - econstructor; eauto. rewrite H; auto. + inv H1. econstructor. rewrite H; eauto. eapply volatile_load_preserved; eauto. (* valid blocks *) - destruct H; auto. + inv H; auto. (* bounds *) - destruct H; auto. -(* mem extends *) - destruct H. - inv H1. - exists (Val.load_result chunk v); exists m1'; intuition. - econstructor; eauto. - red; auto. - inv H1. - exploit Mem.load_extends; eauto. intros [v' [A B]]. - exists v'; exists m1'; intuition. - econstructor; eauto. - red; auto. -(* mem injects *) - destruct H0. - inv H2. - exists f; exists (Val.load_result chunk v); exists m1'; intuition. - econstructor; eauto. - apply val_load_result_inject. eapply eventval_match_inject_2; eauto. - red; auto. - red; auto. - red; intros. congruence. - inv H2. destruct H as [P [Q R]]. exploit P; eauto. intros EQ. - exploit Mem.load_inject; eauto. rewrite Zplus_0_r. intros [v1 [A B]]. - exists f; exists v1; exists m1'; intuition. - econstructor; eauto. - red; auto. - red; auto. - red; intros. congruence. + inv H; auto. +(* extends *) + inv H. inv H1. exploit volatile_load_extends; eauto. intros [v' [A B]]. + exists v'; exists m1'; intuition. econstructor; eauto. red; auto. +(* inject *) + inv H0. inv H2. + assert (val_inject f (Vptr b ofs) (Vptr b ofs)). + exploit (proj1 H); eauto. intros EQ. econstructor. eauto. rewrite Int.add_zero; auto. + exploit volatile_load_inject; eauto. intros [v' [A B]]. + exists f; exists v'; exists m1'; intuition. econstructor; eauto. + red; auto. red; auto. red; intros; congruence. (* trace length *) - inv H; simpl; omega. + inv H; inv H1; simpl; omega. (* receptive *) - inv H; inv H0. - exploit eventval_match_valid; eauto. intros [A B]. - exploit eventval_valid_match. eexact H9. rewrite <- H10; eauto. - intros [v' EVM]. exists (Val.load_result chunk v'); exists m1. - eapply volatile_load_global_sem_vol; eauto. - exists vres1; exists m1; eapply volatile_load_global_sem_nonvol; eauto. + inv H. exploit volatile_load_receptive; eauto. intros [v2 A]. + exists v2; exists m1; econstructor; eauto. (* determ *) - inv H; inv H0; try congruence. - assert (b = b0) by congruence. subst b0. - exploit eventval_match_valid. eexact H3. intros [V1 T1]. - exploit eventval_match_valid. eexact H5. intros [V2 T2]. - split. constructor; auto. congruence. - intros EQ; inv EQ. - assert (v = v0) by (eapply eventval_match_determ_1; eauto). subst v0. - auto. - split. constructor. intuition congruence. + rewrite volatile_load_global_charact in *. + destruct H as [b1 [A1 B1]]. destruct H0 as [b2 [A2 B2]]. + rewrite A1 in A2; inv A2. + eapply ec_determ. eapply volatile_load_ok. eauto. eauto. Qed. (** ** Semantics of volatile stores *) Inductive volatile_store_sem (chunk: memory_chunk) (F V: Type) (ge: Genv.t F V): list val -> mem -> trace -> val -> mem -> Prop := - | volatile_store_sem_vol: forall b ofs m id ev v, - Genv.find_symbol ge id = Some b -> block_is_volatile ge b = true -> - eventval_match ge ev (type_of_chunk chunk) v -> - volatile_store_sem chunk ge - (Vptr b ofs :: v :: nil) m - (Event_vstore chunk id ofs ev :: nil) - Vundef m - | volatile_store_sem_nonvol: forall b ofs m v m', - block_is_volatile ge b = false -> - Mem.store chunk m b (Int.unsigned ofs) v = Some m' -> - volatile_store_sem chunk ge - (Vptr b ofs :: v :: nil) m - E0 - Vundef m'. + | volatile_store_sem_intro: forall b ofs m1 v t m2, + volatile_store ge chunk m1 b ofs v t m2 -> + volatile_store_sem chunk ge (Vptr b ofs :: v :: nil) m1 t Vundef m2. -Lemma volatile_store_ok: - forall chunk, - extcall_properties (volatile_store_sem chunk) - (mksignature (Tint :: type_of_chunk chunk :: nil) None). +Lemma volatile_store_preserved: + forall F1 V1 (ge1: Genv.t F1 V1) F2 V2 (ge2: Genv.t F2 V2) chunk m1 b ofs v t m2, + (forall id, Genv.find_symbol ge2 id = Genv.find_symbol ge1 id) -> + (forall b, block_is_volatile ge2 b = block_is_volatile ge1 b) -> + volatile_store ge1 chunk m1 b ofs v t m2 -> + volatile_store ge2 chunk m1 b ofs v t m2. Proof. - intros; constructor; intros. -(* well typed *) - unfold proj_sig_res; simpl. inv H; constructor. -(* arity *) - inv H; simpl; auto. -(* symbols preserved *) - inv H1. - constructor. rewrite H; auto. rewrite H0; auto. eapply eventval_match_preserved; eauto. - constructor; auto. rewrite H0; auto. -(* valid block *) - inv H. auto. eauto with mem. -(* bounds *) - inv H. auto. eapply Mem.bounds_store; eauto. -(* mem extends*) - inv H. - inv H1. inv H6. inv H8. inv H7. - exists Vundef; exists m1'; intuition. - constructor; auto. eapply eventval_match_lessdef; eauto. - red; auto. - inv H1. inv H5. inv H7. inv H6. - exploit Mem.store_within_extends; eauto. intros [m' [A B]]. - exists Vundef; exists m'; intuition. - constructor; auto. + intros. inv H1; constructor; auto. + rewrite H0; auto. + rewrite H; auto. + eapply eventval_match_preserved; eauto. + rewrite H0; auto. +Qed. + +Lemma volatile_store_extends: + forall F V (ge: Genv.t F V) chunk m1 b ofs v t m2 m1' v', + volatile_store ge chunk m1 b ofs v t m2 -> + Mem.extends m1 m1' -> + Val.lessdef v v' -> + exists m2', + volatile_store ge chunk m1' b ofs v' t m2' + /\ Mem.extends m2 m2' + /\ mem_unchanged_on (loc_out_of_bounds m1) m1' m2'. +Proof. + intros. inv H. + econstructor; split. econstructor; eauto. eapply eventval_match_lessdef; eauto. + split. auto. red; auto. + exploit Mem.store_within_extends; eauto. intros [m2' [A B]]. + exists m2'; intuition. econstructor; eauto. red; split; intros. eapply Mem.perm_store_1; eauto. - rewrite <- H1. eapply Mem.load_store_other; eauto. + rewrite <- H4. eapply Mem.load_store_other; eauto. destruct (eq_block b0 b); auto. subst b0; right. exploit Mem.valid_access_in_bounds. eapply Mem.store_valid_access_3. eexact H3. @@ -883,30 +895,37 @@ Proof. (Int.unsigned ofs, Int.unsigned ofs + size_chunk chunk)). red; intros. generalize (H x H5). unfold loc_out_of_bounds, Intv.In; simpl. omega. simpl; omega. simpl; omega. -(* mem injects *) - inv H0. - inv H2. inv H7. inv H9. inv H10. - generalize H; intros [P [Q R]]. - exploit P; eauto. intro EQ; rewrite H6 in EQ; inv EQ. - exists f; exists Vundef; exists m1'; intuition. - rewrite Int.add_zero. constructor; auto. - eapply eventval_match_inject; eauto. - red; auto. - red; auto. - red; intros; congruence. - inv H2. inv H8. inv H9. inv H6. +Qed. + +Lemma volatile_store_inject: + forall F V (ge: Genv.t F V) f chunk m1 b ofs v t m2 m1' b' ofs' v', + meminj_preserves_globals ge f -> + volatile_store ge chunk m1 b ofs v t m2 -> + val_inject f (Vptr b ofs) (Vptr b' ofs') -> + val_inject f v v' -> + Mem.inject f m1 m1' -> + exists m2', + volatile_store ge chunk m1' b' ofs' v' t m2' + /\ Mem.inject f m2 m2' + /\ mem_unchanged_on (loc_unmapped f) m1 m2 + /\ mem_unchanged_on (loc_out_of_reach f m1) m1' m2'. +Proof. + intros. inv H0. + inv H1. exploit (proj1 H); eauto. intros EQ; rewrite H9 in EQ; inv EQ. + rewrite Int.add_zero. exists m1'. + split. constructor; auto. eapply eventval_match_inject; eauto. + split. auto. split. red; auto. red; auto. assert (Mem.storev chunk m1 (Vptr b ofs) v = Some m2). simpl; auto. exploit Mem.storev_mapped_inject; eauto. intros [m2' [A B]]. - inv H4. - exists f; exists Vundef; exists m2'; intuition. - constructor; auto. rewrite <- H3. eapply meminj_preserves_block_is_volatile; eauto. + inv H1. exists m2'; intuition. + constructor; auto. rewrite <- H4. eapply meminj_preserves_block_is_volatile; eauto. split; intros. eapply Mem.perm_store_1; eauto. - rewrite <- H4. eapply Mem.load_store_other; eauto. - left. exploit (H2 ofs0). generalize (size_chunk_pos chunk0). omega. + rewrite <- H6. eapply Mem.load_store_other; eauto. + left. exploit (H1 ofs0). generalize (size_chunk_pos chunk0). omega. unfold loc_unmapped. congruence. split; intros. eapply Mem.perm_store_1; eauto. - rewrite <- H4. eapply Mem.load_store_other; eauto. - destruct (eq_block b0 b2); auto. subst b0; right. + rewrite <- H6. eapply Mem.load_store_other; eauto. + destruct (eq_block b0 b'); auto. subst b0; right. assert (EQ: Int.unsigned (Int.add ofs (Int.repr delta)) = Int.unsigned ofs + delta). eapply Mem.address_inject; eauto with mem. unfold Mem.storev in A. rewrite EQ in A. rewrite EQ. @@ -917,16 +936,48 @@ Proof. generalize (size_chunk_pos chunk). intro G. apply (Intv.range_disjoint' (ofs0, ofs0 + size_chunk chunk0) (Int.unsigned ofs + delta, Int.unsigned ofs + delta + size_chunk chunk)). - red; intros. exploit (H2 x H8). eauto. unfold Intv.In; simpl. omega. + red; intros. exploit (H1 x H7). eauto. unfold Intv.In; simpl. omega. simpl; omega. simpl; omega. - red; intros; congruence. +Qed. + +Lemma volatile_store_receptive: + forall F V (ge: Genv.t F V) chunk m b ofs v t1 m1 t2, + volatile_store ge chunk m b ofs v t1 m1 -> match_traces ge t1 t2 -> t1 = t2. +Proof. + intros. inv H; inv H0; auto. +Qed. + +Lemma volatile_store_ok: + forall chunk, + extcall_properties (volatile_store_sem chunk) + (mksignature (Tint :: type_of_chunk chunk :: nil) None). +Proof. + intros; constructor; intros. +(* well typed *) + unfold proj_sig_res; simpl. inv H; constructor. +(* arity *) + inv H; simpl; auto. +(* symbols preserved *) + inv H1. constructor. eapply volatile_store_preserved; eauto. +(* valid block *) + inv H. inv H1. auto. eauto with mem. +(* bounds *) + inv H. inv H1. auto. eapply Mem.bounds_store; eauto. +(* mem extends*) + inv H. inv H1. inv H6. inv H7. inv H4. + exploit volatile_store_extends; eauto. intros [m2' [A [B C]]]. + exists Vundef; exists m2'; intuition. constructor; auto. +(* mem inject *) + inv H0. inv H2. inv H7. inv H8. inversion H5; subst. + exploit volatile_store_inject; eauto. intros [m2' [A [B [C D]]]]. + exists f; exists Vundef; exists m2'; intuition. constructor; auto. red; intros; congruence. (* trace length *) - inv H; simpl; omega. + inv H; inv H0; simpl; omega. (* receptive *) - assert (t1 = t2). inv H; inv H0; auto. - exists vres1; exists m1; congruence. + assert (t1 = t2). inv H. eapply volatile_store_receptive; eauto. + subst t2; exists vres1; exists m1; auto. (* determ *) - inv H; inv H0; try congruence. + inv H; inv H0. inv H1; inv H8; try congruence. assert (id = id0) by (eapply Genv.genv_vars_inj; eauto). subst id0. assert (ev = ev0) by (eapply eventval_match_determ_2; eauto). subst ev0. split. constructor. auto. @@ -936,20 +987,10 @@ Qed. Inductive volatile_store_global_sem (chunk: memory_chunk) (id: ident) (ofs: int) (F V: Type) (ge: Genv.t F V): list val -> mem -> trace -> val -> mem -> Prop := - | volatile_store_global_sem_vol: forall b m ev v, - Genv.find_symbol ge id = Some b -> block_is_volatile ge b = true -> - eventval_match ge ev (type_of_chunk chunk) v -> - volatile_store_global_sem chunk id ofs ge - (v :: nil) m - (Event_vstore chunk id ofs ev :: nil) - Vundef m - | volatile_store_global_sem_nonvol: forall b m v m', - Genv.find_symbol ge id = Some b -> block_is_volatile ge b = false -> - Mem.store chunk m b (Int.unsigned ofs) v = Some m' -> - volatile_store_global_sem chunk id ofs ge - (v :: nil) m - E0 - Vundef m'. + | volatile_store_global_sem_intro: forall b m1 v t m2, + Genv.find_symbol ge id = Some b -> + volatile_store ge chunk m1 b ofs v t m2 -> + volatile_store_global_sem chunk id ofs ge (v :: nil) m1 t Vundef m2. Remark volatile_store_global_charact: forall chunk id ofs (F V: Type) (ge: Genv.t F V) vargs m t vres m', @@ -958,9 +999,7 @@ Remark volatile_store_global_charact: Proof. intros; split. intros. inv H; exists b; split; auto; econstructor; eauto. - intros [b [P Q]]. inv Q. - assert (id0 = id) by (eapply Genv.genv_vars_inj; eauto). subst id0. econstructor; eauto. - econstructor; eauto. + intros [b [P Q]]. inv Q. econstructor; eauto. Qed. Lemma volatile_store_global_ok: @@ -974,13 +1013,11 @@ Proof. (* arity *) inv H; simpl; auto. (* symbols preserved *) - inv H1. - econstructor. rewrite H; eauto. rewrite H0; auto. eapply eventval_match_preserved; eauto. - econstructor; eauto. rewrite H; auto. + inv H1. econstructor. rewrite H; eauto. eapply volatile_store_preserved; eauto. (* valid block *) - inv H. auto. eauto with mem. + inv H. inv H2. auto. eauto with mem. (* bounds *) - inv H. auto. eapply Mem.bounds_store; eauto. + inv H. inv H2. auto. eapply Mem.bounds_store; eauto. (* mem extends*) rewrite volatile_store_global_charact in H. destruct H as [b [P Q]]. exploit ec_mem_extends. eapply volatile_store_ok. eexact Q. eauto. eauto. @@ -995,16 +1032,14 @@ Proof. exists f'; exists vres'; exists m2'; intuition. rewrite volatile_store_global_charact. exists b; auto. (* trace length *) - inv H; simpl; omega. + inv H. inv H1; simpl; omega. (* receptive *) - assert (t1 = t2). inv H; inv H0; auto. + assert (t1 = t2). inv H. eapply volatile_store_receptive; eauto. subst t2. exists vres1; exists m1; congruence. (* determ *) - inv H; inv H0; try congruence. - assert (b = b0) by congruence. subst b0. - assert (ev = ev0) by (eapply eventval_match_determ_2; eauto). subst ev0. - split. constructor. auto. - split. constructor. intuition congruence. + rewrite volatile_store_global_charact in *. + destruct H as [b1 [A1 B1]]. destruct H0 as [b2 [A2 B2]]. rewrite A1 in A2; inv A2. + eapply ec_determ. eapply volatile_store_ok. eauto. eauto. Qed. (** ** Semantics of dynamic memory allocation (malloc) *) diff --git a/common/Smallstep.v b/common/Smallstep.v index 63ab5ea..458e8c6 100644 --- a/common/Smallstep.v +++ b/common/Smallstep.v @@ -817,12 +817,15 @@ End COMPOSE_SIMULATIONS. (** * Receptiveness and determinacy *) +Definition single_events (L: semantics) : Prop := + forall s t s', Step L s t s' -> (length t <= 1)%nat. + Record receptive (L: semantics) : Prop := Receptive { sr_receptive: forall s t1 s1 t2, Step L s t1 s1 -> match_traces (globalenv L) t1 t2 -> exists s2, Step L s t2 s2; - sr_traces: forall s t s', - Step L s t s' -> (length t <= 1)%nat + sr_traces: + single_events L }. Record determinate (L: semantics) : Prop := @@ -830,8 +833,8 @@ Record determinate (L: semantics) : Prop := sd_determ: forall s t1 s1 t2 s2, Step L s t1 s1 -> Step L s t2 s2 -> match_traces (globalenv L) t1 t2 /\ (t1 = t2 -> s1 = s2); - sd_traces: forall s t s', - Step L s t s' -> (length t <= 1)%nat; + sd_traces: + single_events L; sd_initial_determ: forall s1 s2, initial_state L s1 -> initial_state L s2 -> s1 = s2; sd_final_nostep: forall s r, @@ -925,8 +928,6 @@ Record backward_simulation (L1 L2: semantics) : Type := exists i', exists s1', (Plus L1 s1 t s1' \/ (Star L1 s1 t s1' /\ bsim_order i' i)) /\ bsim_match_states i' s1' s2'; - bsim_traces: - forall s2 t s2', Step L2 s2 t s2' -> (length t <= 1)%nat; bsim_symbols_preserved: forall id, Genv.find_symbol (globalenv L2) id = Genv.find_symbol (globalenv L1) id }. @@ -960,9 +961,6 @@ Variable L2: semantics. Hypothesis symbols_preserved: forall id, Genv.find_symbol (globalenv L2) id = Genv.find_symbol (globalenv L1) id. -Hypothesis length_traces: - forall s2 t s2', Step L2 s2 t s2' -> (length t <= 1)%nat. - Variable match_states: state L1 -> state L2 -> Prop. Hypothesis initial_states_exist: @@ -1085,6 +1083,7 @@ Section COMPOSE_BACKWARD_SIMULATIONS. Variable L1: semantics. Variable L2: semantics. Variable L3: semantics. +Hypothesis L3_single_events: single_events L3. Variable S12: backward_simulation L1 L2. Variable S23: backward_simulation L2 L3. @@ -1117,7 +1116,7 @@ Proof. intros [ [i2' [s2' [PLUS2 MATCH2]]] | [i2' [ORD2 [EQ MATCH2]]]]. (* 1 L2 makes one or several transitions *) assert (EITHER: t = E0 \/ (length t = 1)%nat). - exploit bsim_traces; eauto. + exploit L3_single_events; eauto. destruct t; auto. destruct t; auto. simpl. intros. omegaContradiction. destruct EITHER. (* 1.1 these are silent transitions *) @@ -1202,8 +1201,6 @@ Proof. eapply (bsim_progress S23). eauto. eapply star_safe; eauto. eapply bsim_safe; eauto. (* simulation *) exact bb_simulation. -(* trace length *) - exact (bsim_traces S23). (* symbols *) intros. transitivity (Genv.find_symbol (globalenv L2) id); apply bsim_symbols_preserved; auto. Qed. @@ -1217,9 +1214,8 @@ Section FORWARD_TO_BACKWARD. Variable L1: semantics. Variable L2: semantics. Variable FS: forward_simulation L1 L2. - -Hypothesis receptive: receptive L1. -Hypothesis determinate: determinate L2. +Hypothesis L1_receptive: receptive L1. +Hypothesis L2_determinate: determinate L2. (** Exploiting forward simulation *) @@ -1391,7 +1387,7 @@ Proof. (* 1. At matching states *) exploit f2b_progress; eauto. intros TRANS; inv TRANS. (* 1.1 L1 can reach final state and L2 is at final state: impossible! *) - exploit (sd_final_nostep determinate); eauto. contradiction. + exploit (sd_final_nostep L2_determinate); eauto. contradiction. (* 1.2 L1 can make 0 or several steps; L2 can make 1 or several matching steps. *) inv H2. exploit f2b_determinacy_inv. eexact H5. eexact STEP2. @@ -1409,15 +1405,15 @@ Proof. right; split. auto. constructor. econstructor. eauto. auto. apply star_one; eauto. eauto. eauto. (* 1.2.2 L2 makes a non-silent transition, and so does L1 *) - exploit not_silent_length. eapply (sr_traces receptive); eauto. intros [EQ | EQ]. + exploit not_silent_length. eapply (sr_traces L1_receptive); eauto. intros [EQ | EQ]. congruence. subst t2. rewrite E0_right in H1. (* Use receptiveness to equate the traces *) - exploit (sr_receptive receptive); eauto. intros [s1''' STEP1]. + exploit (sr_receptive L1_receptive); eauto. intros [s1''' STEP1]. exploit fsim_simulation_not_E0. eexact STEP1. auto. eauto. intros [i''' [s2''' [P Q]]]. inv P. (* Exploit determinacy *) - exploit not_silent_length. eapply (sr_traces receptive); eauto. intros [EQ | EQ]. + exploit not_silent_length. eapply (sr_traces L1_receptive); eauto. intros [EQ | EQ]. subst t0. simpl in *. exploit sd_determ_1. eauto. eexact STEP2. eexact H2. intros. elim NOT2. inv H8. auto. subst t2. rewrite E0_right in *. @@ -1436,17 +1432,17 @@ Proof. right; split. apply star_refl. constructor. omega. econstructor; eauto. eapply star_right; eauto. (* 2.2 L2 make a non-silent transition *) - exploit not_silent_length. eapply (sr_traces receptive); eauto. intros [EQ | EQ]. + exploit not_silent_length. eapply (sr_traces L1_receptive); eauto. intros [EQ | EQ]. congruence. subst. rewrite E0_right in *. (* Use receptiveness to equate the traces *) - exploit (sr_receptive receptive); eauto. intros [s1''' STEP1]. + exploit (sr_receptive L1_receptive); eauto. intros [s1''' STEP1]. exploit fsim_simulation_not_E0. eexact STEP1. auto. eauto. intros [i''' [s2''' [P Q]]]. (* Exploit determinacy *) exploit f2b_determinacy_star. eauto. eexact STEP2. auto. apply plus_star; eauto. intro R. inv R. congruence. - exploit not_silent_length. eapply (sr_traces receptive); eauto. intros [EQ | EQ]. + exploit not_silent_length. eapply (sr_traces L1_receptive); eauto. intros [EQ | EQ]. subst. simpl in *. exploit sd_determ_1. eauto. eexact STEP2. eexact H2. intros. elim NOT2. inv H7; auto. subst. rewrite E0_right in *. @@ -1482,11 +1478,11 @@ Proof. (* final states *) intros. inv H. exploit f2b_progress; eauto. intros TRANS; inv TRANS. - assert (r0 = r) by (eapply (sd_final_determ determinate); eauto). subst r0. + assert (r0 = r) by (eapply (sd_final_determ L2_determinate); eauto). subst r0. exists s1'; auto. - inv H4. exploit (sd_final_nostep determinate); eauto. contradiction. - inv H5. congruence. exploit (sd_final_nostep determinate); eauto. contradiction. - inv H2. exploit (sd_final_nostep determinate); eauto. contradiction. + inv H4. exploit (sd_final_nostep L2_determinate); eauto. contradiction. + inv H5. congruence. exploit (sd_final_nostep L2_determinate); eauto. contradiction. + inv H2. exploit (sd_final_nostep L2_determinate); eauto. contradiction. (* progress *) intros. inv H. exploit f2b_progress; eauto. intros TRANS; inv TRANS. @@ -1496,14 +1492,265 @@ Proof. inv H1. right; econstructor; econstructor; eauto. (* simulation *) exact f2b_simulation_step. -(* trace length *) - exact (sd_traces determinate). (* symbols preserved *) exact (fsim_symbols_preserved FS). Qed. End FORWARD_TO_BACKWARD. +(** * Transforming a semantics into a single-event, equivalent semantics *) + +Definition well_behaved_traces (L: semantics) : Prop := + forall s t s', Step L s t s' -> + match t with nil => True | ev :: t' => output_trace t' end. + +Section ATOMIC. + +Variable L: semantics. + +Hypothesis Lwb: well_behaved_traces L. + +Inductive atomic_step (ge: Genv.t (funtype L) (vartype L)): (trace * state L) -> trace -> (trace * state L) -> Prop := + | atomic_step_silent: forall s s', + Step L s E0 s' -> + atomic_step ge (E0, s) E0 (E0, s') + | atomic_step_start: forall s ev t s', + Step L s (ev :: t) s' -> + atomic_step ge (E0, s) (ev :: nil) (t, s') + | atomic_step_continue: forall ev t s, + output_trace (ev :: t) -> + atomic_step ge (ev :: t, s) (ev :: nil) (t, s). + +Definition atomic : semantics := {| + state := (trace * state L)%type; + funtype := funtype L; + vartype := vartype L; + step := atomic_step; + initial_state := fun s => initial_state L (snd s) /\ fst s = E0; + final_state := fun s r => final_state L (snd s) r /\ fst s = E0; + globalenv := globalenv L +|}. + +End ATOMIC. + +(** A forward simulation from a semantics [L1] to a single-event semantics [L2] + can be "factored" into a forward simulation from [atomic L1] to [L2]. *) + +Section FACTOR_FORWARD_SIMULATION. + +Variable L1: semantics. +Variable L2: semantics. +Variable sim: forward_simulation L1 L2. +Hypothesis L2single: single_events L2. + +Inductive ffs_match: fsim_index sim -> (trace * state L1) -> state L2 -> Prop := + | ffs_match_at: forall i s1 s2, + sim i s1 s2 -> + ffs_match i (E0, s1) s2 + | ffs_match_buffer: forall i ev t s1 s2 s2', + Star L2 s2 (ev :: t) s2' -> sim i s1 s2' -> + ffs_match i (ev :: t, s1) s2. + +Lemma star_non_E0_split': + forall s2 t s2', Star L2 s2 t s2' -> + match t with + | nil => True + | ev :: t' => exists s2x, Plus L2 s2 (ev :: nil) s2x /\ Star L2 s2x t' s2' + end. +Proof. + induction 1. simpl. auto. + exploit L2single; eauto. intros LEN. + destruct t1. simpl in *. subst. destruct t2. auto. + destruct IHstar as [s2x [A B]]. exists s2x; split; auto. + eapply plus_left. eauto. apply plus_star; eauto. auto. + destruct t1. simpl in *. subst t. exists s2; split; auto. apply plus_one; auto. + simpl in LEN. omegaContradiction. +Qed. + +Lemma ffs_simulation: + forall s1 t s1', Step (atomic L1) s1 t s1' -> + forall i s2, ffs_match i s1 s2 -> + exists i', exists s2', + (Plus L2 s2 t s2' \/ (Star L2 s2 t s2') /\ fsim_order sim i' i) + /\ ffs_match i' s1' s2'. +Proof. + induction 1; intros. +(* silent step *) + inv H0. + exploit (fsim_simulation sim); eauto. + intros [i' [s2' [A B]]]. + exists i'; exists s2'; split. auto. constructor; auto. +(* start step *) + inv H0. + exploit (fsim_simulation sim); eauto. + intros [i' [s2' [A B]]]. + destruct t as [ | ev' t]. + (* single event *) + exists i'; exists s2'; split. auto. constructor; auto. + (* multiple events *) + assert (C: Star L2 s2 (ev :: ev' :: t) s2'). intuition. apply plus_star; auto. + exploit star_non_E0_split'. eauto. simpl. intros [s2x [P Q]]. + exists i'; exists s2x; split. auto. econstructor; eauto. +(* continue step *) + inv H0. + exploit star_non_E0_split'. eauto. simpl. intros [s2x [P Q]]. + destruct t. + exists i; exists s2'; split. left. eapply plus_star_trans; eauto. constructor; auto. + exists i; exists s2x; split. auto. econstructor; eauto. +Qed. + +Theorem factor_forward_simulation: + forward_simulation (atomic L1) L2. +Proof. + apply Forward_simulation with (fsim_match_states := ffs_match) (fsim_order := fsim_order sim). +(* wf *) + apply fsim_order_wf. +(* initial states *) + intros. destruct s1 as [t1 s1]. simpl in H. destruct H. subst. + exploit (fsim_match_initial_states sim); eauto. intros [i [s2 [A B]]]. + exists i; exists s2; split; auto. constructor; auto. +(* final states *) + intros. destruct s1 as [t1 s1]. simpl in H0; destruct H0; subst. inv H. + eapply (fsim_match_final_states sim); eauto. +(* simulation *) + exact ffs_simulation. +(* symbols preserved *) + simpl. exact (fsim_symbols_preserved sim). +Qed. + +End FACTOR_FORWARD_SIMULATION. + +(** Likewise, a backward simulation from a single-event semantics [L1] to a semantics [L2] + can be "factored" as a backward simulation from [L1] to [atomic L2]. *) + +Section FACTOR_BACKWARD_SIMULATION. + +Variable L1: semantics. +Variable L2: semantics. +Variable sim: backward_simulation L1 L2. +Hypothesis L1single: single_events L1. +Hypothesis L2wb: well_behaved_traces L2. + +Inductive fbs_match: bsim_index sim -> state L1 -> (trace * state L2) -> Prop := + | fbs_match_intro: forall i s1 t s2 s1', + Star L1 s1 t s1' -> sim i s1' s2 -> + t = E0 \/ output_trace t -> + fbs_match i s1 (t, s2). + +Lemma fbs_simulation: + forall s2 t s2', Step (atomic L2) s2 t s2' -> + forall i s1, fbs_match i s1 s2 -> safe L1 s1 -> + exists i', exists s1', + (Plus L1 s1 t s1' \/ (Star L1 s1 t s1' /\ bsim_order sim i' i)) + /\ fbs_match i' s1' s2'. +Proof. + induction 1; intros. +(* silent step *) + inv H0. + exploit (bsim_simulation sim); eauto. eapply star_safe; eauto. + intros [i' [s1'' [A B]]]. + exists i'; exists s1''; split. + destruct A as [P | [P Q]]. left. eapply star_plus_trans; eauto. right; split; auto. eapply star_trans; eauto. + econstructor. apply star_refl. auto. auto. +(* start step *) + inv H0. + exploit (bsim_simulation sim); eauto. eapply star_safe; eauto. + intros [i' [s1'' [A B]]]. + assert (C: Star L1 s1 (ev :: t) s1''). + eapply star_trans. eauto. destruct A as [P | [P Q]]. apply plus_star; eauto. eauto. auto. + exploit star_non_E0_split'; eauto. simpl. intros [s1x [P Q]]. + exists i'; exists s1x; split. + left; auto. + econstructor; eauto. + exploit L2wb; eauto. +(* continue step *) + inv H0. unfold E0 in H8; destruct H8; try congruence. + exploit star_non_E0_split'; eauto. simpl. intros [s1x [P Q]]. + exists i; exists s1x; split. left; auto. econstructor; eauto. simpl in H0; tauto. +Qed. + +Lemma fbs_progress: + forall i s1 s2, + fbs_match i s1 s2 -> safe L1 s1 -> + (exists r, final_state (atomic L2) s2 r) \/ + (exists t, exists s2', Step (atomic L2) s2 t s2'). +Proof. + intros. inv H. destruct t. +(* 1. no buffered events *) + exploit (bsim_progress sim); eauto. eapply star_safe; eauto. + intros [[r A] | [t [s2' A]]]. +(* final state *) + left; exists r; simpl; auto. +(* L2 can step *) + destruct t. + right; exists E0; exists (nil, s2'). constructor. auto. + right; exists (e :: nil); exists (t, s2'). constructor. auto. +(* 2. some buffered events *) + unfold E0 in H3; destruct H3. congruence. + right; exists (e :: nil); exists (t, s3). constructor. auto. +Qed. + +Theorem factor_backward_simulation: + backward_simulation L1 (atomic L2). +Proof. + apply Backward_simulation with (bsim_match_states := fbs_match) (bsim_order := bsim_order sim). +(* wf *) + apply bsim_order_wf. +(* initial states exist *) + intros. exploit (bsim_initial_states_exist sim); eauto. intros [s2 A]. + exists (E0, s2). simpl; auto. +(* initial states match *) + intros. destruct s2 as [t s2]; simpl in H0; destruct H0; subst. + exploit (bsim_match_initial_states sim); eauto. intros [i [s1' [A B]]]. + exists i; exists s1'; split. auto. econstructor. apply star_refl. auto. auto. +(* final states match *) + intros. destruct s2 as [t s2]; simpl in H1; destruct H1; subst. + inv H. exploit (bsim_match_final_states sim); eauto. eapply star_safe; eauto. + intros [s1'' [A B]]. exists s1''; split; auto. eapply star_trans; eauto. +(* progress *) + exact fbs_progress. +(* simulation *) + exact fbs_simulation. +(* symbols *) + simpl. exact (bsim_symbols_preserved sim). +Qed. + +End FACTOR_BACKWARD_SIMULATION. + +(** Receptiveness of [atomic L]. *) + +Record strongly_receptive (L: semantics) : Prop := + Strongly_receptive { + ssr_receptive: forall s ev1 t1 s1 ev2, + Step L s (ev1 :: t1) s1 -> + match_traces (globalenv L) (ev1 :: nil) (ev2 :: nil) -> + exists s2, exists t2, Step L s (ev2 :: t2) s2; + ssr_well_behaved: + well_behaved_traces L + }. + +Theorem atomic_receptive: + forall L, strongly_receptive L -> receptive (atomic L). +Proof. + intros. constructor; intros. +(* receptive *) + inv H0. + (* silent step *) + inv H1. exists (E0, s'). constructor; auto. + (* start step *) + assert (exists ev2, t2 = ev2 :: nil). inv H1; econstructor; eauto. + destruct H0 as [ev2 EQ]; subst t2. + exploit ssr_receptive; eauto. intros [s2 [t2 P]]. + exploit ssr_well_behaved. eauto. eexact P. simpl; intros Q. + exists (t2, s2). constructor; auto. + (* continue step *) + simpl in H2; destruct H2. + assert (t2 = ev :: nil). inv H1; simpl in H0; tauto. + subst t2. exists (t, s0). constructor; auto. simpl; auto. +(* single-event *) + red. intros. inv H0; simpl; omega. +Qed. + (** * Connections with big-step semantics *) (** The general form of a big-step semantics *) diff --git a/common/Values.v b/common/Values.v index 7fae3b7..54eac86 100644 --- a/common/Values.v +++ b/common/Values.v @@ -160,6 +160,13 @@ Definition notint (v: val) : val := Definition of_bool (b: bool): val := if b then Vtrue else Vfalse. +Definition boolval (v: val) : val := + match v with + | Vint n => of_bool (negb (Int.eq n Int.zero)) + | Vptr b ofs => Vtrue + | _ => Vundef + end. + Definition notbool (v: val) : val := match v with | Vint n => of_bool (Int.eq n Int.zero) @@ -32,6 +32,8 @@ usage='Usage: ./configure [options] target Supported targets: ppc-macosx (PowerPC, MacOS X) ppc-linux (PowerPC, Linux) + ppc-eabi-unix (PowerPC, EABI with Unix tools) + ppc-eabi-diab (PowerPC, EABI with Diab tools) arm-linux (ARM, Linux EABI) ia32-linux (x86 32 bits, Linux) ia32-bsd (x86 32 bits, BSD) @@ -76,7 +78,7 @@ case "$target" in clinker="gcc -arch ppc" libmath="" need_stdlib_wrapper="true";; - powerpc-linux|ppc-linux) + powerpc-linux|ppc-linux|powerpc-eabi-unix|ppc-eabi-unix) arch="powerpc" variant="eabi" system="linux" @@ -86,6 +88,16 @@ case "$target" in clinker="gcc" libmath="-lm" need_stdlib_wrapper="false";; + powerpc-eabi-diab|ppc-eabi-diab) + arch="powerpc" + variant="eabi" + system="diab" + cc="dcc" + cprepro="dcc -E" + casm="das" + clinker="dcc" + libmath="-lm" + need_stdlib_wrapper="false";; arm-linux) arch="arm" variant="linux" @@ -227,7 +239,7 @@ fi if test "$target" = "manual"; then cat <<EOF -Please finish the configuration by editing file ./Makefile.config +Please finish the configuration by editing file ./Makefile.config. EOF @@ -251,6 +263,8 @@ CompCert configuration: Binaries installed in......... $bindirexp Library files installed in.... $libdirexp +If anything above looks wrong, please edit file ./Makefile.config to correct. + EOF fi diff --git a/cparser/.depend b/cparser/.depend index 51f3b5e..4a7f538 100644 --- a/cparser/.depend +++ b/cparser/.depend @@ -1,4 +1,3 @@ -AddCasts.cmi: C.cmi Bitfields.cmi: C.cmi Builtins.cmi: Env.cmi C.cmi C.cmi: @@ -12,18 +11,13 @@ Errors.cmi: GCC.cmi: Builtins.cmi Lexer.cmi: Parser.cmi Machine.cmi: -PackedStructs.cmi: C.cmi Parse.cmi: C.cmi Parse_aux.cmi: Parser.cmi: Cabs.cmo Rename.cmi: C.cmi -SimplExpr.cmi: C.cmi -StructAssign.cmi: C.cmi -StructByValue.cmi: C.cmi +StructReturn.cmi: C.cmi Transform.cmi: Env.cmi C.cmi Unblock.cmi: C.cmi -AddCasts.cmo: Transform.cmi Cutil.cmi C.cmi AddCasts.cmi -AddCasts.cmx: Transform.cmx Cutil.cmx C.cmi AddCasts.cmi Bitfields.cmo: Transform.cmi Machine.cmi Cutil.cmi C.cmi Bitfields.cmi Bitfields.cmx: Transform.cmx Machine.cmx Cutil.cmx C.cmi Bitfields.cmi Builtins.cmo: Env.cmi Cutil.cmi C.cmi Builtins.cmi @@ -59,31 +53,21 @@ Machine.cmx: Machine.cmi Main.cmo: Parse.cmi GCC.cmi Cprint.cmi Builtins.cmi Main.cmx: Parse.cmx GCC.cmx Cprint.cmx Builtins.cmx PackedStructs.cmo: Transform.cmi Machine.cmi Errors.cmi Env.cmi Cutil.cmi \ - C.cmi Builtins.cmi PackedStructs.cmi + Cprint.cmi C.cmi Builtins.cmi PackedStructs.cmx: Transform.cmx Machine.cmx Errors.cmx Env.cmx Cutil.cmx \ - C.cmi Builtins.cmx PackedStructs.cmi -Parse.cmo: Unblock.cmi StructByValue.cmi StructAssign.cmi SimplVolatile.cmo \ - SimplExpr.cmi Rename.cmi PackedStructs.cmi Errors.cmi Elab.cmi \ - Bitfields.cmi AddCasts.cmi Parse.cmi -Parse.cmx: Unblock.cmx StructByValue.cmx StructAssign.cmx SimplVolatile.cmx \ - SimplExpr.cmx Rename.cmx PackedStructs.cmx Errors.cmx Elab.cmx \ - Bitfields.cmx AddCasts.cmx Parse.cmi + Cprint.cmx C.cmi Builtins.cmx +Parse.cmo: Unblock.cmi StructReturn.cmi Rename.cmi PackedStructs.cmo \ + Errors.cmi Elab.cmi Bitfields.cmi Parse.cmi +Parse.cmx: Unblock.cmx StructReturn.cmx Rename.cmx PackedStructs.cmx \ + Errors.cmx Elab.cmx Bitfields.cmx Parse.cmi Parse_aux.cmo: Errors.cmi Cabshelper.cmo Parse_aux.cmi Parse_aux.cmx: Errors.cmx Cabshelper.cmx Parse_aux.cmi Parser.cmo: Parse_aux.cmi Cabshelper.cmo Cabs.cmo Parser.cmi Parser.cmx: Parse_aux.cmx Cabshelper.cmx Cabs.cmx Parser.cmi Rename.cmo: Errors.cmi Cutil.cmi C.cmi Builtins.cmi Rename.cmi Rename.cmx: Errors.cmx Cutil.cmx C.cmi Builtins.cmx Rename.cmi -SimplExpr.cmo: Transform.cmi Errors.cmi Cutil.cmi C.cmi SimplExpr.cmi -SimplExpr.cmx: Transform.cmx Errors.cmx Cutil.cmx C.cmi SimplExpr.cmi -SimplVolatile.cmo: Transform.cmi Cutil.cmi C.cmi -SimplVolatile.cmx: Transform.cmx Cutil.cmx C.cmi -StructAssign.cmo: Transform.cmi Machine.cmi Errors.cmi Env.cmi Cutil.cmi \ - C.cmi StructAssign.cmi -StructAssign.cmx: Transform.cmx Machine.cmx Errors.cmx Env.cmx Cutil.cmx \ - C.cmi StructAssign.cmi -StructByValue.cmo: Transform.cmi Env.cmi Cutil.cmi C.cmi StructByValue.cmi -StructByValue.cmx: Transform.cmx Env.cmx Cutil.cmx C.cmi StructByValue.cmi +StructReturn.cmo: Transform.cmi Env.cmi Cutil.cmi C.cmi StructReturn.cmi +StructReturn.cmx: Transform.cmx Env.cmx Cutil.cmx C.cmi StructReturn.cmi Transform.cmo: Env.cmi Cutil.cmi C.cmi Builtins.cmi Transform.cmi Transform.cmx: Env.cmx Cutil.cmx C.cmi Builtins.cmx Transform.cmi Unblock.cmo: Transform.cmi Errors.cmi Cutil.cmi C.cmi Unblock.cmi diff --git a/cparser/AddCasts.ml b/cparser/AddCasts.ml deleted file mode 100644 index eb3fa08..0000000 --- a/cparser/AddCasts.ml +++ /dev/null @@ -1,243 +0,0 @@ -(* *********************************************************************) -(* *) -(* 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. *) -(* *) -(* *********************************************************************) - -(* Materialize implicit casts *) - -(* Assumes: simplified code - Produces: simplified code - Preserves: unblocked code *) - -open C -open Cutil -open Transform - -(* We have the option of materializing all casts or leave "widening" - casts implicit. Widening casts are: -- from a small integer type to a larger integer type, - provided both types have the same signedness; -- from a small float type to a larger float type; -- from a pointer type to void *. -*) - -let omit_widening_casts = ref false - -let widening_cast env tfrom tto = - begin match unroll env tfrom, unroll env tto with - | TInt(k1, _), TInt(k2, _) -> - integer_rank k1 <= integer_rank k2 - && is_signed_ikind k1 = is_signed_ikind k2 - | TFloat(k1, _), TFloat(k2, _) -> - float_rank k1 <= float_rank k2 - | TPtr(ty1, _), TPtr(ty2, _) -> is_void_type env ty2 - | _, _ -> false - end - -let cast_not_needed env tfrom tto = - let tfrom = pointer_decay env tfrom - and tto = pointer_decay env tto in - compatible_types env tfrom tto - || (!omit_widening_casts && widening_cast env tfrom tto) - -let cast env e tto = - if cast_not_needed env e.etyp tto - then e - else {edesc = ECast(tto, e); etyp = tto} - -(* Note: this pass applies only to simplified expressions - because casts cannot be materialized in op= expressions... *) - -let rec add_expr env e = - match e.edesc with - | EConst _ -> e - | EVar _ -> e - | ESizeof _ -> e - | EUnop(op, e1) -> - let e1' = add_expr env e1 in - let desc = - match op with - | Ominus | Oplus | Onot -> - EUnop(op, cast env e1' e.etyp) - | Olognot | Oderef | Oaddrof - | Odot _ | Oarrow _ -> - EUnop(op, e1') - | Opreincr | Opredecr | Opostincr | Opostdecr -> - assert false (* not simplified *) - in { edesc = desc; etyp = e.etyp } - | EBinop(op, e1, e2, ty) -> - let e1' = add_expr env e1 in - let e2' = add_expr env e2 in - let desc = - match op with - | Oadd -> - if is_pointer_type env ty - then EBinop(Oadd, e1', e2', ty) - else EBinop(Oadd, cast env e1' ty, cast env e2' ty, ty) - | Osub -> - if is_pointer_type env ty - then EBinop(Osub, e1', e2', ty) - else EBinop(Osub, cast env e1' ty, cast env e2' ty, ty) - | Omul|Odiv|Omod|Oand|Oor|Oxor|Oeq|One|Olt|Ogt|Ole|Oge -> - EBinop(op, cast env e1' ty, cast env e2' ty, ty) - | Oshl|Oshr -> - EBinop(op, cast env e1' ty, e2', ty) - | Oindex | Ologand | Ologor | Ocomma -> - EBinop(op, e1', e2', ty) - | Oassign - | Oadd_assign|Osub_assign|Omul_assign|Odiv_assign|Omod_assign - | Oand_assign|Oor_assign|Oxor_assign|Oshl_assign|Oshr_assign -> - assert false (* not simplified *) - in { edesc = desc; etyp = e.etyp } - | EConditional(e1, e2, e3) -> - { edesc = - EConditional(add_expr env e1, add_expr env e2, add_expr env e3); - etyp = e.etyp } - | ECast(ty, e1) -> - { edesc = ECast(ty, add_expr env e1); etyp = e.etyp } - | ECall(e1, el) -> - assert false (* not simplified *) - -(* Arguments to a prototyped function *) - -let rec add_proto env args params = - match args, params with - | [], _ -> [] - | _::_, [] -> add_noproto env args - | arg1 :: argl, (_, ty_p) :: paraml -> - cast env (add_expr env arg1) ty_p :: - add_proto env argl paraml - -(* Arguments to a non-prototyped function *) - -and add_noproto env args = - match args with - | [] -> [] - | arg1 :: argl -> - cast env (add_expr env arg1) (default_argument_conversion env arg1.etyp) :: - add_noproto env argl - -(* Arguments to function calls in general *) - -let add_arguments env ty_fun args = - let ty_args = - match unroll env ty_fun with - | TFun(res, args, vararg, a) -> args - | TPtr(ty, a) -> - begin match unroll env ty with - | TFun(res, args, vararg, a) -> args - | _ -> assert false - end - | _ -> assert false in - match ty_args with - | None -> add_noproto env args - | Some targs -> add_proto env args targs - -(* Toplevel expressions (appearing in Sdo statements) *) - -let add_topexpr env loc e = - match e.edesc with - | EBinop(Oassign, lhs, {edesc = ECall(e1, el); etyp = ty}, _) -> - let ecall = - {edesc = ECall(add_expr env e1, add_arguments env e1.etyp el); - etyp = ty} in - if cast_not_needed env ty lhs.etyp then - sassign loc (add_expr env lhs) ecall - else begin - let tmp = new_temp (erase_attributes_type env ty) in - sseq loc (sassign loc tmp ecall) - (sassign loc (add_expr env lhs) (cast env tmp lhs.etyp)) - end - | EBinop(Oassign, lhs, rhs, _) -> - sassign loc (add_expr env lhs) (cast env (add_expr env rhs) lhs.etyp) - | ECall(e1, el) -> - let ecall = - {edesc = ECall(add_expr env e1, add_arguments env e1.etyp el); - etyp = e.etyp} in - {sdesc = Sdo ecall; sloc = loc} - | _ -> - assert false - -(* Initializers *) - -let rec add_init env tto = function - | Init_single e -> - Init_single (cast env (add_expr env e) tto) - | Init_array il -> - let ty_elt = - match unroll env tto with - | TArray(ty, _, _) -> ty | _ -> assert false in - Init_array (List.map (add_init env ty_elt) il) - | Init_struct(id, fil) -> - Init_struct (id, List.map - (fun (fld, i) -> (fld, add_init env fld.fld_typ i)) - fil) - | Init_union(id, fld, i) -> - Init_union(id, fld, add_init env fld.fld_typ i) - -(* Declarations *) - -let add_decl env (sto, id, ty, optinit) = - (sto, id, ty, - begin match optinit with - | None -> None - | Some init -> Some(add_init env ty init) - end) - -(* Statements *) - -let rec add_stmt env f s = - match s.sdesc with - | Sskip -> s - | Sdo e -> add_topexpr env s.sloc e - | Sseq(s1, s2) -> - {sdesc = Sseq(add_stmt env f s1, add_stmt env f s2); sloc = s.sloc } - | Sif(e, s1, s2) -> - {sdesc = Sif(add_expr env e, add_stmt env f s1, add_stmt env f s2); - sloc = s.sloc} - | Swhile(e, s1) -> - {sdesc = Swhile(add_expr env e, add_stmt env f s1); - sloc = s.sloc} - | Sdowhile(s1, e) -> - {sdesc = Sdowhile(add_stmt env f s1, add_expr env e); - sloc = s.sloc} - | Sfor(s1, e, s2, s3) -> - {sdesc = Sfor(add_stmt env f s1, add_expr env e, add_stmt env f s2, - add_stmt env f s3); - sloc = s.sloc} - | Sbreak -> s - | Scontinue -> s - | Sswitch(e, s1) -> - {sdesc = Sswitch(add_expr env e, add_stmt env f s1); sloc = s.sloc} - | Slabeled(lbl, s) -> - {sdesc = Slabeled(lbl, add_stmt env f s); sloc = s.sloc} - | Sgoto lbl -> s - | Sreturn None -> s - | Sreturn (Some e) -> - {sdesc = Sreturn(Some(cast env (add_expr env e) f.fd_ret)); sloc = s.sloc} - | Sblock sl -> - {sdesc = Sblock(List.map (add_stmt env f) sl); sloc = s.sloc} - | Sdecl d -> - {sdesc = Sdecl(add_decl env d); sloc = s.sloc} - -let add_fundef env f = - reset_temps(); - let body' = add_stmt env f f.fd_body in - let temps = get_temps () in - (* fd_locals have no initializers, so no need to transform them *) - { f with fd_locals = f.fd_locals @ temps; fd_body = body' } - - -let program ?(all = false) p = - omit_widening_casts := not all; - Transform.program ~decl:add_decl ~fundef:add_fundef p diff --git a/cparser/AddCasts.mli b/cparser/AddCasts.mli deleted file mode 100644 index 318ecc6..0000000 --- a/cparser/AddCasts.mli +++ /dev/null @@ -1,16 +0,0 @@ -(* *********************************************************************) -(* *) -(* 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. *) -(* *) -(* *********************************************************************) - -val program: ?all: bool -> C.program -> C.program diff --git a/cparser/Elab.ml b/cparser/Elab.ml index 870385d..2da1936 100644 --- a/cparser/Elab.ml +++ b/cparser/Elab.ml @@ -1508,13 +1508,13 @@ let rec enter_decdefs local loc env = function (* check for incomplete type *) if sto' <> Storage_extern && incomplete_type env ty' then warning loc "'%s' has incomplete type" s; - if local && sto <> Storage_extern && sto <> Storage_static then begin + if local && sto' <> Storage_extern && sto' <> Storage_static then begin (* Local definition *) let (decls, env3) = enter_decdefs local loc env2 rem in ((sto', id, ty', init') :: decls, env3) end else begin (* Global definition *) - emit_elab (elab_loc loc) (Gdecl(sto, id, ty', init')); + emit_elab (elab_loc loc) (Gdecl(sto', id, ty', init')); enter_decdefs local loc env2 rem end diff --git a/cparser/Makefile b/cparser/Makefile index 527cdd3..da2c28b 100644 --- a/cparser/Makefile +++ b/cparser/Makefile @@ -15,8 +15,8 @@ SRCS=Errors.ml Cabs.ml Cabshelper.ml Parse_aux.ml Parser.ml Lexer.ml \ Builtins.ml GCC.ml \ Cleanup.ml Elab.ml Rename.ml \ Transform.ml \ - Unblock.ml SimplExpr.ml AddCasts.ml StructByValue.ml StructAssign.ml \ - Bitfields.ml PackedStructs.ml SimplVolatile.ml \ + Unblock.ml StructReturn.ml \ + Bitfields.ml PackedStructs.ml \ Parse.ml COBJS=uint64.o diff --git a/cparser/Parse.ml b/cparser/Parse.ml index dcd01e9..2c467a7 100644 --- a/cparser/Parse.ml +++ b/cparser/Parse.ml @@ -20,28 +20,18 @@ module CharSet = Set.Make(struct type t = char let compare = compare end) let transform_program t p = let run_pass pass flag p = if CharSet.mem flag t then pass p else p in Rename.program - (run_pass (AddCasts.program ~all:(CharSet.mem 'C' t)) 'c' - (run_pass (SimplExpr.program ~volatile:(CharSet.mem 'V' t)) 'e' - (run_pass SimplVolatile.program 'v' - (run_pass StructAssign.program 'S' - (run_pass StructByValue.program 's' + (run_pass StructReturn.program 's' (run_pass PackedStructs.program 'p' (run_pass Bitfields.program 'f' (run_pass Unblock.program 'b' - p)))))))) + p)))) let parse_transformations s = let t = ref CharSet.empty in let set s = String.iter (fun c -> t := CharSet.add c !t) s in String.iter (function 'b' -> set "b" - | 'e' -> set "e" - | 'c' -> set "ec" - | 'C' -> set "ecC" | 's' -> set "s" - | 'S' -> set "bsS" - | 'v' -> set "v" - | 'V' -> set "eV" | 'f' -> set "bf" | 'p' -> set "bp" | _ -> ()) diff --git a/cparser/SimplExpr.ml b/cparser/SimplExpr.ml deleted file mode 100644 index 4184d95..0000000 --- a/cparser/SimplExpr.ml +++ /dev/null @@ -1,568 +0,0 @@ -(* *********************************************************************) -(* *) -(* 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. *) -(* *) -(* *********************************************************************) - -(* Pulling side-effects out of expressions *) - -(* Assumes: nothing - Produces: simplified code *) - -open C -open Cutil -open Transform - -(* Grammar of simplified expressions: - e ::= EConst cst - | ESizeof ty - | EVar id - | EUnop pure-unop e - | EBinop pure-binop e e - | EConditional e e e - | ECast ty e - - Grammar of statements produced to reflect side-effects in expressions: - s ::= Sskip - | Sdo (EBinop Oassign e e) - | Sdo (EBinop Oassign e (ECall e e* )) - | Sdo (Ecall e el) - | Sseq s s - | Sif e s s -*) - -let rec is_simpl_expr e = - match e.edesc with - | EConst cst -> true - | ESizeof ty -> true - | EVar id -> true - | EUnop((Ominus|Oplus|Olognot|Onot|Oderef|Oaddrof), e1) -> - is_simpl_expr e1 - | EBinop((Oadd|Osub|Omul|Odiv|Omod|Oand|Oor|Oxor|Oshl|Oshr| - Oeq|One|Olt|Ogt|Ole|Oge|Oindex|Ologand|Ologor), e1, e2, _) -> - is_simpl_expr e1 && is_simpl_expr e2 - | EConditional(e1, e2, e3) -> - is_simpl_expr e1 && is_simpl_expr e2 && is_simpl_expr e3 - | ECast(ty, e1) -> - is_simpl_expr e1 - | _ -> - false - -(* "Destination" of a simplified expression *) - -type exp_destination = - | RHS (* evaluate as a r-value *) - | LHS (* evaluate as a l-value *) - | Drop (* drop its value, we only need the side-effects *) - | Set of exp (* assign it to the given simplified l.h.s. *) - -let voidconst = { nullconst with etyp = TVoid [] } - -(* Reads from volatile lvalues are also considered as side-effects if - [volatilize] is true. *) - -let volatilize = ref false - -(* [simpl_expr loc env e act] returns a pair [s, e'] of - a statement that performs the side-effects present in [e] and - a simplified, side-effect-free expression [e']. - If [act] is [RHS], [e'] evaluates to the same value as [e]. - If [act] is [LHS], [e'] evaluates to the same location as [e]. - If [act] is [Drop], [e'] is not meaningful and must be ignored. - If [act] is [Set lhs], [s] also performs an assignment - equivalent to [lhs = e]. [e'] is not meaningful. *) - -let simpl_expr loc env e act = - - (* Temporaries should not be [const] because we assign into them, - and need not be [volatile] because no one else is writing into them. - As for [restrict] it doesn't make sense anyway. *) - - let new_temp ty = - Transform.new_temp (erase_attributes_type env ty) in - - let eboolvalof e = - { edesc = EBinop(One, e, intconst 0L IInt, TInt(IInt, [])); - etyp = TInt(IInt, []) } in - - let sseq s1 s2 = Cutil.sseq loc s1 s2 in - - let sassign e1 e2 = - { sdesc = Sdo {edesc = EBinop(Oassign, e1, e2, e1.etyp); etyp = e1.etyp}; - sloc = loc } in - - let sif e s1 s2 = - { sdesc = Sif(e, s1, s2); sloc = loc } in - - let is_volatile_read e = - !volatilize - && List.mem AVolatile (attributes_of_type env e.etyp) - && is_lvalue e in - - let lhs_to_rhs e = - if is_volatile_read e - then (let t = new_temp e.etyp in (sassign t e, t)) - else (sskip, e) in - - let finish act s e = - match act with - | RHS -> - if is_volatile_read e - then (let t = new_temp e.etyp in (sseq s (sassign t e), t)) - else (s, e) - | LHS -> - (s, e) - | Drop -> - if is_volatile_read e - then (let t = new_temp e.etyp in (sseq s (sassign t e), voidconst)) - else (s, voidconst) - | Set lhs -> - if is_volatile_read e - then (let t = new_temp e.etyp in - (sseq s (sseq (sassign t e) (sassign lhs t)), voidconst)) - else (sseq s (sassign lhs e), voidconst) in - - let rec simpl e act = - match e.edesc with - - | EConst cst -> - finish act sskip e - - | ESizeof ty -> - finish act sskip e - - | EVar id -> - finish act sskip e - - | EUnop(op, e1) -> - - begin match op with - - | Ominus | Oplus | Olognot | Onot | Oderef | Oarrow _ -> - let (s1, e1') = simpl e1 RHS in - finish act s1 {edesc = EUnop(op, e1'); etyp = e.etyp} - - | Oaddrof -> - let (s1, e1') = simpl e1 LHS in - finish act s1 {edesc = EUnop(op, e1'); etyp = e.etyp} - - | Odot _ -> - let (s1, e1') = simpl e1 (if act = LHS then LHS else RHS) in - finish act s1 {edesc = EUnop(op, e1'); etyp = e.etyp} - - | Opreincr | Opredecr -> - let (s1, e1') = simpl e1 LHS in - let (s2, e2') = lhs_to_rhs e1' in - let op' = match op with Opreincr -> Oadd | _ -> Osub in - let ty = unary_conversion env e.etyp in - let e3 = - {edesc = EBinop(op', e2', intconst 1L IInt, ty); etyp = ty} in - begin match act with - | Drop -> - (sseq s1 (sseq s2 (sassign e1' e3)), voidconst) - | _ -> - let tmp = new_temp e.etyp in - finish act (sseq s1 (sseq s2 (sseq (sassign tmp e3) - (sassign e1' tmp)))) - tmp - end - - | Opostincr | Opostdecr -> - let (s1, e1') = simpl e1 LHS in - let op' = match op with Opostincr -> Oadd | _ -> Osub in - let ty = unary_conversion env e.etyp in - begin match act with - | Drop -> - let (s2, e2') = lhs_to_rhs e1' in - let e3 = - {edesc = EBinop(op', e2', intconst 1L IInt, ty); etyp = ty} in - (sseq s1 (sseq s2 (sassign e1' e3)), voidconst) - | _ -> - let tmp = new_temp e.etyp in - let e3 = - {edesc = EBinop(op', tmp, intconst 1L IInt, ty); etyp = ty} in - finish act (sseq s1 (sseq (sassign tmp e1') (sassign e1' e3))) - tmp - end - - end - - | EBinop(op, e1, e2, ty) -> - - begin match op with - - | Oadd | Osub | Omul | Odiv | Omod | Oand | Oor | Oxor - | Oshl | Oshr | Oeq | One | Olt | Ogt | Ole | Oge | Oindex -> - let (s1, e1') = simpl e1 RHS in - let (s2, e2') = simpl e2 RHS in - finish act (sseq s1 s2) - {edesc = EBinop(op, e1', e2', ty); etyp = e.etyp} - - | Oassign -> - if act = Drop && is_simpl_expr e1 then - simpl e2 (Set e1) - else begin - match act with - | Drop -> - let (s1, e1') = simpl e1 LHS in - let (s2, e2') = simpl e2 RHS in - (sseq s1 (sseq s2 (sassign e1' e2')), voidconst) - | _ -> - let tmp = new_temp e.etyp in - let (s1, e1') = simpl e1 LHS in - let (s2, e2') = simpl e2 (Set tmp) in - finish act (sseq s1 (sseq s2 (sassign e1' tmp))) - tmp - end - - | Oadd_assign | Osub_assign | Omul_assign | Odiv_assign - | Omod_assign | Oand_assign | Oor_assign | Oxor_assign - | Oshl_assign | Oshr_assign -> - let (s1, e1') = simpl e1 LHS in - let (s11, e11') = lhs_to_rhs e1' in - let (s2, e2') = simpl e2 RHS in - let op' = - match op with - | Oadd_assign -> Oadd | Osub_assign -> Osub - | Omul_assign -> Omul | Odiv_assign -> Odiv - | Omod_assign -> Omod | Oand_assign -> Oand - | Oor_assign -> Oor | Oxor_assign -> Oxor - | Oshl_assign -> Oshl | Oshr_assign -> Oshr - | _ -> assert false in - let e3 = - { edesc = EBinop(op', e11', e2', ty); etyp = ty } in - begin match act with - | Drop -> - (sseq s1 (sseq s11 (sseq s2 (sassign e1' e3))), voidconst) - | _ -> - let tmp = new_temp e.etyp in - finish act (sseq s1 (sseq s11 (sseq s2 - (sseq (sassign tmp e3) (sassign e1' tmp))))) - tmp - end - - | Ocomma -> - let (s1, _) = simpl e1 Drop in - let (s2, e2') = simpl e2 act in - (sseq s1 s2, e2') - - | Ologand -> - let (s1, e1') = simpl e1 RHS in - if is_simpl_expr e2 then begin - finish act s1 - {edesc = EBinop(Ologand, e1', e2, ty); etyp = e.etyp} - end else begin - match act with - | Drop -> - let (s2, _) = simpl e2 Drop in - (sseq s1 (sif e1' s2 sskip), voidconst) - | RHS | LHS -> (* LHS should not happen *) - let (s2, e2') = simpl e2 RHS in - let tmp = new_temp e.etyp in - (sseq s1 (sif e1' - (sseq s2 (sassign tmp (eboolvalof e2'))) - (sassign tmp (intconst 0L IInt))), - tmp) - | Set lv -> - let (s2, e2') = simpl e2 RHS in - (sseq s1 (sif e1' - (sseq s2 (sassign lv (eboolvalof e2'))) - (sassign lv (intconst 0L IInt))), - voidconst) - end - - | Ologor -> - let (s1, e1') = simpl e1 RHS in - if is_simpl_expr e2 then begin - finish act s1 - {edesc = EBinop(Ologor, e1', e2, ty); etyp = e.etyp} - end else begin - match act with - | Drop -> - let (s2, _) = simpl e2 Drop in - (sseq s1 (sif e1' sskip s2), voidconst) - | RHS | LHS -> (* LHS should not happen *) - let (s2, e2') = simpl e2 RHS in - let tmp = new_temp e.etyp in - (sseq s1 (sif e1' - (sassign tmp (intconst 1L IInt)) - (sseq s2 (sassign tmp (eboolvalof e2')))), - tmp) - | Set lv -> - let (s2, e2') = simpl e2 RHS in - (sseq s1 (sif e1' - (sassign lv (intconst 1L IInt)) - (sseq s2 (sassign lv (eboolvalof e2')))), - voidconst) - end - - end - - | EConditional(e1, e2, e3) -> - let (s1, e1') = simpl e1 RHS in - if is_simpl_expr e2 && is_simpl_expr e3 then begin - finish act s1 {edesc = EConditional(e1', e2, e3); etyp = e.etyp} - end else begin - match act with - | Drop -> - let (s2, _) = simpl e2 Drop in - let (s3, _) = simpl e3 Drop in - (sseq s1 (sif e1' s2 s3), voidconst) - | RHS | LHS -> (* LHS should not happen *) - let tmp = new_temp e.etyp in - let (s2, _) = simpl e2 (Set tmp) in - let (s3, _) = simpl e3 (Set tmp) in - (sseq s1 (sif e1' s2 s3), tmp) - | Set lv -> - let (s2, _) = simpl e2 (Set lv) in - let (s3, _) = simpl e3 (Set lv) in - (sseq s1 (sif e1' s2 s3), voidconst) - end - - | ECast(ty, e1) -> - if is_void_type env ty then begin - if act <> Drop then - Errors.warning "%acast to 'void' in a context expecting a value\n" - formatloc loc; - simpl e1 act - end else begin - let (s1, e1') = simpl e1 RHS in - finish act s1 {edesc = ECast(ty, e1'); etyp = e.etyp} - end - - | ECall(e1, el) -> - let (s1, e1') = simpl e1 RHS in - let (s2, el') = simpl_list el in - let e2 = { edesc = ECall(e1', el'); etyp = e.etyp } in - begin match act with - | Drop -> - (sseq s1 (sseq s2 {sdesc = Sdo e2; sloc=loc}), voidconst) - | Set({edesc = EVar _} as lhs) -> - (* CompCert wants the destination of a call to be a variable, - not a more complex lhs. In the latter case, we - fall through the catch-all case below *) - (sseq s1 (sseq s2 (sassign lhs e2)), voidconst) - | _ -> - let tmp = new_temp e.etyp in - finish act (sseq s1 (sseq s2 (sassign tmp e2))) tmp - end - - and simpl_list = function - | [] -> (sskip, []) - | e1 :: el -> - let (s1, e1') = simpl e1 RHS in - let (s2, el') = simpl_list el in - (sseq s1 s2, e1' :: el') - - in simpl e act - -(* Simplification of an initializer *) - -let simpl_initializer loc env i = - - let rec simpl_init = function - | Init_single e -> - let (s, e') = simpl_expr loc env e RHS in - (s, Init_single e) - | Init_array il -> - let rec simpl = function - | [] -> (sskip, []) - | i1 :: il -> - let (s1, i1') = simpl_init i1 in - let (s2, il') = simpl il in - (sseq loc s1 s2, i1' :: il') in - let (s, il') = simpl il in - (s, Init_array il') - | Init_struct(id, il) -> - let rec simpl = function - | [] -> (sskip, []) - | (f1, i1) :: il -> - let (s1, i1') = simpl_init i1 in - let (s2, il') = simpl il in - (sseq loc s1 s2, (f1, i1') :: il') in - let (s, il') = simpl il in - (s, Init_struct(id, il')) - | Init_union(id, f, i) -> - let (s, i') = simpl_init i in - (s, Init_union(id, f, i')) - - in simpl_init i - -(* Construct a simplified statement equivalent to [if (e) s1; else s2;]. - Optimizes the case where e contains [&&] or [||] or [?]. - [s1] or [s2] can be duplicated, so use only for small [s1] and [s2] - that do not define any labels. *) - -let rec simpl_if loc env e s1 s2 = - match e.edesc with - | EUnop(Olognot, e1) -> - simpl_if loc env e1 s2 s1 - | EBinop(Ologand, e1, e2, _) -> - simpl_if loc env e1 - (simpl_if loc env e2 s1 s2) - s2 - | EBinop(Ologor, e1, e2, _) -> - simpl_if loc env e1 - s1 - (simpl_if loc env e2 s1 s2) - | EConditional(e1, e2, e3) -> - simpl_if loc env e1 - (simpl_if loc env e2 s1 s2) - (simpl_if loc env e3 s1 s2) - | _ -> - let (s, e') = simpl_expr loc env e RHS in - sseq loc s {sdesc = Sif(e', s1, s2); sloc = loc} - -(* Trivial statements for which [simpl_if] is applicable *) - -let trivial_stmt s = - match s.sdesc with - | Sskip | Scontinue | Sbreak | Sgoto _ -> true - | _ -> false - -(* Construct a simplified statement equivalent to [if (!e) exit; ]. *) - -let break_if_false loc env e = - simpl_if loc env e - {sdesc = Sskip; sloc = loc} - {sdesc = Sbreak; sloc = loc} - -(* Simplification of a statement *) - -let simpl_statement env s = - - let rec simpl_stmt s = - match s.sdesc with - - | Sskip -> - s - - | Sdo e -> - let (s', _) = simpl_expr s.sloc env e Drop in - s' - - | Sseq(s1, s2) -> - {sdesc = Sseq(simpl_stmt s1, simpl_stmt s2); sloc = s.sloc} - - | Sif(e, s1, s2) -> - if trivial_stmt s1 && trivial_stmt s2 then - simpl_if s.sloc env e (simpl_stmt s1) (simpl_stmt s2) - else begin - let (s', e') = simpl_expr s.sloc env e RHS in - sseq s.sloc s' - {sdesc = Sif(e', simpl_stmt s1, simpl_stmt s2); - sloc = s.sloc} - end - - | Swhile(e, s1) -> - if is_simpl_expr e then - {sdesc = Swhile(e, simpl_stmt s1); sloc = s.sloc} - else - {sdesc = - Swhile(intconst 1L IInt, - sseq s.sloc (break_if_false s.sloc env e) - (simpl_stmt s1)); - sloc = s.sloc} - - | Sdowhile(s1, e) -> - if is_simpl_expr e then - {sdesc = Sdowhile(simpl_stmt s1, e); sloc = s.sloc} - else begin - let tmp = new_temp (TInt(IInt, [])) in - let (s', _) = simpl_expr s.sloc env e (Set tmp) in - let s_init = - {sdesc = Sdo {edesc = EBinop(Oassign, tmp, intconst 1L IInt, tmp.etyp); - etyp = tmp.etyp}; - sloc = s.sloc} in - {sdesc = Sfor(s_init, tmp, s', simpl_stmt s1); sloc = s.sloc} - end -(*** Alternate translation that unfortunately puts a "break" in the - "next" part of a "for", something that is not supported - by Clight semantics, and has unknown behavior in gcc. - {sdesc = - Sfor(sskip, - intconst 1L IInt, - break_if_false s.sloc env e, - simpl_stmt s1); - sloc = s.sloc} -***) - - | Sfor(s1, e, s2, s3) -> - if is_simpl_expr e then - {sdesc = Sfor(simpl_stmt s1, - e, - simpl_stmt s2, - simpl_stmt s3); - sloc = s.sloc} - else - let (s', e') = simpl_expr s.sloc env e RHS in - {sdesc = Sfor(sseq s.sloc (simpl_stmt s1) s', - e', - sseq s.sloc (simpl_stmt s2) s', - simpl_stmt s3); - sloc = s.sloc} - - | Sbreak -> - s - | Scontinue -> - s - - | Sswitch(e, s1) -> - let (s', e') = simpl_expr s.sloc env e RHS in - sseq s.sloc s' {sdesc = Sswitch(e', simpl_stmt s1); sloc = s.sloc} - - | Slabeled(lbl, s1) -> - {sdesc = Slabeled(lbl, simpl_stmt s1); sloc = s.sloc} - - | Sgoto lbl -> - s - - | Sreturn None -> - s - - | Sreturn (Some e) -> - let (s', e') = simpl_expr s.sloc env e RHS in - sseq s.sloc s' {sdesc = Sreturn(Some e'); sloc = s.sloc} - - | Sblock sl -> - {sdesc = Sblock(simpl_block sl); sloc = s.sloc} - - | Sdecl d -> assert false - - and simpl_block = function - | [] -> [] - | ({sdesc = Sdecl(sto, id, ty, None)} as s) :: sl -> - s :: simpl_block sl - | ({sdesc = Sdecl(sto, id, ty, Some i)} as s) :: sl -> - let (s', i') = simpl_initializer s.sloc env i in - let sl' = - {sdesc = Sdecl(sto, id, ty, Some i'); sloc = s.sloc} - :: simpl_block sl in - if s'.sdesc = Sskip then sl' else s' :: sl' - | s :: sl -> - simpl_stmt s :: simpl_block sl - - in simpl_stmt s - -(* Simplification of a function definition *) - -let simpl_fundef env f = - reset_temps(); - let body' = simpl_statement env f.fd_body in - let temps = get_temps() in - { f with fd_locals = f.fd_locals @ temps; fd_body = body' } - -(* Entry point *) - -let program ?(volatile = false) p = - volatilize := volatile; - Transform.program ~fundef:simpl_fundef p diff --git a/cparser/SimplExpr.mli b/cparser/SimplExpr.mli deleted file mode 100644 index cdeb30c..0000000 --- a/cparser/SimplExpr.mli +++ /dev/null @@ -1,20 +0,0 @@ -(* *********************************************************************) -(* *) -(* 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. *) -(* *) -(* *********************************************************************) - -(* Pulling side effects out of expressions. - If [volatile] is [true], treats reads from volatile rvalues - as side-effects *) - -val program: ?volatile: bool -> C.program -> C.program diff --git a/cparser/SimplVolatile.ml b/cparser/SimplVolatile.ml deleted file mode 100644 index ef7a3a0..0000000 --- a/cparser/SimplVolatile.ml +++ /dev/null @@ -1,81 +0,0 @@ -(* *********************************************************************) -(* *) -(* 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. *) -(* *) -(* *********************************************************************) - -(* Elimination of read-modify-write operators (+=, ++, etc) applied - to volatile expressions. *) - -open Printf -open C -open Cutil -open Transform - -(* Rewriting of expressions *) - -let transf_expr loc env ctx e = - - let is_volatile ty = - List.mem AVolatile (attributes_of_type env ty) in - - let rec texp ctx e = - match e.edesc with - | EConst _ -> e - | ESizeof _ -> e - | EVar _ -> e - | EUnop((Opreincr|Opredecr as op), e1) when is_volatile e1.etyp -> - expand_preincrdecr ~read:(fun e -> e) ~write:eassign - env ctx op (texp Val e1) - | EUnop((Opostincr|Opostdecr as op), e1) when is_volatile e1.etyp -> - expand_postincrdecr ~read:(fun e -> e) ~write:eassign - env ctx op (texp Val e1) - | EUnop(op, e1) -> - {edesc = EUnop(op, texp Val e1); etyp = e.etyp} - | EBinop(Oassign, e1, e2, ty) when is_volatile e1.etyp -> - expand_assign ~write:eassign env ctx (texp Val e1) (texp Val e2) - | EBinop((Oadd_assign | Osub_assign | Omul_assign - | Odiv_assign | Omod_assign - | Oand_assign | Oor_assign | Oxor_assign - | Oshl_assign | Oshr_assign) as op, e1, e2, ty) - when is_volatile e1.etyp -> - expand_assignop ~read:(fun e -> e) ~write:eassign - env ctx op (texp Val e1) (texp Val e2) ty - | EBinop(Ocomma, e1, e2, ty) -> - {edesc = EBinop(Ocomma, texp Effects e1, texp ctx e2, ty); - etyp = e.etyp} - | EBinop(op, e1, e2, ty) -> - {edesc = EBinop(op, texp Val e1, texp Val e2, ty); etyp = e.etyp} - | EConditional(e1, e2, e3) -> - {edesc = EConditional(texp Val e1, texp ctx e2, texp ctx e3); - etyp = e.etyp} - | ECast(ty, e1) -> - {edesc = ECast(ty, texp Val e1); etyp = e.etyp} - | ECall(e1, el) -> - {edesc = ECall(texp Val e1, List.map (texp Val) el); etyp = e.etyp} - - in texp ctx e - -(* Statements *) - -let transf_stmt env s = - Transform.stmt transf_expr env s - -(* Functions *) - -let transf_fundef env f = - Transform.fundef transf_stmt env f - -(* Programs *) - -let program p = - Transform.program ~fundef:transf_fundef p diff --git a/cparser/StructAssign.ml b/cparser/StructAssign.ml deleted file mode 100644 index d9ad8f5..0000000 --- a/cparser/StructAssign.ml +++ /dev/null @@ -1,165 +0,0 @@ -(* *********************************************************************) -(* *) -(* 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. *) -(* *) -(* *********************************************************************) - -(* Expand assignments between structs and between unions *) - -(* Assumes: unblocked code. - Preserves: unblocked code *) - -open C -open Machine -open Cutil -open Env -open Errors -open Transform - -(* Finding appropriate memcpy functions *) - -let memcpy_decl = ref (None : ident option) - -let memcpy_type = - TFun(TPtr(TVoid [], []), - Some [(Env.fresh_ident "", TPtr(TVoid [], [])); - (Env.fresh_ident "", TPtr(TVoid [AConst], [])); - (Env.fresh_ident "", TInt(size_t_ikind, []))], - false, []) - -let lookup_function env name = - match Env.lookup_ident env name with - | (id, II_ident(sto, ty)) -> (id, ty) - | (id, II_enum _) -> raise (Env.Error(Env.Unbound_identifier name)) - -let default_memcpy () = - match !memcpy_decl with - | Some id -> - (id, memcpy_type) - | None -> - let id = Env.fresh_ident "memcpy" in - memcpy_decl := Some id; - (id, memcpy_type) - -let find_memcpy env = - try - (lookup_function env "__builtin_memcpy_aligned", true) - with Env.Error _ -> - try - (lookup_function env "__builtin_memcpy", false) - with Env.Error _ -> - try - (lookup_function env "memcpy", false) - with Env.Error _ -> - (default_memcpy(), false) - -(* Smart constructor that "bubble up" sequence expressions *) - -let rec edot f e ty = - match e.edesc with - | EBinop(Ocomma, e1, e2, _) -> ecomma e1 (edot f e2 ty) - | _ -> { edesc = EUnop(Odot f, e); etyp = ty } - -(* Translate an assignment [lhs = rhs] between composite types. - [lhs] and [rhs] must be l-values. *) - -let transf_assign env lhs rhs = - let al = - match Cutil.alignof env lhs.etyp with Some al -> al | None -> 1 in - let ((ident, ty), four_args) = find_memcpy env in - let memcpy = {edesc = EVar(ident); etyp = ty} in - let e_lhs = eaddrof lhs - and e_rhs = eaddrof rhs - and e_size = {edesc = ESizeof(lhs.etyp); etyp = TInt(size_t_ikind, [])} - and e_align = intconst (Int64.of_int al) size_t_ikind in - let args = - if four_args - then [e_lhs; e_rhs; e_size; e_align] - else [e_lhs; e_rhs; e_size] in - {edesc = ECall(memcpy, args); etyp = TVoid[]} - -(* Transformation of expressions. *) - -let transf_expr loc env ctx e = - let rec texp ctx e = - match e.edesc with - | EBinop(Oassign, lhs, rhs, _) when is_composite_type env lhs.etyp -> - let lhs' = texp Val lhs in - let rhs' = texp Val rhs in - begin match ctx with - | Effects -> - transf_assign env lhs' rhs' - | Val -> - bind_lvalue env lhs' (fun l -> ecomma (transf_assign env l rhs') l) - end - | EConst c -> e - | ESizeof ty -> e - | EVar x -> - if ctx = Effects && is_composite_type env e.etyp - then nullconst - else e - | EUnop(Oaddrof, e1) -> - eaddrof (texp Val e1) - | EUnop(Oderef, e1) -> - if ctx = Effects && is_composite_type env e.etyp - then texp Effects e1 - else {edesc = EUnop(Oderef, texp Val e1); etyp = e.etyp} - | EUnop(Odot f, e1) -> - if ctx = Effects && is_composite_type env e.etyp - then texp Effects e1 - else edot f (texp Val e1) e.etyp - | EUnop(Oarrow f, e1) -> - if ctx = Effects && is_composite_type env e.etyp - then texp Effects e1 - else {edesc = EUnop(Oarrow f, texp Val e1); etyp = e.etyp} - | EUnop(op, e1) -> - {edesc = EUnop(op, texp Val e1); etyp = e.etyp} - | EBinop(Oindex, e1, e2, ty) -> - if ctx = Effects && is_composite_type env e.etyp - then ecomma (texp Effects e1) (texp Effects e2) - else {edesc = EBinop(Oindex, texp Val e1, texp Val e2, ty); etyp = e.etyp} - | EBinop(Ocomma, e1, e2, ty) -> - ecomma (texp Effects e1) (texp ctx e2) - | EBinop(op, e1, e2, ty) -> - {edesc = EBinop(op, texp Val e1, texp Val e2, ty); - etyp = e.etyp} - | EConditional(e1, e2, e3) -> - {edesc = EConditional(texp Val e1, texp ctx e2, texp ctx e3); - etyp = e.etyp} - | ECast(ty, e1) -> - {edesc = ECast(ty, texp Val e1); etyp = e.etyp} - | ECall(e1, el) -> - {edesc = ECall(texp Val e1, - List.map (texp Val) el); - etyp = e.etyp} - in texp ctx e - -(* Transformation of statements *) - -let transf_stmt env s = - Transform.stmt transf_expr env s - -(* Transformation of function definitions *) - -let transf_fundef env f = - Transform.fundef transf_stmt env f - -(* Transformation of programs *) - -let program p = - memcpy_decl := None; - let p' = Transform.program ~fundef:transf_fundef p in - match !memcpy_decl with - | None -> p' - | Some id -> - {gdesc = Gdecl(Storage_extern, id, memcpy_type, None); gloc = no_loc} - :: p' diff --git a/cparser/StructAssign.mli b/cparser/StructAssign.mli deleted file mode 100644 index 5549282..0000000 --- a/cparser/StructAssign.mli +++ /dev/null @@ -1,18 +0,0 @@ -(* *********************************************************************) -(* *) -(* 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. *) -(* *) -(* *********************************************************************) - -(* Expand assignments between structs and between unions *) - -val program: C.program -> C.program diff --git a/cparser/StructByValue.ml b/cparser/StructReturn.ml index 1b74ec5..2a4bbc1 100644 --- a/cparser/StructByValue.ml +++ b/cparser/StructReturn.ml @@ -13,17 +13,14 @@ (* *) (* *********************************************************************) -(* Eliminate by-value passing of structs and unions. *) - -(* Assumes: nothing. - Preserves: unblocked code *) +(* Eliminate structs and unions being returned by value as function results *) +(* This is a simpler special case of [StructByValue]. *) open C open Cutil open Transform -(* In function argument types, struct s -> const struct s * - In function result types, struct s -> void + add 1st parameter struct s * +(* In function result types, struct s -> void + add 1st parameter struct s * Try to preserve original typedef names when no change. *) @@ -49,11 +46,7 @@ let rec transf_type env t = if t1' = t1 then t else TArray(transf_type env t1, sz, attr) | _ -> t -and transf_funarg env (id, t) = - let t = transf_type env t in - if is_composite_type env t - then (id, TPtr(add_attributes_type [AConst] t, [])) - else (id, t) +and transf_funarg env (id, t) = (id, transf_type env t) (* Expressions: transform calls + rewrite the types *) @@ -92,26 +85,21 @@ let rec transf_expr env ctx e = if is_composite_type env e.etyp then transf_composite_call env ctx None fn args e.etyp else - {edesc = ECall(transf_expr env Val fn, List.map (transf_arg env) args); + {edesc = ECall(transf_expr env Val fn, + List.map (transf_expr env Val) args); etyp = newty} -(* Function arguments: pass by reference those having composite type *) - -and transf_arg env e = - let e' = transf_expr env Val e in - if is_composite_type env e'.etyp then eaddrof e' else e' - (* Function calls returning a composite: add first argument. - ctx = Effects: lv = f(...) -> f(&lv, ...) + ctx = Effects: lv = f(...) -> f(&lv, ...) [copy optimization] f(...) -> f(&newtemp, ...) - ctx = Val: lv = f(...) -> f(&newtemp, ...), lv = newtemp, newtemp + ctx = Val: lv = f(...) -> f(&newtemp, ...), lv = newtemp f(...) -> f(&newtemp, ...), newtemp *) and transf_composite_call env ctx opt_lhs fn args ty = let ty = transf_type env ty in let fn = transf_expr env Val fn in - let args = List.map (transf_arg env) args in + let args = List.map (transf_expr env Val) args in match ctx, opt_lhs with | Effects, None -> let tmp = new_temp ~name:"_res" ty in @@ -125,54 +113,14 @@ and transf_composite_call env ctx opt_lhs fn args ty = | Val, Some lhs -> let lhs = transf_expr env Val lhs in let tmp = new_temp ~name:"_res" ty in - ecomma (ecomma {edesc = ECall(fn, eaddrof tmp :: args); etyp = TVoid []} - (eassign lhs tmp)) - tmp - -(* The transformation above can create ill-formed lhs containing ",", as in - f().x = y ---> (f(&tmp), tmp).x = y - f(g(x)); ---> f(&(g(&tmp),tmp)) - We fix this by floating the "," above the lhs, up to the nearest enclosing - rhs: - f().x = y ---> (f(&tmp), tmp).x = y --> f(&tmp), tmp.x = y - f(g(x)); ---> f(&(g(&tmp),tmp)) --> f((g(&tmp), &tmp)) -*) - -let rec float_comma e = - match e.edesc with - | EConst c -> e - | ESizeof ty -> e - | EVar x -> e - (* lvalue-consuming unops *) - | EUnop((Oaddrof|Opreincr|Opredecr|Opostincr|Opostdecr|Odot _) as op, - {edesc = EBinop(Ocomma, e1, e2, _)}) -> - ecomma (float_comma e1) - (float_comma {edesc = EUnop(op, e2); etyp = e.etyp}) - (* lvalue-consuming binops *) - | EBinop((Oassign|Oadd_assign|Osub_assign|Omul_assign|Odiv_assign - |Omod_assign|Oand_assign|Oor_assign|Oxor_assign - |Oshl_assign|Oshr_assign) as op, - {edesc = EBinop(Ocomma, e1, e2, _)}, e3, tyres) -> - ecomma (float_comma e1) - (float_comma {edesc = EBinop(op, e2, e3, tyres); etyp = e.etyp}) - (* other expressions *) - | EUnop(op, e1) -> - {edesc = EUnop(op, float_comma e1); etyp = e.etyp} - | EBinop(op, e1, e2, tyres) -> - {edesc = EBinop(op, float_comma e1, float_comma e2, tyres); etyp = e.etyp} - | EConditional(e1, e2, e3) -> - {edesc = EConditional(float_comma e1, float_comma e2, float_comma e3); - etyp = e.etyp} - | ECast(ty, e1) -> - {edesc = ECast(ty, float_comma e1); etyp = e.etyp} - | ECall(e1, el) -> - {edesc = ECall(float_comma e1, List.map float_comma el); etyp = e.etyp} + ecomma {edesc = ECall(fn, eaddrof tmp :: args); etyp = TVoid []} + (eassign lhs tmp) (* Initializers *) let rec transf_init env = function | Init_single e -> - Init_single (float_comma(transf_expr env Val e)) + Init_single (transf_expr env Val e) | Init_array il -> Init_array (List.map (transf_init env) il) | Init_struct(id, fil) -> @@ -190,7 +138,7 @@ let transf_decl env (sto, id, ty, init) = let transf_funbody env body optres = -let transf_expr ctx e = float_comma(transf_expr env ctx e) in +let transf_expr ctx e = transf_expr env ctx e in (* Function returns: if return type is struct or union, return x -> _res = x; return @@ -239,33 +187,11 @@ let rec transf_stmt s = in transf_stmt body -let transf_params loc env params = - let rec transf_prm = function - | [] -> - ([], [], sskip) - | (id, ty) :: params -> - let ty = transf_type env ty in - if is_composite_type env ty then begin - let id' = Env.fresh_ident id.name in - let ty' = TPtr(add_attributes_type [AConst] ty, []) in - let (params', decls, init) = transf_prm params in - ((id', ty') :: params', - (Storage_default, id, ty, None) :: decls, - sseq loc - (sassign loc {edesc = EVar id; etyp = ty} - {edesc = EUnop(Oderef, {edesc = EVar id'; etyp = ty'}); - etyp = ty}) - init) - end else begin - let (params', decls, init) = transf_prm params in - ((id, ty) :: params', decls, init) - end - in transf_prm params - let transf_fundef env f = reset_temps(); let ret = transf_type env f.fd_ret in - let (params, newdecls, init) = transf_params f.fd_body.sloc env f.fd_params in + let params = + List.map (fun (id, ty) -> (id, transf_type env ty)) f.fd_params in let (ret1, params1, body1) = if is_composite_type env ret then begin let vres = Env.fresh_ident "_res" in @@ -277,10 +203,9 @@ let transf_fundef env f = transf_funbody env f.fd_body (Some eeres)) end else (ret, params, transf_funbody env f.fd_body None) in - let body2 = sseq body1.sloc init body1 in let temps = get_temps() in {f with fd_ret = ret1; fd_params = params1; - fd_locals = newdecls @ f.fd_locals @ temps; fd_body = body2} + fd_locals = f.fd_locals @ temps; fd_body = body1} (* Composites *) diff --git a/cparser/StructByValue.mli b/cparser/StructReturn.mli index 45899a4..45899a4 100644 --- a/cparser/StructByValue.mli +++ b/cparser/StructReturn.mli diff --git a/driver/Clflags.ml b/driver/Clflags.ml index cb26b72..95f4209 100644 --- a/driver/Clflags.ml +++ b/driver/Clflags.ml @@ -17,12 +17,10 @@ let linker_options = ref ([]: string list) let exe_name = ref "a.out" let option_flonglong = ref true let option_flongdouble = ref false -let option_fstruct_passing = ref false -let option_fstruct_assign = ref false +let option_fstruct_return = ref false let option_fbitfields = ref false let option_fvararg_calls = ref true let option_fpacked_structs = ref false -let option_fvolatile_rmw = ref true let option_fmadd = ref false let option_fsse = ref true let option_dparse = ref false diff --git a/driver/Compiler.v b/driver/Compiler.v index ce9db20..6779aaf 100644 --- a/driver/Compiler.v +++ b/driver/Compiler.v @@ -400,7 +400,7 @@ Theorem transf_cstrategy_program_correct: forall p tp, transf_c_program p = OK tp -> forward_simulation (Cstrategy.semantics p) (Asm.semantics tp) - * backward_simulation (Cstrategy.semantics p) (Asm.semantics tp). + * backward_simulation (atomic (Cstrategy.semantics p)) (Asm.semantics tp). Proof. intros. assert (F: forward_simulation (Cstrategy.semantics p) (Asm.semantics tp)). @@ -411,8 +411,9 @@ Proof. exact (fst (transf_clight_program_correct _ _ EQ1)). split. auto. - apply forward_to_backward_simulation. auto. - apply Cstrategy.semantics_receptive. + apply forward_to_backward_simulation. + apply factor_forward_simulation. auto. eapply sd_traces. eapply Asm.semantics_determinate. + apply atomic_receptive. apply Cstrategy.semantics_strongly_receptive. apply Asm.semantics_determinate. Qed. @@ -422,7 +423,11 @@ Theorem transf_c_program_correct: backward_simulation (Csem.semantics p) (Asm.semantics tp). Proof. intros. - eapply compose_backward_simulation. + apply compose_backward_simulation with (atomic (Cstrategy.semantics p)). + eapply sd_traces; eapply Asm.semantics_determinate. + apply factor_backward_simulation. apply Cstrategy.strategy_simulation. + apply Csem.semantics_single_events. + eapply ssr_well_behaved; eapply Cstrategy.semantics_strongly_receptive. exact (snd (transf_cstrategy_program_correct _ _ H)). Qed. diff --git a/driver/Complements.v b/driver/Complements.v index 1b7e974..57351a2 100644 --- a/driver/Complements.v +++ b/driver/Complements.v @@ -78,15 +78,21 @@ Theorem transf_cstrategy_program_preservation: program_behaves (Asm.semantics tp) beh -> program_behaves (Cstrategy.semantics p) beh). Proof. + assert (WBT: forall p, well_behaved_traces (Cstrategy.semantics p)). + intros. eapply ssr_well_behaved. apply Cstrategy.semantics_strongly_receptive. intros. intuition. eapply forward_simulation_behavior_improves; eauto. apply (fst (transf_cstrategy_program_correct _ _ H)). - eapply backward_simulation_behavior_improves; eauto. + exploit backward_simulation_behavior_improves. apply (snd (transf_cstrategy_program_correct _ _ H)). + eauto. + intros [beh1 [A B]]. exists beh1; split; auto. rewrite atomic_behaviors; auto. eapply forward_simulation_same_safe_behavior; eauto. apply (fst (transf_cstrategy_program_correct _ _ H)). - eapply backward_simulation_same_safe_behavior; eauto. + exploit backward_simulation_same_safe_behavior. apply (snd (transf_cstrategy_program_correct _ _ H)). + intros. rewrite <- atomic_behaviors in H2; eauto. eauto. + intros. rewrite atomic_behaviors; auto. Qed. (** We can also use the alternate big-step semantics for [Cstrategy] diff --git a/driver/Driver.ml b/driver/Driver.ml index cee6250..9813939 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -69,11 +69,9 @@ let parse_c_file sourcename ifile = (* Simplification options *) let simplifs = "b" (* blocks: mandatory *) - ^ (if !option_fstruct_passing then "s" else "") - ^ (if !option_fstruct_assign then "S" else "") + ^ (if !option_fstruct_return then "s" else "") ^ (if !option_fbitfields then "f" else "") ^ (if !option_fpacked_structs then "p" else "") - ^ (if !option_fvolatile_rmw then "v" else "") in (* Parsing and production of a simplified C AST *) let ast = @@ -333,10 +331,8 @@ 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-passing Emulate passing structs and unions by value [off] - -fstruct-assign Emulate assignment between structs or unions [off] + -fstruct-return Emulate returning structs and unions by value [off] -fvararg-calls Emulate calls to variable-argument functions [on] - -fvolatile-rmw Emulate ++, -- and op= on volatile l-values [on] -fpacked-structs Emulate packed structs [off] -fall Activate all language support options above -fnone Turn off all language support options above @@ -374,9 +370,8 @@ Interpreter mode: " let language_support_options = [ - option_fbitfields; option_flonglong; option_flongdouble; option_fstruct_passing; - option_fstruct_assign; option_fvararg_calls; option_fpacked_structs; - option_fvolatile_rmw + option_fbitfields; option_flonglong; option_flongdouble; + option_fstruct_return; option_fvararg_calls; option_fpacked_structs ] let cmdline_actions = @@ -434,14 +429,12 @@ let cmdline_actions = ] @ f_opt "longlong" option_flonglong @ f_opt "longdouble" option_flongdouble - @ f_opt "struct-passing" option_fstruct_passing - @ f_opt "struct-assign" option_fstruct_assign + @ f_opt "struct-return" option_fstruct_return @ f_opt "bitfields" option_fbitfields @ f_opt "vararg-calls" option_fvararg_calls @ f_opt "madd" option_fmadd @ f_opt "packed-structs" option_fpacked_structs @ f_opt "sse" option_fsse - @ f_opt "volatile-rmw" option_fvolatile_rmw let _ = Gc.set { (Gc.get()) with Gc.minor_heap_size = 524288 }; diff --git a/driver/Interp.ml b/driver/Interp.ml index a1e01f0..50e512b 100644 --- a/driver/Interp.ml +++ b/driver/Interp.ml @@ -113,12 +113,15 @@ let print_state prog p = function | Returnstate(res, k, m) -> fprintf p "returning@ %a" print_val res + | Stuckstate -> + fprintf p "stuck after an undefined expression" let mem_of_state = function | State(f, s, k, e, m) -> m | ExprState(f, r, k, e, m) -> m | Callstate(fd, args, k, m) -> m | Returnstate(res, k, m) -> m + | Stuckstate -> assert false (* Comparing memory states *) @@ -211,6 +214,7 @@ let rank_state = function | ExprState _ -> 1 | Callstate _ -> 2 | Returnstate _ -> 3 + | Stuckstate -> 4 let compare_state s1 s2 = if s1 == s2 then 0 else @@ -382,16 +386,17 @@ let do_step p prog ge time s = exit (Int32.to_int (camlint_of_coqint r)) end | None -> - match Cexec.do_step ge world s with - | [] -> - if !trace = 1 then - fprintf p "@[<hov 2>Time %d: %a@]@." time (print_state prog) s; - fprintf p "ERROR: Undefined behavior@."; - fprintf p "@]."; - exit 126 - | l -> - List.iter (fun (t, s') -> do_events p ge time s t) l; - List.map snd l + let l = Cexec.do_step ge world s in + if l = [] || List.exists (fun (t,s) -> s = Stuckstate) l then begin + if !trace = 1 then + fprintf p "@[<hov 2>Time %d: %a@]@." time (print_state prog) s; + fprintf p "ERROR: Undefined behavior@."; + fprintf p "@]."; + exit 126 + end else begin + List.iter (fun (t, s') -> do_events p ge time s t) l; + List.map snd l + end let rec explore p prog ge time ss = let succs = @@ -415,14 +420,13 @@ let unvolatile prog = {prog with prog_vars = List.map unvolatile_globvar prog.prog_vars} let change_main_function p old_main old_main_ty = - let tint = Tint(I32, Signed) in let old_main = Evalof(Evar(old_main, old_main_ty), old_main_ty) in - let arg1 = Eval(Vint(coqint_of_camlint 0l), tint) in + let arg1 = Eval(Vint(coqint_of_camlint 0l), type_int32s) in let arg2 = arg1 in let body = - Sreturn(Some(Ecall(old_main, Econs(arg1, Econs(arg2, Enil)), tint))) in + Sreturn(Some(Ecall(old_main, Econs(arg1, Econs(arg2, Enil)), type_int32s))) in let new_main_fn = - { fn_return = tint; fn_params = []; fn_vars = []; fn_body = body } in + { fn_return = type_int32s; fn_params = []; fn_vars = []; fn_body = body } in let new_main_id = intern_string "___main" in { p with prog_main = new_main_id; @@ -431,9 +435,9 @@ let change_main_function p old_main old_main_ty = let fixup_main p = try match type_of_fundef (List.assoc p.prog_main p.prog_funct) with - | Tfunction(Tnil, Tint(I32, Signed)) -> + | Tfunction(Tnil, Tint(I32, Signed, _)) -> Some p - | Tfunction(Tcons(Tint _, Tcons(Tpointer(Tpointer(Tint(I8,_))), Tnil)), + | Tfunction(Tcons(Tint _, Tcons(Tpointer(Tpointer(Tint(I8,_,_),_),_), Tnil)), Tint _) as ty -> Some (change_main_function p p.prog_main ty) | _ -> @@ -848,7 +848,7 @@ Ltac Equalities := exploit external_call_determ. eexact H3. eexact H8. intros [A B]. split. auto. intros. destruct B; auto. subst. auto. (* trace length *) - inv H; simpl. + red; intros; inv H; simpl. omega. eapply external_call_trace_length; eauto. eapply external_call_trace_length; eauto. diff --git a/ia32/SelectOp.vp b/ia32/SelectOp.vp index 71dc83b..98db388 100644 --- a/ia32/SelectOp.vp +++ b/ia32/SelectOp.vp @@ -62,6 +62,21 @@ Definition addrstack (ofs: int) := Definition notint (e: expr) := Eop (Oxorimm Int.mone) (e ::: Enil). +(** ** Boolean value and boolean negation *) + +Fixpoint boolval (e: expr) {struct e} : expr := + let default := Eop (Ocmp (Ccompuimm Cne Int.zero)) (e ::: Enil) in + match e with + | Eop (Ointconst n) Enil => + Eop (Ointconst (if Int.eq n Int.zero then Int.zero else Int.one)) Enil + | Eop (Ocmp cond) args => + Eop (Ocmp cond) args + | Econdition e1 e2 e3 => + Econdition e1 (boolval e2) (boolval e3) + | _ => + default + end. + (** ** Boolean negation *) Fixpoint notbool (e: expr) {struct e} : expr := diff --git a/ia32/SelectOpproof.v b/ia32/SelectOpproof.v index f14b6a9..e6fd809 100644 --- a/ia32/SelectOpproof.v +++ b/ia32/SelectOpproof.v @@ -138,6 +138,31 @@ Proof. unfold notint; red; intros. TrivialExists. Qed. +Theorem eval_boolval: unary_constructor_sound boolval Val.boolval. +Proof. + assert (DFL: + forall le a x, + eval_expr ge sp e m le a x -> + exists v, eval_expr ge sp e m le (Eop (Ocmp (Ccompuimm Cne Int.zero)) (a ::: Enil)) v + /\ Val.lessdef (Val.boolval x) v). + intros. TrivialExists. simpl. destruct x; simpl; auto. + + red. induction a; simpl; intros; eauto. destruct o; eauto. +(* intconst *) + destruct e0; eauto. InvEval. TrivialExists. simpl. destruct (Int.eq i Int.zero); auto. +(* cmp *) + inv H. simpl in H5. + destruct (eval_condition c vl m) as []_eqn. + TrivialExists. simpl. inv H5. rewrite Heqo. destruct b; auto. + simpl in H5. inv H5. + exists Vundef; split; auto. EvalOp; simpl. rewrite Heqo; auto. + +(* condition *) + inv H. destruct v1. + exploit IHa1; eauto. intros [v [A B]]. exists v; split; auto. eapply eval_Econdition; eauto. + exploit IHa2; eauto. intros [v [A B]]. exists v; split; auto. eapply eval_Econdition; eauto. +Qed. + Theorem eval_notbool: unary_constructor_sound notbool Val.notbool. Proof. assert (DFL: diff --git a/powerpc/Asm.v b/powerpc/Asm.v index 7174f79..2d71ca9 100644 --- a/powerpc/Asm.v +++ b/powerpc/Asm.v @@ -508,12 +508,6 @@ Definition compare_float (rs: regset) (v1 v2: val) := #CR0_2 <- (Val.cmpf Ceq v1 v2) #CR0_3 <- Vundef. -Definition val_cond_reg (rs: regset) := - Val.or (Val.shl rs#CR0_0 (Vint (Int.repr 31))) - (Val.or (Val.shl rs#CR0_1 (Vint (Int.repr 30))) - (Val.or (Val.shl rs#CR0_2 (Vint (Int.repr 29))) - (Val.shl rs#CR0_3 (Vint (Int.repr 28))))). - (** Execution of a single instruction [i] in initial state [rs] and [m]. Return updated state. For instructions that correspond to actual PowerPC instructions, the cases are @@ -968,7 +962,7 @@ Ltac Equalities := exploit external_call_determ. eexact H3. eexact H8. intros [A B]. split. auto. intros. destruct B; auto. subst. auto. (* trace length *) - inv H; simpl. + red; intros. inv H; simpl. omega. eapply external_call_trace_length; eauto. eapply external_call_trace_length; eauto. diff --git a/powerpc/PrintAsm.ml b/powerpc/PrintAsm.ml index e566e3c..f6c1c49 100644 --- a/powerpc/PrintAsm.ml +++ b/powerpc/PrintAsm.ml @@ -202,8 +202,8 @@ let name_of_section_MacOS = function let name_of_section_Linux = function | Section_text -> ".text" - | Section_data i -> ".data" (*if i then ".data" else ".bss"*) - | Section_small_data i -> ".sdata" (*if i then ".sdata" else ".sbss"*) + | Section_data i -> if i then ".data" else "COMM" + | Section_small_data i -> if i then ".sdata" else "COMM" | Section_const -> ".rodata" | Section_small_const -> ".sdata2" | Section_string -> ".rodata" @@ -238,7 +238,9 @@ let name_of_section = | Diab -> name_of_section_Diab let section oc sec = - fprintf oc " %s\n" (name_of_section sec) + let name = name_of_section sec in + assert (name <> "COMM"); + fprintf oc " %s\n" name (* Encoding masks for rlwinm instructions *) @@ -663,8 +665,8 @@ let print_instruction oc = function | Plwzx(r1, r2, r3) -> fprintf oc " lwzx %a, %a, %a\n" ireg r1 ireg r2 ireg r3 | Pmfcrbit(r1, bit) -> - fprintf oc " mfcr %a\n" ireg GPR12; - fprintf oc " rlwinm %a, %a, %d, 31, 31\n" ireg r1 ireg GPR12 (1 + num_crbit bit) + fprintf oc " mfcr %a\n" ireg r1; + fprintf oc " rlwinm %a, %a, %d, 31, 31\n" ireg r1 ireg r1 (1 + num_crbit bit) | Pmflr(r1) -> fprintf oc " mflr %a\n" ireg r1 | Pmr(r1, r2) -> @@ -1012,21 +1014,32 @@ let print_var oc (name, v) = let init = match v.gvar_init with [Init_space _] -> false | _ -> true in let sec = - Sections.section_for_variable name init - and align = + Sections.section_for_variable name init in + let align = match C2C.atom_alignof name with | Some a -> log2 a - | None -> 3 (* 8-alignment is a safe default *) - in - section oc sec; - fprintf oc " .align %d\n" align; - if not (C2C.atom_is_static name) then - fprintf oc " .globl %a\n" symbol name; - fprintf oc "%a:\n" symbol name; - print_init_data oc name v.gvar_init; - if target <> MacOS then begin - fprintf oc " .type %a, @object\n" symbol name; - fprintf oc " .size %a, . - %a\n" symbol name symbol name + | None -> 3 in (* 8-alignment is a safe default *) + let name_sec = + name_of_section sec in + if name_sec <> "COMM" then begin + fprintf oc " %s\n" name_sec; + fprintf oc " .align %d\n" align; + if not (C2C.atom_is_static name) then + fprintf oc " .globl %a\n" symbol name; + fprintf oc "%a:\n" symbol name; + print_init_data oc name v.gvar_init; + if target <> MacOS then begin + fprintf oc " .type %a, @object\n" symbol name; + fprintf oc " .size %a, . - %a\n" symbol name symbol name + end + end else begin + let sz = + match v.gvar_init with [Init_space sz] -> sz | _ -> assert false in + fprintf oc " %s %a, %ld, %d\n" + (if C2C.atom_is_static name then ".lcomm" else ".comm") + symbol name + (camlint_of_coqint sz) + (1 lsl align) end let print_program oc p = diff --git a/powerpc/SelectOp.vp b/powerpc/SelectOp.vp index 3bb5544..08968f7 100644 --- a/powerpc/SelectOp.vp +++ b/powerpc/SelectOp.vp @@ -69,7 +69,20 @@ Nondetfunction notint (e: expr) := | _ => Elet e (Eop Onor (Eletvar O ::: Eletvar O ::: Enil)) end. -(** ** Boolean negation *) +(** ** Boolean value and boolean negation *) + +Fixpoint boolval (e: expr) {struct e} : expr := + let default := Eop (Ocmp (Ccompuimm Cne Int.zero)) (e ::: Enil) in + match e with + | Eop (Ointconst n) Enil => + Eop (Ointconst (if Int.eq n Int.zero then Int.zero else Int.one)) Enil + | Eop (Ocmp cond) args => + Eop (Ocmp cond) args + | Econdition e1 e2 e3 => + Econdition e1 (boolval e2) (boolval e3) + | _ => + default + end. Fixpoint notbool (e: expr) {struct e} : expr := let default := Eop (Ocmp (Ccompuimm Ceq Int.zero)) (e ::: Enil) in diff --git a/powerpc/SelectOpproof.v b/powerpc/SelectOpproof.v index cc14d33..59f2a41 100644 --- a/powerpc/SelectOpproof.v +++ b/powerpc/SelectOpproof.v @@ -148,6 +148,31 @@ Proof. simpl. destruct x; simpl; auto. rewrite Int.or_idem. auto. Qed. +Theorem eval_boolval: unary_constructor_sound boolval Val.boolval. +Proof. + assert (DFL: + forall le a x, + eval_expr ge sp e m le a x -> + exists v, eval_expr ge sp e m le (Eop (Ocmp (Ccompuimm Cne Int.zero)) (a ::: Enil)) v + /\ Val.lessdef (Val.boolval x) v). + intros. TrivialExists. simpl. destruct x; simpl; auto. + + red. induction a; simpl; intros; eauto. destruct o; eauto. +(* intconst *) + destruct e0; eauto. InvEval. TrivialExists. simpl. destruct (Int.eq i Int.zero); auto. +(* cmp *) + inv H. simpl in H5. + destruct (eval_condition c vl m) as []_eqn. + TrivialExists. simpl. inv H5. rewrite Heqo. destruct b; auto. + simpl in H5. inv H5. + exists Vundef; split; auto. EvalOp; simpl. rewrite Heqo; auto. + +(* condition *) + inv H. destruct v1. + exploit IHa1; eauto. intros [v [A B]]. exists v; split; auto. eapply eval_Econdition; eauto. + exploit IHa2; eauto. intros [v [A B]]. exists v; split; auto. eapply eval_Econdition; eauto. +Qed. + Theorem eval_notbool: unary_constructor_sound notbool Val.notbool. Proof. assert (DFL: diff --git a/test/raytracer/Makefile b/test/raytracer/Makefile index db359b1..a4b8894 100644 --- a/test/raytracer/Makefile +++ b/test/raytracer/Makefile @@ -1,7 +1,7 @@ include ../../Makefile.config CC=../../ccomp -CFLAGS=-stdlib ../../runtime -dparse -dclight -dasm -fstruct-passing -fstruct-assign +CFLAGS=-stdlib ../../runtime -dparse -dclight -dasm -fstruct-return LIBS=$(LIBMATH) TIME=xtime -mintime 2.0 diff --git a/test/regression/Makefile b/test/regression/Makefile index f3dcf4d..e9d0318 100644 --- a/test/regression/Makefile +++ b/test/regression/Makefile @@ -12,7 +12,7 @@ TESTS=attribs1 bitfields1 bitfields2 bitfields3 bitfields4 \ expr1 expr6 initializers volatile1 volatile2 volatile3 \ funct3 expr5 struct7 struct8 struct11 casts1 casts2 char1 \ sizeof1 sizeof2 packedstruct1 packedstruct2 \ - instrsel + instrsel bool # Other tests: should compile to .s without errors (but expect warnings) EXTRAS=annot1 commaprec expr2 expr3 expr4 extern1 funct2 funptr1 init1 \ diff --git a/test/regression/Results/bool b/test/regression/Results/bool new file mode 100644 index 0000000..923c6e2 --- /dev/null +++ b/test/regression/Results/bool @@ -0,0 +1,9 @@ +a = 1 +b = 0 +c = 1 +d = 0 +e = 1 +f = 0 +g = 1 +h = 1 +i = 0 diff --git a/test/regression/bool.c b/test/regression/bool.c new file mode 100644 index 0000000..d2b3857 --- /dev/null +++ b/test/regression/bool.c @@ -0,0 +1,29 @@ +/* Testing _Bool type support */ + +#include <stdio.h> + +int x = 42; + +int main() +{ + _Bool a, b, c, d, e, f, g, h, i; + a = x; + b = x >= 100; + c = &x; + d = a && b; + e = a || b; + f = a & b; + g = a | b; + h = 3.14; + i = 0.0; + printf("a = %d\n", a); + printf("b = %d\n", b); + printf("c = %d\n", c); + printf("d = %d\n", d); + printf("e = %d\n", e); + printf("f = %d\n", f); + printf("g = %d\n", g); + printf("h = %d\n", h); + printf("i = %d\n", i); + return 0; +} diff --git a/test/spass/Makefile b/test/spass/Makefile index 536488b..6797475 100644 --- a/test/spass/Makefile +++ b/test/spass/Makefile @@ -1,7 +1,7 @@ include ../../Makefile.config CC=../../ccomp -CFLAGS=-stdlib ../../runtime -dparse -dclight -dasm -fstruct-passing -fstruct-assign +CFLAGS=-stdlib ../../runtime -dparse -dclight -dasm -fstruct-return SRCS=analyze.c clause.c clock.c closure.c cnf.c component.c \ condensing.c context.c defs.c dfgparser.c dfgscanner.c doc-proof.c \ |