From 60b6624ae2b28ebe9fb30c2aa6115e4d5c1ab436 Mon Sep 17 00:00:00 2001 From: xleroy Date: Sat, 26 Nov 2011 15:40:57 +0000 Subject: cparser/*: refactoring of the expansion of read-modify-write operators cparser/PackedStructs: treat r-m-w operations over byte-swapped fields cparser/PackedStructs: allow static initialization of packed structs test/regression: more packedstruct tests git-svn-id: https://yquem.inria.fr/compcert/svn/compcert/trunk@1738 fca1b0fc-160b-0410-b1d3-a4f43f01ea2e --- cparser/.depend | 166 ++++++++++++++++++++++---------------------- cparser/Bitfields.ml | 24 +------ cparser/Machine.ml | 6 +- cparser/Machine.mli | 2 +- cparser/PackedStructs.ml | 175 ++++++++++++++++++++++++++++++++++++----------- cparser/SimplVolatile.ml | 77 ++------------------- cparser/Transform.ml | 90 ++++++++++++++++++++++-- cparser/Transform.mli | 27 +++++++- 8 files changed, 342 insertions(+), 225 deletions(-) (limited to 'cparser') diff --git a/cparser/.depend b/cparser/.depend index 2d6b280..51f3b5e 100644 --- a/cparser/.depend +++ b/cparser/.depend @@ -1,88 +1,90 @@ -AddCasts.cmi: C.cmi -Bitfields.cmi: C.cmi -Builtins.cmi: Env.cmi C.cmi -C.cmi: -Ceval.cmi: Env.cmi C.cmi -Cleanup.cmi: C.cmi -Cprint.cmi: C.cmi -Cutil.cmi: Env.cmi C.cmi -Elab.cmi: C.cmi -Env.cmi: C.cmi -Errors.cmi: -GCC.cmi: Builtins.cmi -Lexer.cmi: Parser.cmi -Machine.cmi: -PackedStructs.cmi: C.cmi -Parse.cmi: C.cmi -Parse_aux.cmi: -Parser.cmi: Cabs.cmo -Rename.cmi: C.cmi -SimplExpr.cmi: C.cmi -StructAssign.cmi: C.cmi -StructByValue.cmi: C.cmi -Transform.cmi: Env.cmi C.cmi -Unblock.cmi: C.cmi -AddCasts.cmo: Transform.cmi Cutil.cmi C.cmi AddCasts.cmi -AddCasts.cmx: Transform.cmx Cutil.cmx C.cmi AddCasts.cmi -Bitfields.cmo: Transform.cmi Machine.cmi Cutil.cmi C.cmi Bitfields.cmi -Bitfields.cmx: Transform.cmx Machine.cmx Cutil.cmx C.cmi Bitfields.cmi -Builtins.cmo: Env.cmi Cutil.cmi C.cmi Builtins.cmi -Builtins.cmx: Env.cmx Cutil.cmx C.cmi Builtins.cmi -Cabs.cmo: -Cabs.cmx: -Cabshelper.cmo: Cabs.cmo -Cabshelper.cmx: Cabs.cmx -Ceval.cmo: Machine.cmi Cutil.cmi C.cmi Ceval.cmi -Ceval.cmx: Machine.cmx Cutil.cmx C.cmi Ceval.cmi -Cleanup.cmo: Cutil.cmi C.cmi Cleanup.cmi -Cleanup.cmx: Cutil.cmx C.cmi Cleanup.cmi -Cprint.cmo: C.cmi Cprint.cmi -Cprint.cmx: C.cmi Cprint.cmi -Cutil.cmo: Machine.cmi Errors.cmi Env.cmi Cprint.cmi C.cmi Cutil.cmi -Cutil.cmx: Machine.cmx Errors.cmx Env.cmx Cprint.cmx C.cmi Cutil.cmi +AddCasts.cmi: C.cmi +Bitfields.cmi: C.cmi +Builtins.cmi: Env.cmi C.cmi +C.cmi: +Ceval.cmi: Env.cmi C.cmi +Cleanup.cmi: C.cmi +Cprint.cmi: C.cmi +Cutil.cmi: Env.cmi C.cmi +Elab.cmi: C.cmi +Env.cmi: C.cmi +Errors.cmi: +GCC.cmi: Builtins.cmi +Lexer.cmi: Parser.cmi +Machine.cmi: +PackedStructs.cmi: C.cmi +Parse.cmi: C.cmi +Parse_aux.cmi: +Parser.cmi: Cabs.cmo +Rename.cmi: C.cmi +SimplExpr.cmi: C.cmi +StructAssign.cmi: C.cmi +StructByValue.cmi: C.cmi +Transform.cmi: Env.cmi C.cmi +Unblock.cmi: C.cmi +AddCasts.cmo: Transform.cmi Cutil.cmi C.cmi AddCasts.cmi +AddCasts.cmx: Transform.cmx Cutil.cmx C.cmi AddCasts.cmi +Bitfields.cmo: Transform.cmi Machine.cmi Cutil.cmi C.cmi Bitfields.cmi +Bitfields.cmx: Transform.cmx Machine.cmx Cutil.cmx C.cmi Bitfields.cmi +Builtins.cmo: Env.cmi Cutil.cmi C.cmi Builtins.cmi +Builtins.cmx: Env.cmx Cutil.cmx C.cmi Builtins.cmi +Cabs.cmo: +Cabs.cmx: +Cabshelper.cmo: Cabs.cmo +Cabshelper.cmx: Cabs.cmx +Ceval.cmo: Machine.cmi Cutil.cmi C.cmi Ceval.cmi +Ceval.cmx: Machine.cmx Cutil.cmx C.cmi Ceval.cmi +Cleanup.cmo: Cutil.cmi C.cmi Cleanup.cmi +Cleanup.cmx: Cutil.cmx C.cmi Cleanup.cmi +Cprint.cmo: C.cmi Cprint.cmi +Cprint.cmx: C.cmi Cprint.cmi +Cutil.cmo: Machine.cmi Errors.cmi Env.cmi Cprint.cmi C.cmi Cutil.cmi +Cutil.cmx: Machine.cmx Errors.cmx Env.cmx Cprint.cmx C.cmi Cutil.cmi Elab.cmo: Parser.cmi Machine.cmi Lexer.cmi Errors.cmi Env.cmi Cutil.cmi \ Cprint.cmi Cleanup.cmi Ceval.cmi Cabshelper.cmo Cabs.cmo C.cmi \ - Builtins.cmi Elab.cmi + Builtins.cmi Elab.cmi Elab.cmx: Parser.cmx Machine.cmx Lexer.cmx Errors.cmx Env.cmx Cutil.cmx \ Cprint.cmx Cleanup.cmx Ceval.cmx Cabshelper.cmx Cabs.cmx C.cmi \ - Builtins.cmx Elab.cmi -Env.cmo: C.cmi Env.cmi -Env.cmx: C.cmi Env.cmi -Errors.cmo: Errors.cmi -Errors.cmx: Errors.cmi -GCC.cmo: Cutil.cmi C.cmi Builtins.cmi GCC.cmi -GCC.cmx: Cutil.cmx C.cmi Builtins.cmx GCC.cmi -Lexer.cmo: Parser.cmi Parse_aux.cmi Cabshelper.cmo Lexer.cmi -Lexer.cmx: Parser.cmx Parse_aux.cmx Cabshelper.cmx Lexer.cmi -Machine.cmo: Machine.cmi -Machine.cmx: Machine.cmi -Main.cmo: Parse.cmi GCC.cmi Cprint.cmi Builtins.cmi -Main.cmx: Parse.cmx GCC.cmx Cprint.cmx Builtins.cmx -PackedStructs.cmo: Errors.cmi Env.cmi Cutil.cmi C.cmi Builtins.cmi \ - PackedStructs.cmi -PackedStructs.cmx: Errors.cmx Env.cmx Cutil.cmx C.cmi Builtins.cmx \ - PackedStructs.cmi -Parse.cmo: Unblock.cmi StructByValue.cmi StructAssign.cmi SimplExpr.cmi \ - Rename.cmi PackedStructs.cmi Errors.cmi Elab.cmi Bitfields.cmi \ - AddCasts.cmi Parse.cmi -Parse.cmx: Unblock.cmx StructByValue.cmx StructAssign.cmx SimplExpr.cmx \ - Rename.cmx PackedStructs.cmx Errors.cmx Elab.cmx Bitfields.cmx \ - AddCasts.cmx Parse.cmi -Parse_aux.cmo: Errors.cmi Cabshelper.cmo Parse_aux.cmi -Parse_aux.cmx: Errors.cmx Cabshelper.cmx Parse_aux.cmi -Parser.cmo: Parse_aux.cmi Cabshelper.cmo Cabs.cmo Parser.cmi -Parser.cmx: Parse_aux.cmx Cabshelper.cmx Cabs.cmx Parser.cmi -Rename.cmo: Errors.cmi Cutil.cmi C.cmi Builtins.cmi Rename.cmi -Rename.cmx: Errors.cmx Cutil.cmx C.cmi Builtins.cmx Rename.cmi -SimplExpr.cmo: Transform.cmi Errors.cmi Cutil.cmi C.cmi SimplExpr.cmi -SimplExpr.cmx: Transform.cmx Errors.cmx Cutil.cmx C.cmi SimplExpr.cmi + Builtins.cmx Elab.cmi +Env.cmo: C.cmi Env.cmi +Env.cmx: C.cmi Env.cmi +Errors.cmo: Errors.cmi +Errors.cmx: Errors.cmi +GCC.cmo: Cutil.cmi C.cmi Builtins.cmi GCC.cmi +GCC.cmx: Cutil.cmx C.cmi Builtins.cmx GCC.cmi +Lexer.cmo: Parser.cmi Parse_aux.cmi Cabshelper.cmo Lexer.cmi +Lexer.cmx: Parser.cmx Parse_aux.cmx Cabshelper.cmx Lexer.cmi +Machine.cmo: Machine.cmi +Machine.cmx: Machine.cmi +Main.cmo: Parse.cmi GCC.cmi Cprint.cmi Builtins.cmi +Main.cmx: Parse.cmx GCC.cmx Cprint.cmx Builtins.cmx +PackedStructs.cmo: Transform.cmi Machine.cmi Errors.cmi Env.cmi Cutil.cmi \ + C.cmi Builtins.cmi PackedStructs.cmi +PackedStructs.cmx: Transform.cmx Machine.cmx Errors.cmx Env.cmx Cutil.cmx \ + C.cmi Builtins.cmx PackedStructs.cmi +Parse.cmo: Unblock.cmi StructByValue.cmi StructAssign.cmi SimplVolatile.cmo \ + SimplExpr.cmi Rename.cmi PackedStructs.cmi Errors.cmi Elab.cmi \ + Bitfields.cmi AddCasts.cmi Parse.cmi +Parse.cmx: Unblock.cmx StructByValue.cmx StructAssign.cmx SimplVolatile.cmx \ + SimplExpr.cmx Rename.cmx PackedStructs.cmx Errors.cmx Elab.cmx \ + Bitfields.cmx AddCasts.cmx Parse.cmi +Parse_aux.cmo: Errors.cmi Cabshelper.cmo Parse_aux.cmi +Parse_aux.cmx: Errors.cmx Cabshelper.cmx Parse_aux.cmi +Parser.cmo: Parse_aux.cmi Cabshelper.cmo Cabs.cmo Parser.cmi +Parser.cmx: Parse_aux.cmx Cabshelper.cmx Cabs.cmx Parser.cmi +Rename.cmo: Errors.cmi Cutil.cmi C.cmi Builtins.cmi Rename.cmi +Rename.cmx: Errors.cmx Cutil.cmx C.cmi Builtins.cmx Rename.cmi +SimplExpr.cmo: Transform.cmi Errors.cmi Cutil.cmi C.cmi SimplExpr.cmi +SimplExpr.cmx: Transform.cmx Errors.cmx Cutil.cmx C.cmi SimplExpr.cmi +SimplVolatile.cmo: Transform.cmi Cutil.cmi C.cmi +SimplVolatile.cmx: Transform.cmx Cutil.cmx C.cmi StructAssign.cmo: Transform.cmi Machine.cmi Errors.cmi Env.cmi Cutil.cmi \ - C.cmi StructAssign.cmi + C.cmi StructAssign.cmi StructAssign.cmx: Transform.cmx Machine.cmx Errors.cmx Env.cmx Cutil.cmx \ - C.cmi StructAssign.cmi -StructByValue.cmo: Transform.cmi Env.cmi Cutil.cmi C.cmi StructByValue.cmi -StructByValue.cmx: Transform.cmx Env.cmx Cutil.cmx C.cmi StructByValue.cmi -Transform.cmo: Env.cmi Cutil.cmi C.cmi Builtins.cmi Transform.cmi -Transform.cmx: Env.cmx Cutil.cmx C.cmi Builtins.cmx Transform.cmi -Unblock.cmo: Transform.cmi Errors.cmi Cutil.cmi C.cmi Unblock.cmi -Unblock.cmx: Transform.cmx Errors.cmx Cutil.cmx C.cmi Unblock.cmi + C.cmi StructAssign.cmi +StructByValue.cmo: Transform.cmi Env.cmi Cutil.cmi C.cmi StructByValue.cmi +StructByValue.cmx: Transform.cmx Env.cmx Cutil.cmx C.cmi StructByValue.cmi +Transform.cmo: Env.cmi Cutil.cmi C.cmi Builtins.cmi Transform.cmi +Transform.cmx: Env.cmx Cutil.cmx C.cmi Builtins.cmx Transform.cmi +Unblock.cmo: Transform.cmi Errors.cmi Cutil.cmi C.cmi Unblock.cmi +Unblock.cmx: Transform.cmx Errors.cmx Cutil.cmx C.cmi Unblock.cmi diff --git a/cparser/Bitfields.ml b/cparser/Bitfields.ml index d16f91f..c1b83cb 100644 --- a/cparser/Bitfields.ml +++ b/cparser/Bitfields.ml @@ -201,28 +201,6 @@ let bitfield_assign bf carrier newval = {edesc = EBinop(Oor, oldval_masked, newval_masked, TInt(IUInt,[])); etyp = TInt(IUInt,[])} -(* Transformation of operators *) - -let op_for_incr_decr = function - | Opreincr -> Oadd - | Opredecr -> Osub - | Opostincr -> Oadd - | Opostdecr -> Osub - | _ -> assert false - -let op_for_assignop = function - | Oadd_assign -> Oadd - | Osub_assign -> Osub - | Omul_assign -> Omul - | Odiv_assign -> Odiv - | Omod_assign -> Omod - | Oand_assign -> Oand - | Oor_assign -> Oor - | Oxor_assign -> Oxor - | Oshl_assign -> Oshl - | Oshr_assign -> Oshr - | _ -> assert false - (* 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 *) @@ -356,7 +334,7 @@ let transf_expr env ctx e = bind_lvalue env (texp Val e1) (fun base -> let carrier = {edesc = EUnop(Odot bf.bf_carrier, base); etyp = bf.bf_carrier_typ} in - let temp = new_temp tyfield in + let temp = mk_temp env tyfield in let tyres = unary_conversion env tyfield in let settemp = eassign temp (bitfield_extract bf carrier) in let rhs = diff --git a/cparser/Machine.ml b/cparser/Machine.ml index ffff5fb..0300582 100644 --- a/cparser/Machine.ml +++ b/cparser/Machine.ml @@ -40,6 +40,7 @@ type t = { alignof_longdouble: int; alignof_void: int option; alignof_fun: int option; + bigendian: bool; bitfields_msb_first: bool } @@ -68,6 +69,7 @@ let ilp32ll64 = { alignof_longdouble = 16; alignof_void = None; alignof_fun = None; + bigendian = false; bitfields_msb_first = false } @@ -96,6 +98,7 @@ let i32lpll64 = { alignof_longdouble = 16; alignof_void = None; alignof_fun = None; + bigendian = false; bitfields_msb_first = false } @@ -124,6 +127,7 @@ let il32pll64 = { alignof_longdouble = 16; alignof_void = None; alignof_fun = None; + bigendian = false; bitfields_msb_first = false } @@ -132,7 +136,7 @@ let il32pll64 = { let x86_32 = { ilp32ll64 with char_signed = true } let x86_64 = { i32lpll64 with char_signed = true } let win64 = { il32pll64 with char_signed = true } -let ppc_32_bigendian = { ilp32ll64 with bitfields_msb_first = true } +let ppc_32_bigendian = { ilp32ll64 with bigendian = true; bitfields_msb_first = true } let arm_littleendian = ilp32ll64 (* Add GCC extensions re: sizeof and alignof *) diff --git a/cparser/Machine.mli b/cparser/Machine.mli index f1d3567..3becce3 100644 --- a/cparser/Machine.mli +++ b/cparser/Machine.mli @@ -40,8 +40,8 @@ type t = { alignof_longdouble: int; alignof_void: int option; alignof_fun: int option; + bigendian: bool; bitfields_msb_first: bool - } val ilp32ll64 : t diff --git a/cparser/PackedStructs.ml b/cparser/PackedStructs.ml index 7fc0067..30466cb 100644 --- a/cparser/PackedStructs.ml +++ b/cparser/PackedStructs.ml @@ -28,6 +28,11 @@ type field_info = { fi_swap: bool (* true if byte-swapped *) } +(* Mapping from struct name to size. + Only packed structs are mentioned in this table. *) + +let packed_structs : (ident, int) Hashtbl.t = Hashtbl.create 17 + (* Mapping from (struct name, field name) to field_info. Only fields of packed structs are mentioned in this table. *) @@ -50,6 +55,15 @@ let align x boundary = assert (is_pow2 boundary); (x + boundary - 1) land (lnot (boundary - 1)) +(* What are the types that can be byte-swapped? *) + +let rec can_byte_swap env ty = + match unroll env ty with + | TInt(ik, _) -> (true, sizeof_ikind ik > 1) + | TPtr(_, _) -> (true, true) (* tolerance? *) + | TArray(ty_elt, _, _) -> can_byte_swap env ty_elt + | _ -> (false, false) + (* Layout algorithm *) let layout_struct mfa msa swapped loc env struct_id fields = @@ -63,13 +77,21 @@ let layout_struct mfa msa swapped loc env struct_id fields = let (sz, al) = match sizeof env f.fld_typ, alignof env f.fld_typ with | Some s, Some a -> (s, a) - | _, _ -> error "%a: struct field has incomplete type" formatloc loc; + | _, _ -> error "%a: Error: struct field has incomplete type" formatloc loc; (0, 1) in + let swap = + if swapped then begin + let (can_swap, must_swap) = can_byte_swap env f.fld_typ in + if not can_swap then + error "%a: Error: cannot byte-swap field of type '%a'" + formatloc loc Cprint.typ f.fld_typ; + must_swap + end else false in let al1 = min al mfa in let pos1 = align pos al1 in Hashtbl.add packed_fields (struct_id, f.fld_name) - {fi_offset = pos1; fi_swap = swapped}; + {fi_offset = pos1; fi_swap = swap}; let pos2 = pos1 + sz in layout (max max_al al1) pos2 rem in let (al, sz) = layout 1 0 fields in @@ -80,6 +102,11 @@ let layout_struct mfa msa swapped loc env struct_id fields = (* Rewriting of struct declarations *) +let payload_field sz = + { fld_name = "__payload"; + fld_typ = TArray(TInt(IUChar, []), Some(Int64.of_int sz), []); + fld_bitfield = None} + let transf_composite loc env su id attrs ml = match su with | Union -> (attrs, ml) @@ -93,13 +120,12 @@ let transf_composite loc env su id attrs ml = (0, 0, false) in if mfa = 0 then (attrs, ml) else begin let (al, sz) = layout_struct mfa msa swapped loc env id ml in + Hashtbl.add packed_structs id sz; let attrs = if al = 0 then attrs else add_attributes [Attr("__aligned__", [AInt(Int64.of_int al)])] attrs and field = - {fld_name = "__payload"; - fld_typ = TArray(TInt(IChar, []), Some(Int64.of_int sz), []); - fld_bitfield = None} + payload_field sz in (attrs, [field]) end @@ -152,7 +178,8 @@ let arrow_packed_field base pf ty = ederef ty (ecast (TPtr(ty, [])) (eoffset payload pf.fi_offset)) (* (ty) __builtin_read_NN_reversed(&lval) *) -let bswap_read loc env lval ty = +let bswap_read loc env lval = + let ty = lval.etyp in let (bsize, aty) = accessor_type loc env ty in if bsize = 8 then lval else begin @@ -165,7 +192,8 @@ let bswap_read loc env lval ty = end (* __builtin_write_intNN_reversed(&lhs,rhs) *) -let bswap_write loc env lhs rhs ty = +let bswap_write loc env lhs rhs = + let ty = lhs.etyp in let (bsize, aty) = accessor_type loc env ty in if bsize = 8 then eassign lhs rhs else begin @@ -227,14 +255,31 @@ let transf_expr loc env ctx e = | EUnop(Odot _, _) | EUnop(Oarrow _, _) | EBinop(Oindex, _, _, _) -> let (e', swap) = lvalue e in - if swap then bswap_read loc env e' e'.etyp else e' + if swap then bswap_read loc env e' else e' - | EUnop((Oaddrof|Opreincr|Opredecr|Opostincr|Opostdecr as op), e1) -> + | EUnop(Oaddrof, e1) -> let (e1', swap) = lvalue e1 in if swap then - error "%a: Error: &, ++ and -- over byte-swapped field are not supported" - formatloc loc; - {edesc = EUnop(op, e1'); etyp = e.etyp} + error "%a: Error: & over byte-swapped field" formatloc loc; + {edesc = EUnop(Oaddrof, e1'); etyp = e.etyp} + + | EUnop((Opreincr|Opredecr) as op, e1) -> + let (e1', swap) = lvalue e1 in + if swap then + expand_preincrdecr + ~read:(bswap_read loc env) ~write:(bswap_write loc env) + env ctx op e1' + else + {edesc = EUnop(op, e1'); etyp = e.etyp} + + | EUnop((Opostincr|Opostdecr as op), e1) -> + let (e1', swap) = lvalue e1 in + if swap then + expand_postincrdecr + ~read:(bswap_read loc env) ~write:(bswap_write loc env) + env ctx op e1' + else + {edesc = EUnop(op, e1'); etyp = e.etyp} | EUnop(op, e1) -> {edesc = EUnop(op, texp Val e1); etyp = e.etyp} @@ -242,12 +287,9 @@ let transf_expr loc env ctx e = | EBinop(Oassign, e1, e2, ty) -> let (e1', swap) = lvalue e1 in let e2' = texp Val e2 in - if swap then begin - if ctx <> Effects then - error "%a: Error: assignment over byte-swapped field in value context is not supported" - formatloc loc; - bswap_write loc env e1' e2' e1'.etyp - end else + if swap then + expand_assign ~write:(bswap_write loc env) env ctx e1' e2' + else {edesc = EBinop(Oassign, e1', e2', ty); etyp = e.etyp} | EBinop((Oadd_assign|Osub_assign|Omul_assign|Odiv_assign|Omod_assign| @@ -256,9 +298,11 @@ let transf_expr loc env ctx e = let (e1', swap) = lvalue e1 in let e2' = texp Val e2 in if swap then - error "%a: Error: op-assignment over byte-swapped field is not supported" - formatloc loc; - {edesc = EBinop(op, e1', e2', ty); etyp = e.etyp} + expand_assignop + ~read:(bswap_read loc env) ~write:(bswap_write loc env) + env ctx op e1' e2' ty + else + {edesc = EBinop(op, e1', e2', ty); etyp = e.etyp} | EBinop(Ocomma, e1, e2, ty) -> {edesc = EBinop(Ocomma, texp Effects e1, texp Val e2, ty); @@ -291,29 +335,80 @@ let transf_fundef env f = (* Initializers *) -let rec check_init i = - match i with - | Init_single e -> true - | Init_array il -> List.for_all check_init il +let extract_byte env e i = + let ty = unary_conversion env e.etyp in + let e1 = + if i = 0 then e else + { edesc = EBinop(Oshr, e, intconst (Int64.of_int (i*8)) IInt, ty); + etyp = ty } in + { edesc = EBinop(Oand, e1, intconst 0xFFL IInt, ty); etyp = ty } + +let init_packed_struct loc env struct_id struct_sz initdata = + + let new_initdata = Array.make struct_sz (Init_single (intconst 0L IUChar)) in + + let enter_scalar pos e sz bigendian = + for i = 0 to sz - 1 do + let bytenum = if bigendian then sz - 1 - i else i in + new_initdata.(pos + i) <- Init_single(extract_byte env e bytenum) + done in + + let rec enter_init pos ty init bigendian = + match (unroll env ty, init) with + | (TInt(ik, _), Init_single e) -> + enter_scalar pos e (sizeof_ikind ik) bigendian + | (TPtr _, Init_single e) -> + enter_scalar pos e ((!Machine.config).sizeof_ptr) bigendian + | (TArray(ty_elt, _, _), Init_array il) -> + begin match sizeof env ty_elt with + | Some sz -> enter_init_array pos ty_elt sz il bigendian + | None -> fatal_error "%a: Internal error: incomplete type in init data" formatloc loc + end + | (_, _) -> + error "%a: Unsupported initializer for packed struct" formatloc loc + and enter_init_array pos ty sz il bigendian = + match il with + | [] -> () + | i1 :: il' -> + enter_init pos ty i1 bigendian; + enter_init_array (pos + sz) ty sz il' bigendian in + + let enter_field (fld, init) = + let finfo = + try Hashtbl.find packed_fields (struct_id, fld.fld_name) + with Not_found -> + fatal_error "%a: Internal error: non-packed field in packed struct" + formatloc loc in + enter_init finfo.fi_offset fld.fld_typ init + ((!Machine.config).bigendian <> finfo.fi_swap) in + + List.iter enter_field initdata; + + Init_struct(struct_id, [ + (payload_field struct_sz, Init_array (Array.to_list new_initdata)) + ]) + +let transf_init loc env i = + let rec trinit = function + | Init_single e as i -> i + | Init_array il -> Init_array (List.map trinit il) | Init_struct(id, fld_init_list) -> - List.for_all - (fun (f, i) -> - not (Hashtbl.mem packed_fields (id, f.fld_name))) - fld_init_list - | Init_union(id, fld, i) -> - check_init i + begin try + let sz = Hashtbl.find packed_structs id in + init_packed_struct loc env id sz fld_init_list + with Not_found -> + Init_struct(id, List.map (fun (f,i) -> (f, trinit i)) fld_init_list) + end + | Init_union(id, fld, i) -> Init_union(id, fld, trinit i) + in trinit i (* Declarations *) -let transf_decl loc env (sto, id, ty, init_opt as decl) = - begin match init_opt with - | None -> () - | Some i -> - if not (check_init i) then - error "%a: Error: Initialization of packed structs is not supported" - formatloc loc - end; - decl +let transf_decl loc env (sto, id, ty, init_opt) = + (sto, id, ty, + match init_opt with + | None -> None + | Some i -> Some (transf_init loc env i)) (* Pragmas *) diff --git a/cparser/SimplVolatile.ml b/cparser/SimplVolatile.ml index b155a3c..ef7a3a0 100644 --- a/cparser/SimplVolatile.ml +++ b/cparser/SimplVolatile.ml @@ -21,69 +21,6 @@ open C open Cutil open Transform -(* Expansion of read-write-modify constructs. *) - -(* Temporaries must not be [const] because we assign into them, - and should not be [volatile] because they are private. *) - -let mk_temp env ty = - new_temp (erase_attributes_type env ty) - -(** [l = r]. *) - -let mk_assign env ctx l r = - match ctx with - | Effects -> - eassign l r - | Val -> - let tmp = mk_temp env l.etyp in - ecomma (eassign tmp r) (ecomma (eassign l tmp) tmp) - -(** [l op= r]. Warning: [l] is evaluated twice. *) - -let mk_assignop env ctx op l r ty = - let op' = - match op with - | Oadd_assign -> Oadd | Osub_assign -> Osub - | Omul_assign -> Omul | Odiv_assign -> Odiv | Omod_assign -> Omod - | Oand_assign -> Oand | Oor_assign -> Oor | Oxor_assign -> Oxor - | Oshl_assign -> Oshl | Oshr_assign -> Oshr - | _ -> assert false in - let res = {edesc = EBinop(op', l, r, ty); etyp = ty} in - match ctx with - | Effects -> - eassign l res - | Val -> - let tmp = mk_temp env l.etyp in - ecomma (eassign tmp res) (ecomma (eassign l tmp) tmp) - -(** [++l] or [--l]. Warning: [l] is evaluated twice. *) - -let mk_preincrdecr env ctx op l ty = - let op' = - match op with - | Opreincr -> Oadd_assign - | Opredecr -> Osub_assign - | _ -> assert false in - mk_assignop env ctx op' l (intconst 1L IInt) ty - -(** [l++] or [l--]. Warning: [l] is evaluated twice. *) - -let mk_postincrdecr env ctx op l ty = - let op' = - match op with - | Opostincr -> Oadd - | Opostdecr -> Osub - | _ -> assert false in - match ctx with - | Effects -> - let newval = {edesc = EBinop(op', l, intconst 1L IInt, ty); etyp = ty} in - eassign l newval - | Val -> - let tmp = mk_temp env l.etyp in - let newval = {edesc = EBinop(op', tmp, intconst 1L IInt, ty); etyp = ty} in - ecomma (eassign tmp l) (ecomma (eassign l newval) tmp) - (* Rewriting of expressions *) let transf_expr loc env ctx e = @@ -97,22 +34,22 @@ let transf_expr loc env ctx e = | ESizeof _ -> e | EVar _ -> e | EUnop((Opreincr|Opredecr as op), e1) when is_volatile e1.etyp -> - bind_lvalue env (texp Val e1) - (fun l -> mk_preincrdecr env ctx op l (unary_conversion env l.etyp)) + expand_preincrdecr ~read:(fun e -> e) ~write:eassign + env ctx op (texp Val e1) | EUnop((Opostincr|Opostdecr as op), e1) when is_volatile e1.etyp -> - bind_lvalue env (texp Val e1) - (fun l -> mk_postincrdecr env ctx op l (unary_conversion env l.etyp)) + expand_postincrdecr ~read:(fun e -> e) ~write:eassign + env ctx op (texp Val e1) | EUnop(op, e1) -> {edesc = EUnop(op, texp Val e1); etyp = e.etyp} | EBinop(Oassign, e1, e2, ty) when is_volatile e1.etyp -> - mk_assign env ctx (texp Val e1) (texp Val e2) + expand_assign ~write:eassign env ctx (texp Val e1) (texp Val e2) | EBinop((Oadd_assign | Osub_assign | Omul_assign | Odiv_assign | Omod_assign | Oand_assign | Oor_assign | Oxor_assign | Oshl_assign | Oshr_assign) as op, e1, e2, ty) when is_volatile e1.etyp -> - bind_lvalue env (texp Val e1) - (fun l -> mk_assignop env ctx op l (texp Val e2) ty) + expand_assignop ~read:(fun e -> e) ~write:eassign + env ctx op (texp Val e1) (texp Val e2) ty | EBinop(Ocomma, e1, e2, ty) -> {edesc = EBinop(Ocomma, texp Effects e1, texp ctx e2, ty); etyp = e.etyp} diff --git a/cparser/Transform.ml b/cparser/Transform.ml index 8bdf2e2..0e7357b 100644 --- a/cparser/Transform.ml +++ b/cparser/Transform.ml @@ -26,6 +26,11 @@ let temporaries = ref ([]: decl list) let reset_temps () = temporaries := [] +let get_temps () = + let temps = !temporaries in + temporaries := []; + List.rev temps + let new_temp_var ?(name = "t") ty = let id = Env.fresh_ident name in temporaries := (Storage_default, id, ty, None) :: !temporaries; @@ -35,10 +40,13 @@ let new_temp ?(name = "t") ty = let id = new_temp_var ~name ty in { edesc = EVar id; etyp = ty } -let get_temps () = - let temps = !temporaries in - temporaries := []; - List.rev temps +(* Temporaries should not be [const] because we assign into them + and not be [volatile] because they are local and not observable *) + +let attributes_to_remove_from_temp = add_attributes [AConst] [AVolatile] + +let mk_temp env ?(name = "t") ty = + new_temp (remove_attributes_type env attributes_to_remove_from_temp ty) (* Bind a l-value to a temporary variable if it is not invariant. *) @@ -57,11 +65,81 @@ let bind_lvalue env e fn = (fn {edesc = EUnop(Oderef, tmp); etyp = e.etyp}) end -(* Generic transformation of a statement, transforming expressions within - and preserving the statement structure. Applies only to unblocked code. *) +(* Most transformations over expressions can be optimized if the + value of the expression is not needed and it is evaluated only + for its side-effects. The type [context] records whether + we are in a side-effects-only position ([Effects]) or not ([Val]). *) type context = Val | Effects +(* Expansion of assignment expressions *) + +let op_for_assignop = function + | Oadd_assign -> Oadd + | Osub_assign -> Osub + | Omul_assign -> Omul + | Odiv_assign -> Odiv + | Omod_assign -> Omod + | Oand_assign -> Oand + | Oor_assign -> Oor + | Oxor_assign -> Oxor + | Oshl_assign -> Oshl + | Oshr_assign -> Oshr + | _ -> assert false + +let op_for_incr_decr = function + | Opreincr -> Oadd + | Opredecr -> Osub + | Opostincr -> Oadd + | Opostdecr -> Osub + | _ -> assert false + +let assignop_for_incr_decr = function + | Opreincr -> Oadd_assign + | Opredecr -> Osub_assign + | _ -> assert false + +let expand_assign ~write env ctx l r = + match ctx with + | Effects -> + write l r + | Val -> + let tmp = mk_temp env l.etyp in + ecomma (eassign tmp r) (ecomma (write l tmp) tmp) + +let expand_assignop ~read ~write env ctx op l r ty = + bind_lvalue env l (fun l -> + let res = {edesc = EBinop(op_for_assignop op, read l, r, ty); etyp = ty} in + match ctx with + | Effects -> + write l res + | Val -> + let tmp = mk_temp env l.etyp in + ecomma (eassign tmp res) (ecomma (write l tmp) tmp)) + +let expand_preincrdecr ~read ~write env ctx op l = + expand_assignop ~read ~write env ctx (assignop_for_incr_decr op) + l (intconst 1L IInt) (unary_conversion env l.etyp) + +let expand_postincrdecr ~read ~write env ctx op l = + bind_lvalue env l (fun l -> + let ty = unary_conversion env l.etyp in + match ctx with + | Effects -> + let newval = + {edesc = EBinop(op_for_incr_decr op, read l, intconst 1L IInt, ty); + etyp = ty} in + write l newval + | Val -> + let tmp = mk_temp env l.etyp in + let newval = + {edesc = EBinop(op_for_incr_decr op, tmp, intconst 1L IInt, ty); + etyp = ty} in + ecomma (eassign tmp (read l)) (ecomma (write l newval) tmp)) + +(* Generic transformation of a statement, transforming expressions within + and preserving the statement structure. Applies only to unblocked code. *) + let stmt trexpr env s = let rec stm s = match s.sdesc with diff --git a/cparser/Transform.mli b/cparser/Transform.mli index 8215997..5736abc 100644 --- a/cparser/Transform.mli +++ b/cparser/Transform.mli @@ -15,18 +15,41 @@ (** Creation of fresh temporary variables. *) val reset_temps : unit -> unit +val get_temps : unit -> C.decl list val new_temp_var : ?name:string -> C.typ -> C.ident val new_temp : ?name:string -> C.typ -> C.exp -val get_temps : unit -> C.decl list +val mk_temp : Env.t -> ?name:string -> C.typ -> C.exp (** Avoiding repeated evaluation of a l-value *) val bind_lvalue: Env.t -> C.exp -> (C.exp -> C.exp) -> C.exp -(** Generic transformation of a statement *) +(* Most transformations over expressions can be optimized if the + value of the expression is not needed and it is evaluated only + for its side-effects. The type [context] records whether + we are in a side-effects-only position ([Effects]) or not ([Val]). *) type context = Val | Effects +(** Expansion of assignment expressions *) +val op_for_assignop : C.binary_operator -> C.binary_operator +val op_for_incr_decr : C.unary_operator -> C.binary_operator +val assignop_for_incr_decr : C.unary_operator -> C.binary_operator +val expand_assign : + write:(C.exp -> C.exp -> C.exp) -> + Env.t -> context -> C.exp -> C.exp -> C.exp +val expand_assignop : + read:(C.exp -> C.exp) -> write:(C.exp -> C.exp -> C.exp) -> + Env.t -> context -> C.binary_operator -> C.exp -> C.exp -> C.typ -> C.exp +val expand_preincrdecr : + read:(C.exp -> C.exp) -> write:(C.exp -> C.exp -> C.exp) -> + Env.t -> context -> C.unary_operator -> C.exp -> C.exp +val expand_postincrdecr : + read:(C.exp -> C.exp) -> write:(C.exp -> C.exp -> C.exp) -> + Env.t -> context -> C.unary_operator -> C.exp -> C.exp + +(** Generic transformation of a statement *) + val stmt : (C.location -> Env.t -> context -> C.exp -> C.exp) -> Env.t -> C.stmt -> C.stmt -- cgit v1.2.3