From a15858a0a8fcea82db02fe8c9bd2ed912210419f Mon Sep 17 00:00:00 2001 From: xleroy Date: Wed, 18 Aug 2010 09:06:55 +0000 Subject: Merge of branches/full-expr-4: - Csyntax, Csem: source C language has side-effects within expressions, performs implicit casts, and has nondeterministic reduction semantics for expressions - Cstrategy: deterministic red. sem. for the above - Clight: the previous source C language, with pure expressions. Added: temporary variables + implicit casts. - New pass SimplExpr to pull side-effects out of expressions (previously done in untrusted Caml code in cparser/) - Csharpminor: added temporary variables to match Clight. - Cminorgen: adapted, removed cast optimization (moved to back-end) - CastOptim: RTL-level optimization of casts - cparser: transformations Bitfields, StructByValue and StructAssign now work on non-simplified expressions - Added pretty-printers for several intermediate languages, and matching -dxxx command-line flags. git-svn-id: https://yquem.inria.fr/compcert/svn/compcert/trunk@1467 fca1b0fc-160b-0410-b1d3-a4f43f01ea2e --- cparser/Bitfields.ml | 273 +++++++++++++++++++++++++++++++---------------- cparser/Cutil.ml | 15 ++- cparser/Cutil.mli | 6 ++ cparser/Makefile | 4 +- cparser/Parse.ml | 6 +- cparser/StructAssign.ml | 143 +++++++++++++++++++------ cparser/StructByValue.ml | 187 +++++++++++++++++++++----------- 7 files changed, 440 insertions(+), 194 deletions(-) (limited to 'cparser') diff --git a/cparser/Bitfields.ml b/cparser/Bitfields.ml index dea1862..2abe6b1 100644 --- a/cparser/Bitfields.ml +++ b/cparser/Bitfields.ml @@ -175,107 +175,194 @@ let bitfield_assign bf carrier newval = {edesc = EBinop(Oor, oldval_masked, newval_masked, TInt(IUInt,[])); etyp = TInt(IUInt,[])} -(* Expressions *) +(* Detect invariant l-values *) + +let rec invariant_lvalue e = + match e.edesc with + | EVar _ -> true + | EUnop(Oderef, {edesc = EVar _}) -> true (* to check *) + | EUnop(Odot _, e1) -> invariant_lvalue e1 + | _ -> false + +(* Bind a l-value to a temporary variable if it is not invariant. *) + +let bind_lvalue e fn = + if invariant_lvalue e then + fn e + else begin + let tmp = new_temp (TPtr(e.etyp, [])) in + ecomma (eassign tmp (eaddrof e)) + (fn {edesc = EUnop(Oderef, tmp); etyp = e.etyp}) + end + +(* Transformation of operators *) + +let op_for_incr_decr = function + | Opreincr -> Oadd + | Opredecr -> Osub + | Opostincr -> Oadd + | Opostdecr -> Osub + | _ -> assert false -let transf_expr env e = +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 is_bitfield_access ty fieldname = - match unroll env ty with - | TStruct(id, _) -> - (try Some(Hashtbl.find bitfield_table (id, fieldname)) - with Not_found -> None) - | _ -> None in +(* 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 + | 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, _) -> + is_bitfield_access env + {edesc = EUnop(Odot fieldname, + {edesc = EUnop(Oderef, e1); etyp = ty}); + etyp = e.etyp} + | _ -> + None + end + | _ -> None - let is_bitfield_access_ptr ty fieldname = - match unroll env ty with - | TPtr(ty', _) -> is_bitfield_access ty' fieldname - | _ -> None in +(* Expressions *) - let rec texp e = +type context = Val | Effects + +let transf_expr env ctx e = + + let rec texp ctx e = match e.edesc with | EConst _ -> e | ESizeof _ -> e | EVar _ -> e - | EUnop(Odot fieldname, e1) -> - let e1' = texp e1 in - begin match is_bitfield_access e1.etyp fieldname with + | EUnop(Odot s, e1) -> + begin match is_bitfield_access env e with | None -> - {edesc = EUnop(Odot fieldname, e1'); etyp = e.etyp} - | Some bf -> - bitfield_extract bf - {edesc = EUnop(Odot bf.bf_carrier, e1'); - etyp = bf.bf_carrier_typ} + {edesc = EUnop(Odot s, texp Val e1); etyp = e.etyp} + | Some(ex, bf) -> + transf_read ex bf end - - | EUnop(Oarrow fieldname, e1) -> - let e1' = texp e1 in - begin match is_bitfield_access_ptr e1.etyp fieldname with + | EUnop(Oarrow s, e1) -> + begin match is_bitfield_access env e with | None -> - {edesc = EUnop(Oarrow fieldname, e1'); etyp = e.etyp} - | Some bf -> - bitfield_extract bf - {edesc = EUnop(Oarrow bf.bf_carrier, e1'); - etyp = bf.bf_carrier_typ} + {edesc = EUnop(Oarrow s, texp Val e1); etyp = e.etyp} + | Some(ex, bf) -> + transf_read ex bf end - - | EUnop(op, e1) -> - (* Note: simplified expr, so no ++/-- *) - {edesc = EUnop(op, texp e1); etyp = e.etyp} + | EUnop((Opreincr|Opredecr) as op, e1) -> + begin match is_bitfield_access env e1 with + | None -> + {edesc = EUnop(op, texp Val e1); etyp = e.etyp} + | Some(ex, bf) -> + transf_pre 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, texp Val e1); etyp = e.etyp} + | Some(ex, bf) -> + transf_post ctx (op_for_incr_decr op) ex bf e1.etyp + end + | EUnop(op, e1) -> + {edesc = EUnop(op, texp Val e1); etyp = e.etyp} | EBinop(Oassign, e1, e2, ty) -> - begin match e1.edesc with - | EUnop(Odot fieldname, e11) -> - let lhs = texp e11 in let rhs = texp e2 in - begin match is_bitfield_access e11.etyp fieldname with - | None -> - {edesc = EBinop(Oassign, - {edesc = EUnop(Odot fieldname, lhs); - etyp = e1.etyp}, - rhs, ty); - etyp = e.etyp} - | Some bf -> - let carrier = - {edesc = EUnop(Odot bf.bf_carrier, lhs); - etyp = bf.bf_carrier_typ} in - {edesc = EBinop(Oassign, carrier, - bitfield_assign bf carrier rhs, - carrier.etyp); - etyp = carrier.etyp} - end - | EUnop(Oarrow fieldname, e11) -> - let lhs = texp e11 in let rhs = texp e2 in - begin match is_bitfield_access_ptr e11.etyp fieldname with - | None -> - {edesc = EBinop(Oassign, - {edesc = EUnop(Oarrow fieldname, lhs); - etyp = e1.etyp}, - rhs, ty); - etyp = e.etyp} - | Some bf -> - let carrier = - {edesc = EUnop(Oarrow bf.bf_carrier, lhs); - etyp = bf.bf_carrier_typ} in - {edesc = EBinop(Oassign, carrier, - bitfield_assign bf carrier rhs, - carrier.etyp); - etyp = carrier.etyp} - end - | _ -> - {edesc = EBinop(Oassign, texp e1, texp e2, e1.etyp); etyp = e1.etyp} + begin match is_bitfield_access env e1 with + | None -> + {edesc = EBinop(Oassign, texp Val e1, texp Val e2, ty); + etyp = e.etyp} + | Some(ex, bf) -> + transf_assign 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, texp Val e1, texp Val e2, ty); etyp = e.etyp} + | Some(ex, bf) -> + transf_assignop ctx (op_for_assignop op) ex bf e2 ty + end + | EBinop(Ocomma, e1, e2, ty) -> + {edesc = EBinop(Ocomma, texp Effects e1, texp Val e2, ty); + etyp = e.etyp} | EBinop(op, e1, e2, ty) -> - (* Note: simplified expr assumed, so no assign-op *) - {edesc = EBinop(op, texp e1, texp e2, ty); etyp = e.etyp} + {edesc = EBinop(op, texp Val e1, texp Val e2, ty); etyp = e.etyp} + | EConditional(e1, e2, e3) -> - {edesc = EConditional(texp e1, texp e2, texp e3); etyp = e.etyp} + {edesc = EConditional(texp Val e1, texp ctx e2, texp ctx e3); + etyp = e.etyp} | ECast(ty, e1) -> - {edesc = ECast(ty, texp e1); etyp = e.etyp} + {edesc = ECast(ty, texp Val e1); etyp = e.etyp} | ECall(e1, el) -> - {edesc = ECall(texp e1, List.map texp el); etyp = e.etyp} - - in texp e + {edesc = ECall(texp Val e1, List.map (texp Val) el); etyp = e.etyp} + + and transf_read e bf = + bitfield_extract bf + {edesc = EUnop(Odot bf.bf_carrier, texp Val e); etyp = bf.bf_carrier_typ} + + and transf_assign ctx e1 bf e2 = + bind_lvalue (texp 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 bf carrier (texp Val e2)) in + if ctx = Val then ecomma asg (bitfield_extract bf carrier) else asg) + + and transf_assignop ctx op e1 bf e2 tyres = + bind_lvalue (texp 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 bf carrier, texp Val e2, tyres); + etyp = tyres} in + let asg = + eassign carrier (bitfield_assign bf carrier rhs) in + if ctx = Val then ecomma asg (bitfield_extract bf carrier) else asg) + + and transf_pre ctx op e1 bf tyfield = + transf_assignop ctx op e1 bf (intconst 1L IInt) + (unary_conversion env tyfield) + + and transf_post ctx op e1 bf tyfield = + if ctx = Effects then + transf_pre ctx op e1 bf tyfield + else begin + bind_lvalue (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 tyres = unary_conversion env tyfield in + let settemp = eassign temp (bitfield_extract bf carrier) in + let rhs = + {edesc = EBinop(op, temp, intconst 1L IInt, tyres); etyp = tyres} in + let asg = + eassign carrier (bitfield_assign bf carrier rhs) in + ecomma (ecomma settemp asg) temp) + end + + in texp ctx e (* Statements *) @@ -283,39 +370,43 @@ let rec transf_stmt env s = match s.sdesc with | Sskip -> s | Sdo e -> - {sdesc = Sdo(transf_expr env e); sloc = s.sloc} + {sdesc = Sdo(transf_expr env Effects e); sloc = s.sloc} | Sseq(s1, s2) -> {sdesc = Sseq(transf_stmt env s1, transf_stmt env s2); sloc = s.sloc } | Sif(e, s1, s2) -> - {sdesc = Sif(transf_expr env e, transf_stmt env s1, transf_stmt env s2); + {sdesc = Sif(transf_expr env Val e, transf_stmt env s1, transf_stmt env s2); sloc = s.sloc} | Swhile(e, s1) -> - {sdesc = Swhile(transf_expr env e, transf_stmt env s1); + {sdesc = Swhile(transf_expr env Val e, transf_stmt env s1); sloc = s.sloc} | Sdowhile(s1, e) -> - {sdesc = Sdowhile(transf_stmt env s1, transf_expr env e); + {sdesc = Sdowhile(transf_stmt env s1, transf_expr env Val e); sloc = s.sloc} | Sfor(s1, e, s2, s3) -> - {sdesc = Sfor(transf_stmt env s1, transf_expr env e, transf_stmt env s2, - transf_stmt env s3); + {sdesc = Sfor(transf_stmt env s1, transf_expr env Val e, + transf_stmt env s2, transf_stmt env s3); sloc = s.sloc} | Sbreak -> s | Scontinue -> s | Sswitch(e, s1) -> - {sdesc = Sswitch(transf_expr env e, transf_stmt env s1); sloc = s.sloc} + {sdesc = Sswitch(transf_expr env Val e, transf_stmt env s1); + sloc = s.sloc} | Slabeled(lbl, s) -> {sdesc = Slabeled(lbl, transf_stmt env s); sloc = s.sloc} | Sgoto lbl -> s | Sreturn None -> s | Sreturn (Some e) -> - {sdesc = Sreturn(Some(transf_expr env e)); sloc = s.sloc} + {sdesc = Sreturn(Some(transf_expr env Val e)); sloc = s.sloc} | Sblock _ | Sdecl _ -> assert false (* should not occur in unblocked code *) (* Functions *) let transf_fundef env f = - { f with fd_body = transf_stmt env f.fd_body } + reset_temps(); + let newbody = transf_stmt env f.fd_body in + let temps = get_temps() in + { f with fd_locals = f.fd_locals @ temps; fd_body = newbody } (* Initializers *) @@ -374,7 +465,7 @@ let rec transf_struct_init id fld_init_list = let rec transf_init env i = match i with - | Init_single e -> Init_single (transf_expr env e) + | Init_single e -> Init_single (transf_expr env Val e) | Init_array il -> Init_array (List.map (transf_init env) il) | Init_struct(id, fld_init_list) -> let fld_init_list' = diff --git a/cparser/Cutil.ml b/cparser/Cutil.ml index 49b25a2..c7c5e30 100644 --- a/cparser/Cutil.ml +++ b/cparser/Cutil.ml @@ -655,6 +655,18 @@ let floatconst v fk = let nullconst = { edesc = EConst(CInt(0L, ptr_t_ikind, "0")); etyp = TPtr(TVoid [], []) } +(* Construct an address-of expression *) + +let eaddrof e = { edesc = EUnop(Oaddrof, e); etyp = TPtr(e.etyp, []) } + +(* Construct an assignment expression *) + +let eassign e1 e2 = { edesc = EBinop(Oassign, e1, e2, e1.etyp); etyp = e1.etyp } + +(* Construct a "," expression *) + +let ecomma e1 e2 = { edesc = EBinop(Ocomma, e1, e2, e2.etyp); etyp = e2.etyp } + (* Construct a sequence *) let sseq loc s1 s2 = @@ -667,8 +679,7 @@ let sseq loc s1 s2 = (* Construct an assignment statement *) let sassign loc lv rv = - { sdesc = Sdo {edesc = EBinop(Oassign, lv, rv, lv.etyp); etyp = lv.etyp}; - sloc = loc } + { sdesc = Sdo (eassign lv rv); sloc = loc } (* Empty location *) diff --git a/cparser/Cutil.mli b/cparser/Cutil.mli index 9587c57..2e61cf5 100644 --- a/cparser/Cutil.mli +++ b/cparser/Cutil.mli @@ -155,6 +155,12 @@ val floatconst : float -> fkind -> exp (* Build expression for given float constant. *) val nullconst : exp (* Expression for [(void * ) 0] *) +val eaddrof : exp -> exp + (* Expression for [&e] *) +val eassign : exp -> exp -> exp + (* Expression for [e1 = e2] *) +val ecomma : exp -> exp -> exp + (* Expression for [e1, e2] *) val sskip: stmt (* The [skip] statement. No location. *) val sseq : location -> stmt -> stmt -> stmt diff --git a/cparser/Makefile b/cparser/Makefile index 59d4b47..f4c1274 100644 --- a/cparser/Makefile +++ b/cparser/Makefile @@ -40,7 +40,7 @@ cparser.byte: $(COBJS) $(BOBJS) Main.cmo $(OCAMLC) -custom -o cparser.byte str.cma $(COBJS) $(BOBJS) Main.cmo clean:: - rm -f cparser + rm -f cparser.byte cparser.cma libcparser.a: uint64.o Cparser.cmo $(OCAMLMKLIB) -o cparser uint64.o Cparser.cmo @@ -82,7 +82,7 @@ beforedepend:: Lexer.ml $(OCAMLC) -c $*.c clean:: - rm -f *.cm? *.o *.so + rm -f *.cm? *.cmxa *.o *.so *.a depend: beforedepend $(OCAMLDEP) *.mli *.ml > .depend diff --git a/cparser/Parse.ml b/cparser/Parse.ml index 7dcc8d1..ed988f9 100644 --- a/cparser/Parse.ml +++ b/cparser/Parse.ml @@ -21,10 +21,10 @@ let transform_program t p = let run_pass pass flag p = if CharSet.mem flag t then pass p else p in Rename.program (run_pass (AddCasts.program ~all:(CharSet.mem 'C' t)) 'c' + (run_pass (SimplExpr.program ~volatile:(CharSet.mem 'v' t)) 'e' (run_pass StructAssign.program 'S' (run_pass StructByValue.program 's' (run_pass Bitfields.program 'f' - (run_pass (SimplExpr.program ~volatile:(CharSet.mem 'v' t)) 'e' (run_pass Unblock.program 'b' p)))))) @@ -37,9 +37,9 @@ let parse_transformations s = | 'c' -> set "ec" | 'C' -> set "ecC" | 's' -> set "s" - | 'S' -> set "esS" + | 'S' -> set "bsS" | 'v' -> set "ev" - | 'f' -> set "bef" + | 'f' -> set "bf" | _ -> ()) s; !t diff --git a/cparser/StructAssign.ml b/cparser/StructAssign.ml index 725c136..51cb489 100644 --- a/cparser/StructAssign.ml +++ b/cparser/StructAssign.ml @@ -15,17 +15,23 @@ (* Expand assignments between structs and between unions *) -(* Assumes: simplified code. - Preserves: simplified code, unblocked code *) +(* Assumes: unblocked code. + Preserves: unblocked code *) open C open Machine open Cutil open Env open Errors +open Transform + +(* Max number of assignments that can be inlined. Above this threshold, + we call memcpy() instead. *) let maxsize = ref 8 +(* Finding appropriate memcpy functions *) + let memcpy_decl = ref (None : ident option) let memcpy_type = @@ -57,7 +63,18 @@ let memcpy_words_ident env = try lookup_function env "__builtin_memcpy_words" with Env.Error _ -> memcpy_ident env -let transf_assign env loc lhs rhs = +(* Smart constructor for "," expressions *) + +let comma e1 e2 = + match e1.edesc, e2.edesc with + | EConst _, _ -> e2 + | _, EConst _ -> e1 + | _, _ -> ecomma e1 e2 + +(* Translate an assignment [lhs = rhs] between composite types. + [lhs] and [rhs] must be pure, invariant l-values. *) + +let transf_assign env lhs rhs = let num_assign = ref 0 in @@ -65,38 +82,35 @@ let transf_assign env loc lhs rhs = incr num_assign; if !num_assign > !maxsize then raise Exit - else sassign loc l r in + else eassign l r in let rec transf l r = match unroll env l.etyp with | TStruct(id, attr) -> let ci = Env.find_struct env id in - if ci.ci_sizeof = None then - error "%a: Error: incomplete struct '%s'" formatloc loc id.name; transf_struct l r ci.ci_members | TUnion(id, attr) -> raise Exit | TArray(ty_elt, Some sz, attr) -> transf_array l r ty_elt 0L sz | TArray(ty_elt, None, attr) -> - error "%a: Error: array of unknown size" formatloc loc; - sskip (* will be ignored later *) + assert false | _ -> assign l r and transf_struct l r = function - | [] -> sskip + | [] -> nullconst | f :: fl -> - sseq loc (transf {edesc = EUnop(Odot f.fld_name, l); etyp = f.fld_typ} - {edesc = EUnop(Odot f.fld_name, r); etyp = f.fld_typ}) - (transf_struct l r fl) + comma (transf {edesc = EUnop(Odot f.fld_name, l); etyp = f.fld_typ} + {edesc = EUnop(Odot f.fld_name, r); etyp = f.fld_typ}) + (transf_struct l r fl) and transf_array l r ty idx sz = - if idx >= sz then sskip else begin + if idx >= sz then nullconst else begin let e = intconst idx size_t_ikind in - sseq loc (transf {edesc = EBinop(Oindex, l, e, ty); etyp = ty} - {edesc = EBinop(Oindex, r, e, ty); etyp = ty}) - (transf_array l r ty (Int64.add idx 1L) sz) + comma (transf {edesc = EBinop(Oindex, l, e, ty); etyp = ty} + {edesc = EBinop(Oindex, r, e, ty); etyp = ty}) + (transf_array l r ty (Int64.add idx 1L) sz) end in @@ -115,42 +129,101 @@ let transf_assign env loc lhs rhs = let e_lhs = {edesc = EUnop(Oaddrof, lhs); etyp = TPtr(lhs.etyp, [])} in let e_rhs = {edesc = EUnop(Oaddrof, rhs); etyp = TPtr(rhs.etyp, [])} in let e_size = {edesc = ESizeof(lhs.etyp); etyp = TInt(size_t_ikind, [])} in - {sdesc = Sdo {edesc = ECall(memcpy, [e_lhs; e_rhs; e_size]); - etyp = TVoid[]}; - sloc = loc} + {edesc = ECall(memcpy, [e_lhs; e_rhs; e_size]); etyp = TVoid[]} + +(* Detect invariant l-values *) + +let rec invariant_lvalue e = + match e.edesc with + | EVar _ -> true + | EUnop(Oderef, {edesc = EVar _}) -> true (* to check *) + | EUnop(Odot _, e1) -> invariant_lvalue e1 + | _ -> false + +(* Bind a l-value to a temporary variable if it is not invariant. *) + +let rec bind_lvalue e fn = + match e.edesc with + | EBinop(Ocomma, e1, e2, _) -> + ecomma e1 (bind_lvalue e2 fn) + | _ -> + if invariant_lvalue e then + fn e + else begin + let tmp = new_temp (TPtr(e.etyp, [])) in + ecomma (eassign tmp (eaddrof e)) + (fn {edesc = EUnop(Oderef, tmp); etyp = e.etyp}) + end + +(* Transformation of expressions. *) + +type context = Val | Effects + +let rec transf_expr env ctx e = + match e.edesc with + | EBinop(Oassign, lhs, rhs, _) when is_composite_type env lhs.etyp -> + bind_lvalue (transf_expr env Val lhs) (fun l -> + bind_lvalue (transf_expr env Val rhs) (fun r -> + let e' = transf_assign env l r in + if ctx = Val then ecomma e' l else e')) + | EConst c -> e + | ESizeof ty -> e + | EVar x -> e + | EUnop(op, e1) -> + {edesc = EUnop(op, transf_expr env Val e1); etyp = e.etyp} + | EBinop(Ocomma, e1, e2, ty) -> + {edesc = EBinop(Ocomma, transf_expr env Effects e1, + transf_expr env ctx e2, ty); + etyp = e.etyp} + | EBinop(op, e1, e2, ty) -> + {edesc = EBinop(op, transf_expr env Val e1, + transf_expr env Val e2, ty); + etyp = e.etyp} + | EConditional(e1, e2, e3) -> + {edesc = EConditional(transf_expr env Val e1, + transf_expr env ctx e2, transf_expr env ctx e3); + etyp = e.etyp} + | ECast(ty, e1) -> + {edesc = ECast(ty, transf_expr env Val e1); etyp = e.etyp} + | ECall(e1, el) -> + {edesc = ECall(transf_expr env Val e1, + List.map (transf_expr env Val) el); + etyp = e.etyp} + +(* Transformation of statements *) let rec transf_stmt env s = match s.sdesc with | Sskip -> s - | Sdo {edesc = EBinop(Oassign, lhs, rhs, _)} - when is_composite_type env lhs.etyp -> - transf_assign env s.sloc lhs rhs - | Sdo _ -> s + | Sdo e -> {s with sdesc = Sdo(transf_expr env Effects e)} | Sseq(s1, s2) -> {s with sdesc = Sseq(transf_stmt env s1, transf_stmt env s2)} | Sif(e, s1, s2) -> - {s with sdesc = Sif(e, transf_stmt env s1, transf_stmt env s2)} + {s with sdesc = Sif(transf_expr env Val e, + transf_stmt env s1, transf_stmt env s2)} | Swhile(e, s1) -> - {s with sdesc = Swhile(e, transf_stmt env s1)} + {s with sdesc = Swhile(transf_expr env Val e, transf_stmt env s1)} | Sdowhile(s1, e) -> - {s with sdesc = Sdowhile(transf_stmt env s1, e)} + {s with sdesc = Sdowhile(transf_stmt env s1, transf_expr env Val e)} | Sfor(s1, e, s2, s3) -> - {s with sdesc = Sfor(transf_stmt env s1, e, + {s with sdesc = Sfor(transf_stmt env s1, transf_expr env Val e, transf_stmt env s2, transf_stmt env s3)} | Sbreak -> s | Scontinue -> s | Sswitch(e, s1) -> - {s with sdesc = Sswitch(e, transf_stmt env s1)} + {s with sdesc = Sswitch(transf_expr env Val e, transf_stmt env s1)} | Slabeled(lbl, s1) -> {s with sdesc = Slabeled(lbl, transf_stmt env s1)} | Sgoto lbl -> s - | Sreturn _ -> s - | Sblock sl -> - {s with sdesc = Sblock(List.map (transf_stmt env) sl)} - | Sdecl d -> s - -let transf_fundef env fd = - {fd with fd_body = transf_stmt env fd.fd_body} + | Sreturn None -> s + | Sreturn (Some e) -> {s with sdesc = Sreturn(Some(transf_expr env Val e))} + | Sblock _ | Sdecl _ -> assert false (* not in unblocked code *) + +let transf_fundef env f = + reset_temps(); + let newbody = transf_stmt env f.fd_body in + let temps = get_temps() in + {f with fd_locals = f.fd_locals @ temps; fd_body = newbody} let program p = memcpy_decl := None; diff --git a/cparser/StructByValue.ml b/cparser/StructByValue.ml index de79737..c66af32 100644 --- a/cparser/StructByValue.ml +++ b/cparser/StructByValue.ml @@ -16,7 +16,7 @@ (* Eliminate by-value passing of structs and unions. *) (* Assumes: nothing. - Preserves: simplified code, unblocked code *) + Preserves: unblocked code *) open C open Cutil @@ -55,30 +55,126 @@ and transf_funarg env (id, t) = then (id, TPtr(add_attributes_type [AConst] t, [])) else (id, t) -(* Simple exprs: no change in structure, since calls cannot occur within, - but need to rewrite the types. *) - -let rec transf_expr env e = - { etyp = transf_type env e.etyp; - edesc = match e.edesc with - | EConst c -> EConst c - | ESizeof ty -> ESizeof (transf_type env ty) - | EVar x -> EVar x - | EUnop(op, e1) -> EUnop(op, transf_expr env e1) - | EBinop(op, e1, e2, ty) -> - EBinop(op, transf_expr env e1, transf_expr env e2, transf_type env ty) - | EConditional(e1, e2, e3) -> - assert (not (is_composite_type env e.etyp)); - EConditional(transf_expr env e1, transf_expr env e2, transf_expr env e3) - | ECast(ty, e1) -> ECast(transf_type env ty, transf_expr env e1) - | ECall(e1, el) -> assert false - } +(* Expressions: transform calls + rewrite the types *) + +type context = Val | Effects + +let rec transf_expr env ctx e = + let newty = transf_type env e.etyp in + match e.edesc with + | EConst c -> + {edesc = EConst c; etyp = newty} + | ESizeof ty -> + {edesc = ESizeof (transf_type env ty); etyp = newty} + | EVar x -> + {edesc = EVar x; etyp = newty} + | EUnop(op, e1) -> + {edesc = EUnop(op, transf_expr env Val e1); etyp = newty} + | EBinop(Oassign, lhs, {edesc = ECall(fn, args)}, ty) + when is_composite_type env ty -> + transf_composite_call env ctx (Some lhs) fn args ty + | EBinop(Ocomma, e1, e2, ty) -> + {edesc = EBinop(Ocomma, transf_expr env Effects e1, + transf_expr env ctx e2, + transf_type env ty); + etyp = newty} + | EBinop(op, e1, e2, ty) -> + {edesc = EBinop(op, transf_expr env Val e1, + transf_expr env Val e2, + transf_type env ty); + etyp = newty} + | EConditional(e1, e2, e3) -> + {edesc = EConditional(transf_expr env Val e1, + transf_expr env ctx e2, + transf_expr env ctx e3); + etyp = newty} + | ECast(ty, e1) -> + {edesc = ECast(transf_type env ty, transf_expr env Val e1); etyp = newty} + | ECall(fn, args) -> + if is_composite_type env e.etyp then + transf_composite_call env ctx None fn args e.etyp + else + {edesc = ECall(transf_expr env Val fn, List.map (transf_arg env) args); + etyp = newty} + +(* Function arguments: pass by reference those having composite type *) + +and transf_arg env e = + let e' = transf_expr env Val e in + if is_composite_type env e'.etyp then eaddrof e' else e' + +(* Function calls returning a composite: add first argument. + ctx = Effects: lv = f(...) -> f(&lv, ...) + f(...) -> f(&newtemp, ...) + ctx = Val: lv = f(...) -> f(&newtemp, ...), lv = newtemp, newtemp + f(...) -> f(&newtemp, ...), newtemp +*) + +and transf_composite_call env ctx opt_lhs fn args ty = + let ty = transf_type env ty in + let fn = transf_expr env Val fn in + let args = List.map (transf_arg env) args in + match ctx, opt_lhs with + | Effects, None -> + let tmp = new_temp ~name:"_res" ty in + {edesc = ECall(fn, eaddrof tmp :: args); etyp = TVoid []} + | Effects, Some lhs -> + let lhs = transf_expr env Val lhs in + {edesc = ECall(fn, eaddrof lhs :: args); etyp = TVoid []} + | Val, None -> + let tmp = new_temp ~name:"_res" ty in + ecomma {edesc = ECall(fn, eaddrof tmp :: args); etyp = TVoid []} tmp + | Val, Some lhs -> + let lhs = transf_expr env Val lhs in + let tmp = new_temp ~name:"_res" ty in + ecomma (ecomma {edesc = ECall(fn, eaddrof tmp :: args); etyp = TVoid []} + (eassign lhs tmp)) + tmp + +(* The transformation above can create ill-formed lhs containing ",", as in + f().x = y ---> (f(&tmp), tmp).x = y + f(g(x)); ---> f(&(g(&tmp),tmp)) + We fix this by floating the "," above the lhs, up to the nearest enclosing + rhs: + f().x = y ---> (f(&tmp), tmp).x = y --> f(&tmp), tmp.x = y + f(g(x)); ---> f(&(g(&tmp),tmp)) --> f((g(&tmp), &tmp)) +*) + +let rec float_comma e = + match e.edesc with + | EConst c -> e + | ESizeof ty -> e + | EVar x -> e + (* lvalue-consuming unops *) + | EUnop((Oaddrof|Opreincr|Opredecr|Opostincr|Opostdecr|Odot _) as op, + {edesc = EBinop(Ocomma, e1, e2, _)}) -> + ecomma (float_comma e1) + (float_comma {edesc = EUnop(op, e2); etyp = e.etyp}) + (* lvalue-consuming binops *) + | EBinop((Oassign|Oadd_assign|Osub_assign|Omul_assign|Odiv_assign + |Omod_assign|Oand_assign|Oor_assign|Oxor_assign + |Oshl_assign|Oshr_assign) as op, + {edesc = EBinop(Ocomma, e1, e2, _)}, e3, tyres) -> + ecomma (float_comma e1) + (float_comma {edesc = EBinop(op, e2, e3, tyres); etyp = e.etyp}) + (* other expressions *) + | EUnop(op, e1) -> + {edesc = EUnop(op, float_comma e1); etyp = e.etyp} + | EBinop(op, e1, e2, tyres) -> + {edesc = EBinop(op, float_comma e1, float_comma e2, tyres); etyp = e.etyp} + | EConditional(e1, e2, e3) -> + {edesc = EConditional(float_comma e1, float_comma e2, float_comma e3); + etyp = e.etyp} + | ECast(ty, e1) -> + {edesc = ECast(ty, float_comma e1); etyp = e.etyp} + | ECall(e1, el) -> + {edesc = ECall(float_comma e1, List.map float_comma el); etyp = e.etyp} (* Initializers *) let rec transf_init env = function | Init_single e -> - Init_single (transf_expr env e) + Init_single (float_comma(transf_expr env Val e)) | Init_array il -> Init_array (List.map (transf_init env) il) | Init_struct(id, fil) -> @@ -96,70 +192,39 @@ let transf_decl env (sto, id, ty, init) = let transf_funbody env body optres = -let transf_type t = transf_type env t -and transf_expr e = transf_expr env e in - -(* Function arguments: pass by reference those having struct/union type *) - -let transf_arg e = - let e' = transf_expr e in - if is_composite_type env e'.etyp - then {edesc = EUnop(Oaddrof, e'); etyp = TPtr(e'.etyp, [])} - else e' -in +let transf_expr ctx e = float_comma(transf_expr env ctx e) in -(* Function calls: if return type is struct or union, - lv = f(...) -> f(&lv, ...) - f(...) -> f(&newtemp, ...) - Returns: if return type is struct or union, +(* Function returns: if return type is struct or union, return x -> _res = x; return *) let rec transf_stmt s = match s.sdesc with | Sskip -> s - | Sdo {edesc = ECall(fn, args); etyp = ty} -> - let fn = transf_expr fn in - let args = List.map transf_arg args in - if is_composite_type env ty then begin - let tmp = new_temp ~name:"_res" ty in - let arg0 = {edesc = EUnop(Oaddrof, tmp); etyp = TPtr(ty, [])} in - {s with sdesc = Sdo {edesc = ECall(fn, arg0 :: args); etyp = TVoid []}} - end else - {s with sdesc = Sdo {edesc = ECall(fn, args); etyp = ty}} - | Sdo {edesc = EBinop(Oassign, dst, {edesc = ECall(fn, args); etyp = ty}, _)} -> - let dst = transf_expr dst in - let fn = transf_expr fn in - let args = List.map transf_arg args in - let ty = transf_type ty in - if is_composite_type env ty then begin - let arg0 = {edesc = EUnop(Oaddrof, dst); etyp = TPtr(dst.etyp, [])} in - {s with sdesc = Sdo {edesc = ECall(fn, arg0 :: args); etyp = TVoid []}} - end else - sassign s.sloc dst {edesc = ECall(fn, args); etyp = ty} | Sdo e -> - {s with sdesc = Sdo(transf_expr e)} + {s with sdesc = Sdo(transf_expr Effects e)} | Sseq(s1, s2) -> {s with sdesc = Sseq(transf_stmt s1, transf_stmt s2)} | Sif(e, s1, s2) -> - {s with sdesc = Sif(transf_expr e, transf_stmt s1, transf_stmt s2)} + {s with sdesc = Sif(transf_expr Val e, + transf_stmt s1, transf_stmt s2)} | Swhile(e, s1) -> - {s with sdesc = Swhile(transf_expr e, transf_stmt s1)} + {s with sdesc = Swhile(transf_expr Val e, transf_stmt s1)} | Sdowhile(s1, e) -> - {s with sdesc = Sdowhile(transf_stmt s1, transf_expr e)} + {s with sdesc = Sdowhile(transf_stmt s1, transf_expr Val e)} | Sfor(s1, e, s2, s3) -> - {s with sdesc = Sfor(transf_stmt s1, transf_expr e, + {s with sdesc = Sfor(transf_stmt s1, transf_expr Val e, transf_stmt s2, transf_stmt s3)} | Sbreak -> s | Scontinue -> s | Sswitch(e, s1) -> - {s with sdesc = Sswitch(transf_expr e, transf_stmt s1)} + {s with sdesc = Sswitch(transf_expr Val e, transf_stmt s1)} | Slabeled(lbl, s1) -> {s with sdesc = Slabeled(lbl, transf_stmt s1)} | Sgoto lbl -> s | Sreturn None -> s | Sreturn(Some e) -> - let e = transf_expr e in + let e = transf_expr Val e in begin match optres with | None -> {s with sdesc = Sreturn(Some e)} -- cgit v1.2.3