Commit 60b6624a authored by xleroy's avatar xleroy
Browse files

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
parent 015c64c6
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
......@@ -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 =
......
......@@ -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 *)
......
......@@ -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
......
......@@ -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 *)
......
......@@ -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
|