diff options
73 files changed, 4440 insertions, 2612 deletions
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index fea5e5c8..72125292 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -220,8 +220,7 @@ build_rv64: - make -j "$NJOBS" - make -C test SIMU='qemu-riscv64 -L /usr/riscv64-linux-gnu' EXECUTE='qemu-riscv64 -L /usr/riscv64-linux-gnu' all test - ulimit -s65536 && make -C test/monniaux/yarpgen TARGET_CC='riscv64-linux-gnu-gcc' EXECUTE='qemu-riscv64 -L /usr/riscv64-linux-gnu' - # disabled until https://github.com/AbsInt/CompCert/issues/412 is fixed - # - ulimit -s65536 && make -C test/monniaux/csmith TARGET_CC='riscv64-linux-gnu-gcc' EXECUTE='timeout 10s qemu-riscv64 -L /usr/riscv64-linux-gnu' CCOMPOPTS='-static' TARGET_CFLAGS='-static' + - ulimit -s65536 && make -C test/monniaux/csmith TARGET_CC='riscv64-linux-gnu-gcc' EXECUTE='timeout 10s qemu-riscv64 -L /usr/riscv64-linux-gnu' CCOMPOPTS='-static' TARGET_CFLAGS='-static' rules: - if: '$CI_COMMIT_BRANCH == "kvx-work"' when: always @@ -1,3 +1,7 @@ +Coq development: +- Updated the Flocq library to version 3.4.2. + + Release 3.9, 2021-05-10 ======================= diff --git a/Makefile.extr b/Makefile.extr index d7c40cd4..b478e64b 100644 --- a/Makefile.extr +++ b/Makefile.extr @@ -51,9 +51,7 @@ INCLUDES=$(patsubst %,-I %, $(DIRS)) # Control of warnings: -# WARNINGS=-w +a-4-9-27-42 -strict-sequence -safe-string -warn-error +a #Deprication returns with ocaml 4.03 -WARNINGS=-w +a-4-9-27-42-70-69 # 70,69 for OCaml 4.13 - +WARNINGS=-w +a-4-9-27-70-42 extraction/%.cmx: WARNINGS +=-w -20-27-32..34-39-41-44..45-60-67 extraction/%.cmo: WARNINGS +=-w -20-27-32..34-39-41-44..45-60-67 cparser/pre_parser.cmx: WARNINGS += -w -41 diff --git a/MenhirLib/Alphabet.v b/MenhirLib/Alphabet.v index 530e3b4a..cd849761 100644 --- a/MenhirLib/Alphabet.v +++ b/MenhirLib/Alphabet.v @@ -11,7 +11,7 @@ (* *) (****************************************************************************) -From Coq Require Import Omega List Relations RelationClasses. +From Coq Require Import ZArith List Relations RelationClasses. Import ListNotations. Local Obligation Tactic := intros. diff --git a/aarch64/Asmexpand.ml b/aarch64/Asmexpand.ml index 68884550..eb9ec600 100644 --- a/aarch64/Asmexpand.ml +++ b/aarch64/Asmexpand.ml @@ -185,15 +185,15 @@ let memcpy_small_arg sz arg tmp = | BA_addrstack ofs -> if offset_in_range ofs && offset_in_range (Ptrofs.add ofs (Ptrofs.repr (Z.of_uint sz))) - && (Z.to_int ofs) mod 8 = 0 + && Int64.rem (Z.to_int64 ofs) 8L = 0L then (XSP, ofs) else begin expand_addimm64 (RR1 tmp) XSP ofs; (RR1 tmp, _0) end | _ -> assert false let expand_builtin_memcpy_small sz al src dst = - let (tsrc, tdst) = - if dst <> BA (DR(IR(RR1 X17))) then (X17, X29) else (X29, X17) in + let tsrc = if dst <> BA (DR(IR(RR1 X17))) then X17 else X29 in + let tdst = if src <> BA (DR(IR(RR1 X29))) then X29 else X17 in let (rsrc, osrc) = memcpy_small_arg sz src tsrc in let (rdst, odst) = memcpy_small_arg sz dst tdst in let rec copy osrc odst sz = diff --git a/arm/Asmexpand.ml b/arm/Asmexpand.ml index 629d0fcc..b81ae74b 100644 --- a/arm/Asmexpand.ml +++ b/arm/Asmexpand.ml @@ -111,8 +111,8 @@ let memcpy_small_arg sz arg tmp = assert false let expand_builtin_memcpy_small sz al src dst = - let (tsrc, tdst) = - if dst <> BA (IR IR2) then (IR2, IR3) else (IR3, IR2) in + let tsrc = if dst <> BA (IR IR2) then IR2 else IR3 in + let tdst = if src <> BA (IR IR3) then IR3 else IR2 in let (rsrc, osrc) = memcpy_small_arg sz src tsrc in let (rdst, odst) = memcpy_small_arg sz dst tdst in let rec copy osrc odst sz = diff --git a/arm/Asmgenproof1.v b/arm/Asmgenproof1.v index 7a707f32..729ddb4f 100644 --- a/arm/Asmgenproof1.v +++ b/arm/Asmgenproof1.v @@ -1218,7 +1218,7 @@ Proof. split. unfold rs2; Simpl. unfold rs1; Simpl. unfold Val.shr, Val.shl; destruct (rs x0); auto. change (Int.ltu (Int.repr 24) Int.iwordsize) with true; simpl. - f_equal. symmetry. apply (Int.sign_ext_shr_shl 8). compute; auto. + f_equal. symmetry. apply (Int.sign_ext_shr_shl 8). compute; intuition congruence. intros. unfold rs2, rs1; Simpl. (* Ocast16signed *) destruct Archi.thumb2_support. @@ -1231,7 +1231,7 @@ Proof. split. unfold rs2; Simpl. unfold rs1; Simpl. unfold Val.shr, Val.shl; destruct (rs x0); auto. change (Int.ltu (Int.repr 16) Int.iwordsize) with true; simpl. - f_equal. symmetry. apply (Int.sign_ext_shr_shl 16). compute; auto. + f_equal. symmetry. apply (Int.sign_ext_shr_shl 16). compute; intuition congruence. intros. unfold rs2, rs1; Simpl. (* Oaddimm *) generalize (addimm_correct x x0 i k rs m). diff --git a/backend/IRC.ml b/backend/IRC.ml index 29d224c8..d9e4651e 100644 --- a/backend/IRC.ml +++ b/backend/IRC.ml @@ -34,8 +34,8 @@ type node = { ident: int; (*r unique identifier *) typ: typ; (*r its type *) var: var; (*r the XTL variable it comes from *) - mutable regclass: int; (*r identifier of register class *) - mutable accesses: int; (*r number of defs and uses *) + regclass: int; (*r identifier of register class *) + accesses: int; (*r number of defs and uses *) mutable spillcost: float; (*r estimated cost of spilling *) mutable adjlist: node list; (*r all nodes it interferes with *) mutable degree: int; (*r number of adjacent nodes *) @@ -207,7 +207,7 @@ type graph = { varTable: (var, node) Hashtbl.t; mutable nextIdent: int; (* The adjacency set *) - mutable adjSet: unit IntPairs.t; + adjSet: unit IntPairs.t; (* Low-degree, non-move-related nodes *) simplifyWorklist: DLinkNode.t; (* Low-degree, move-related nodes *) diff --git a/backend/Inlining.v b/backend/Inlining.v index 0e18d38e..317c288c 100644 --- a/backend/Inlining.v +++ b/backend/Inlining.v @@ -293,10 +293,13 @@ Inductive inline_decision (ros: reg + ident) : Type := | Cannot_inline | Can_inline (id: ident) (f: function) (P: ros = inr reg id) (Q: fenv!id = Some f). +Arguments Cannot_inline {ros}. +Arguments Can_inline {ros}. + Program Definition can_inline (ros: reg + ident): inline_decision ros := match ros with - | inl r => Cannot_inline _ - | inr id => match fenv!id with Some f => Can_inline _ id f _ _ | None => Cannot_inline _ end + | inl r => Cannot_inline + | inr id => match fenv!id with Some f => Can_inline id f _ _ | None => Cannot_inline end end. (** Inlining of a call to function [f]. An appropriate context is diff --git a/cfrontend/C2C.ml b/cfrontend/C2C.ml index bab58244..502108f8 100644 --- a/cfrontend/C2C.ml +++ b/cfrontend/C2C.ml @@ -267,22 +267,6 @@ let builtins_generic = { (TVoid [], [TPtr(TVoid [], [])], false); - "__compcert_va_int32", - (TInt(IUInt, []), - [TPtr(TVoid [], [])], - false); - "__compcert_va_int64", - (TInt(IULongLong, []), - [TPtr(TVoid [], [])], - false); - "__compcert_va_float64", - (TFloat(FDouble, []), - [TPtr(TVoid [], [])], - false); - "__compcert_va_composite", - (TPtr(TVoid [], []), - [TPtr(TVoid [], []); TInt(IULong, [])], - false); (* Optimization hints *) "__builtin_unreachable", (TVoid [], [], false); @@ -650,7 +634,7 @@ let checkFunctionType env tres targs = end end -let rec convertTyp env t = +let rec convertTyp env ?bitwidth t = match t with | C.TVoid a -> Tvoid | C.TInt(ik, a) -> @@ -681,7 +665,21 @@ let rec convertTyp env t = | C.TUnion(id, a) -> Tunion(intern_string id.name, convertAttr a) | C.TEnum(id, a) -> - convertIkind Cutil.enum_ikind (convertAttr a) + let ik = + match bitwidth with + | None -> Cutil.enum_ikind + | Some w -> + let info = Env.find_enum env id in + let representable sg = + List.for_all (fun (_, v, _) -> Cutil.int_representable v w sg) + info.Env.ei_members in + if representable false then + Cutil.unsigned_ikind_of Cutil.enum_ikind + else if representable true then + Cutil.signed_ikind_of Cutil.enum_ikind + else + Cutil.enum_ikind in + convertIkind ik (convertAttr a) and convertParams env = function | [] -> Tnil @@ -717,9 +715,16 @@ let rec convertTypAnnotArgs env = function convertTypAnnotArgs env el) let convertField env f = - if f.fld_bitfield <> None then - unsupported "bit field in struct or union (consider adding option [-fbitfields])"; - (intern_string f.fld_name, convertTyp env f.fld_typ) + let id = intern_string f.fld_name + and ty = convertTyp env ?bitwidth: f.fld_bitfield f.fld_typ in + match f.fld_bitfield with + | None -> Member_plain(id, ty) + | Some w -> + match ty with + | Tint(sz, sg, attr) -> + Member_bitfield(id, sz, sg, attr, Z.of_uint w, f.fld_name = "") + | _ -> + fatal_error "bitfield must have type int" let convertCompositedef env su id attr members = if Cutil.find_custom_attributes ["packed";"__packed__"] attr <> [] then @@ -822,6 +827,11 @@ let convertFloat f kind = (** Expressions *) +let check_volatile_bitfield env e = + if Cutil.is_bitfield env e + && List.mem AVolatile (Cutil.attributes_of_type env e.etyp) then + warning Diagnostics.Unnamed "access to a volatile bit field, the 'volatile' qualifier is ignored" + let ezero = Eval(Vint(coqint_of_camlint 0l), type_int32s) let ewrap = function @@ -836,6 +846,7 @@ let rec convertExpr env e = | C.EUnop((C.Oderef|C.Odot _|C.Oarrow _), _) | C.EBinop(C.Oindex, _, _, _) -> let l = convertLvalue env e in + check_volatile_bitfield env e; ewrap (Ctyping.evalof l) | C.EConst(C.CInt(i, k, _)) -> @@ -905,6 +916,7 @@ let rec convertExpr env e = if Cutil.is_composite_type env e2.etyp && List.mem AVolatile (Cutil.attributes_of_type env e2.etyp) then warning Diagnostics.Unnamed "assignment of a value of volatile composite type, the 'volatile' qualifier is ignored"; + check_volatile_bitfield env e1; ewrap (Ctyping.eassign e1' e2') | 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| @@ -925,6 +937,7 @@ let rec convertExpr env e = | _ -> assert false in let e1' = convertLvalue env e1 in let e2' = convertExpr env e2 in + check_volatile_bitfield env e1; ewrap (Ctyping.eassignop op' e1' e2') | C.EBinop(C.Ocomma, e1, e2, _) -> ewrap (Ctyping.ecomma (convertExpr env e1) (convertExpr env e2)) @@ -1327,10 +1340,13 @@ let convertFundef loc env fd = (** External function declaration *) let re_builtin = Str.regexp "__builtin_" + +(* BEGIN CHECK *) let re_runtime64 = Str.regexp "__compcert_i64" let re_runtime32 = Str.regexp "__compcert_i32" let re_runtimef32 = Str.regexp "__compcert_f32" let re_runtimef64 = Str.regexp "__compcert_f64" +(* END CHECK *) let convertFundecl env (sto, id, ty, optinit) = let (args, res, cconv) = @@ -1342,13 +1358,15 @@ let convertFundecl env (sto, id, ty, optinit) = let sg = signature_of_type args res cconv in let ef = if id.name = "malloc" then AST.EF_malloc else - if id.name = "free" then AST.EF_free else + if id.name = "free" then AST.EF_free else + (* BEGIN CHECK *) if Str.string_match re_runtime64 id.name 0 || Str.string_match re_runtime32 id.name 0 || Str.string_match re_runtimef64 id.name 0 || Str.string_match re_runtimef32 id.name 0 then AST.EF_runtime(id'', sg) else + (* END CHECK *) if Str.string_match re_builtin id.name 0 && List.mem_assoc id.name builtins.builtin_functions then AST.EF_builtin(id'', sg) @@ -1476,6 +1494,81 @@ let rec convertCompositedefs env res gl = | _ -> convertCompositedefs env res gl' +(** Add declarations for the helper functions + (for varargs and for int64 arithmetic) *) + +let helper_functions () = [ + "__compcert_va_int32", + Tint(I32, Unsigned, noattr), + [Tpointer(Tvoid, noattr)]; + "__compcert_va_int64", + Tlong(Unsigned, noattr), + [Tpointer(Tvoid, noattr)]; + "__compcert_va_float64", + Tfloat(F64, noattr), + [Tpointer(Tvoid, noattr)]; + "__compcert_va_composite", + Tpointer(Tvoid, noattr), + [Tpointer(Tvoid, noattr); convertIkind (Cutil.size_t_ikind()) noattr]; + "__compcert_i64_dtos", + Tlong(Signed, noattr), + [Tfloat(F64, noattr)]; + "__compcert_i64_dtou", + Tlong(Unsigned, noattr), + [Tfloat(F64, noattr)]; + "__compcert_i64_stod", + Tfloat(F64, noattr), + [Tlong(Signed, noattr)]; + "__compcert_i64_utod", + Tfloat(F64, noattr), + [Tlong(Unsigned, noattr)]; + "__compcert_i64_stof", + Tfloat(F32, noattr), + [Tlong(Signed, noattr)]; + "__compcert_i64_utof", + Tfloat(F32, noattr), + [Tlong(Unsigned, noattr)]; + "__compcert_i64_sdiv", + Tlong(Signed, noattr), + [Tlong(Signed, noattr); Tlong(Signed, noattr)]; + "__compcert_i64_udiv", + Tlong(Unsigned, noattr), + [Tlong(Unsigned, noattr); Tlong(Unsigned, noattr)]; + "__compcert_i64_smod", + Tlong(Signed, noattr), + [Tlong(Signed, noattr); Tlong(Signed, noattr)]; + "__compcert_i64_umod", + Tlong(Unsigned, noattr), + [Tlong(Unsigned, noattr); Tlong(Unsigned, noattr)]; + "__compcert_i64_shl", + Tlong(Signed, noattr), + [Tlong(Signed, noattr); Tint(I32, Signed, noattr)]; + "__compcert_i64_shr", + Tlong(Unsigned, noattr), + [Tlong(Unsigned, noattr); Tint(I32, Signed, noattr)]; + "__compcert_i64_sar", + Tlong(Signed, noattr), + [Tlong(Signed, noattr); Tint(I32, Signed, noattr)]; + "__compcert_i64_smulh", + Tlong(Signed, noattr), + [Tlong(Signed, noattr); Tlong(Signed, noattr)]; + "__compcert_i64_umulh", + Tlong(Unsigned, noattr), + [Tlong(Unsigned, noattr); Tlong(Unsigned, noattr)] +] + +let helper_function_declaration (name, tyres, tyargs) = + let tyargs = + List.fold_right (fun t tl -> Tcons(t, tl)) tyargs Tnil in + let ef = + AST.EF_runtime(coqstring_of_camlstring name, + signature_of_type tyargs tyres AST.cc_default) in + (intern_string name, + AST.Gfun (Ctypes.External(ef, tyargs, tyres, AST.cc_default))) + +let add_helper_functions globs = + List.map helper_function_declaration (helper_functions()) @ globs + (** Build environment of typedefs, structs, unions and enums *) let rec translEnv env = function @@ -1573,10 +1666,11 @@ let convertProgram p = comp_env := ce; let gl1 = convertGlobdecls env [] p in let gl2 = globals_for_strings gl1 in + let gl3 = add_helper_functions gl2 in comp_env := Maps.PTree.empty; let p' = - { prog_defs = gl2; - prog_public = public_globals gl2; + { prog_defs = gl3; + prog_public = public_globals gl3; prog_main = intern_string !Clflags.main_function_name; prog_types = typs; prog_comp_env = ce } in diff --git a/cfrontend/Cexec.v b/cfrontend/Cexec.v index 24f10b68..cc3058a9 100644 --- a/cfrontend/Cexec.v +++ b/cfrontend/Cexec.v @@ -37,6 +37,10 @@ Notation "'do' X , Y , Z <- A ; B" := (match A with Some (X, Y, Z) => B | None = (at level 200, X ident, Y ident, Z ident, A at level 100, B at level 200) : option_monad_scope. +Notation "'do' X , Y , Z , W <- A ; B" := (match A with Some (X, Y, Z, W) => B | None => None end) + (at level 200, X ident, Y ident, Z ident, W 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. @@ -61,14 +65,14 @@ Proof. intros until ty. destruct a; simpl; congruence. Qed. -Definition is_loc (a: expr) : option (block * ptrofs * type) := +Definition is_loc (a: expr) : option (block * ptrofs * bitfield * type) := match a with - | Eloc b ofs ty => Some(b, ofs, ty) + | Eloc b ofs bf ty => Some(b, ofs, bf, ty) | _ => None end. Lemma is_loc_inv: - forall a b ofs ty, is_loc a = Some(b, ofs, ty) -> a = Eloc b ofs ty. + forall a b ofs bf ty, is_loc a = Some(b, ofs, bf, ty) -> a = Eloc b ofs bf ty. Proof. intros until ty. destruct a; simpl; congruence. Qed. @@ -209,15 +213,15 @@ Definition do_volatile_load (w: world) (chunk: memory_chunk) (m: mem) (b: block) Some(w, E0, v). Definition do_volatile_store (w: world) (chunk: memory_chunk) (m: mem) (b: block) (ofs: ptrofs) (v: val) - : option (world * trace * mem) := + : option (world * trace * mem * val) := if Genv.block_is_volatile ge b then do id <- Genv.invert_symbol ge b; do ev <- eventval_of_val (Val.load_result chunk v) (type_of_chunk chunk); do w' <- nextworld_vstore w chunk id ofs ev; - Some(w', Event_vstore chunk id ofs ev :: nil, m) + Some(w', Event_vstore chunk id ofs ev :: nil, m, v) else do m' <- Mem.store chunk m b (Ptrofs.unsigned ofs) v; - Some(w, E0, m'). + Some(w, E0, m', v). Lemma do_volatile_load_sound: forall w chunk m b ofs w' t v, @@ -244,21 +248,21 @@ Proof. 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'. + forall w chunk m b ofs v w' t m' v', + do_volatile_store w chunk m b ofs v = Some(w', t, m', v') -> + volatile_store ge chunk m b ofs v t m' /\ possible_trace w t w' /\ v' = v. Proof. - intros until m'. unfold do_volatile_store. mydestr. + intros until v'. 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. + split. econstructor. constructor; eauto. constructor. auto. + split. constructor; auto. split. constructor. auto. 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'). + do_volatile_store w chunk m b ofs v = Some(w', t, m', v). Proof. unfold do_volatile_store; intros. inv H; simpl in *. rewrite H1. rewrite (Genv.find_invert_symbol _ _ H2). @@ -269,16 +273,31 @@ Qed. (** Accessing locations *) -Definition do_deref_loc (w: world) (ty: type) (m: mem) (b: block) (ofs: ptrofs) : option (world * trace * val) := - match access_mode ty with - | By_value chunk => +Definition do_deref_loc (w: world) (ty: type) (m: mem) (b: block) (ofs: ptrofs) (bf: bitfield) : option (world * trace * val) := + match bf with + | Full => + 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 + | By_reference => Some(w, E0, Vptr b ofs) + | By_copy => Some(w, E0, Vptr b ofs) + | _ => None + end + | Bits sz sg pos width => + match ty with + | Tint sz1 sg1 _ => + check (intsize_eq sz1 sz && + signedness_eq sg1 (if zlt width (bitsize_intsize sz) then Signed else sg) && + zle 0 pos && zlt 0 width && zle width (bitsize_intsize sz) && zle (pos + width) (bitsize_carrier sz)); + match Mem.loadv (chunk_for_carrier sz) m (Vptr b ofs) with + | Some (Vint c) => Some (w, E0, Vint (bitfield_extract sz sg pos width c)) + | _ => None + end + | _ => None + end end. Definition assign_copy_ok (ty: type) (b: block) (ofs: ptrofs) (b': block) (ofs': ptrofs) : Prop := @@ -310,75 +329,103 @@ Proof with try (right; intuition lia). destruct Y... left; intuition lia. Defined. -Definition do_assign_loc (w: world) (ty: type) (m: mem) (b: block) (ofs: ptrofs) (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' (Ptrofs.unsigned ofs') (sizeof ge ty); - do m' <- Mem.storebytes m b (Ptrofs.unsigned ofs) bytes; - Some(w, E0, m') - else None - | _ => None - end - | _ => None +Definition do_assign_loc (w: world) (ty: type) (m: mem) (b: block) (ofs: ptrofs) (bf: bitfield) (v: val): option (world * trace * mem * val) := + match bf with + | Full => + 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', v) + | 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' (Ptrofs.unsigned ofs') (sizeof ge ty); + do m' <- Mem.storebytes m b (Ptrofs.unsigned ofs) bytes; + Some(w, E0, m', v) + else None + | _ => None + end + | _ => None + end + | Bits sz sg pos width => + check (zle 0 pos && zlt 0 width && zle width (bitsize_intsize sz) && zle (pos + width) (bitsize_carrier sz)); + match ty, v, Mem.loadv (chunk_for_carrier sz) m (Vptr b ofs) with + | Tint sz1 sg1 _, Vint n, Some (Vint c) => + check (intsize_eq sz1 sz && + signedness_eq sg1 (if zlt width (bitsize_intsize sz) then Signed else sg)); + do m' <- Mem.storev (chunk_for_carrier sz) m (Vptr b ofs) + (Vint ((Int.bitfield_insert (first_bit sz pos width) width c n))); + Some (w, E0, m', Vint (bitfield_normalize sz sg width n)) + | _, _, _ => None + end 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'. + forall w ty m b ofs bf w' t v, + do_deref_loc w ty m b ofs bf = Some(w', t, v) -> + deref_loc ge ty m b ofs bf t v /\ possible_trace w t w'. Proof. unfold do_deref_loc; intros until v. - destruct (access_mode ty) eqn:?; mydestr. + destruct bf. +- destruct (access_mode ty) 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. +- mydestr. destruct ty; mydestr. InvBooleans. subst i. destruct v0; mydestr. + split. eapply deref_loc_bitfield; eauto. econstructor; 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). + forall w ty m b ofs bf w' t v, + deref_loc ge ty m b ofs bf t v -> possible_trace w t w' -> + do_deref_loc w ty m b ofs bf = 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. +- 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. +- inv H0. inv H1. + unfold proj_sumbool; rewrite ! dec_eq_true, ! zle_true, ! zlt_true by lia. cbn. + cbn in H4; rewrite H4. 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'. + forall w ty m b ofs bf v w' t m' v', + do_assign_loc w ty m b ofs bf v = Some(w', t, m', v') -> + assign_loc ge ty m b ofs bf v t m' v' /\ possible_trace w t w'. Proof. - unfold do_assign_loc; intros until m'. - destruct (access_mode ty) eqn:?; mydestr. - intros. exploit do_volatile_store_sound; eauto. intuition. eapply assign_loc_volatile; eauto. + unfold do_assign_loc; intros until v'. + destruct bf. +- destruct (access_mode ty) eqn:?; mydestr. + intros. exploit do_volatile_store_sound; eauto. intros (P & Q & R). subst v'. 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. +- mydestr. InvBooleans. + destruct ty; mydestr. destruct v; mydestr. destruct v; mydestr. InvBooleans. subst s i. + split. eapply assign_loc_bitfield; eauto. econstructor; 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'). + forall w ty m b ofs bf v w' t m' v', + assign_loc ge ty m b ofs bf v t m' v' -> possible_trace w t w' -> + do_assign_loc w ty m b ofs bf v = Some(w', t, m', v'). 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 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. +- inv H0. inv H1. + unfold proj_sumbool; rewrite ! zle_true, ! zlt_true by lia. cbn. + rewrite ! dec_eq_true. + cbn in H4; rewrite H4. cbn in H5; rewrite H5. auto. Qed. (** External calls *) @@ -421,7 +468,7 @@ Definition do_ef_volatile_load (chunk: memory_chunk) 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') + | Vptr b ofs :: v :: nil => do w',t,m',v' <- do_volatile_store w chunk m b ofs v; Some(w',t,Vundef,m') | _ => None end. @@ -569,7 +616,7 @@ Proof with try congruence. exploit do_volatile_load_sound; eauto. intuition. econstructor; eauto. - (* EF_vstore *) unfold do_ef_volatile_store. destruct vargs... destruct v... destruct vargs... destruct vargs... - mydestr. destruct p as [[w'' t''] m'']. mydestr. + mydestr. destruct p as [[[w'' t''] m''] v'']. mydestr. exploit do_volatile_store_sound; eauto. intuition. econstructor; eauto. - (* EF_malloc *) unfold do_ef_malloc. destruct vargs... destruct vargs... mydestr. @@ -719,6 +766,10 @@ Notation "'do' X , Y , Z <- A ; B" := (match A with Some (X, Y, Z) => B | None = (at level 200, X ident, Y ident, Z ident, A at level 100, B at level 200) : reducts_monad_scope. +Notation "'do' X , Y , Z , W <- A ; B" := (match A with Some (X, Y, Z, W) => B | None => stuck end) + (at level 200, X ident, Y ident, Z ident, W 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. @@ -727,21 +778,21 @@ 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 => + | LV, Eloc b ofs bf ty => nil | LV, Evar x ty => match e!x with | Some(b, ty') => check type_eq ty ty'; - topred (Lred "red_var_local" (Eloc b Ptrofs.zero ty) m) + topred (Lred "red_var_local" (Eloc b Ptrofs.zero Full ty) m) | None => do b <- Genv.find_symbol ge x; - topred (Lred "red_var_global" (Eloc b Ptrofs.zero ty) m) + topred (Lred "red_var_global" (Eloc b Ptrofs.zero Full ty) m) end | LV, Ederef r ty => match is_val r with | Some(Vptr b ofs, ty') => - topred (Lred "red_deref" (Eloc b ofs ty) m) + topred (Lred "red_deref" (Eloc b ofs Full ty) m) | Some _ => stuck | None => @@ -755,11 +806,14 @@ Fixpoint step_expr (k: kind) (a: expr) (m: mem): reducts expr := do co <- ge.(genv_cenv)!id; match field_offset ge f (co_members co) with | Error _ => stuck - | OK delta => topred (Lred "red_field_struct" (Eloc b (Ptrofs.add ofs (Ptrofs.repr delta)) ty) m) + | OK (delta, bf) => topred (Lred "red_field_struct" (Eloc b (Ptrofs.add ofs (Ptrofs.repr delta)) bf ty) m) end | Tunion id _ => do co <- ge.(genv_cenv)!id; - topred (Lred "red_field_union" (Eloc b ofs ty) m) + match union_field_offset ge f (co_members co) with + | Error _ => stuck + | OK (delta, bf) => topred (Lred "red_field_union" (Eloc b (Ptrofs.add ofs (Ptrofs.repr delta)) bf ty) m) + end | _ => stuck end | Some _ => @@ -771,16 +825,19 @@ Fixpoint step_expr (k: kind) (a: expr) (m: mem): reducts expr := nil | RV, Evalof l ty => match is_loc l with - | Some(b, ofs, ty') => + | Some(b, ofs, bf, ty') => check type_eq ty ty'; - do w',t,v <- do_deref_loc w ty m b ofs; + do w',t,v <- do_deref_loc w ty m b ofs bf; topred (Rred "red_rvalof" (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 "red_addrof" (Eval (Vptr b ofs) ty) m E0) + | Some(b, ofs, bf, ty') => + match bf with Full => topred (Rred "red_addrof" (Eval (Vptr b ofs) ty) m E0) + | Bits _ _ _ _ => stuck + end | None => incontext (fun x => Eaddrof x ty) (step_expr LV l m) end | RV, Eunop op r1 ty => @@ -840,21 +897,21 @@ Fixpoint step_expr (k: kind) (a: expr) (m: mem): reducts expr := topred (Rred "red_alignof" (Eval (Vptrofs (Ptrofs.repr (alignof ge ty'))) ty) m E0) | RV, Eassign l1 r2 ty => match is_loc l1, is_val r2 with - | Some(b, ofs, ty1), Some(v2, ty2) => + | Some(b, ofs, bf, ty1), Some(v2, ty2) => check type_eq ty1 ty; do v <- sem_cast v2 ty2 ty1 m; - do w',t,m' <- do_assign_loc w ty1 m b ofs v; - topred (Rred "red_assign" (Eval v ty) m' t) + do w',t,m',v' <- do_assign_loc w ty1 m b ofs bf v; + topred (Rred "red_assign" (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) end | RV, Eassignop op l1 r2 tyres ty => match is_loc l1, is_val r2 with - | Some(b, ofs, ty1), Some(v2, ty2) => + | Some(b, ofs, bf, ty1), Some(v2, ty2) => check type_eq ty1 ty; - do w',t,v1 <- do_deref_loc w ty1 m b ofs; - let r' := Eassign (Eloc b ofs ty1) + do w',t,v1 <- do_deref_loc w ty1 m b ofs bf; + let r' := Eassign (Eloc b ofs bf ty1) (Ebinop op (Eval v1 ty1) (Eval v2 ty2) tyres) ty1 in topred (Rred "red_assignop" r' m t) | _, _ => @@ -863,12 +920,12 @@ Fixpoint step_expr (k: kind) (a: expr) (m: mem): reducts expr := end | RV, Epostincr id l ty => match is_loc l with - | Some(b, ofs, ty1) => + | Some(b, ofs, bf, ty1) => check type_eq ty1 ty; - do w',t, v1 <- do_deref_loc w ty m b ofs; + do w',t, v1 <- do_deref_loc w ty m b ofs bf; let op := match id with Incr => Oadd | Decr => Osub end in let r' := - Ecomma (Eassign (Eloc b ofs ty) + Ecomma (Eassign (Eloc b ofs bf ty) (Ebinop op (Eval v1 ty) (Eval (Vint Int.one) type_int32s) (incrdecr_type ty)) ty) (Eval v1 ty) ty in @@ -935,8 +992,8 @@ with step_exprlist (rl: exprlist) (m: mem): reducts exprlist := 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_loc: forall b ofs ty bf m, + imm_safe_t LV (Eloc b ofs bf ty) m | imm_safe_t_lred: forall to C l m l' m', lred ge e l m l' m' -> context LV to C -> @@ -970,23 +1027,25 @@ Fixpoint exprlist_all_values (rl: exprlist) : Prop := Definition invert_expr_prop (a: expr) (m: mem) : Prop := match a with - | Eloc b ofs ty => False + | Eloc b ofs bf ty => False | Evar x ty => exists b, e!x = Some(b, ty) \/ (e!x = None /\ Genv.find_symbol ge x = Some b) | Ederef (Eval v ty1) ty => exists b, exists ofs, v = Vptr b ofs + | Eaddrof (Eloc b ofs bf ty1) ty => + bf = Full | Efield (Eval v ty1) f ty => exists b, exists ofs, v = Vptr b ofs /\ match ty1 with - | Tstruct id _ => exists co delta, ge.(genv_cenv)!id = Some co /\ field_offset ge f (co_members co) = OK delta - | Tunion id _ => exists co, ge.(genv_cenv)!id = Some co + | Tstruct id _ => exists co delta bf, ge.(genv_cenv)!id = Some co /\ field_offset ge f (co_members co) = OK (delta, bf) + | Tunion id _ => exists co delta bf, ge.(genv_cenv)!id = Some co /\ union_field_offset ge f (co_members co) = OK (delta, bf) | _ => 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' + | Evalof (Eloc b ofs bf ty') ty => + ty' = ty /\ exists t, exists v, exists w', deref_loc ge ty m b ofs bf t v /\ possible_trace w t w' | Eunop op (Eval v1 ty1) ty => exists v, sem_unary_operation op v1 ty1 m = Some v | Ebinop op (Eval v1 ty1) (Eval v2 ty2) ty => @@ -999,15 +1058,15 @@ Definition invert_expr_prop (a: expr) (m: mem) : Prop := exists b, bool_val v1 ty1 m = Some b | Econdition (Eval v1 ty1) r1 r2 ty => exists b, bool_val v1 ty1 m = 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 m = 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 => + | Eassign (Eloc b ofs bf ty1) (Eval v2 ty2) ty => + exists v, exists m', exists v', exists t, exists w', + ty = ty1 /\ sem_cast v2 ty2 ty1 m = Some v /\ assign_loc ge ty1 m b ofs bf v t m' v' /\ possible_trace w t w' + | Eassignop op (Eloc b ofs bf 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 => + ty = ty1 /\ deref_loc ge ty1 m b ofs bf t v1 /\ possible_trace w t w' + | Epostincr id (Eloc b ofs bf ty1) ty => exists t, exists v1, exists w', - ty = ty1 /\ deref_loc ge ty m b ofs t v1 /\ possible_trace w t w' + ty = ty1 /\ deref_loc ge ty m b ofs bf t v1 /\ possible_trace w t w' | Ecomma (Eval v ty1) r2 ty => typeof r2 = ty | Eparen (Eval v1 ty1) tycast ty => @@ -1035,8 +1094,8 @@ Proof. exists b; auto. exists b; auto. exists b; exists ofs; auto. - exists b; exists ofs; split; auto. exists co, delta; auto. - exists b; exists ofs; split; auto. exists co; auto. + exists b; exists ofs; split; auto. exists co, delta, bf; auto. + exists b; exists ofs; split; auto. exists co, delta, bf; auto. Qed. Lemma rred_invert: @@ -1050,7 +1109,7 @@ Proof. exists true; auto. exists false; auto. exists true; auto. exists false; auto. exists b; auto. - exists v; exists m'; exists t; exists w'; auto. + exists v; exists m'; exists v'; exists t; exists w'; auto. exists t; exists v1; exists w'; auto. exists t; exists v1; exists w'; auto. exists v; auto. @@ -1085,7 +1144,7 @@ Proof. 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 (C a); auto; contradiction. destruct e1; auto; destruct (C a); auto; contradiction. @@ -1111,7 +1170,7 @@ Lemma imm_safe_t_inv: forall k a m, imm_safe_t k a m -> match a with - | Eloc _ _ _ => True + | Eloc _ _ _ _ => True | Eval _ _ => True | _ => invert_expr_prop a m end. @@ -1237,7 +1296,7 @@ Qed. Lemma not_invert_ok: forall k a m, match a with - | Eloc _ _ _ => False + | Eloc _ _ _ _ => False | Eval _ _ => False | _ => invert_expr_prop a m -> False end -> @@ -1378,18 +1437,19 @@ Proof with (try (apply not_invert_ok; simpl; intro; myinv; intuition congruence; destruct ty'... (* top struct *) destruct (ge.(genv_cenv)!i0) as [co|] eqn:?... - destruct (field_offset ge f (co_members co)) as [delta|] eqn:?... + destruct (field_offset ge f (co_members co)) as [[delta bf]|] eqn:?... apply topred_ok; auto. eapply red_field_struct; eauto. (* top union *) destruct (ge.(genv_cenv)!i0) as [co|] eqn:?... + destruct (union_field_offset ge f (co_members co)) as [[delta bf]|] eqn:?... apply topred_ok; auto. eapply red_field_union; eauto. (* in depth *) eapply incontext_ok; eauto. (* Evalof *) - destruct (is_loc a) as [[[b ofs] ty'] | ] eqn:?. rewrite (is_loc_inv _ _ _ _ Heqo). + destruct (is_loc a) as [[[[b ofs] bf] ty'] | ] eqn:?. rewrite (is_loc_inv _ _ _ _ _ Heqo). (* top *) destruct (type_eq ty ty')... subst ty'. - destruct (do_deref_loc w ty m b ofs) as [[[w' t] v] | ] eqn:?. + destruct (do_deref_loc w ty m b ofs bf) 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. @@ -1402,8 +1462,9 @@ Proof with (try (apply not_invert_ok; simpl; intro; myinv; intuition congruence; (* depth *) eapply incontext_ok; eauto. (* Eaddrof *) - destruct (is_loc a) as [[[b ofs] ty'] | ] eqn:?. rewrite (is_loc_inv _ _ _ _ Heqo). + destruct (is_loc a) as [[[[b ofs] bf ] ty'] | ] eqn:?. rewrite (is_loc_inv _ _ _ _ _ Heqo). (* top *) + destruct bf... apply topred_ok; auto. split. apply red_addrof; auto. exists w; constructor. (* depth *) eapply incontext_ok; eauto. @@ -1459,26 +1520,26 @@ Proof with (try (apply not_invert_ok; simpl; intro; myinv; intuition congruence; (* alignof *) apply topred_ok; auto. split. apply red_alignof. exists w; constructor. (* assign *) - destruct (is_loc a1) as [[[b ofs] ty1] | ] eqn:?. + destruct (is_loc a1) as [[[[b ofs] bf] ty1] | ] eqn:?. destruct (is_val a2) as [[v2 ty2] | ] eqn:?. - rewrite (is_loc_inv _ _ _ _ Heqo). rewrite (is_val_inv _ _ _ Heqo0). + rewrite (is_loc_inv _ _ _ _ _ Heqo). rewrite (is_val_inv _ _ _ Heqo0). (* top *) destruct (type_eq ty1 ty)... subst ty1. destruct (sem_cast v2 ty2 ty m) as [v|] eqn:?... - destruct (do_assign_loc w ty m b ofs v) as [[[w' t] m']|] eqn:?. + destruct (do_assign_loc w ty m b ofs bf v) as [[[[w' t] m'] v']|] eqn:?. exploit do_assign_loc_sound; eauto. intros [P Q]. - apply topred_ok; auto. split. apply red_assign; auto. exists w'; auto. + apply topred_ok; auto. split. eapply red_assign; eauto. 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_loc a1) as [[[[b ofs] bf] ty1] | ] eqn:?. destruct (is_val a2) as [[v2 ty2] | ] eqn:?. - rewrite (is_loc_inv _ _ _ _ Heqo). rewrite (is_val_inv _ _ _ Heqo0). + rewrite (is_loc_inv _ _ _ _ _ Heqo). rewrite (is_val_inv _ _ _ Heqo0). (* top *) destruct (type_eq ty1 ty)... subst ty1. - destruct (do_deref_loc w ty m b ofs) as [[[w' t] v] | ] eqn:?. + destruct (do_deref_loc w ty m b ofs bf) 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. @@ -1486,10 +1547,10 @@ Proof with (try (apply not_invert_ok; simpl; intro; myinv; intuition congruence; eapply incontext2_ok; eauto. eapply incontext2_ok; eauto. (* postincr *) - destruct (is_loc a) as [[[b ofs] ty'] | ] eqn:?. rewrite (is_loc_inv _ _ _ _ Heqo). + destruct (is_loc a) as [[[[b ofs] bf] ty'] | ] eqn:?. rewrite (is_loc_inv _ _ _ _ _ Heqo). (* top *) destruct (type_eq ty' ty)... subst ty'. - destruct (do_deref_loc w ty m b ofs) as [[[w' t] v] | ] eqn:?. + destruct (do_deref_loc w ty m b ofs bf) 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. @@ -1585,7 +1646,7 @@ Proof. (* field struct *) rewrite H, H0; econstructor; eauto. (* field union *) - rewrite H; econstructor; eauto. + rewrite H, H0; econstructor; eauto. Qed. Lemma rred_topred: @@ -1596,7 +1657,7 @@ Proof. induction 1; simpl; intros. (* valof *) rewrite dec_eq_true. - rewrite (do_deref_loc_complete _ _ _ _ _ _ _ _ H H0). econstructor; eauto. + rewrite (do_deref_loc_complete _ _ _ _ _ _ _ _ _ H H0). econstructor; eauto. (* addrof *) inv H. econstructor; eauto. (* unop *) @@ -1618,13 +1679,13 @@ Proof. (* alignof *) inv H. econstructor; eauto. (* assign *) - rewrite dec_eq_true. rewrite H. rewrite (do_assign_loc_complete _ _ _ _ _ _ _ _ _ H0 H1). + rewrite dec_eq_true. rewrite H. rewrite (do_assign_loc_complete _ _ _ _ _ _ _ _ _ _ _ H0 H1). econstructor; eauto. (* assignop *) - rewrite dec_eq_true. rewrite (do_deref_loc_complete _ _ _ _ _ _ _ _ H H0). + rewrite dec_eq_true. rewrite (do_deref_loc_complete _ _ _ _ _ _ _ _ _ H H0). econstructor; eauto. (* postincr *) - rewrite dec_eq_true. subst. rewrite (do_deref_loc_complete _ _ _ _ _ _ _ _ H H1). + rewrite dec_eq_true. subst. rewrite (do_deref_loc_complete _ _ _ _ _ _ _ _ _ H H1). econstructor; eauto. (* comma *) inv H0. rewrite dec_eq_true. econstructor; eauto. @@ -1673,10 +1734,10 @@ Proof. Qed. Lemma reducts_incl_loc: - forall (A: Type) a m b ofs ty (C: expr -> A) res, - is_loc a = Some(b, ofs, ty) -> reducts_incl C (step_expr LV a m) res. + forall (A: Type) a m b ofs ty bf (C: expr -> A) res, + is_loc a = Some(b, ofs, bf, ty) -> reducts_incl C (step_expr LV a m) res. Proof. - intros. rewrite (is_loc_inv _ _ _ _ H). apply reducts_incl_nil. + intros. rewrite (is_loc_inv _ _ _ _ _ H). apply reducts_incl_nil. Qed. Lemma reducts_incl_listval: @@ -1741,10 +1802,10 @@ Proof. 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. + destruct (is_loc (C a)) as [[[[b ofs] bf] ty']|] eqn:?; eauto. (* addrof *) eapply reducts_incl_trans with (C' := fun x => Eaddrof x ty); eauto. - destruct (is_loc (C a)) as [[[b ofs] ty']|] eqn:?; eauto. + destruct (is_loc (C a)) as [[[[b ofs] bf] ty']|] eqn:?; eauto. (* unop *) eapply reducts_incl_trans with (C' := fun x => Eunop op x ty); eauto. destruct (is_val (C a)) as [[v ty']|] eqn:?; eauto. @@ -1769,21 +1830,21 @@ Proof. destruct (is_val (C a)) as [[v ty']|] eqn:?; eauto. (* assign left *) eapply reducts_incl_trans with (C' := fun x => Eassign x e2 ty); eauto. - destruct (is_loc (C a)) as [[[b ofs] ty']|] eqn:?; eauto. + destruct (is_loc (C a)) as [[[[b ofs] bf] ty']|] eqn:?; eauto. (* assign right *) eapply reducts_incl_trans with (C' := fun x => Eassign e1 x ty); eauto. - destruct (is_loc e1) as [[[b ofs] ty1]|] eqn:?; eauto. + destruct (is_loc e1) as [[[[b ofs] bf] ty1]|] eqn:?; eauto. destruct (is_val (C a)) as [[v2 ty2]|] eqn:?; eauto. (* assignop left *) eapply reducts_incl_trans with (C' := fun x => Eassignop op x e2 tyres ty); eauto. - destruct (is_loc (C a)) as [[[b ofs] ty']|] eqn:?; eauto. + destruct (is_loc (C a)) as [[[[b ofs] bf] ty']|] eqn:?; eauto. (* assignop right *) eapply reducts_incl_trans with (C' := fun x => Eassignop op e1 x tyres ty); eauto. - destruct (is_loc e1) as [[[b ofs] ty1]|] eqn:?; eauto. + destruct (is_loc e1) as [[[[b ofs] bf] ty1]|] eqn:?; eauto. destruct (is_val (C a)) as [[v2 ty2]|] eqn:?; eauto. (* postincr *) eapply reducts_incl_trans with (C' := fun x => Epostincr id x ty); eauto. - destruct (is_loc (C a)) as [[[b ofs] ty']|] eqn:?; eauto. + destruct (is_loc (C a)) as [[[[b ofs] bf] ty']|] eqn:?; eauto. (* call left *) eapply reducts_incl_trans with (C' := fun x => Ecall x el ty); eauto. destruct (is_val (C a)) as [[v ty']|] eqn:?; eauto. @@ -1924,7 +1985,7 @@ Function sem_bind_parameters (w: world) (e: env) (m: mem) (l: list (ident * type match PTree.get id e with | Some (b, ty') => check (type_eq ty ty'); - do w', t, m1 <- do_assign_loc w ty m b Ptrofs.zero v1; + do w', t, m1, v' <- do_assign_loc w ty m b Ptrofs.zero Full v1; match t with nil => sem_bind_parameters w e m1 params lv | _ => None end | None => None end @@ -1944,10 +2005,11 @@ 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. +Local Opaque do_assign_loc. induction 1; simpl; auto. rewrite H. rewrite dec_eq_true. assert (possible_trace w E0 w) by constructor. - rewrite (do_assign_loc_complete _ _ _ _ _ _ _ _ _ H0 H2). + rewrite (do_assign_loc_complete _ _ _ _ _ _ _ _ _ _ _ H0 H2). simpl. auto. Qed. diff --git a/cfrontend/Clight.v b/cfrontend/Clight.v index 3b21be28..d15bc90a 100644 --- a/cfrontend/Clight.v +++ b/cfrontend/Clight.v @@ -197,36 +197,42 @@ Definition empty_env: env := (PTree.empty (block * type)). Definition temp_env := PTree.t val. -(** [deref_loc ty m b ofs v] computes the value of a datum - of type [ty] residing in memory [m] at block [b], offset [ofs]. +(** [deref_loc ty m b ofs bf v] computes the value of a datum + of type [ty] residing in memory [m] at block [b], offset [ofs], + and bitfield designation [bf]. If the type [ty] indicates an access by value, the corresponding memory load is performed. If the type [ty] indicates an access by reference or by copy, the pointer [Vptr b ofs] is returned. *) -Inductive deref_loc (ty: type) (m: mem) (b: block) (ofs: ptrofs) : val -> Prop := +Inductive deref_loc (ty: type) (m: mem) (b: block) (ofs: ptrofs) : + bitfield -> val -> Prop := | deref_loc_value: forall chunk v, access_mode ty = By_value chunk -> Mem.loadv chunk m (Vptr b ofs) = Some v -> - deref_loc ty m b ofs v + deref_loc ty m b ofs Full v | deref_loc_reference: access_mode ty = By_reference -> - deref_loc ty m b ofs (Vptr b ofs) + deref_loc ty m b ofs Full (Vptr b ofs) | deref_loc_copy: access_mode ty = By_copy -> - deref_loc ty m b ofs (Vptr b ofs). + deref_loc ty m b ofs Full (Vptr b ofs) + | deref_loc_bitfield: forall sz sg pos width v, + load_bitfield ty sz sg pos width m (Vptr b ofs) v -> + deref_loc ty m b ofs (Bits sz sg pos width) v. -(** Symmetrically, [assign_loc ty m b ofs v m'] returns the +(** Symmetrically, [assign_loc ty m b ofs bf v 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]. + of type [ty] residing in memory [m] at block [b], offset [ofs], + bitfield designation [bf]. This is allowed only if [ty] indicates an access by value or by copy. [m'] is the updated memory state. *) Inductive assign_loc (ce: composite_env) (ty: type) (m: mem) (b: block) (ofs: ptrofs): - val -> mem -> Prop := + bitfield -> val -> mem -> Prop := | assign_loc_value: forall v chunk m', access_mode ty = By_value chunk -> Mem.storev chunk m (Vptr b ofs) v = Some m' -> - assign_loc ce ty m b ofs v m' + assign_loc ce ty m b ofs Full v m' | assign_loc_copy: forall b' ofs' bytes m', access_mode ty = By_copy -> (sizeof ce ty > 0 -> (alignof_blockcopy ce ty | Ptrofs.unsigned ofs')) -> @@ -236,7 +242,10 @@ Inductive assign_loc (ce: composite_env) (ty: type) (m: mem) (b: block) (ofs: pt \/ Ptrofs.unsigned ofs + sizeof ce ty <= Ptrofs.unsigned ofs' -> Mem.loadbytes m b' (Ptrofs.unsigned ofs') (sizeof ce ty) = Some bytes -> Mem.storebytes m b (Ptrofs.unsigned ofs) bytes = Some m' -> - assign_loc ce ty m b ofs (Vptr b' ofs') m'. + assign_loc ce ty m b ofs Full (Vptr b' ofs') m' + | assign_loc_bitfield: forall sz sg pos width v m' v', + store_bitfield ty sz sg pos width m (Vptr b ofs) v m' v' -> + assign_loc ce ty m b ofs (Bits sz sg pos width) v m'. Section SEMANTICS. @@ -275,7 +284,7 @@ Inductive bind_parameters (e: env): | bind_parameters_cons: forall m id ty params v1 vl b m1 m2, PTree.get id e = Some(b, ty) -> - assign_loc ge ty m b Ptrofs.zero v1 m1 -> + assign_loc ge ty m b Ptrofs.zero Full v1 m1 -> bind_parameters e m1 params vl m2 -> bind_parameters e m ((id, ty) :: params) (v1 :: vl) m2. @@ -369,7 +378,7 @@ Inductive eval_expr: expr -> val -> Prop := le!id = Some v -> eval_expr (Etempvar id ty) v | eval_Eaddrof: forall a ty loc ofs, - eval_lvalue a loc ofs -> + eval_lvalue a loc ofs Full -> eval_expr (Eaddrof a ty) (Vptr loc ofs) | eval_Eunop: forall op a ty v1 v, eval_expr a v1 -> @@ -388,37 +397,39 @@ Inductive eval_expr: expr -> val -> Prop := eval_expr (Esizeof ty1 ty) (Vptrofs (Ptrofs.repr (sizeof ge ty1))) | eval_Ealignof: forall ty1 ty, eval_expr (Ealignof ty1 ty) (Vptrofs (Ptrofs.repr (alignof ge ty1))) - | eval_Elvalue: forall a loc ofs v, - eval_lvalue a loc ofs -> - deref_loc (typeof a) m loc ofs v -> + | eval_Elvalue: forall a loc ofs bf v, + eval_lvalue a loc ofs bf -> + deref_loc (typeof a) m loc ofs bf v -> eval_expr a v (** [eval_lvalue ge e m a b ofs] defines the evaluation of expression [a] in l-value position. The result is the memory location [b, ofs] - that contains the value of the expression [a]. *) + that contains the value of the expression [a], and the bitfield [bf] + designation. *) -with eval_lvalue: expr -> block -> ptrofs -> Prop := +with eval_lvalue: expr -> block -> ptrofs -> bitfield -> Prop := | eval_Evar_local: forall id l ty, e!id = Some(l, ty) -> - eval_lvalue (Evar id ty) l Ptrofs.zero + eval_lvalue (Evar id ty) l Ptrofs.zero Full | eval_Evar_global: forall id l ty, e!id = None -> Genv.find_symbol ge id = Some l -> - eval_lvalue (Evar id ty) l Ptrofs.zero + eval_lvalue (Evar id ty) l Ptrofs.zero Full | 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 co att delta, + eval_lvalue (Ederef a ty) l ofs Full + | eval_Efield_struct: forall a i ty l ofs id co att delta bf, eval_expr a (Vptr l ofs) -> typeof a = Tstruct id att -> ge.(genv_cenv)!id = Some co -> - field_offset ge i (co_members co) = OK delta -> - eval_lvalue (Efield a i ty) l (Ptrofs.add ofs (Ptrofs.repr delta)) - | eval_Efield_union: forall a i ty l ofs id co att, + field_offset ge i (co_members co) = OK (delta, bf) -> + eval_lvalue (Efield a i ty) l (Ptrofs.add ofs (Ptrofs.repr delta)) bf + | eval_Efield_union: forall a i ty l ofs id co att delta bf, eval_expr a (Vptr l ofs) -> typeof a = Tunion id att -> ge.(genv_cenv)!id = Some co -> - eval_lvalue (Efield a i ty) l ofs. + union_field_offset ge i (co_members co) = OK (delta, bf) -> + eval_lvalue (Efield a i ty) l (Ptrofs.add ofs (Ptrofs.repr delta)) bf. Scheme eval_expr_ind2 := Minimality for eval_expr Sort Prop with eval_lvalue_ind2 := Minimality for eval_lvalue Sort Prop. @@ -547,11 +558,11 @@ Variable function_entry: function -> list val -> mem -> env -> temp_env -> mem - Inductive step: state -> trace -> state -> Prop := - | step_assign: forall f a1 a2 k e le m loc ofs v2 v m', - eval_lvalue e le m a1 loc ofs -> + | step_assign: forall f a1 a2 k e le m loc ofs bf v2 v m', + eval_lvalue e le m a1 loc ofs bf -> eval_expr e le m a2 v2 -> sem_cast v2 (typeof a2) (typeof a1) m = Some v -> - assign_loc ge (typeof a1) m loc ofs v m' -> + assign_loc ge (typeof a1) m loc ofs bf v m' -> step (State f (Sassign a1 a2) k e le m) E0 (State f Sskip k e le m') diff --git a/cfrontend/ClightBigstep.v b/cfrontend/ClightBigstep.v index 644c4c6c..51487fa2 100644 --- a/cfrontend/ClightBigstep.v +++ b/cfrontend/ClightBigstep.v @@ -79,11 +79,11 @@ 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', - eval_lvalue ge e le m a1 loc ofs -> + | exec_Sassign: forall e le m a1 a2 loc ofs bf v2 v m', + eval_lvalue ge e le m a1 loc ofs bf -> eval_expr ge e le m a2 v2 -> sem_cast v2 (typeof a2) (typeof a1) m = Some v -> - assign_loc ge (typeof a1) m loc ofs v m' -> + assign_loc ge (typeof a1) m loc ofs bf v m' -> exec_stmt e le m (Sassign a1 a2) E0 le m' Out_normal | exec_Sset: forall e le m id a v, diff --git a/cfrontend/Cop.v b/cfrontend/Cop.v index 8bb46f0b..2f8b5e7c 100644 --- a/cfrontend/Cop.v +++ b/cfrontend/Cop.v @@ -1094,6 +1094,60 @@ Definition incrdecr_type (ty: type) := | _ => Tvoid end. +(** ** Accessing bit fields *) + +Definition chunk_for_carrier (sz: intsize) : memory_chunk := + match sz with + | I8 | IBool => Mint8unsigned + | I16 => Mint16unsigned + | I32 => Mint32 + end. + +(** For bitfield accesses, bits are numbered differently on + little-endian and on big-endian machines: bit 0 is the least + significant bit in little-endian, and the most significant bit in + big-endian. *) + +Definition bitsize_carrier (sz: intsize) : Z := + match sz with + | I8 | IBool => 8 + | I16 => 16 + | I32 => 32 + end. + +Definition first_bit (sz: intsize) (pos width: Z) : Z := + if Archi.big_endian + then bitsize_carrier sz - pos - width + else pos. + +Definition bitfield_extract (sz: intsize) (sg: signedness) (pos width: Z) (c: int) : int := + if intsize_eq sz IBool || signedness_eq sg Unsigned + then Int.unsigned_bitfield_extract (first_bit sz pos width) width c + else Int.signed_bitfield_extract (first_bit sz pos width) width c. + +Definition bitfield_normalize (sz: intsize) (sg: signedness) (width: Z) (n: int) : int := + if intsize_eq sz IBool || signedness_eq sg Unsigned + then Int.zero_ext width n + else Int.sign_ext width n. + +Inductive load_bitfield: type -> intsize -> signedness -> Z -> Z -> mem -> val -> val -> Prop := + | load_bitfield_intro: forall sz sg1 attr sg pos width m addr c, + 0 <= pos -> 0 < width <= bitsize_intsize sz -> pos + width <= bitsize_carrier sz -> + sg1 = (if zlt width (bitsize_intsize sz) then Signed else sg) -> + Mem.loadv (chunk_for_carrier sz) m addr = Some (Vint c) -> + load_bitfield (Tint sz sg1 attr) sz sg pos width m addr + (Vint (bitfield_extract sz sg pos width c)). + +Inductive store_bitfield: type -> intsize -> signedness -> Z -> Z -> mem -> val -> val -> mem -> val -> Prop := + | store_bitfield_intro: forall sz sg1 attr sg pos width m addr c n m', + 0 <= pos -> 0 < width <= bitsize_intsize sz -> pos + width <= bitsize_carrier sz -> + sg1 = (if zlt width (bitsize_intsize sz) then Signed else sg) -> + Mem.loadv (chunk_for_carrier sz) m addr = Some (Vint c) -> + Mem.storev (chunk_for_carrier sz) m addr + (Vint (Int.bitfield_insert (first_bit sz pos width) width c n)) = Some m' -> + store_bitfield (Tint sz sg1 attr) sz sg pos width m addr (Vint n) + m' (Vint (bitfield_normalize sz sg width n)). + (** * Compatibility with extensions and injections *) Section GENERIC_INJECTION. diff --git a/cfrontend/Csem.v b/cfrontend/Csem.v index 724c1c9e..6698c56f 100644 --- a/cfrontend/Csem.v +++ b/cfrontend/Csem.v @@ -46,49 +46,59 @@ Section SEMANTICS. Variable ge: genv. -(** [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]. +(** [deref_loc ty m b ofs bf t v] computes the value of a datum + of type [ty] residing in memory [m] at block [b], offset [ofs], + and bitfield designation [bf]. 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. [v] is the value returned, and [t] the trace of observables (nonempty if this is a volatile access). *) -Inductive deref_loc (ty: type) (m: mem) (b: block) (ofs: ptrofs) : trace -> val -> Prop := +Inductive deref_loc (ty: type) (m: mem) (b: block) (ofs: ptrofs) : + bitfield -> 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 ty m b ofs E0 v + deref_loc ty m b ofs Full 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 ty m b ofs t v + deref_loc ty m b ofs Full t v | deref_loc_reference: access_mode ty = By_reference -> - deref_loc ty m b ofs E0 (Vptr b ofs) + deref_loc ty m b ofs Full E0 (Vptr b ofs) | deref_loc_copy: access_mode ty = By_copy -> - deref_loc ty m b ofs E0 (Vptr b ofs). + deref_loc ty m b ofs Full E0 (Vptr b ofs) + | deref_loc_bitfield: forall sz sg pos width v, + load_bitfield ty sz sg pos width m (Vptr b ofs) v -> + deref_loc ty m b ofs (Bits sz sg pos width) E0 v. -(** Symmetrically, [assign_loc ty m b ofs v t m'] returns the +(** Symmetrically, [assign_loc ty m b ofs bf v t m' v'] returns the memory state after storing the value [v] in the datum - of type [ty] residing in memory [m] at block [b], offset [ofs]. + of type [ty] residing in memory [m] at block [b], offset [ofs], + and bitfield designation [bf]. 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). *) + (nonempty if this is a volatile store). + [v'] is the result value of the assignment. It is equal to [v] + if [bf] is [Full], and to [v] normalized to the width and signedness + of the bitfield [bf] otherwise. +*) Inductive assign_loc (ty: type) (m: mem) (b: block) (ofs: ptrofs): - val -> trace -> mem -> Prop := + bitfield -> val -> trace -> mem -> val -> 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 ty m b ofs v E0 m' + assign_loc ty m b ofs Full v E0 m' v | 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 ty m b ofs v t m' + assign_loc ty m b ofs Full v t m' v | assign_loc_copy: forall b' ofs' bytes m', access_mode ty = By_copy -> (alignof_blockcopy ge ty | Ptrofs.unsigned ofs') -> @@ -98,7 +108,10 @@ Inductive assign_loc (ty: type) (m: mem) (b: block) (ofs: ptrofs): \/ Ptrofs.unsigned ofs + sizeof ge ty <= Ptrofs.unsigned ofs' -> Mem.loadbytes m b' (Ptrofs.unsigned ofs') (sizeof ge ty) = Some bytes -> Mem.storebytes m b (Ptrofs.unsigned ofs) bytes = Some m' -> - assign_loc ty m b ofs (Vptr b' ofs') E0 m'. + assign_loc ty m b ofs Full (Vptr b' ofs') E0 m' (Vptr b' ofs') + | assign_loc_bitfield: forall sz sg pos width v m' v', + store_bitfield ty sz sg pos width m (Vptr b ofs) v m' v' -> + assign_loc ty m b ofs (Bits sz sg pos width) v E0 m' v'. (** Allocation of function-local variables. [alloc_variables e1 m1 vars e2 m2] allocates one memory block @@ -131,9 +144,9 @@ Inductive bind_parameters (e: env): forall m, bind_parameters e m nil nil m | bind_parameters_cons: - forall m id ty params v1 vl b m1 m2, + forall m id ty params v1 vl v1' b m1 m2, PTree.get id e = Some(b, ty) -> - assign_loc ty m b Ptrofs.zero v1 E0 m1 -> + assign_loc ty m b Ptrofs.zero Full v1 E0 m1 v1' -> bind_parameters e m1 params vl m2 -> bind_parameters e m ((id, ty) :: params) (v1 :: vl) m2. @@ -202,34 +215,35 @@ Inductive lred: expr -> mem -> expr -> mem -> Prop := | red_var_local: forall x ty m b, e!x = Some(b, ty) -> lred (Evar x ty) m - (Eloc b Ptrofs.zero ty) m + (Eloc b Ptrofs.zero Full ty) m | red_var_global: forall x ty m b, e!x = None -> Genv.find_symbol ge x = Some b -> lred (Evar x ty) m - (Eloc b Ptrofs.zero ty) m + (Eloc b Ptrofs.zero Full ty) m | 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 co a f ty m delta, + (Eloc b ofs Full ty) m + | red_field_struct: forall b ofs id co a f ty m delta bf, ge.(genv_cenv)!id = Some co -> - field_offset ge f (co_members co) = OK delta -> + field_offset ge f (co_members co) = OK (delta, bf) -> lred (Efield (Eval (Vptr b ofs) (Tstruct id a)) f ty) m - (Eloc b (Ptrofs.add ofs (Ptrofs.repr delta)) ty) m - | red_field_union: forall b ofs id co a f ty m, + (Eloc b (Ptrofs.add ofs (Ptrofs.repr delta)) bf ty) m + | red_field_union: forall b ofs id co a f ty m delta bf, ge.(genv_cenv)!id = Some co -> + union_field_offset ge f (co_members co) = OK (delta, bf) -> lred (Efield (Eval (Vptr b ofs) (Tunion id a)) f ty) m - (Eloc b ofs ty) m. + (Eloc b (Ptrofs.add ofs (Ptrofs.repr delta)) bf ty) m. (** Head reductions for r-values *) Inductive rred: expr -> mem -> trace -> expr -> mem -> Prop := - | red_rvalof: forall b ofs ty m t v, - deref_loc ty m b ofs t v -> - rred (Evalof (Eloc b ofs ty) ty) m + | red_rvalof: forall b ofs bf ty m t v, + deref_loc ty m b ofs bf t v -> + rred (Evalof (Eloc b ofs bf ty) ty) m t (Eval v ty) m | red_addrof: forall b ofs ty1 ty m, - rred (Eaddrof (Eloc b ofs ty1) ty) m + rred (Eaddrof (Eloc b ofs Full ty1) ty) m E0 (Eval (Vptr b ofs) ty) m | red_unop: forall op v1 ty1 ty m v, sem_unary_operation op v1 ty1 m = Some v -> @@ -269,21 +283,21 @@ Inductive rred: expr -> mem -> trace -> expr -> mem -> Prop := | red_alignof: forall ty1 ty m, rred (Ealignof ty1 ty) m E0 (Eval (Vptrofs (Ptrofs.repr (alignof ge ty1))) ty) m - | red_assign: forall b ofs ty1 v2 ty2 m v t m', + | red_assign: forall b ofs ty1 bf v2 ty2 m v t m' v', sem_cast v2 ty2 ty1 m = Some v -> - assign_loc ty1 m b ofs v t m' -> - rred (Eassign (Eloc b ofs ty1) (Eval v2 ty2) ty1) m - t (Eval v ty1) m' - | red_assignop: forall op b ofs ty1 v2 ty2 tyres m t v1, - deref_loc ty1 m b ofs t v1 -> - rred (Eassignop op (Eloc b ofs ty1) (Eval v2 ty2) tyres ty1) m - t (Eassign (Eloc b ofs ty1) + assign_loc ty1 m b ofs bf v t m' v' -> + rred (Eassign (Eloc b ofs bf ty1) (Eval v2 ty2) ty1) m + t (Eval v' ty1) m' + | red_assignop: forall op b ofs ty1 bf v2 ty2 tyres m t v1, + deref_loc ty1 m b ofs bf t v1 -> + rred (Eassignop op (Eloc b ofs bf ty1) (Eval v2 ty2) tyres ty1) m + t (Eassign (Eloc b ofs bf 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 ty m b ofs t v1 -> + | red_postincr: forall id b ofs ty bf m t v1 op, + deref_loc ty m b ofs bf t v1 -> op = match id with Incr => Oadd | Decr => Osub end -> - rred (Epostincr id (Eloc b ofs ty) ty) m - t (Ecomma (Eassign (Eloc b ofs ty) + rred (Epostincr id (Eloc b ofs bf ty) ty) m + t (Ecomma (Eassign (Eloc b ofs bf ty) (Ebinop op (Eval v1 ty) (Eval (Vint Int.one) type_int32s) (incrdecr_type ty)) @@ -409,8 +423,8 @@ with contextlist: kind -> (expr -> exprlist) -> Prop := 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_loc: forall b ofs bf ty m, + imm_safe LV (Eloc b ofs bf ty) m | imm_safe_lred: forall to C e m e' m', lred e m e' m' -> context LV to C -> @@ -839,10 +853,10 @@ Lemma semantics_single_events: Proof. unfold semantics; intros; red; simpl; intros. set (ge := globalenv 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 lia. inv H3; simpl; try lia. - 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 lia. inv H3; simpl; try lia. + assert (DEREF: forall chunk m b ofs bf t v, deref_loc ge chunk m b ofs bf t v -> (length t <= 1)%nat). + { intros. inv H0; simpl; try lia. inv H3; simpl; try lia. } + assert (ASSIGN: forall chunk m b ofs bf t v m' v', assign_loc ge chunk m b ofs bf v t m' v' -> (length t <= 1)%nat). + { intros. inv H0; simpl; try lia. inv H3; simpl; try lia. } destruct H. inv H; simpl; try lia. inv H0; eauto; simpl; try lia. eapply external_call_trace_length; eauto. diff --git a/cfrontend/Cshmgen.v b/cfrontend/Cshmgen.v index f78b52ae..173b8c8c 100644 --- a/cfrontend/Cshmgen.v +++ b/cfrontend/Cshmgen.v @@ -377,19 +377,56 @@ Definition make_cmp (c: comparison) (e1: expr) (ty1: type) (e2: expr) (ty2: type e1 ty1 e2 ty2 end. +(** Auxiliary for translating bitfield accesses *) + +Definition make_extract_bitfield (sz: intsize) (sg: signedness) (pos width: Z) + (addr: expr) : res expr := + if zle 0 pos && zlt 0 width && zle (pos + width) (bitsize_carrier sz) then + let amount1 := Int.repr (Int.zwordsize - first_bit sz pos width - width) in + let amount2 := Int.repr (Int.zwordsize - width) in + let e1 := Eload (chunk_for_carrier sz) addr in + let e2 := Ebinop Oshl e1 (make_intconst amount1) in + let e3 := Ebinop (if intsize_eq sz IBool + || signedness_eq sg Unsigned then Oshru else Oshr) + e2 (make_intconst amount2) in + OK e3 + else + Error(msg "Cshmgen.extract_bitfield"). + (** [make_load addr ty_res] loads a value of type [ty_res] from - the memory location denoted by the Csharpminor expression [addr]. + the memory location denoted by the Csharpminor expression [addr] + and the bitfield designator [bf]. If [ty_res] is an array or function type, returns [addr] instead, as consistent with C semantics. *) -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. +Definition make_load (addr: expr) (ty_res: type) (bf: bitfield) := + match bf with + | Full => + 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 + | Bits sz sg pos width => + make_extract_bitfield sz sg pos width addr + end. + +(** Auxiliary for translating bitfield updates *) + +Definition make_store_bitfield (sz: intsize) (sg: signedness) (pos width: Z) + (addr val: expr) : res stmt := + if zle 0 pos && zlt 0 width && zle (pos + width) (bitsize_carrier sz) then + let amount := first_bit sz pos width in + let mask := Int.shl (Int.repr (two_p width - 1)) (Int.repr amount) in + let e1 := Eload (chunk_for_carrier sz) addr in + let e2 := Ebinop Oshl val (make_intconst (Int.repr amount)) in + let e3 := Ebinop Oor (Ebinop Oand e2 (make_intconst mask)) + (Ebinop Oand e1 (make_intconst (Int.not mask))) in + OK (Sstore (chunk_for_carrier sz) addr e3) + else + Error(msg "Cshmgen.make_store_bitfield"). (** [make_memcpy dst src ty] returns a [memcpy] builtin appropriate for by-copy assignment of a value of Clight type [ty]. *) @@ -399,16 +436,21 @@ Definition make_memcpy (ce: composite_env) (dst src: expr) (ty: type) := OK (Sbuiltin None (EF_memcpy sz (Ctypes.alignof_blockcopy ce ty)) (dst :: src :: nil)). -(** [make_store addr ty rhs] stores the value of the +(** [make_store addr ty bf 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. *) - -Definition make_store (ce: composite_env) (addr: expr) (ty: type) (rhs: expr) := - match access_mode ty with - | By_value chunk => OK (Sstore chunk addr rhs) - | By_copy => make_memcpy ce addr rhs ty - | _ => Error (msg "Cshmgen.make_store") + [ty] is the type of the memory location and [bf] a bitfield designator. *) + +Definition make_store (ce: composite_env) (addr: expr) (ty: type) (bf: bitfield) (rhs: expr) := + match bf with + | Full => + match access_mode ty with + | By_value chunk => OK (Sstore chunk addr rhs) + | By_copy => make_memcpy ce addr rhs ty + | _ => Error (msg "Cshmgen.make_store") + end + | Bits sz sg pos width => + make_store_bitfield sz sg pos width addr rhs end. (** ** Translation of operators *) @@ -447,23 +489,27 @@ Definition transl_binop (ce: composite_env) (** ** Translation of field accesses *) -Definition make_field_access (ce: composite_env) (ty: type) (f: ident) (a: expr) : res expr := - match ty with - | Tstruct id _ => - match ce!id with - | None => - Error (MSG "Undefined struct " :: CTX id :: nil) - | Some co => - do ofs <- field_offset ce f (co_members co); - OK (if Archi.ptr64 - then Ebinop Oaddl a (make_longconst (Int64.repr ofs)) - else Ebinop Oadd a (make_intconst (Int.repr ofs))) - end - | Tunion id _ => - OK a - | _ => - Error(msg "Cshmgen.make_field_access") - end. +Definition make_field_access (ce: composite_env) (ty: type) (f: ident) (a: expr) : res (expr * bitfield) := + do (ofs, bf) <- + match ty with + | Tstruct id _ => + match ce!id with + | None => Error (MSG "Undefined struct " :: CTX id :: nil) + | Some co => field_offset ce f (co_members co) + end + | Tunion id _ => + match ce!id with + | None => Error (MSG "Undefined union " :: CTX id :: nil) + | Some co => union_field_offset ce f (co_members co) + end + | _ => + Error(msg "Cshmgen.make_field_access") + end; + let a' := + if Archi.ptr64 + then Ebinop Oaddl a (make_longconst (Int64.repr ofs)) + else Ebinop Oadd a (make_intconst (Int.repr ofs)) in + OK (a', bf). (** * Translation of expressions *) @@ -482,14 +528,18 @@ Fixpoint transl_expr (ce: composite_env) (a: Clight.expr) {struct a} : res expr | Clight.Econst_long n _ => OK(make_longconst n) | Clight.Evar id ty => - make_load (Eaddrof id) ty + make_load (Eaddrof id) ty Full | Clight.Etempvar id ty => OK(Evar id) | Clight.Ederef b ty => do tb <- transl_expr ce b; - make_load tb ty + make_load tb ty Full | Clight.Eaddrof b _ => - transl_lvalue ce b + do (tb, bf) <- transl_lvalue ce b; + match bf with + | Full => OK tb + | Bits _ _ _ _ => Error (msg "Cshmgen.transl_expr: addrof bitfield") + end | Clight.Eunop op b _ => do tb <- transl_expr ce b; transl_unop op tb (typeof b) @@ -502,8 +552,8 @@ Fixpoint transl_expr (ce: composite_env) (a: Clight.expr) {struct a} : res expr make_cast (typeof b) ty tb | Clight.Efield b i ty => do tb <- transl_expr ce b; - do addr <- make_field_access ce (typeof b) i tb; - make_load addr ty + do (addr, bf) <- make_field_access ce (typeof b) i tb; + make_load addr ty bf | Clight.Esizeof ty' ty => do sz <- sizeof ce ty'; OK(make_ptrofsconst sz) | Clight.Ealignof ty' ty => @@ -512,15 +562,16 @@ Fixpoint transl_expr (ce: composite_env) (a: Clight.expr) {struct a} : res expr (** [transl_lvalue a] returns the Csharpminor code that evaluates [a] as a lvalue, that is, code that returns the memory address - where the value of [a] is stored. + where the value of [a] is stored. It also returns the bitfield to be + accessed at this address, if appropriate. *) -with transl_lvalue (ce: composite_env) (a: Clight.expr) {struct a} : res expr := +with transl_lvalue (ce: composite_env) (a: Clight.expr) {struct a} : res (expr * bitfield) := match a with | Clight.Evar id _ => - OK (Eaddrof id) + OK (Eaddrof id, Full) | Clight.Ederef b _ => - transl_expr ce b + do tb <- transl_expr ce b; OK (tb, Full) | Clight.Efield b i ty => do tb <- transl_expr ce b; make_field_access ce (typeof b) i tb @@ -624,10 +675,10 @@ Fixpoint transl_statement (ce: composite_env) (tyret: type) (nbrk ncnt: nat) | Clight.Sskip => OK Sskip | Clight.Sassign b c => - do tb <- transl_lvalue ce b; + do (tb, bf) <- transl_lvalue ce b; do tc <- transl_expr ce c; do tc' <- make_cast (typeof c) (typeof b) tc; - make_store ce tb (typeof b) tc' + make_store ce tb (typeof b) bf tc' | Clight.Sset x b => do tb <- transl_expr ce b; OK(Sset x tb) diff --git a/cfrontend/Cshmgenproof.v b/cfrontend/Cshmgenproof.v index 715ba472..e373d4e5 100644 --- a/cfrontend/Cshmgenproof.v +++ b/cfrontend/Cshmgenproof.v @@ -115,6 +115,21 @@ Proof. destruct (prog_comp_env cunit)!i as [co|] eqn:X; try discriminate; erewrite H1 by eauto; auto. Qed. +Lemma union_field_offset_stable: + forall (cunit prog: Clight.program) id co f, + linkorder cunit prog -> + cunit.(prog_comp_env)!id = Some co -> + prog.(prog_comp_env)!id = Some co /\ + union_field_offset prog.(prog_comp_env) f (co_members co) = union_field_offset cunit.(prog_comp_env) f (co_members co). +Proof. + intros. + assert (C: composite_consistent cunit.(prog_comp_env) co). + { apply build_composite_env_consistent with cunit.(prog_types) id; auto. + apply prog_comp_env_eq. } + destruct H as [_ A]. + split. auto. apply Ctypes.union_field_offset_stable; eauto using co_consistent_complete. +Qed. + Lemma field_offset_stable: forall (cunit prog: Clight.program) id co f, linkorder cunit prog -> @@ -127,38 +142,11 @@ Proof. { apply build_composite_env_consistent with cunit.(prog_types) id; auto. apply prog_comp_env_eq. } destruct H as [_ A]. - split. auto. generalize (co_consistent_complete _ _ C). - unfold field_offset. generalize 0. induction (co_members co) as [ | [f1 t1] m]; simpl; intros. -- auto. -- InvBooleans. - rewrite ! (alignof_stable _ _ A) by auto. - rewrite ! (sizeof_stable _ _ A) by auto. - destruct (ident_eq f f1); eauto. + split. auto. apply Ctypes.field_offset_stable; eauto using co_consistent_complete. Qed. (** * Properties of the translation functions *) -(** Transformation of expressions and statements. *) - -Lemma transl_expr_lvalue: - forall ge e le m a loc ofs ce ta, - Clight.eval_lvalue ge e le m a loc ofs -> - transl_expr ce a = OK ta -> - (exists tb, transl_lvalue ce a = OK tb /\ make_load tb (typeof a) = OK ta). -Proof. - intros until ta; intros EVAL TR. inv EVAL; simpl in TR. - (* var local *) - exists (Eaddrof id); auto. - (* var global *) - exists (Eaddrof id); auto. - (* deref *) - monadInv TR. exists x; auto. - (* field struct *) - monadInv TR. exists x0; split; auto. simpl; rewrite EQ; auto. - (* field union *) - monadInv TR. exists x0; split; auto. simpl; rewrite EQ; auto. -Qed. - (** Properties of labeled statements *) Lemma transl_lbl_stmt_1: @@ -946,28 +934,83 @@ Proof. - eapply make_cmp_correct; eauto. Qed. +Remark int_ltu_true: + forall x, 0 <= x < Int.zwordsize -> Int.ltu (Int.repr x) Int.iwordsize = true. +Proof. + intros. unfold Int.ltu. rewrite Int.unsigned_repr_wordsize, Int.unsigned_repr, zlt_true by (generalize Int.wordsize_max_unsigned; lia). + auto. +Qed. + +Remark first_bit_range: forall sz pos width, + 0 <= pos -> 0 < width -> pos + width <= bitsize_carrier sz -> + 0 <= first_bit sz pos width < Int.zwordsize + /\ 0 <= Int.zwordsize - first_bit sz pos width - width < Int.zwordsize. +Proof. + intros. + assert (bitsize_carrier sz <= Int.zwordsize) by (destruct sz; compute; congruence). + unfold first_bit; destruct Archi.big_endian; lia. +Qed. + Lemma make_load_correct: - forall addr ty code b ofs v e le m, - make_load addr ty = OK code -> + forall addr ty bf code b ofs v e le m, + make_load addr ty bf = OK code -> eval_expr ge e le m addr (Vptr b ofs) -> - deref_loc ty m b ofs v -> + deref_loc ty m b ofs bf v -> eval_expr ge e le m code v. Proof. unfold make_load; intros until m; intros MKLOAD EVEXP DEREF. inv DEREF. - (* scalar *) +- (* scalar *) rewrite H in MKLOAD. inv MKLOAD. apply eval_Eload with (Vptr b ofs); auto. - (* by reference *) +- (* by reference *) rewrite H in MKLOAD. inv MKLOAD. auto. - (* by copy *) +- (* by copy *) rewrite H in MKLOAD. inv MKLOAD. auto. +- (* by bitfield *) + inv H. + unfold make_extract_bitfield in MKLOAD. unfold bitfield_extract. + exploit (first_bit_range sz pos width); eauto. lia. intros [A1 A2]. + set (amount1 := Int.repr (Int.zwordsize - first_bit sz pos width - width)) in MKLOAD. + set (amount2 := Int.repr (Int.zwordsize - width)) in MKLOAD. + destruct (zle 0 pos && zlt 0 width && zle (pos + width) (bitsize_carrier sz)); inv MKLOAD. + set (e1 := Eload (chunk_for_carrier sz) addr). + assert (E1: eval_expr ge e le m e1 (Vint c)) by (econstructor; eauto). + set (e2 := Ebinop Oshl e1 (make_intconst amount1)). + assert (E2: eval_expr ge e le m e2 (Vint (Int.shl c amount1))). + { econstructor; eauto using make_intconst_correct. cbn. + unfold amount1 at 1; rewrite int_ltu_true by lia. auto. } + econstructor; eauto using make_intconst_correct. + destruct (Ctypes.intsize_eq sz IBool || Ctypes.signedness_eq sg Unsigned); cbn. + + unfold amount2 at 1; rewrite int_ltu_true by lia. + rewrite Int.unsigned_bitfield_extract_by_shifts by lia. auto. + + unfold amount2 at 1; rewrite int_ltu_true by lia. + rewrite Int.signed_bitfield_extract_by_shifts by lia. auto. +Qed. + +Lemma make_store_bitfield_correct: + forall f sz sg pos width dst src ty k e le m b ofs v m' s, + eval_expr ge e le m dst (Vptr b ofs) -> + eval_expr ge e le m src v -> + assign_loc prog.(prog_comp_env) ty m b ofs (Bits sz sg pos width) v m' -> + make_store_bitfield sz sg pos width dst src = OK s -> + step ge (State f s k e le m) E0 (State f Sskip k e le m'). +Proof. + intros until s; intros DST SRC ASG MK. + inv ASG. inv H5. unfold make_store_bitfield in MK. + destruct (zle 0 pos && zlt 0 width && zle (pos + width) (bitsize_carrier sz)); inv MK. + econstructor; eauto. + exploit (first_bit_range sz pos width); eauto. lia. intros [A1 A2]. + rewrite Int.bitfield_insert_alternative by lia. + set (amount := first_bit sz pos width). + set (mask := Int.shl (Int.repr (two_p width - 1)) (Int.repr amount)). + repeat econstructor; eauto. cbn. rewrite int_ltu_true by lia. auto. Qed. Lemma make_memcpy_correct: forall f dst src ty k e le m b ofs v m' s, eval_expr ge e le m dst (Vptr b ofs) -> eval_expr ge e le m src v -> - assign_loc prog.(prog_comp_env) ty m b ofs v m' -> + assign_loc prog.(prog_comp_env) ty m b ofs Full v m' -> access_mode ty = By_copy -> make_memcpy cunit.(prog_comp_env) dst src ty = OK s -> step ge (State f s k e le m) E0 (State f Sskip k e le m'). @@ -985,21 +1028,23 @@ Proof. Qed. Lemma make_store_correct: - forall addr ty rhs code e le m b ofs v m' f k, - make_store cunit.(prog_comp_env) addr ty rhs = OK code -> + forall addr ty bf rhs code e le m b ofs v m' f k, + make_store cunit.(prog_comp_env) addr ty bf rhs = OK code -> eval_expr ge e le m addr (Vptr b ofs) -> eval_expr ge e le m rhs v -> - assign_loc prog.(prog_comp_env) ty m b ofs v m' -> + assign_loc prog.(prog_comp_env) ty m b ofs bf v m' -> step ge (State f code k e le m) E0 (State f Sskip k e le m'). Proof. unfold make_store. intros until k; intros MKSTORE EV1 EV2 ASSIGN. inversion ASSIGN; subst. - (* nonvolatile scalar *) +- (* nonvolatile scalar *) rewrite H in MKSTORE; inv MKSTORE. econstructor; eauto. - (* by copy *) +- (* by copy *) rewrite H in MKSTORE. eapply make_memcpy_correct with (b := b) (v := Vptr b' ofs'); eauto. +- (* bitfield *) + eapply make_store_bitfield_correct; eauto. Qed. Lemma make_normalization_correct: @@ -1218,15 +1263,51 @@ Variable m: mem. Variable te: Csharpminor.env. Hypothesis MENV: match_env e te. +Lemma transl_expr_lvalue: + forall a loc ofs bf ta, + Clight.eval_lvalue ge e le m a loc ofs bf -> + transl_expr cunit.(prog_comp_env) a = OK ta -> + exists tb, transl_lvalue cunit.(prog_comp_env) a = OK (tb, bf) + /\ make_load tb (typeof a) bf = OK ta. +Proof. + intros until ta; intros EVAL TR. inv EVAL; simpl in TR. +- (* var local *) + exists (Eaddrof id); auto. +- (* var global *) + exists (Eaddrof id); auto. +- (* deref *) + monadInv TR. cbn; rewrite EQ. exists x; auto. +- (* field struct *) + monadInv TR. + assert (x1 = bf). + { rewrite H0 in EQ1. unfold make_field_access in EQ1. + destruct ((prog_comp_env cunit)!id) as [co'|] eqn:E; try discriminate. + monadInv EQ1. + exploit field_offset_stable. eexact LINK. eauto. instantiate (1 := i). intros [A B]. + simpl in H1, H2. congruence. } + subst x1. + exists x0; split; auto. simpl; rewrite EQ; auto. +- (* field union *) + monadInv TR. + assert (x1 = bf). + { rewrite H0 in EQ1. unfold make_field_access in EQ1. + destruct ((prog_comp_env cunit)!id) as [co'|] eqn:E; try discriminate. + monadInv EQ1. + exploit union_field_offset_stable. eexact LINK. eauto. instantiate (1 := i). intros [A B]. + simpl in H1, H2. congruence. } + subst x1. + exists x0; split; auto. simpl; rewrite EQ; auto. +Qed. + Lemma transl_expr_lvalue_correct: (forall a v, Clight.eval_expr ge e le m a v -> forall ta (TR: transl_expr cunit.(prog_comp_env) a = OK ta) , Csharpminor.eval_expr tge te le m ta v) -/\(forall a b ofs, - Clight.eval_lvalue ge e le m a b ofs -> - forall ta (TR: transl_lvalue cunit.(prog_comp_env) a = OK ta), - Csharpminor.eval_expr tge te le m ta (Vptr b ofs)). +/\(forall a b ofs bf, + Clight.eval_lvalue ge e le m a b ofs bf -> + forall ta bf' (TR: transl_lvalue cunit.(prog_comp_env) a = OK (ta, bf')), + bf = bf' /\ Csharpminor.eval_expr tge te le m ta (Vptr b ofs)). Proof. apply eval_expr_lvalue_ind; intros; try (monadInv TR). - (* const int *) @@ -1240,7 +1321,7 @@ Proof. - (* temp var *) constructor; auto. - (* addrof *) - simpl in TR. auto. + destruct x0; inv EQ0. apply H0 in EQ. destruct EQ. auto. - (* unop *) eapply transl_unop_correct; eauto. - (* binop *) @@ -1253,31 +1334,43 @@ Proof. rewrite (transl_alignof _ _ _ _ LINK EQ). apply make_ptrofsconst_correct. - (* rvalue out of lvalue *) exploit transl_expr_lvalue; eauto. intros [tb [TRLVAL MKLOAD]]. + apply H0 in TRLVAL; destruct TRLVAL. eapply make_load_correct; eauto. - (* var local *) exploit (me_local _ _ MENV); eauto. intros EQ. - econstructor. eapply eval_var_addr_local. eauto. + split; auto. econstructor. eapply eval_var_addr_local. eauto. - (* var global *) - econstructor. eapply eval_var_addr_global. + split; auto. econstructor. eapply eval_var_addr_global. eapply match_env_globals; eauto. rewrite symbols_preserved. auto. - (* deref *) - simpl in TR. eauto. + eauto. - (* field struct *) unfold make_field_access in EQ0. rewrite H1 in EQ0. - destruct (prog_comp_env cunit)!id as [co'|] eqn:CO; monadInv EQ0. + destruct (prog_comp_env cunit)!id as [co'|] eqn:CO; try discriminate; monadInv EQ0. exploit field_offset_stable. eexact LINK. eauto. instantiate (1 := i). intros [A B]. - rewrite <- B in EQ1. + rewrite <- B in EQ1. assert (x0 = delta) by (unfold ge in *; simpl in *; congruence). - subst x0. + assert (bf' = bf) by (unfold ge in *; simpl in *; congruence). + subst x0 bf'. split; auto. destruct Archi.ptr64 eqn:SF. + eapply eval_Ebinop; eauto using make_longconst_correct. simpl. rewrite SF. apply f_equal. apply f_equal. apply f_equal. auto with ptrofs. + eapply eval_Ebinop; eauto using make_intconst_correct. simpl. rewrite SF. apply f_equal. apply f_equal. apply f_equal. auto with ptrofs. - (* field union *) - unfold make_field_access in EQ0; rewrite H1 in EQ0; monadInv EQ0. - auto. + unfold make_field_access in EQ0. rewrite H1 in EQ0. + destruct (prog_comp_env cunit)!id as [co'|] eqn:CO; try discriminate; monadInv EQ0. + exploit union_field_offset_stable. eexact LINK. eauto. instantiate (1 := i). intros [A B]. + rewrite <- B in EQ1. + assert (x0 = delta) by (unfold ge in *; simpl in *; congruence). + assert (bf' = bf) by (unfold ge in *; simpl in *; congruence). + subst x0 bf'. split; auto. + destruct Archi.ptr64 eqn:SF. ++ eapply eval_Ebinop; eauto using make_longconst_correct. + simpl. rewrite SF. apply f_equal. apply f_equal. apply f_equal. auto with ptrofs. ++ eapply eval_Ebinop; eauto using make_intconst_correct. + simpl. rewrite SF. apply f_equal. apply f_equal. apply f_equal. auto with ptrofs. Qed. Lemma transl_expr_correct: @@ -1288,10 +1381,10 @@ Lemma transl_expr_correct: Proof (proj1 transl_expr_lvalue_correct). Lemma transl_lvalue_correct: - forall a b ofs, - Clight.eval_lvalue ge e le m a b ofs -> - forall ta, transl_lvalue cunit.(prog_comp_env) a = OK ta -> - Csharpminor.eval_expr tge te le m ta (Vptr b ofs). + forall a b ofs bf, + Clight.eval_lvalue ge e le m a b ofs bf -> + forall ta bf', transl_lvalue cunit.(prog_comp_env) a = OK (ta, bf') -> + bf = bf' /\ Csharpminor.eval_expr tge te le m ta (Vptr b ofs). Proof (proj2 transl_expr_lvalue_correct). Lemma transl_arglist_correct: @@ -1474,7 +1567,11 @@ Proof. auto. - (* assign *) unfold make_store, make_memcpy in EQ3. + destruct x0. destruct (access_mode (typeof e)); monadInv EQ3; auto. + unfold make_store_bitfield in EQ3. + destruct (zle 0 pos && zlt 0 width && zle (pos + width) (bitsize_carrier sz)); + monadInv EQ3; auto. - (* set *) auto. - (* call *) @@ -1574,11 +1671,17 @@ Proof. assert (SAME: ts' = ts /\ tk' = tk). { inversion MTR. auto. subst ts. unfold make_store, make_memcpy in EQ3. - destruct (access_mode (typeof a1)); monadInv EQ3; auto. } + destruct x0. + destruct (access_mode (typeof a1)); monadInv EQ3; auto. + unfold make_store_bitfield in EQ3. + destruct (zle 0 pos && zlt 0 width && zle (pos + width) (bitsize_carrier sz)); + monadInv EQ3; auto. + } destruct SAME; subst ts' tk'. + exploit transl_lvalue_correct; eauto. intros [A B]; subst x0. econstructor; split. apply plus_one. eapply make_store_correct; eauto. - eapply transl_lvalue_correct; eauto. eapply make_cast_correct; eauto. + eapply make_cast_correct; eauto. eapply transl_expr_correct; eauto. eapply match_states_skip; eauto. diff --git a/cfrontend/Cstrategy.v b/cfrontend/Cstrategy.v index 6365f85c..ce965672 100644 --- a/cfrontend/Cstrategy.v +++ b/cfrontend/Cstrategy.v @@ -49,7 +49,7 @@ Variable ge: genv. Fixpoint simple (a: expr) : bool := match a with - | Eloc _ _ _ => true + | Eloc _ _ _ _ => true | Evar _ _ => true | Ederef r _ => simple r | Efield r _ _ => simple r @@ -86,41 +86,42 @@ Section SIMPLE_EXPRS. Variable e: env. Variable m: mem. -Inductive eval_simple_lvalue: expr -> block -> ptrofs -> Prop := - | esl_loc: forall b ofs ty, - eval_simple_lvalue (Eloc b ofs ty) b ofs +Inductive eval_simple_lvalue: expr -> block -> ptrofs -> bitfield -> Prop := + | esl_loc: forall b ofs ty bf, + eval_simple_lvalue (Eloc b ofs bf ty) b ofs bf | esl_var_local: forall x ty b, e!x = Some(b, ty) -> - eval_simple_lvalue (Evar x ty) b Ptrofs.zero + eval_simple_lvalue (Evar x ty) b Ptrofs.zero Full | esl_var_global: forall x ty b, e!x = None -> Genv.find_symbol ge x = Some b -> - eval_simple_lvalue (Evar x ty) b Ptrofs.zero + eval_simple_lvalue (Evar x ty) b Ptrofs.zero Full | 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 r f ty b ofs id co a delta, + eval_simple_lvalue (Ederef r ty) b ofs Full + | esl_field_struct: forall r f ty b ofs id co a delta bf, eval_simple_rvalue r (Vptr b ofs) -> typeof r = Tstruct id a -> ge.(genv_cenv)!id = Some co -> - field_offset ge f (co_members co) = OK delta -> - eval_simple_lvalue (Efield r f ty) b (Ptrofs.add ofs (Ptrofs.repr delta)) - | esl_field_union: forall r f ty b ofs id co a, + field_offset ge f (co_members co) = OK (delta, bf) -> + eval_simple_lvalue (Efield r f ty) b (Ptrofs.add ofs (Ptrofs.repr delta)) bf + | esl_field_union: forall r f ty b ofs id co a delta bf, eval_simple_rvalue r (Vptr b ofs) -> typeof r = Tunion id a -> + union_field_offset ge f (co_members co) = OK (delta, bf) -> ge.(genv_cenv)!id = Some co -> - eval_simple_lvalue (Efield r f ty) b ofs + eval_simple_lvalue (Efield r f ty) b (Ptrofs.add ofs (Ptrofs.repr delta)) bf 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 -> + | esr_rvalof: forall b ofs bf l ty v, + eval_simple_lvalue l b ofs bf -> ty = typeof l -> type_is_volatile ty = false -> - deref_loc ge ty m b ofs E0 v -> + deref_loc ge ty m b ofs bf E0 v -> eval_simple_rvalue (Evalof l ty) v | esr_addrof: forall b ofs l ty, - eval_simple_lvalue l b ofs -> + eval_simple_lvalue l b ofs Full -> eval_simple_rvalue (Eaddrof l ty) (Vptr b ofs) | esr_unop: forall op r1 ty v1 v, eval_simple_rvalue r1 v1 -> @@ -240,10 +241,10 @@ 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, + | step_rvalof_volatile: forall f C l ty k e m b ofs bf t v, leftcontext RV RV C -> - eval_simple_lvalue e m l b ofs -> - deref_loc ge ty m b ofs t v -> + eval_simple_lvalue e m l b ofs bf -> + deref_loc ge ty m b ofs bf 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) @@ -281,68 +282,68 @@ 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 ty)) k e m) - | step_assign: forall f C l r ty k e m b ofs v v' t m', + | step_assign: forall f C l r ty k e m b ofs bf v v1 t m' v', leftcontext RV RV C -> - eval_simple_lvalue e m l b ofs -> + eval_simple_lvalue e m l b ofs bf -> eval_simple_rvalue e m r v -> - sem_cast v (typeof r) (typeof l) m = Some v' -> - assign_loc ge (typeof l) m b ofs v' t m' -> + sem_cast v (typeof r) (typeof l) m = Some v1 -> + assign_loc ge (typeof l) m b ofs bf v1 t m' v' -> ty = typeof l -> estep (ExprState f (C (Eassign l r 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 t1 t2 m' t, + | step_assignop: forall f C op l r tyres ty k e m b ofs bf v1 v2 v3 v4 t1 t2 m' v' t, leftcontext RV RV C -> - eval_simple_lvalue e m l b ofs -> - deref_loc ge (typeof l) m b ofs t1 v1 -> + eval_simple_lvalue e m l b ofs bf -> + deref_loc ge (typeof l) m b ofs bf t1 v1 -> eval_simple_rvalue e m r v2 -> sem_binary_operation ge op v1 (typeof l) v2 (typeof r) m = Some v3 -> sem_cast v3 tyres (typeof l) m = Some v4 -> - assign_loc ge (typeof l) m b ofs v4 t2 m' -> + assign_loc ge (typeof l) m b ofs bf v4 t2 m' v' -> ty = typeof l -> t = t1 ** t2 -> estep (ExprState f (C (Eassignop op l r tyres ty)) k e m) - t (ExprState f (C (Eval v4 ty)) k e m') + t (ExprState f (C (Eval v' ty)) k e m') - | step_assignop_stuck: forall f C op l r tyres ty k e m b ofs v1 v2 t, + | step_assignop_stuck: forall f C op l r tyres ty k e m b ofs bf v1 v2 t, leftcontext RV RV C -> - eval_simple_lvalue e m l b ofs -> - deref_loc ge (typeof l) m b ofs t v1 -> + eval_simple_lvalue e m l b ofs bf -> + deref_loc ge (typeof l) m b ofs bf t v1 -> eval_simple_rvalue e m r v2 -> match sem_binary_operation ge op v1 (typeof l) v2 (typeof r) m with | None => True | Some v3 => match sem_cast v3 tyres (typeof l) m with | None => True - | Some v4 => forall t2 m', ~(assign_loc ge (typeof l) m b ofs v4 t2 m') + | Some v4 => forall t2 m' v', ~(assign_loc ge (typeof l) m b ofs bf v4 t2 m' v') 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, + | step_postincr: forall f C id l ty k e m b ofs bf v1 v2 v3 t1 t2 m' v' t, leftcontext RV RV C -> - eval_simple_lvalue e m l b ofs -> - deref_loc ge ty m b ofs t1 v1 -> + eval_simple_lvalue e m l b ofs bf -> + deref_loc ge ty m b ofs bf t1 v1 -> sem_incrdecr ge id v1 ty m = Some v2 -> sem_cast v2 (incrdecr_type ty) ty m = Some v3 -> - assign_loc ge ty m b ofs v3 t2 m' -> + assign_loc ge ty m b ofs bf v3 t2 m' v' -> 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, + | step_postincr_stuck: forall f C id l ty k e m b ofs bf v1 t, leftcontext RV RV C -> - eval_simple_lvalue e m l b ofs -> - deref_loc ge ty m b ofs t v1 -> + eval_simple_lvalue e m l b ofs bf -> + deref_loc ge ty m b ofs bf t v1 -> match sem_incrdecr ge id v1 ty m with | None => True | Some v2 => match sem_cast v2 (incrdecr_type ty) ty m with | None => True - | Some v3 => forall t2 m', ~(assign_loc ge (typeof l) m b ofs v3 t2 m') + | Some v3 => forall t2 m' v', ~(assign_loc ge (typeof l) m b ofs bf v3 t2 m' v') end end -> ty = typeof l -> @@ -452,7 +453,7 @@ Qed. Definition expr_kind (a: expr) : kind := match a with - | Eloc _ _ _ => LV + | Eloc _ _ _ _ => LV | Evar _ _ => LV | Ederef _ _ => LV | Efield _ _ _ => LV @@ -518,23 +519,25 @@ Fixpoint exprlist_all_values (rl: exprlist) : Prop := Definition invert_expr_prop (a: expr) (m: mem) : Prop := match a with - | Eloc b ofs ty => False + | Eloc b ofs bf ty => False | Evar x ty => exists b, e!x = Some(b, ty) \/ (e!x = None /\ Genv.find_symbol ge x = Some b) | Ederef (Eval v ty1) ty => exists b, exists ofs, v = Vptr b ofs + | Eaddrof (Eloc b ofs bf ty) ty' => + bf = Full | Efield (Eval v ty1) f ty => exists b, exists ofs, v = Vptr b ofs /\ match ty1 with - | Tstruct id _ => exists co delta, ge.(genv_cenv)!id = Some co /\ field_offset ge f (co_members co) = Errors.OK delta - | Tunion id _ => exists co, ge.(genv_cenv)!id = Some co + | Tstruct id _ => exists co delta bf, ge.(genv_cenv)!id = Some co /\ field_offset ge f (co_members co) = Errors.OK (delta, bf) + | Tunion id _ => exists co delta bf, ge.(genv_cenv)!id = Some co /\ union_field_offset ge f (co_members co) = Errors.OK (delta, bf) | _ => False end | Eval v ty => False - | Evalof (Eloc b ofs ty') ty => - ty' = ty /\ exists t, exists v, deref_loc ge ty m b ofs t v + | Evalof (Eloc b ofs bf ty') ty => + ty' = ty /\ exists t, exists v, deref_loc ge ty m b ofs bf t v | Eunop op (Eval v1 ty1) ty => exists v, sem_unary_operation op v1 ty1 m = Some v | Ebinop op (Eval v1 ty1) (Eval v2 ty2) ty => @@ -547,17 +550,17 @@ Definition invert_expr_prop (a: expr) (m: mem) : Prop := exists b, bool_val v1 ty1 m = Some b | Econdition (Eval v1 ty1) r1 r2 ty => exists b, bool_val v1 ty1 m = Some b - | Eassign (Eloc b ofs ty1) (Eval v2 ty2) ty => - exists v, exists m', exists t, - ty = ty1 /\ sem_cast v2 ty2 ty1 m = Some v /\ assign_loc ge ty1 m b ofs v t m' - | Eassignop op (Eloc b ofs ty1) (Eval v2 ty2) tyres ty => - exists t, exists v1, + | Eassign (Eloc b ofs bf ty1) (Eval v2 ty2) ty => + exists v m' v' t, + ty = ty1 /\ sem_cast v2 ty2 ty1 m = Some v /\ assign_loc ge ty1 m b ofs bf v t m' v' + | Eassignop op (Eloc b ofs bf ty1) (Eval v2 ty2) tyres ty => + exists t v1, ty = ty1 - /\ deref_loc ge ty1 m b ofs t v1 - | Epostincr id (Eloc b ofs ty1) ty => - exists t, exists v1, + /\ deref_loc ge ty1 m b ofs bf t v1 + | Epostincr id (Eloc b ofs bf ty1) ty => + exists t v1, ty = ty1 - /\ deref_loc ge ty m b ofs t v1 + /\ deref_loc ge ty m b ofs bf t v1 | Ecomma (Eval v ty1) r2 ty => typeof r2 = ty | Eparen (Eval v1 ty1) ty2 ty => @@ -584,8 +587,8 @@ Proof. exists b; auto. exists b; auto. exists b; exists ofs; auto. - exists b; exists ofs; split; auto. exists co, delta; auto. - exists b; exists ofs; split; auto. exists co; auto. + exists b; exists ofs; split; auto. exists co, delta, bf; auto. + exists b; exists ofs; split; auto. exists co, delta, bf; auto. Qed. Lemma rred_invert: @@ -599,7 +602,7 @@ Proof. exists true; auto. exists false; auto. exists true; auto. exists false; auto. exists b; auto. - exists v; exists m'; exists t; auto. + exists v; exists m'; exists v'; exists t; auto. exists t; exists v1; auto. exists t; exists v1; auto. exists v; auto. @@ -634,7 +637,7 @@ Proof. 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 (C a); auto; contradiction. destruct e1; auto; destruct (C a); auto; contradiction. @@ -660,7 +663,7 @@ Lemma imm_safe_inv: forall k a m, imm_safe ge e k a m -> match a with - | Eloc _ _ _ => True + | Eloc _ _ _ _ => True | Eval _ _ => True | _ => invert_expr_prop a m end. @@ -685,7 +688,7 @@ Lemma safe_inv: safe (ExprState f (C a) K e m) -> context k RV C -> match a with - | Eloc _ _ _ => True + | Eloc _ _ _ _ => True | Eval _ _ => True | _ => invert_expr_prop a m end. @@ -709,10 +712,10 @@ Lemma eval_simple_steps: 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 a b ofs bf, eval_simple_lvalue e m a b ofs bf -> 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)). + E0 (ExprState f (C (Eloc b ofs bf (typeof a))) k e m)). Proof. Ltac Steps REC C' := eapply star_trans; [apply (REC C'); eauto | idtac | simpl; reflexivity]. @@ -760,10 +763,10 @@ Lemma eval_simple_rvalue_steps: Proof (proj1 eval_simple_steps). Lemma eval_simple_lvalue_steps: - forall a b ofs, eval_simple_lvalue e m a b ofs -> + forall a b ofs bf, eval_simple_lvalue e m a b ofs bf -> 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). + E0 (ExprState f (C (Eloc b ofs bf (typeof a))) k e m). Proof (proj2 eval_simple_steps). Corollary eval_simple_rvalue_safe: @@ -776,10 +779,10 @@ Proof. Qed. Corollary eval_simple_lvalue_safe: - forall C a b ofs, - eval_simple_lvalue e m a b ofs -> + forall C a b ofs bf, + eval_simple_lvalue e m a b ofs bf -> context LV RV C -> safe (ExprState f (C a) k e m) -> - safe (ExprState f (C (Eloc b ofs (typeof a))) k e m). + safe (ExprState f (C (Eloc b ofs bf (typeof a))) k e m). Proof. intros. eapply safe_steps; eauto. eapply eval_simple_lvalue_steps; eauto. Qed. @@ -788,15 +791,15 @@ Lemma simple_can_eval: forall a from C, simple a = true -> context from RV C -> safe (ExprState f (C a) k e m) -> match from with - | LV => exists b, exists ofs, eval_simple_lvalue e m a b ofs + | LV => exists b ofs bf, eval_simple_lvalue e m a b ofs bf | RV => exists v, eval_simple_rvalue e m a v end. Proof. Ltac StepL REC C' a := - let b := fresh "b" in let ofs := fresh "ofs" in + let b := fresh "b" in let ofs := fresh "ofs" in let bf := fresh "bf" in let E := fresh "E" in let S := fresh "SAFE" in - exploit (REC LV C'); eauto; intros [b [ofs E]]; - assert (S: safe (ExprState f (C' (Eloc b ofs (typeof a))) k e m)) by + exploit (REC LV C'); eauto; intros (b & ofs & bf & E); + assert (S: safe (ExprState f (C' (Eloc b ofs bf (typeof a))) k e m)) by (eapply (eval_simple_lvalue_safe C'); eauto); simpl in S. Ltac StepR REC C' a := @@ -809,51 +812,52 @@ Ltac StepR REC C' a := induction a; intros from C S CTX SAFE; generalize (safe_expr_kind _ _ _ _ _ _ _ CTX SAFE); intro K; subst; simpl in S; try discriminate; simpl. -(* val *) +- (* val *) exists v; constructor. -(* var *) +- (* var *) exploit safe_inv; eauto; simpl. intros [b A]. - exists b; exists Ptrofs.zero. + exists b, Ptrofs.zero, Full. intuition. apply esl_var_local; auto. apply esl_var_global; auto. -(* field *) +- (* field *) 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) eqn:?; try contradiction. - destruct TY as (co & delta & CE & OFS). exists b; exists (Ptrofs.add ofs (Ptrofs.repr delta)); econstructor; eauto. - destruct TY as (co & CE). exists b; exists ofs; econstructor; eauto. -(* valof *) + destruct TY as (co & delta & bf & CE & OFS). exists b, (Ptrofs.add ofs (Ptrofs.repr delta)), bf; eapply esl_field_struct; eauto. + destruct TY as (co & delta & bf & CE & OFS). exists b, (Ptrofs.add ofs (Ptrofs.repr delta)), bf; eapply esl_field_union; eauto. +- (* valof *) destruct (andb_prop _ _ S) as [S1 S2]. clear S. rewrite negb_true_iff in S2. 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 *) +- (* deref *) StepR IHa (fun x => C(Ederef x ty)) a. exploit safe_inv. eexact SAFE0. eauto. simpl. intros [b [ofs EQ]]. - subst v. exists b; exists ofs; econstructor; eauto. -(* addrof *) + subst v. exists b, ofs, Full; econstructor; eauto. +- (* addrof *) StepL IHa (fun x => C(Eaddrof x ty)) a. + exploit safe_inv. eexact SAFE0. eauto. simpl. intros EQ; subst bf. exists (Vptr b ofs); econstructor; eauto. -(* unop *) +- (* unop *) StepR IHa (fun x => C(Eunop op x ty)) a. exploit safe_inv. eexact SAFE0. eauto. simpl. intros [v' EQ]. exists v'; econstructor; eauto. -(* binop *) +- (* binop *) destruct (andb_prop _ _ S) as [S1 S2]; clear S. StepR IHa1 (fun x => C(Ebinop op x a2 ty)) a1. StepR IHa2 (fun x => C(Ebinop op (Eval v (typeof a1)) x ty)) a2. exploit safe_inv. eexact SAFE1. eauto. simpl. intros [v' EQ]. exists v'; econstructor; eauto. -(* cast *) +- (* cast *) StepR IHa (fun x => C(Ecast x ty)) a. exploit safe_inv. eexact SAFE0. eauto. simpl. intros [v' CAST]. exists v'; econstructor; eauto. -(* sizeof *) +- (* sizeof *) econstructor; econstructor. -(* alignof *) +- (* alignof *) econstructor; econstructor. -(* loc *) - exists b; exists ofs; constructor. +- (* loc *) + exists b, ofs, bf; constructor. Qed. Lemma simple_can_eval_rval: @@ -869,11 +873,11 @@ Qed. Lemma simple_can_eval_lval: forall l C, simple l = true -> context LV RV C -> safe (ExprState f (C l) k e m) -> - exists b, exists ofs, eval_simple_lvalue e m l b ofs - /\ safe (ExprState f (C (Eloc b ofs (typeof l))) k e m). + exists b ofs bf, eval_simple_lvalue e m l b ofs bf + /\ safe (ExprState f (C (Eloc b ofs bf (typeof l))) k e m). Proof. - intros. exploit (simple_can_eval l LV); eauto. intros [b [ofs A]]. - exists b; exists ofs; split; auto. eapply eval_simple_lvalue_safe; eauto. + intros. exploit (simple_can_eval l LV); eauto. intros (b & ofs & bf & A). + exists b, ofs, bf; split; auto. eapply eval_simple_lvalue_safe; eauto. Qed. Fixpoint rval_list (vl: list val) (rl: exprlist) : exprlist := @@ -1178,18 +1182,18 @@ Proof. eapply star_plus_trans. eapply eval_simple_lvalue_steps with (C := fun x => C(Eassign x r (typeof l))); eauto. eapply plus_right. - eapply eval_simple_rvalue_steps with (C := fun x => C(Eassign (Eloc b ofs (typeof l)) x (typeof l))); eauto. + eapply eval_simple_rvalue_steps with (C := fun x => C(Eassign (Eloc b ofs bf (typeof l)) x (typeof l))); eauto. left; apply step_rred; eauto. econstructor; eauto. reflexivity. auto. (* assignop *) 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 eval_simple_rvalue_steps with (C := fun x => C(Eassignop op (Eloc b ofs bf (typeof l)) x tyres (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(Eassign (Eloc b ofs (typeof l)) x (typeof l))); eauto. econstructor; eauto. + left; apply step_rred with (C := fun x => C(Eassign (Eloc b ofs bf (typeof l)) x (typeof l))); eauto. econstructor; eauto. apply star_one. left; apply step_rred; auto. econstructor; eauto. reflexivity. reflexivity. reflexivity. traceEq. @@ -1197,19 +1201,19 @@ Proof. 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 eval_simple_rvalue_steps with (C := fun x => C(Eassignop op (Eloc b ofs bf (typeof l)) x tyres (typeof l))); eauto. eapply plus_left. left; apply step_rred; auto. econstructor; eauto. destruct (sem_binary_operation ge 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. + left; apply step_rred with (C := fun x => C(Eassign (Eloc b ofs bf (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]]]]]. + red; intros. exploit imm_safe_inv; eauto. simpl. intros [v4' [m' [v' [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. + left; eapply step_stuck with (C := fun x => C(Eassign (Eloc b ofs bf (typeof l)) x (typeof l))); eauto. red; intros. exploit imm_safe_inv; eauto. simpl. intros [v3 A]. congruence. reflexivity. reflexivity. traceEq. @@ -1219,7 +1223,7 @@ Proof. 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. + left; apply step_rred with (C := fun x => C (Ecomma (Eassign (Eloc b ofs bf (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. @@ -1238,15 +1242,15 @@ Proof. destruct id; auto. destruct (sem_incrdecr ge id v1 (typeof l) m) 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. + left; apply step_rred with (C := fun x => C (Ecomma (Eassign (Eloc b ofs bf (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]]]]]. + red; intros. exploit imm_safe_inv; eauto. simpl. intros [v3 [m' [v' [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. + left; eapply step_stuck with (C := fun x => C (Ecomma (Eassign (Eloc b ofs bf (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. @@ -1291,7 +1295,7 @@ Proof. (* 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]]]. + intros (b1 & ofs & bf & E1 & S1). exploit safe_inv. eexact S1. eauto. simpl. intros [A [t [v B]]]. econstructor; econstructor; eapply step_rvalof_volatile; eauto. congruence. (* seqand *) @@ -1316,40 +1320,40 @@ Proof. (* 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 (b & ofs & bf & E1 & S1). + exploit (simple_can_eval_rval f k e m b2 (fun x => C(Eassign (Eloc b ofs bf (typeof b1)) x ty))); eauto. intros [v [E2 S2]]. - exploit safe_inv. eexact S2. eauto. simpl. intros [v' [m' [t [A [B D]]]]]. + exploit safe_inv. eexact S2. eauto. simpl. intros [v1 [m' [v' [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 (b & ofs & bf & E1 & S1). + exploit (simple_can_eval_rval f k e m b2 (fun x => C(Eassignop op (Eloc b ofs bf (typeof b1)) x tyres ty))); eauto. intros [v [E2 S2]]. exploit safe_inv. eexact S2. eauto. simpl. intros [t1 [v1 [A B]]]. destruct (sem_binary_operation ge op v1 (typeof b1) v (typeof b2) m) as [v3|] eqn:?. destruct (sem_cast v3 tyres (typeof b1) m) 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]]. + destruct (classic (exists t2 m' v', assign_loc ge (typeof b1) m b ofs bf v4 t2 m' v')). + destruct H2 as [t2 [m' [v' 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. + rewrite Heqo. rewrite Heqo0. intros; red; intros. elim H2. exists t2, m', v'; 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]]]. + intros (b1 & ofs & bf & E1 & S1). exploit safe_inv. eexact S1. eauto. simpl. intros [t [v1 [A B]]]. destruct (sem_incrdecr ge id v1 ty m) as [v2|] eqn:?. destruct (sem_cast v2 (incrdecr_type ty) ty m) 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]]. + destruct (classic (exists t2 m' v', assign_loc ge ty m b1 ofs bf v3 t2 m' v')). + destruct H0 as [t2 [m' [v' 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. + rewrite Heqo. rewrite Heqo0. intros; red; intros. elim H0. exists t2, m', v'; congruence. econstructor; econstructor; eapply step_postincr_stuck; eauto. rewrite Heqo. rewrite Heqo0. auto. econstructor; econstructor; eapply step_postincr_stuck; eauto. @@ -1440,18 +1444,18 @@ Definition semantics (p: program) := (** This semantics is receptive to changes in events. *) Remark deref_loc_trace: - forall ge ty m b ofs t v, - deref_loc ge ty m b ofs t v -> + forall ge ty m b ofs bf t v, + deref_loc ge ty m b ofs bf 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 ge ty m b ofs ev1 t1 v ev2, - deref_loc ge ty m b ofs (ev1 :: t1) v -> + forall ge ty m b ofs bf ev1 t1 v ev2, + deref_loc ge ty m b ofs bf (ev1 :: t1) v -> match_traces ge (ev1 :: nil) (ev2 :: nil) -> - t1 = nil /\ exists v', deref_loc ge ty m b ofs (ev2 :: nil) v'. + t1 = nil /\ exists v', deref_loc ge ty m b ofs bf (ev2 :: nil) v'. Proof. intros. assert (t1 = nil). exploit deref_loc_trace; eauto. destruct t1; simpl; tauto. @@ -1460,16 +1464,16 @@ Proof. Qed. Remark assign_loc_trace: - forall ge ty m b ofs t v m', - assign_loc ge ty m b ofs v t m' -> + forall ge ty m b ofs bf t v m' v', + assign_loc ge ty m b ofs bf v t m' v' -> 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 ge ty m b ofs ev1 t1 v m' ev2, - assign_loc ge ty m b ofs v (ev1 :: t1) m' -> + forall ge ty m b ofs bf ev1 t1 v m' v' ev2, + assign_loc ge ty m b ofs bf v (ev1 :: t1) m' v' -> match_traces ge (ev1 :: nil) (ev2 :: nil) -> ev1 :: t1 = ev2 :: nil. Proof. @@ -1499,11 +1503,11 @@ Proof. inv H10. exploit deref_loc_receptive; eauto. intros [EQ [v1' A]]. subst t0. destruct (sem_binary_operation ge op v1' (typeof l) v2 (typeof r) m) as [v3'|] eqn:?. destruct (sem_cast v3' tyres (typeof l) m) as [v4'|] eqn:?. - destruct (classic (exists t2', exists m'', assign_loc ge (typeof l) m b ofs v4' t2' m'')). - destruct H1 as [t2' [m'' P]]. + destruct (classic (exists t2' m'' v'', assign_loc ge (typeof l) m b ofs bf v4' t2' m'' v'')). + destruct H1 as [t2' [m'' [v'' 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. + rewrite Heqo; rewrite Heqo0. intros; red; intros; elim H1. exists t0, m'0, v'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. @@ -1512,11 +1516,11 @@ Proof. exploit deref_loc_receptive; eauto. intros [EQ [v1' A]]. subst t1. destruct (sem_binary_operation ge op v1' (typeof l) v2 (typeof r) m) as [v3'|] eqn:?. destruct (sem_cast v3' tyres (typeof l) m) as [v4'|] eqn:?. - destruct (classic (exists t2', exists m'', assign_loc ge (typeof l) m b ofs v4' t2' m'')). - destruct H1 as [t2' [m'' P]]. + destruct (classic (exists t2' m'' v'', assign_loc ge (typeof l) m b ofs bf v4' t2' m'' v'')). + destruct H1 as [t2' [m'' [v'' 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. + rewrite Heqo; rewrite Heqo0. intros; red; intros; elim H1. exists t2, m', v'; 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. @@ -1528,11 +1532,11 @@ Proof. inv H9. exploit deref_loc_receptive; eauto. intros [EQ [v1' A]]. subst t0. destruct (sem_incrdecr ge id v1' (typeof l) m) as [v2'|] eqn:?. destruct (sem_cast v2' (incrdecr_type (typeof l)) (typeof l) m) as [v3'|] eqn:?. - destruct (classic (exists t2', exists m'', assign_loc ge (typeof l) m b ofs v3' t2' m'')). - destruct H1 as [t2' [m'' P]]. + destruct (classic (exists t2' m'' v'', assign_loc ge (typeof l) m b ofs bf v3' t2' m'' v'')). + destruct H1 as [t2' [m'' [v'' 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. + rewrite Heqo; rewrite Heqo0. intros; red; intros; elim H1. exists t0, m'0, v'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. @@ -1541,11 +1545,11 @@ Proof. exploit deref_loc_receptive; eauto. intros [EQ [v1' A]]. subst t1. destruct (sem_incrdecr ge id v1' (typeof l) m) as [v2'|] eqn:?. destruct (sem_cast v2' (incrdecr_type (typeof l)) (typeof l) m) as [v3'|] eqn:?. - destruct (classic (exists t2', exists m'', assign_loc ge (typeof l) m b ofs v3' t2' m'')). - destruct H1 as [t2' [m'' P]]. + destruct (classic (exists t2' m'' v'', assign_loc ge (typeof l) m b ofs bf v3' t2' m'' v'')). + destruct H1 as [t2' [m'' [v'' 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. + rewrite Heqo; rewrite Heqo0. intros; red; intros; elim H1. exists t2, m', v'; 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. @@ -1671,11 +1675,11 @@ with eval_expr: env -> mem -> kind -> expr -> trace -> mem -> expr -> Prop := 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, + | eval_valof_volatile: forall e m a t1 m' a' ty b ofs bf 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 -> + eval_simple_lvalue ge e m' a' b ofs bf -> + deref_loc ge (typeof a) m' b ofs bf 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, @@ -1723,32 +1727,32 @@ with eval_expr: env -> mem -> kind -> expr -> trace -> mem -> expr -> Prop := eval_expr e m RV (Esizeof ty' ty) E0 m (Esizeof ty' ty) | eval_alignof: forall e m ty' ty, eval_expr e m RV (Ealignof ty' ty) E0 m (Ealignof ty' ty) - | eval_assign: forall e m l r ty t1 m1 l' t2 m2 r' b ofs v v' t3 m3, + | eval_assign: forall e m l r ty t1 m1 l' t2 m2 r' b ofs bf v v1 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_lvalue ge e m2 l' b ofs bf -> eval_simple_rvalue ge e m2 r' v -> - sem_cast v (typeof r) (typeof l) m2 = Some v' -> - assign_loc ge (typeof l) m2 b ofs v' t3 m3 -> + sem_cast v (typeof r) (typeof l) m2 = Some v1 -> + assign_loc ge (typeof l) m2 b ofs bf v1 t3 m3 v' -> ty = typeof l -> 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 t3 t4 m3, + | eval_assignop: forall e m op l r tyres ty t1 m1 l' t2 m2 r' b ofs bf + v1 v2 v3 v4 v' 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 -> - deref_loc ge (typeof l) m2 b ofs t3 v1 -> + eval_simple_lvalue ge e m2 l' b ofs bf -> + deref_loc ge (typeof l) m2 b ofs bf t3 v1 -> eval_simple_rvalue ge e m2 r' v2 -> sem_binary_operation ge op v1 (typeof l) v2 (typeof r) m2 = Some v3 -> sem_cast v3 tyres (typeof l) m2 = Some v4 -> - assign_loc ge (typeof l) m2 b ofs v4 t4 m3 -> + assign_loc ge (typeof l) m2 b ofs bf v4 t4 m3 v' -> ty = typeof 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 RV (Eassignop op l r tyres ty) (t1**t2**t3**t4) m3 (Eval v' ty) + | eval_postincr: forall e m id l ty t1 m1 l' b ofs bf v1 v2 v3 v' m2 t2 t3, eval_expr e m LV l t1 m1 l' -> - eval_simple_lvalue ge e m1 l' b ofs -> - deref_loc ge ty m1 b ofs t2 v1 -> + eval_simple_lvalue ge e m1 l' b ofs bf -> + deref_loc ge ty m1 b ofs bf t2 v1 -> sem_incrdecr ge id v1 ty m1 = Some v2 -> sem_cast v2 (incrdecr_type ty) ty m1 = Some v3 -> - assign_loc ge ty m1 b ofs v3 t3 m2 -> + assign_loc ge ty m1 b ofs bf v3 t3 m2 v' -> ty = typeof l -> 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', @@ -2311,7 +2315,7 @@ Proof. simpl; intuition. eapply star_trans. eexact D. eapply star_right. eexact G. - left. eapply step_assign; eauto. congruence. rewrite B; eauto. congruence. + left. eapply step_assign with (v1 := v1); eauto. congruence. rewrite B; eauto. congruence. reflexivity. traceEq. (* assignop *) exploit (H0 (fun x => C(Eassignop op x r tyres ty))). @@ -2322,7 +2326,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. rewrite B; eauto. congruence. + rewrite B; eauto. rewrite B; rewrite F; eauto. rewrite B; eauto. rewrite B; eauto. congruence. reflexivity. traceEq. (* postincr *) exploit (H0 (fun x => C(Epostincr id x ty))). @@ -2656,7 +2660,7 @@ Proof (proj2 (proj2 (proj2 (proj2 bigstep_to_steps)))). Fixpoint esize (a: expr) : nat := match a with - | Eloc _ _ _ => 1%nat + | Eloc _ _ _ _ => 1%nat | Evar _ _ => 1%nat | Ederef r1 _ => S(esize r1) | Efield l1 _ _ => S(esize l1) diff --git a/cfrontend/Csyntax.v b/cfrontend/Csyntax.v index 19bc2ec3..5b8a62be 100644 --- a/cfrontend/Csyntax.v +++ b/cfrontend/Csyntax.v @@ -56,7 +56,7 @@ Inductive expr : Type := (**r function call [r1(rargs)] *) | Ebuiltin (ef: external_function) (tyargs: typelist) (rargs: exprlist) (ty: type) (**r builtin function call *) - | Eloc (b: block) (ofs: ptrofs) (ty: type) + | Eloc (b: block) (ofs: ptrofs) (bf: bitfield) (ty: type) (**r memory location, result of evaluating a l-value *) | Eparen (r: expr) (tycast: type) (ty: type) (**r marked subexpression *) @@ -117,7 +117,7 @@ Definition Eselection (r1 r2 r3: expr) (ty: type) := Definition typeof (a: expr) : type := match a with - | Eloc _ _ ty => ty + | Eloc _ _ _ ty => ty | Evar _ ty => ty | Ederef _ ty => ty | Efield _ _ ty => ty diff --git a/cfrontend/Ctypes.v b/cfrontend/Ctypes.v index bcd8d350..e3356510 100644 --- a/cfrontend/Ctypes.v +++ b/cfrontend/Ctypes.v @@ -20,6 +20,10 @@ Require Import Axioms Coqlib Maps Errors. Require Import AST Linking. Require Archi. +Set Asymmetric Patterns. + +Local Open Scope error_monad_scope. + (** * Syntax of types *) (** Compcert C types are similar to those of C. They include numeric types, @@ -84,21 +88,28 @@ Proof. decide equality. Defined. +Lemma signedness_eq: forall (s1 s2: signedness), {s1=s2} + {s1<>s2}. +Proof. + decide equality. +Defined. + +Lemma attr_eq: forall (a1 a2: attr), {a1=a2} + {a1<>a2}. +Proof. + decide equality. decide equality. apply N.eq_dec. apply bool_dec. +Defined. + Lemma type_eq: forall (ty1 ty2: type), {ty1=ty2} + {ty1<>ty2} with typelist_eq: forall (tyl1 tyl2: typelist), {tyl1=tyl2} + {tyl1<>tyl2}. Proof. - assert (forall (x y: signedness), {x=y} + {x<>y}) by decide equality. assert (forall (x y: floatsize), {x=y} + {x<>y}) by decide equality. - assert (forall (x y: attr), {x=y} + {x<>y}). - { decide equality. decide equality. apply N.eq_dec. apply bool_dec. } - generalize ident_eq zeq bool_dec ident_eq intsize_eq; intros. + generalize ident_eq zeq bool_dec ident_eq intsize_eq signedness_eq attr_eq; intros. decide equality. decide equality. decide equality. decide equality. Defined. -Opaque type_eq typelist_eq. +Global Opaque intsize_eq signedness_eq attr_eq type_eq typelist_eq. (** Extract the attributes of a type. *) @@ -150,17 +161,53 @@ Definition attr_union (a1 a2: attr) : attr := Definition merge_attributes (ty: type) (a: attr) : type := change_attributes (attr_union a) ty. +(** Maximal size in bits of a bitfield of type [sz]. *) + +Definition bitsize_intsize (sz: intsize) : Z := + match sz with + | I8 => 8 + | I16 => 16 + | I32 => 32 + | IBool => 1 + end. + (** Syntax for [struct] and [union] definitions. [struct] and [union] are collectively called "composites". Each compilation unit comes with a list of top-level definitions of composites. *) Inductive struct_or_union : Type := Struct | Union. -Definition members : Type := list (ident * type). +Inductive member : Type := + | Member_plain (id: ident) (t: type) + | Member_bitfield (id: ident) (sz: intsize) (sg: signedness) (a: attr) + (width: Z) (padding: bool). + +Definition members : Type := list member. Inductive composite_definition : Type := Composite (id: ident) (su: struct_or_union) (m: members) (a: attr). +Definition name_member (m: member) : ident := + match m with + | Member_plain id _ => id + | Member_bitfield id _ _ _ _ _ => id + end. + +Definition type_member (m: member) : type := + match m with + | Member_plain _ t => t + | Member_bitfield _ sz sg a w _ => + (* An unsigned bitfield of width < size of type reads with a signed type *) + let sg' := if zlt w (bitsize_intsize sz) then Signed else sg in + Tint sz sg' a + end. + +Definition member_is_padding (m: member) : bool := + match m with + | Member_plain _ _ => false + | Member_bitfield _ _ _ _ _ p => p + end. + Definition name_composite_def (c: composite_definition) : ident := match c with Composite id su m a => id end. @@ -168,7 +215,9 @@ Definition composite_def_eq (x y: composite_definition): {x=y} + {x<>y}. Proof. decide equality. - decide equality. decide equality. apply N.eq_dec. apply bool_dec. -- apply list_eq_dec. decide equality. apply type_eq. apply ident_eq. +- apply list_eq_dec. decide equality. + apply type_eq. apply ident_eq. + apply bool_dec. apply zeq. apply attr_eq. apply signedness_eq. apply intsize_eq. apply ident_eq. - decide equality. - apply ident_eq. Defined. @@ -194,6 +243,13 @@ Record composite : Type := { Definition composite_env : Type := PTree.t composite. +(** Access modes for members of structs or unions: either a plain field + or a bitfield *) + +Inductive bitfield : Type := + | Full + | Bits (sz: intsize) (sg: signedness) (pos: Z) (width: Z). + (** * Operations over types *) (** ** Conversions *) @@ -389,41 +445,205 @@ Proof. - destruct (env!i). apply co_sizeof_alignof. apply Z.divide_0_r. Qed. +(** ** Layout of struct fields *) + +Section LAYOUT. + +Variable env: composite_env. + +Definition bitalignof (t: type) := alignof env t * 8. + +Definition bitsizeof (t: type) := sizeof env t * 8. + +Definition bitalignof_intsize (sz: intsize) : Z := + match sz with + | I8 | IBool => 8 + | I16 => 16 + | I32 => 32 + end. + +Definition next_field (pos: Z) (m: member) : Z := + match m with + | Member_plain _ t => + align pos (bitalignof t) + bitsizeof t + | Member_bitfield _ sz _ _ w _ => + let s := bitalignof_intsize sz in + if zle w 0 then + align pos s + else + let curr := floor pos s in + let next := curr + s in + if zle (pos + w) next then pos + w else next + w + end. + +Definition layout_field (pos: Z) (m: member) : res (Z * bitfield) := + match m with + | Member_plain _ t => + OK (align pos (bitalignof t) / 8, Full) + | Member_bitfield _ sz sg _ w _ => + if zle w 0 then Error (msg "accessing zero-width bitfield") + else if zlt (bitsize_intsize sz) w then Error (msg "bitfield too wide") + else + let s := bitalignof_intsize sz in + let start := floor pos s in + let next := start + s in + if zle (pos + w) next then + OK (start / 8, Bits sz sg (pos - start) w) + else + OK (next / 8, Bits sz sg 0 w) + end. + +(** Some properties *) + +Lemma bitalignof_intsize_pos: + forall sz, bitalignof_intsize sz > 0. +Proof. + destruct sz; simpl; lia. +Qed. + +Lemma next_field_incr: + forall pos m, pos <= next_field pos m. +Proof. + intros. unfold next_field. destruct m. +- set (al := bitalignof t). + assert (A: al > 0). + { unfold al, bitalignof. generalize (alignof_pos env t). lia. } + assert (pos <= align pos al) by (apply align_le; auto). + assert (bitsizeof t >= 0). + { unfold bitsizeof. generalize (sizeof_pos env t). lia. } + lia. +- set (s := bitalignof_intsize sz). + assert (A: s > 0) by (apply bitalignof_intsize_pos). + destruct (zle width 0). ++ apply align_le; auto. ++ generalize (floor_interval pos s A). + set (start := floor pos s). intros B. + destruct (zle (pos + width) (start + s)); lia. +Qed. + +Definition layout_start (p: Z) (bf: bitfield) := + p * 8 + match bf with Full => 0 | Bits sz sg pos w => pos end. + +Definition layout_width (t: type) (bf: bitfield) := + match bf with Full => bitsizeof t | Bits sz sg pos w => w end. + +Lemma layout_field_range: forall pos m ofs bf, + layout_field pos m = OK (ofs, bf) -> + pos <= layout_start ofs bf + /\ layout_start ofs bf + layout_width (type_member m) bf <= next_field pos m. +Proof. + intros until bf; intros L. unfold layout_start, layout_width. destruct m; simpl in L. +- inv L. simpl. + set (al := bitalignof t). + set (q := align pos al). + assert (A: al > 0). + { unfold al, bitalignof. generalize (alignof_pos env t). lia. } + assert (B: pos <= q) by (apply align_le; auto). + assert (C: (al | q)) by (apply align_divides; auto). + assert (D: (8 | q)). + { apply Z.divide_transitive with al; auto. apply Z.divide_factor_r. } + assert (E: q / 8 * 8 = q). + { destruct D as (n & E). rewrite E. rewrite Z.div_mul by lia. auto. } + rewrite E. lia. +- unfold next_field. + destruct (zle width 0); try discriminate. + destruct (zlt (bitsize_intsize sz) width); try discriminate. + set (s := bitalignof_intsize sz) in *. + assert (A: s > 0) by (apply bitalignof_intsize_pos). + generalize (floor_interval pos s A). set (p := floor pos s) in *. intros B. + assert (C: (s | p)) by (apply floor_divides; auto). + assert (D: (8 | s)). + { exists (s / 8). unfold s. destruct sz; reflexivity. } + assert (E: (8 | p)) by (apply Z.divide_transitive with s; auto). + assert (F: (8 | p + s)) by (apply Z.divide_add_r; auto). + assert (G: p / 8 * 8 = p). + { destruct E as (n & EQ). rewrite EQ. rewrite Z.div_mul by lia. auto. } + assert (H: (p + s) / 8 * 8 = p + s). + { destruct F as (n & EQ). rewrite EQ. rewrite Z.div_mul by lia. auto. } + destruct (zle (pos + width) (p + s)); inv L; lia. +Qed. + +Definition layout_alignment (t: type) (bf: bitfield) := + match bf with + | Full => alignof env t + | Bits sz _ _ _ => bitalignof_intsize sz / 8 + end. + +Lemma layout_field_alignment: forall pos m ofs bf, + layout_field pos m = OK (ofs, bf) -> + (layout_alignment (type_member m) bf | ofs). +Proof. + intros until bf; intros L. destruct m; simpl in L. +- inv L; simpl. + set (q := align pos (bitalignof t)). + assert (A: (bitalignof t | q)). + { apply align_divides. unfold bitalignof. generalize (alignof_pos env t). lia. } + destruct A as [n E]. exists n. rewrite E. unfold bitalignof. rewrite Z.mul_assoc, Z.div_mul by lia. auto. +- destruct (zle width 0); try discriminate. + destruct (zlt (bitsize_intsize sz) width); try discriminate. + set (s := bitalignof_intsize sz) in *. + assert (A: s > 0) by (apply bitalignof_intsize_pos). + set (p := floor pos s) in *. + assert (C: (s | p)) by (apply floor_divides; auto). + assert (D: (8 | s)). + { exists (s / 8). unfold s. destruct sz; reflexivity. } + assert (E: forall n, (s | n) -> (s / 8 | n / 8)). + { intros. destruct H as [n1 E1], D as [n2 E2]. rewrite E1, E2. + rewrite Z.mul_assoc, ! Z.div_mul by lia. exists n1; auto. } + destruct (zle (pos + width) (p + s)); inv L; simpl; fold s. + + apply E. auto. + + apply E. apply Z.divide_add_r; auto using Z.divide_refl. +Qed. + +End LAYOUT. + (** ** Size and alignment for composite definitions *) (** The alignment for a structure or union is the max of the alignment - of its members. *) + of its members. Padding bitfields are ignored. *) -Fixpoint alignof_composite (env: composite_env) (m: members) : Z := - match m with +Fixpoint alignof_composite (env: composite_env) (ms: members) : Z := + match ms with | nil => 1 - | (id, t) :: m' => Z.max (alignof env t) (alignof_composite env m') + | m :: ms => + if member_is_padding m + then alignof_composite env ms + else Z.max (alignof env (type_member m)) (alignof_composite env ms) end. (** The size of a structure corresponds to its layout: fields are laid out consecutively, and padding is inserted to align - each field to the alignment for its type. *) + each field to the alignment for its type. Bitfields are packed + as described above. *) -Fixpoint sizeof_struct (env: composite_env) (cur: Z) (m: members) : Z := - match m with +Fixpoint bitsizeof_struct (env: composite_env) (cur: Z) (ms: members) : Z := + match ms with | nil => cur - | (id, t) :: m' => sizeof_struct env (align cur (alignof env t) + sizeof env t) m' + | m :: ms => bitsizeof_struct env (next_field env cur m) ms end. +Definition bytes_of_bits (n: Z) := (n + 7) / 8. + +Definition sizeof_struct (env: composite_env) (m: members) : Z := + bytes_of_bits (bitsizeof_struct env 0 m). + (** The size of an union is the max of the sizes of its members. *) -Fixpoint sizeof_union (env: composite_env) (m: members) : Z := - match m with +Fixpoint sizeof_union (env: composite_env) (ms: members) : Z := + match ms with | nil => 0 - | (id, t) :: m' => Z.max (sizeof env t) (sizeof_union env m') + | m :: ms => Z.max (sizeof env (type_member m)) (sizeof_union env ms) end. +(** Some properties *) + Lemma alignof_composite_two_p: forall env m, exists n, alignof_composite env m = two_power_nat n. Proof. - induction m as [|[id t]]; simpl. + induction m; simpl. - exists 0%nat; auto. -- apply Z.max_case; auto. apply alignof_two_p. +- destruct (member_is_padding a); auto. + apply Z.max_case; auto. apply alignof_two_p. Qed. Lemma alignof_composite_pos: @@ -435,94 +655,113 @@ Proof. rewrite EQ; apply two_power_nat_pos. Qed. -Lemma sizeof_struct_incr: - forall env m cur, cur <= sizeof_struct env cur m. +Lemma bitsizeof_struct_incr: + forall env m cur, cur <= bitsizeof_struct env cur m. Proof. - induction m as [|[id t]]; simpl; intros. + induction m; simpl; intros. - lia. -- apply Z.le_trans with (align cur (alignof env t)). - apply align_le. apply alignof_pos. - apply Z.le_trans with (align cur (alignof env t) + sizeof env t). - generalize (sizeof_pos env t); lia. - apply IHm. +- apply Z.le_trans with (next_field env cur a). + apply next_field_incr. apply IHm. Qed. Lemma sizeof_union_pos: forall env m, 0 <= sizeof_union env m. Proof. - induction m as [|[id t]]; simpl; extlia. + induction m; simpl; extlia. Qed. -(** ** Byte offset for a field of a structure *) - -(** [field_offset env id fld] returns the byte offset for field [id] - in a structure whose members are [fld]. Fields are laid out - consecutively, and padding is inserted to align each field to the - alignment for its type. *) +(** ** Byte offset and bitfield designator for a field of a structure *) -Fixpoint field_offset_rec (env: composite_env) (id: ident) (fld: members) (pos: Z) - {struct fld} : res Z := - match fld with +Fixpoint field_type (id: ident) (ms: members) {struct ms} : res type := + match ms with | nil => Error (MSG "Unknown field " :: CTX id :: nil) - | (id', t) :: fld' => - if ident_eq id id' - then OK (align pos (alignof env t)) - else field_offset_rec env id fld' (align pos (alignof env t) + sizeof env t) + | m :: ms => if ident_eq id (name_member m) then OK (type_member m) else field_type id ms end. -Definition field_offset (env: composite_env) (id: ident) (fld: members) : res Z := - field_offset_rec env id fld 0. +(** [field_offset env id fld] returns the byte offset for field [id] + in a structure whose members are [fld]. It also returns a + bitfield designator, giving the location of the bits to access + within the storage unit for the bitfield. *) -Fixpoint field_type (id: ident) (fld: members) {struct fld} : res type := - match fld with +Fixpoint field_offset_rec (env: composite_env) (id: ident) (ms: members) (pos: Z) + {struct ms} : res (Z * bitfield) := + match ms with | nil => Error (MSG "Unknown field " :: CTX id :: nil) - | (id', t) :: fld' => if ident_eq id id' then OK t else field_type id fld' + | m :: ms => + if ident_eq id (name_member m) + then layout_field env pos m + else field_offset_rec env id ms (next_field env pos m) end. +Definition field_offset (env: composite_env) (id: ident) (ms: members) : res (Z * bitfield) := + field_offset_rec env id ms 0. + (** Some sanity checks about field offsets. First, field offsets are within the range of acceptable offsets. *) Remark field_offset_rec_in_range: - forall env id ofs ty fld pos, - field_offset_rec env id fld pos = OK ofs -> field_type id fld = OK ty -> - pos <= ofs /\ ofs + sizeof env ty <= sizeof_struct env pos fld. + forall env id ofs bf ty ms pos, + field_offset_rec env id ms pos = OK (ofs, bf) -> field_type id ms = OK ty -> + pos <= layout_start ofs bf + /\ layout_start ofs bf + layout_width env ty bf <= bitsizeof_struct env pos ms. Proof. - intros until ty. induction fld as [|[i t]]; simpl; intros. + induction ms as [ | m ms]; simpl; intros. - discriminate. -- destruct (ident_eq id i); intros. - inv H. inv H0. split. - apply align_le. apply alignof_pos. apply sizeof_struct_incr. - exploit IHfld; eauto. intros [A B]. split; auto. - eapply Z.le_trans; eauto. apply Z.le_trans with (align pos (alignof env t)). - apply align_le. apply alignof_pos. generalize (sizeof_pos env t). lia. +- destruct (ident_eq id (name_member m)). + + inv H0. + exploit layout_field_range; eauto. + generalize (bitsizeof_struct_incr env ms (next_field env pos m)). + lia. + + exploit IHms; eauto. + generalize (next_field_incr env pos m). + lia. Qed. -Lemma field_offset_in_range: - forall env fld id ofs ty, - field_offset env id fld = OK ofs -> field_type id fld = OK ty -> - 0 <= ofs /\ ofs + sizeof env ty <= sizeof_struct env 0 fld. +Lemma field_offset_in_range_gen: + forall env ms id ofs bf ty, + field_offset env id ms = OK (ofs, bf) -> field_type id ms = OK ty -> + 0 <= layout_start ofs bf + /\ layout_start ofs bf + layout_width env ty bf <= bitsizeof_struct env 0 ms. Proof. intros. eapply field_offset_rec_in_range; eauto. Qed. +Corollary field_offset_in_range: + forall env ms id ofs ty, + field_offset env id ms = OK (ofs, Full) -> field_type id ms = OK ty -> + 0 <= ofs /\ ofs + sizeof env ty <= sizeof_struct env ms. +Proof. + intros. exploit field_offset_in_range_gen; eauto. + unfold layout_start, layout_width, bitsizeof, sizeof_struct. intros [A B]. + assert (C: forall x y, x * 8 <= y -> x <= bytes_of_bits y). + { unfold bytes_of_bits; intros. + assert (P: 8 > 0) by lia. + generalize (Z_div_mod_eq (y + 7) 8 P) (Z_mod_lt (y + 7) 8 P). + lia. } + split. lia. apply C. lia. +Qed. + (** Second, two distinct fields do not overlap *) Lemma field_offset_no_overlap: - forall env id1 ofs1 ty1 id2 ofs2 ty2 fld, - field_offset env id1 fld = OK ofs1 -> field_type id1 fld = OK ty1 -> - field_offset env id2 fld = OK ofs2 -> field_type id2 fld = OK ty2 -> + forall env id1 ofs1 bf1 ty1 id2 ofs2 bf2 ty2 fld, + field_offset env id1 fld = OK (ofs1, bf1) -> field_type id1 fld = OK ty1 -> + field_offset env id2 fld = OK (ofs2, bf2) -> field_type id2 fld = OK ty2 -> id1 <> id2 -> - ofs1 + sizeof env ty1 <= ofs2 \/ ofs2 + sizeof env ty2 <= ofs1. + layout_start ofs1 bf1 + layout_width env ty1 bf1 <= layout_start ofs2 bf2 + \/ layout_start ofs2 bf2 + layout_width env ty2 bf2 <= layout_start ofs1 bf1. Proof. intros until fld. unfold field_offset. generalize 0 as pos. - induction fld as [|[i t]]; simpl; intros. + induction fld as [|m fld]; simpl; intros. - discriminate. -- destruct (ident_eq id1 i); destruct (ident_eq id2 i). +- destruct (ident_eq id1 (name_member m)); destruct (ident_eq id2 (name_member m)). + congruence. -+ subst i. inv H; inv H0. - exploit field_offset_rec_in_range. eexact H1. eauto. tauto. -+ subst i. inv H1; inv H2. - exploit field_offset_rec_in_range. eexact H. eauto. tauto. ++ inv H0. + exploit field_offset_rec_in_range; eauto. + exploit layout_field_range; eauto. lia. ++ inv H2. + exploit field_offset_rec_in_range; eauto. + exploit layout_field_range; eauto. lia. + eapply IHfld; eauto. Qed. @@ -530,31 +769,90 @@ Qed. are the same. *) Lemma field_offset_prefix: - forall env id ofs fld2 fld1, - field_offset env id fld1 = OK ofs -> - field_offset env id (fld1 ++ fld2) = OK ofs. + forall env id ofs bf fld2 fld1, + field_offset env id fld1 = OK (ofs, bf) -> + field_offset env id (fld1 ++ fld2) = OK (ofs, bf). Proof. intros until fld1. unfold field_offset. generalize 0 as pos. - induction fld1 as [|[i t]]; simpl; intros. + induction fld1 as [|m fld1]; simpl; intros. - discriminate. -- destruct (ident_eq id i); auto. +- destruct (ident_eq id (name_member m)); auto. Qed. (** Fourth, the position of each field respects its alignment. *) -Lemma field_offset_aligned: - forall env id fld ofs ty, - field_offset env id fld = OK ofs -> field_type id fld = OK ty -> - (alignof env ty | ofs). +Lemma field_offset_aligned_gen: + forall env id fld ofs bf ty, + field_offset env id fld = OK (ofs, bf) -> field_type id fld = OK ty -> + (layout_alignment env ty bf | ofs). Proof. intros until ty. unfold field_offset. generalize 0 as pos. revert fld. - induction fld as [|[i t]]; simpl; intros. + induction fld as [|m fld]; simpl; intros. - discriminate. -- destruct (ident_eq id i). -+ inv H; inv H0. apply align_divides. apply alignof_pos. +- destruct (ident_eq id (name_member m)). ++ inv H0. eapply layout_field_alignment; eauto. + eauto. Qed. +Corollary field_offset_aligned: + forall env id fld ofs ty, + field_offset env id fld = OK (ofs, Full) -> field_type id fld = OK ty -> + (alignof env ty | ofs). +Proof. + intros. exploit field_offset_aligned_gen; eauto. +Qed. + +(** [union_field_offset env id ms] returns the byte offset and + bitfield designator for accessing a member named [id] of a union + whose members are [ms]. The byte offset is always 0. *) + +Fixpoint union_field_offset (env: composite_env) (id: ident) (ms: members) + {struct ms} : res (Z * bitfield) := + match ms with + | nil => Error (MSG "Unknown field " :: CTX id :: nil) + | m :: ms => + if ident_eq id (name_member m) + then layout_field env 0 m + else union_field_offset env id ms + end. + +(** Some sanity checks about union field offsets. First, field offsets + fit within the size of the union. *) + +Lemma union_field_offset_in_range_gen: + forall env id ofs bf ty ms, + union_field_offset env id ms = OK (ofs, bf) -> field_type id ms = OK ty -> + ofs = 0 /\ 0 <= layout_start ofs bf /\ layout_start ofs bf + layout_width env ty bf <= sizeof_union env ms * 8. +Proof. + induction ms as [ | m ms]; simpl; intros. +- discriminate. +- destruct (ident_eq id (name_member m)). + + inv H0. set (ty := type_member m) in *. + destruct m; simpl in H. + * inv H. unfold layout_start, layout_width. + rewrite align_same. change (0 / 8) with 0. unfold bitsizeof. lia. + unfold bitalignof. generalize (alignof_pos env t). lia. + apply Z.divide_0_r. + * destruct (zle width 0); try discriminate. + destruct (zlt (bitsize_intsize sz) width); try discriminate. + assert (A: bitsize_intsize sz <= bitalignof_intsize sz <= sizeof env ty * 8). + { unfold ty, type_member; destruct sz; simpl; lia. } + rewrite zle_true in H by lia. inv H. + unfold layout_start, layout_width. + unfold floor; rewrite Z.div_0_l by lia. + lia. + + exploit IHms; eauto. lia. +Qed. + +Corollary union_field_offset_in_range: + forall env ms id ofs ty, + union_field_offset env id ms = OK (ofs, Full) -> field_type id ms = OK ty -> + ofs = 0 /\ sizeof env ty <= sizeof_union env ms. +Proof. + intros. exploit union_field_offset_in_range_gen; eauto. + unfold layout_start, layout_width, bitsizeof. lia. +Qed. + (** ** Access modes *) (** The [access_mode] function describes how a l-value of the given @@ -712,7 +1010,8 @@ Fixpoint rank_type (ce: composite_env) (t: type) : nat := Fixpoint rank_members (ce: composite_env) (m: members) : nat := match m with | nil => 0%nat - | (id, t) :: m => Init.Nat.max (rank_type ce t) (rank_members ce m) + | Member_plain _ t :: m => Init.Nat.max (rank_type ce t) (rank_members ce m) + | Member_bitfield _ _ _ _ _ _ :: m => rank_members ce m end. (** ** C types and back-end types *) @@ -766,7 +1065,7 @@ Definition signature_of_type (args: typelist) (res: type) (cc: calling_conventio Definition sizeof_composite (env: composite_env) (su: struct_or_union) (m: members) : Z := match su with - | Struct => sizeof_struct env 0 m + | Struct => sizeof_struct env m | Union => sizeof_union env m end. @@ -774,21 +1073,23 @@ Lemma sizeof_composite_pos: forall env su m, 0 <= sizeof_composite env su m. Proof. intros. destruct su; simpl. - apply sizeof_struct_incr. - apply sizeof_union_pos. +- unfold sizeof_struct, bytes_of_bits. + assert (0 <= bitsizeof_struct env 0 m) by apply bitsizeof_struct_incr. + change 0 with (0 / 8) at 1. apply Z.div_le_mono; lia. +- apply sizeof_union_pos. Qed. -Fixpoint complete_members (env: composite_env) (m: members) : bool := - match m with +Fixpoint complete_members (env: composite_env) (ms: members) : bool := + match ms with | nil => true - | (id, t) :: m' => complete_type env t && complete_members env m' + | m :: ms => complete_type env (type_member m) && complete_members env ms end. Lemma complete_member: - forall env id t m, - In (id, t) m -> complete_members env m = true -> complete_type env t = true. + forall env m ms, + In m ms -> complete_members env ms = true -> complete_type env (type_member m) = true. Proof. - induction m as [|[id1 t1] m]; simpl; intuition auto. + induction ms as [|m1 ms]; simpl; intuition auto. InvBooleans; inv H1; auto. InvBooleans; eauto. Qed. @@ -852,8 +1153,6 @@ Defined. must precede all uses of this composite, unless the use is under a pointer or function type. *) -Local Open Scope error_monad_scope. - Fixpoint add_composite_definitions (env: composite_env) (defs: list composite_definition) : res composite_env := match defs with | nil => OK env @@ -916,52 +1215,88 @@ Proof. Qed. Lemma alignof_composite_stable: - forall m, complete_members env m = true -> alignof_composite env' m = alignof_composite env m. + forall ms, complete_members env ms = true -> alignof_composite env' ms = alignof_composite env ms. Proof. - induction m as [|[id t]]; simpl; intros. + induction ms as [|m ms]; simpl; intros. auto. - InvBooleans. rewrite alignof_stable by auto. rewrite IHm by auto. auto. + InvBooleans. rewrite alignof_stable by auto. rewrite IHms by auto. auto. Qed. -Lemma sizeof_struct_stable: - forall m pos, complete_members env m = true -> sizeof_struct env' pos m = sizeof_struct env pos m. +Remark next_field_stable: forall pos m, + complete_type env (type_member m) = true -> next_field env' pos m = next_field env pos m. Proof. - induction m as [|[id t]]; simpl; intros. + destruct m; simpl; intros. +- unfold bitalignof, bitsizeof. rewrite alignof_stable, sizeof_stable by auto. auto. +- auto. +Qed. + +Lemma bitsizeof_struct_stable: + forall ms pos, complete_members env ms = true -> bitsizeof_struct env' pos ms = bitsizeof_struct env pos ms. +Proof. + induction ms as [|m ms]; simpl; intros. auto. - InvBooleans. rewrite alignof_stable by auto. rewrite sizeof_stable by auto. - rewrite IHm by auto. auto. + InvBooleans. rewrite next_field_stable by auto. apply IHms; auto. Qed. Lemma sizeof_union_stable: - forall m, complete_members env m = true -> sizeof_union env' m = sizeof_union env m. + forall ms, complete_members env ms = true -> sizeof_union env' ms = sizeof_union env ms. Proof. - induction m as [|[id t]]; simpl; intros. + induction ms as [|m ms]; simpl; intros. auto. - InvBooleans. rewrite sizeof_stable by auto. rewrite IHm by auto. auto. + InvBooleans. rewrite sizeof_stable by auto. rewrite IHms by auto. auto. Qed. Lemma sizeof_composite_stable: - forall su m, complete_members env m = true -> sizeof_composite env' su m = sizeof_composite env su m. + forall su ms, complete_members env ms = true -> sizeof_composite env' su ms = sizeof_composite env su ms. Proof. intros. destruct su; simpl. - apply sizeof_struct_stable; auto. + unfold sizeof_struct. f_equal. apply bitsizeof_struct_stable; auto. apply sizeof_union_stable; auto. Qed. Lemma complete_members_stable: - forall m, complete_members env m = true -> complete_members env' m = true. + forall ms, complete_members env ms = true -> complete_members env' ms = true. Proof. - induction m as [|[id t]]; simpl; intros. + induction ms as [|m ms]; simpl; intros. auto. - InvBooleans. rewrite complete_type_stable by auto. rewrite IHm by auto. auto. + InvBooleans. rewrite complete_type_stable by auto. rewrite IHms by auto. auto. Qed. Lemma rank_members_stable: - forall m, complete_members env m = true -> rank_members env' m = rank_members env m. + forall ms, complete_members env ms = true -> rank_members env' ms = rank_members env ms. Proof. - induction m as [|[id t]]; simpl; intros. + induction ms as [|m ms]; simpl; intros. auto. - InvBooleans. f_equal; auto. apply rank_type_stable; auto. + InvBooleans. destruct m; auto. f_equal; auto. apply rank_type_stable; auto. +Qed. + +Remark layout_field_stable: forall pos m, + complete_type env (type_member m) = true -> layout_field env' pos m = layout_field env pos m. +Proof. + destruct m; simpl; intros. +- unfold bitalignof. rewrite alignof_stable by auto. auto. +- auto. +Qed. + +Lemma field_offset_stable: + forall f ms, complete_members env ms = true -> field_offset env' f ms = field_offset env f ms. +Proof. + intros until ms. unfold field_offset. generalize 0. + induction ms as [|m ms]; simpl; intros. +- auto. +- InvBooleans. destruct (ident_eq f (name_member m)). + apply layout_field_stable; auto. + rewrite next_field_stable by auto. apply IHms; auto. +Qed. + +Lemma union_field_offset_stable: + forall f ms, complete_members env ms = true -> union_field_offset env' f ms = union_field_offset env f ms. +Proof. + induction ms as [|m ms]; simpl; intros. +- auto. +- InvBooleans. destruct (ident_eq f (name_member m)). + apply layout_field_stable; auto. + apply IHms; auto. Qed. End STABILITY. @@ -1091,19 +1426,23 @@ Qed. is strictly greater than the ranks of its member types. *) Remark rank_type_members: - forall ce id t m, In (id, t) m -> (rank_type ce t <= rank_members ce m)%nat. + forall ce m ms, In m ms -> (rank_type ce (type_member m) <= rank_members ce ms)%nat. Proof. - induction m; simpl; intros; intuition auto. - subst a. extlia. - extlia. + induction ms; simpl; intros. +- tauto. +- destruct a; destruct H; subst; simpl. + + lia. + + apply IHms in H. lia. + + lia. + + apply IHms; auto. Qed. Lemma rank_struct_member: - forall ce id a co id1 t1, + forall ce id a co m, composite_env_consistent ce -> ce!id = Some co -> - In (id1, t1) (co_members co) -> - (rank_type ce t1 < rank_type ce (Tstruct id a))%nat. + In m (co_members co) -> + (rank_type ce (type_member m) < rank_type ce (Tstruct id a))%nat. Proof. intros; simpl. rewrite H0. erewrite co_consistent_rank by eauto. @@ -1112,11 +1451,11 @@ Proof. Qed. Lemma rank_union_member: - forall ce id a co id1 t1, + forall ce id a co m, composite_env_consistent ce -> ce!id = Some co -> - In (id1, t1) (co_members co) -> - (rank_type ce t1 < rank_type ce (Tunion id a))%nat. + In m (co_members co) -> + (rank_type ce (type_member m) < rank_type ce (Tunion id a))%nat. Proof. intros; simpl. rewrite H0. erewrite co_consistent_rank by eauto. @@ -1516,6 +1855,57 @@ Global Opaque Linker_program. (** ** Commutation between linking and program transformations *) +Section LINK_MATCH_PROGRAM_GEN. + +Context {F G: Type}. +Variable match_fundef: program F -> fundef F -> fundef G -> Prop. + +Hypothesis link_match_fundef: + forall ctx1 ctx2 f1 tf1 f2 tf2 f, + link f1 f2 = Some f -> + match_fundef ctx1 f1 tf1 -> match_fundef ctx2 f2 tf2 -> + exists tf, link tf1 tf2 = Some tf /\ (match_fundef ctx1 f tf \/ match_fundef ctx2 f tf). + +Let match_program (p: program F) (tp: program G) : Prop := + Linking.match_program_gen match_fundef eq p p tp + /\ prog_types tp = prog_types p. + +Theorem link_match_program_gen: + forall p1 p2 tp1 tp2 p, + link p1 p2 = Some p -> match_program p1 tp1 -> match_program p2 tp2 -> + exists tp, link tp1 tp2 = Some tp /\ match_program p tp. +Proof. + intros until p; intros L [M1 T1] [M2 T2]. + exploit link_linkorder; eauto. intros [LO1 LO2]. +Local Transparent Linker_program. + simpl in L; unfold link_program in L. + destruct (link (program_of_program p1) (program_of_program p2)) as [pp|] eqn:LP; try discriminate. + assert (A: exists tpp, + link (program_of_program tp1) (program_of_program tp2) = Some tpp + /\ Linking.match_program_gen match_fundef eq p pp tpp). + { eapply Linking.link_match_program; eauto. + - intros. + Local Transparent Linker_types. + simpl in *. destruct (type_eq v1 v2); inv H. exists v; rewrite dec_eq_true; auto. + } + destruct A as (tpp & TLP & MP). + simpl; unfold link_program. rewrite TLP. + destruct (lift_option (link (prog_types p1) (prog_types p2))) as [[typs EQ]|EQ]; try discriminate. + destruct (link_build_composite_env (prog_types p1) (prog_types p2) typs + (prog_comp_env p1) (prog_comp_env p2) (prog_comp_env_eq p1) + (prog_comp_env_eq p2) EQ) as (env & P & Q). + rewrite <- T1, <- T2 in EQ. + destruct (lift_option (link (prog_types tp1) (prog_types tp2))) as [[ttyps EQ']|EQ']; try congruence. + assert (ttyps = typs) by congruence. subst ttyps. + destruct (link_build_composite_env (prog_types tp1) (prog_types tp2) typs + (prog_comp_env tp1) (prog_comp_env tp2) (prog_comp_env_eq tp1) + (prog_comp_env_eq tp2) EQ') as (tenv & R & S). + assert (tenv = env) by congruence. subst tenv. + econstructor; split; eauto. inv L. split; auto. +Qed. + +End LINK_MATCH_PROGRAM_GEN. + Section LINK_MATCH_PROGRAM. Context {F G: Type}. @@ -1571,3 +1961,4 @@ Local Transparent Linker_program. Qed. End LINK_MATCH_PROGRAM. + diff --git a/cfrontend/Ctyping.v b/cfrontend/Ctyping.v index 589c856c..6363686d 100644 --- a/cfrontend/Ctyping.v +++ b/cfrontend/Ctyping.v @@ -411,8 +411,8 @@ Inductive wt_rvalue : expr -> Prop := wt_rvalue (Eparen r tycast ty) with wt_lvalue : expr -> Prop := - | wt_Eloc: forall b ofs ty, - wt_lvalue (Eloc b ofs ty) + | wt_Eloc: forall b ofs bf ty, + wt_lvalue (Eloc b ofs bf ty) | wt_Evar: forall x ty, e!x = Some ty -> wt_lvalue (Evar x ty) @@ -441,7 +441,7 @@ Definition wt_expr_kind (k: kind) (a: expr) := Definition expr_kind (a: expr) : kind := match a with - | Eloc _ _ _ => LV + | Eloc _ _ _ _ => LV | Evar _ _ => LV | Ederef _ _ => LV | Efield _ _ _ => LV @@ -597,7 +597,7 @@ Fixpoint check_arguments (el: exprlist) (tyl: typelist) : res unit := Definition check_rval (e: expr) : res unit := match e with - | Eloc _ _ _ | Evar _ _ | Ederef _ _ | Efield _ _ _ => + | Eloc _ _ _ _ | Evar _ _ | Ederef _ _ | Efield _ _ _ => Error (msg "not a r-value") | _ => OK tt @@ -605,7 +605,7 @@ Definition check_rval (e: expr) : res unit := Definition check_lval (e: expr) : res unit := match e with - | Eloc _ _ _ | Evar _ _ | Ederef _ _ | Efield _ _ _ => + | Eloc _ _ _ _ | Evar _ _ | Ederef _ _ | Efield _ _ _ => OK tt | _ => Error (msg "not a l-value") @@ -847,7 +847,7 @@ Fixpoint retype_expr (ce: composite_env) (e: typenv) (a: expr) : res expr := do r1' <- retype_expr ce e r1; do rl' <- retype_exprlist ce e rl; ecall r1' rl' | Ebuiltin ef tyargs rl tyres => do rl' <- retype_exprlist ce e rl; ebuiltin ef tyargs rl' tyres - | Eloc _ _ _ => + | Eloc _ _ _ _ => Error (msg "Eloc in source") | Eparen _ _ _ => Error (msg "Eparen in source") @@ -985,6 +985,7 @@ Lemma binarith_type_cast: forall t1 t2 m t, binarith_type t1 t2 m = OK t -> wt_cast t1 t /\ wt_cast t2 t. Proof. +Local Transparent Ctypes.intsize_eq. unfold wt_cast, binarith_type, classify_binarith; intros; DestructCases; simpl; split; try congruence; try (destruct Archi.ptr64; congruence). @@ -1659,9 +1660,31 @@ Proof. unfold Mptr in *. destruct Archi.ptr64 eqn:SF; auto with ty. Qed. +Remark wt_bitfield_normalize: forall sz sg width sg1 n, + 0 < width <= bitsize_intsize sz -> + sg1 = (if zlt width (bitsize_intsize sz) then Signed else sg) -> + wt_int (bitfield_normalize sz sg width n) sz sg1. +Proof. + intros. destruct sz; cbn in *. + + destruct sg. + * replace sg1 with Signed by (destruct zlt; auto). + apply Int.sign_ext_widen; lia. + * subst sg1; destruct zlt. + ** apply Int.sign_zero_ext_widen; lia. + ** apply Int.zero_ext_widen; lia. + + destruct sg. + * replace sg1 with Signed by (destruct zlt; auto). + apply Int.sign_ext_widen; lia. + * subst sg1; destruct zlt. + ** apply Int.sign_zero_ext_widen; lia. + ** apply Int.zero_ext_widen; lia. + + auto. + + apply Int.zero_ext_widen; lia. +Qed. + Lemma wt_deref_loc: - forall ge ty m b ofs t v, - deref_loc ge ty m b ofs t v -> + forall ge ty m b ofs bf t v, + deref_loc ge ty m b ofs bf t v -> wt_val v ty. Proof. induction 1. @@ -1683,6 +1706,19 @@ Proof. destruct ty; simpl in H; try discriminate; auto with ty. destruct i; destruct s; discriminate. destruct f; discriminate. +- (* bitfield *) + inv H. constructor. + apply wt_bitfield_normalize. lia. auto. +Qed. + +Lemma wt_assign_loc: + forall ge ty m b ofs bf v t m' v', + assign_loc ge ty m b ofs bf v t m' v' -> + wt_val v ty -> wt_val v' ty. +Proof. + induction 1; intros; auto. +- inv H. constructor. + apply wt_bitfield_normalize. lia. auto. Qed. Lemma wt_cast_self: @@ -1773,7 +1809,7 @@ Proof. - (* condition *) constructor. destruct b; auto. destruct b; auto. red; auto. - (* sizeof *) unfold size_t, Vptrofs; destruct Archi.ptr64; constructor; auto with ty. - (* alignof *) unfold size_t, Vptrofs; destruct Archi.ptr64; constructor; auto with ty. -- (* assign *) inversion H5. constructor. eapply pres_sem_cast; eauto. +- (* assign *) inversion H5. constructor. eapply wt_assign_loc; eauto. eapply pres_sem_cast; eauto. - (* assignop *) subst tyres l r. constructor. auto. constructor. constructor. eapply wt_deref_loc; eauto. auto. auto. auto. diff --git a/cfrontend/Initializers.v b/cfrontend/Initializers.v index 77d6cfea..32fbf46b 100644 --- a/cfrontend/Initializers.v +++ b/cfrontend/Initializers.v @@ -114,18 +114,23 @@ Fixpoint constval (ce: composite_env) (a: expr) : res val := | Ederef r ty => constval ce r | Efield l f ty => - match typeof l with - | Tstruct id _ => - do co <- lookup_composite ce id; - do delta <- field_offset ce f (co_members co); - do v <- constval ce l; + do (delta, bf) <- + match typeof l with + | Tstruct id _ => + do co <- lookup_composite ce id; field_offset ce f (co_members co) + | Tunion id _ => + do co <- lookup_composite ce id; union_field_offset ce f (co_members co) + | _ => + Error (msg "ill-typed field access") + end; + do v <- constval ce l; + match bf with + | Full => OK (if Archi.ptr64 then Val.addl v (Vlong (Int64.repr delta)) else Val.add v (Vint (Int.repr delta))) - | Tunion id _ => - constval ce l - | _ => - Error(msg "ill-typed field access") + | Bits _ _ _ _ => + Error(msg "taking the address of a bitfield") end | Eparen r tycast ty => do v <- constval ce r; do_cast v (typeof r) tycast @@ -138,6 +143,183 @@ Fixpoint constval (ce: composite_env) (a: expr) : res val := Definition constval_cast (ce: composite_env) (a: expr) (ty: type): res val := do v <- constval ce a; do_cast v (typeof a) ty. +(** * Building and recording initialization data *) + +(** The following [state] type is the output of the translation of + initializers. It contains the list of initialization data + generated so far, the corresponding position in bytes, and the + total size expected for the final initialization data, in bytes. *) + +Record state : Type := { + init: list init_data; (**r reversed *) + curr: Z; (**r current position for head of [init] *) + total_size: Z (**r total expected size *) +}. + +(** A state [s] can also be viewed as a memory block. The size of + the block is [s.(total_size)], it is initialized with zero bytes, + then filled with the initialization data [rev s.(init)] like + [Genv.store_init_data_list] does. *) + +Definition initial_state (sz: Z) : state := + {| init := nil; curr := 0; total_size := sz |}. + +(** We now define abstract "store" operations that operate + directly on the state, but whose behavior mimic those of + storing in the corresponding memory block. To initialize + bitfields, we also need an abstract "load" operation. + The operations are optimized for stores that occur at increasing + positions, like those that take place during initialization. *) + +(** Initialization from bytes *) + +Definition int_of_byte (b: byte) := Int.repr (Byte.unsigned b). + +Definition Init_byte (b: byte) := Init_int8 (int_of_byte b). + +(** Add a list of bytes to a reversed initialization data list. *) + +Fixpoint add_rev_bytes (l: list byte) (il: list init_data) := + match l with + | nil => il + | b :: l => add_rev_bytes l (Init_byte b :: il) + end. + +(** Add [n] zero bytes to an initialization data list. *) + +Definition add_zeros (n: Z) (il: list init_data) := + Z.iter n (fun l => Init_int8 Int.zero :: l) il. + +(** Make sure the [depth] positions at the top of [il] are bytes, + that is, [Init_int8] items. Other numerical items are split + into bytes. [Init_addrof] items cannot be split and result in + an error. *) + +Fixpoint normalize (il: list init_data) (depth: Z) : res (list init_data) := + if zle depth 0 then OK il else + match il with + | nil => + Error (msg "normalize: empty list") + | Init_int8 n :: il => + do il' <- normalize il (depth - 1); + OK (Init_int8 n :: il') + | Init_int16 n :: il => + do il' <- normalize il (depth - 2); + OK (add_rev_bytes (encode_int 2%nat (Int.unsigned n)) il') + | Init_int32 n :: il => + do il' <- normalize il (depth - 4); + OK (add_rev_bytes (encode_int 4%nat (Int.unsigned n)) il') + | Init_int64 n :: il => + do il' <- normalize il (depth - 8); + OK (add_rev_bytes (encode_int 8%nat (Int64.unsigned n)) il') + | Init_float32 f :: il => + do il' <- normalize il (depth - 4); + OK (add_rev_bytes (encode_int 4%nat (Int.unsigned (Float32.to_bits f))) il') + | Init_float64 f :: il => + do il' <- normalize il (depth - 8); + OK (add_rev_bytes (encode_int 8%nat (Int64.unsigned (Float.to_bits f))) il') + | Init_addrof _ _ :: il => + Error (msg "normalize: Init_addrof") + | Init_space n :: il => + let n := Z.max 0 n in + if zle n depth then + do il' <- normalize il (depth - n); + OK (add_zeros n il') + else + OK (add_zeros depth (Init_space (n - depth) :: il)) + end. + +(** Split [il] into [depth] bytes and the initialization list that follows. + The bytes are returned reversed. *) + +Fixpoint decompose_rec (accu: list byte) (il: list init_data) (depth: Z) : res (list byte * list init_data) := + if zle depth 0 then OK (accu, il) else + match il with + | Init_int8 n :: il => decompose_rec (Byte.repr (Int.unsigned n) :: accu) il (depth - 1) + | _ => Error (msg "decompose: wrong shape") + end. + +Definition decompose (il: list init_data) (depth: Z) : res (list byte * list init_data) := + decompose_rec nil il depth. + +(** Decompose an initialization list in three parts: + [depth] bytes (reversed), [sz] bytes (reversed), + and the remainder of the initialization list. *) + +Definition trisection (il: list init_data) (depth sz: Z) : res (list byte * list byte * list init_data) := + do il0 <- normalize il (depth + sz); + do (bytes1, il1) <- decompose il0 depth; + do (bytes2, il2) <- decompose il1 sz; + OK (bytes1, bytes2, il2). + +(** Graphically: [rev il] is equal to +<< + <---sz---><--depth--> ++----------------+---------+---------+ +| | | | ++----------------+---------+---------+ + rev il2 bytes2 bytes1 +>> +*) + +(** Add padding if necessary so that position [pos] is within the state. *) + +Definition pad_to (s: state) (pos: Z) : state := + if zle pos s.(curr) + then s + else {| init := Init_space (pos - s.(curr)) :: s.(init); + curr := pos; + total_size := s.(total_size) |}. + +(** Store the initialization data [i] at position [pos] in state [s]. *) + +Definition store_data (s: state) (pos: Z) (i: init_data) : res state := + let sz := init_data_size i in + assertion (zle 0 pos && zle (pos + sz) s.(total_size)); + if zle s.(curr) pos then + OK {| init := i :: (if zlt s.(curr) pos + then Init_space (pos - s.(curr)) :: s.(init) + else s.(init)); + curr := pos + sz; + total_size := s.(total_size) |} + else + let s' := pad_to s (pos + sz) in + do x3 <- trisection s'.(init) (s'.(curr) - (pos + sz)) sz; + let '(bytes1, _, il2) := x3 in + OK {| init := add_rev_bytes bytes1 (i :: il2); + curr := s'.(curr); + total_size := s'.(total_size) |}. + +(** Store the integer [n] of size [isz] at position [pos] in state [s]. *) + +Definition init_data_for_carrier (isz: intsize) (n: int) := + match isz with + | I8 | IBool => Init_int8 n + | I16 => Init_int16 n + | I32 => Init_int32 n + end. + +Definition store_int (s: state) (pos: Z) (isz: intsize) (n: int) : res state := + store_data s pos (init_data_for_carrier isz n). + +(** Load the integer of size [isz] at position [pos] in state [s]. *) + +Definition load_int (s: state) (pos: Z) (isz: intsize) : res int := + let chunk := chunk_for_carrier isz in + let sz := size_chunk chunk in + assertion (zle 0 pos && zle (pos + sz) s.(total_size)); + let s' := pad_to s (pos + sz) in + do x3 <- trisection s'.(init) (s'.(curr) - (pos + sz)) sz; + let '(_, bytes2, _) := x3 in + OK (Int.repr (decode_int bytes2)). + +(** Extract the final initialization data from a state. *) + +Definition init_data_list_of_state (s: state) : res (list init_data) := + assertion (zle s.(curr) s.(total_size)); + let s' := pad_to s s.(total_size) in + OK (List.rev' s'.(init)). + (** * Translation of initializers *) Inductive initializer := @@ -149,6 +331,11 @@ with initializer_list := | Init_nil | Init_cons (i: initializer) (il: initializer_list). +Definition length_initializer_list (il: initializer_list) := + let fix length (accu: Z) (il: initializer_list) : Z := + match il with Init_nil => accu | Init_cons _ il => length (Z.succ accu) il end + in length 0 il. + (** Translate an initializing expression [a] for a scalar variable of type [ty]. Return the corresponding initialization datum. *) @@ -170,69 +357,116 @@ Definition transl_init_single (ce: composite_env) (ty: type) (a: expr) : res ini | _, _ => Error (msg "type mismatch in initializer") end. -(** Translate an initializer [i] for a variable of type [ty]. - [transl_init ce ty i] returns the appropriate list of initialization data. - The intermediate functions [transl_init_rec], [transl_init_array] - and [transl_init_struct] append initialization data to the given - list [k], and build the list of initialization data in reverse order, - so as to remain tail-recursive. *) +(** Initialize a bitfield [Bits sz sg p w] with expression [a]. *) -Definition padding (frm to: Z) (k: list init_data) : list init_data := - if zlt frm to then Init_space (to - frm) :: k else k. +Definition transl_init_bitfield (ce: composite_env) (s: state) + (ty: type) (sz: intsize) (p w: Z) + (i: initializer) (pos: Z) : res state := + match i with + | Init_single a => + do v <- constval_cast ce a ty; + match v with + | Vint n => + do c <- load_int s pos sz; + let c' := Int.bitfield_insert (first_bit sz p w) w c n in + store_int s pos sz c' + | Vundef => + Error (msg "undefined operation in bitfield initializer") + | _ => + Error (msg "type mismatch in bitfield initializer") + end + | _ => + Error (msg "bitfield initialized by composite initializer") + end. + +(** Padding bitfields and bitfields with zero width are not initialized. *) + +Definition member_not_initialized (m: member) : bool := + match m with + | Member_plain _ _ => false + | Member_bitfield _ _ _ _ w p => p || zle w 0 + end. -Fixpoint transl_init_rec (ce: composite_env) (ty: type) (i: initializer) - (k: list init_data) {struct i} : res (list init_data) := +(** Translate an initializer [i] for a variable of type [ty] + and store the corresponding list of initialization data in state [s] + at position [pos]. Return the updated state. *) + +Fixpoint transl_init_rec (ce: composite_env) (s: state) + (ty: type) (i: initializer) (pos: Z) + {struct i} : res state := match i, ty with | Init_single a, _ => - do d <- transl_init_single ce ty a; OK (d :: k) + do d <- transl_init_single ce ty a; store_data s pos d | Init_array il, Tarray tyelt nelt _ => - transl_init_array ce tyelt il (Z.max 0 nelt) k + assertion (zle (length_initializer_list il) (Z.max 0 nelt)); + transl_init_array ce s tyelt il pos | Init_struct il, Tstruct id _ => do co <- lookup_composite ce id; match co_su co with - | Struct => transl_init_struct ce ty (co_members co) il 0 k + | Struct => transl_init_struct ce s (co_members co) il pos 0 | Union => Error (MSG "struct/union mismatch on " :: CTX id :: nil) end | Init_union f i1, Tunion id _ => do co <- lookup_composite ce id; match co_su co with | Struct => Error (MSG "union/struct mismatch on " :: CTX id :: nil) - | Union => - do ty1 <- field_type f (co_members co); - do k1 <- transl_init_rec ce ty1 i1 k; - OK (padding (sizeof ce ty1) (sizeof ce ty) k1) + | Union => do ty1 <- field_type f (co_members co); + do (delta, layout) <- union_field_offset ce f (co_members co); + match layout with + | Full => + transl_init_rec ce s ty1 i1 (pos + delta) + | Bits sz sg p w => + transl_init_bitfield ce s ty1 sz p w i1 (pos + delta) + end end | _, _ => Error (msg "wrong type for compound initializer") end -with transl_init_array (ce: composite_env) (ty: type) (il: initializer_list) (sz: Z) - (k: list init_data) {struct il} : res (list init_data) := +with transl_init_array (ce: composite_env) (s: state) + (tyelt: type) (il: initializer_list) (pos: Z) + {struct il} : res state := match il with | Init_nil => - if zeq sz 0 then OK k - else if zle 0 sz then OK (Init_space (sz * sizeof ce ty) :: k) - else Error (msg "wrong number of elements in array initializer") + OK s | Init_cons i1 il' => - do k1 <- transl_init_rec ce ty i1 k; - transl_init_array ce ty il' (sz - 1) k1 + do s1 <- transl_init_rec ce s tyelt i1 pos; + transl_init_array ce s1 tyelt il' (pos + sizeof ce tyelt) end -with transl_init_struct (ce: composite_env) (ty: type) - (fl: members) (il: initializer_list) (pos: Z) - (k: list init_data) - {struct il} : res (list init_data) := - match il, fl with - | Init_nil, nil => - OK (padding pos (sizeof ce ty) k) - | Init_cons i1 il', (_, ty1) :: fl' => - let pos1 := align pos (alignof ce ty1) in - do k1 <- transl_init_rec ce ty1 i1 (padding pos pos1 k); - transl_init_struct ce ty fl' il' (pos1 + sizeof ce ty1) k1 - | _, _ => - Error (msg "wrong number of elements in struct initializer") +with transl_init_struct (ce: composite_env) (s: state) + (ms: members) (il: initializer_list) + (base: Z) (pos: Z) + {struct il} : res state := + match il with + | Init_nil => + OK s + | Init_cons i1 il' => + let fix init (ms: members) (pos: Z) {struct ms} : res state := + match ms with + | nil => + Error (msg "too many elements in struct initializer") + | m :: ms' => + if member_not_initialized m then + init ms' (next_field ce pos m) + else + do (delta, layout) <- layout_field ce pos m; + do s1 <- + match layout with + | Full => + transl_init_rec ce s (type_member m) i1 (base + delta) + | Bits sz sg p w => + transl_init_bitfield ce s (type_member m) sz p w i1 (base + delta) + end; + transl_init_struct ce s1 ms' il' base (next_field ce pos m) + end in + init ms pos end. +(** The entry point. *) + Definition transl_init (ce: composite_env) (ty: type) (i: initializer) : res (list init_data) := - do k <- transl_init_rec ce ty i nil; OK (List.rev' k). + let s0 := initial_state (sizeof ce ty) in + do s1 <- transl_init_rec ce s0 ty i 0; + init_data_list_of_state s1. diff --git a/cfrontend/Initializersproof.v b/cfrontend/Initializersproof.v index 10ccbeff..00f7e331 100644 --- a/cfrontend/Initializersproof.v +++ b/cfrontend/Initializersproof.v @@ -12,7 +12,7 @@ (** Compile-time evaluation of initializers for global C variables. *) -Require Import Coqlib Maps. +Require Import Zwf Coqlib Maps. Require Import Errors Integers Floats Values AST Memory Globalenvs Events Smallstep. Require Import Ctypes Cop Csyntax Csem. Require Import Initializers. @@ -30,7 +30,7 @@ Variable ge: genv. Fixpoint simple (a: expr) : Prop := match a with - | Eloc _ _ _ => True + | Eloc _ _ _ _ => True | Evar _ _ => True | Ederef r _ => simple r | Efield l1 _ _ => simple l1 @@ -65,38 +65,38 @@ Section SIMPLE_EXPRS. Variable e: env. Variable m: mem. -Inductive eval_simple_lvalue: expr -> block -> ptrofs -> Prop := - | esl_loc: forall b ofs ty, - eval_simple_lvalue (Eloc b ofs ty) b ofs +Inductive eval_simple_lvalue: expr -> block -> ptrofs -> bitfield -> Prop := + | esl_loc: forall b ofs bf ty, + eval_simple_lvalue (Eloc b ofs bf ty) b ofs bf | esl_var_local: forall x ty b, e!x = Some(b, ty) -> - eval_simple_lvalue (Evar x ty) b Ptrofs.zero + eval_simple_lvalue (Evar x ty) b Ptrofs.zero Full | esl_var_global: forall x ty b, e!x = None -> Genv.find_symbol ge x = Some b -> - eval_simple_lvalue (Evar x ty) b Ptrofs.zero + eval_simple_lvalue (Evar x ty) b Ptrofs.zero Full | 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 r f ty b ofs id co a delta, + eval_simple_lvalue (Ederef r ty) b ofs Full + | esl_field_struct: forall r f ty b ofs id co a delta bf, eval_simple_rvalue r (Vptr b ofs) -> - typeof r = Tstruct id a -> ge.(genv_cenv)!id = Some co -> field_offset ge f (co_members co) = OK delta -> - eval_simple_lvalue (Efield r f ty) b (Ptrofs.add ofs (Ptrofs.repr delta)) - | esl_field_union: forall r f ty b ofs id a, + typeof r = Tstruct id a -> ge.(genv_cenv)!id = Some co -> field_offset ge f (co_members co) = OK (delta, bf) -> + eval_simple_lvalue (Efield r f ty) b (Ptrofs.add ofs (Ptrofs.repr delta)) bf + | esl_field_union: forall r f ty b ofs id co a delta bf, eval_simple_rvalue r (Vptr b ofs) -> - typeof r = Tunion id a -> - eval_simple_lvalue (Efield r f ty) b ofs + typeof r = Tunion id a -> ge.(genv_cenv)!id = Some co -> union_field_offset ge f (co_members co) = OK (delta, bf) -> + eval_simple_lvalue (Efield r f ty) b (Ptrofs.add ofs (Ptrofs.repr delta)) bf 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 -> + | esr_rvalof: forall b ofs bf l ty v, + eval_simple_lvalue l b ofs bf -> ty = typeof l -> - deref_loc ge ty m b ofs E0 v -> + deref_loc ge ty m b ofs bf E0 v -> eval_simple_rvalue (Evalof l ty) v | esr_addrof: forall b ofs l ty, - eval_simple_lvalue l b ofs -> + eval_simple_lvalue l b ofs Full -> eval_simple_rvalue (Eaddrof l ty) (Vptr b ofs) | esr_unop: forall op r1 ty v1 v, eval_simple_rvalue r1 v1 -> @@ -153,7 +153,7 @@ End SIMPLE_EXPRS. Definition compat_eval (k: kind) (e: env) (a a': expr) (m: mem) : Prop := typeof a = typeof a' /\ match k with - | LV => forall b ofs, eval_simple_lvalue e m a' b ofs -> eval_simple_lvalue e m a b ofs + | LV => forall b ofs bf, eval_simple_lvalue e m a' b ofs bf -> eval_simple_lvalue e m a b ofs bf | RV => forall v, eval_simple_rvalue e m a' v -> eval_simple_rvalue e m a v end. @@ -167,7 +167,7 @@ Lemma lred_compat: forall e l m l' m', lred ge e l m l' m' -> m = m' /\ compat_eval LV e l l' m. Proof. - induction 1; simpl; split; auto; split; auto; intros bx ofsx EV; inv EV. + induction 1; simpl; split; auto; split; auto; intros bx ofsx bf' EV; inv EV. apply esl_var_local; auto. apply esl_var_global; auto. constructor. constructor. @@ -365,6 +365,22 @@ Proof. intros. eapply bool_val_inj; eauto. intros. rewrite mem_empty_not_weak_valid_pointer in H2; discriminate. Qed. +Lemma add_offset_match: + forall v b ofs delta, + Val.inject inj v (Vptr b ofs) -> + Val.inject inj + (if Archi.ptr64 + then Val.addl v (Vlong (Int64.repr delta)) + else Val.add v (Vint (Int.repr delta))) + (Vptr b (Ptrofs.add ofs (Ptrofs.repr delta))). +Proof. + intros. inv H. +- rewrite Ptrofs.add_assoc. rewrite (Ptrofs.add_commut (Ptrofs.repr delta0)). + unfold Val.addl, Val.add; destruct Archi.ptr64 eqn:SF; + econstructor; eauto; rewrite ! Ptrofs.add_assoc; f_equal; f_equal; symmetry; auto with ptrofs. +- unfold Val.addl, Val.add; destruct Archi.ptr64; auto. +Qed. + (** Soundness of [constval] with respect to the big-step semantics *) Lemma constval_rvalue: @@ -374,20 +390,22 @@ Lemma constval_rvalue: constval ge a = OK v' -> Val.inject inj v' v with constval_lvalue: - forall m a b ofs, - eval_simple_lvalue empty_env m a b ofs -> + forall m a b ofs bf, + eval_simple_lvalue empty_env m a b ofs bf -> forall v', constval ge a = OK v' -> - Val.inject inj v' (Vptr b ofs). + bf = Full /\ Val.inject inj v' (Vptr b ofs). Proof. (* rvalue *) induction 1; intros vres CV; simpl in CV; try (monadInv CV). (* val *) destruct v; monadInv CV; constructor. (* rval *) - inv H1; rewrite H2 in CV; try congruence. eauto. eauto. + assert (constval ge l = OK vres) by (destruct (access_mode ty); congruence). + exploit constval_lvalue; eauto. intros [A B]. subst bf. + inv H1; rewrite H3 in CV; congruence. (* addrof *) - eauto. + eapply constval_lvalue; eauto. (* unop *) destruct (sem_unary_operation op x (typeof r1) Mem.empty) as [v1'|] eqn:E; inv EQ0. exploit (sem_unary_operation_inj inj Mem.empty m). @@ -438,28 +456,31 @@ Proof. (* lvalue *) induction 1; intros v' CV; simpl in CV; try (monadInv CV). (* var local *) - unfold empty_env in H. rewrite PTree.gempty in H. congruence. + split; auto. unfold empty_env in H. rewrite PTree.gempty in H. congruence. (* var_global *) - econstructor. unfold inj. rewrite H0. eauto. auto. + split; auto. econstructor. unfold inj. rewrite H0. eauto. auto. (* deref *) - eauto. + split; eauto. (* field struct *) - rewrite H0 in CV. monadInv CV. unfold lookup_composite in EQ; rewrite H1 in EQ; monadInv EQ. - exploit constval_rvalue; eauto. intro MV. inv MV. - replace x0 with delta by congruence. rewrite Ptrofs.add_assoc. rewrite (Ptrofs.add_commut (Ptrofs.repr delta0)). - simpl; destruct Archi.ptr64 eqn:SF; - econstructor; eauto; rewrite ! Ptrofs.add_assoc; f_equal; f_equal; symmetry; auto with ptrofs. - destruct Archi.ptr64; auto. + rewrite H0 in EQ. monadInv EQ. destruct x0; monadInv EQ2. + unfold lookup_composite in EQ0; rewrite H1 in EQ0; monadInv EQ0. + exploit constval_rvalue; eauto. intro MV. + split. congruence. + replace x with delta by congruence. + apply (add_offset_match _ _ _ _ MV). (* field union *) - rewrite H0 in CV. eauto. + rewrite H0 in EQ. monadInv EQ. destruct x0; monadInv EQ2. + unfold lookup_composite in EQ0; rewrite H1 in EQ0; monadInv EQ0. + exploit constval_rvalue; eauto. intro MV. + split. congruence. + replace x with delta by congruence. + apply (add_offset_match _ _ _ _ MV). Qed. Lemma constval_simple: forall a v, constval ge a = OK v -> simple a. Proof. induction a; simpl; intros vx CV; try (monadInv CV); eauto. - destruct (typeof a); discriminate || eauto. - monadInv CV. eauto. destruct (access_mode ty); discriminate || eauto. intuition eauto. Qed. @@ -476,331 +497,757 @@ Proof. intros [A [B C]]. intuition. eapply constval_rvalue; eauto. Qed. -(** * Relational specification of the translation of initializers *) - -Definition tr_padding (frm to: Z) : list init_data := - if zlt frm to then Init_space (to - frm) :: nil else nil. - -Inductive tr_init: type -> initializer -> list init_data -> Prop := - | tr_init_sgl: forall ty a d, - transl_init_single ge ty a = OK d -> - tr_init ty (Init_single a) (d :: nil) - | tr_init_arr: forall tyelt nelt attr il d, - tr_init_array tyelt il (Z.max 0 nelt) d -> - tr_init (Tarray tyelt nelt attr) (Init_array il) d - | tr_init_str: forall id attr il co d, - lookup_composite ge id = OK co -> co_su co = Struct -> - tr_init_struct (Tstruct id attr) (co_members co) il 0 d -> - tr_init (Tstruct id attr) (Init_struct il) d - | tr_init_uni: forall id attr f i1 co ty1 d, - lookup_composite ge id = OK co -> co_su co = Union -> field_type f (co_members co) = OK ty1 -> - tr_init ty1 i1 d -> - tr_init (Tunion id attr) (Init_union f i1) - (d ++ tr_padding (sizeof ge ty1) (sizeof ge (Tunion id attr))) - -with tr_init_array: type -> initializer_list -> Z -> list init_data -> Prop := - | tr_init_array_nil_0: forall ty, - tr_init_array ty Init_nil 0 nil - | tr_init_array_nil_pos: forall ty sz, - 0 < sz -> - tr_init_array ty Init_nil sz (Init_space (sz * sizeof ge ty) :: nil) - | tr_init_array_cons: forall ty i il sz d1 d2, - tr_init ty i d1 -> tr_init_array ty il (sz - 1) d2 -> - tr_init_array ty (Init_cons i il) sz (d1 ++ d2) - -with tr_init_struct: type -> members -> initializer_list -> Z -> list init_data -> Prop := - | tr_init_struct_nil: forall ty pos, - tr_init_struct ty nil Init_nil pos (tr_padding pos (sizeof ge ty)) - | tr_init_struct_cons: forall ty f1 ty1 fl i1 il pos d1 d2, - let pos1 := align pos (alignof ge ty1) in - tr_init ty1 i1 d1 -> - tr_init_struct ty fl il (pos1 + sizeof ge ty1) d2 -> - tr_init_struct ty ((f1, ty1) :: fl) (Init_cons i1 il) - pos (tr_padding pos pos1 ++ d1 ++ d2). - -Lemma transl_padding_spec: - forall frm to k, padding frm to k = rev (tr_padding frm to) ++ k. -Proof. - unfold padding, tr_padding; intros. - destruct (zlt frm to); auto. -Qed. - -Lemma transl_init_rec_spec: - forall i ty k res, - transl_init_rec ge ty i k = OK res -> - exists d, tr_init ty i d /\ res = rev d ++ k - -with transl_init_array_spec: - forall il ty sz k res, - transl_init_array ge ty il sz k = OK res -> - exists d, tr_init_array ty il sz d /\ res = rev d ++ k - -with transl_init_struct_spec: - forall il ty fl pos k res, - transl_init_struct ge ty fl il pos k = OK res -> - exists d, tr_init_struct ty fl il pos d /\ res = rev d ++ k. - -Proof. -Local Opaque sizeof. -- destruct i; intros until res; intros TR; simpl in TR. -+ monadInv TR. exists (x :: nil); split; auto. constructor; auto. -+ destruct ty; try discriminate. - destruct (transl_init_array_spec _ _ _ _ _ TR) as (d & A & B). - exists d; split; auto. constructor; auto. -+ destruct ty; try discriminate. monadInv TR. destruct (co_su x) eqn:SU; try discriminate. - destruct (transl_init_struct_spec _ _ _ _ _ _ EQ0) as (d & A & B). - exists d; split; auto. econstructor; eauto. -+ destruct ty; try discriminate. - monadInv TR. destruct (co_su x) eqn:SU; monadInv EQ0. - destruct (transl_init_rec_spec _ _ _ _ EQ0) as (d & A & B). - exists (d ++ tr_padding (sizeof ge x0) (sizeof ge (Tunion i0 a))); split. - econstructor; eauto. - rewrite rev_app_distr, app_ass, B. apply transl_padding_spec. - -- destruct il; intros until res; intros TR; simpl in TR. -+ destruct (zeq sz 0). - inv TR. exists (@nil init_data); split; auto. constructor. - destruct (zle 0 sz). - inv TR. econstructor; split. constructor. lia. auto. - discriminate. -+ monadInv TR. - destruct (transl_init_rec_spec _ _ _ _ EQ) as (d1 & A1 & B1). - destruct (transl_init_array_spec _ _ _ _ _ EQ0) as (d2 & A2 & B2). - exists (d1 ++ d2); split. econstructor; eauto. - subst res x. rewrite rev_app_distr, app_ass. auto. +(** * Correctness of operations over the initialization state *) + +(** ** Properties of the in-memory bytes denoted by initialization data *) + +Local Notation boid := (Genv.bytes_of_init_data (genv_genv ge)). +Local Notation boidl := (Genv.bytes_of_init_data_list (genv_genv ge)). + +Lemma boidl_app: forall il2 il1, + boidl (il1 ++ il2) = boidl il1 ++ boidl il2. +Proof. + induction il1 as [ | il il1]; simpl. auto. rewrite app_ass. f_equal; auto. +Qed. + +Corollary boidl_rev_cons: forall i il, + boidl (rev il ++ i :: nil) = boidl (rev il) ++ boid i. +Proof. + intros. rewrite boidl_app. simpl. rewrite <- app_nil_end. auto. +Qed. + +Definition byte_of_int (n: int) := Byte.repr (Int.unsigned n). + +Lemma byte_of_int_of_byte: forall b, byte_of_int (int_of_byte b) = b. +Proof. + intros. unfold int_of_byte, byte_of_int. + rewrite Int.unsigned_repr, Byte.repr_unsigned. auto. + assert(Byte.max_unsigned < Int.max_unsigned) by reflexivity. + generalize (Byte.unsigned_range_2 b). lia. +Qed. + +Lemma inj_bytes_1: forall n, + inj_bytes (encode_int 1 n) = Byte (Byte.repr n) :: nil. +Proof. + intros. unfold encode_int, bytes_of_int, rev_if_be. destruct Archi.big_endian; auto. +Qed. + +Lemma inj_bytes_byte: forall b, + inj_bytes (encode_int 1 (Int.unsigned (int_of_byte b))) = Byte b :: nil. +Proof. + intros. rewrite inj_bytes_1. do 2 f_equal. apply byte_of_int_of_byte. +Qed. + +Lemma boidl_init_ints8: forall l, + boidl (map Init_int8 l) = inj_bytes (map byte_of_int l). +Proof. + induction l as [ | i l]; simpl. auto. rewrite inj_bytes_1; simpl. f_equal; auto. +Qed. + +Lemma boidl_init_bytes: forall l, + boidl (map Init_byte l) = inj_bytes l. +Proof. + induction l as [ | b l]; simpl. auto. rewrite inj_bytes_byte, IHl. auto. +Qed. + +Lemma boidl_ints8: forall i n, + boidl (repeat (Init_int8 i) n) = repeat (Byte (byte_of_int i)) n. +Proof. + induction n; simpl. auto. rewrite inj_bytes_1. simpl; f_equal; auto. +Qed. + +(** ** Properties of operations over list of initialization data *) + +Lemma add_rev_bytes_spec: forall l il, + add_rev_bytes l il = List.map Init_byte (List.rev l) ++ il. +Proof. + induction l as [ | b l]; intros; simpl. +- auto. +- rewrite IHl. rewrite map_app. simpl. rewrite app_ass. auto. +Qed. + +Lemma add_rev_bytes_spec': forall l il, + List.rev (add_rev_bytes l il) = List.rev il ++ List.map Init_byte l. +Proof. + intros. rewrite add_rev_bytes_spec. rewrite rev_app_distr, map_rev, rev_involutive. auto. +Qed. + +Lemma add_zeros_spec: forall n il, + 0 <= n -> + add_zeros n il = List.repeat (Init_int8 Int.zero) (Z.to_nat n) ++ il. +Proof. + intros. + unfold add_zeros; rewrite iter_nat_of_Z by auto; rewrite Zabs2Nat.abs_nat_nonneg by auto. + induction (Z.to_nat n); simpl. auto. f_equal; auto. +Qed. + +Lemma decompose_spec: forall il depth bl il', + decompose il depth = OK (bl, il') -> + exists nl, il = List.map Init_int8 nl ++ il' + /\ bl = List.map byte_of_int (rev nl) + /\ List.length nl = Z.to_nat depth. +Proof. + assert (REC: forall il accu depth bl il', + decompose_rec accu il depth = OK (bl, il') -> + exists nl, il = List.map Init_int8 nl ++ il' + /\ bl = List.map byte_of_int (rev nl) ++ accu + /\ List.length nl = Z.to_nat depth). + { induction il as [ | i il ]; intros until il'; intros D; simpl in D. + - destruct (zle depth 0); inv D. + exists (@nil int); simpl. rewrite Z_to_nat_neg by auto. auto. + - destruct (zle depth 0). + + inv D. exists (@nil int); simpl. rewrite Z_to_nat_neg by auto. auto. + + destruct i; try discriminate. + apply IHil in D; destruct D as (nl & P & Q & R). + exists (i :: nl); simpl; split. congruence. split. + rewrite map_app. simpl. rewrite app_ass. exact Q. + rewrite R, <- Z2Nat.inj_succ by lia. f_equal; lia. + } + intros. apply REC in H. destruct H as (nl & P & Q & R). rewrite app_nil_r in Q. + exists nl; auto. +Qed. + +Lemma list_repeat_app: forall (A: Type) (a: A) n2 n1, + List.repeat a n1 ++ List.repeat a n2 = List.repeat a (n1 + n2)%nat. +Proof. + induction n1; simpl; congruence. +Qed. + +Lemma list_rev_repeat: forall (A: Type) (a: A) n, + rev (List.repeat a n) = List.repeat a n. +Proof. + induction n; simpl. auto. rewrite IHn. change (a :: nil) with (repeat a 1%nat). + rewrite list_repeat_app. rewrite Nat.add_comm. auto. +Qed. + +Lemma normalize_boidl: forall il depth il', + normalize il depth = OK il' -> + boidl (rev il') = boidl (rev il). +Proof. + induction il as [ | i il]; simpl; intros depth il' AT. +- destruct (zle depth 0); inv AT. auto. +- destruct (zle depth 0). inv AT. auto. + destruct i; + try (monadInv AT; simpl; + rewrite ? add_rev_bytes_spec', ? boidl_rev_cons, ? boidl_app, ? boidl_init_bytes; + erewrite IHil by eauto; reflexivity). + set (n := Z.max 0 z) in *. destruct (zle n depth); monadInv AT. + + rewrite add_zeros_spec, rev_app_distr, ! boidl_app by lia. + erewrite IHil by eauto. f_equal. + rewrite list_rev_repeat. simpl. rewrite app_nil_r, boidl_ints8. + f_equal. unfold n. apply Z.max_case_strong; intros; auto. rewrite ! Z_to_nat_neg by lia. auto. + + rewrite add_zeros_spec, rev_app_distr, !boidl_app by lia. + simpl. rewrite boidl_rev_cons, list_rev_repeat. simpl. + rewrite app_ass, app_nil_r, !boidl_ints8. f_equal. + rewrite list_repeat_app. f_equal. rewrite <- Z2Nat.inj_add by lia. + unfold n. apply Z.max_case_strong; intros; f_equal; lia. +Qed. + +Lemma trisection_boidl: forall il depth sz bytes1 bytes2 il', + trisection il depth sz = OK (bytes1, bytes2, il') -> + boidl (rev il) = boidl (rev il') ++ inj_bytes bytes2 ++ inj_bytes bytes1 + /\ length bytes1 = Z.to_nat depth + /\ length bytes2 = Z.to_nat sz. +Proof. + unfold trisection; intros. monadInv H. + apply normalize_boidl in EQ. rewrite <- EQ. + apply decompose_spec in EQ1. destruct EQ1 as (nl1 & A1 & B1 & C1). + apply decompose_spec in EQ0. destruct EQ0 as (nl2 & A2 & B2 & C2). + split. +- rewrite A1, A2, !rev_app_distr, !boidl_app, app_ass. + rewrite <- !map_rev, !boidl_init_ints8. rewrite <- B1, <- B2. auto. +- rewrite B1, B2, !map_length, !rev_length. auto. +Qed. + +Lemma store_init_data_loadbytes: + forall m b p i m', + Genv.store_init_data ge m b p i = Some m' -> + match i with Init_space _ => False | _ => True end -> + Mem.loadbytes m' b p (init_data_size i) = Some (boid i). +Proof. + intros; destruct i; simpl in H; try apply (Mem.loadbytes_store_same _ _ _ _ _ _ H). +- contradiction. +- rewrite Genv.init_data_size_addrof. simpl. + destruct (Genv.find_symbol ge i) as [b'|]; try discriminate. + rewrite (Mem.loadbytes_store_same _ _ _ _ _ _ H). + unfold encode_val, Mptr; destruct Archi.ptr64; reflexivity. +Qed. + +(** ** Validity and size of initialization data *) + +Definition idvalid (i: init_data) : Prop := + match i with + | Init_addrof symb ofs => exists b, Genv.find_symbol ge symb = Some b + | _ => True + end. + +Fixpoint idlvalid (p: Z) (il: list init_data) {struct il} : Prop := + match il with + | nil => True + | i1 :: il => + (Genv.init_data_alignment i1 | p) + /\ idvalid i1 + /\ idlvalid (p + init_data_size i1) il + end. + +Lemma idlvalid_app: forall l2 l1 pos, + idlvalid pos (l1 ++ l2) <-> idlvalid pos l1 /\ idlvalid (pos + init_data_list_size l1) l2. +Proof. + induction l1 as [ | d l1]; intros; simpl. +- rewrite Z.add_0_r; tauto. +- rewrite IHl1. rewrite Z.add_assoc. tauto. +Qed. + +Lemma add_rev_bytes_valid: forall il bl, + idlvalid 0 (rev il) -> idlvalid 0 (rev (add_rev_bytes bl il)). +Proof. + intros. rewrite add_rev_bytes_spec, rev_app_distr, idlvalid_app. split; auto. + generalize (rev bl) (0 + init_data_list_size (rev il)). induction l; simpl; intros. + auto. + rewrite idlvalid_app; split; auto. simpl. auto using Z.divide_1_l. +Qed. + +Lemma add_zeros_valid: forall il n, + 0 <= n -> idlvalid 0 (rev il) -> idlvalid 0 (rev (add_zeros n il)). +Proof. + intros. rewrite add_zeros_spec, rev_app_distr, idlvalid_app by auto. + split; auto. + generalize (Z.to_nat n) (0 + init_data_list_size (rev il)). induction n0; simpl; intros. + auto. + rewrite idlvalid_app; split; auto. simpl. auto using Z.divide_1_l. +Qed. -- destruct il; intros until res; intros TR; simpl in TR. -+ destruct fl; inv TR. econstructor; split. constructor. apply transl_padding_spec. -+ destruct fl as [ | [f1 ty1] fl ]; monadInv TR. - destruct (transl_init_rec_spec _ _ _ _ EQ) as (d1 & A1 & B1). - destruct (transl_init_struct_spec _ _ _ _ _ _ EQ0) as (d2 & A2 & B2). - exists (tr_padding pos (align pos (alignof ge ty1)) ++ d1 ++ d2); split. - econstructor; eauto. - rewrite ! rev_app_distr. subst res x. rewrite ! app_ass. rewrite transl_padding_spec. auto. +Lemma normalize_valid: forall il depth il', + normalize il depth = OK il' -> idlvalid 0 (rev il) -> idlvalid 0 (rev il'). +Proof. + induction il as [ | i il]; simpl; intros. +- destruct (zle depth 0); inv H. simpl. tauto. +- destruct (zle depth 0). inv H. auto. + rewrite idlvalid_app in H0; destruct H0. + destruct i; try (monadInv H; apply add_rev_bytes_valid; eapply IHil; eauto). + + monadInv H. simpl. rewrite idlvalid_app; split. eauto. simpl; auto using Z.divide_1_l. + + destruct (zle (Z.max 0 z)); monadInv H. + * apply add_zeros_valid. lia. eauto. + * apply add_zeros_valid. lia. simpl. rewrite idlvalid_app; split. auto. simpl; auto using Z.divide_1_l. Qed. -Theorem transl_init_spec: - forall ty i d, transl_init ge ty i = OK d -> tr_init ty i d. +Lemma trisection_valid: forall il depth sz bytes1 bytes2 il', + trisection il depth sz = OK (bytes1, bytes2, il') -> + idlvalid 0 (rev il) -> + idlvalid 0 (rev il'). Proof. - unfold transl_init; intros. monadInv H. - exploit transl_init_rec_spec; eauto. intros (d & A & B). - subst x. unfold rev'; rewrite <- rev_alt. - rewrite rev_app_distr; simpl. rewrite rev_involutive. auto. + unfold trisection; intros. monadInv H. + apply decompose_spec in EQ1. destruct EQ1 as (nl1 & A1 & B1 & C1). + apply decompose_spec in EQ0. destruct EQ0 as (nl2 & A2 & B2 & C2). + exploit normalize_valid; eauto. rewrite A1, A2, !rev_app_distr, !idlvalid_app. + tauto. +Qed. + +Lemma init_data_size_boid: forall i, + init_data_size i = Z.of_nat (length (boid i)). +Proof. + intros. destruct i; simpl; rewrite ?length_inj_bytes, ?encode_int_length; auto. +- rewrite repeat_length. rewrite Z_to_nat_max; auto. +- destruct (Genv.find_symbol ge i), Archi.ptr64; reflexivity. +Qed. + +Lemma init_data_list_size_boidl: forall il, + init_data_list_size il = Z.of_nat (length (boidl il)). +Proof. + induction il as [ | i il]; simpl. auto. + rewrite app_length, init_data_size_boid. lia. +Qed. + +Lemma init_data_list_size_app: forall l1 l2, + init_data_list_size (l1 ++ l2) = init_data_list_size l1 + init_data_list_size l2. +Proof. + induction l1 as [ | i l1]; intros; simpl. auto. rewrite IHl1; lia. +Qed. + +(** ** Memory areas that are initialized to zeros *) + +Definition reads_as_zeros (m: mem) (b: block) (from to: Z) : Prop := + forall i, from <= i < to -> Mem.loadbytes m b i 1 = Some (Byte Byte.zero :: nil). + +Lemma reads_as_zeros_mono: forall m b from1 from2 to1 to2, + reads_as_zeros m b from1 to1 -> from1 <= from2 -> to2 <= to1 -> + reads_as_zeros m b from2 to2. +Proof. + intros; red; intros. apply H; lia. +Qed. + +Remark reads_as_zeros_unchanged: + forall (P: block -> Z -> Prop) m b from to m', + reads_as_zeros m b from to -> + Mem.unchanged_on P m m' -> + (forall i, from <= i < to -> P b i) -> + reads_as_zeros m' b from to. +Proof. + intros; red; intros. eapply Mem.loadbytes_unchanged_on; eauto. + intros; apply H1. lia. +Qed. + +Lemma reads_as_zeros_loadbytes: forall m b from to, + reads_as_zeros m b from to -> + forall len pos, from <= pos -> pos + len <= to -> 0 <= len -> + Mem.loadbytes m b pos len = Some (repeat (Byte Byte.zero) (Z.to_nat len)). +Proof. + intros until to; intros RZ. + induction len using (well_founded_induction (Zwf_well_founded 0)). + intros. destruct (zeq len 0). +- subst len. rewrite Mem.loadbytes_empty by lia. auto. +- replace (Z.to_nat len) with (S (Z.to_nat (len - 1))). + change (repeat (Byte Byte.zero) (S (Z.to_nat (len - 1)))) + with ((Byte Byte.zero :: nil) ++ repeat (Byte Byte.zero) (Z.to_nat (len - 1))). + replace len with (1 + (len - 1)) at 1 by lia. + apply Mem.loadbytes_concat; try lia. + + apply RZ. lia. + + apply H; unfold Zwf; lia. + + rewrite <- Z2Nat.inj_succ by lia. f_equal; lia. +Qed. + +Lemma reads_as_zeros_equiv: forall m b from to, + reads_as_zeros m b from to <-> Genv.readbytes_as_zero m b from (to - from). +Proof. + intros; split; intros. +- red; intros. set (len := Z.of_nat n). + replace n with (Z.to_nat len) by apply Nat2Z.id. + eapply reads_as_zeros_loadbytes; eauto. lia. lia. +- red; intros. red in H. apply (H i 1%nat). lia. lia. +Qed. + +(** ** Semantic correctness of state operations *) + +(** Semantic interpretation of states. *) + +Record match_state (s: state) (m: mem) (b: block) : Prop := { + match_range: + 0 <= s.(curr) <= s.(total_size); + match_contents: + Mem.loadbytes m b 0 s.(curr) = Some (boidl (rev s.(init))); + match_valid: + idlvalid 0 (rev s.(init)); + match_uninitialized: + reads_as_zeros m b s.(curr) s.(total_size) +}. + +Lemma match_size: forall s m b, + match_state s m b -> + init_data_list_size (rev s.(init)) = s.(curr). +Proof. + intros. rewrite init_data_list_size_boidl. + erewrite Mem.loadbytes_length by (eapply match_contents; eauto). + apply Z2Nat.id. eapply match_range; eauto. +Qed. + +Lemma curr_pad_to: forall s pos, + curr s <= curr (pad_to s pos) /\ pos <= curr (pad_to s pos). +Proof. + unfold pad_to; intros. destruct (zle pos (curr s)); simpl; lia. +Qed. + +Lemma total_size_pad_to: forall s pos, + total_size (pad_to s pos) = total_size s. +Proof. + unfold pad_to; intros. destruct (zle pos (curr s)); auto. +Qed. + +Lemma pad_to_correct: forall pos s m b, + match_state s m b -> pos <= s.(total_size) -> + match_state (pad_to s pos) m b. +Proof. + intros. unfold pad_to. destruct (zle pos (curr s)); auto. + destruct H; constructor; simpl; intros. +- lia. +- rewrite boidl_rev_cons. simpl. + replace pos with (s.(curr) + (pos - s.(curr))) at 1 by lia. + apply Mem.loadbytes_concat; try lia. + * auto. + * eapply reads_as_zeros_loadbytes; eauto. lia. lia. lia. +- rewrite idlvalid_app. split; auto. simpl. intuition auto using Z.divide_1_l. +- eapply reads_as_zeros_mono; eauto; lia. +Qed. + +Lemma trisection_correct: forall s m b pos sz bytes1 bytes2 il, + match_state s m b -> + trisection s.(init) (s.(curr) - (pos + sz)) sz = OK (bytes1, bytes2, il) -> + 0 <= pos -> pos + sz <= s.(curr) -> 0 <= sz -> + Mem.loadbytes m b 0 pos = Some (boidl (rev il)) + /\ Mem.loadbytes m b pos sz = Some (inj_bytes bytes2) + /\ Mem.loadbytes m b (pos + sz) (s.(curr) - (pos + sz)) = Some (inj_bytes bytes1). +Proof. + intros. apply trisection_boidl in H0. destruct H0 as (A & B & C). + set (depth := curr s - (pos + sz)) in *. + pose proof (match_contents _ _ _ H) as D. + replace (curr s) with ((pos + sz) + depth) in D by lia. + exploit Mem.loadbytes_split. eexact D. lia. lia. + rewrite Z.add_0_l. intros (bytes0 & bytes1' & LB0 & LB1 & E1). + exploit Mem.loadbytes_split. eexact LB0. lia. lia. + rewrite Z.add_0_l. intros (bytes3 & bytes2' & LB3 & LB2 & E2). + rewrite A in E1. rewrite <- app_ass in E1. + exploit list_append_injective_r. eexact E1. + { unfold inj_bytes; rewrite map_length. erewrite Mem.loadbytes_length; eauto. } + intros (E3 & E4). + rewrite E2 in E3. + exploit list_append_injective_r. eexact E3. + { unfold inj_bytes; rewrite map_length. erewrite Mem.loadbytes_length; eauto. } + intros (E5 & E6). + intuition congruence. +Qed. + +Remark decode_int_zero_ext: forall n bytes, + 0 <= n <= 4 -> n = Z.of_nat (length bytes) -> + Int.zero_ext (n * 8) (Int.repr (decode_int bytes)) = Int.repr (decode_int bytes). +Proof. + intros. + assert (0 <= decode_int bytes < two_p (n * 8)). + { rewrite H0. replace (length bytes) with (length (rev_if_be bytes)). + apply int_of_bytes_range. + apply rev_if_be_length. } + assert (two_p (n * 8) <= Int.modulus). + { apply (two_p_monotone (n * 8) 32); lia. } + unfold Int.zero_ext. + rewrite Int.unsigned_repr by (unfold Int.max_unsigned; lia). + rewrite Zbits.Zzero_ext_mod by lia. + rewrite Zmod_small by auto. auto. +Qed. + +Theorem load_int_correct: forall s m b pos isz i v, + match_state s m b -> + load_int s pos isz = OK i -> + Mem.load (chunk_for_carrier isz) m b pos = Some v -> + v = Vint i. +Proof. + intros until v; intros MS RI LD. + exploit Mem.load_valid_access. eauto. intros [PERM ALIGN]. + unfold load_int in RI. + set (chunk := chunk_for_carrier isz) in *. + set (sz := size_chunk chunk) in *. + assert (sz > 0) by (apply size_chunk_pos). + set (s1 := pad_to s (pos + sz)) in *. + assert (pos + sz <= curr s1) by (apply curr_pad_to). + monadInv RI. InvBooleans. destruct x as [[bytes1 bytes2] il]. + assert (MS': match_state s1 m b) by (apply pad_to_correct; auto). + exploit trisection_correct; eauto. lia. + intros (L1 & L2 & L3). + assert (LEN: Z.of_nat (length bytes2) = sz). + { apply Mem.loadbytes_length in L2. unfold inj_bytes in L2. + rewrite map_length in L2. rewrite L2. apply Z2Nat.id; lia. } + exploit Mem.loadbytes_load. eexact L2. exact ALIGN. rewrite LD. + unfold decode_val. rewrite proj_inj_bytes. intros E; inv E; inv EQ0. + unfold chunk, chunk_for_carrier; destruct isz; f_equal. + - apply (decode_int_zero_ext 1). lia. auto. + - apply (decode_int_zero_ext 2). lia. auto. + - apply (decode_int_zero_ext 1). lia. auto. +Qed. + +Remark loadbytes_concat_3: forall m b ofs1 len1 l1 ofs2 len2 l2 ofs3 len3 l3 len, + Mem.loadbytes m b ofs1 len1 = Some l1 -> + Mem.loadbytes m b ofs2 len2 = Some l2 -> + Mem.loadbytes m b ofs3 len3 = Some l3 -> + ofs2 = ofs1 + len1 -> ofs3 = ofs2 + len2 -> 0 <= len1 -> 0 <= len2 -> 0 <= len3 -> + len = len1 + len2 + len3 -> + Mem.loadbytes m b ofs1 len = Some (l1 ++ l2 ++ l3). +Proof. + intros. rewrite H7, <- Z.add_assoc. apply Mem.loadbytes_concat. auto. + apply Mem.loadbytes_concat. rewrite <- H2; auto. rewrite <- H2, <- H3; auto. + lia. lia. lia. lia. +Qed. + +Theorem store_data_correct: forall s m b pos i s' m', + match_state s m b -> + store_data s pos i = OK s' -> + Genv.store_init_data ge m b pos i = Some m' -> + match i with Init_space _ => False | _ => True end -> + match_state s' m' b. +Proof. + intros until m'; intros MS ST SI NOSPACE. + exploit Genv.store_init_data_aligned; eauto. intros ALIGN. + assert (VALID: idvalid i). + { destruct i; simpl; auto. simpl in SI. destruct (Genv.find_symbol ge i); try discriminate. exists b0; auto. } + unfold store_data in ST. + set (sz := init_data_size i) in *. + assert (sz >= 0) by (apply init_data_size_pos). + set (s1 := pad_to s (pos + sz)) in *. + monadInv ST. InvBooleans. + assert (U: Mem.unchanged_on (fun b i => ~(pos <= i < pos + sz)) m m'). + { eapply Genv.store_init_data_unchanged. eauto. tauto. } + exploit store_init_data_loadbytes; eauto. fold sz. intros D. + destruct (zle (curr s) pos). +- inv ST. + set (il := if zlt (curr s) pos then Init_space (pos - curr s) :: init s else init s). + assert (IL: boidl (rev il) = boidl (rev (init s)) ++ repeat (Byte Byte.zero) (Z.to_nat (pos - curr s))). + { unfold il; destruct (zlt (curr s) pos). + - simpl rev. rewrite boidl_rev_cons. simpl. auto. + - rewrite Z_to_nat_neg by lia. simpl. rewrite app_nil_r; auto. + } + constructor; simpl; intros. + + lia. + + rewrite boidl_rev_cons, IL, app_ass. + apply loadbytes_concat_3 with (len1 := curr s) (ofs2 := curr s) (len2 := pos - curr s) (ofs3 := pos) (len3 := sz); try lia. + * eapply Mem.loadbytes_unchanged_on; eauto. + intros. simpl. lia. + eapply match_contents; eauto. + * eapply Mem.loadbytes_unchanged_on; eauto. + intros. simpl. lia. + eapply reads_as_zeros_loadbytes. eapply match_uninitialized; eauto. lia. lia. lia. + * exact D. + * eapply match_range; eauto. + + rewrite idlvalid_app; split. + * unfold il; destruct (zlt (curr s) pos). + ** simpl; rewrite idlvalid_app; split. eapply match_valid; eauto. simpl. auto using Z.divide_1_l. + ** eapply match_valid; eauto. + * simpl. + replace (init_data_list_size (rev il)) with pos. tauto. + unfold il; destruct (zlt (curr s) pos). + ** simpl; rewrite init_data_list_size_app; simpl. + erewrite match_size by eauto. lia. + ** erewrite match_size by eauto. lia. + + eapply reads_as_zeros_unchanged; eauto. + eapply reads_as_zeros_mono. eapply match_uninitialized; eauto. lia. lia. + intros. simpl. lia. +- monadInv ST. destruct x as [[bytes1 bytes2] il]. inv EQ0. + assert (pos + sz <= curr s1) by (apply curr_pad_to). + assert (MS': match_state s1 m b) by (apply pad_to_correct; auto). + exploit trisection_correct; eauto. lia. + intros (L1 & L2 & L3). + constructor; simpl; intros. + + eapply match_range; eauto. + + rewrite add_rev_bytes_spec, rev_app_distr; simpl; rewrite app_ass; simpl. + rewrite <- map_rev, rev_involutive. + rewrite boidl_app. simpl. rewrite boidl_init_bytes. + apply loadbytes_concat_3 with (len1 := pos) (ofs2 := pos) (len2 := sz) (ofs3 := pos + sz) + (len3 := curr s1 - (pos + sz)); try lia. + * eapply Mem.loadbytes_unchanged_on; eauto. + intros. simpl. lia. + * exact D. + * eapply Mem.loadbytes_unchanged_on; eauto. + intros. simpl. lia. + + apply add_rev_bytes_valid. simpl; rewrite idlvalid_app; split. + * eapply trisection_valid; eauto. eapply match_valid; eauto. + * rewrite init_data_list_size_boidl. erewrite Mem.loadbytes_length by eauto. + rewrite Z2Nat.id by lia. simpl. tauto. + + eapply reads_as_zeros_unchanged; eauto. eapply match_uninitialized; eauto. + intros. simpl. lia. +Qed. + +Corollary store_int_correct: forall s m b pos isz n s' m', + match_state s m b -> + store_int s pos isz n = OK s' -> + Mem.store (chunk_for_carrier isz) m b pos (Vint n) = Some m' -> + match_state s' m' b. +Proof. + intros. eapply store_data_correct; eauto. +- destruct isz; exact H1. +- destruct isz; exact I. +Qed. + +Theorem init_data_list_of_state_correct: forall s m b il b' m1, + match_state s m b -> + init_data_list_of_state s = OK il -> + Mem.range_perm m1 b' 0 s.(total_size) Cur Writable -> + reads_as_zeros m1 b' 0 s.(total_size) -> + exists m2, + Genv.store_init_data_list ge m1 b' 0 il = Some m2 + /\ Mem.loadbytes m2 b' 0 (init_data_list_size il) = Mem.loadbytes m b 0 s.(total_size). +Proof. + intros. unfold init_data_list_of_state in H0; monadInv H0. rename l into LE. + set (s1 := pad_to s s.(total_size)) in *. + assert (MS1: match_state s1 m b) by (apply pad_to_correct; auto; lia). + apply reads_as_zeros_equiv in H2. rewrite Z.sub_0_r in H2. + assert (R: rev' (init s1) = rev (init s1)). + { unfold rev'. rewrite <- rev_alt. auto. } + assert (C: curr s1 = total_size s). + { unfold s1, pad_to. destruct zle; simpl; lia. } + assert (A: Genv.init_data_list_aligned 0 (rev (init s1))). + { exploit match_valid; eauto. generalize (rev (init s1)) 0. + induction l as [ | i l]; simpl; intuition. } + assert (B: forall id ofs, In (Init_addrof id ofs) (rev (init s1)) -> + exists b, Genv.find_symbol ge id = Some b). + { intros id ofs. exploit match_valid; eauto. generalize (rev (init s1)) 0. + induction l as [ | i l]; simpl; intuition eauto. subst i; assumption. } + exploit Genv.store_init_data_list_exists. + 2: eexact A. 2: eexact B. + erewrite match_size by eauto. rewrite C. eauto. + intros (m2 & ST). exists m2; split. +- rewrite R. auto. +- rewrite R. transitivity (Some (boidl (rev (init s1)))). + + eapply Genv.store_init_data_list_loadbytes; eauto. + erewrite match_size, C by eauto. auto. + + symmetry. rewrite <- C. eapply match_contents; eauto. +Qed. + +(** ** Total size properties *) + +Lemma total_size_store_data: forall s pos i s', + store_data s pos i = OK s' -> total_size s' = total_size s. +Proof. + unfold store_data; intros. monadInv H. destruct (zle (curr s) pos); monadInv H. +- auto. +- destruct x as [[bytes1 bytes2] il2]. inv EQ0. simpl. apply total_size_pad_to. +Qed. + +Lemma total_size_transl_init_bitfield: forall ce s ty sz p w i pos s', + transl_init_bitfield ce s ty sz p w i pos = OK s' -> total_size s' = total_size s. +Proof. + unfold transl_init_bitfield; intros. destruct i; monadInv H. destruct x; monadInv EQ0. + eapply total_size_store_data. eexact EQ2. +Qed. + +Lemma total_size_transl_init_rec: forall ce s ty i pos s', + transl_init_rec ce s ty i pos = OK s' -> total_size s' = total_size s +with total_size_transl_init_array: forall ce s tyelt il pos s', + transl_init_array ce s tyelt il pos = OK s' -> total_size s' = total_size s +with total_size_transl_init_struct: forall ce s ms il base pos s', + transl_init_struct ce s ms il base pos = OK s' -> total_size s' = total_size s. +Proof. +- destruct i; simpl; intros. + + monadInv H; eauto using total_size_store_data. + + destruct ty; monadInv H. eauto. + + destruct ty; monadInv H. destruct (co_su x); try discriminate. eauto. + + destruct ty; monadInv H. destruct (co_su x); monadInv EQ0. destruct x2. + * eauto. + * eauto using total_size_transl_init_bitfield. +- destruct il; simpl; intros. + + inv H; auto. + + monadInv H. transitivity (total_size x); eauto. +- destruct il; simpl; intros. + + inv H; auto. + + revert ms pos H. induction ms; intros. + * inv H. + * destruct (member_not_initialized a). eapply IHms; eauto. + monadInv H. transitivity (total_size x1). eauto. + destruct x0; eauto using total_size_transl_init_bitfield. Qed. (** * Soundness of the translation of initializers *) (** Soundness for single initializers. *) -Theorem transl_init_single_steps: - forall ty a data f m v1 ty1 m' v chunk b ofs m'', +Inductive exec_assign: mem -> block -> Z -> bitfield -> type -> val -> mem -> Prop := + | exec_assign_full: forall m b ofs ty v m' chunk, + access_mode ty = By_value chunk -> + Mem.store chunk m b ofs v = Some m' -> + exec_assign m b ofs Full ty v m' + | exec_assign_bits: forall m b ofs sz sg sg1 attr pos width ty n m' c, + type_is_volatile ty = false -> + 0 <= pos -> 0 < width -> pos + width <= bitsize_intsize sz -> + sg1 = (if zlt width (bitsize_intsize sz) then Signed else sg) -> + Mem.load (chunk_for_carrier sz) m b ofs = Some (Vint c) -> + Mem.store (chunk_for_carrier sz) m b ofs + (Vint (Int.bitfield_insert (first_bit sz pos width) width c n)) = Some m' -> + exec_assign m b ofs (Bits sz sg pos width) (Tint sz sg1 attr) (Vint n) m'. + +Lemma transl_init_single_sound: + forall ty a data f m v1 ty1 m' v b ofs m'', transl_init_single ge ty a = OK data -> 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 m' = Some v -> - access_mode ty = By_value chunk -> - Mem.store chunk m' b ofs v = Some m'' -> - Genv.store_init_data ge m b ofs data = Some m''. + exec_assign m' b ofs Full ty v m'' -> + Genv.store_init_data ge m b ofs data = Some m'' + /\ match data with Init_space _ => False | _ => True end. Proof. - intros. monadInv H. monadInv EQ. + intros until m''; intros TR STEPS CAST ASG. + monadInv TR. monadInv EQ. exploit constval_steps; eauto. intros [A [B C]]. subst m' ty1. exploit sem_cast_match; eauto. intros D. - unfold Genv.store_init_data. - inv D. + inv ASG. rename H into A. unfold Genv.store_init_data. inv D. - (* int *) remember Archi.ptr64 as ptr64. destruct ty; try discriminate EQ0. + destruct i0; inv EQ0. - destruct s; simpl in H2; inv H2. rewrite <- Mem.store_signed_unsigned_8; auto. auto. - destruct s; simpl in H2; inv H2. rewrite <- Mem.store_signed_unsigned_16; auto. auto. - simpl in H2; inv H2. assumption. - simpl in H2; inv H2. assumption. -+ destruct ptr64; inv EQ0. simpl in H2; unfold Mptr in H2; rewrite <- Heqptr64 in H2; inv H2. assumption. + destruct s; simpl in A; inv A. rewrite <- Mem.store_signed_unsigned_8; auto. auto. + destruct s; simpl in A; inv A. rewrite <- Mem.store_signed_unsigned_16; auto. auto. + simpl in A; inv A. auto. + simpl in A; inv A. auto. ++ destruct ptr64; inv EQ0. simpl in A; unfold Mptr in A; rewrite <- Heqptr64 in A; inv A. auto. - (* Long *) - remember Archi.ptr64 as ptr64. destruct ty; inv EQ0. -+ simpl in H2; inv H2. assumption. -+ simpl in H2; unfold Mptr in H2; destruct Archi.ptr64; inv H4. - inv H2; assumption. + remember Archi.ptr64 as ptr64. destruct ty; monadInv EQ0. ++ simpl in A; inv A. auto. ++ simpl in A; unfold Mptr in A; rewrite <- Heqptr64 in A; inv A. auto. - (* float *) destruct ty; try discriminate. - destruct f1; inv EQ0; simpl in H2; inv H2; assumption. + destruct f1; inv EQ0; simpl in A; inv A; auto. - (* single *) destruct ty; try discriminate. - destruct f1; inv EQ0; simpl in H2; inv H2; assumption. + destruct f1; inv EQ0; simpl in A; inv A; auto. - (* pointer *) unfold inj in H. - assert (data = Init_addrof b1 ofs1 /\ chunk = Mptr). + assert (X: data = Init_addrof b1 ofs1 /\ chunk = Mptr). { remember Archi.ptr64 as ptr64. destruct ty; inversion EQ0. - destruct i; inv H5. unfold Mptr. destruct Archi.ptr64; inv H6; inv H2; auto. - subst ptr64. unfold Mptr. destruct Archi.ptr64; inv H5; inv H2; auto. - inv H2. auto. } - destruct H4; subst. destruct (Genv.find_symbol ge b1); inv H. - rewrite Ptrofs.add_zero in H3. auto. + - destruct i; monadInv H2. unfold Mptr. rewrite <- Heqptr64. inv A; auto. + - monadInv H2. unfold Mptr. rewrite <- Heqptr64. inv A; auto. + - inv A; auto. + } + destruct X; subst. destruct (Genv.find_symbol ge b1); inv H. + rewrite Ptrofs.add_zero in H0. auto. - (* undef *) discriminate. Qed. -(** Size properties for initializers. *) - -Lemma transl_init_single_size: - forall ty a data, - transl_init_single ge ty a = OK data -> - init_data_size data = sizeof ge ty. -Proof. - intros. monadInv H. monadInv EQ. remember Archi.ptr64 as ptr64. destruct x. -- monadInv EQ0. -- destruct ty; try discriminate. - destruct i0; inv EQ0; auto. - destruct ptr64; inv EQ0. -Local Transparent sizeof. - unfold sizeof. rewrite <- Heqptr64; auto. -- destruct ty; inv EQ0; auto. - unfold sizeof. destruct Archi.ptr64; inv H0; auto. -- destruct ty; try discriminate. - destruct f0; inv EQ0; auto. -- destruct ty; try discriminate. - destruct f0; inv EQ0; auto. -- destruct ty; try discriminate. - destruct i0; inv EQ0; auto. - destruct Archi.ptr64 eqn:SF; inv H0. simpl. rewrite SF; auto. - destruct ptr64; inv EQ0. simpl. rewrite <- Heqptr64; auto. - inv EQ0. unfold init_data_size, sizeof. auto. -Qed. - -Notation idlsize := init_data_list_size. - -Remark padding_size: - forall frm to, frm <= to -> idlsize (tr_padding frm to) = to - frm. -Proof. - unfold tr_padding; intros. destruct (zlt frm to). - simpl. extlia. - simpl. lia. -Qed. - -Remark idlsize_app: - forall d1 d2, idlsize (d1 ++ d2) = idlsize d1 + idlsize d2. -Proof. - induction d1; simpl; intros. - auto. - rewrite IHd1. lia. -Qed. - -Remark union_field_size: - forall f ty fl, field_type f fl = OK ty -> sizeof ge ty <= sizeof_union ge fl. -Proof. - induction fl as [|[i t]]; simpl; intros. -- inv H. -- destruct (ident_eq f i). - + inv H. extlia. - + specialize (IHfl H). extlia. -Qed. - -Hypothesis ce_consistent: composite_env_consistent ge. - -Lemma tr_init_size: - forall i ty data, - tr_init ty i data -> - idlsize data = sizeof ge ty -with tr_init_array_size: - forall ty il sz data, - tr_init_array ty il sz data -> - idlsize data = sizeof ge ty * sz -with tr_init_struct_size: - forall ty fl il pos data, - tr_init_struct ty fl il pos data -> - sizeof_struct ge pos fl <= sizeof ge ty -> - idlsize data + pos = sizeof ge ty. -Proof. -Local Opaque sizeof. -- destruct 1; simpl. -+ erewrite transl_init_single_size by eauto. lia. -+ Local Transparent sizeof. simpl. eapply tr_init_array_size; eauto. -+ replace (idlsize d) with (idlsize d + 0) by lia. - eapply tr_init_struct_size; eauto. simpl. - unfold lookup_composite in H. destruct (ge.(genv_cenv)!id) as [co'|] eqn:?; inv H. - erewrite co_consistent_sizeof by (eapply ce_consistent; eauto). - unfold sizeof_composite. rewrite H0. apply align_le. - destruct (co_alignof_two_p co) as [n EQ]. rewrite EQ. apply two_power_nat_pos. -+ rewrite idlsize_app, padding_size. - exploit tr_init_size; eauto. intros EQ; rewrite EQ. lia. - simpl. unfold lookup_composite in H. destruct (ge.(genv_cenv)!id) as [co'|] eqn:?; inv H. - apply Z.le_trans with (sizeof_union ge (co_members co)). - eapply union_field_size; eauto. - erewrite co_consistent_sizeof by (eapply ce_consistent; eauto). - unfold sizeof_composite. rewrite H0. apply align_le. - destruct (co_alignof_two_p co) as [n EQ]. rewrite EQ. apply two_power_nat_pos. - -- destruct 1; simpl. -+ lia. -+ rewrite Z.mul_comm. - assert (0 <= sizeof ge ty * sz). - { apply Zmult_gt_0_le_0_compat. lia. generalize (sizeof_pos ge ty); lia. } - extlia. -+ rewrite idlsize_app. - erewrite tr_init_size by eauto. - erewrite tr_init_array_size by eauto. - ring. - -- destruct 1; simpl; intros. -+ rewrite padding_size by auto. lia. -+ rewrite ! idlsize_app, padding_size. - erewrite tr_init_size by eauto. - rewrite <- (tr_init_struct_size _ _ _ _ _ H0 H1). lia. - unfold pos1. apply align_le. apply alignof_pos. -Qed. +(* Hypothesis ce_consistent: composite_env_consistent ge. *) (** A semantics for general initializers *) Definition dummy_function := mkfunction Tvoid cc_default nil nil Sskip. -Fixpoint fields_of_struct (fl: members) (pos: Z) : list (Z * type) := - match fl with - | nil => nil - | (id1, ty1) :: fl' => - (align pos (alignof ge ty1), ty1) :: fields_of_struct fl' (align pos (alignof ge ty1) + sizeof ge ty1) +Fixpoint initialized_fields_of_struct (ms: members) (pos: Z) : res (list (Z * bitfield * type)) := + match ms with + | nil => + OK nil + | m :: ms' => + let pos' := next_field ge.(genv_cenv) pos m in + if member_not_initialized m + then initialized_fields_of_struct ms' pos' + else + do ofs_bf <- layout_field ge.(genv_cenv) pos m; + do l <- initialized_fields_of_struct ms' pos'; + OK ((ofs_bf, type_member m) :: l) end. -Inductive exec_init: mem -> block -> Z -> type -> initializer -> mem -> Prop := - | exec_init_single: forall m b ofs ty a v1 ty1 chunk m' v m'', +Inductive exec_init: mem -> block -> Z -> bitfield -> type -> initializer -> mem -> Prop := + | exec_init_single_: forall m b ofs bf ty a v1 ty1 m' v m'', star step ge (ExprState dummy_function a Kstop empty_env m) E0 (ExprState dummy_function (Eval v1 ty1) Kstop empty_env m') -> sem_cast v1 ty1 ty m' = Some v -> - 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_assign m' b ofs bf ty v m'' -> + exec_init m b ofs bf ty (Init_single a) m'' | exec_init_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 a) (Init_array il) m' - | exec_init_struct: forall m b ofs id a il co m', + exec_init m b ofs Full (Tarray ty sz a) (Init_array il) m' + | exec_init_struct_: forall m b ofs id a il co flds m', ge.(genv_cenv)!id = Some co -> co_su co = Struct -> - exec_init_list m b ofs (fields_of_struct (co_members co) 0) il m' -> - exec_init m b ofs (Tstruct id a) (Init_struct il) m' - | exec_init_union: forall m b ofs id a f i ty co m', + initialized_fields_of_struct (co_members co) 0 = OK flds -> + exec_init_struct m b ofs flds il m' -> + exec_init m b ofs Full (Tstruct id a) (Init_struct il) m' + | exec_init_union_: forall m b ofs id a f i co ty pos bf m', ge.(genv_cenv)!id = Some co -> co_su co = Union -> field_type f (co_members co) = OK ty -> - exec_init m b ofs ty i m' -> - exec_init m b ofs (Tunion id a) (Init_union f i) m' + union_field_offset ge f (co_members co) = OK (pos, bf) -> + exec_init m b (ofs + pos) bf ty i m' -> + exec_init m b ofs Full (Tunion id a) (Init_union f i) m' with exec_init_array: mem -> block -> Z -> type -> Z -> initializer_list -> mem -> Prop := | exec_init_array_nil: forall m b ofs ty sz, sz >= 0 -> exec_init_array m b ofs ty sz Init_nil m | exec_init_array_cons: forall m b ofs ty sz i1 il m' m'', - exec_init m b ofs ty i1 m' -> + exec_init m b ofs Full ty i1 m' -> exec_init_array m' b (ofs + sizeof ge ty) ty (sz - 1) il m'' -> exec_init_array m b ofs ty sz (Init_cons i1 il) m'' -with exec_init_list: mem -> block -> Z -> list (Z * type) -> initializer_list -> mem -> Prop := - | exec_init_list_nil: forall m b ofs, - exec_init_list m b ofs nil Init_nil m - | exec_init_list_cons: forall m b ofs pos ty l i1 il m' m'', - exec_init m b (ofs + pos) ty i1 m' -> - exec_init_list m' b ofs l il m'' -> - exec_init_list m b ofs ((pos, ty) :: l) (Init_cons i1 il) m''. +with exec_init_struct: mem -> block -> Z -> list (Z * bitfield * type) -> initializer_list -> mem -> Prop := + | exec_init_struct_nil: forall m b ofs, + exec_init_struct m b ofs nil Init_nil m + | exec_init_struct_cons: forall m b ofs pos bf ty l i1 il m' m'', + exec_init m b (ofs + pos) bf ty i1 m' -> + exec_init_struct m' b ofs l il m'' -> + exec_init_struct m b ofs ((pos, bf, ty) :: l) (Init_cons i1 il) m''. Scheme exec_init_ind3 := Minimality for exec_init Sort Prop with exec_init_array_ind3 := Minimality for exec_init_array Sort Prop - with exec_init_list_ind3 := Minimality for exec_init_list Sort Prop. -Combined Scheme exec_init_scheme from exec_init_ind3, exec_init_array_ind3, exec_init_list_ind3. + with exec_init_struct_ind3 := Minimality for exec_init_struct Sort Prop. +Combined Scheme exec_init_scheme from exec_init_ind3, exec_init_array_ind3, exec_init_struct_ind3. Remark exec_init_array_length: forall m b ofs ty sz il m', @@ -809,87 +1256,95 @@ Proof. induction 1; lia. Qed. -Lemma store_init_data_list_app: - forall data1 m b ofs m' data2 m'', - Genv.store_init_data_list ge m b ofs data1 = Some m' -> - Genv.store_init_data_list ge m' b (ofs + idlsize data1) data2 = Some m'' -> - Genv.store_init_data_list ge m b ofs (data1 ++ data2) = Some m''. -Proof. - induction data1; simpl; intros. - inv H. rewrite Z.add_0_r in H0. auto. - destruct (Genv.store_init_data ge m b ofs a); try discriminate. - rewrite Z.add_assoc in H0. eauto. -Qed. - -Remark store_init_data_list_padding: - forall frm to b ofs m, - Genv.store_init_data_list ge m b ofs (tr_padding frm to) = Some m. +Lemma transl_init_rec_sound: + (forall m b ofs bf ty i m', + exec_init m b ofs bf ty i m' -> + forall s s', + match_state s m b -> + match bf with + | Full => transl_init_rec ge s ty i ofs + | Bits sz sg p w => transl_init_bitfield ge s ty sz p w i ofs + end = OK s' -> + match_state s' m' b) +/\ (forall m b ofs ty sz il m', + exec_init_array m b ofs ty sz il m' -> + forall s s', + match_state s m b -> + transl_init_array ge s ty il ofs = OK s' -> + match_state s' m' b) +/\ (forall m b ofs flds il m', + exec_init_struct m b ofs flds il m' -> + forall s s' ms pos, + match_state s m b -> + initialized_fields_of_struct ms pos = OK flds -> + transl_init_struct ge s ms il ofs pos = OK s' -> + match_state s' m' b). Proof. - intros. unfold tr_padding. destruct (zlt frm to); auto. -Qed. - -Lemma tr_init_sound: - (forall m b ofs ty i m', exec_init m b ofs ty i m' -> - forall data, tr_init ty i data -> - Genv.store_init_data_list ge m b ofs data = Some m') -/\(forall m b ofs ty sz il m', exec_init_array m b ofs ty sz il m' -> - forall data, tr_init_array ty il sz data -> - Genv.store_init_data_list ge m b ofs data = Some m') -/\(forall m b ofs l il m', exec_init_list m b ofs l il m' -> - forall ty fl data pos, - l = fields_of_struct fl pos -> - tr_init_struct ty fl il pos data -> - Genv.store_init_data_list ge m b (ofs + pos) data = Some m'). -Proof. -Local Opaque sizeof. - apply exec_init_scheme; simpl; intros. + apply exec_init_scheme. - (* single *) - inv H3. simpl. erewrite transl_init_single_steps by eauto. auto. + intros until m''; intros STEP CAST ASG s s' MS TR. destruct bf; monadInv TR. + + (* full *) + exploit transl_init_single_sound; eauto. intros [P Q]. + eapply store_data_correct; eauto. + + (* bitfield *) + destruct x; monadInv EQ0. monadInv EQ. + exploit constval_steps; eauto. intros [A [B C]]. subst m' ty1. + exploit sem_cast_match; eauto. intros D. + inv ASG. inv D. + set (f := first_bit sz pos width) in *. + assert (E: Vint c = Vint x) by (eapply load_int_correct; eauto). + inv E. + eapply store_int_correct; eauto. - (* array *) - inv H1. replace (Z.max 0 sz) with sz in H7. eauto. - assert (sz >= 0) by (eapply exec_init_array_length; eauto). extlia. + intros. monadInv H2. eauto. - (* struct *) - inv H3. unfold lookup_composite in H7. rewrite H in H7. inv H7. - replace ofs with (ofs + 0) by lia. eauto. + intros. monadInv H5. unfold lookup_composite in EQ. rewrite H in EQ. inv EQ. + rewrite H0 in EQ0. eauto. - (* union *) - inv H4. unfold lookup_composite in H9. rewrite H in H9. inv H9. rewrite H1 in H12; inv H12. - eapply store_init_data_list_app. eauto. - apply store_init_data_list_padding. - -- (* array, empty *) - inv H0; auto. -- (* array, nonempty *) - inv H3. - eapply store_init_data_list_app. - eauto. - rewrite (tr_init_size _ _ _ H7). eauto. - -- (* struct, empty *) - inv H0. apply store_init_data_list_padding. -- (* struct, nonempty *) - inv H4. simpl in H3; inv H3. - eapply store_init_data_list_app. apply store_init_data_list_padding. - rewrite padding_size. - replace (ofs + pos0 + (pos2 - pos0)) with (ofs + pos2) by lia. - eapply store_init_data_list_app. + intros. monadInv H6. unfold lookup_composite in EQ. rewrite H in EQ. inv EQ. rewrite H0 in EQ0. + rewrite H1, H2 in EQ0. simpl in EQ0. eauto. +- (* array nil *) + intros. monadInv H1. auto. +- (* array cons *) + intros. monadInv H4. eauto. +- (* struct nil *) + intros. monadInv H1. auto. +- (* struct cons *) + intros. simpl in H5. revert H4 H5. generalize pos0. induction ms as [ | m1 ms]. discriminate. + simpl. destruct (member_not_initialized m1). + intros; eapply IHms; eauto. + clear IHms. intros. monadInv H5. rewrite EQ in H4. monadInv H4. inv EQ0. eauto. - rewrite (tr_init_size _ _ _ H9). - rewrite <- Z.add_assoc. eapply H2. eauto. eauto. - apply align_le. apply alignof_pos. Qed. End SOUNDNESS. Theorem transl_init_sound: - forall p m b ty i m' data, - exec_init (globalenv p) m b 0 ty i m' -> + forall p m b ty i m1 data, + let sz := sizeof (prog_comp_env p) ty in + Mem.range_perm m b 0 sz Cur Writable -> + reads_as_zeros m b 0 sz -> + exec_init (globalenv p) m b 0 Full ty i m1 -> transl_init (prog_comp_env p) ty i = OK data -> - Genv.store_init_data_list (globalenv p) m b 0 data = Some m'. + exists m2, + Genv.store_init_data_list (globalenv p) m b 0 data = Some m2 + /\ Mem.loadbytes m2 b 0 (init_data_list_size data) = Mem.loadbytes m1 b 0 sz. Proof. intros. set (ge := globalenv p) in *. - change (prog_comp_env p) with (genv_cenv ge) in H0. - destruct (tr_init_sound ge) as (A & B & C). - eapply build_composite_env_consistent. apply prog_comp_env_eq. - eapply A; eauto. apply transl_init_spec; auto. + change (prog_comp_env p) with (genv_cenv ge) in *. + unfold transl_init in H2; monadInv H2. + fold sz in EQ. set (s0 := initial_state sz) in *. + assert (match_state ge s0 m b). + { constructor; simpl. + - generalize (sizeof_pos ge ty). fold sz. lia. + - apply Mem.loadbytes_empty. lia. + - auto. + - assumption. + } + assert (match_state ge x m1 b). + { eapply (proj1 (transl_init_rec_sound ge)); eauto. } + assert (total_size x = sz). + { change sz with s0.(total_size). eapply total_size_transl_init_rec; eauto. } + rewrite <- H4. eapply init_data_list_of_state_correct; eauto; rewrite H4; auto. Qed. diff --git a/cfrontend/PrintCsyntax.ml b/cfrontend/PrintCsyntax.ml index 898a14b6..5fa9ea17 100644 --- a/cfrontend/PrintCsyntax.ml +++ b/cfrontend/PrintCsyntax.ml @@ -206,7 +206,7 @@ let rec expr p (prec, e) = then fprintf p "@[<hov 2>(" else fprintf p "@[<hov 2>"; begin match e with - | Eloc(b, ofs, _) -> + | Eloc(b, ofs, _, _) -> fprintf p "<loc%a>" !print_pointer_hook (b, ofs) | Evar(id, _) -> fprintf p "%s" (extern_atom id) @@ -536,13 +536,18 @@ let struct_or_union = function Struct -> "struct" | Union -> "union" let declare_composite p (Composite(id, su, m, a)) = fprintf p "%s %s;@ " (struct_or_union su) (extern_atom id) +let print_member p = function + | Member_plain(id, ty) -> + fprintf p "@ %s;" (name_cdecl (extern_atom id) ty) + | Member_bitfield(id, sz, sg, attr, w, _is_padding) -> + fprintf p "@ %s : %s;" + (name_cdecl (extern_atom id) (Tint(sz, sg, attr))) + (Z.to_string w) + let define_composite p (Composite(id, su, m, a)) = fprintf p "@[<v 2>%s %s%s {" (struct_or_union su) (extern_atom id) (attributes a); - List.iter - (fun (fid, fty) -> - fprintf p "@ %s;" (name_cdecl (extern_atom fid) fty)) - m; + List.iter (print_member p) m; fprintf p "@;<0 -2>};@]@ @ " let print_program p prog = diff --git a/cfrontend/SimplExpr.v b/cfrontend/SimplExpr.v index c7e57a54..bb1dbe38 100644 --- a/cfrontend/SimplExpr.v +++ b/cfrontend/SimplExpr.v @@ -13,17 +13,8 @@ (** Translation from Compcert C to Clight. Side effects are pulled out of Compcert C expressions. *) -Require Import Coqlib. -Require Import Errors. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import AST. -Require Import Ctypes. -Require Import Cop. -Require Import Csyntax. -Require Import Clight. +Require Import Coqlib Maps Integers Floats Values AST Memory Errors. +Require Import Ctypes Cop Csyntax Clight. Local Open Scope string_scope. Local Open Scope list_scope. @@ -71,8 +62,6 @@ Notation "'do' ( X , Y ) <- A ; B" := (bind2 A (fun X Y => B)) (at level 200, X ident, Y ident, A at level 100, B at level 200) : gensym_monad_scope. -Local Open Scope gensym_monad_scope. - Parameter first_unused_ident: unit -> ident. Definition initial_generator (x: unit) : generator := @@ -96,6 +85,12 @@ Fixpoint makeseq_rec (s: statement) (l: list statement) : statement := Definition makeseq (l: list statement) : statement := makeseq_rec Sskip l. +Section SIMPL_EXPR. + +Local Open Scope gensym_monad_scope. + +Variable ce: composite_env. + (** Smart constructor for [if ... then ... else]. *) Fixpoint eval_simpl_expr (a: expr) : option val := @@ -144,16 +139,64 @@ Definition transl_incrdecr (id: incr_or_decr) (a: expr) (ty: type) : expr := | Decr => Ebinop Osub a (Econst_int Int.one type_int32s) (incrdecr_type ty) end. -(** Generate a [Sset] or [Sbuiltin] operation as appropriate - to dereference a l-value [l] and store its result in temporary variable [id]. *) +(** Given a simple l-value expression [l], determine whether it + designates a bitfield. *) + +Definition is_bitfield_access_aux + (fn: composite_env -> ident -> members -> res (Z * bitfield)) + (id: ident) (fld: ident) : mon bitfield := + match ce!id with + | None => error (MSG "unknown composite " :: CTX id :: nil) + | Some co => + match fn ce fld (co_members co) with + | OK (_, bf) => ret bf + | Error _ => error (MSG "unknown field " :: CTX fld :: nil) + end + end. -Definition chunk_for_volatile_type (ty: type) : option memory_chunk := - if type_is_volatile ty - then match access_mode ty with By_value chunk => Some chunk | _ => None end +Definition is_bitfield_access (l: expr) : mon bitfield := + match l with + | Efield r f _ => + match typeof r with + | Tstruct id _ => is_bitfield_access_aux field_offset id f + | Tunion id _ => is_bitfield_access_aux union_field_offset id f + | _ => error (msg "is_bitfield_access") + end + | _ => ret Full + end. + +(** According to the CompCert C semantics, an access to a l-value of + volatile-qualified type can either + - produce an event in the trace of observable events, or + - produce no event and behave as if no volatile qualifier was there. + + The latter case, where the volatile qualifier is ignored, happens if + - the l-value is a struct or union + - the l-value is an access to a bit field. + + The [chunk_for_volatile_type] function distinguishes between the two + cases. It returns [Some chunk] if the semantics is to produce + an observable event of the [Event_vload chunk] or [Event_vstore chunk] + kind. It returns [None] if the semantics is that of a non-volatile + access. *) + +Definition chunk_for_volatile_type (ty: type) (bf: bitfield) : option memory_chunk := + if type_is_volatile ty then + match access_mode ty with + | By_value chunk => + match bf with + | Full => Some chunk + | Bits _ _ _ _ => None + end + | _ => None + end else None. -Definition make_set (id: ident) (l: expr) : statement := - match chunk_for_volatile_type (typeof l) with +(** Generate a [Sset] or [Sbuiltin] operation as appropriate + to dereference a l-value [l] and store its result in temporary variable [id]. *) + +Definition make_set (bf: bitfield) (id: ident) (l: expr) : statement := + match chunk_for_volatile_type (typeof l) bf with | None => Sset id l | Some chunk => let typtr := Tpointer (typeof l) noattr in @@ -165,13 +208,15 @@ Definition make_set (id: ident) (l: expr) : statement := Definition transl_valof (ty: type) (l: expr) : mon (list statement * expr) := if type_is_volatile ty - then do t <- gensym ty; ret (make_set t l :: nil, Etempvar t ty) + then do t <- gensym ty; + do bf <- is_bitfield_access l; + ret (make_set bf t l :: nil, Etempvar t ty) else ret (nil, l). (** Translation of an assignment. *) -Definition make_assign (l r: expr) : statement := - match chunk_for_volatile_type (typeof l) with +Definition make_assign (bf: bitfield) (l r: expr) : statement := + match chunk_for_volatile_type (typeof l) bf with | None => Sassign l r | Some chunk => @@ -181,6 +226,30 @@ Definition make_assign (l r: expr) : statement := (Eaddrof l typtr :: r :: nil) end. +(** Translation of the value of an assignment expression. + For non-bitfield assignments, it's the value of the right-hand side + converted to the type of the left-hand side. + For assignments to bitfields, an additional normalization to + the width and signedness of the bitfield is required. *) + +Definition make_normalize (sz: intsize) (sg: signedness) (width: Z) (r: expr) := + let intconst (n: Z) := Econst_int (Int.repr n) type_int32s in + if intsize_eq sz IBool || signedness_eq sg Unsigned then + let mask := two_p width - 1 in + Ebinop Oand r (intconst mask) (typeof r) + else + let amount := Int.zwordsize - width in + Ebinop Oshr + (Ebinop Oshl r (intconst amount) type_int32s) + (intconst amount) + (typeof r). + +Definition make_assign_value (bf: bitfield) (r: expr): expr := + match bf with + | Full => r + | Bits sz sg pos width => make_normalize sz sg width r + 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] @@ -229,7 +298,7 @@ Definition sd_seqbool_set (ty: type) (sd: set_destination) := Fixpoint transl_expr (dst: destination) (a: Csyntax.expr) : mon (list statement * expr) := match a with - | Csyntax.Eloc b ofs ty => + | Csyntax.Eloc b ofs bf ty => error (msg "SimplExpr.transl_expr: Eloc") | Csyntax.Evar x ty => ret (finish dst nil (Evar x ty)) @@ -335,16 +404,17 @@ Fixpoint transl_expr (dst: destination) (a: Csyntax.expr) : mon (list statement | Csyntax.Eassign l1 r2 ty => do (sl1, a1) <- transl_expr For_val l1; do (sl2, a2) <- transl_expr For_val r2; + do bf <- is_bitfield_access a1; let ty1 := Csyntax.typeof l1 in let ty2 := Csyntax.typeof r2 in match dst with | For_val | For_set _ => do t <- gensym ty1; ret (finish dst - (sl1 ++ sl2 ++ Sset t (Ecast a2 ty1) :: make_assign a1 (Etempvar t ty1) :: nil) - (Etempvar t ty1)) + (sl1 ++ sl2 ++ Sset t (Ecast a2 ty1) :: make_assign bf a1 (Etempvar t ty1) :: nil) + (make_assign_value bf (Etempvar t ty1))) | For_effects => - ret (sl1 ++ sl2 ++ make_assign a1 a2 :: nil, + ret (sl1 ++ sl2 ++ make_assign bf a1 a2 :: nil, dummy_expr) end | Csyntax.Eassignop op l1 r2 tyres ty => @@ -352,31 +422,33 @@ Fixpoint transl_expr (dst: destination) (a: Csyntax.expr) : mon (list statement do (sl1, a1) <- transl_expr For_val l1; do (sl2, a2) <- transl_expr For_val r2; do (sl3, a3) <- transl_valof ty1 a1; + do bf <- is_bitfield_access a1; match dst with | For_val | For_set _ => do t <- gensym ty1; ret (finish dst (sl1 ++ sl2 ++ sl3 ++ Sset t (Ecast (Ebinop op a3 a2 tyres) ty1) :: - make_assign a1 (Etempvar t ty1) :: nil) - (Etempvar t ty1)) + make_assign bf a1 (Etempvar t ty1) :: nil) + (make_assign_value bf (Etempvar t ty1))) | For_effects => - ret (sl1 ++ sl2 ++ sl3 ++ make_assign a1 (Ebinop op a3 a2 tyres) :: nil, + ret (sl1 ++ sl2 ++ sl3 ++ make_assign bf a1 (Ebinop op a3 a2 tyres) :: nil, dummy_expr) end | Csyntax.Epostincr id l1 ty => let ty1 := Csyntax.typeof l1 in do (sl1, a1) <- transl_expr For_val l1; + do bf <- is_bitfield_access a1; match dst with | For_val | For_set _ => do t <- gensym ty1; ret (finish dst - (sl1 ++ make_set t a1 :: - make_assign a1 (transl_incrdecr id (Etempvar t ty1) ty1) :: nil) + (sl1 ++ make_set bf t a1 :: + make_assign bf a1 (transl_incrdecr id (Etempvar t ty1) ty1) :: nil) (Etempvar t ty1)) | For_effects => do (sl2, a2) <- transl_valof ty1 a1; - ret (sl1 ++ sl2 ++ make_assign a1 (transl_incrdecr id a2 ty1) :: nil, + ret (sl1 ++ sl2 ++ make_assign bf a1 (transl_incrdecr id a2 ty1) :: nil, dummy_expr) end | Csyntax.Ecomma r1 r2 ty => @@ -424,12 +496,6 @@ Definition transl_expression (r: Csyntax.expr) : mon (statement * expr) := Definition transl_expr_stmt (r: Csyntax.expr) : mon statement := do (sl, a) <- transl_expr For_effects r; ret (makeseq sl). -(* -Definition transl_if (r: Csyntax.expr) (s1 s2: statement) : mon statement := - do (sl, a) <- transl_expr For_val r; - ret (makeseq (sl ++ makeif a s1 s2 :: nil)). -*) - Definition transl_if (r: Csyntax.expr) (s1 s2: statement) : mon statement := do (sl, a) <- transl_expr For_val r; ret (makeseq (sl ++ makeif a s1 s2 :: nil)). @@ -533,8 +599,12 @@ Definition transl_fundef (fd: Csyntax.fundef) : res fundef := OK (External ef targs tres cc) end. +End SIMPL_EXPR. + +Local Open Scope error_monad_scope. + Definition transl_program (p: Csyntax.program) : res program := - do p1 <- AST.transform_partial_program transl_fundef p; + do p1 <- AST.transform_partial_program (transl_fundef p.(prog_comp_env)) p; OK {| prog_defs := AST.prog_defs p1; prog_public := AST.prog_public p1; prog_main := AST.prog_main p1; diff --git a/cfrontend/SimplExprproof.v b/cfrontend/SimplExprproof.v index 2d059ddd..67bf0e51 100644 --- a/cfrontend/SimplExprproof.v +++ b/cfrontend/SimplExprproof.v @@ -22,7 +22,7 @@ Require Import SimplExpr SimplExprspec. (** ** Relational specification of the translation. *) Definition match_prog (p: Csyntax.program) (tp: Clight.program) := - match_program (fun ctx f tf => tr_fundef f tf) eq p tp + match_program_gen tr_fundef eq p p tp /\ prog_types tp = prog_types p. Lemma transf_program_match: @@ -30,8 +30,9 @@ Lemma transf_program_match: Proof. unfold transl_program; intros. monadInv H. split; auto. unfold program_of_program; simpl. destruct x; simpl. - eapply match_transform_partial_program_contextual. eexact EQ. - intros. apply transl_fundef_spec; auto. + eapply match_transform_partial_program2; eauto. +- intros. apply transl_fundef_spec; auto. +- intros. inv H. auto. Qed. (** ** Semantic preservation *) @@ -65,25 +66,19 @@ Proof (Genv.senv_match (proj1 TRANSL)). Lemma function_ptr_translated: forall b f, Genv.find_funct_ptr ge b = Some f -> - exists tf, - Genv.find_funct_ptr tge b = Some tf /\ tr_fundef f tf. -Proof. - intros. - edestruct (Genv.find_funct_ptr_match (proj1 TRANSL)) as (ctx & tf & A & B & C); eauto. -Qed. + exists cu tf, + Genv.find_funct_ptr tge b = Some tf /\ tr_fundef cu f tf /\ linkorder cu prog. +Proof (Genv.find_funct_ptr_match (proj1 TRANSL)). Lemma functions_translated: forall v f, Genv.find_funct ge v = Some f -> - exists tf, - Genv.find_funct tge v = Some tf /\ tr_fundef f tf. -Proof. - intros. - edestruct (Genv.find_funct_match (proj1 TRANSL)) as (ctx & tf & A & B & C); eauto. -Qed. + exists cu tf, + Genv.find_funct tge v = Some tf /\ tr_fundef cu f tf /\ linkorder cu prog. +Proof (Genv.find_funct_match (proj1 TRANSL)). Lemma type_of_fundef_preserved: - forall f tf, tr_fundef f tf -> + forall cu f tf, tr_fundef cu f tf -> type_of_fundef tf = Csyntax.type_of_fundef f. Proof. intros. inv H. @@ -92,7 +87,7 @@ Proof. Qed. Lemma function_return_preserved: - forall f tf, tr_function f tf -> + forall ce f tf, tr_function ce f tf -> fn_return tf = Csyntax.fn_return f. Proof. intros. inv H; auto. @@ -100,10 +95,16 @@ Qed. (** Properties of smart constructors. *) +Section TRANSLATION. + +Variable cunit: Csyntax.program. +Hypothesis LINKORDER: linkorder cunit prog. +Let ce := cunit.(prog_comp_env). + Lemma eval_Ederef': forall ge e le m a t l ofs, eval_expr ge e le m a (Vptr l ofs) -> - eval_lvalue ge e le m (Ederef' a t) l ofs. + eval_lvalue ge e le m (Ederef' a t) l ofs Full. Proof. intros. unfold Ederef'; destruct a; auto using eval_Ederef. destruct (type_eq t (typeof a)); auto using eval_Ederef. @@ -120,7 +121,7 @@ Qed. Lemma eval_Eaddrof': forall ge e le m a t l ofs, - eval_lvalue ge e le m a l ofs -> + eval_lvalue ge e le m a l ofs Full -> eval_expr ge e le m (Eaddrof' a t) (Vptr l ofs). Proof. intros. unfold Eaddrof'; destruct a; auto using eval_Eaddrof. @@ -134,12 +135,45 @@ Proof. unfold Eaddrof'; intros; destruct a; auto. destruct (type_eq t (typeof a)); auto. Qed. +Lemma eval_make_normalize: + forall ge e le m a n sz sg sg1 attr width, + 0 < width -> width <= bitsize_intsize sz -> + typeof a = Tint sz sg1 attr -> + eval_expr ge e le m a (Vint n) -> + eval_expr ge e le m (make_normalize sz sg width a) (Vint (bitfield_normalize sz sg width n)). +Proof. + intros. unfold make_normalize, bitfield_normalize. + assert (bitsize_intsize sz <= Int.zwordsize) by (destruct sz; compute; congruence). + destruct (intsize_eq sz IBool || signedness_eq sg Unsigned). +- rewrite Int.zero_ext_and by lia. econstructor. eauto. econstructor. + rewrite H1; simpl. unfold sem_and, sem_binarith. + assert (A: exists sg2, classify_binarith (Tint sz sg1 attr) type_int32s = bin_case_i sg2). + { unfold classify_binarith. unfold type_int32s. destruct sz, sg1; econstructor; eauto. } + destruct A as (sg2 & A); rewrite A. + unfold binarith_type. + assert (B: forall i sz0 sg0 attr0, + sem_cast (Vint i) (Tint sz0 sg0 attr0) (Tint I32 sg2 noattr) m = Some (Vint i)). + { intros. unfold sem_cast, classify_cast. destruct Archi.ptr64; reflexivity. } + unfold type_int32s; rewrite ! B. auto. +- rewrite Int.sign_ext_shr_shl by lia. + set (amount := Int.repr (Int.zwordsize - width)). + assert (LT: Int.ltu amount Int.iwordsize = true). + { unfold Int.ltu. rewrite Int.unsigned_repr_wordsize. apply zlt_true. + unfold amount; rewrite Int.unsigned_repr. lia. + assert (Int.zwordsize < Int.max_unsigned) by reflexivity. lia. } + econstructor. + econstructor. eauto. econstructor. + rewrite H1. unfold sem_binary_operation, sem_shl, sem_shift. rewrite LT. destruct sz, sg1; reflexivity. + econstructor. + unfold sem_binary_operation, sem_shr, sem_shift. rewrite LT. reflexivity. +Qed. + (** Translation of simple expressions. *) Lemma tr_simple_nil: - (forall le dst r sl a tmps, tr_expr le dst r sl a tmps -> + (forall le dst r sl a tmps, tr_expr ce le dst r sl a tmps -> dst = For_val \/ dst = For_effects -> simple r = true -> sl = nil) -/\(forall le rl sl al tmps, tr_exprlist le rl sl al tmps -> +/\(forall le rl sl al tmps, tr_exprlist ce le rl sl al tmps -> simplelist rl = true -> sl = nil). Proof. assert (A: forall dst a, dst = For_val \/ dst = For_effects -> final dst a = nil). @@ -160,52 +194,104 @@ Proof. Qed. Lemma tr_simple_expr_nil: - forall le dst r sl a tmps, tr_expr le dst r sl a tmps -> + forall le dst r sl a tmps, tr_expr ce le dst r sl a tmps -> dst = For_val \/ dst = For_effects -> simple r = true -> sl = nil. Proof (proj1 tr_simple_nil). Lemma tr_simple_exprlist_nil: - forall le rl sl al tmps, tr_exprlist le rl sl al tmps -> + forall le rl sl al tmps, tr_exprlist ce le rl sl al tmps -> simplelist rl = true -> sl = nil. Proof (proj2 tr_simple_nil). (** Translation of [deref_loc] and [assign_loc] operations. *) Remark deref_loc_translated: - forall ty m b ofs t v, - Csem.deref_loc ge ty m b ofs t v -> - match chunk_for_volatile_type ty with - | None => t = E0 /\ Clight.deref_loc ty m b ofs v - | Some chunk => volatile_load tge chunk m b ofs t v + forall ty m b ofs bf t v, + Csem.deref_loc ge ty m b ofs bf t v -> + match chunk_for_volatile_type ty bf with + | None => t = E0 /\ Clight.deref_loc ty m b ofs bf v + | Some chunk => bf = Full /\ volatile_load tge chunk m b ofs t v end. Proof. intros. unfold chunk_for_volatile_type. inv H. - (* By_value, not volatile *) +- (* By_value, not volatile *) rewrite H1. split; auto. eapply deref_loc_value; eauto. - (* By_value, volatile *) - rewrite H0; rewrite H1. eapply volatile_load_preserved with (ge1 := ge); auto. apply senv_preserved. - (* By reference *) +- (* By_value, volatile *) + rewrite H0, H1. split; auto. eapply volatile_load_preserved with (ge1 := ge); auto. apply senv_preserved. +- (* By reference *) rewrite H0. destruct (type_is_volatile ty); split; auto; eapply deref_loc_reference; eauto. - (* By copy *) +- (* By copy *) rewrite H0. destruct (type_is_volatile ty); split; auto; eapply deref_loc_copy; eauto. +- (* Bitfield *) + destruct (type_is_volatile ty); [destruct (access_mode ty)|]; auto using deref_loc_bitfield. Qed. Remark assign_loc_translated: - forall ty m b ofs v t m', - Csem.assign_loc ge ty m b ofs v t m' -> - match chunk_for_volatile_type ty with - | None => t = E0 /\ Clight.assign_loc tge ty m b ofs v m' - | Some chunk => volatile_store tge chunk m b ofs v t m' + forall ty m b ofs bf v t m' v', + Csem.assign_loc ge ty m b ofs bf v t m' v' -> + match chunk_for_volatile_type ty bf with + | None => t = E0 /\ Clight.assign_loc tge ty m b ofs bf v m' + | Some chunk => bf = Full /\ volatile_store tge chunk m b ofs v t m' end. Proof. intros. unfold chunk_for_volatile_type. inv H. - (* By_value, not volatile *) +- (* By_value, not volatile *) rewrite H1. split; auto. eapply assign_loc_value; eauto. - (* By_value, volatile *) - rewrite H0; rewrite H1. eapply volatile_store_preserved with (ge1 := ge); auto. apply senv_preserved. - (* By copy *) +- (* By_value, volatile *) + rewrite H0, H1. split; auto. eapply volatile_store_preserved with (ge1 := ge); auto. apply senv_preserved. +- (* By copy *) rewrite H0. rewrite <- comp_env_preserved in *. destruct (type_is_volatile ty); split; auto; eapply assign_loc_copy; eauto. +- (* Bitfield *) + destruct (type_is_volatile ty); [destruct (access_mode ty)|]; eauto using assign_loc_bitfield. +Qed. + +(** Bitfield accesses *) + +Lemma is_bitfield_access_sound: forall e le m a b ofs bf bf', + eval_lvalue tge e le m a b ofs bf -> + tr_is_bitfield_access ce a bf' -> + bf' = bf. +Proof. + assert (A: forall id co co', + tge.(genv_cenv)!id = Some co -> ce!id = Some co' -> + co' = co /\ complete_members ce (co_members co) = true). + { intros. rewrite comp_env_preserved in H. + assert (ge.(Csem.genv_cenv) ! id = Some co') by (apply LINKORDER; auto). + replace co' with co in * by congruence. + split; auto. apply co_consistent_complete. + eapply build_composite_env_consistent. eapply prog_comp_env_eq. eauto. + } + induction 1; simpl; auto. +- rewrite H0. intros (co' & delta' & E1 & E2). rewrite comp_env_preserved in H2. + exploit A; eauto. intros (E3 & E4). subst co'. + assert (field_offset ge i (co_members co) = field_offset ce i (co_members co)). + { apply field_offset_stable. apply LINKORDER. auto. } + congruence. +- rewrite H0. intros (co' & delta' & E1 & E2). rewrite comp_env_preserved in H2. + exploit A; eauto. intros (E3 & E4). subst co'. + assert (union_field_offset ge i (co_members co) = union_field_offset ce i (co_members co)). + { apply union_field_offset_stable. apply LINKORDER. auto. } + congruence. +Qed. + +Lemma make_assign_value_sound: + forall ty m b ofs bf v t m' v', + Csem.assign_loc ge ty m b ofs bf v t m' v' -> + forall tge e le m'' r, + typeof r = ty -> + eval_expr tge e le m'' r v -> + eval_expr tge e le m'' (make_assign_value bf r) v'. +Proof. + unfold make_assign_value; destruct 1; intros; auto. + inv H. eapply eval_make_normalize; eauto; lia. +Qed. + +Lemma typeof_make_assign_value: forall bf r, + typeof (make_assign_value bf r) = typeof r. +Proof. + intros. destruct bf; simpl; auto. unfold make_normalize. + destruct (intsize_eq sz IBool || signedness_eq sg Unsigned); auto. Qed. (** Evaluation of simple expressions and of their translation *) @@ -215,7 +301,7 @@ Lemma tr_simple: (forall r v, eval_simple_rvalue ge e m r v -> forall le dst sl a tmps, - tr_expr le dst r sl a tmps -> + tr_expr ce le dst r sl a tmps -> match dst with | For_val => sl = nil /\ Csyntax.typeof r = typeof a /\ eval_expr tge e le m a v | For_effects => sl = nil @@ -225,11 +311,11 @@ Lemma tr_simple: /\ eval_expr tge e le m b v end) /\ - (forall l b ofs, - eval_simple_lvalue ge e m l b ofs -> + (forall l b ofs bf, + eval_simple_lvalue ge e m l b ofs bf -> forall le sl a tmps, - tr_expr le For_val l sl a tmps -> - sl = nil /\ Csyntax.typeof l = typeof a /\ eval_lvalue tge e le m a b ofs). + tr_expr ce le For_val l sl a tmps -> + sl = nil /\ Csyntax.typeof l = typeof a /\ eval_lvalue tge e le m a b ofs bf). Proof. Opaque makeif. intros e m. @@ -306,7 +392,7 @@ Lemma tr_simple_rvalue: forall e m r v, eval_simple_rvalue ge e m r v -> forall le dst sl a tmps, - tr_expr le dst r sl a tmps -> + tr_expr ce le dst r sl a tmps -> match dst with | For_val => sl = nil /\ Csyntax.typeof r = typeof a /\ eval_expr tge e le m a v | For_effects => sl = nil @@ -320,18 +406,18 @@ Proof. Qed. Lemma tr_simple_lvalue: - forall e m l b ofs, - eval_simple_lvalue ge e m l b ofs -> + forall e m l b ofs bf, + eval_simple_lvalue ge e m l b ofs bf -> forall le sl a tmps, - tr_expr le For_val l sl a tmps -> - sl = nil /\ Csyntax.typeof l = typeof a /\ eval_lvalue tge e le m a b ofs. + tr_expr ce le For_val l sl a tmps -> + sl = nil /\ Csyntax.typeof l = typeof a /\ eval_lvalue tge e le m a b ofs bf. Proof. intros e m. exact (proj2 (tr_simple e m)). Qed. Lemma tr_simple_exprlist: forall le rl sl al tmps, - tr_exprlist le rl sl al tmps -> + tr_exprlist ce le rl sl al tmps -> forall e m tyl vl, eval_simple_list ge e m rl tyl vl -> sl = nil /\ eval_exprlist tge e le m al tyl vl. @@ -362,29 +448,29 @@ Lemma tr_expr_leftcontext_rec: ( forall from to C, leftcontext from to C -> forall le e dst sl a tmps, - tr_expr le dst (C e) sl a tmps -> + tr_expr ce le dst (C e) sl a tmps -> exists dst', exists sl1, exists sl2, exists a', exists tmp', - tr_expr le dst' e sl1 a' tmp' + tr_expr ce le dst' e sl1 a' tmp' /\ sl = sl1 ++ sl2 /\ incl tmp' tmps /\ (forall le' e' sl3, - tr_expr le' dst' e' sl3 a' tmp' -> + tr_expr ce le' dst' e' sl3 a' tmp' -> (forall id, ~In id tmp' -> le'!id = le!id) -> Csyntax.typeof e' = Csyntax.typeof e -> - tr_expr le' dst (C e') (sl3 ++ sl2) a tmps) + tr_expr ce le' dst (C e') (sl3 ++ sl2) a tmps) ) /\ ( forall from C, leftcontextlist from C -> forall le e sl a tmps, - tr_exprlist le (C e) sl a tmps -> + tr_exprlist ce le (C e) sl a tmps -> exists dst', exists sl1, exists sl2, exists a', exists tmp', - tr_expr le dst' e sl1 a' tmp' + tr_expr ce le dst' e sl1 a' tmp' /\ sl = sl1 ++ sl2 /\ incl tmp' tmps /\ (forall le' e' sl3, - tr_expr le' dst' e' sl3 a' tmp' -> + tr_expr ce le' dst' e' sl3 a' tmp' -> (forall id, ~In id tmp' -> le'!id = le!id) -> Csyntax.typeof e' = Csyntax.typeof e -> - tr_exprlist le' (C e') (sl3 ++ sl2) a tmps) + tr_exprlist ce le' (C e') (sl3 ++ sl2) a tmps) ). Proof. @@ -553,7 +639,7 @@ Ltac UNCHANGED := red; auto. intros. rewrite <- app_ass. econstructor. apply S; auto. eapply tr_expr_invariant; eauto. UNCHANGED. - auto. auto. auto. + auto. auto. auto. auto. + (* for val *) exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [R S]]]]]]]]. TR. subst sl1. rewrite app_ass. eauto. @@ -561,7 +647,7 @@ Ltac UNCHANGED := intros. rewrite <- app_ass. econstructor. apply S; auto. eapply tr_expr_invariant; eauto. UNCHANGED. auto. auto. auto. auto. auto. auto. - eapply typeof_context; eauto. + eapply typeof_context. eauto. auto. eauto. auto. - (* assign right *) inv H2. @@ -573,7 +659,7 @@ Ltac UNCHANGED := intros. rewrite <- app_ass. change (sl3 ++ sl2') with (nil ++ (sl3 ++ sl2')). rewrite app_ass. econstructor. eapply tr_expr_invariant; eauto. UNCHANGED. - apply S; auto. auto. auto. auto. + apply S; 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 [R S]]]]]]]]. @@ -583,7 +669,7 @@ Ltac UNCHANGED := econstructor. eapply tr_expr_invariant; eauto. UNCHANGED. apply S; auto. auto. auto. auto. auto. auto. auto. auto. - eapply typeof_context; eauto. + eapply typeof_context; eauto. auto. - (* assignop left *) inv H1. + (* for effects *) @@ -593,7 +679,7 @@ Ltac UNCHANGED := intros. rewrite <- app_ass. econstructor. apply S; auto. eapply tr_expr_invariant; eauto. UNCHANGED. symmetry; eapply typeof_context; eauto. eauto. - auto. auto. auto. auto. auto. auto. + auto. auto. auto. auto. auto. auto. auto. + (* for val *) exploit H0; eauto. intros [dst' [sl1' [sl2' [a' [tmp' [P [Q [R S]]]]]]]]. TR. subst sl1. rewrite app_ass. eauto. @@ -601,7 +687,7 @@ Ltac UNCHANGED := intros. rewrite <- app_ass. econstructor. apply S; auto. eapply tr_expr_invariant; eauto. UNCHANGED. eauto. auto. auto. auto. auto. auto. auto. auto. auto. auto. auto. - eapply typeof_context; eauto. + eapply typeof_context; eauto. auto. - (* assignop right *) inv H2. + (* for effects *) @@ -611,7 +697,7 @@ Ltac UNCHANGED := red; auto. 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. eauto. auto. auto. auto. auto. auto. auto. + apply S; auto. auto. eauto. auto. 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 [R S]]]]]]]]. @@ -619,7 +705,7 @@ Ltac UNCHANGED := red; auto. intros. rewrite <- app_ass. change (sl0 ++ sl2') with (nil ++ sl0 ++ sl2'). rewrite app_ass. econstructor. eapply tr_expr_invariant; eauto. UNCHANGED. - apply S; auto. eauto. auto. auto. auto. auto. auto. auto. auto. auto. auto. auto. auto. + apply S; auto. eauto. auto. auto. auto. auto. auto. auto. auto. auto. auto. auto. auto. auto. - (* postincr *) inv H1. + (* for effects *) @@ -725,35 +811,35 @@ Qed. Theorem tr_expr_leftcontext: forall C le r dst sl a tmps, leftcontext RV RV C -> - tr_expr le dst (C r) sl a tmps -> + tr_expr ce le dst (C r) sl a tmps -> exists dst', exists sl1, exists sl2, exists a', exists tmp', - tr_expr le dst' r sl1 a' tmp' + tr_expr ce le dst' r sl1 a' tmp' /\ sl = sl1 ++ sl2 /\ incl tmp' tmps /\ (forall le' r' sl3, - tr_expr le' dst' r' sl3 a' tmp' -> + tr_expr ce le' dst' r' sl3 a' tmp' -> (forall id, ~In id tmp' -> le'!id = le!id) -> Csyntax.typeof r' = Csyntax.typeof r -> - tr_expr le' dst (C r') (sl3 ++ sl2) a tmps). + tr_expr ce le' dst (C r') (sl3 ++ sl2) a tmps). Proof. intros. eapply (proj1 tr_expr_leftcontext_rec); eauto. Qed. Theorem tr_top_leftcontext: forall e le m dst rtop sl a tmps, - tr_top tge e le m dst rtop sl a tmps -> + tr_top ce tge e le m dst rtop sl a tmps -> forall r C, rtop = C r -> leftcontext RV RV C -> exists dst', exists sl1, exists sl2, exists a', exists tmp', - tr_top tge e le m dst' r sl1 a' tmp' + tr_top ce tge e le m dst' r sl1 a' tmp' /\ sl = sl1 ++ sl2 /\ incl tmp' tmps /\ (forall le' m' r' sl3, - tr_expr le' dst' r' sl3 a' tmp' -> + tr_expr ce le' dst' r' sl3 a' tmp' -> (forall id, ~In id tmp' -> le'!id = le!id) -> Csyntax.typeof r' = Csyntax.typeof r -> - tr_top tge e le' m' dst (C r') (sl3 ++ sl2) a tmps). + tr_top ce tge e le' m' dst (C r') (sl3 ++ sl2) a tmps). Proof. induction 1; intros. (* val for val *) @@ -835,17 +921,18 @@ Proof. Qed. Lemma step_make_set: - forall id a ty m b ofs t v e le f k, - Csem.deref_loc ge ty m b ofs t v -> - eval_lvalue tge e le m a b ofs -> + forall id a ty m b ofs bf t v e le f k, + Csem.deref_loc ge ty m b ofs bf t v -> + eval_lvalue tge e le m a b ofs bf -> typeof a = ty -> - step1 tge (State f (make_set id a) k e le m) + step1 tge (State f (make_set bf id a) k e le m) t (State f Sskip k e (PTree.set id v le) m). Proof. intros. exploit deref_loc_translated; eauto. rewrite <- H1. - unfold make_set. destruct (chunk_for_volatile_type (typeof a)) as [chunk|]. + unfold make_set. destruct (chunk_for_volatile_type (typeof a) bf) as [chunk|]. (* volatile case *) - intros. change (PTree.set id v le) with (set_opttemp (Some id) v le). econstructor. + intros [A B]. subst bf. + change (PTree.set id v le) with (set_opttemp (Some id) v le). econstructor. econstructor. constructor. eauto. simpl. unfold sem_cast. simpl. eauto. constructor. simpl. econstructor; eauto. @@ -854,19 +941,19 @@ Proof. Qed. Lemma step_make_assign: - forall a1 a2 ty m b ofs t v m' v2 e le f k, - Csem.assign_loc ge ty m b ofs v t m' -> - eval_lvalue tge e le m a1 b ofs -> + forall a1 a2 ty m b ofs bf t v m' v' v2 e le f k, + Csem.assign_loc ge ty m b ofs bf v t m' v' -> + eval_lvalue tge e le m a1 b ofs bf -> eval_expr tge e le m a2 v2 -> sem_cast v2 (typeof a2) ty m = Some v -> typeof a1 = ty -> - step1 tge (State f (make_assign a1 a2) k e le m) + step1 tge (State f (make_assign bf a1 a2) k e le m) t (State f Sskip k e le m'). Proof. intros. exploit assign_loc_translated; eauto. rewrite <- H3. - unfold make_assign. destruct (chunk_for_volatile_type (typeof a1)) as [chunk|]. + unfold make_assign. destruct (chunk_for_volatile_type (typeof a1) bf) as [chunk|]. (* volatile case *) - intros. change le with (set_opttemp None Vundef le) at 2. econstructor. + intros [A B]. subst bf. change le with (set_opttemp None Vundef le) at 2. econstructor. econstructor. constructor. eauto. simpl. unfold sem_cast. simpl. eauto. econstructor; eauto. rewrite H3; eauto. constructor. @@ -900,10 +987,10 @@ Proof. Qed. Lemma step_tr_rvalof: - forall ty m b ofs t v e le a sl a' tmp f k, - Csem.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 -> + forall ty m b ofs bf t v e le a sl a' tmp f k, + Csem.deref_loc ge ty m b ofs bf t v -> + eval_lvalue tge e le m a b ofs bf -> + tr_rvalof ce ty a sl a' tmp -> typeof a = ty -> exists le', star step1 tge (State f Sskip (Kseqlist sl k) e le m) @@ -920,141 +1007,149 @@ Proof. split. eapply eval_Elvalue; eauto. auto. (* volatile *) - intros. exists (PTree.set t0 v le); split. + intros. + exploit is_bitfield_access_sound; eauto. intros EQ; subst bf0. + exists (PTree.set t0 v le); split. simpl. eapply star_two. econstructor. eapply step_make_set; eauto. traceEq. split. constructor. apply PTree.gss. split. auto. intros. apply PTree.gso. congruence. Qed. +End TRANSLATION. + + (** Matching between continuations *) -Inductive match_cont : Csem.cont -> cont -> Prop := - | match_Kstop: - match_cont Csem.Kstop Kstop - | match_Kseq: forall s k ts tk, - tr_stmt s ts -> - match_cont k tk -> - match_cont (Csem.Kseq s k) (Kseq ts tk) - | match_Kwhile2: forall r s k s' ts tk, - tr_if r Sskip Sbreak s' -> - tr_stmt s ts -> - match_cont k tk -> - match_cont (Csem.Kwhile2 r s k) - (Kloop1 (Ssequence s' ts) Sskip tk) - | match_Kdowhile1: forall r s k s' ts tk, - tr_if r Sskip Sbreak s' -> - tr_stmt s ts -> - match_cont k tk -> - match_cont (Csem.Kdowhile1 r s k) - (Kloop1 ts s' tk) - | match_Kfor3: forall r s3 s k ts3 s' ts tk, - tr_if r Sskip Sbreak s' -> - tr_stmt s3 ts3 -> - tr_stmt s ts -> - match_cont k tk -> - match_cont (Csem.Kfor3 r s3 s k) - (Kloop1 (Ssequence s' ts) ts3 tk) - | match_Kfor4: forall r s3 s k ts3 s' ts tk, - tr_if r Sskip Sbreak s' -> - tr_stmt s3 ts3 -> - tr_stmt s ts -> - match_cont k tk -> - match_cont (Csem.Kfor4 r s3 s k) - (Kloop2 (Ssequence s' ts) ts3 tk) - | match_Kswitch2: forall k tk, - match_cont k tk -> - match_cont (Csem.Kswitch2 k) (Kswitch tk) - | match_Kcall: forall f e C ty k optid tf le sl tk a dest tmps, - tr_function f tf -> - leftcontext RV RV C -> - (forall v m, tr_top tge e (set_opttemp optid v le) m dest (C (Csyntax.Eval v ty)) sl a tmps) -> - match_cont_exp dest a k tk -> - match_cont (Csem.Kcall f e C ty k) - (Kcall optid tf e le (Kseqlist sl tk)) -(* - | match_Kcall_some: forall f e C ty k dst tf le sl tk a dest tmps, - transl_function f = Errors.OK tf -> +Inductive match_cont : composite_env -> Csem.cont -> cont -> Prop := + | match_Kstop: forall ce, + match_cont ce Csem.Kstop Kstop + | match_Kseq: forall ce s k ts tk, + tr_stmt ce s ts -> + match_cont ce k tk -> + match_cont ce (Csem.Kseq s k) (Kseq ts tk) + | match_Kwhile2: forall ce r s k s' ts tk, + tr_if ce r Sskip Sbreak s' -> + tr_stmt ce s ts -> + match_cont ce k tk -> + match_cont ce (Csem.Kwhile2 r s k) + (Kloop1 (Ssequence s' ts) Sskip tk) + | match_Kdowhile1: forall ce r s k s' ts tk, + tr_if ce r Sskip Sbreak s' -> + tr_stmt ce s ts -> + match_cont ce k tk -> + match_cont ce (Csem.Kdowhile1 r s k) + (Kloop1 ts s' tk) + | match_Kfor3: forall ce r s3 s k ts3 s' ts tk, + tr_if ce r Sskip Sbreak s' -> + tr_stmt ce s3 ts3 -> + tr_stmt ce s ts -> + match_cont ce k tk -> + match_cont ce (Csem.Kfor3 r s3 s k) + (Kloop1 (Ssequence s' ts) ts3 tk) + | match_Kfor4: forall ce r s3 s k ts3 s' ts tk, + tr_if ce r Sskip Sbreak s' -> + tr_stmt ce s3 ts3 -> + tr_stmt ce s ts -> + match_cont ce k tk -> + match_cont ce (Csem.Kfor4 r s3 s k) + (Kloop2 (Ssequence s' ts) ts3 tk) + | match_Kswitch2: forall ce k tk, + match_cont ce k tk -> + match_cont ce (Csem.Kswitch2 k) (Kswitch tk) + | match_Kcall: forall f e C ty k optid tf le sl tk a dest tmps cu ce, + linkorder cu prog -> + tr_function cu.(prog_comp_env) f tf -> leftcontext RV RV C -> - (forall v m, tr_top tge e (PTree.set dst v le) m dest (C (C.Eval v ty)) sl a tmps) -> - match_cont_exp dest a k tk -> - match_cont (Csem.Kcall f e C ty k) - (Kcall (Some dst) tf e le (Kseqlist sl tk)) -*) - -with match_cont_exp : destination -> expr -> Csem.cont -> cont -> Prop := - | match_Kdo: forall k a tk, - match_cont k tk -> - match_cont_exp For_effects a (Csem.Kdo k) tk - | match_Kifthenelse_empty: forall a k tk, - match_cont k tk -> - match_cont_exp For_val a (Csem.Kifthenelse Csyntax.Sskip Csyntax.Sskip k) (Kseq Sskip tk) - | match_Kifthenelse_1: forall a s1 s2 k ts1 ts2 tk, - tr_stmt s1 ts1 -> tr_stmt s2 ts2 -> - match_cont k tk -> - match_cont_exp For_val a (Csem.Kifthenelse s1 s2 k) (Kseq (Sifthenelse a ts1 ts2) tk) - | match_Kwhile1: forall r s k s' a ts tk, - tr_if r Sskip Sbreak s' -> - tr_stmt s ts -> - match_cont k tk -> - match_cont_exp For_val a + (forall v m, tr_top cu.(prog_comp_env) tge e (set_opttemp optid v le) m dest (C (Csyntax.Eval v ty)) sl a tmps) -> + match_cont_exp cu.(prog_comp_env) dest a k tk -> + match_cont ce (Csem.Kcall f e C ty k) + (Kcall optid tf e le (Kseqlist sl tk)) + +with match_cont_exp : composite_env -> destination -> expr -> Csem.cont -> cont -> Prop := + | match_Kdo: forall ce k a tk, + match_cont ce k tk -> + match_cont_exp ce For_effects a (Csem.Kdo k) tk + | match_Kifthenelse_empty: forall ce a k tk, + match_cont ce k tk -> + match_cont_exp ce For_val a (Csem.Kifthenelse Csyntax.Sskip Csyntax.Sskip k) (Kseq Sskip tk) + | match_Kifthenelse_1: forall ce a s1 s2 k ts1 ts2 tk, + tr_stmt ce s1 ts1 -> tr_stmt ce s2 ts2 -> + match_cont ce k tk -> + match_cont_exp ce For_val a (Csem.Kifthenelse s1 s2 k) (Kseq (Sifthenelse a ts1 ts2) tk) + | match_Kwhile1: forall ce r s k s' a ts tk, + tr_if ce r Sskip Sbreak s' -> + tr_stmt ce s ts -> + match_cont ce k tk -> + match_cont_exp ce For_val a (Csem.Kwhile1 r s k) (Kseq (makeif a Sskip Sbreak) (Kseq ts (Kloop1 (Ssequence s' ts) Sskip tk))) - | match_Kdowhile2: forall r s k s' a ts tk, - tr_if r Sskip Sbreak s' -> - tr_stmt s ts -> - match_cont k tk -> - match_cont_exp For_val a + | match_Kdowhile2: forall ce r s k s' a ts tk, + tr_if ce r Sskip Sbreak s' -> + tr_stmt ce s ts -> + match_cont ce k tk -> + match_cont_exp ce For_val a (Csem.Kdowhile2 r s k) (Kseq (makeif a Sskip Sbreak) (Kloop2 ts s' tk)) - | match_Kfor2: forall r s3 s k s' a ts3 ts tk, - tr_if r Sskip Sbreak s' -> - tr_stmt s3 ts3 -> - tr_stmt s ts -> - match_cont k tk -> - match_cont_exp For_val a + | match_Kfor2: forall ce r s3 s k s' a ts3 ts tk, + tr_if ce r Sskip Sbreak s' -> + tr_stmt ce s3 ts3 -> + tr_stmt ce s ts -> + match_cont ce k tk -> + match_cont_exp ce For_val a (Csem.Kfor2 r s3 s k) (Kseq (makeif a Sskip Sbreak) (Kseq ts (Kloop1 (Ssequence s' ts) ts3 tk))) - | match_Kswitch1: forall ls k a tls tk, - tr_lblstmts ls tls -> - match_cont k tk -> - match_cont_exp For_val a (Csem.Kswitch1 ls k) (Kseq (Sswitch a tls) tk) - | match_Kreturn: forall k a tk, - match_cont k tk -> - match_cont_exp For_val a (Csem.Kreturn k) (Kseq (Sreturn (Some a)) tk). - -Lemma match_cont_call: - forall k tk, - match_cont k tk -> - match_cont (Csem.call_cont k) (call_cont tk). + | match_Kswitch1: forall ce ls k a tls tk, + tr_lblstmts ce ls tls -> + match_cont ce k tk -> + match_cont_exp ce For_val a (Csem.Kswitch1 ls k) (Kseq (Sswitch a tls) tk) + | match_Kreturn: forall ce k a tk, + match_cont ce k tk -> + match_cont_exp ce For_val a (Csem.Kreturn k) (Kseq (Sreturn (Some a)) tk). + +Lemma match_cont_is_call_cont: + forall ce k tk, + match_cont ce k tk -> Csem.is_call_cont k -> + forall ce', match_cont ce' k tk. Proof. - induction 1; simpl; auto. constructor. econstructor; eauto. + destruct 1; simpl; intros; try contradiction; econstructor; eauto. +Qed. + +Lemma match_cont_call_cont: + forall ce k tk, + match_cont ce k tk -> + forall ce', match_cont ce' (Csem.call_cont k) (call_cont tk). +Proof. + induction 1; simpl; auto; intros; econstructor; eauto. Qed. (** Matching between states *) Inductive match_states: Csem.state -> state -> Prop := - | match_exprstates: forall f r k e m tf sl tk le dest a tmps, - tr_function f tf -> - tr_top tge e le m dest r sl a tmps -> - match_cont_exp dest a k tk -> + | match_exprstates: forall f r k e m tf sl tk le dest a tmps cu + (LINK: linkorder cu prog) + (TRF: tr_function cu.(prog_comp_env) f tf) + (TR: tr_top cu.(prog_comp_env) tge e le m dest r sl a tmps) + (MK: match_cont_exp cu.(prog_comp_env) dest a k tk), match_states (Csem.ExprState f r k e m) (State tf Sskip (Kseqlist sl tk) e le m) - | match_regularstates: forall f s k e m tf ts tk le, - tr_function f tf -> - tr_stmt s ts -> - match_cont k tk -> + | match_regularstates: forall f s k e m tf ts tk le cu + (LINK: linkorder cu prog) + (TRF: tr_function cu.(prog_comp_env) f tf) + (TR: tr_stmt cu.(prog_comp_env) s ts) + (MK: match_cont cu.(prog_comp_env) k tk), match_states (Csem.State f s k e m) (State tf ts tk e le m) - | match_callstates: forall fd args k m tfd tk, - tr_fundef fd tfd -> - match_cont k tk -> + | match_callstates: forall fd args k m tfd tk cu + (LINK: linkorder cu prog) + (TR: tr_fundef cu fd tfd) + (MK: forall ce, match_cont ce k tk), match_states (Csem.Callstate fd args k m) (Callstate tfd args tk m) - | match_returnstates: forall res k m tk, - match_cont k tk -> + | match_returnstates: forall res k m tk + (MK: forall ce, match_cont ce k tk), match_states (Csem.Returnstate res k m) (Returnstate res tk m) | match_stuckstate: forall S, @@ -1063,21 +1158,22 @@ Inductive match_states: Csem.state -> state -> Prop := (** Additional results on translation of statements *) Lemma tr_select_switch: - forall n ls tls, - tr_lblstmts ls tls -> - tr_lblstmts (Csem.select_switch n ls) (select_switch n tls). + forall ce n ls tls, + tr_lblstmts ce ls tls -> + tr_lblstmts ce (Csem.select_switch n ls) (select_switch n tls). Proof. + intros ce. assert (DFL: forall ls tls, - tr_lblstmts ls tls -> - tr_lblstmts (Csem.select_switch_default ls) (select_switch_default tls)). + tr_lblstmts ce ls tls -> + tr_lblstmts ce (Csem.select_switch_default ls) (select_switch_default tls)). { induction 1; simpl. constructor. destruct c; auto. constructor; auto. } assert (CASE: forall n ls tls, - tr_lblstmts ls tls -> + tr_lblstmts ce ls tls -> match Csem.select_switch_case n ls with | None => select_switch_case n tls = None | Some ls' => - exists tls', select_switch_case n tls = Some tls' /\ tr_lblstmts ls' tls' + exists tls', select_switch_case n tls = Some tls' /\ tr_lblstmts ce ls' tls' end). { induction 1; simpl; intros. auto. @@ -1091,9 +1187,9 @@ Proof. Qed. Lemma tr_seq_of_labeled_statement: - forall ls tls, - tr_lblstmts ls tls -> - tr_stmt (Csem.seq_of_labeled_statement ls) (seq_of_labeled_statement tls). + forall ce ls tls, + tr_lblstmts ce ls tls -> + tr_stmt ce (Csem.seq_of_labeled_statement ls) (seq_of_labeled_statement tls). Proof. induction 1; simpl; constructor; auto. Qed. @@ -1102,6 +1198,7 @@ Qed. Section FIND_LABEL. +Variable ce: composite_env. Variable lbl: label. Definition nolabel (s: statement) : Prop := @@ -1137,21 +1234,21 @@ Proof. Qed. Lemma make_set_nolabel: - forall t a, nolabel (make_set t a). + forall bf t a, nolabel (make_set bf t a). Proof. unfold make_set; intros; red; intros. - destruct (chunk_for_volatile_type (typeof a)); auto. + destruct (chunk_for_volatile_type (typeof a) bf); auto. Qed. Lemma make_assign_nolabel: - forall l r, nolabel (make_assign l r). + forall bf l r, nolabel (make_assign bf l r). Proof. unfold make_assign; intros; red; intros. - destruct (chunk_for_volatile_type (typeof l)); auto. + destruct (chunk_for_volatile_type (typeof l) bf); auto. Qed. Lemma tr_rvalof_nolabel: - forall ty a sl a' tmp, tr_rvalof ty a sl a' tmp -> nolabel_list sl. + forall ce ty a sl a' tmp, tr_rvalof ce ty a sl a' tmp -> nolabel_list sl. Proof. destruct 1; simpl; intuition. apply make_set_nolabel. Qed. @@ -1177,16 +1274,16 @@ Ltac NoLabelTac := | [ H: _ -> nolabel_list ?x |- nolabel_list ?x ] => apply H; NoLabelTac | [ |- nolabel (makeseq _) ] => apply makeseq_nolabel; NoLabelTac | [ |- nolabel (makeif _ _ _) ] => apply makeif_nolabel; NoLabelTac - | [ |- nolabel (make_set _ _) ] => apply make_set_nolabel - | [ |- nolabel (make_assign _ _) ] => apply make_assign_nolabel + | [ |- nolabel (make_set _ _ _) ] => apply make_set_nolabel + | [ |- nolabel (make_assign _ _ _) ] => apply make_assign_nolabel | [ |- nolabel _ ] => red; intros; simpl; auto | [ |- _ /\ _ ] => split; NoLabelTac | _ => auto end. Lemma tr_find_label_expr: - (forall le dst r sl a tmps, tr_expr le dst r sl a tmps -> nolabel_list sl) -/\(forall le rl sl al tmps, tr_exprlist le rl sl al tmps -> nolabel_list sl). + (forall le dst r sl a tmps, tr_expr ce le dst r sl a tmps -> nolabel_list sl) +/\(forall le rl sl al tmps, tr_exprlist ce le rl sl al tmps -> nolabel_list sl). Proof. apply tr_expr_exprlist; intros; NoLabelTac. apply nolabel_do_set. @@ -1200,14 +1297,14 @@ Qed. Lemma tr_find_label_top: forall e le m dst r sl a tmps, - tr_top tge e le m dst r sl a tmps -> nolabel_list sl. + tr_top ce tge e le m dst r sl a tmps -> nolabel_list sl. Proof. induction 1; intros; NoLabelTac. eapply (proj1 tr_find_label_expr); eauto. Qed. Lemma tr_find_label_expression: - forall r s a, tr_expression r s a -> forall k, find_label lbl s k = None. + forall r s a, tr_expression ce r s a -> forall k, find_label lbl s k = None. Proof. intros. inv H. assert (nolabel (makeseq sl)). apply makeseq_nolabel. @@ -1216,7 +1313,7 @@ Proof. Qed. Lemma tr_find_label_expr_stmt: - forall r s, tr_expr_stmt r s -> forall k, find_label lbl s k = None. + forall r s, tr_expr_stmt ce r s -> forall k, find_label lbl s k = None. Proof. intros. inv H. assert (nolabel (makeseq sl)). apply makeseq_nolabel. @@ -1226,7 +1323,7 @@ Qed. Lemma tr_find_label_if: forall r s, - tr_if r Sskip Sbreak s -> + tr_if ce r Sskip Sbreak s -> forall k, find_label lbl s k = None. Proof. intros. inv H. @@ -1241,29 +1338,29 @@ Qed. Lemma tr_find_label: forall s k ts tk - (TR: tr_stmt s ts) - (MC: match_cont k tk), + (TR: tr_stmt ce s ts) + (MC: match_cont ce k tk), match Csem.find_label lbl s k with | None => find_label lbl ts tk = None | Some (s', k') => exists ts', exists tk', find_label lbl ts tk = Some (ts', tk') - /\ tr_stmt s' ts' - /\ match_cont k' tk' + /\ tr_stmt ce s' ts' + /\ match_cont ce k' tk' end with tr_find_label_ls: forall s k ts tk - (TR: tr_lblstmts s ts) - (MC: match_cont k tk), + (TR: tr_lblstmts ce s ts) + (MC: match_cont ce k tk), match Csem.find_label_ls lbl s k with | None => find_label_ls lbl ts tk = None | Some (s', k') => exists ts', exists tk', find_label_ls lbl ts tk = Some (ts', tk') - /\ tr_stmt s' ts' - /\ match_cont k' tk' + /\ tr_stmt ce s' ts' + /\ match_cont ce k' tk' end. Proof. induction s; intros; inversion TR; subst; clear TR; simpl. @@ -1362,7 +1459,7 @@ The following measure decreases for these stuttering steps. *) Fixpoint esize (a: Csyntax.expr) : nat := match a with - | Csyntax.Eloc _ _ _ => 1%nat + | Csyntax.Eloc _ _ _ _ => 1%nat | Csyntax.Evar _ _ => 1%nat | Csyntax.Ederef r1 _ => S(esize r1) | Csyntax.Efield l1 _ _ => S(esize l1) @@ -1423,12 +1520,12 @@ Qed. (** Forward simulation for expressions. *) Lemma tr_val_gen: - forall le dst v ty a tmp, + forall ce le dst v ty a tmp, typeof a = ty -> (forall tge e le' m, (forall id, In id tmp -> le'!id = le!id) -> eval_expr tge e le' m a v) -> - tr_expr le dst (Csyntax.Eval v ty) (final dst a) a tmp. + tr_expr ce le dst (Csyntax.Eval v ty) (final dst a) a tmp. Proof. intros. destruct dst; simpl; econstructor; auto. Qed. @@ -1441,43 +1538,53 @@ Lemma estep_simulation: (star step1 tge S1' t S2' /\ measure S2 < measure S1)%nat) /\ match_states S2 S2'. Proof. + +Ltac NOTIN := + match goal with + | [ H1: In ?x ?l, H2: list_disjoint ?l _ |- ~In ?x _ ] => + 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; fail + end. + induction 1; intros; inv MS. -(* expr *) - assert (tr_expr le dest r sl a tmps). - inv H9. contradiction. auto. +- (* expr *) + assert (tr_expr (prog_comp_env cu) le dest r sl a tmps). + { inv TR. contradiction. auto. } exploit tr_simple_rvalue; eauto. destruct dest. - (* for val *) ++ (* for val *) intros [SL1 [TY1 EV1]]. subst sl. econstructor; split. right; split. apply star_refl. destruct r; simpl; (contradiction || lia). econstructor; eauto. instantiate (1 := tmps). apply tr_top_val_val; auto. - (* for effects *) ++ (* for effects *) intros SL1. subst sl. econstructor; split. right; split. apply star_refl. destruct r; simpl; (contradiction || lia). econstructor; eauto. instantiate (1 := tmps). apply tr_top_base. constructor. - (* for set *) - inv H10. -(* rval volatile *) - exploit tr_top_leftcontext; eauto. clear H11. ++ (* for set *) + inv MK. +- (* rval volatile *) + exploit tr_top_leftcontext; eauto. clear TR. intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [R S]]]]]]]]. inv P. inv H2. inv H7; try congruence. exploit tr_simple_lvalue; eauto. intros [SL [TY EV]]. subst sl0; simpl. + exploit is_bitfield_access_sound; eauto. intros EQ; subst bf0. econstructor; split. left. eapply plus_two. constructor. eapply step_make_set; eauto. traceEq. econstructor; eauto. change (final dst' (Etempvar t0 (Csyntax.typeof l)) ++ sl2) with (nil ++ (final dst' (Etempvar t0 (Csyntax.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. + intros. constructor. rewrite H7; auto. apply PTree.gss. + intros. apply PTree.gso. red; intros; subst; elim H7; auto. auto. -(* seqand true *) - exploit tr_top_leftcontext; eauto. clear H9. +- (* seqand true *) + exploit tr_top_leftcontext; eauto. clear TR. intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [R S]]]]]]]]. inv P. inv H2. - (* for val *) ++ (* for val *) exploit tr_simple_rvalue; eauto. intros [SL [TY EV]]. subst sl0; simpl Kseqlist. econstructor; split. @@ -1488,7 +1595,7 @@ Proof. eapply match_exprstates; eauto. apply S. apply tr_paren_val with (a1 := a2); auto. apply tr_expr_monotone with tmp2; eauto. auto. auto. - (* for effects *) ++ (* for effects *) exploit tr_simple_rvalue; eauto. intros [SL [TY EV]]. subst sl0; simpl Kseqlist. econstructor; split. @@ -1499,7 +1606,7 @@ Proof. eapply match_exprstates; eauto. apply S. apply tr_paren_effects with (a1 := a2); auto. apply tr_expr_monotone with tmp2; eauto. auto. auto. - (* for set *) ++ (* for set *) exploit tr_simple_rvalue; eauto. intros [SL [TY EV]]. subst sl0; simpl Kseqlist. econstructor; split. @@ -1510,11 +1617,11 @@ Proof. eapply match_exprstates; eauto. apply S. apply tr_paren_set with (a1 := a2) (t := sd_temp sd); auto. apply tr_expr_monotone with tmp2; eauto. auto. auto. -(* seqand false *) - exploit tr_top_leftcontext; eauto. clear H9. +- (* seqand false *) + exploit tr_top_leftcontext; eauto. clear TR. intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [R S]]]]]]]]. inv P. inv H2. - (* for val *) ++ (* for val *) exploit tr_simple_rvalue; eauto. intros [SL [TY EV]]. subst sl0; simpl Kseqlist. econstructor; split. @@ -1526,7 +1633,7 @@ Proof. intros. constructor. rewrite H2. apply PTree.gss. auto. intros. apply PTree.gso. congruence. auto. - (* for effects *) ++ (* for effects *) exploit tr_simple_rvalue; eauto. intros [SL [TY EV]]. subst sl0; simpl Kseqlist. econstructor; split. @@ -1536,7 +1643,7 @@ Proof. eapply match_exprstates; eauto. change sl2 with (nil ++ sl2). apply S. econstructor; eauto. auto. auto. - (* for set *) ++ (* for set *) exploit tr_simple_rvalue; eauto. intros [SL [TY EV]]. subst sl0; simpl Kseqlist. econstructor; split. @@ -1546,11 +1653,11 @@ Proof. rewrite <- Kseqlist_app. eapply match_exprstates; eauto. apply S. econstructor; eauto. intros. constructor. auto. auto. -(* seqor true *) - exploit tr_top_leftcontext; eauto. clear H9. +- (* seqor true *) + exploit tr_top_leftcontext; eauto. clear TR. intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [R S]]]]]]]]. inv P. inv H2. - (* for val *) ++ (* for val *) exploit tr_simple_rvalue; eauto. intros [SL [TY EV]]. subst sl0; simpl Kseqlist. econstructor; split. @@ -1562,7 +1669,7 @@ Proof. intros. constructor. rewrite H2. apply PTree.gss. auto. intros. apply PTree.gso. congruence. auto. - (* for effects *) ++ (* for effects *) exploit tr_simple_rvalue; eauto. intros [SL [TY EV]]. subst sl0; simpl Kseqlist. econstructor; split. @@ -1572,7 +1679,7 @@ Proof. eapply match_exprstates; eauto. change sl2 with (nil ++ sl2). apply S. econstructor; eauto. auto. auto. - (* for set *) ++ (* for set *) exploit tr_simple_rvalue; eauto. intros [SL [TY EV]]. subst sl0; simpl Kseqlist. econstructor; split. @@ -1582,11 +1689,11 @@ Proof. rewrite <- Kseqlist_app. eapply match_exprstates; eauto. apply S. econstructor; eauto. intros. constructor. auto. auto. -(* seqand false *) - exploit tr_top_leftcontext; eauto. clear H9. +- (* seqand false *) + exploit tr_top_leftcontext; eauto. clear TR. intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [R S]]]]]]]]. inv P. inv H2. - (* for val *) ++ (* for val *) exploit tr_simple_rvalue; eauto. intros [SL [TY EV]]. subst sl0; simpl Kseqlist. econstructor; split. @@ -1597,7 +1704,7 @@ Proof. eapply match_exprstates; eauto. apply S. apply tr_paren_val with (a1 := a2); auto. apply tr_expr_monotone with tmp2; eauto. auto. auto. - (* for effects *) ++ (* for effects *) exploit tr_simple_rvalue; eauto. intros [SL [TY EV]]. subst sl0; simpl Kseqlist. econstructor; split. @@ -1608,7 +1715,7 @@ Proof. eapply match_exprstates; eauto. apply S. apply tr_paren_effects with (a1 := a2); auto. apply tr_expr_monotone with tmp2; eauto. auto. auto. - (* for set *) ++ (* for set *) exploit tr_simple_rvalue; eauto. intros [SL [TY EV]]. subst sl0; simpl Kseqlist. econstructor; split. @@ -1619,11 +1726,11 @@ Proof. eapply match_exprstates; eauto. apply S. apply tr_paren_set with (a1 := a2) (t := sd_temp sd); auto. apply tr_expr_monotone with tmp2; eauto. auto. auto. -(* condition *) - exploit tr_top_leftcontext; eauto. clear H9. +- (* condition *) + exploit tr_top_leftcontext; eauto. clear TR. intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [R S]]]]]]]]. inv P. inv H2. - (* for value *) ++ (* for value *) exploit tr_simple_rvalue; eauto. intros [SL [TY EV]]. subst sl0; simpl Kseqlist. destruct b. econstructor; split. @@ -1640,7 +1747,7 @@ Proof. rewrite <- Kseqlist_app. eapply match_exprstates; eauto. apply S. econstructor; eauto. apply tr_expr_monotone with tmp3; eauto. auto. auto. - (* for effects *) ++ (* for effects *) exploit tr_simple_rvalue; eauto. intros [SL [TY EV]]. subst sl0; simpl Kseqlist. destruct b. econstructor; split. @@ -1649,7 +1756,7 @@ Proof. apply push_seq. reflexivity. traceEq. rewrite <- Kseqlist_app. - econstructor. eauto. apply S. + econstructor; eauto. apply S. econstructor; eauto. apply tr_expr_monotone with tmp2; eauto. econstructor; eauto. auto. auto. @@ -1659,11 +1766,11 @@ Proof. apply push_seq. reflexivity. traceEq. rewrite <- Kseqlist_app. - econstructor. eauto. apply S. + econstructor; eauto. apply S. econstructor; eauto. apply tr_expr_monotone with tmp3; eauto. econstructor; eauto. - auto. auto. - (* for set *) + auto. ++ (* for set *) exploit tr_simple_rvalue; eauto. intros [SL [TY EV]]. subst sl0; simpl Kseqlist. destruct b. econstructor; split. @@ -1672,40 +1779,42 @@ Proof. apply push_seq. reflexivity. traceEq. rewrite <- Kseqlist_app. - econstructor. eauto. apply S. + econstructor; eauto. apply S. econstructor; eauto. apply tr_expr_monotone with tmp2; eauto. econstructor; eauto. - auto. auto. + auto. econstructor; split. left. eapply plus_left. constructor. eapply star_trans. apply step_makeif with (b := false) (v1 := v); auto. congruence. apply push_seq. reflexivity. traceEq. rewrite <- Kseqlist_app. - econstructor. eauto. apply S. + econstructor; eauto. apply S. econstructor; eauto. apply tr_expr_monotone with tmp3; eauto. econstructor; eauto. - auto. auto. -(* assign *) - exploit tr_top_leftcontext; eauto. clear H12. + auto. +- (* assign *) + exploit tr_top_leftcontext; eauto. clear TR. intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [R S]]]]]]]]. inv P. inv H4. - (* for effects *) ++ (* for effects *) exploit tr_simple_rvalue; eauto. intros [SL2 [TY2 EV2]]. exploit tr_simple_lvalue; eauto. intros [SL1 [TY1 EV1]]. + assert (bf0 = bf) by (eapply is_bitfield_access_sound; eauto). subst; simpl Kseqlist. econstructor; split. left. eapply plus_left. constructor. apply star_one. eapply step_make_assign; eauto. rewrite <- TY2; eauto. traceEq. - econstructor. auto. change sl2 with (nil ++ sl2). apply S. - constructor. auto. auto. auto. - (* for value *) + econstructor; eauto. change sl2 with (nil ++ sl2). apply S. + constructor. 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 t0 v' le). eauto. + eapply tr_expr_invariant with (le' := PTree.set t0 v1 le). eauto. intros. apply PTree.gso. intuition congruence. intros [SL1 [TY1 EV1]]. + assert (bf0 = bf) by (eapply is_bitfield_access_sound; eauto). subst; simpl Kseqlist. econstructor; split. left. eapply plus_left. constructor. @@ -1714,22 +1823,24 @@ Proof. apply star_one. eapply step_make_assign; eauto. constructor. apply PTree.gss. simpl. eapply cast_idempotent; eauto. reflexivity. reflexivity. traceEq. - econstructor. auto. apply S. - apply tr_val_gen. auto. intros. constructor. - rewrite H4; auto. apply PTree.gss. + econstructor; eauto. apply S. + apply tr_val_gen. rewrite typeof_make_assign_value; auto. + intros. eapply make_assign_value_sound; eauto. + constructor. rewrite H4; auto. apply PTree.gss. intros. apply PTree.gso. intuition congruence. - auto. auto. -(* assignop *) - exploit tr_top_leftcontext; eauto. clear H15. + auto. +- (* assignop *) + exploit tr_top_leftcontext; eauto. clear TR. intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [R S]]]]]]]]. inv P. inv H6. - (* for effects *) ++ (* for effects *) exploit tr_simple_lvalue; eauto. intros [SL1 [TY1 EV1]]. 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]]. + assert (bf0 = bf) by (eapply is_bitfield_access_sound; eauto). subst; simpl Kseqlist. econstructor; split. left. eapply star_plus_trans. rewrite app_ass. rewrite Kseqlist_app. eexact EXEC. @@ -1737,9 +1848,9 @@ Proof. econstructor. eexact EV3. eexact EV2. rewrite TY3; rewrite <- TY1; rewrite <- TY2; rewrite comp_env_preserved; auto. reflexivity. traceEq. - econstructor. auto. change sl2 with (nil ++ sl2). apply S. - constructor. auto. auto. auto. - (* for value *) + econstructor; eauto. change sl2 with (nil ++ sl2). apply S. + constructor. auto. auto. ++ (* for value *) exploit tr_simple_lvalue; eauto. intros [SL1 [TY1 EV1]]. 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. @@ -1750,6 +1861,7 @@ Proof. eapply tr_expr_invariant with (le := le) (le' := PTree.set t v4 le'). eauto. intros. rewrite PTree.gso. apply INV. NOTIN. intuition congruence. intros [? [? EV1'']]. + assert (bf0 = bf) by (eapply is_bitfield_access_sound; eauto). subst; simpl Kseqlist. econstructor; split. left. rewrite app_ass. rewrite Kseqlist_app. @@ -1761,18 +1873,19 @@ Proof. econstructor. eapply step_make_assign; eauto. constructor. apply PTree.gss. simpl. eapply cast_idempotent; eauto. reflexivity. traceEq. - econstructor. auto. apply S. - apply tr_val_gen. auto. intros. constructor. - rewrite H10; auto. apply PTree.gss. + econstructor; eauto. apply S. + apply tr_val_gen. rewrite typeof_make_assign_value; auto. + intros. eapply make_assign_value_sound; eauto. + constructor. 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. + auto. +- (* assignop stuck *) + exploit tr_top_leftcontext; eauto. clear TR. intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [R S]]]]]]]]. inv P. inv H4. - (* for effects *) ++ (* 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]]]]. @@ -1781,7 +1894,7 @@ Proof. right; split. rewrite app_ass. rewrite Kseqlist_app. eexact EXEC. simpl. lia. constructor. - (* for value *) ++ (* 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]]]]. @@ -1790,15 +1903,16 @@ Proof. right; split. rewrite app_ass. rewrite Kseqlist_app. eexact EXEC. simpl. lia. constructor. -(* postincr *) - exploit tr_top_leftcontext; eauto. clear H14. +- (* postincr *) + exploit tr_top_leftcontext; eauto. clear TR. intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [R S]]]]]]]]. inv P. inv H5. - (* for effects *) ++ (* for effects *) exploit tr_simple_lvalue; eauto. intros [SL1 [TY1 EV1]]. 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']]. + assert (bf0 = bf) by (eapply is_bitfield_access_sound; eauto). subst; simpl Kseqlist. econstructor; split. left. rewrite app_ass; rewrite Kseqlist_app. @@ -1810,14 +1924,15 @@ Proof. econstructor. eauto. constructor. rewrite TY3; rewrite <- TY1; rewrite comp_env_preserved. simpl; eauto. destruct id; auto. reflexivity. traceEq. - econstructor. auto. change sl2 with (nil ++ sl2). apply S. - constructor. auto. auto. auto. - (* for value *) + econstructor; eauto. change sl2 with (nil ++ sl2). apply S. + constructor. auto. auto. ++ (* for value *) exploit tr_simple_lvalue; eauto. intros [SL1 [TY1 EV1]]. exploit tr_simple_lvalue. eauto. eapply tr_expr_invariant with (le' := PTree.set t v1 le). eauto. intros. apply PTree.gso. intuition congruence. intros [SL2 [TY2 EV2]]. + assert (bf0 = bf) by (eapply is_bitfield_access_sound; eauto). subst; simpl Kseqlist. econstructor; split. left. eapply plus_four. constructor. @@ -1831,16 +1946,16 @@ Proof. rewrite comp_env_preserved; simpl; eauto. destruct id; auto. traceEq. - econstructor. auto. apply S. + econstructor; eauto. 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. + auto. +- (* postincr stuck *) + exploit tr_top_leftcontext; eauto. clear TR. intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [R S]]]]]]]]. inv P. inv H3. - (* for effects *) ++ (* 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. @@ -1848,15 +1963,16 @@ Proof. right; split. rewrite app_ass; rewrite Kseqlist_app. eexact EXEC. simpl; lia. constructor. - (* for value *) ++ (* for value *) exploit tr_simple_lvalue; eauto. intros [SL1 [TY1 EV1]]. + assert (bf0 = bf) by (eapply is_bitfield_access_sound; eauto). 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. +- (* comma *) + exploit tr_top_leftcontext; eauto. clear TR. intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [R S]]]]]]]]. inv P. inv H1. exploit tr_simple_rvalue; eauto. simpl; intro SL1. @@ -1867,11 +1983,11 @@ Proof. econstructor; eauto. apply S. eapply tr_expr_monotone; eauto. auto. auto. -(* paren *) - exploit tr_top_leftcontext; eauto. clear H9. +- (* paren *) + exploit tr_top_leftcontext; eauto. clear TR. intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [R S]]]]]]]]. inv P. inv H2. - (* for value *) ++ (* for value *) exploit tr_simple_rvalue; eauto. intros [b [SL1 [TY1 EV1]]]. subst sl1; simpl Kseqlist. econstructor; split. @@ -1882,14 +1998,14 @@ Proof. constructor. auto. intros. constructor. rewrite H2; auto. apply PTree.gss. intros. apply PTree.gso. intuition congruence. auto. - (* for effects *) ++ (* for effects *) econstructor; split. right; split. apply star_refl. simpl. apply plus_lt_compat_r. apply (leftcontext_size _ _ _ H). simpl. lia. econstructor; eauto. exploit tr_simple_rvalue; eauto. simpl. intros A. subst sl1. apply S. constructor; auto. auto. auto. - (* for set *) ++ (* for set *) exploit tr_simple_rvalue; eauto. simpl. intros [b [SL1 [TY1 EV1]]]. subst sl1. simpl Kseqlist. econstructor; split. @@ -1901,46 +2017,46 @@ Proof. intros. apply PTree.gso. congruence. auto. -(* call *) - exploit tr_top_leftcontext; eauto. clear H12. +- (* call *) + exploit tr_top_leftcontext; eauto. clear TR. intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [R S]]]]]]]]. inv P. inv H5. - (* for effects *) ++ (* for effects *) exploit tr_simple_rvalue; eauto. intros [SL1 [TY1 EV1]]. exploit tr_simple_exprlist; eauto. intros [SL2 EV2]. subst. simpl Kseqlist. - exploit functions_translated; eauto. intros [tfd [J K]]. + exploit functions_translated; eauto. intros (cu' & tfd & J & K & L). econstructor; split. left. eapply plus_left. constructor. apply star_one. econstructor; eauto. rewrite <- TY1; eauto. exploit type_of_fundef_preserved; eauto. congruence. traceEq. - constructor; auto. econstructor; eauto. + econstructor. eexact L. eauto. econstructor. eexact LINK. auto. auto. intros. change sl2 with (nil ++ sl2). apply S. - constructor. auto. auto. - (* for value *) + constructor. auto. auto. auto. ++ (* for value *) exploit tr_simple_rvalue; eauto. intros [SL1 [TY1 EV1]]. exploit tr_simple_exprlist; eauto. intros [SL2 EV2]. subst. simpl Kseqlist. - exploit functions_translated; eauto. intros [tfd [J K]]. + exploit functions_translated; eauto. intros (cu' & tfd & J & K & L). econstructor; split. left. eapply plus_left. constructor. apply star_one. econstructor; eauto. rewrite <- TY1; eauto. exploit type_of_fundef_preserved; eauto. congruence. traceEq. - constructor; auto. econstructor; eauto. + econstructor. eexact L. eauto. econstructor. eexact LINK. auto. auto. intros. apply S. destruct dst'; constructor. auto. intros. constructor. rewrite H5; auto. apply PTree.gss. auto. intros. constructor. rewrite H5; auto. apply PTree.gss. intros. apply PTree.gso. intuition congruence. - auto. + auto. auto. -(* builtin *) - exploit tr_top_leftcontext; eauto. clear H9. +- (* builtin *) + exploit tr_top_leftcontext; eauto. clear TR. intros [dst' [sl1 [sl2 [a' [tmp' [P [Q [R S]]]]]]]]. inv P. inv H2. - (* for effects *) ++ (* for effects *) exploit tr_simple_exprlist; eauto. intros [SL EV]. subst. simpl Kseqlist. econstructor; split. @@ -1950,7 +2066,7 @@ Proof. traceEq. econstructor; eauto. change sl2 with (nil ++ sl2). apply S. constructor. simpl; auto. auto. - (* for value *) ++ (* for value *) exploit tr_simple_exprlist; eauto. intros [SL EV]. subst. simpl Kseqlist. econstructor; split. @@ -1968,8 +2084,8 @@ Qed. (** Forward simulation for statements. *) Lemma tr_top_val_for_val_inv: - forall e le m v ty sl a tmps, - tr_top tge e le m For_val (Csyntax.Eval v ty) sl a tmps -> + forall ce e le m v ty sl a tmps, + tr_top ce tge e le m For_val (Csyntax.Eval v ty) sl a tmps -> sl = nil /\ typeof a = ty /\ eval_expr tge e le m a v. Proof. intros. inv H. auto. inv H0. auto. @@ -2011,264 +2127,263 @@ Lemma sstep_simulation: /\ match_states S2 S2'. Proof. induction 1; intros; inv MS. -(* do 1 *) - inv H6. inv H0. +- (* do 1 *) + inv TR. inv H0. econstructor; split. right; split. apply push_seq. simpl. lia. econstructor; eauto. constructor. auto. -(* do 2 *) - inv H7. inv H6. inv H. +- (* do 2 *) + inv MK. inv TR. inv H. econstructor; split. right; split. apply star_refl. simpl. lia. econstructor; eauto. constructor. -(* seq *) - inv H6. econstructor; split. left. apply plus_one. constructor. +- (* seq *) + inv TR. econstructor; split. left. apply plus_one. constructor. econstructor; eauto. constructor; auto. -(* skip seq *) - inv H6; inv H7. econstructor; split. +- (* skip seq *) + inv TR; inv MK. econstructor; split. left. apply plus_one; constructor. econstructor; eauto. -(* continue seq *) - inv H6; inv H7. econstructor; split. +- (* continue seq *) + inv TR; inv MK. econstructor; split. left. apply plus_one; constructor. econstructor; eauto. constructor. -(* break seq *) - inv H6; inv H7. econstructor; split. +- (* break seq *) + inv TR; inv MK. econstructor; split. left. apply plus_one; constructor. econstructor; eauto. constructor. -(* ifthenelse *) - inv H6. -(* ifthenelse empty *) +- (* ifthenelse *) + inv TR. ++ (* ifthenelse empty *) inv H3. econstructor; split. left. eapply plus_left. constructor. apply push_seq. econstructor; eauto. econstructor; eauto. econstructor; eauto. -(* ifthenelse non empty *) ++ (* ifthenelse non empty *) inv H2. econstructor; split. left. eapply plus_left. constructor. apply push_seq. traceEq. econstructor; eauto. econstructor; eauto. -(* ifthenelse *) - inv H8. -(* ifthenelse empty *) +- (* ifthenelse *) + inv MK. ++ (* ifthenelse empty *) exploit tr_top_val_for_val_inv; eauto. intros [A [B C]]. subst. econstructor; split; simpl. right. destruct b; econstructor; eauto. eapply star_left. apply step_skip_seq. econstructor. traceEq. eapply star_left. apply step_skip_seq. econstructor. traceEq. destruct b; econstructor; eauto. econstructor; eauto. econstructor; eauto. - (* ifthenelse non empty *) ++ (* ifthenelse non empty *) exploit tr_top_val_for_val_inv; eauto. intros [A [B C]]. subst. econstructor; split. left. eapply plus_two. constructor. apply step_ifthenelse with (v1 := v) (b := b); auto. traceEq. destruct b; econstructor; eauto. -(* while *) - inv H6. inv H1. econstructor; split. +- (* while *) + inv TR. inv H1. econstructor; split. left. eapply plus_left. constructor. eapply star_left. constructor. apply push_seq. reflexivity. traceEq. rewrite Kseqlist_app. - econstructor; eauto. simpl. econstructor; eauto. econstructor; eauto. -(* while false *) - inv H8. + econstructor; eauto. simpl. econstructor; eauto. econstructor; eauto. +- (* while false *) + inv MK. exploit tr_top_val_for_val_inv; eauto. intros [A [B C]]. subst. econstructor; split. left. simpl. eapply plus_left. constructor. eapply star_trans. apply step_makeif with (v1 := v) (b := false); auto. eapply star_two. constructor. apply step_break_loop1. reflexivity. reflexivity. traceEq. - constructor; auto. constructor. -(* while true *) - inv H8. + econstructor; eauto. constructor. +- (* while true *) + inv MK. exploit tr_top_val_for_val_inv; eauto. intros [A [B C]]. subst. econstructor; split. left. simpl. eapply plus_left. constructor. eapply star_right. apply step_makeif with (v1 := v) (b := true); auto. constructor. reflexivity. traceEq. - constructor; auto. constructor; auto. -(* skip-or-continue while *) - assert (ts = Sskip \/ ts = Scontinue). destruct H; subst s0; inv H7; auto. - inv H8. + econstructor; eauto. constructor; auto. +- (* skip-or-continue while *) + assert (ts = Sskip \/ ts = Scontinue). { destruct H; subst s0; inv TR; auto. } + inv MK. econstructor; split. left. eapply plus_two. apply step_skip_or_continue_loop1; auto. apply step_skip_loop2. traceEq. - constructor; auto. constructor; auto. -(* break while *) - inv H6. inv H7. + econstructor; eauto. constructor; auto. +- (* break while *) + inv TR. inv MK. econstructor; split. left. apply plus_one. apply step_break_loop1. - constructor; auto. constructor. + econstructor; eauto. constructor. -(* dowhile *) - inv H6. +- (* dowhile *) + inv TR. econstructor; split. left. apply plus_one. apply step_loop. - constructor; auto. constructor; auto. -(* skip_or_continue dowhile *) - assert (ts = Sskip \/ ts = Scontinue). destruct H; subst s0; inv H7; auto. - inv H8. inv H4. + econstructor; eauto. constructor; auto. +- (* skip_or_continue dowhile *) + assert (ts = Sskip \/ ts = Scontinue). { destruct H; subst s0; inv TR; auto. } + inv MK. inv H5. econstructor; split. left. eapply plus_left. apply step_skip_or_continue_loop1. auto. apply push_seq. traceEq. rewrite Kseqlist_app. econstructor; eauto. simpl. econstructor; auto. econstructor; eauto. -(* dowhile false *) - inv H8. +- (* dowhile false *) + inv MK. exploit tr_top_val_for_val_inv; eauto. intros [A [B C]]. subst. econstructor; split. left. simpl. eapply plus_left. constructor. eapply star_right. apply step_makeif with (v1 := v) (b := false); auto. constructor. reflexivity. traceEq. - constructor; auto. constructor. -(* dowhile true *) - inv H8. + econstructor; eauto. constructor. +- (* dowhile true *) + inv MK. exploit tr_top_val_for_val_inv; eauto. intros [A [B C]]. subst. econstructor; split. left. simpl. eapply plus_left. constructor. eapply star_right. apply step_makeif with (v1 := v) (b := true); auto. constructor. reflexivity. traceEq. - constructor; auto. constructor; auto. -(* break dowhile *) - inv H6. inv H7. + econstructor; eauto. constructor; auto. +- (* break dowhile *) + inv TR. inv MK. econstructor; split. left. apply plus_one. apply step_break_loop1. - constructor; auto. constructor. + econstructor; eauto. constructor. -(* for start *) - inv H7. congruence. +- (* for start *) + inv TR. congruence. econstructor; split. left; apply plus_one. constructor. econstructor; eauto. constructor; auto. econstructor; eauto. -(* for *) - inv H6; try congruence. inv H2. +- (* for *) + inv TR; try congruence. inv H2. econstructor; split. left. eapply plus_left. apply step_loop. eapply star_left. constructor. apply push_seq. reflexivity. traceEq. rewrite Kseqlist_app. econstructor; eauto. simpl. constructor; auto. econstructor; eauto. -(* for false *) - inv H8. exploit tr_top_val_for_val_inv; eauto. intros [A [B C]]. subst. +- (* for false *) + inv MK. exploit tr_top_val_for_val_inv; eauto. intros [A [B C]]. subst. econstructor; split. left. simpl. eapply plus_left. constructor. eapply star_trans. apply step_makeif with (v1 := v) (b := false); auto. eapply star_two. constructor. apply step_break_loop1. reflexivity. reflexivity. traceEq. - constructor; auto. constructor. -(* for true *) - inv H8. exploit tr_top_val_for_val_inv; eauto. intros [A [B C]]. subst. + econstructor; eauto. constructor. +- (* for true *) + inv MK. exploit tr_top_val_for_val_inv; eauto. intros [A [B C]]. subst. econstructor; split. left. simpl. eapply plus_left. constructor. eapply star_right. apply step_makeif with (v1 := v) (b := true); auto. constructor. reflexivity. traceEq. - constructor; auto. constructor; auto. -(* skip_or_continue for3 *) - assert (ts = Sskip \/ ts = Scontinue). destruct H; subst x; inv H7; auto. - inv H8. + econstructor; eauto. constructor; auto. +- (* skip_or_continue for3 *) + assert (ts = Sskip \/ ts = Scontinue). { destruct H; subst x; inv TR; auto. } + inv MK. econstructor; split. left. apply plus_one. apply step_skip_or_continue_loop1. auto. econstructor; eauto. econstructor; auto. -(* break for3 *) - inv H6. inv H7. +- (* break for3 *) + inv TR. inv MK. econstructor; split. left. apply plus_one. apply step_break_loop1. econstructor; eauto. constructor. -(* skip for4 *) - inv H6. inv H7. +- (* skip for4 *) + inv TR. inv MK. econstructor; split. left. apply plus_one. constructor. econstructor; eauto. constructor; auto. - -(* return none *) - inv H7. econstructor; split. +- (* return none *) + inv TR. econstructor; split. left. apply plus_one. econstructor; eauto. rewrite blocks_of_env_preserved; eauto. - constructor. apply match_cont_call; auto. -(* return some 1 *) - inv H6. inv H0. econstructor; split. + econstructor. intros; eapply match_cont_call_cont; eauto. +- (* return some 1 *) + inv TR. inv H0. econstructor; split. left; eapply plus_left. constructor. apply push_seq. traceEq. econstructor; eauto. constructor. auto. -(* return some 2 *) - inv H9. exploit tr_top_val_for_val_inv; eauto. intros [A [B C]]. subst. +- (* return some 2 *) + inv MK. exploit tr_top_val_for_val_inv; eauto. intros [A [B C]]. subst. econstructor; split. left. eapply plus_two. constructor. econstructor. eauto. erewrite function_return_preserved; eauto. rewrite blocks_of_env_preserved; eauto. eauto. traceEq. - constructor. apply match_cont_call; auto. -(* skip return *) - inv H8. - assert (is_call_cont tk). inv H9; simpl in *; auto. + econstructor. intros; eapply match_cont_call_cont; eauto. +- (* skip return *) + inv TR. + assert (is_call_cont tk). { inv MK; simpl in *; auto. } econstructor; split. left. apply plus_one. apply step_skip_call; eauto. rewrite blocks_of_env_preserved; eauto. - constructor. auto. + econstructor. intros; eapply match_cont_is_call_cont; eauto. -(* switch *) - inv H6. inv H1. +- (* switch *) + inv TR. inv H1. econstructor; split. left; eapply plus_left. constructor. apply push_seq. traceEq. econstructor; eauto. constructor; auto. -(* expr switch *) - inv H8. exploit tr_top_val_for_val_inv; eauto. intros [A [B C]]. subst. +- (* expr switch *) + inv MK. exploit tr_top_val_for_val_inv; eauto. intros [A [B C]]. subst. econstructor; split. left; eapply plus_two. constructor. econstructor; eauto. traceEq. econstructor; eauto. apply tr_seq_of_labeled_statement. apply tr_select_switch. auto. constructor; auto. -(* skip-or-break switch *) - assert (ts = Sskip \/ ts = Sbreak). destruct H; subst x; inv H7; auto. - inv H8. +- (* skip-or-break switch *) + assert (ts = Sskip \/ ts = Sbreak). { destruct H; subst x; inv TR; auto. } + inv MK. econstructor; split. left; apply plus_one. apply step_skip_break_switch. auto. - constructor; auto. constructor. + econstructor; eauto. constructor. -(* continue switch *) - inv H6. inv H7. +- (* continue switch *) + inv TR. inv MK. econstructor; split. left; apply plus_one. apply step_continue_switch. - constructor; auto. constructor. + econstructor; eauto. constructor. -(* label *) - inv H6. econstructor; split. +- (* label *) + inv TR. econstructor; split. left; apply plus_one. constructor. - constructor; auto. + econstructor; eauto. -(* goto *) - inv H7. - inversion H6; subst. - exploit tr_find_label. eauto. apply match_cont_call. eauto. +- (* goto *) + inv TR. + inversion TRF; subst. + exploit tr_find_label. eauto. eapply match_cont_call_cont; eauto. instantiate (1 := lbl). rewrite H. intros [ts' [tk' [P [Q R]]]]. econstructor; split. left. apply plus_one. econstructor; eauto. econstructor; eauto. -(* internal function *) - inv H7. inversion H3; subst. +- (* internal function *) + inv TR. inversion H3; subst. econstructor; split. left; apply plus_one. eapply step_internal_function. econstructor. rewrite H6; rewrite H7; auto. rewrite H6; rewrite H7. eapply alloc_variables_preserved; eauto. rewrite H6. eapply bind_parameters_preserved; eauto. eauto. - constructor; auto. + econstructor; eauto. -(* external function *) - inv H5. +- (* external function *) + inv TR. econstructor; split. left; apply plus_one. econstructor; eauto. eapply external_call_symbols_preserved; eauto. apply senv_preserved. - constructor; auto. + econstructor; eauto. -(* return *) - inv H3. +- (* return *) + specialize (MK (PTree.empty _)). inv MK. econstructor; split. left; apply plus_one. constructor. econstructor; eauto. @@ -2295,7 +2410,7 @@ Lemma transl_initial_states: exists S', Clight.initial_state tprog S' /\ match_states S S'. Proof. intros. inv H. - exploit function_ptr_translated; eauto. intros [tf [FIND TR]]. + exploit function_ptr_translated; eauto. intros (cu & tf & FIND & TR & L). econstructor; split. econstructor. eapply (Genv.init_mem_match (proj1 TRANSL)); eauto. @@ -2303,15 +2418,15 @@ Proof. rewrite symbols_preserved. eauto. destruct TRANSL. destruct H as (A & B & C). simpl in B. auto. eexact FIND. - rewrite <- H3. apply type_of_fundef_preserved. auto. - constructor. auto. constructor. + rewrite <- H3. eapply type_of_fundef_preserved; eauto. + econstructor; eauto. intros; constructor. Qed. Lemma transl_final_states: forall S S' r, match_states S S' -> Csem.final_state S r -> Clight.final_state S' r. Proof. - intros. inv H0. inv H. inv H4. constructor. + intros. inv H0. inv H. specialize (MK (PTree.empty _)). inv MK. constructor. Qed. Theorem transl_program_correct: @@ -2331,13 +2446,13 @@ End PRESERVATION. Instance TransfSimplExprLink : TransfLink match_prog. Proof. - red; intros. eapply Ctypes.link_match_program; eauto. + red; intros. eapply Ctypes.link_match_program_gen; eauto. - intros. Local Transparent Linker_fundef. simpl in *; unfold link_fundef in *. inv H3; inv H4; try discriminate. - destruct ef; inv H2. exists (Internal tf); split; auto. constructor; auto. - destruct ef; inv H2. exists (Internal tf); split; auto. constructor; auto. + destruct ef; inv H2. exists (Internal tf); split; auto. left; constructor; auto. + destruct ef; inv H2. exists (Internal tf); split; auto. right; constructor; auto. destruct (external_function_eq ef ef0 && typelist_eq targs targs0 && type_eq tres tres0 && calling_convention_eq cconv cconv0); inv H2. - exists (External ef targs tres cconv); split; auto. constructor. + exists (External ef targs tres cconv); split; auto. left; constructor. Qed. diff --git a/cfrontend/SimplExprspec.v b/cfrontend/SimplExprspec.v index 98425311..b689bdeb 100644 --- a/cfrontend/SimplExprspec.v +++ b/cfrontend/SimplExprspec.v @@ -18,6 +18,8 @@ Require Import Ctypes Cop Csyntax Clight SimplExpr. Section SPEC. +Variable ce: composite_env. + Local Open Scope gensym_monad_scope. (** * Relational specification of the translation. *) @@ -40,13 +42,28 @@ Definition final (dst: destination) (a: expr) : list statement := | For_set sd => do_set sd a end. +Definition tr_is_bitfield_access (l: expr) (bf: bitfield) : Prop := + match l with + | Efield r f _ => + exists co ofs, + match typeof r with + | Tstruct id _ => + ce!id = Some co /\ field_offset ce f (co_members co) = OK (ofs, bf) + | Tunion id _ => + ce!id = Some co /\ union_field_offset ce f (co_members co) = OK (ofs, bf) + | _ => False + end + | _ => bf = Full + 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, + | tr_rvalof_vol: forall ty a t bf tmp, type_is_volatile ty = true -> In t tmp -> - tr_rvalof ty a (make_set t a :: nil) (Etempvar t ty) tmp. + tr_is_bitfield_access a bf -> + tr_rvalof ty a (make_set bf t a :: nil) (Etempvar t ty) tmp. Inductive tr_expr: temp_env -> destination -> Csyntax.expr -> list statement -> expr -> list ident -> Prop := | tr_var: forall le dst id ty tmp, @@ -200,15 +217,16 @@ Inductive tr_expr: temp_env -> destination -> Csyntax.expr -> list statement -> tr_expr le (For_set sd) (Csyntax.Econdition e1 e2 e3 ty) (sl1 ++ makeif a1 (makeseq sl2) (makeseq sl3) :: nil) any tmp - | tr_assign_effects: forall le e1 e2 ty sl1 a1 tmp1 sl2 a2 tmp2 any tmp, + | tr_assign_effects: forall le e1 e2 ty sl1 a1 tmp1 sl2 a2 tmp2 bf 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 -> + tr_is_bitfield_access a1 bf -> tr_expr le For_effects (Csyntax.Eassign e1 e2 ty) - (sl1 ++ sl2 ++ make_assign a1 a2 :: nil) + (sl1 ++ sl2 ++ make_assign bf a1 a2 :: nil) any tmp - | tr_assign_val: forall le dst e1 e2 ty sl1 a1 tmp1 sl2 a2 tmp2 t tmp ty1 ty2, + | tr_assign_val: forall le dst e1 e2 ty sl1 a1 tmp1 sl2 a2 tmp2 t tmp ty1 ty2 bf, tr_expr le For_val e1 sl1 a1 tmp1 -> tr_expr le For_val e2 sl2 a2 tmp2 -> incl tmp1 tmp -> incl tmp2 tmp -> @@ -216,23 +234,25 @@ Inductive tr_expr: temp_env -> destination -> Csyntax.expr -> list statement -> In t tmp -> ~In t tmp1 -> ~In t tmp2 -> ty1 = Csyntax.typeof e1 -> ty2 = Csyntax.typeof e2 -> + tr_is_bitfield_access a1 bf -> tr_expr le dst (Csyntax.Eassign e1 e2 ty) (sl1 ++ sl2 ++ Sset t (Ecast a2 ty1) :: - make_assign a1 (Etempvar t ty1) :: - final dst (Etempvar t ty1)) - (Etempvar t ty1) tmp - | tr_assignop_effects: forall le op e1 e2 tyres ty ty1 sl1 a1 tmp1 sl2 a2 tmp2 sl3 a3 tmp3 any tmp, + make_assign bf a1 (Etempvar t ty1) :: + final dst (make_assign_value bf (Etempvar t ty1))) + (make_assign_value bf (Etempvar t ty1)) tmp + | tr_assignop_effects: forall le op e1 e2 tyres ty ty1 sl1 a1 tmp1 sl2 a2 tmp2 bf sl3 a3 tmp3 any tmp, tr_expr le For_val e1 sl1 a1 tmp1 -> tr_expr le For_val e2 sl2 a2 tmp2 -> ty1 = Csyntax.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_is_bitfield_access a1 bf -> tr_expr le For_effects (Csyntax.Eassignop op e1 e2 tyres ty) - (sl1 ++ sl2 ++ sl3 ++ make_assign a1 (Ebinop op a3 a2 tyres) :: nil) + (sl1 ++ sl2 ++ sl3 ++ make_assign bf 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 sl3 a3 tmp3 t tmp ty1, + | tr_assignop_val: forall le dst op e1 e2 tyres ty sl1 a1 tmp1 sl2 a2 tmp2 sl3 a3 tmp3 t bf tmp ty1, tr_expr le For_val e1 sl1 a1 tmp1 -> tr_expr le For_val e2 sl2 a2 tmp2 -> tr_rvalof ty1 a1 sl3 a3 tmp3 -> @@ -240,28 +260,31 @@ Inductive tr_expr: temp_env -> destination -> Csyntax.expr -> list statement -> incl tmp1 tmp -> incl tmp2 tmp -> incl tmp3 tmp -> In t tmp -> ~In t tmp1 -> ~In t tmp2 -> ~In t tmp3 -> ty1 = Csyntax.typeof e1 -> + tr_is_bitfield_access a1 bf -> tr_expr le dst (Csyntax.Eassignop op e1 e2 tyres ty) (sl1 ++ sl2 ++ sl3 ++ Sset t (Ecast (Ebinop op a3 a2 tyres) ty1) :: - make_assign a1 (Etempvar t ty1) :: - final dst (Etempvar t ty1)) - (Etempvar t ty1) tmp - | tr_postincr_effects: forall le id e1 ty ty1 sl1 a1 tmp1 sl2 a2 tmp2 any tmp, + make_assign bf a1 (Etempvar t ty1) :: + final dst (make_assign_value bf (Etempvar t ty1))) + (make_assign_value bf (Etempvar t ty1)) tmp + | tr_postincr_effects: forall le id e1 ty ty1 sl1 a1 tmp1 sl2 a2 tmp2 bf any tmp, tr_expr le For_val e1 sl1 a1 tmp1 -> tr_rvalof ty1 a1 sl2 a2 tmp2 -> ty1 = Csyntax.typeof e1 -> incl tmp1 tmp -> incl tmp2 tmp -> list_disjoint tmp1 tmp2 -> + tr_is_bitfield_access a1 bf -> tr_expr le For_effects (Csyntax.Epostincr id e1 ty) - (sl1 ++ sl2 ++ make_assign a1 (transl_incrdecr id a2 ty1) :: nil) + (sl1 ++ sl2 ++ make_assign bf 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_postincr_val: forall le dst id e1 ty sl1 a1 tmp1 bf t ty1 tmp, tr_expr le For_val e1 sl1 a1 tmp1 -> incl tmp1 tmp -> In t tmp -> ~In t tmp1 -> ty1 = Csyntax.typeof e1 -> + tr_is_bitfield_access a1 bf -> tr_expr le dst (Csyntax.Epostincr id e1 ty) - (sl1 ++ make_set t a1 :: - make_assign a1 (transl_incrdecr id (Etempvar t ty1) ty1) :: + (sl1 ++ make_set bf t a1 :: + make_assign bf a1 (transl_incrdecr id (Etempvar t ty1) ty1) :: final dst (Etempvar t ty1)) (Etempvar t ty1) tmp | tr_comma: forall le dst e1 e2 ty sl1 a1 tmp1 sl2 a2 tmp2 tmp, @@ -746,14 +769,31 @@ Proof. intros. apply tr_expr_monotone with tmps; auto. apply add_dest_incl. Qed. +Lemma is_bitfield_access_meets_spec: forall l g bf g' I, + is_bitfield_access ce l g = Res bf g' I -> + tr_is_bitfield_access l bf. +Proof. + unfold is_bitfield_access; intros; red. destruct l; try (monadInv H; auto). + assert (AUX: forall fn id, + is_bitfield_access_aux ce fn id i g = Res bf g' I -> + exists co ofs, + ce!id = Some co /\ fn ce i (co_members co) = OK (ofs, bf)). + { unfold is_bitfield_access_aux; intros. + destruct ce!id as [co|]; try discriminate. + destruct (fn ce i (co_members co)) as [[ofs1 bf1]|] eqn:FN; inv H0. + exists co, ofs1; auto. } + destruct (typeof l); try discriminate; apply AUX; auto. +Qed. + Lemma transl_valof_meets_spec: forall ty a g sl b g' I, - transl_valof ty a g = Res (sl, b) g' I -> + transl_valof ce 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) eqn:?; monadInv H. - exists (x :: nil); split; eauto with gensym. econstructor; eauto with coqlib. + exists (x :: nil); split; eauto with gensym. + econstructor; eauto using is_bitfield_access_meets_spec with coqlib. exists (@nil ident); split; eauto with gensym. constructor; auto. Qed. @@ -763,12 +803,12 @@ Combined Scheme expr_exprlist_ind from expr_ind2, exprlist_ind2. Lemma transl_meets_spec: (forall r dst g sl a g' I, - transl_expr dst r g = Res (sl, a) g' I -> + transl_expr ce dst r g = Res (sl, a) g' I -> dest_below dst g -> exists tmps, (forall le, tr_expr le dst r sl a (add_dest dst tmps)) /\ contained tmps g g') /\ (forall rl g sl al g' I, - transl_exprlist rl g = Res (sl, al) g' I -> + transl_exprlist ce rl g = Res (sl, al) g' I -> exists tmps, (forall le, tr_exprlist le rl sl al tmps) /\ contained tmps g g'). Proof. apply expr_exprlist_ind; simpl add_dest; intros. @@ -920,9 +960,10 @@ Opaque makeif. - (* assign *) monadInv H1. exploit H; eauto. intros [tmp1 [A B]]. exploit H0; eauto. intros [tmp2 [Csyntax D]]. - destruct dst; monadInv EQ2; simpl add_dest in *. + apply is_bitfield_access_meets_spec in EQ0. + destruct dst; monadInv EQ3; simpl add_dest in *. + (* for value *) - exists (x1 :: tmp1 ++ tmp2); split. + exists (x2 :: tmp1 ++ tmp2); split. intros. eapply tr_assign_val with (dst := For_val); eauto with gensym. apply contained_cons. eauto with gensym. apply contained_app; eauto with gensym. @@ -931,7 +972,7 @@ Opaque makeif. econstructor; eauto with gensym. apply contained_app; eauto with gensym. + (* for set *) - exists (x1 :: tmp1 ++ tmp2); split. + exists (x2 :: tmp1 ++ tmp2); split. repeat rewrite app_ass. simpl. intros. eapply tr_assign_val with (dst := For_set sd); eauto with gensym. apply contained_cons. eauto with gensym. @@ -940,37 +981,39 @@ Opaque makeif. monadInv H1. exploit H; eauto. intros [tmp1 [A B]]. exploit H0; eauto. intros [tmp2 [Csyntax D]]. exploit transl_valof_meets_spec; eauto. intros [tmp3 [E F]]. - destruct dst; monadInv EQ3; simpl add_dest in *. + apply is_bitfield_access_meets_spec in EQ2. + destruct dst; monadInv EQ4; simpl add_dest in *. + (* for value *) - 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. + exists (x3 :: tmp1 ++ tmp2 ++ tmp3); split. + intros. eapply tr_assignop_val with (dst := For_val); eauto 6 with gensym. + apply contained_cons. eauto 6 with gensym. + apply contained_app; eauto 6 with gensym. + (* for effects *) exists (tmp1 ++ tmp2 ++ tmp3); split. econstructor; eauto with gensym. apply contained_app; eauto with gensym. + (* for set *) - exists (x2 :: tmp1 ++ tmp2 ++ tmp3); split. + exists (x3 :: tmp1 ++ tmp2 ++ tmp3); split. repeat rewrite app_ass. simpl. - intros. eapply tr_assignop_val with (dst := For_set sd); eauto with gensym. - apply contained_cons. eauto with gensym. - apply contained_app; eauto with gensym. + intros. eapply tr_assignop_val with (dst := For_set sd); eauto 6 with gensym. + apply contained_cons. eauto 6 with gensym. + apply contained_app; eauto 6 with gensym. - (* postincr *) monadInv H0. exploit H; eauto. intros [tmp1 [A B]]. - destruct dst; monadInv EQ0; simpl add_dest in *. + apply is_bitfield_access_meets_spec in EQ1. + destruct dst; monadInv EQ2; simpl add_dest in *. + (* for value *) - exists (x0 :: tmp1); split. + exists (x1 :: tmp1); split. econstructor; eauto with gensym. apply contained_cons; eauto with gensym. + (* for effects *) - exploit transl_valof_meets_spec; eauto. intros [tmp2 [Csyntax D]]. + exploit transl_valof_meets_spec; eauto. intros [tmp2 [C D]]. exists (tmp1 ++ tmp2); split. econstructor; eauto with gensym. eauto with gensym. + (* for set *) repeat rewrite app_ass; simpl. - exists (x0 :: tmp1); split. + exists (x1 :: tmp1); split. econstructor; eauto with gensym. apply contained_cons; eauto with gensym. - (* comma *) @@ -1032,7 +1075,7 @@ Qed. Lemma transl_expr_meets_spec: forall r dst g sl a g' I, - transl_expr dst r g = Res (sl, a) g' I -> + transl_expr ce dst r g = Res (sl, a) g' I -> dest_below dst g -> exists tmps, forall ge e le m, tr_top ge e le m dst r sl a tmps. Proof. @@ -1042,7 +1085,7 @@ Qed. Lemma transl_expression_meets_spec: forall r g s a g' I, - transl_expression r g = Res (s, a) g' I -> + transl_expression ce r g = Res (s, a) g' I -> tr_expression r s a. Proof. intros. monadInv H. exploit transl_expr_meets_spec; eauto. @@ -1051,7 +1094,7 @@ Qed. Lemma transl_expr_stmt_meets_spec: forall r g s g' I, - transl_expr_stmt r g = Res s g' I -> + transl_expr_stmt ce r g = Res s g' I -> tr_expr_stmt r s. Proof. intros. monadInv H. exploit transl_expr_meets_spec; eauto. @@ -1060,7 +1103,7 @@ Qed. Lemma transl_if_meets_spec: forall r s1 s2 g s g' I, - transl_if r s1 s2 g = Res s g' I -> + transl_if ce r s1 s2 g = Res s g' I -> tr_if r s1 s2 s. Proof. intros. monadInv H. exploit transl_expr_meets_spec; eauto. @@ -1068,9 +1111,9 @@ Proof. Qed. Lemma transl_stmt_meets_spec: - forall s g ts g' I, transl_stmt s g = Res ts g' I -> tr_stmt s ts + forall s g ts g' I, transl_stmt ce s g = Res ts g' I -> tr_stmt s ts with transl_lblstmt_meets_spec: - forall s g ts g' I, transl_lblstmt s g = Res ts g' I -> tr_lblstmts s ts. + forall s g ts g' I, transl_lblstmt ce s g = Res ts g' I -> tr_lblstmts s ts. Proof. generalize transl_expression_meets_spec transl_expr_stmt_meets_spec transl_if_meets_spec; intros T1 T2 T3. Opaque transl_expression transl_expr_stmt. @@ -1099,32 +1142,32 @@ Inductive tr_function: Csyntax.function -> Clight.function -> Prop := fn_vars tf = Csyntax.fn_vars f -> tr_function f tf. -Inductive tr_fundef: Csyntax.fundef -> Clight.fundef -> Prop := - | tr_internal: forall f tf, - tr_function f tf -> - tr_fundef (Internal f) (Internal tf) - | tr_external: forall ef targs tres cconv, - tr_fundef (External ef targs tres cconv) (External ef targs tres cconv). - Lemma transl_function_spec: forall f tf, - transl_function f = OK tf -> + transl_function ce f = OK tf -> tr_function f tf. Proof. unfold transl_function; intros. - destruct (transl_stmt (Csyntax.fn_body f) (initial_generator tt)) eqn:T; inv H. + destruct (transl_stmt ce (Csyntax.fn_body f) (initial_generator tt)) eqn:T; inv H. constructor; auto. simpl. eapply transl_stmt_meets_spec; eauto. Qed. +End SPEC. + +Inductive tr_fundef (p: Csyntax.program): Csyntax.fundef -> Clight.fundef -> Prop := + | tr_internal: forall f tf, + tr_function p.(prog_comp_env) f tf -> + tr_fundef p (Internal f) (Internal tf) + | tr_external: forall ef targs tres cconv, + tr_fundef p (External ef targs tres cconv) (External ef targs tres cconv). + Lemma transl_fundef_spec: - forall fd tfd, - transl_fundef fd = OK tfd -> - tr_fundef fd tfd. + forall p fd tfd, + transl_fundef p.(prog_comp_env) fd = OK tfd -> + tr_fundef p fd tfd. Proof. unfold transl_fundef; intros. destruct fd; Errors.monadInv H. + constructor. eapply transl_function_spec; eauto. + constructor. Qed. - -End SPEC. diff --git a/cfrontend/SimplLocalsproof.v b/cfrontend/SimplLocalsproof.v index 988988a1..e4b759c4 100644 --- a/cfrontend/SimplLocalsproof.v +++ b/cfrontend/SimplLocalsproof.v @@ -391,7 +391,7 @@ Lemma match_envs_assign_lifted: e!id = Some(b, ty) -> val_casted v ty -> Val.inject f v tv -> - assign_loc ge ty m b Ptrofs.zero v m' -> + assign_loc ge ty m b Ptrofs.zero Full v m' -> VSet.mem id cenv = true -> match_envs f cenv e le m' lo hi te (PTree.set id tv tle) tlo thi. Proof. @@ -1004,13 +1004,13 @@ Proof. Qed. Lemma assign_loc_inject: - forall f ty m loc ofs v m' tm loc' ofs' v', - assign_loc ge ty m loc ofs v m' -> + forall f ty m loc ofs bf v m' tm loc' ofs' v', + assign_loc ge ty m loc ofs bf v m' -> Val.inject f (Vptr loc ofs) (Vptr loc' ofs') -> Val.inject f v v' -> Mem.inject f m tm -> exists tm', - assign_loc tge ty tm loc' ofs' v' tm' + assign_loc tge ty tm loc' ofs' bf v' tm' /\ Mem.inject f m' tm' /\ (forall b chunk v, f b = None -> Mem.load chunk m b 0 = Some v -> Mem.load chunk m' b 0 = Some v). @@ -1078,15 +1078,25 @@ Proof. split. auto. intros. rewrite <- H0. eapply Mem.load_storebytes_other; eauto. left. congruence. +- (* bitfield *) + inv H3. + exploit Mem.loadv_inject; eauto. intros (vc' & LD' & INJ). inv INJ. + exploit Mem.storev_mapped_inject; eauto. intros [tm' [A B]]. + inv H1. + exists tm'; split. eapply assign_loc_bitfield; eauto. econstructor; eauto. + split. auto. + intros. rewrite <- H3. eapply Mem.load_store_other; eauto. + left. inv H0. congruence. Qed. Lemma assign_loc_nextblock: - forall ge ty m b ofs v m', - assign_loc ge ty m b ofs v m' -> Mem.nextblock m' = Mem.nextblock m. + forall ge ty m b ofs bf v m', + assign_loc ge ty m b ofs bf v m' -> Mem.nextblock m' = Mem.nextblock m. Proof. induction 1. simpl in H0. eapply Mem.nextblock_store; eauto. eapply Mem.nextblock_storebytes; eauto. + inv H. eapply Mem.nextblock_store; eauto. Qed. Theorem store_params_correct: @@ -1168,7 +1178,7 @@ Local Opaque Conventions1.parameter_needs_normalization. reflexivity. reflexivity. eexact U. traceEq. - rewrite (assign_loc_nextblock _ _ _ _ _ _ _ A) in Z. auto. + rewrite (assign_loc_nextblock _ _ _ _ _ _ _ _ A) in Z. auto. Qed. Lemma bind_parameters_nextblock: @@ -1400,19 +1410,22 @@ Proof. Qed. Lemma deref_loc_inject: - forall ty loc ofs v loc' ofs', - deref_loc ty m loc ofs v -> + forall ty loc ofs bf v loc' ofs', + deref_loc ty m loc ofs bf v -> Val.inject f (Vptr loc ofs) (Vptr loc' ofs') -> - exists tv, deref_loc ty tm loc' ofs' tv /\ Val.inject f v tv. + exists tv, deref_loc ty tm loc' ofs' bf tv /\ Val.inject f v tv. Proof. intros. inv H. - (* by value *) +- (* by value *) exploit Mem.loadv_inject; eauto. intros [tv [A B]]. exists tv; split; auto. eapply deref_loc_value; eauto. - (* by reference *) +- (* by reference *) exists (Vptr loc' ofs'); split; auto. eapply deref_loc_reference; eauto. - (* by copy *) +- (* by copy *) exists (Vptr loc' ofs'); split; auto. eapply deref_loc_copy; eauto. +- (* bitfield *) + inv H1. exploit Mem.loadv_inject; eauto. intros [tc [A B]]. inv B. + econstructor; split. eapply deref_loc_bitfield. econstructor; eauto. constructor. Qed. Lemma eval_simpl_expr: @@ -1422,11 +1435,11 @@ Lemma eval_simpl_expr: exists tv, eval_expr tge te tle tm (simpl_expr cenv a) tv /\ Val.inject f v tv with eval_simpl_lvalue: - forall a b ofs, - eval_lvalue ge e le m a b ofs -> + forall a b ofs bf, + eval_lvalue ge e le m a b ofs bf -> compat_cenv (addr_taken_expr a) cenv -> match a with Evar id ty => VSet.mem id cenv = false | _ => True end -> - exists b', exists ofs', eval_lvalue tge te tle tm (simpl_expr cenv a) b' ofs' /\ Val.inject f (Vptr b ofs) (Vptr b' ofs'). + exists b', exists ofs', eval_lvalue tge te tle tm (simpl_expr cenv a) b' ofs' bf /\ Val.inject f (Vptr b ofs) (Vptr b' ofs'). Proof. destruct 1; simpl; intros. @@ -1472,7 +1485,7 @@ Proof. subst a. simpl. rewrite OPT. exploit me_vars; eauto. instantiate (1 := id). intros MV. inv H; inv MV; try congruence. - rewrite ENV in H6; inv H6. + rewrite ENV in H7; inv H7. inv H0; try congruence. assert (chunk0 = chunk). simpl in H. congruence. subst chunk0. assert (v0 = v). unfold Mem.loadv in H2. rewrite Ptrofs.unsigned_zero in H2. congruence. subst v0. @@ -1516,7 +1529,8 @@ Proof. exploit eval_simpl_expr; eauto. intros [tv [A B]]. inversion B. subst. econstructor; econstructor; split. - eapply eval_Efield_union; eauto. rewrite typeof_simpl_expr; eauto. auto. + eapply eval_Efield_union; eauto. rewrite typeof_simpl_expr; eauto. + econstructor; eauto. repeat rewrite Ptrofs.add_assoc. decEq. apply Ptrofs.add_commut. Qed. Lemma eval_simpl_exprlist: @@ -1607,18 +1621,20 @@ Qed. (** Invariance by assignment to location "above" *) Lemma match_cont_assign_loc: - forall f cenv k tk m bound tbound ty loc ofs v m', + forall f cenv k tk m bound tbound ty loc ofs bf v m', match_cont f cenv k tk m bound tbound -> - assign_loc ge ty m loc ofs v m' -> + assign_loc ge ty m loc ofs bf v m' -> Ple bound loc -> match_cont f cenv k tk m' bound tbound. Proof. intros. eapply match_cont_invariant; eauto. intros. rewrite <- H4. inv H0. - (* scalar *) +- (* scalar *) simpl in H6. eapply Mem.load_store_other; eauto. left. unfold block; extlia. - (* block copy *) +- (* block copy *) eapply Mem.load_storebytes_other; eauto. left. unfold block; extlia. +- (* bitfield *) + inv H5. eapply Mem.load_store_other; eauto. left. unfold block; extlia. Qed. (** Invariance by external calls *) diff --git a/common/Behaviors.v b/common/Behaviors.v index 023b33e2..1f7f6226 100644 --- a/common/Behaviors.v +++ b/common/Behaviors.v @@ -25,6 +25,7 @@ Require Import Integers. Require Import Smallstep. Set Implicit Arguments. +Set Asymmetric Patterns. (** * Behaviors for program executions *) diff --git a/common/Builtins0.v b/common/Builtins0.v index 384dde1e..d1922297 100644 --- a/common/Builtins0.v +++ b/common/Builtins0.v @@ -142,17 +142,34 @@ Definition valty (t: typ) : Type := | Tany32 | Tany64 => Empty_set (**r no clear semantic meaning *) end. -(** We can inject and project between the numerical type [valty t] and the type [val]. *) +Definition valretty (t: rettype) : Type := + match t with + | Tret t => valty t + | Tint8signed => { n: int | n = Int.sign_ext 8 n } + | Tint8unsigned => { n: int | n = Int.zero_ext 8 n } + | Tint16signed => { n: int | n = Int.sign_ext 16 n } + | Tint16unsigned => { n: int | n = Int.zero_ext 16 n } + | Tvoid => unit + end. + +(** We can inject from the numerical type [valretty t] to the value type [val]. *) -Definition inj_num (t: typ) : valty t -> val := +Definition inj_num (t: rettype) : valretty t -> val := match t with - | Tint => Vint - | Tlong => Vlong - | Tfloat => Vfloat - | Tsingle => Vsingle - | Tany32 | Tany64 => fun _ => Vundef + | Tret Tint => Vint + | Tret Tlong => Vlong + | Tret Tfloat => Vfloat + | Tret Tsingle => Vsingle + | Tret (Tany32 | Tany64) => fun _ => Vundef + | Tint8signed => fun n => Vint (proj1_sig n) + | Tint8unsigned => fun n => Vint (proj1_sig n) + | Tint16signed => fun n => Vint (proj1_sig n) + | Tint16unsigned => fun n => Vint (proj1_sig n) + | Tvoid => fun _ => Vundef end. +(** Conversely, we can project a value to the numerical type [valty t]. *) + Definition proj_num {A: Type} (t: typ) (k0: A) (v: val): (valty t -> A) -> A := match t with | Tint => fun k1 => match v with Vint n => k1 n | _ => k0 end @@ -162,14 +179,15 @@ Definition proj_num {A: Type} (t: typ) (k0: A) (v: val): (valty t -> A) -> A := | Tany32 | Tany64 => fun k1 => k0 end. -Lemma inj_num_wt: forall t x, Val.has_type (inj_num t x) t. +Lemma inj_num_wt: forall t x, Val.has_rettype (inj_num t x) t. Proof. - destruct t; intros; exact I. + destruct t; intros; simpl; auto; try (apply proj2_sig). + destruct t; exact I. Qed. Lemma inj_num_inject: forall j t x, Val.inject j (inj_num t x) (inj_num t x). Proof. - destruct t; intros; constructor. + destruct t; intros; try constructor. destruct t; constructor. Qed. Lemma inj_num_opt_wt: forall t x, val_opt_has_rettype (option_map (inj_num t) x) t. @@ -185,10 +203,13 @@ Qed. Lemma proj_num_wt: forall tres t k1 v, - (forall x, Val.has_type (k1 x) tres) -> - Val.has_type (proj_num t Vundef v k1) tres. + (forall x, Val.has_rettype (k1 x) tres) -> + Val.has_rettype (proj_num t Vundef v k1) tres. Proof. - intros. destruct t; simpl; destruct v; auto; exact I. + intros. + assert (U: Val.has_rettype Vundef tres). + { destruct tres; exact I. } + intros. destruct t; simpl; destruct v; auto. Qed. Lemma proj_num_inject: @@ -201,13 +222,14 @@ Proof. Qed. Lemma proj_num_opt_wt: - forall (tres: typ) t k0 k1 v, + forall tres t k0 k1 v, k0 = None \/ k0 = Some Vundef -> (forall x, val_opt_has_rettype (k1 x) tres) -> val_opt_has_rettype (proj_num t k0 v k1) tres. Proof. intros. - assert (val_opt_has_rettype k0 tres). { destruct H; subst k0; exact I. } + assert (val_opt_has_rettype k0 tres). + { destruct H; subst k0. exact I. hnf. destruct tres; exact I. } destruct t; simpl; destruct v; auto. Qed. @@ -228,8 +250,8 @@ Qed. *) Program Definition mkbuiltin_n1t - (targ1: typ) (tres: typ) - (f: valty targ1 -> valty tres) := + (targ1: typ) (tres: rettype) + (f: valty targ1 -> valretty tres) := mkbuiltin_v1t tres (fun v1 => proj_num targ1 Vundef v1 (fun x => inj_num tres (f x))) _ _. @@ -241,8 +263,8 @@ Next Obligation. Qed. Program Definition mkbuiltin_n2t - (targ1 targ2: typ) (tres: typ) - (f: valty targ1 -> valty targ2 -> valty tres) := + (targ1 targ2: typ) (tres: rettype) + (f: valty targ1 -> valty targ2 -> valretty tres) := mkbuiltin_v2t tres (fun v1 v2 => proj_num targ1 Vundef v1 (fun x1 => @@ -256,8 +278,8 @@ Next Obligation. Qed. Program Definition mkbuiltin_n3t - (targ1 targ2 targ3: typ) (tres: typ) - (f: valty targ1 -> valty targ2 -> valty targ3 -> valty tres) := + (targ1 targ2 targ3: typ) (tres: rettype) + (f: valty targ1 -> valty targ2 -> valty targ3 -> valretty tres) := mkbuiltin_v3t tres (fun v1 v2 v3 => proj_num targ1 Vundef v1 (fun x1 => @@ -272,8 +294,8 @@ Next Obligation. Qed. Program Definition mkbuiltin_n1p - (targ1: typ) (tres: typ) - (f: valty targ1 -> option (valty tres)) := + (targ1: typ) (tres: rettype) + (f: valty targ1 -> option (valretty tres)) := mkbuiltin_v1p tres (fun v1 => proj_num targ1 None v1 (fun x => option_map (inj_num tres) (f x))) _ _. @@ -285,8 +307,8 @@ Next Obligation. Qed. Program Definition mkbuiltin_n2p - (targ1 targ2: typ) (tres: typ) - (f: valty targ1 -> valty targ2 -> option (valty tres)) := + (targ1 targ2: typ) (tres: rettype) + (f: valty targ1 -> valty targ2 -> option (valretty tres)) := mkbuiltin_v2p tres (fun v1 v2 => proj_num targ1 None v1 (fun x1 => diff --git a/common/Linking.v b/common/Linking.v index 089f4fd2..d23b1028 100644 --- a/common/Linking.v +++ b/common/Linking.v @@ -869,7 +869,7 @@ Infix ":::" := pass_cons (at level 60, right associativity) : linking_scope. Fixpoint compose_passes (l l': Language) (passes: Passes l l') : Pass l l' := match passes in Passes l l' return Pass l l' with | pass_nil l => pass_identity l - | pass_cons l1 l2 l3 pass1 passes => pass_compose pass1 (compose_passes passes) + | pass_cons pass1 passes => pass_compose pass1 (compose_passes passes) end. (** Some more lemmas about [nlist_forall2]. *) diff --git a/cparser/Bitfields.ml b/cparser/Bitfields.ml deleted file mode 100644 index ad6e1696..00000000 --- a/cparser/Bitfields.ml +++ /dev/null @@ -1,581 +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 Lesser General Public License as *) -(* published by the Free Software Foundation, either version 2.1 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 bit fields in structs *) - -(* Assumes: nothing. *) - -open Machine -open C -open Cutil -open Transform - -(* Info associated to each bitfield *) - -type bitfield_info = - { bf_carrier: string; (* name of underlying regular field *) - bf_carrier_typ: typ; (* type of underlying regular field *) - bf_pos: int; (* start bit *) - bf_size: int; (* size in bit *) - bf_signed: bool; (* is field signed or unsigned? *) - bf_signed_res: bool; (* is result of extracting field signed or unsigned? *) - bf_bool: bool (* does field have type _Bool? *) - } - -(* invariants: - 0 <= pos < bitsizeof(int) - 0 < sz <= bitsizeof(int) - 0 < pos + sz <= bitsizeof(int) -*) - -let carrier_field bf = - { fld_name = bf.bf_carrier; fld_typ = bf.bf_carrier_typ; - fld_bitfield = None; fld_anonymous = false } - -(* Mapping (struct/union identifier, bitfield name) -> bitfield info *) - -let bitfield_table = - (Hashtbl.create 57: (ident * string, bitfield_info) Hashtbl.t) - -let is_bitfield structid fieldname = - Hashtbl.find_opt bitfield_table (structid, fieldname) - -(* Mapping struct/union identifier -> list of members after transformation, - including the carrier fields, but without the bit fields. - structs and unions containing no bit fields are not put in this table. *) - -let composite_transformed_members = - (Hashtbl.create 57: (ident, C.field list) Hashtbl.t) - -(* Signedness issues *) - -let unsigned_ikind_for_carrier nbits = - if nbits <= 8 then IUChar else - if nbits <= 8 * !config.sizeof_short then IUShort else - if nbits <= 8 * !config.sizeof_int then IUInt else - if nbits <= 8 * !config.sizeof_long then IULong else - if nbits <= 8 * !config.sizeof_longlong then IULongLong else - assert false - -let is_signed_enum_bitfield env sid fld eid n = - let info = Env.find_enum env eid in - if List.for_all (fun (_, v, _) -> int_representable v n false) info.Env.ei_members - then false - else if List.for_all (fun (_, v, _) -> int_representable v n true) info.Env.ei_members - then true - else begin - Diagnostics.warning Diagnostics.no_loc Diagnostics.Unnamed - "not all values of type 'enum %s' can be represented in bit-field '%s' of struct '%s' (%d bits are not enough)" - eid.C.name fld sid.C.name n; - false - end - -(* Packing algorithm -- keep consistent with [Cutil.pack_bitfield]! *) - -let pack_bitfields env sid ml = - let rec pack accu pos = function - | [] -> - (pos, accu, []) - | m :: ms as ml -> - match m.fld_bitfield with - | None -> (pos, accu, ml) - | Some n -> - if n = 0 then - (pos, accu, ms) (* bit width 0 means end of pack *) - else if pos + n > 8 * !config.sizeof_int then - (pos, accu, ml) (* doesn't fit in current word *) - else begin - let signed = - match unroll env m.fld_typ with - | TInt(ik, _) -> is_signed_ikind ik - | TEnum(eid, _) -> is_signed_enum_bitfield env sid m.fld_name eid n - | _ -> assert false (* should never happen, checked in Elab *) in - let signed2 = - match unroll env (type_of_member env m) with - | TInt(ik, _) -> is_signed_ikind ik - | _ -> assert false (* should never happen, checked in Elab *) in - let is_bool = - match unroll env m.fld_typ with - | TInt(IBool, _) -> true - | _ -> false in - - pack ((m.fld_name, pos, n, signed, signed2, is_bool) :: accu) - (pos + n) ms - end - in pack [] 0 ml - -let rec transf_struct_members env id count = function - | [] -> [] - | m :: ms as ml -> - if m.fld_bitfield = None then - m :: transf_struct_members env id count ms - else begin - let (nbits, bitfields, ml') = pack_bitfields env id ml in - if nbits = 0 then - (* Lone zero-size bitfield: just ignore *) - transf_struct_members env id count ml' - else begin - (* Create integer field of sufficient size for this bitfield group *) - let carrier = Printf.sprintf "__bf%d" count in - let carrier_ikind = unsigned_ikind_for_carrier nbits in - let carrier_typ = TInt(carrier_ikind, []) in - (* Enter each field with its bit position, size, signedness *) - List.iter - (fun (name, pos, sz, signed, signed2, is_bool) -> - if name <> "" then begin - let pos' = - if !config.bitfields_msb_first - then sizeof_ikind carrier_ikind * 8 - pos - sz - else pos in - Debug.set_bitfield_offset id name pos carrier (sizeof_ikind carrier_ikind); - Hashtbl.add bitfield_table - (id, name) - {bf_carrier = carrier; bf_carrier_typ = carrier_typ; - bf_pos = pos'; bf_size = sz; - bf_signed = signed; bf_signed_res = signed2; - bf_bool = is_bool} - end) - bitfields; - { fld_name = carrier; fld_typ = carrier_typ; fld_bitfield = None; fld_anonymous = false;} - :: transf_struct_members env id (count + 1) ml' - end - end - -let rec transf_union_members env id count = function - | [] -> [] - | m :: ms -> - (match m.fld_bitfield with - | None -> m::transf_union_members env id count ms - | Some nbits -> - let carrier = Printf.sprintf "__bf%d" count in - let carrier_ikind = unsigned_ikind_for_carrier nbits in - let carrier_typ = TInt(carrier_ikind, []) in - let signed = - match unroll env m.fld_typ with - | TInt(ik, _) -> is_signed_ikind ik - | TEnum(eid, _) -> is_signed_enum_bitfield env id m.fld_name eid nbits - | _ -> assert false (* should never happen, checked in Elab *) in - let signed2 = - match unroll env (type_of_member env m) with - | TInt(ik, _) -> is_signed_ikind ik - | _ -> assert false (* should never happen, checked in Elab *) in - let pos' = - if !config.bitfields_msb_first - then sizeof_ikind carrier_ikind * 8 - nbits - else 0 in - let is_bool = - match unroll env m.fld_typ with - | TInt(IBool, _) -> true - | _ -> false in - Hashtbl.add bitfield_table - (id, m.fld_name) - {bf_carrier = carrier; bf_carrier_typ = carrier_typ; - bf_pos = pos'; bf_size = nbits; - bf_signed = signed; bf_signed_res = signed2; - bf_bool = is_bool}; - { fld_name = carrier; fld_typ = carrier_typ; fld_bitfield = None; fld_anonymous = false;} - :: transf_union_members env id (count + 1) ms) - -let transf_composite env loc su id attr ml = - if List.for_all (fun f -> f.fld_bitfield = None) ml then - (attr, ml) - else begin - if find_custom_attributes ["packed";"__packed__"] attr <> [] then - Diagnostics.error loc "bitfields in packed structs not allowed"; - let ml' = - match su with - | Struct -> transf_struct_members env id 1 ml - | Union -> transf_union_members env id 1 ml in - Hashtbl.add composite_transformed_members id ml'; - (attr, ml') - end - -(* Bitfield manipulation expressions *) - -let left_shift_count bf = - intconst - (Int64.of_int (8 * !config.sizeof_int - (bf.bf_pos + bf.bf_size))) - IInt - -let right_shift_count bf = - intconst - (Int64.of_int (8 * !config.sizeof_int - bf.bf_size)) - IInt - -let uintconst_hex v = - { edesc = EConst(CInt(v, IUInt, Printf.sprintf "0x%LXU" v)); - etyp = TInt(IUInt, []) } - -let insertion_mask bf = - let m = - Int64.shift_left - (Int64.pred (Int64.shift_left 1L bf.bf_size)) - bf.bf_pos in - (* Give the mask an hexadecimal string representation, nicer to read *) - uintconst_hex m - -let eshift env op a b = - let ty = unary_conversion env a.etyp in - { edesc = EBinop(op, a, b, ty); etyp = ty } - -let ebinint env op a b = - let ty = binary_conversion env a.etyp b.etyp in - { edesc = EBinop(op, a, b, ty); etyp = ty } - -(* Extract the value of a bitfield *) - -(* Reference C code: - -unsigned int bitfield_unsigned_extract(unsigned int x, int ofs, int sz) -{ - return (x << (BITSIZE_UINT - (ofs + sz))) >> (BITSIZE_UINT - sz); -} - -signed int bitfield_signed_extract(unsigned int x, int ofs, int sz) -{ - return ((signed int) (x << (BITSIZE_UINT - (ofs + sz)))) - >> (BITSIZE_UINT - sz); -} - -*) - -let bitfield_extract env bf carrier = - let e1 = eshift env Oshl carrier (left_shift_count bf) in - let ty = TInt((if bf.bf_signed then IInt else IUInt), []) in - let e2 = ecast ty e1 in - let e3 = eshift env Oshr e2 (right_shift_count bf) in - if bf.bf_signed_res = bf.bf_signed - then e3 - else ecast (TInt((if bf.bf_signed_res then IInt else IUInt), [])) e3 - -(* Assign a bitfield within a carrier *) - -(* Reference C code: - -unsigned int bitfield_insert(unsigned int x, int ofs, int sz, unsigned int y) -{ - unsigned int mask = ((1U << sz) - 1) << ofs; - return ((y << ofs) & mask) | (x & ~mask); -} - -If the bitfield is of type _Bool, the new value (y above) must be converted -to _Bool to normalize it to 0 or 1. -*) - -let bitfield_assign env bf carrier newval = - let msk = insertion_mask bf in - let notmsk = {edesc = EUnop(Onot, msk); etyp = msk.etyp} in - let newval_casted = - ecast (TInt(IUInt,[])) - (if bf.bf_bool then ecast (TInt(IBool,[])) newval else newval) in - let newval_shifted = - eshift env Oshl newval_casted (intconst (Int64.of_int bf.bf_pos) IUInt) in - let newval_masked = ebinint env Oand newval_shifted msk - and oldval_masked = ebinint env Oand carrier notmsk in - ebinint env Oor newval_masked oldval_masked - -(* Initialize a bitfield *) - -(* Reference C code: - -unsigned int bitfield_init(int ofs, int sz, unsigned int y) -{ - unsigned int mask = (1U << sz) - 1; - return (y & mask) << ofs; -} - -If the bitfield is of type _Bool, the new value (y above) must be converted -to _Bool to normalize it to 0 or 1. -*) - -let bitfield_initializer bf i = - match i with - | Init_single e -> - let m = Int64.pred (Int64.shift_left 1L bf.bf_size) in - let e_cast = - if bf.bf_bool then ecast (TInt(IBool,[])) e else e in - let e_mask = uintconst_hex m in - let e_and = - {edesc = EBinop(Oand, e_cast, e_mask, TInt(IUInt,[])); - etyp = TInt(IUInt,[])} in - {edesc = EBinop(Oshl, e_and, intconst (Int64.of_int bf.bf_pos) IInt, - TInt(IUInt, [])); - etyp = TInt(IUInt, [])} - | _ -> - assert false - -(* Associate to the left so that it prints more nicely *) - -let or_expr_list = function - | [] -> intconst 0L IUInt - | [e] -> e - | e1 :: el -> - List.fold_left - (fun accu e -> - {edesc = EBinop(Oor, accu, e, TInt(IUInt,[])); - etyp = TInt(IUInt,[])}) - e1 el - -(* Initialize the carrier for consecutive bitfields *) - -let rec pack_bitfield_init id carrier fld_init_list = - match fld_init_list with - | [] -> ([], []) - | (fld, i) :: rem -> - match is_bitfield id fld.fld_name with - | None -> - ([], fld_init_list) - | Some bf -> - if bf.bf_carrier <> carrier then - ([], fld_init_list) - else begin - let (el, rem') = pack_bitfield_init id carrier rem in - (bitfield_initializer bf i :: el, rem') - end - -let rec transf_struct_init id fld_init_list = - match fld_init_list with - | [] -> [] - | (fld, i) :: rem -> - match is_bitfield id fld.fld_name with - | None -> - (fld, i) :: transf_struct_init id rem - | Some bf -> - let (el, rem') = - pack_bitfield_init id bf.bf_carrier fld_init_list in - (carrier_field bf, - Init_single {edesc = ECast(bf.bf_carrier_typ, or_expr_list el); - etyp = bf.bf_carrier_typ}) - :: transf_struct_init id rem' - -(* Add default initialization for carrier fields that are not listed in the output of - [transf_struct_init]. This happens with carrier fields that contain no named - bitfields, only anonymous bitfields. *) - -let rec completed_struct_init env actual expected = - match actual, expected with - | [], [] -> [] - | (f_a, i) :: actual', f_e :: expected' when f_a.fld_name = f_e.fld_name -> - (f_a, i) :: completed_struct_init env actual' expected' - | _, f_e :: expected' -> - (f_e, default_init env f_e.fld_typ) :: completed_struct_init env actual expected' - | _, [] -> - assert false - -(* Check whether a field access (e.f or e->f) is a bitfield access. - If so, return carrier expression (e and *e, respectively) - and bitfield_info *) - -let rec is_bitfield_access env e = - match e.edesc with - | EUnop(Odot fieldname, e1) -> - begin match unroll env e1.etyp with - | TUnion (id,_) - | TStruct(id, _) -> - (try Some(e1, Hashtbl.find bitfield_table (id, fieldname)) - with Not_found -> None) - | _ -> - None - end - | EUnop(Oarrow fieldname, e1) -> - begin match unroll env e1.etyp with - | TPtr(ty, _) | TArray(ty, _, _) -> - is_bitfield_access env - {edesc = EUnop(Odot fieldname, - {edesc = EUnop(Oderef, e1); etyp = ty}); - etyp = e.etyp} - | _ -> - None - end - | _ -> None - -(* Expressions *) - -let rec transf_exp env ctx e = - match e.edesc with - | EConst _ -> e - | ESizeof _ -> e - | EAlignof _ -> e - | EVar _ -> e - - | EUnop(Odot s, e1) -> - begin match is_bitfield_access env e with - | None -> - {edesc = EUnop(Odot s, transf_exp env Val e1); etyp = e.etyp} - | Some(ex, bf) -> - transf_read env ex bf - end - | EUnop(Oarrow s, e1) -> - begin match is_bitfield_access env e with - | None -> - {edesc = EUnop(Oarrow s, transf_exp env Val e1); etyp = e.etyp} - | Some(ex, bf) -> - transf_read env ex bf - end - | EUnop((Opreincr|Opredecr) as op, e1) -> - begin match is_bitfield_access env e1 with - | None -> - {edesc = EUnop(op, transf_exp env Val e1); etyp = e.etyp} - | Some(ex, bf) -> - transf_pre env ctx (op_for_incr_decr op) ex bf e1.etyp - end - | EUnop((Opostincr|Opostdecr) as op, e1) -> - begin match is_bitfield_access env e1 with - | None -> - {edesc = EUnop(op, transf_exp env Val e1); etyp = e.etyp} - | Some(ex, bf) -> - transf_post env ctx (op_for_incr_decr op) ex bf e1.etyp - end - | EUnop(op, e1) -> - {edesc = EUnop(op, transf_exp env Val e1); etyp = e.etyp} - - | EBinop(Oassign, e1, e2, ty) -> - begin match is_bitfield_access env e1 with - | None -> - {edesc = EBinop(Oassign, transf_exp env Val e1, - transf_exp env Val e2, ty); - etyp = e.etyp} - | Some(ex, bf) -> - transf_assign env ctx ex bf e2 - end - | 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) -> - begin match is_bitfield_access env e1 with - | None -> - {edesc = EBinop(op, transf_exp env Val e1, - transf_exp env Val e2, ty); etyp = e.etyp} - | Some(ex, bf) -> - transf_assignop env ctx (op_for_assignop op) ex bf e2 ty - end - | EBinop(Ocomma, e1, e2, ty) -> - {edesc = EBinop(Ocomma, transf_exp env Effects e1, - transf_exp env Val e2, ty); - etyp = e.etyp} - | EBinop(op, e1, e2, ty) -> - {edesc = EBinop(op, transf_exp env Val e1, transf_exp env Val e2, ty); - etyp = e.etyp} - - | EConditional(e1, e2, e3) -> - {edesc = EConditional(transf_exp env Val e1, - transf_exp env ctx e2, transf_exp env ctx e3); - etyp = e.etyp} - | ECast(ty, e1) -> - {edesc = ECast(ty, transf_exp env Val e1); etyp = e.etyp} - | ECompound(ty, i) -> - {edesc = ECompound(ty, transf_init env i); etyp = e.etyp} - | ECall(e1, el) -> - {edesc = ECall(transf_exp env Val e1, List.map (transf_exp env Val) el); - etyp = e.etyp} - -and transf_read env e bf = - bitfield_extract env bf - {edesc = EUnop(Odot bf.bf_carrier, transf_exp env Val e); - etyp = bf.bf_carrier_typ} - -and transf_assign env ctx e1 bf e2 = - bind_lvalue env (transf_exp env Val e1) (fun base -> - let carrier = - {edesc = EUnop(Odot bf.bf_carrier, base); etyp = bf.bf_carrier_typ} in - let asg = - eassign carrier (bitfield_assign env bf carrier (transf_exp env Val e2)) in - if ctx = Val then ecomma asg (bitfield_extract env bf carrier) else asg) - -and transf_assignop env ctx op e1 bf e2 tyres = - bind_lvalue env (transf_exp env Val e1) (fun base -> - let carrier = - {edesc = EUnop(Odot bf.bf_carrier, base); etyp = bf.bf_carrier_typ} in - let rhs = - {edesc = EBinop(op, bitfield_extract env bf carrier, transf_exp env Val e2, tyres); - etyp = tyres} in - let asg = - eassign carrier (bitfield_assign env bf carrier rhs) in - if ctx = Val then ecomma asg (bitfield_extract env bf carrier) else asg) - -and transf_pre env ctx op e1 bf tyfield = - transf_assignop env ctx op e1 bf (intconst 1L IInt) - (unary_conversion env tyfield) - -and transf_post env ctx op e1 bf tyfield = - if ctx = Effects then - transf_pre env ctx op e1 bf tyfield - else begin - bind_lvalue env (transf_exp env Val e1) (fun base -> - let carrier = - {edesc = EUnop(Odot bf.bf_carrier, base); etyp = bf.bf_carrier_typ} in - let temp = mk_temp env tyfield in - let tyres = unary_conversion env tyfield in - let settemp = eassign temp (bitfield_extract env bf carrier) in - let rhs = - {edesc = EBinop(op, temp, intconst 1L IInt, tyres); etyp = tyres} in - let asg = - eassign carrier (bitfield_assign env bf carrier rhs) in - ecomma (ecomma settemp asg) temp) - end - -(* Initializers *) - -and transf_init env i = - match i with - | Init_single e -> Init_single (transf_exp env Val e) - | Init_array il -> Init_array (List.rev (List.rev_map (transf_init env) il)) - | Init_struct(id, fld_init_list) -> - let fld_init_list' = - List.map (fun (f, i) -> (f, transf_init env i)) fld_init_list in - begin match Hashtbl.find composite_transformed_members id with - | exception Not_found -> - Init_struct(id, fld_init_list') - | ml -> - Init_struct(id, completed_struct_init env (transf_struct_init id fld_init_list') ml) - end - | Init_union(id, fld, i) -> - let i' = transf_init env i in - match is_bitfield id fld.fld_name with - | None -> - Init_union(id, fld, i') - | Some bf -> - Init_union(id, carrier_field bf, Init_single (bitfield_initializer bf i')) - -(* Declarations *) - -let transf_decl env loc (sto, id, ty, init_opt) = - (sto, id, ty, - match init_opt with None -> None | Some i -> Some(transf_init env i)) - -(* Statements *) - -let transf_stmt env s = - Transform.stmt - ~expr:(fun loc env ctx e -> transf_exp env ctx e) - ~decl:(fun env (sto, id, ty, init_opt) -> transf_decl env s.sloc (sto, id, ty, init_opt)) - env s - -(* Functions *) - -let transf_fundef env loc f = - Transform.fundef transf_stmt env f - -(* Programs *) - -let program p = - Hashtbl.clear bitfield_table; - Hashtbl.clear composite_transformed_members; - Transform.program - ~composite:transf_composite - ~decl: transf_decl - ~fundef:transf_fundef - p diff --git a/cparser/Bitfields.mli b/cparser/Bitfields.mli deleted file mode 100644 index 3ac42495..00000000 --- a/cparser/Bitfields.mli +++ /dev/null @@ -1,17 +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 Lesser General Public License as *) -(* published by the Free Software Foundation, either version 2.1 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: C.program -> C.program diff --git a/cparser/Cutil.ml b/cparser/Cutil.ml index 2dcf193d..d3a830ce 100644 --- a/cparser/Cutil.ml +++ b/cparser/Cutil.ml @@ -449,34 +449,6 @@ let rec equal_types env t1 t2 = let compatible_types mode env t1 t2 = match combine_types mode env t1 t2 with Some _ -> true | None -> false -(* Naive placement algorithm for bit fields, might not match that - of the compiler. *) - -let pack_bitfields ml = - let rec pack nbits = function - | [] -> - (nbits, []) - | m :: ms as ml -> - match m.fld_bitfield with - | None -> (nbits, ml) - | Some n -> - if n = 0 then - (nbits, ms) (* bit width 0 means end of pack *) - else if nbits + n > 8 * !config.sizeof_int then - (nbits, ml) (* doesn't fit in current word *) - else - pack (nbits + n) ms (* add to current word *) - in - let (nbits, ml') = pack 0 ml in - let (sz, al) = - (* A lone bitfield of width 0 consumes no space and aligns to 1 *) - if nbits = 0 then (0, 1) else - if nbits <= 8 then (1, 1) else - if nbits <= 16 then (2, 2) else - if nbits <= 32 then (4, 4) else - if nbits <= 64 then (8, 8) else assert false in - (sz, al, ml') - (* Natural alignment, in bytes *) let alignof_ikind = function @@ -520,15 +492,13 @@ let rec alignof env t = let alignof_struct_union env members = let rec align_rec al = function | [] -> Some al - | m :: rem as ml -> - if m.fld_bitfield = None then begin + | m :: rem -> + if m.fld_name = "" then + align_rec al rem + else match alignof env m.fld_typ with | None -> None | Some a -> align_rec (max a al) rem - end else begin - let (s, a, ml') = pack_bitfields ml in - align_rec (max a al) ml' - end in align_rec 1 members let align x boundary = @@ -605,43 +575,63 @@ let sizeof_union env members = Bitfields are taken into account for the size and offset computations but not given an offset. Not done here but in composite_info_def: rounding size to alignment. *) + let sizeof_layout_struct env members ma = - let align_offset ofs a = - align ofs (if ma > 0 && a > ma then ma else a) in - let rec sizeof_rec ofs accu = function + + let align_bit_offset pos a = + align pos (8 * (if ma > 0 && a > ma then ma else a)) in + + let record_field name pos = + assert (pos mod 8 = 0); + (name, pos / 8) in + + (* pos is the current position in bits *) + let rec sizeof_rec pos accu = function | [] -> - Some (ofs, accu) + Some (pos, accu) | [ { fld_typ = TArray(_, None, _) } as m ] -> (* C99: ty[] allowed as last field *) begin match alignof env m.fld_typ with | Some a -> - let ofs = align_offset ofs a in - Some (ofs, (m.fld_name, ofs) :: accu) + let pos = align_bit_offset pos a in + Some (pos, record_field m.fld_name pos :: accu) | None -> None end - | m :: rem as ml -> - if m.fld_bitfield = None then begin - match alignof env m.fld_typ, sizeof env m.fld_typ with - | Some a, Some s -> - let ofs = align_offset ofs a in - sizeof_rec (ofs + s) ((m.fld_name, ofs) :: accu) rem - | _, _ -> None - end else begin - let (s, a, ml') = pack_bitfields ml in - sizeof_rec (align_offset ofs a + s) accu ml' + | m :: rem -> + begin match alignof env m.fld_typ, sizeof env m.fld_typ with + | Some a, Some s -> + begin match m.fld_bitfield with + | None -> + let pos = align_bit_offset pos a in + sizeof_rec (pos + s * 8) + (record_field m.fld_name pos :: accu) + rem + | Some width -> + (* curr = beginning of storage unit, in bits + next = one past end of storage unit, in bits *) + let curr = pos / (a * 8) * (a * 8) in + let next = curr + s * 8 in + let pos' = + if width <= 0 then align pos (a * 8) + else if pos + width <= next then pos + width + else next + width in + sizeof_rec pos' accu rem + end + | _, _ -> + None end in sizeof_rec 0 [] members let sizeof_struct env members ma = match sizeof_layout_struct env members ma with | None -> None - | Some(sz, offsets) -> Some sz + | Some(bitsize, offsets) -> Some ((bitsize + 7) / 8) (* Compute the offsets of all non-bitfield members of a struct. *) let struct_layout env attrs members = let (ma, _, _) = packing_parameters attrs in match sizeof_layout_struct env members ma with - | Some(sz, offsets) -> offsets + | Some(bitsize, offsets) -> offsets | None -> [] (* Compute the offset of a struct member *) diff --git a/cparser/PackedStructs.ml b/cparser/PackedStructs.ml index 6bea4b92..f3a45785 100644 --- a/cparser/PackedStructs.ml +++ b/cparser/PackedStructs.ml @@ -61,10 +61,10 @@ let set_alignas_attr al attrs = (* Rewriting field declarations *) let transf_field_decl mfa swapped loc env struct_id f = - if f.fld_bitfield <> None then - error loc "bitfields in packed structs not allowed"; (* Register as byte-swapped if needed *) if swapped then begin + if f.fld_bitfield <> None then + error loc "byte-swapped bit fields are not supported"; let (can_swap, must_swap) = can_byte_swap env f.fld_typ in if not can_swap then fatal_error loc "cannot byte-swap field of type '%a'" @@ -74,6 +74,8 @@ let transf_field_decl mfa swapped loc env struct_id f = end; (* Reduce alignment if requested *) if mfa = 0 then f else begin + if f.fld_bitfield <> None then + error loc "bit fields in packed structs are not supported"; let al = safe_alignof loc env f.fld_typ in { f with fld_typ = change_attributes_type env (set_alignas_attr (min mfa al)) f.fld_typ } diff --git a/cparser/Parse.ml b/cparser/Parse.ml index d88d439b..a54af0cc 100644 --- a/cparser/Parse.ml +++ b/cparser/Parse.ml @@ -28,7 +28,6 @@ let transform_program t p = p in p - |> run_pass Bitfields.program 'f' |> run_pass Unblock.program 'b' |> run_pass PackedStructs.program 'p' |> run_pass StructPassing.program 's' @@ -40,7 +39,6 @@ let parse_transformations s = String.iter (function 'b' -> set "b" | 's' -> set "s" - | 'f' -> set "bf" | 'p' -> set "bp" | _ -> ()) s; diff --git a/driver/Clflags.ml b/driver/Clflags.ml index bcbf0668..db67142e 100644 --- a/driver/Clflags.ml +++ b/driver/Clflags.ml @@ -17,7 +17,6 @@ let linker_options = ref ([]: string list) let assembler_options = ref ([]: string list) let option_flongdouble = ref (Configuration.arch = "kvx") let option_fstruct_passing = ref false -let option_fbitfields = ref false let option_fvararg_calls = ref true let option_funprototyped = ref true let option_fpacked_structs = ref false diff --git a/driver/CommonOptions.ml b/driver/CommonOptions.ml index a816dd41..9da1e533 100644 --- a/driver/CommonOptions.ml +++ b/driver/CommonOptions.ml @@ -32,7 +32,7 @@ let version_options tool_name = (* Language support options *) let all_language_support_options = [ - option_fbitfields; option_flongdouble; + option_flongdouble; option_fstruct_passing; option_fvararg_calls; option_funprototyped; option_fpacked_structs; option_finline_asm ] @@ -44,11 +44,11 @@ let unset_all opts () = List.iter (fun r -> r := false) opts let language_support_options = [ Exact "-fall", Unit (set_all all_language_support_options); - Exact "-fnone", Unit (unset_all all_language_support_options);] + Exact "-fnone", Unit (unset_all all_language_support_options); + Exact "-fbitfields", Unit (fun () -> ()); ] @ f_opt "longdouble" option_flongdouble @ f_opt "struct-return" option_fstruct_passing @ f_opt "struct-passing" option_fstruct_passing - @ f_opt "bitfields" option_fbitfields @ f_opt "vararg-calls" option_fvararg_calls @ f_opt "unprototyped" option_funprototyped @ f_opt "packed-structs" option_fpacked_structs @@ -56,7 +56,6 @@ let language_support_options = let language_support_help = {|Language support options (use -fno-<opt> to turn off -f<opt>) : - -fbitfields Emulate bit fields in structs [off] -flongdouble Treat 'long double' as 'double' [off] -fstruct-passing Support passing structs and unions by value as function results or function arguments [off] @@ -67,6 +66,7 @@ let language_support_help = -finline-asm Support inline 'asm' statements [off] -fall Activate all language support options above -fnone Turn off all language support options above + -fbitfields Ignored (bit fields are now implemented natively) |} (* General options *) diff --git a/driver/Frontend.ml b/driver/Frontend.ml index 480932df..ecf3d6a5 100644 --- a/driver/Frontend.ml +++ b/driver/Frontend.ml @@ -80,7 +80,6 @@ let parse_c_file sourcename ifile = let simplifs = "b" (* blocks: mandatory *) ^ (if !option_fstruct_passing then "s" else "") - ^ (if !option_fbitfields then "f" else "") ^ (if !option_fpacked_structs then "p" else "") in (* Parsing and production of a simplified C AST *) diff --git a/exportclight/ExportClight.ml b/exportclight/ExportClight.ml index 474a1bd8..742b3a5c 100644 --- a/exportclight/ExportClight.ml +++ b/exportclight/ExportClight.ml @@ -90,23 +90,22 @@ let coqstring p s = exception Not_an_identifier +let sanitize_char = function + | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' as c -> c + | ' ' | '$' -> '_' + | _ -> raise Not_an_identifier + let sanitize s = - let s' = Bytes.create (String.length s) in - for i = 0 to String.length s - 1 do - Bytes.set s' i - (match String.get s i with - | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' as c -> c - | ' ' | '$' -> '_' - | _ -> raise Not_an_identifier) - done; - Bytes.to_string s' + if s <> "" + then "_" ^ String.map sanitize_char s + else "empty_ident" let temp_names : (ident, string) Hashtbl.t = Hashtbl.create 17 let ident p id = try let s = Hashtbl.find string_of_atom id in - fprintf p "_%s" (sanitize s) + fprintf p "%s" (sanitize s) with Not_found | Not_an_identifier -> try let s = Hashtbl.find temp_names id in @@ -125,10 +124,10 @@ let define_idents p = (fun (id, name) -> try if !use_canonical_atoms && id = pos_of_string name then - fprintf p "Definition _%s : ident := $\"%s\".@ " + fprintf p "Definition %s : ident := $\"%s\".@ " (sanitize name) name else - fprintf p "Definition _%s : ident := %a.@ " + fprintf p "Definition %s : ident := %a.@ " (sanitize name) positive id with Not_an_identifier -> ()); @@ -161,6 +160,22 @@ let attribute p a = a.attr_volatile (print_option coqN) a.attr_alignas +(* Raw int size and signedness *) + +let intsize p sz = + fprintf p "%s" + (match sz with + | I8 -> "I8" + | I16 -> "I16" + | I32 -> "I32" + | IBool -> "IBool") + +let signedness p sg = + fprintf p "%s" + (match sg with + | Signed -> "Signed" + | Unsigned -> "Unsigned") + (* Types *) let rec typ p t = @@ -399,7 +414,7 @@ and lblstmts p = function (print_option coqZ) lbl stmt s lblstmts ls let print_function p (id, f) = - fprintf p "Definition f_%s := {|@ " (sanitize (extern_atom id)); + fprintf p "Definition f%s := {|@ " (sanitize (extern_atom id)); fprintf p " fn_return := %a;@ " typ f.fn_return; fprintf p " fn_callconv := %a;@ " callconv f.fn_callconv; fprintf p " fn_params := %a;@ " (print_list (print_pair ident typ)) f.fn_params; @@ -420,7 +435,7 @@ let init_data p = function | Init_addrof(id,ofs) -> fprintf p "Init_addrof %a %a" ident id coqptrofs ofs let print_variable p (id, v) = - fprintf p "Definition v_%s := {|@ " (sanitize (extern_atom id)); + fprintf p "Definition v%s := {|@ " (sanitize (extern_atom id)); fprintf p " gvar_info := %a;@ " typ v.gvar_info; fprintf p " gvar_init := %a;@ " (print_list init_data) v.gvar_init; fprintf p " gvar_readonly := %B;@ " v.gvar_readonly; @@ -435,20 +450,33 @@ let print_globdef p (id, gd) = let print_ident_globdef p = function | (id, Gfun(Ctypes.Internal f)) -> - fprintf p "(%a, Gfun(Internal f_%s))" ident id (sanitize (extern_atom id)) + fprintf p "(%a, Gfun(Internal f%s))" ident id (sanitize (extern_atom id)) | (id, Gfun(Ctypes.External(ef, targs, tres, cc))) -> fprintf p "@[<hov 2>(%a,@ @[<hov 2>Gfun(External %a@ %a@ %a@ %a))@]@]" ident id external_function ef typlist targs typ tres callconv cc | (id, Gvar v) -> - fprintf p "(%a, Gvar v_%s)" ident id (sanitize (extern_atom id)) + fprintf p "(%a, Gvar v%s)" ident id (sanitize (extern_atom id)) (* Composite definitions *) +let print_member p = function + | Member_plain (id, ty) -> + fprintf p "@[<hov 2>Member_plain@ %a@ %a@]" + ident id typ ty + | Member_bitfield (id, sz, sg, a, width, pad) -> + fprintf p "@[<hov 2>Member_bitfield@ %a@ %a@ %a@ %a@ %a@ %B@]" + ident id + intsize sz + signedness sg + attribute a + coqZ width + pad + let print_composite_definition p (Composite(id, su, m, a)) = fprintf p "@[<hv 2>Composite %a %s@ %a@ %a@]" ident id (match su with Struct -> "Struct" | Union -> "Union") - (print_list (print_pair ident typ)) m + (print_list print_member) m attribute a (* The prologue *) diff --git a/flocq/Core/Raux.v b/flocq/Core/Raux.v index 455190dc..221d84d6 100644 --- a/flocq/Core/Raux.v +++ b/flocq/Core/Raux.v @@ -18,7 +18,7 @@ COPYING file for more details. *) (** * Missing definitions/lemmas *) -Require Export Psatz. +Require Import Psatz. Require Export Reals ZArith. Require Export Zaux. @@ -1277,7 +1277,7 @@ Theorem Zfloor_div : Zfloor (IZR x / IZR y) = (x / y)%Z. Proof. intros x y Zy. -generalize (Z_div_mod_eq_full x y Zy). +generalize (Z.div_mod x y Zy). intros Hx. rewrite Hx at 1. assert (Zy': IZR y <> 0%R). diff --git a/flocq/Core/Zaux.v b/flocq/Core/Zaux.v index b40b0c4f..5ca3971f 100644 --- a/flocq/Core/Zaux.v +++ b/flocq/Core/Zaux.v @@ -327,18 +327,10 @@ Theorem Zmod_mod_mult : forall n a b, (0 < a)%Z -> (0 <= b)%Z -> Zmod (Zmod n (a * b)) b = Zmod n b. Proof. -intros n a [|b|b] Ha Hb. -now rewrite 2!Zmod_0_r. -rewrite (Zmod_eq n (a * Zpos b)). -rewrite Zmult_assoc. -unfold Zminus. -rewrite Zopp_mult_distr_l. -apply Z_mod_plus. -easy. -apply Zmult_gt_0_compat. -now apply Z.lt_gt. -easy. -now elim Hb. + intros n a b Ha Hb. destruct (Zle_lt_or_eq _ _ Hb) as [H'b|H'b]. + - rewrite (Z.mul_comm a b), Z.rem_mul_r, Z.add_mod, Z.mul_mod, Z.mod_same, + Z.mul_0_l, Z.mod_0_l, Z.add_0_r, !Z.mod_mod; lia. + - subst. now rewrite Z.mul_0_r, !Zmod_0_r. Qed. Theorem ZOmod_eq : @@ -370,24 +362,14 @@ Theorem Zdiv_mod_mult : (Z.div (Zmod n (a * b)) a) = Zmod (Z.div n a) b. Proof. intros n a b Ha Hb. -destruct (Zle_lt_or_eq _ _ Ha) as [Ha'|Ha']. -destruct (Zle_lt_or_eq _ _ Hb) as [Hb'|Hb']. -rewrite (Zmod_eq n (a * b)). -rewrite (Zmult_comm a b) at 2. -rewrite Zmult_assoc. -unfold Zminus. -rewrite Zopp_mult_distr_l. -rewrite Z_div_plus by now apply Z.lt_gt. -rewrite <- Zdiv_Zdiv by easy. -apply sym_eq. -apply Zmod_eq. -now apply Z.lt_gt. -now apply Zmult_gt_0_compat ; apply Z.lt_gt. -rewrite <- Hb'. -rewrite Zmult_0_r, 2!Zmod_0_r. -apply Zdiv_0_l. -rewrite <- Ha'. -now rewrite 2!Zdiv_0_r, Zmod_0_l. +destruct (Zle_lt_or_eq _ _ Ha) as [Ha'|<-]. +- destruct (Zle_lt_or_eq _ _ Hb) as [Hb'|<-]. + + rewrite Z.rem_mul_r, Z.add_comm, Z.mul_comm, Z.div_add_l by lia. + rewrite (Zdiv_small (Zmod n a)). + apply Z.add_0_r. + now apply Z.mod_pos_bound. + + now rewrite Z.mul_0_r, !Zmod_0_r, ?Zdiv_0_l. +- now rewrite Z.mul_0_l, !Zdiv_0_r, Zmod_0_l. Qed. Theorem ZOdiv_mod_mult : @@ -856,7 +838,7 @@ Definition Zfast_div_eucl (a b : Z) := | Z0 => (0, 0)%Z | Zpos a' => match b with - | Z0 => (0, 0)%Z + | Z0 => (0, (match (1 mod 0) with | 0 => 0 | _ => a end))%Z | Zpos b' => Zpos_div_eucl_aux a' b' | Zneg b' => let (q, r) := Zpos_div_eucl_aux a' b' in @@ -868,7 +850,7 @@ Definition Zfast_div_eucl (a b : Z) := end | Zneg a' => match b with - | Z0 => (0, 0)%Z + | Z0 => (0, (match (1 mod 0) with | 0 => 0 | _ => a end))%Z | Zpos b' => let (q, r) := Zpos_div_eucl_aux a' b' in match r with diff --git a/flocq/IEEE754/Binary.v b/flocq/IEEE754/Binary.v index 35d15cb3..4516f0a0 100644 --- a/flocq/IEEE754/Binary.v +++ b/flocq/IEEE754/Binary.v @@ -2472,9 +2472,9 @@ case f. now revert Hover; unfold B2R, F2R; simpl; rewrite Rmult_assoc, bpow_plus. Qed. -(** This hypothesis is needed to implement Bfrexp +(** This hypothesis is needed to implement [Bfrexp] (otherwise, we have emin > - prec - and Bfrexp cannot fit the mantissa in interval [0.5, 1)) *) + and [Bfrexp] cannot fit the mantissa in interval #[0.5, 1)#) *) Hypothesis Hemax : (3 <= emax)%Z. Definition Ffrexp_core_binary s m e := diff --git a/flocq/IEEE754/Bits.v b/flocq/IEEE754/Bits.v index 68bc541a..3c19e31b 100644 --- a/flocq/IEEE754/Bits.v +++ b/flocq/IEEE754/Bits.v @@ -163,11 +163,11 @@ Proof. intros x Hx. unfold split_bits, join_bits. rewrite Z.shiftl_mul_pow2 by now apply Zlt_le_weak. -pattern x at 4 ; rewrite Z_div_mod_eq_full with x (2^mw)%Z. +pattern x at 4 ; rewrite Z.div_mod with x (2^mw)%Z. apply (f_equal (fun v => (v + _)%Z)). rewrite Zmult_comm. apply f_equal. -pattern (x / (2^mw))%Z at 2 ; rewrite Z_div_mod_eq_full with (x / (2^mw))%Z (2^ew)%Z. +pattern (x / (2^mw))%Z at 2 ; rewrite Z.div_mod with (x / (2^mw))%Z (2^ew)%Z. apply (f_equal (fun v => (v + _)%Z)). replace (x / 2 ^ mw / 2 ^ ew)%Z with (if Zle_bool (2 ^ mw * 2 ^ ew) x then 1 else 0)%Z. case Zle_bool. diff --git a/kvx/Asmblockgenproof1.v b/kvx/Asmblockgenproof1.v index 259c4f9c..a18afec8 100644 --- a/kvx/Asmblockgenproof1.v +++ b/kvx/Asmblockgenproof1.v @@ -1521,14 +1521,14 @@ Opaque Int.eq. repeat split; intros; simpl; Simpl. assert (A: Int.ltu (Int.repr 24) Int.iwordsize = true) by auto. destruct (rs x0); auto; simpl. rewrite A; simpl. Simpl. unfold Val.shr. rewrite A. - apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity. + apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. compute; intuition congruence. - (* Ocast16signed *) econstructor; split. eapply exec_straight_two. simpl;eauto. simpl;eauto. repeat split; intros; Simpl. assert (A: Int.ltu (Int.repr 16) Int.iwordsize = true) by auto. destruct (rs x0); auto; simpl. rewrite A; simpl. Simpl. unfold Val.shr. rewrite A. - apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity. + apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. compute; intuition congruence. - (* Oshrximm *) econstructor; split. + apply exec_straight_one. simpl. eauto. diff --git a/lib/Coqlib.v b/lib/Coqlib.v index eda3862f..19c641e3 100644 --- a/lib/Coqlib.v +++ b/lib/Coqlib.v @@ -25,8 +25,6 @@ Require Export List. Require Export Bool. Require Export Lia. -Global Set Asymmetric Patterns. - (** * Useful tactics *) Ltac inv H := inversion H; clear H; subst. @@ -525,6 +523,60 @@ Proof. intros. unfold align. apply Z.divide_factor_r. Qed. +Lemma align_lt: forall x y, y > 0 -> align x y < x + y. +Proof. + intros. unfold align. + generalize (Z_div_mod_eq (x + y - 1) y H); intro. + generalize (Z_mod_lt (x + y - 1) y H); intro. + lia. +Qed. + +Lemma align_same: + forall x y, y > 0 -> (y | x) -> align x y = x. +Proof. + unfold align; intros. destruct H0 as [k E]. + replace (x + y - 1) with (x + (y - 1)) by lia. + rewrite E, Z.div_add_l, Z.div_small by lia. + lia. +Qed. + +(** Floor: [floor n amount] returns the greatest multiple of [amount] + less than or equal to [n]. *) + +Definition floor (n: Z) (amount: Z) := (n / amount) * amount. + +Lemma floor_interval: + forall x y, y > 0 -> floor x y <= x < floor x y + y. +Proof. + unfold floor; intros. + generalize (Z_div_mod_eq x y H) (Z_mod_lt x y H). + set (q := x / y). set (r := x mod y). intros. lia. +Qed. + +Lemma floor_divides: + forall x y, y > 0 -> (y | floor x y). +Proof. + unfold floor; intros. exists (x / y); auto. +Qed. + +Lemma floor_same: + forall x y, y > 0 -> (y | x) -> floor x y = x. +Proof. + unfold floor; intros. rewrite (Zdivide_Zdiv_eq y x) at 2; auto; lia. +Qed. + +Lemma floor_align_interval: + forall x y, y > 0 -> + floor x y <= align x y <= floor x y + y. +Proof. + unfold floor, align; intros. + replace (x / y * y + y) with ((x + 1 * y) / y * y). + assert (A: forall a b, a <= b -> a / y * y <= b / y * y). + { intros. apply Z.mul_le_mono_nonneg_r. lia. apply Z.div_le_mono; lia. } + split; apply A; lia. + rewrite Z.div_add by lia. lia. +Qed. + (** * Definitions and theorems on the data types [option], [sum] and [list] *) Set Implicit Arguments. @@ -773,6 +825,32 @@ Proof. exists (a0 :: l1); exists l2; intuition. simpl; congruence. Qed. +(** Properties of [List.app] (concatenation) *) + +Lemma list_append_injective_l: + forall (A: Type) (l1 l2 l1' l2': list A), + l1 ++ l2 = l1' ++ l2' -> List.length l1 = List.length l1' -> l1 = l1' /\ l2 = l2'. +Proof. + intros until l2'. revert l1 l1'. induction l1 as [ | a l1]; destruct l1' as [ | a' l1']; simpl; intros. +- auto. +- discriminate. +- discriminate. +- destruct (IHl1 l1'). congruence. congruence. split; congruence. +Qed. + +Lemma list_append_injective_r: + forall (A: Type) (l1 l2 l1' l2': list A), + l1 ++ l2 = l1' ++ l2' -> List.length l2 = List.length l2' -> l1 = l1' /\ l2 = l2'. +Proof. + intros. + assert (X: rev l2 = rev l2' /\ rev l1 = rev l1'). + { apply list_append_injective_l. + rewrite <- ! rev_app_distr. congruence. + rewrite ! rev_length; auto. } + rewrite <- (rev_involutive l1), <- (rev_involutive l1'), <- (rev_involutive l2), <- (rev_involutive l2'). + intuition congruence. +Qed. + (** Folding a function over a list *) Section LIST_FOLD. diff --git a/lib/Floats.v b/lib/Floats.v index b10b3392..9ee5302d 100644 --- a/lib/Floats.v +++ b/lib/Floats.v @@ -26,6 +26,7 @@ Import ListNotations. Close Scope R_scope. Open Scope Z_scope. +Set Asymmetric Patterns. Definition float := binary64. (**r the type of IEE754 double-precision FP numbers *) diff --git a/lib/Integers.v b/lib/Integers.v index 2addc78b..b6c41d8d 100644 --- a/lib/Integers.v +++ b/lib/Integers.v @@ -2851,7 +2851,7 @@ Qed. Corollary sign_ext_shr_shl: forall n x, - 0 < n < zwordsize -> + 0 < n <= zwordsize -> let y := repr (zwordsize - n) in sign_ext n x = shr (shl x y) y. Proof. @@ -2886,7 +2886,7 @@ Qed. Lemma sign_ext_range: forall n x, 0 < n < zwordsize -> -two_p (n-1) <= signed (sign_ext n x) < two_p (n-1). Proof. - intros. rewrite sign_ext_shr_shl; auto. + intros. rewrite sign_ext_shr_shl by lia. set (X := shl x (repr (zwordsize - n))). assert (two_p (n - 1) > 0) by (apply two_p_gt_ZERO; lia). assert (unsigned (repr (zwordsize - n)) = zwordsize - n). @@ -3474,6 +3474,118 @@ Proof. lia. Qed. +(** ** Accessing bit fields *) + +Definition unsigned_bitfield_extract (pos width: Z) (n: int) : int := + zero_ext width (shru n (repr pos)). + +Definition signed_bitfield_extract (pos width: Z) (n: int) : int := + sign_ext width (shru n (repr pos)). + +Definition bitfield_insert (pos width: Z) (n p: int) : int := + let mask := shl (repr (two_p width - 1)) (repr pos) in + or (shl (zero_ext width p) (repr pos)) + (and n (not mask)). + +Lemma bits_unsigned_bitfield_extract: + forall pos width n i, + 0 <= pos -> 0 < width -> pos + width <= zwordsize -> + 0 <= i < zwordsize -> + testbit (unsigned_bitfield_extract pos width n) i = + if zlt i width then testbit n (i + pos) else false. +Proof. + intros. unfold unsigned_bitfield_extract. rewrite bits_zero_ext by lia. + destruct (zlt i width); auto. + rewrite bits_shru by auto. rewrite unsigned_repr, zlt_true. auto. + lia. + generalize wordsize_max_unsigned; lia. +Qed. + +Lemma bits_signed_bitfield_extract: + forall pos width n i, + 0 <= pos -> 0 < width -> pos + width <= zwordsize -> + 0 <= i < zwordsize -> + testbit (signed_bitfield_extract pos width n) i = + testbit n (if zlt i width then i + pos else width - 1 + pos). +Proof. + intros. unfold signed_bitfield_extract. rewrite bits_sign_ext by lia. + rewrite bits_shru, unsigned_repr, zlt_true. + destruct (zlt i width); auto. + destruct (zlt i width); lia. + generalize wordsize_max_unsigned; lia. + destruct (zlt i width); lia. +Qed. + +Lemma bits_bitfield_insert: + forall pos width n p i, + 0 <= pos -> 0 < width -> pos + width <= zwordsize -> + 0 <= i < zwordsize -> + testbit (bitfield_insert pos width n p) i = + if zle pos i && zlt i (pos + width) then testbit p (i - pos) else testbit n i. +Proof. + intros. unfold bitfield_insert. + assert (P: unsigned (repr pos) = pos). + { apply unsigned_repr. generalize wordsize_max_unsigned; lia. } + rewrite bits_or, bits_and, bits_not, ! bits_shl, ! P by auto. + destruct (zlt i pos). +- unfold proj_sumbool; rewrite zle_false by lia. cbn. apply andb_true_r. +- unfold proj_sumbool; rewrite zle_true by lia; cbn. + rewrite bits_zero_ext, testbit_repr, Ztestbit_two_p_m1 by lia. + destruct (zlt (i - pos) width); cbn. ++ rewrite zlt_true by lia. rewrite andb_false_r, orb_false_r. auto. ++ rewrite zlt_false by lia. apply andb_true_r. +Qed. + +Lemma unsigned_bitfield_extract_by_shifts: + forall pos width n, + 0 <= pos -> 0 < width -> pos + width <= zwordsize -> + unsigned_bitfield_extract pos width n = + shru (shl n (repr (zwordsize - pos - width))) (repr (zwordsize - width)). +Proof. + intros. apply same_bits_eq; intros. + rewrite bits_unsigned_bitfield_extract by lia. + rewrite bits_shru by auto. + rewrite unsigned_repr by (generalize wordsize_max_unsigned; lia). + destruct (zlt i width). +- rewrite bits_shl by lia. + rewrite unsigned_repr by (generalize wordsize_max_unsigned; lia). + rewrite zlt_true by lia. rewrite zlt_false by lia. f_equal; lia. +- rewrite zlt_false by lia. auto. +Qed. + +Lemma signed_bitfield_extract_by_shifts: + forall pos width n, + 0 <= pos -> 0 < width -> pos + width <= zwordsize -> + signed_bitfield_extract pos width n = + shr (shl n (repr (zwordsize - pos - width))) (repr (zwordsize - width)). +Proof. + intros. apply same_bits_eq; intros. + rewrite bits_signed_bitfield_extract by lia. + rewrite bits_shr by auto. + rewrite unsigned_repr by (generalize wordsize_max_unsigned; lia). + rewrite bits_shl. + rewrite unsigned_repr by (generalize wordsize_max_unsigned; lia). + symmetry. rewrite zlt_false. f_equal. + destruct (zlt i width); [rewrite zlt_true | rewrite zlt_false]; lia. + destruct zlt; lia. + destruct zlt; lia. +Qed. + +Lemma bitfield_insert_alternative: + forall pos width n p, + 0 <= width -> + bitfield_insert pos width n p = + let mask := shl (repr (two_p width - 1)) (repr pos) in + or (and (shl p (repr pos)) mask) + (and n (not mask)). +Proof. + intros. unfold bitfield_insert. + set (m1 := repr (two_p width - 1)). + set (m2 := shl m1 (repr pos)). + f_equal. + rewrite zero_ext_and by lia. fold m1. unfold m2. rewrite <- and_shl. auto. +Qed. + End Make. (** * Specialization to integers of size 8, 32, and 64 bits *) diff --git a/lib/Iteration.v b/lib/Iteration.v index 82110bff..66bb3970 100644 --- a/lib/Iteration.v +++ b/lib/Iteration.v @@ -20,6 +20,8 @@ Require Import Axioms. Require Import Coqlib. Require Import Wfsimpl. +Set Asymmetric Patterns. + (** This modules defines several Coq encodings of a general "while" loop. The loop is presented in functional style as the iteration of a [step] function of type [A -> B + A]: diff --git a/lib/UnionFind.v b/lib/UnionFind.v index ee24a9a7..1c37a35b 100644 --- a/lib/UnionFind.v +++ b/lib/UnionFind.v @@ -21,6 +21,7 @@ Require Import Coqlib. Open Scope nat_scope. Set Implicit Arguments. +Set Asymmetric Patterns. (* To avoid useless definitions of inductors in extracted code. *) Local Unset Elimination Schemes. diff --git a/powerpc/Asmexpand.ml b/powerpc/Asmexpand.ml index e663226f..45b3f708 100644 --- a/powerpc/Asmexpand.ml +++ b/powerpc/Asmexpand.ml @@ -58,6 +58,20 @@ let emit_loadimm r n = let emit_addimm rd rs n = List.iter emit (Asmgen.addimm rd rs n []) +let emit_aindexed mk1 mk2 unaligned r1 temp ofs = + List.iter emit (Asmgen.aindexed mk1 mk2 unaligned r1 temp ofs []) + +let emit_aindexed2 mk r1 r2 = + List.iter emit (Asmgen.aindexed2 mk r1 r2 []) + +let emit_aglobal mk1 mk2 unaligned temp symb ofs = + List.iter emit (Asmgen.aglobal mk1 mk2 unaligned temp symb ofs []) + +let emit_abased mk1 mk2 unaligned r1 temp symb ofs = + List.iter emit (Asmgen.abased mk1 mk2 unaligned r1 temp symb ofs []) + +let emit_ainstack mk1 mk2 unaligned temp ofs = + List.iter emit (Asmgen.ainstack mk1 mk2 unaligned temp ofs []) (* Numbering of bits in the CR register *) let num_crbit = function @@ -104,8 +118,8 @@ let memcpy_small_arg sz arg tmp = assert false let expand_builtin_memcpy_small sz al src dst = - let (tsrc, tdst) = - if dst <> BA (IR GPR11) then (GPR11, GPR12) else (GPR12, GPR11) in + let tsrc = if dst <> BA (IR GPR11) then GPR11 else GPR12 in + let tdst = if dst <> BA (IR GPR12) then GPR12 else GPR11 in let (rsrc, osrc) = memcpy_small_arg sz src tsrc in let (rdst, odst) = memcpy_small_arg sz dst tdst in let rec copy osrc odst sz = @@ -175,79 +189,23 @@ let expand_builtin_memcpy sz al args = (* Handling of volatile reads and writes *) let expand_volatile_access - (mk1: ireg -> constant -> unit) - (mk2: ireg -> ireg -> unit) + (mk1: constant -> ireg -> instruction list -> instruction list) + (mk2: ireg -> ireg -> instruction list -> instruction list) ?(ofs_unaligned = true) addr temp = match addr with | BA(IR r) -> - mk1 r (Cint _0) + List.iter emit (mk1 (Cint _0) r []) | BA_addrstack ofs -> - if ofs_unaligned || Int.eq (Int.mods ofs _4) _0 then - if offset_in_range ofs then - mk1 GPR1 (Cint ofs) - else begin - emit (Paddis(temp, GPR1, Cint (Asmgen.high_s ofs))); - mk1 temp (Cint (Asmgen.low_s ofs)) - end - else begin - emit (Paddis (temp, GPR1, Cint (Asmgen.high_s ofs))); - emit (Paddi (temp, temp, Cint (Asmgen.low_s ofs))); - mk1 temp (Cint _0) - end + emit_ainstack mk1 mk2 ofs_unaligned temp ofs | BA_addrglobal(id, ofs) -> - if symbol_is_small_data id ofs then - if ofs_unaligned || Asmgen.symbol_ofs_word_aligned id ofs then - mk1 GPR0 (Csymbol_sda(id, ofs)) - else begin - emit (Paddi (temp, GPR0, (Csymbol_sda (id,ofs)))); - mk1 temp (Cint _0) - end - else if symbol_is_rel_data id ofs then begin - emit (Paddis(temp, GPR0, Csymbol_rel_high(id, ofs))); - emit (Paddi(temp, temp, Csymbol_rel_low(id, ofs))); - mk1 temp (Cint _0) - end else if ofs_unaligned || Asmgen.symbol_ofs_word_aligned id ofs then begin - emit (Paddis(temp, GPR0, Csymbol_high(id, ofs))); - mk1 temp (Csymbol_low(id, ofs)) - end else begin - emit (Paddis (temp, GPR0, (Csymbol_high (id, ofs)))); - emit (Paddi (temp, temp, (Csymbol_low (id, ofs)))); - mk1 temp (Cint _0) - end + emit_aglobal mk1 mk2 ofs_unaligned temp id ofs | BA_addptr(BA(IR r), BA_int n) -> - if ofs_unaligned || Int.eq (Int.mods n _4) _0 then - if offset_in_range n then - mk1 r (Cint n) - else begin - emit (Paddis(temp, r, Cint (Asmgen.high_s n))); - mk1 temp (Cint (Asmgen.low_s n)) - end - else begin - emit (Paddis (temp, r, Cint (Asmgen.high_s n))); - emit (Paddi (temp, temp, Cint (Asmgen.low_s n))); - mk1 temp (Cint _0) - end + emit_aindexed mk1 mk2 ofs_unaligned r temp n | BA_addptr(BA_addrglobal(id, ofs), BA(IR r)) -> - if symbol_is_small_data id ofs then begin - emit (Paddi(GPR0, GPR0, Csymbol_sda(id, ofs))); - mk2 r GPR0 - end else if symbol_is_rel_data id ofs then begin - emit (Pmr(GPR0, r)); - emit (Paddis(temp, GPR0, Csymbol_rel_high(id, ofs))); - emit (Paddi(temp, temp, Csymbol_rel_low(id, ofs))); - mk2 temp GPR0 - end else if ofs_unaligned || Asmgen.symbol_ofs_word_aligned id ofs then begin - emit (Paddis(temp, r, Csymbol_high(id, ofs))); - mk1 temp (Csymbol_low(id, ofs)) - end else begin - emit (Pmr (GPR0, r)); - emit (Paddis(temp, GPR0, Csymbol_high(id, ofs))); - emit (Paddi(temp, temp, Csymbol_low(id, ofs))); - mk2 temp GPR0 - end + emit_abased mk1 mk2 ofs_unaligned r temp id ofs | BA_addptr(BA(IR r1), BA(IR r2)) -> - mk2 r1 r2 + emit_aindexed2 mk2 r1 r2 | _ -> assert false @@ -260,69 +218,69 @@ let offset_constant cst delta = Some (Csymbol_sda(id, Int.add ofs delta)) | _ -> None -let expand_load_int64 hi lo base ofs_hi ofs_lo = +let expand_load_int64 hi lo base ofs_hi ofs_lo k = if hi <> base then begin - emit (Plwz(hi, ofs_hi, base)); - emit (Plwz(lo, ofs_lo, base)) + Plwz(hi, ofs_hi, base) :: + Plwz(lo, ofs_lo, base) :: k end else begin - emit (Plwz(lo, ofs_lo, base)); - emit (Plwz(hi, ofs_hi, base)) + Plwz(lo, ofs_lo, base) :: + Plwz(hi, ofs_hi, base) :: k end let expand_builtin_vload_1 chunk addr res = match chunk, res with | Mint8unsigned, BR(IR res) -> expand_volatile_access - (fun r c -> emit (Plbz(res, c, r))) - (fun r1 r2 -> emit (Plbzx(res, r1, r2))) + (fun c r k -> Plbz(res, c, r) :: k) + (fun r1 r2 k -> Plbzx(res, r1, r2) :: k) addr GPR11 | Mint8signed, BR(IR res) -> expand_volatile_access - (fun r c -> emit (Plbz(res, c, r)); emit (Pextsb(res, res))) - (fun r1 r2 -> emit (Plbzx(res, r1, r2)); emit (Pextsb(res, res))) + (fun c r k-> Plbz(res, c, r) :: Pextsb(res, res) :: k) + (fun r1 r2 k -> Plbzx(res, r1, r2) :: Pextsb(res, res) :: k) addr GPR11 | Mint16unsigned, BR(IR res) -> expand_volatile_access - (fun r c -> emit (Plhz(res, c, r))) - (fun r1 r2 -> emit (Plhzx(res, r1, r2))) + (fun c r k -> Plhz(res, c, r) :: k) + (fun r1 r2 k -> Plhzx(res, r1, r2) :: k) addr GPR11 | Mint16signed, BR(IR res) -> expand_volatile_access - (fun r c -> emit (Plha(res, c, r))) - (fun r1 r2 -> emit (Plhax(res, r1, r2))) + (fun c r k-> Plha(res, c, r) :: k) + (fun r1 r2 k -> Plhax(res, r1, r2) :: k) addr GPR11 | (Mint32 | Many32), BR(IR res) -> expand_volatile_access - (fun r c -> emit (Plwz(res, c, r))) - (fun r1 r2 -> emit (Plwzx(res, r1, r2))) + (fun c r k-> Plwz(res, c, r) :: k) + (fun r1 r2 k -> Plwzx(res, r1, r2) :: k) addr GPR11 | Mfloat32, BR(FR res) -> expand_volatile_access - (fun r c -> emit (Plfs(res, c, r))) - (fun r1 r2 -> emit (Plfsx(res, r1, r2))) + (fun c r k-> Plfs(res, c, r) :: k) + (fun r1 r2 k -> Plfsx(res, r1, r2) :: k) addr GPR11 | (Mfloat64 | Many64), BR(FR res) -> expand_volatile_access - (fun r c -> emit (Plfd(res, c, r))) - (fun r1 r2 -> emit (Plfdx(res, r1, r2))) + (fun c r k-> Plfd(res, c, r) :: k) + (fun r1 r2 k -> Plfdx(res, r1, r2) :: k) addr GPR11 | (Mint64 | Many64), BR(IR res) -> expand_volatile_access - (fun r c -> emit (Pld(res, c, r))) - (fun r1 r2 -> emit (Pldx(res, r1, r2))) + (fun c r k-> Pld(res, c, r) :: k) + (fun r1 r2 k -> Pldx(res, r1, r2) :: k) ~ofs_unaligned:false addr GPR11 | Mint64, BR_splitlong(BR(IR hi), BR(IR lo)) -> expand_volatile_access - (fun r c -> + (fun c r k-> match offset_constant c _4 with - | Some c' -> expand_load_int64 hi lo r c c' + | Some c' -> expand_load_int64 hi lo r c c' k | None -> - emit (Paddi(GPR11, r, c)); - expand_load_int64 hi lo GPR11 (Cint _0) (Cint _4)) - (fun r1 r2 -> - emit (Padd(GPR11, r1, r2)); - expand_load_int64 hi lo GPR11 (Cint _0) (Cint _4)) + Paddi(GPR11, r, c) :: + expand_load_int64 hi lo GPR11 (Cint _0) (Cint _4) k) + (fun r1 r2 k -> + Padd(GPR11, r1, r2) :: + expand_load_int64 hi lo GPR11 (Cint _0) (Cint _4) k) addr GPR11 | _, _ -> assert false @@ -338,55 +296,55 @@ let temp_for_vstore src = else if not (List.mem (IR GPR12) rl) then GPR12 else GPR10 -let expand_store_int64 hi lo base ofs_hi ofs_lo = - emit (Pstw(hi, ofs_hi, base)); - emit (Pstw(lo, ofs_lo, base)) +let expand_store_int64 hi lo base ofs_hi ofs_lo k = + Pstw(hi, ofs_hi, base) :: + Pstw(lo, ofs_lo, base) :: k let expand_builtin_vstore_1 chunk addr src = let temp = temp_for_vstore src in match chunk, src with | (Mint8signed | Mint8unsigned), BA(IR src) -> expand_volatile_access - (fun r c -> emit (Pstb(src, c, r))) - (fun r1 r2 -> emit (Pstbx(src, r1, r2))) + (fun c r k-> Pstb(src, c, r) :: k) + (fun r1 r2 k -> Pstbx(src, r1, r2) :: k) addr temp | (Mint16signed | Mint16unsigned), BA(IR src) -> expand_volatile_access - (fun r c -> emit (Psth(src, c, r))) - (fun r1 r2 -> emit (Psthx(src, r1, r2))) + (fun c r k-> Psth(src, c, r) :: k) + (fun r1 r2 k -> Psthx(src, r1, r2) :: k) addr temp | (Mint32 | Many32), BA(IR src) -> expand_volatile_access - (fun r c -> emit (Pstw(src, c, r))) - (fun r1 r2 -> emit (Pstwx(src, r1, r2))) + (fun c r k-> Pstw(src, c, r) :: k) + (fun r1 r2 k -> Pstwx(src, r1, r2) :: k) addr temp | Mfloat32, BA(FR src) -> expand_volatile_access - (fun r c -> emit (Pstfs(src, c, r))) - (fun r1 r2 -> emit (Pstfsx(src, r1, r2))) + (fun c r k-> Pstfs(src, c, r) :: k) + (fun r1 r2 k -> Pstfsx(src, r1, r2) :: k) addr temp | (Mfloat64 | Many64), BA(FR src) -> expand_volatile_access - (fun r c -> emit (Pstfd(src, c, r))) - (fun r1 r2 -> emit (Pstfdx(src, r1, r2))) + (fun c r k-> Pstfd(src, c, r) :: k) + (fun r1 r2 k -> Pstfdx(src, r1, r2) :: k) addr temp | (Mint64 | Many64), BA(IR src) -> expand_volatile_access - (fun r c -> emit (Pstd(src, c, r))) - (fun r1 r2 -> emit (Pstdx(src, r1, r2))) + (fun c r k-> Pstd(src, c, r) :: k) + (fun r1 r2 k -> Pstdx(src, r1, r2) :: k) ~ofs_unaligned:false addr temp | Mint64, BA_splitlong(BA(IR hi), BA(IR lo)) -> expand_volatile_access - (fun r c -> + (fun c r k -> match offset_constant c _4 with - | Some c' -> expand_store_int64 hi lo r c c' + | Some c' -> expand_store_int64 hi lo r c c' k | None -> - emit (Paddi(temp, r, c)); - expand_store_int64 hi lo temp (Cint _0) (Cint _4)) - (fun r1 r2 -> - emit (Padd(temp, r1, r2)); - expand_store_int64 hi lo temp (Cint _0) (Cint _4)) + Paddi(temp, r, c) :: + expand_store_int64 hi lo temp (Cint _0) (Cint _4) k) + (fun r1 r2 k -> + Padd(temp, r1, r2) :: + expand_store_int64 hi lo temp (Cint _0) (Cint _4) k) addr temp | _, _ -> assert false diff --git a/powerpc/Asmgen.v b/powerpc/Asmgen.v index ec7242bb..924773e7 100644 --- a/powerpc/Asmgen.v +++ b/powerpc/Asmgen.v @@ -730,6 +730,82 @@ Definition symbol_ofs_word_aligned symb ofs := let ofs := Ptrofs.to_int ofs in symbol_is_aligned symb 4 && (Int.eq (Int.mods ofs (Int.repr 4)) Int.zero). +Definition aindexed + (mk1: constant -> ireg -> code -> code) + (mk2: ireg -> ireg -> code -> code) + (unaligned : bool) (r1 temp: ireg) (ofs: int) (k: code) := + if unaligned || Int.eq (Int.mods ofs (Int.repr 4)) Int.zero then + if Int.eq (high_s ofs) Int.zero then + mk1 (Cint ofs) r1 k + else + Paddis temp r1 (Cint (high_s ofs)) :: + mk1 (Cint (low_s ofs)) temp k + else + (loadimm GPR0 ofs (mk2 r1 GPR0 k)). + +Definition aindexed2 + (mk: ireg -> ireg -> code -> code) + (r1 r2: ireg) (k: code) := + mk r1 r2 k. + +Definition aglobal + (mk1: constant -> ireg -> code -> code) + (mk2: ireg -> ireg -> code -> code) + (unaligned : bool) (temp: ireg) + symb ofs k := + if symbol_is_small_data symb ofs then + if unaligned || symbol_ofs_word_aligned symb ofs then + mk1 (Csymbol_sda symb ofs) GPR0 k + else + Paddi temp GPR0 (Csymbol_sda symb ofs) :: + mk1 (Cint Int.zero) temp k + else if symbol_is_rel_data symb ofs then + Paddis temp GPR0 (Csymbol_rel_high symb ofs) :: + Paddi temp temp (Csymbol_rel_low symb ofs) :: + mk1 (Cint Int.zero) temp k + else if unaligned || symbol_ofs_word_aligned symb ofs then + Paddis temp GPR0 (Csymbol_high symb ofs) :: + mk1 (Csymbol_low symb ofs) temp k + else + Paddis temp GPR0 (Csymbol_high symb ofs) :: + Paddi temp temp (Csymbol_low symb ofs) :: + mk1 (Cint Int.zero) temp k. + +Definition abased + (mk1: constant -> ireg -> code -> code) + (mk2: ireg -> ireg -> code -> code) + (unaligned : bool) (r1 temp: ireg) + symb ofs k := + if symbol_is_small_data symb ofs then + Paddi GPR0 GPR0 (Csymbol_sda symb ofs) :: + mk2 r1 GPR0 k + else if symbol_is_rel_data symb ofs then + Pmr GPR0 r1 :: + Paddis temp GPR0 (Csymbol_rel_high symb ofs) :: + Paddi temp temp (Csymbol_rel_low symb ofs) :: + mk2 temp GPR0 k + else if unaligned || symbol_ofs_word_aligned symb ofs then + Paddis temp r1 (Csymbol_high symb ofs) :: + mk1 (Csymbol_low symb ofs) temp k + else + Pmr GPR0 r1 :: + Paddis temp GPR0 (Csymbol_high symb ofs) :: + Paddi temp temp (Csymbol_low symb ofs) :: + mk2 temp GPR0 k. + +Definition ainstack + (mk1 : constant -> ireg -> code -> code) + (mk2 : ireg -> ireg -> code -> code) + (unaligned : bool) (temp: ireg) ofs k := + if unaligned || Int.eq (Int.mods ofs (Int.repr 4)) Int.zero then + if Int.eq (high_s ofs) Int.zero then + mk1 (Cint ofs) GPR1 k + else + Paddis temp GPR1 (Cint (high_s ofs)) :: + mk1 (Cint (low_s ofs)) temp k + else + addimm temp GPR1 ofs (mk1 (Cint Int.zero) temp k). + Definition transl_memory_access (mk1: constant -> ireg -> instruction) (mk2: ireg -> ireg -> instruction) @@ -739,63 +815,18 @@ Definition transl_memory_access match addr, args with | Aindexed ofs, a1 :: nil => do r1 <- ireg_of a1; - OK (if unaligned || Int.eq (Int.mods ofs (Int.repr 4)) Int.zero then - if Int.eq (high_s ofs) Int.zero then - mk1 (Cint ofs) r1 :: k - else - Paddis temp r1 (Cint (high_s ofs)) :: - mk1 (Cint (low_s ofs)) temp :: k - else - (loadimm GPR0 ofs (mk2 r1 GPR0 :: k))) + OK (aindexed (fun c r k => mk1 c r :: k) (fun r1 r2 k => mk2 r1 r2 :: k) unaligned r1 temp ofs k) | Aindexed2, a1 :: a2 :: nil => do r1 <- ireg_of a1; do r2 <- ireg_of a2; - OK (mk2 r1 r2 :: k) + OK (aindexed2 (fun r1 r2 k => mk2 r1 r2 :: k) r1 r2 k) | Aglobal symb ofs, nil => - OK (if symbol_is_small_data symb ofs then - if unaligned || symbol_ofs_word_aligned symb ofs then - mk1 (Csymbol_sda symb ofs) GPR0 :: k - else - Paddi temp GPR0 (Csymbol_sda symb ofs) :: - mk1 (Cint Int.zero) temp :: k - else if symbol_is_rel_data symb ofs then - Paddis temp GPR0 (Csymbol_rel_high symb ofs) :: - Paddi temp temp (Csymbol_rel_low symb ofs) :: - mk1 (Cint Int.zero) temp :: k - else if unaligned || symbol_ofs_word_aligned symb ofs then - Paddis temp GPR0 (Csymbol_high symb ofs) :: - mk1 (Csymbol_low symb ofs) temp :: k - else - Paddis temp GPR0 (Csymbol_high symb ofs) :: - Paddi temp temp (Csymbol_low symb ofs) :: - mk1 (Cint Int.zero) temp :: k) + OK (aglobal (fun c r k => mk1 c r :: k) (fun r1 r2 k => mk2 r1 r2 :: k) unaligned temp symb ofs k) | Abased symb ofs, a1 :: nil => do r1 <- ireg_of a1; - OK (if symbol_is_small_data symb ofs then - Paddi GPR0 GPR0 (Csymbol_sda symb ofs) :: - mk2 r1 GPR0 :: k - else if symbol_is_rel_data symb ofs then - Pmr GPR0 r1 :: - Paddis temp GPR0 (Csymbol_rel_high symb ofs) :: - Paddi temp temp (Csymbol_rel_low symb ofs) :: - mk2 temp GPR0 :: k - else if unaligned || symbol_ofs_word_aligned symb ofs then - Paddis temp r1 (Csymbol_high symb ofs) :: - mk1 (Csymbol_low symb ofs) temp :: k - else - Pmr GPR0 r1 :: - Paddis temp GPR0 (Csymbol_high symb ofs) :: - Paddi temp temp (Csymbol_low symb ofs) :: - mk2 temp GPR0 :: k) + OK (abased (fun c r k => mk1 c r :: k) (fun r1 r2 k => mk2 r1 r2 :: k) unaligned r1 temp symb ofs k) | Ainstack ofs, nil => let ofs := Ptrofs.to_int ofs in - OK (if unaligned || Int.eq (Int.mods ofs (Int.repr 4)) Int.zero then - if Int.eq (high_s ofs) Int.zero then - mk1 (Cint ofs) GPR1 :: k - else - Paddis temp GPR1 (Cint (high_s ofs)) :: - mk1 (Cint (low_s ofs)) temp :: k - else - addimm temp GPR1 ofs (mk1 (Cint Int.zero) temp :: k)) + OK (ainstack (fun c r k => mk1 c r :: k) (fun r1 r2 k => mk2 r1 r2 :: k) unaligned temp ofs k) | _, _ => Error(msg "Asmgen.transl_memory_access") end. diff --git a/powerpc/Asmgenproof.v b/powerpc/Asmgenproof.v index e30ca9ed..e25ae583 100644 --- a/powerpc/Asmgenproof.v +++ b/powerpc/Asmgenproof.v @@ -310,7 +310,7 @@ Remark transl_memory_access_label: (forall r1 r2, nolabel (mk2 r1 r2)) -> tail_nolabel k c. Proof. - unfold transl_memory_access; intros; destruct addr; TailNoLabel. + unfold transl_memory_access, aindexed, aindexed2, aglobal, abased, ainstack; intros; destruct addr; TailNoLabel. destruct (unaligned || Int.eq (Int.mods i (Int.repr 4)) Int.zero). destruct (Int.eq (high_s i) Int.zero); TailNoLabel. eapply tail_nolabel_trans. apply loadimm_label. TailNoLabel. destruct (symbol_is_small_data i i0). destruct (unaligned || symbol_ofs_word_aligned i i0); TailNoLabel. destruct (symbol_is_rel_data i i0); TailNoLabel. diff --git a/powerpc/Asmgenproof1.v b/powerpc/Asmgenproof1.v index 7b0c6266..cc9fc1a7 100644 --- a/powerpc/Asmgenproof1.v +++ b/powerpc/Asmgenproof1.v @@ -1564,6 +1564,7 @@ Proof. intros until m'; intros TR ADDR TEMP MK1 MK2. unfold transl_memory_access in TR; destruct addr; ArgsInv; simpl in ADDR; inv ADDR. - (* Aindexed *) + unfold aindexed. destruct (unaligned || Int.eq (Int.mods i (Int.repr 4)) Int.zero); [destruct (Int.eq (high_s i) Int.zero) |]. + (* Aindexed 4 aligned short *) apply MK1. rewrite gpr_or_zero_not_zero; eauto with asmgen. auto. @@ -1590,6 +1591,7 @@ Proof. - (* Aindexed2 *) apply MK2. rewrite gpr_or_zero_not_zero; eauto with asmgen. auto. - (* Aglobal *) + unfold aglobal in *. destruct (symbol_is_small_data i i0) eqn:SISD; [ | destruct (symbol_is_rel_data i i0) ]; inv TR. + (* Aglobal from small data 4 aligned *) case (unaligned || symbol_ofs_word_aligned i i0). @@ -1643,7 +1645,8 @@ Proof. apply exec_straight_step with rs2 m; auto. simpl. unfold rs2. rewrite gpr_or_zero_not_zero; auto. f_equal. f_equal. f_equal. unfold rs1; Simpl. apply low_high_half_zero. eexact EX'. auto. - -(* Abased *) + - (* Abased *) + unfold abased in *. destruct (symbol_is_small_data i i0) eqn:SISD; [ | destruct (symbol_is_rel_data i i0) ]. + (* Abased from small data *) set (rs1 := nextinstr (rs#GPR0 <- (Genv.symbol_address ge i i0))). @@ -1700,6 +1703,7 @@ Proof. unfold rs2; Simpl. apply low_high_half_zero. eexact EX'. auto. - (* Ainstack *) + unfold ainstack in *. set (ofs := Ptrofs.to_int i) in *. assert (L: Val.lessdef (Val.offset_ptr (rs GPR1) i) (Val.add (rs GPR1) (Vint ofs))). { destruct (rs GPR1); simpl; auto. unfold ofs; rewrite Ptrofs.of_int_to_int; auto. } diff --git a/powerpc/Builtins1.v b/powerpc/Builtins1.v index b3fdebd0..f212f141 100644 --- a/powerpc/Builtins1.v +++ b/powerpc/Builtins1.v @@ -47,22 +47,35 @@ Definition platform_builtin_table : list (string * platform_builtin) := Definition platform_builtin_sig (b: platform_builtin) : signature := match b with - | BI_isel | BI_uisel | BI_bsel => + | BI_isel | BI_uisel => mksignature (Tint :: Tint :: Tint :: nil) Tint cc_default | BI_isel64 | BI_uisel64 => mksignature (Tint :: Tlong :: Tlong :: nil) Tlong cc_default + | BI_bsel => + mksignature (Tint :: Tint :: Tint :: nil) Tint8unsigned cc_default | BI_mulhw | BI_mulhwu => mksignature (Tint :: Tint :: nil) Tint cc_default | BI_mulhd | BI_mulhdu => mksignature (Tlong :: Tlong :: nil) Tlong cc_default end. +Definition isel {A: Type} (c: int) (n1 n2: A) : A := + if Int.eq c Int.zero then n2 else n1. + +Program Definition bsel (c n1 n2: int) : { n : int | n = Int.zero_ext 8 n } := + Int.zero_ext 8 (isel c n1 n2). +Next Obligation. + symmetry. apply Int.zero_ext_idem. lia. +Qed. + Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (sig_res (platform_builtin_sig b)) := match b with - | BI_isel | BI_uisel | BI_bsel => - mkbuiltin_n3t Tint Tint Tint Tint (fun c n1 n2 => if Int.eq c Int.zero then n2 else n1) + | BI_isel | BI_uisel => + mkbuiltin_n3t Tint Tint Tint Tint isel | BI_isel64 | BI_uisel64 => - mkbuiltin_n3t Tint Tlong Tlong Tlong (fun c n1 n2 => if Int.eq c Int.zero then n2 else n1) + mkbuiltin_n3t Tint Tlong Tlong Tlong isel + | BI_bsel => + mkbuiltin_n3t Tint Tint Tint Tint8unsigned bsel | BI_mulhw => mkbuiltin_n2t Tint Tint Tint Int.mulhs | BI_mulhwu => diff --git a/riscV/Asmexpand.ml b/riscV/Asmexpand.ml index 50dc20be..329dd34c 100644 --- a/riscV/Asmexpand.ml +++ b/riscV/Asmexpand.ml @@ -170,8 +170,8 @@ let memcpy_small_arg sz arg tmp = assert false let expand_builtin_memcpy_small sz al src dst = - let (tsrc, tdst) = - if dst <> BA (IR X5) then (X5, X6) else (X6, X5) in + let tsrc = if dst <> BA (IR X5) then X5 else X6 in + let tdst = if src <> BA (IR X6) then X6 else X5 in let (rsrc, osrc) = memcpy_small_arg sz src tsrc in let (rdst, odst) = memcpy_small_arg sz dst tdst in let rec copy osrc odst sz = diff --git a/riscV/Asmgenproof1.v b/riscV/Asmgenproof1.v index 42ab8375..89a48aee 100644 --- a/riscV/Asmgenproof1.v +++ b/riscV/Asmgenproof1.v @@ -1147,14 +1147,14 @@ Opaque Int.eq. split; intros; Simpl. assert (A: Int.ltu (Int.repr 24) Int.iwordsize = true) by auto. destruct (rs x0); auto; simpl. rewrite A; simpl. rewrite A. - apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity. } + apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. compute; intuition congruence. } (* cast16signed *) { econstructor; split. eapply exec_straight_two. simpl;eauto. simpl;eauto. auto. auto. split; intros; Simpl. assert (A: Int.ltu (Int.repr 16) Int.iwordsize = true) by auto. destruct (rs x0); auto; simpl. rewrite A; simpl. rewrite A. - apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity. } + apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. compute; intuition congruence. } (* addimm *) { exploit (opimm32_correct Paddw Paddiw Val.add); auto. instantiate (1 := x0); eauto with asmgen. intros (rs' & A & B & C). diff --git a/test/abi/.gitignore b/test/abi/.gitignore index c115947e..5aa03c7c 100644 --- a/test/abi/.gitignore +++ b/test/abi/.gitignore @@ -2,7 +2,10 @@ *.c *.h *.compcert +*.cc *.cc2compcert *.compcert2cc *.light.c *.s +!layout.c +!staticlayout.c diff --git a/test/abi/Makefile b/test/abi/Makefile index eb9ca292..ef354e06 100644 --- a/test/abi/Makefile +++ b/test/abi/Makefile @@ -8,7 +8,10 @@ TESTS=fixed.compcert fixed.cc2compcert fixed.compcert2cc \ vararg.compcert vararg.cc2compcert vararg.compcert2cc \ struct.compcert struct.cc2compcert struct.compcert2cc -all: $(TESTS) +DIFFTESTS=layout.compcert layout.cc \ + staticlayout.compcert staticlayout.cc + +all: $(TESTS) $(DIFFTESTS) all_s: fixed_def_compcert.s fixed_use_compcert.s \ vararg_def_compcert.s vararg_use_compcert.s \ @@ -18,12 +21,22 @@ test: @set -e; for t in $(TESTS); do \ SIMU='$(SIMU)' ARCH=$(ARCH) MODEL=$(MODEL) ABI=$(ABI) SYSTEM=$(SYSTEM) ./Runtest $$t; \ done + @set -e; for t in layout staticlayout; do \ + $(SIMU) ./$$t.compcert > _compcert.log; \ + $(SIMU) ./$$t.cc > _cc.log; \ + if diff -a -u _cc.log _compcert.log; \ + then echo "$$t: CompCert and $CC agree"; rm _*.log; \ + else echo "$$t: CompCert and $CC DISAGREE"; exit 2; fi; \ + done generator.exe: generator.ml ocamlopt -g -o $@ generator.ml +genlayout.exe: genlayout.ml + ocamlopt -g -o $@ genlayout.ml + clean:: - rm -f generator.exe *.cm[iox] + rm -f generator.exe genlayout.exe *.cm[iox] fixed_decl.h: generator.exe ./generator.exe -rnd 500 -o fixed @@ -49,6 +62,16 @@ struct_def.c struct_use.c: struct_decl.h clean:: rm -f struct_decl.h struct_def.c struct_use.c +ifeq ($(ARCH),arm) +GENLAYOUT_OPTIONS += -stable +endif +ifeq ($(ARCH),aarch64) +GENLAYOUT_OPTIONS += -stable +endif + +layout.h: genlayout.exe + ./genlayout.exe $(GENLAYOUT_OPTIONS) > layout.h + struct%.o: CCOMPFLAGS += -fstruct-passing -dclight %_compcert.o: %.c @@ -61,6 +84,19 @@ struct%.o: CCOMPFLAGS += -fstruct-passing -dclight %_cc.s: %.c $(CC) $(CFLAGS) -S -o $@ $*.c +layout.compcert: layout.c layout.h + $(CCOMP) $(CCOMPFLAGS) -o $@ layout.c +layout.cc: layout.c layout.h + $(CC) $(CFLAGS) -o $@ layout.c + +staticlayout.compcert: staticlayout.c layout.h + $(CCOMP) $(CCOMPFLAGS) -o $@ staticlayout.c +staticlayout.cc: staticlayout.c layout.h + $(CC) $(CFLAGS) -o $@ staticlayout.c + +%.compcert: %_def_compcert.o %_use_compcert.o + $(CCOMP) -o $@ $*_def_compcert.o $*_use_compcert.o + %.compcert: %_def_compcert.o %_use_compcert.o $(CCOMP) -o $@ $*_def_compcert.o $*_use_compcert.o diff --git a/test/abi/generator.ml b/test/abi/generator.ml index aecee7cf..529352e0 100644 --- a/test/abi/generator.ml +++ b/test/abi/generator.ml @@ -439,7 +439,7 @@ let _ = " <seed> use the given seed for randomization" ] (fun s -> raise (Arg.Bad ("don't know what to do with " ^ s))) - "Usage: gencalls [options]\n\nOptions are:"; + "Usage: generator [options]\n\nOptions are:"; let oc0 = open_out (!output_prefix ^ "_decl.h") and oc1 = open_out (!output_prefix ^ "_def.c") and oc2 = open_out (!output_prefix ^ "_use.c") in diff --git a/test/abi/genlayout.ml b/test/abi/genlayout.ml new file mode 100644 index 00000000..5c26ca35 --- /dev/null +++ b/test/abi/genlayout.ml @@ -0,0 +1,158 @@ +open Printf + +type typ = Bool | Char | Short | Int + +type field = + | Plain of typ + | Bitfield of typ * int + | Padding of typ * int + +type struct_ = field list + +(* Concise description of a struct *) + +let print_typ oc = function + | Bool -> fprintf oc "b" + | Char -> fprintf oc "c" + | Short -> fprintf oc "s" + | Int -> fprintf oc "i" + +let print_padding_typ oc = function + | Bool -> fprintf oc "B" + | Char -> fprintf oc "C" + | Short -> fprintf oc "S" + | Int -> fprintf oc "I" + +let print_field oc = function + | Plain t -> print_typ oc t + | Bitfield(t, w) -> fprintf oc "%a%d" print_typ t w + | Padding(t, w) -> fprintf oc "%a%d" print_padding_typ t w + +let rec print_struct oc = function + | [] -> () + | f :: s -> print_field oc f; print_struct oc s + +(* Printing a struct in C syntax *) + +let c_typ oc = function + | Bool -> fprintf oc "_Bool" + | Char -> fprintf oc "char" + | Short -> fprintf oc "short" + | Int -> fprintf oc "int" + +let c_name oc n = fprintf oc "%c" (Char.chr (Char.code 'a' + n)) + +let c_field oc n = function + | Plain t -> + fprintf oc " %a %a;\n" c_typ t c_name n; + n + 1 + | Bitfield(t, w) -> + fprintf oc " %a %a:%d;\n" c_typ t c_name n w; + n + 1 + | Padding(t, w) -> + fprintf oc " %a :%d;\n" c_typ t w; + n + +let c_struct oc s = + fprintf oc "struct %a {\n" print_struct s; + let rec c_str n = function + | [] -> () + | f :: s -> let n' = c_field oc n f in c_str n' s in + c_str 0 s; + fprintf oc "};\n" + +(* Random generation of structs *) + +let random_1_8 () = + let n1 = Random.bits() in + let n2 = n1 lsr 2 in + match n1 land 3 with + | 0 -> 1 + | 1 -> 2 + (n2 land 1) (* 2-3 *) + | 2 -> 4 + (n2 land 1) (* 4-5 *) + | 3 -> 6 + (n2 mod 3) (* 6-8 *) + | _ -> assert false + +let random_1_16 () = + let n1 = Random.bits() in + let n2 = n1 lsr 2 in + match n1 land 3 with + | 0 -> 1 + (n2 land 1) (* 1-2 *) + | 1 -> 3 + (n2 mod 3) (* 3-4-5 *) + | 2 -> 6 + (n2 land 3) (* 6-7-8-9 *) + | 3 -> 10 + (n2 mod 7) (* 10-16 *) + | _ -> assert false + +let random_1_32 () = + let n1 = Random.bits() in + let n2 = n1 lsr 2 in + match n1 land 3 with + | 0 -> 1 + (n2 land 1) (* 1-2 *) + | 1 -> 3 + (n2 mod 5) (* 3-4-5-6-7 *) + | 2 -> 8 + (n2 mod 8) (* 8-15 *) + | 3 -> 16 + (n2 mod 17) (* 16-32 *) + | _ -> assert false + +let random_field () = + let (t, w) = + match Random.int 9 with + | 0 -> (Bool, 1) + | 1|2 -> (Char, random_1_8()) + | 3|4 -> (Short, random_1_16()) + | _ -> (Int, random_1_32()) in + match Random.int 10 with + | 0 -> Padding(t, (if Random.int 3 = 0 then 0 else w)) + | 1 | 2 -> Plain t + | _ -> Bitfield(t, w) + +let rec random_struct len = + if len <= 0 then [] else begin + let f = random_field () in + f :: random_struct (match f with Padding _ -> len | _ -> len - 1) + end + +(* Optional filtering of structs where padding fields can increase alignment. + ELF says that padding fields are ignored to determine struct alignment, + but ARM does otherwise. *) + +let alignof = function Bool -> 1 | Char -> 1 | Short -> 2 | Int -> 4 + +let unstable_alignment str = + let rec alignments al_data al_padding = function + | [] -> + al_padding > al_data + | (Plain t | Bitfield(t, _)) :: l -> + alignments (max (alignof t) al_data) al_padding l + | Padding(t, _) :: l -> + alignments al_data (max (alignof t) al_padding) l + in + alignments 1 1 str + +(* Random testing *) + +let structsize = ref 4 +let ntests = ref 1000 +let stable = ref false + +let _ = + Arg.parse [ + "-size", Arg.Int (fun n -> structsize := n), + " <sz> produce structs with <sz> members (default: 4)"; + "-n", Arg.Int (fun n -> ntests := n), + " <num> produce <num> random structs"; + "-seed", Arg.Int Random.init, + " <seed> use the given seed for randomization"; + "-stable", Arg.Set stable, + " don't generate padding fields that could cause differences in alignment" + ] + (fun s -> raise (Arg.Bad ("don't know what to do with " ^ s))) + "Usage: genlayout [options]\n\nOptions are:"; + for _i = 1 to !ntests do + let s = random_struct !structsize in + if not (!stable && unstable_alignment s) then begin + printf "{\n"; + c_struct stdout s; + printf "TEST%d(%a)\n" !structsize print_struct s; + printf "}\n" + end + done diff --git a/test/abi/layout.c b/test/abi/layout.c new file mode 100644 index 00000000..ebc6a2b2 --- /dev/null +++ b/test/abi/layout.c @@ -0,0 +1,59 @@ +#include <stdio.h> +#include <stdlib.h> +#include <assert.h> +#include <string.h> +#include "../endian.h" + +static inline int bit(void * p, unsigned bitno) +{ + unsigned byteno = bitno / 8; +#ifdef ARCH_BIG_ENDIAN + unsigned bit_in_byte = 7 - (bitno & 7); +#else + unsigned bit_in_byte = bitno & 7; +#endif + return (((unsigned char *) p)[byteno] >> bit_in_byte) & 1; +} + +void print_prologue(char * name, size_t al, size_t sz) +{ + printf("%s: align %d, sizeof %d, layout", name, (int)al, (int)sz); +} + +void print_next_field(_Bool first, size_t sz, void * p) +{ + static unsigned pos; + + if (first) pos = 0; + /* Find first bit set, starting with [pos] */ + while (1) { + assert (pos < 8 * sz); + if (bit(p, pos)) break; + pos += 1; + } + /* Print this position */ + printf(" %u", pos); + /* Skip over one bits */ + while (pos < 8 * sz && bit(p, pos)) pos++; +} + +void print_epilogue(void) +{ + printf("\n"); +} + +#define TEST4(s) \ + struct s x; \ + memset(&x, 0, sizeof(x)); \ + print_prologue(#s, _Alignof(struct s), sizeof(x)); \ + x.a = -1; print_next_field(1, sizeof(x), &x); \ + x.b = -1; print_next_field(0, sizeof(x), &x); \ + x.c = -1; print_next_field(0, sizeof(x), &x); \ + x.d = -1; print_next_field(0, sizeof(x), &x); \ + print_epilogue(); + +int main() +{ +#include "layout.h" + return 0; +} diff --git a/test/abi/staticlayout.c b/test/abi/staticlayout.c new file mode 100644 index 00000000..8a655afc --- /dev/null +++ b/test/abi/staticlayout.c @@ -0,0 +1,76 @@ +#include <stdio.h> +#include "../endian.h" + +static inline int bit(void * p, unsigned bitno) +{ + unsigned byteno = bitno / 8; +#ifdef ARCH_BIG_ENDIAN + unsigned bit_in_byte = 7 - (bitno & 7); +#else + unsigned bit_in_byte = bitno & 7; +#endif + return (((unsigned char *) p)[byteno] >> bit_in_byte) & 1; +} + +void print_prologue(char * name, size_t al, size_t sz) +{ + printf("%s: align %d, sizeof %d, layout", name, (int)al, (int)sz); +} + +#if 0 +void print_contents(size_t sz, void * p) +{ + int last, lastpos; + printf(" - "); + last = 0; lastpos = 0; + for (int i = 0; i < sz; i++) { + for (int b = 0; b < 8; b++) { + int curr = bit((char *) p + i, b); + int currpos = i * 8 + b; + if (curr != last) { + if (currpos > lastpos) { + printf("%d(%d)", last, currpos - lastpos); + } + last = curr; lastpos = currpos; + } + } + } + { int currpos = sz * 8; + if (currpos > lastpos) { + printf("%d(%d)", last, currpos - lastpos); + } + } +} +#else +void print_contents(size_t sz, void * p) +{ + printf(" - "); + for (int i = 0; i < sz; i++) { + printf("%02x", ((unsigned char *)p)[i]); + } +} +#endif + +void print_epilogue (void) +{ + printf("\n"); +} + + +#define TEST4(s) \ + static struct s x1 = {-1, 0, 0, 0}; \ + static struct s x2 = {-1, -1, 0, 0}; \ + static struct s x3 = {-1, 0, -1, 0}; \ + static struct s x4 = {-1, -1, -1, -1}; \ + print_prologue(#s, _Alignof(struct s), sizeof(x1)); \ + print_contents(sizeof(x1), &x1); \ + print_contents(sizeof(x2), &x2); \ + print_contents(sizeof(x3), &x3); \ + print_contents(sizeof(x4), &x4); \ + print_epilogue(); + +int main() +{ +#include "layout.h" + return 0; +} diff --git a/test/clightgen/bitfields.c b/test/clightgen/bitfields.c new file mode 100644 index 00000000..34f6a686 --- /dev/null +++ b/test/clightgen/bitfields.c @@ -0,0 +1,13 @@ +struct s { + int a: 10; + char : 6; + _Bool b : 1; + int : 0; + short c: 7; +}; + +int f(void) +{ + struct s x = { -1, 1, 2 }; + return x.a + x.b + x.c; +} diff --git a/test/regression/Makefile b/test/regression/Makefile index 0f9e368f..b3a2eee8 100644 --- a/test/regression/Makefile +++ b/test/regression/Makefile @@ -18,12 +18,12 @@ TESTS?=int32 int64 floats floats-basics floats-lit \ funct3 expr5 struct7 struct8 struct11 struct12 casts1 casts2 char1 \ sizeof1 sizeof2 binops bool for1 for2 switch switch2 compound \ decl1 bitfields9 ptrs3 \ - parsing krfun ifconv many_parameters + parsing krfun ifconv many_parameters union_passing # Can run, but only in compiled mode, and have reference output in Results TESTS_COMP?=attribs1 bitfields1 bitfields2 bitfields3 bitfields4 \ - bitfields5 bitfields6 bitfields7 bitfields8 bitfields_uint_t \ + bitfields5 bitfields6 bitfields7 bitfields8 bitfields_uint_t bitfields10 \ builtins-common builtins-$(ARCH) packedstruct1 packedstruct2 alignas \ varargs1 varargs2 varargs3 sections alias aligned diff --git a/test/regression/Results/bitfields10 b/test/regression/Results/bitfields10 new file mode 100644 index 00000000..9dc00daf --- /dev/null +++ b/test/regression/Results/bitfields10 @@ -0,0 +1,14 @@ +loc_s = { a = 11, b = 2 } +loc_t = { c = 11, d = 1, e = 2 } +loc_u_u = { u = -5 } +loc_u_v = { v = 3 } +compound_s = { a = 2, b = 3 } +compound_t = { c = 2, d = 1, e = -11 } +compound_u = { u = 2 } +loc_s = { a = 7, b = 2 } +loc_t = { c = 7, d = 1, e = 50 } +loc_u_u = { u = 7 } +loc_u_v = { v = 2 } +compound_s = { a = -14, b = 3 } +compound_t = { c = 50, d = 1, e = -7 } +compound_u = { u = 2 } diff --git a/test/regression/Results/bitfields9 b/test/regression/Results/bitfields9 index e35c2414..ec35fc08 100644 --- a/test/regression/Results/bitfields9 +++ b/test/regression/Results/bitfields9 @@ -2,17 +2,7 @@ glob_s = { a = -12, b = 1 } glob_t = { c = 123, d = 1, e = -45 } glob_u_u = { u = -3 } glob_u_v = { v = 6 } -loc_s = { a = 11, b = 2 } -loc_t = { c = 11, d = 1, e = 2 } -loc_u_u = { u = -5 } -loc_u_v = { v = 3 } -compound_s = { a = 2, b = 3 } -compound_t = { c = 2, d = 1, e = -11 } -compound_u = { u = 2 } -loc_s = { a = 7, b = 2 } -loc_t = { c = 7, d = 1, e = 50 } -loc_u_u = { u = 7 } -loc_u_v = { v = 2 } -compound_s = { a = -14, b = 3 } -compound_t = { c = 50, d = 1, e = -7 } -compound_u = { u = 2 } +loc_s = { a = -12, b = 1 } +loc_t = { c = 123, d = 1, e = -45 } +loc_u_u = { u = -3 } +loc_u_v = { v = 6 } diff --git a/test/regression/Runtest b/test/regression/Runtest index f693219a..600ae045 100755 --- a/test/regression/Runtest +++ b/test/regression/Runtest @@ -51,7 +51,7 @@ then exit 0 else echo "$name: WRONG OUTPUT (diff follows)" - diff -u "$ref" "$out" + diff -a -u "$ref" "$out" exit 2 fi else diff --git a/test/regression/bitfields10.c b/test/regression/bitfields10.c new file mode 100644 index 00000000..0f022664 --- /dev/null +++ b/test/regression/bitfields10.c @@ -0,0 +1,66 @@ +#include <stdio.h> + +/* Dynamic initialization of bit-fields */ +/* Known not to work with the reference interpreter */ + +struct s { + signed char a: 6; + unsigned int b: 2; +}; + +struct t { + unsigned int c: 16; + _Bool d: 1; + short e: 8; + int : 10; +}; + +union u { + int u: 4; + unsigned int v: 3; +}; + +void print_s(char * msg, struct s p) +{ + printf("%s = { a = %d, b = %d }\n", msg, p.a, p.b); +} + +void print_t(char * msg, struct t p) +{ + printf("%s = { c = %d, d = %d, e = %d }\n", msg, p.c, p.d, p.e); +} + +void print_u_u(char * msg, union u p) +{ + printf("%s = { u = %d }\n", msg, p.u); +} + +void print_u_v(char * msg, union u p) +{ + printf("%s = { v = %u }\n", msg, p.v); +} + +/* Local, non-static initialization */ +void f(int x, int y, int z) +{ + struct s loc_s = { x, y }; + struct t loc_t = { x, z, y }; + union u loc_u_u = { .u = x }; + union u loc_u_v = { .v = z }; + print_s("loc_s", loc_s); + print_t("loc_t", loc_t); + print_u_u("loc_u_u", loc_u_u); + print_u_v("loc_u_v", loc_u_v); + print_s("compound_s", (struct s) { y, x }); + print_t("compound_t", (struct t) { y, ~z, -x }); + print_u_u("compound_u", (union u) { y }); +} + +int main() +{ + f(11, 2, 3); + f(7, 50, 2); + return 0; +} + + diff --git a/test/regression/bitfields9.c b/test/regression/bitfields9.c index eef20168..025216fa 100644 --- a/test/regression/bitfields9.c +++ b/test/regression/bitfields9.c @@ -1,6 +1,6 @@ #include <stdio.h> -/* Initialization of bit-fields */ +/* Static initialization of bit-fields */ struct s { signed char a: 6; @@ -39,27 +39,23 @@ void print_u_v(char * msg, union u p) printf("%s = { v = %u }\n", msg, p.v); } - /* Global initialization */ struct s glob_s = { -12, 1 }; struct t glob_t = { 123, 2, -45 }; union u glob_u_u = { -3 }; union u glob_u_v = { .v = 6 }; -/* Local initialization */ -void f(int x, int y, int z) +/* Local, static initialization */ +void f(void) { - struct s loc_s = { x, y }; - struct t loc_t = { x, z, y }; - union u loc_u_u = { .u = x }; - union u loc_u_v = { .v = z }; + static struct s loc_s = { -12, 1 }; + static struct t loc_t = { 123, 2, -45 }; + static union u loc_u_u = { -3 }; + static union u loc_u_v = { .v = 6 }; print_s("loc_s", loc_s); print_t("loc_t", loc_t); print_u_u("loc_u_u", loc_u_u); print_u_v("loc_u_v", loc_u_v); - print_s("compound_s", (struct s) { y, x }); - print_t("compound_t", (struct t) { y, ~z, -x }); - print_u_u("compound_u", (union u) { y }); } int main() @@ -68,8 +64,7 @@ int main() print_t("glob_t", glob_t); print_u_u("glob_u_u", glob_u_u); print_u_v("glob_u_v", glob_u_v); - f(11, 2, 3); - f(7, 50, 2); + f(); return 0; } diff --git a/test/regression/sizeof1.c b/test/regression/sizeof1.c index ca494622..5bd4d739 100644 --- a/test/regression/sizeof1.c +++ b/test/regression/sizeof1.c @@ -17,8 +17,8 @@ char tbl[sizeof(struct s)]; */ struct bits1 { - unsigned a: 1; - unsigned b: 6; + unsigned char a: 1; + unsigned char b: 6; }; char b1[sizeof(struct bits1)]; /* should be 1 */ diff --git a/test/regression/union_passing.c b/test/regression/union_passing.c new file mode 100644 index 00000000..b0ce6319 --- /dev/null +++ b/test/regression/union_passing.c @@ -0,0 +1,23 @@ +#include <stdint.h> +#include <stdio.h> +static int32_t bk; +union ba { + int64_t bb; +}; +static void dada(union ba); +void nothing(void); +void stuff(void) { + union ba f = {5}; + int32_t i[1000]; + nothing(); + dada(f); +} +static void dada(union ba k) { + bk = k.bb; +} +void nothing(void) { +} +int main() { + stuff(); + printf("result = %d\n", bk); +} diff --git a/x86/Asmexpand.ml b/x86/Asmexpand.ml index e2c556c7..f81b9165 100644 --- a/x86/Asmexpand.ml +++ b/x86/Asmexpand.ml @@ -39,11 +39,6 @@ let _16z = Z.of_sint 16 let stack_alignment () = 16 -(* Pseudo instructions for 32/64 bit compatibility *) - -let _Plea (r, addr) = - if Archi.ptr64 then Pleaq (r, addr) else Pleal (r, addr) - (* SP adjustment to allocate or free a stack frame. *) let align n a = @@ -109,6 +104,21 @@ let offset_addressing (Addrmode(base, ofs, cst)) delta = let linear_addr reg ofs = Addrmode(Some reg, None, Coq_inl ofs) let global_addr id ofs = Addrmode(None, None, Coq_inr(id, ofs)) +(* A "leaq" instruction that does not overflow *) + +let emit_leaq r addr = + match Asmgen.normalize_addrmode_64 addr with + | (addr, None) -> + emit (Pleaq (r, addr)) + | (addr, Some delta) -> + emit (Pleaq (r, addr)); + emit (Paddq_ri (r, delta)) + +(* Pseudo "lea" instruction for 32/64 bit compatibility *) + +let emit_lea r addr = + if Archi.ptr64 then emit_leaq r addr else emit (Pleal (r, addr)) + (* Translate a builtin argument into an addressing mode *) let addressing_of_builtin_arg = function @@ -150,8 +160,8 @@ let expand_builtin_memcpy_small sz al src dst = copy (addressing_of_builtin_arg src) (addressing_of_builtin_arg dst) sz let expand_builtin_memcpy_big sz al src dst = - if src <> BA (IR RSI) then emit (_Plea (RSI, addressing_of_builtin_arg src)); - if dst <> BA (IR RDI) then emit (_Plea (RDI, addressing_of_builtin_arg dst)); + if src <> BA (IR RSI) then emit_lea RSI (addressing_of_builtin_arg src); + if dst <> BA (IR RDI) then emit_lea RDI (addressing_of_builtin_arg dst); (* TODO: movsq? *) emit (Pmovl_ri (RCX,coqint_of_camlint (Int32.of_int (sz / 4)))); emit Prep_movsl; @@ -289,9 +299,9 @@ let expand_builtin_va_start_elf64 r = emit (Pmovl_mr (linear_addr r _0z, RAX)); emit (Pmovl_ri (RAX, coqint_of_camlint fp_offset)); emit (Pmovl_mr (linear_addr r _4z, RAX)); - emit (Pleaq (RAX, linear_addr RSP (Z.of_uint64 overflow_arg_area))); + emit_leaq RAX (linear_addr RSP (Z.of_uint64 overflow_arg_area)); emit (Pmovq_mr (linear_addr r _8z, RAX)); - emit (Pleaq (RAX, linear_addr RSP (Z.of_uint64 reg_save_area))); + emit_leaq RAX (linear_addr RSP (Z.of_uint64 reg_save_area)); emit (Pmovq_mr (linear_addr r _16z, RAX)) let expand_builtin_va_start_win64 r = @@ -302,7 +312,7 @@ let expand_builtin_va_start_win64 r = let ofs = Int64.(add !current_function_stacksize (mul 8L (of_int num_args))) in - emit (Pleaq (RAX, linear_addr RSP (Z.of_uint64 ofs))); + emit_leaq RAX (linear_addr RSP (Z.of_uint64 ofs)); emit (Pmovq_mr (linear_addr r _0z, RAX)) (* FMA operations *) @@ -552,7 +562,7 @@ let expand_instruction instr = (* Stack chaining *) let addr1 = linear_addr RSP (Z.of_uint (sz + 8)) in let addr2 = linear_addr RSP ofs_link in - emit (Pleaq (RAX,addr1)); + emit_leaq RAX addr1; emit (Pmovq_mr (addr2, RAX)); current_function_stacksize := Int64.of_int (sz + 8) end else if Archi.ptr64 then begin @@ -563,7 +573,7 @@ let expand_instruction instr = emit (Pcfi_adjust sz'); if save_regs >= 0 then begin (* Save the registers *) - emit (Pleaq (R10, linear_addr RSP (Z.of_uint save_regs))); + emit_leaq R10 (linear_addr RSP (Z.of_uint save_regs)); emit (Pcall_s (intern_string "__compcert_va_saveregs", {sig_args = []; sig_res = Tvoid; sig_cc = cc_default})) end; @@ -571,7 +581,7 @@ let expand_instruction instr = let fullsz = sz + 8 in let addr1 = linear_addr RSP (Z.of_uint fullsz) in let addr2 = linear_addr RSP ofs_link in - emit (Pleaq (RAX, addr1)); + emit_leaq RAX addr1; emit (Pmovq_mr (addr2, RAX)); current_function_stacksize := Int64.of_int fullsz end else begin |