diff options
-rw-r--r-- | cparser/.depend | 166 | ||||
-rw-r--r-- | cparser/Bitfields.ml | 24 | ||||
-rw-r--r-- | cparser/Machine.ml | 6 | ||||
-rw-r--r-- | cparser/Machine.mli | 2 | ||||
-rw-r--r-- | cparser/PackedStructs.ml | 175 | ||||
-rw-r--r-- | cparser/SimplVolatile.ml | 77 | ||||
-rw-r--r-- | cparser/Transform.ml | 90 | ||||
-rw-r--r-- | cparser/Transform.mli | 27 | ||||
-rw-r--r-- | test/regression/Makefile | 2 | ||||
-rw-r--r-- | test/regression/Results/packedstruct1 | 5 | ||||
-rw-r--r-- | test/regression/Results/packedstruct2 | 6 | ||||
-rw-r--r-- | test/regression/packedstruct1.c | 9 | ||||
-rw-r--r-- | test/regression/packedstruct2.c | 69 |
13 files changed, 428 insertions, 230 deletions
diff --git a/cparser/.depend b/cparser/.depend index 2d6b2804..51f3b5ea 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 d16f91f0..c1b83cb7 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 ffff5fbd..03005825 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 f1d3567c..3becce33 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 7fc00675..30466cb0 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 b155a3c4..ef7a3a06 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 8bdf2e2e..0e7357b8 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 82159975..5736abc9 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 diff --git a/test/regression/Makefile b/test/regression/Makefile index 103901ed..044e5936 100644 --- a/test/regression/Makefile +++ b/test/regression/Makefile @@ -11,7 +11,7 @@ TESTS=attribs1 bitfields1 bitfields2 bitfields3 bitfields4 \ bitfields5 bitfields6 bitfields7 \ expr1 expr6 initializers volatile1 volatile2 volatile3 \ funct3 expr5 struct7 struct8 struct11 casts1 casts2 char1 \ - sizeof1 sizeof2 packedstruct1 + sizeof1 sizeof2 packedstruct1 packedstruct2 # Other tests: should compile to .s without errors (but expect warnings) EXTRAS=annot1 commaprec expr2 expr3 expr4 extern1 funct2 funptr1 init1 \ diff --git a/test/regression/Results/packedstruct1 b/test/regression/Results/packedstruct1 index 75491328..0595cc38 100644 --- a/test/regression/Results/packedstruct1 +++ b/test/regression/Results/packedstruct1 @@ -7,8 +7,9 @@ sizeof(struct s2) = 16 offsetof(x) = 0, offsetof(y) = 2, offsetof(z) = 6 s2 = {x = 57, y = -456, z = 3.14159} -sizeof(struct s3) = 29 -s3 = {x = 123, y = 45678, z = 2147483649, v = -456, w = -1234567, p is ok, t = {111,222,333}} +sizeof(struct s3) = 31 +offsetof(s) = 29 +s3 = {x = 123, y = 45678, z = 2147483649, v = -456, w = -1234567, p is ok, t = {111,222,333}, s = {'o','k'}} sizeof(struct s4) = 16 offsetof(x) = 0, offsetof(y) = 4, offsetof(z) = 8 diff --git a/test/regression/Results/packedstruct2 b/test/regression/Results/packedstruct2 new file mode 100644 index 00000000..360a5c6c --- /dev/null +++ b/test/regression/Results/packedstruct2 @@ -0,0 +1,6 @@ +s1 = {x = 2345, y = -12345678, z = 'x'} + +s3 = {x = 42, y = 123, z = 456789, v = -333, w = -314159, p is ok, t = {111,222,333}, s = {'o','k'}} + +s4 = {x = 123, y = -456789, z = 3.14159} + diff --git a/test/regression/packedstruct1.c b/test/regression/packedstruct1.c index cecd1f30..66c8c9e1 100644 --- a/test/regression/packedstruct1.c +++ b/test/regression/packedstruct1.c @@ -52,6 +52,7 @@ struct s3 { signed int w; char * p; unsigned int t[3]; + unsigned char s[2]; }; struct s3 s3; @@ -61,6 +62,7 @@ void test3(void) char xx; printf("sizeof(struct s3) = %d\n", sizeof(struct s3)); + printf("offsetof(s) = %d\n", offsetof(s3,s)); s3.x = 123; s3.y = 45678; s3.z = 0x80000001U; @@ -70,10 +72,13 @@ void test3(void) s3.t[0] = 111; s3.t[1] = 222; s3.t[2] = 333; - printf("s3 = {x = %u, y = %u, z = %u, v = %d, w = %d, p is %s, t = {%d,%d,%d}}\n\n", + s3.s[0] = 'o'; + s3.s[1] = 'k'; + printf("s3 = {x = %u, y = %u, z = %u, v = %d, w = %d, p is %s, t = {%d,%d,%d}, s = {'%c','%c'}}\n\n", s3.x, s3.y, s3.z, s3.v, s3.w, (s3.p == &xx ? "ok" : "BAD"), - s3.t[0], s3.t[1], s3.t[2]); + s3.t[0], s3.t[1], s3.t[2], + s3.s[0], s3.s[1]); } /* Back to normal */ diff --git a/test/regression/packedstruct2.c b/test/regression/packedstruct2.c new file mode 100644 index 00000000..0c383a47 --- /dev/null +++ b/test/regression/packedstruct2.c @@ -0,0 +1,69 @@ +/* Initialization of packed structs */ + +#include <stdio.h> + +/* Simple packing */ + +#pragma pack(1) + +struct s1 { unsigned short x; int y; char z; }; + +struct s1 s1 = { 2345, -12345678, 'x' }; + +void test1(void) +{ + printf("s1 = {x = %d, y = %d, z = '%c'}\n\n", s1.x, s1.y, s1.z); +} + +/* Now with byte-swapped fields */ + +#pragma pack(1,1,1) + +struct s3 { + unsigned char x; + unsigned short y; + unsigned int z; + signed short v; + signed int w; + char * p; + unsigned int t[3]; + unsigned char s[2]; +}; + +struct s3 s3 = { + 42, 123, 456789, -333, -314159, 0, + { 111, 222, 333 }, + { 'o', 'k' } +}; + +void test3(void) +{ + printf("s3 = {x = %u, y = %u, z = %u, v = %d, w = %d, p is %s, t = {%d,%d,%d}, s = {'%c','%c'}}\n\n", + s3.x, s3.y, s3.z, s3.v, s3.w, + (s3.p == 0 ? "ok" : "BAD"), + s3.t[0], s3.t[1], s3.t[2], + s3.s[0], s3.s[1]); +} + +/* Back to normal */ + +#pragma pack() + +struct s4 { unsigned short x; int y; double z; }; + +struct s4 s4 = { 123, -456789, 3.14159 }; + +void test4(void) +{ + printf("s4 = {x = %d, y = %d, z = %.5f}\n\n", s4.x, s4.y, s4.z); +} + +/* Test harness */ + +int main(int argc, char ** argv) +{ + test1(); + test3(); + test4(); + return 0; +} |