From fcc5b32267d22de13553c0f5fc61ae60f0723a50 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Fri, 16 Feb 2018 16:32:41 +0100 Subject: Renamed StructReturn to structPassing --- cparser/StructPassing.ml | 594 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 594 insertions(+) create mode 100644 cparser/StructPassing.ml (limited to 'cparser/StructPassing.ml') diff --git a/cparser/StructPassing.ml b/cparser/StructPassing.ml new file mode 100644 index 00000000..3de05e19 --- /dev/null +++ b/cparser/StructPassing.ml @@ -0,0 +1,594 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU General Public License as published by *) +(* the Free Software Foundation, either version 2 of the License, or *) +(* (at your option) any later version. This file is also distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(* Eliminate structs and unions that are + - returned by value as function results + - passed by value as function parameters. *) + +open Machine +open C +open Cutil +open Transform + +let struct_return_style = ref SR_ref +let struct_passing_style = ref SP_ref_callee + +(* Classification of function return types. *) + +type return_kind = + | Ret_scalar (**r a scalar type, returned as usual *) + | Ret_ref (**r a composite type, returned by reference *) + | Ret_value of typ * int * int + (**r a small composite type, returned as an integer + (type, size, alignment) *) + +let classify_return env ty = + if is_composite_type env ty then begin + match sizeof env ty, alignof env ty with + | Some sz, Some al -> + begin match !struct_return_style with + | SR_int1248 when sz = 1 || sz = 2 || sz = 4 -> + Ret_value (TInt(IUInt, []), sz, al) + | SR_int1248 when sz = 8 -> + Ret_value (TInt(IULongLong, []), sz, al) + | (SR_int1to4 | SR_int1to8) when sz <= 4 -> + Ret_value (TInt(IUInt, []), sz, al) + | SR_int1to8 when sz > 4 && sz <= 8 -> + Ret_value (TInt(IULongLong, []), sz, al) + | _ -> + Ret_ref + end + | _, _ -> + Ret_ref (* should not happen *) + end else + Ret_scalar + +(* Classification of function parameter types. *) + +type param_kind = + | Param_unchanged (**r passed as is *) + | Param_ref_caller (**r passed by reference to a copy taken by the caller *) + | Param_flattened of int * int * int (**r passed as N integer arguments *) + (**r (N, size, alignment) *) + +let classify_param env ty = + if is_composite_type env ty then begin + match !struct_passing_style with + | SP_ref_callee -> Param_unchanged + | SP_ref_caller -> Param_ref_caller + | _ -> + match sizeof env ty, alignof env ty with + | Some sz, Some al -> + Param_flattened ((sz + 3) / 4, sz, al) + | _, _ -> + Param_unchanged (* should not happen *) + end else + Param_unchanged + +(* Return the list [f 0; f 1; ...; f (n-1)] *) + +let list_map_n f n = + let rec map i = if i >= n then [] else f i :: map (i + 1) + in map 0 + +(* Declaring and accessing buffers (arrays of int) *) + +let uchar = TInt(IUChar, []) +let ushort = TInt(IUShort, []) +let uint = TInt(IUInt, []) +let ulonglong = TInt(IULongLong, []) +let ucharptr = TPtr(uchar, []) +let ushortptr = TPtr(ushort, []) +let uintptr = TPtr(uint, []) +let ulonglongptr = TPtr(ulonglong, []) + +let ty_buffer n = + TArray(uint, Some (Int64.of_int n), []) + +let ebuffer_index base idx = + { edesc = EBinop(Oindex, base, intconst (Int64.of_int idx) IInt, uintptr); + etyp = uint } + +let attr_structret = [Attr("__structreturn", [])] + +(* Expression constructor functions *) + +let ereinterpret ty e = + { edesc = EUnop(Oderef, ecast (TPtr(ty, [])) (eaddrof e)); etyp = ty } + +let or2 a b = { edesc = EBinop(Oor, a, b, uint); etyp = uint } +let or3 a b c = or2 (or2 a b) c +let or4 a b c d = or2 (or2 (or2 a b) c) d + +let lshift a nbytes = + if nbytes = 0 then a else + { edesc = EBinop(Oshl, a, intconst (Int64.of_int (nbytes * 8)) IInt, uint); + etyp = uint } + +let offsetptr base ofs = + if ofs = 0 then base else + { edesc = EBinop(Oadd, base, intconst (Int64.of_int ofs) IInt, ucharptr); + etyp = ucharptr } + +let load1 base ofs shift_le shift_be = + let shift = if (!config).bigendian then shift_be else shift_le in + let a = offsetptr base ofs in + lshift { edesc = EUnop(Oderef, a); etyp = uchar } shift + +let load2 base ofs shift_le shift_be = + let shift = if (!config).bigendian then shift_be else shift_le in + let a = ecast ushortptr (offsetptr base ofs) in + lshift { edesc = EUnop(Oderef, a); etyp = ushort } shift + +let load4 base ofs = + let a = ecast uintptr (offsetptr base ofs) in + { edesc = EUnop(Oderef, a); etyp = uint } + +let load8 base ofs = + let a = ecast ulonglongptr (offsetptr base ofs) in + { edesc = EUnop(Oderef, a); etyp = ulonglong } + +let lshift_ll a nbytes = + let a = ecast ulonglong a in + if nbytes = 0 then a else + { edesc = EBinop(Oshl, a, intconst (Int64.of_int (nbytes * 8)) IInt, ulonglong); + etyp = ulonglong } + +let or2_ll a b = { edesc = EBinop(Oor, a, b, uint); etyp = ulonglong } + +(* Loading a memory area as one or several integers. *) + +let load_word base ofs sz al = + match sz with + | 0 -> intconst 0L IInt + | 1 -> load1 base ofs 0 3 + | 2 -> if al >= 2 || (!config).supports_unaligned_accesses then + load2 base ofs 0 2 + else + or2 (load1 base ofs 0 3) + (load1 base (ofs + 1) 1 2) + | 3 -> if al >= 2 || (!config).supports_unaligned_accesses then + or2 (load2 base ofs 0 2) + (load1 base (ofs + 2) 2 1) + else + or3 (load1 base ofs 0 3) + (load1 base (ofs + 1) 1 2) + (load1 base (ofs + 2) 2 1) + | 4 -> if al >= 4 || (!config).supports_unaligned_accesses then + load4 base ofs + else if al >= 2 then + or2 (load2 base ofs 0 2) + (load2 base (ofs + 2) 2 0) + else + or4 (load1 base ofs 0 3) + (load1 base (ofs + 1) 1 2) + (load1 base (ofs + 2) 2 1) + (load1 base (ofs + 3) 3 0) + | _ -> assert false + + +let rec load_words base ofs sz al = + if ofs >= sz then [] + else if ofs + 4 >= sz then [load_word base ofs (sz - ofs) al] + else load_word base ofs 4 al :: load_words base (ofs + 4) sz al + +let load_result base sz al = + assert (sz <= 8); + if sz <= 4 then + load_word base 0 sz al + else if sz = 8 && (al >= 8 || (!config).supports_unaligned_accesses) then + load8 base 0 + else begin + let (shift1, shift2) = if (!config).bigendian then (4, 0) else (0, 4) in + or2_ll (lshift_ll (load_word base 0 4 al) shift1) + (lshift_ll (load_word base 4 (sz - 4) al) shift2) + end + +(* Rewriting of function types. For the return type: + return kind scalar -> no change + return kind ref -> return type void + add 1st parameter struct s * + return kind value(t) -> return type t. + For the parameters: + param unchanged -> no change + param_ref_caller -> turn into a pointer + param_flattened N -> turn into N parameters of type "int" + Try to preserve original typedef names when no change. +*) + +let rec transf_type env t = + match unroll env t with + | TFun(tres, None, vararg, attr) -> + let tres' = transf_type env tres in + begin match classify_return env tres with + | Ret_scalar -> + TFun(tres', None, vararg, attr) + | Ret_ref -> + TFun(TVoid [], None, vararg, add_attributes attr attr_structret) + | Ret_value(ty, sz, al) -> + TFun(ty, None, vararg, attr) + end + | TFun(tres, Some args, vararg, attr) -> + let args' = transf_funargs env args in + let tres' = transf_type env tres in + begin match classify_return env tres with + | Ret_scalar -> + TFun(tres', Some args', vararg, attr) + | Ret_ref -> + let res = Env.fresh_ident "_res" in + TFun(TVoid [], Some((res, TPtr(tres', [])) :: args'), vararg, + add_attributes attr attr_structret) + | Ret_value(ty, sz, al) -> + TFun(ty, Some args', vararg, attr) + end + | TPtr(t1, attr) -> + let t1' = transf_type env t1 in + if t1' = t1 then t else TPtr(transf_type env t1, attr) + | TArray(t1, sz, attr) -> + let t1' = transf_type env t1 in + if t1' = t1 then t else TArray(transf_type env t1, sz, attr) + | _ -> t + +and transf_funargs env = function + | [] -> [] + | (id, t) :: args -> + let t' = transf_type env t in + let args' = transf_funargs env args in + match classify_param env t with + | Param_unchanged -> + (id, t') :: args' + | Param_ref_caller -> + (id, TPtr(t', [])) :: args' + | Param_flattened(n, sz, al) -> + list_map_n (fun _ -> (Env.fresh_ident id.C.name, uint)) n + @ args' + +(* Expressions: transform calls + rewrite the types *) + +let rec translates_to_extended_lvalue arg = + is_lvalue arg || + (match arg.edesc with + | ECall _ -> true + | EBinop(Ocomma, a, b, _) -> translates_to_extended_lvalue b + | _ -> false) + +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} + | EAlignof ty -> + {edesc = EAlignof (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); etyp = ty}, _) -> + transf_call env ctx (Some (transf_expr env Val lhs)) fn args ty + | EBinop(Ocomma, e1, e2, ty) -> + ecomma (transf_expr env Effects e1) (transf_expr env ctx e2) + | 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} + | ECompound(ty, ie) -> + {edesc = ECompound(transf_type env ty, transf_init env ie); etyp = newty} + | ECall(fn, args) -> + transf_call env ctx None fn args e.etyp + +(* Function calls returning a composite by reference: add first argument. + ctx = Effects: lv = f(...) -> f(&newtemp, ...), lv = newtemp + f(...) -> f(&newtemp, ...) + ctx = Val: lv = f(...) -> f(&newtemp, ...), lv = newtemp + f(...) -> f(&newtemp, ...), newtemp + + We used to do a copy optimization: + ctx = Effects: lv = f(...) -> f(&lv, ...) + but it is not correct in case of overlap (see test/regression/struct12.c) + + Function calls returning a composite by value: + ctx = Effects: lv = f(...) -> newtemp = f(...), lv = newtemp + f(...) -> f(...) + ctx = Val: lv = f(...) -> newtemp = f(...), lv = newtemp + f(...) -> newtemp = f(...), newtemp +*) + +and transf_call env ctx opt_lhs fn args ty = + let ty' = transf_type env ty in + let fn' = transf_expr env Val fn in + let (assignments, args') = transf_arguments env args in + let opt_eassign e = + match opt_lhs with + | None -> e + | Some lhs -> eassign lhs e in + match fn with + | {edesc = EVar {C.name = "__builtin_va_arg"}} -> + (* Do not transform the call in this case *) + opt_eassign {edesc = ECall(fn, args'); etyp = ty} + | _ -> + let call = + match classify_return env ty with + | Ret_scalar -> + opt_eassign {edesc = ECall(fn', args'); etyp = ty'} + | Ret_ref -> + begin match ctx, opt_lhs with + | Effects, None -> + let tmp = new_temp ~name:"_res" ty in + {edesc = ECall(fn', eaddrof tmp :: args'); etyp = TVoid []} + (* Copy optimization, turned off as explained above *) + (* | Effects, Some lhs -> + {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 + | _, Some lhs -> + let tmp = new_temp ~name:"_res" ty in + ecomma {edesc = ECall(fn', eaddrof tmp :: args'); etyp = TVoid []} + (eassign lhs tmp) + end + | Ret_value(ty_ret, sz, al) -> + let ecall = {edesc = ECall(fn', args'); etyp = ty_ret} in + begin match ctx, opt_lhs with + | Effects, None -> + ecall + | _, _ -> + let tmp = new_temp ~name:"_res" ty_ret in + opt_eassign + (ecomma (eassign tmp ecall) + (ereinterpret ty' tmp)) + end + in ecommalist assignments call + +(* Function argument of ref_caller kind: take a copy and pass pointer to copy + arg ---> newtemp = arg ... &newtemp + Function argument of flattened(N) kind: load and pass as integers + either using an intermediate array + arg ---> ( * ((ty * ) temparray) = arg ... + temparray[0], ...,, temparray[N-1] + or by using loadwords: + arg ---> addr = &(arg) ... loadwords addr ... +*) + +and transf_arguments env args = + match args with + | [] -> ([], []) + | arg :: args -> + let (assignments, args') = transf_arguments env args in + match classify_param env arg.etyp with + | Param_unchanged -> + let arg' = transf_expr env Val arg in + (assignments, arg' :: args') + | Param_ref_caller -> + let ty' = transf_type env arg.etyp in + let tmp = new_temp ~name:"_arg" ty' in + (transf_assign env tmp arg :: assignments, + eaddrof tmp :: args') + | Param_flattened(n, sz, al) -> + let ty' = transf_type env arg.etyp in + if translates_to_extended_lvalue arg then begin + let tmp = new_temp ~name:"_arg" ucharptr in + (eassign tmp (ecast ucharptr (eaddrof (transf_expr env Val arg))) + :: assignments, + load_words tmp 0 sz al @ args') + end else begin + let tmp = new_temp ~name:"_arg" (ty_buffer n) in + (transf_assign env (ereinterpret ty' tmp) arg :: assignments, + list_map_n (ebuffer_index tmp) n @ args') + end + +and transf_assign env lhs e = + match e.edesc with + | ECall(fn, args) -> + transf_call env Effects (Some lhs) fn args e.etyp + | _ -> + eassign lhs (transf_expr env Val e) + +(* Initializers *) + +and transf_init env = function + | Init_single e -> + Init_single (transf_expr env Val e) + | Init_array il -> + Init_array (List.rev (List.rev_map (transf_init env) il)) + | Init_struct(id, fil) -> + Init_struct (id, List.map (fun (fld, i) -> (fld, transf_init env i)) fil) + | Init_union(id, fld, i) -> + Init_union(id, fld, transf_init env i) + +(* Declarations *) + +let transf_decl env (sto, id, ty, init) = + (sto, id, transf_type env ty, + match init with None -> None | Some i -> Some (transf_init env i)) + +(* Transformation of statements and function bodies *) + +let transf_funbody env body optres = + +let transf_expr ctx e = transf_expr env ctx e in +let transf_asm_operand (lbl, cstr, e) = (lbl, cstr, transf_expr Val e) in + +(* Function returns: + return kind scalar -> return e + return kind ref -> _res = x; return + return kind value ty -> *((struct s * )_res) = x; return _res + or addr = &x; return loadresult(addr) +*) + +let rec transf_stmt s = + match s.sdesc with + | Sskip -> s + | Sdo 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 Val e, + transf_stmt s1, transf_stmt s2)} + | Swhile(e, s1) -> + {s with sdesc = Swhile(transf_expr Val e, transf_stmt s1)} + | Sdowhile(s1, 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 Val e, + transf_stmt s2, transf_stmt s3)} + | Sbreak -> s + | Scontinue -> s + | Sswitch(e, 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 Val e in + begin match classify_return env e'.etyp, optres with + | Ret_scalar, None -> + {s with sdesc = Sreturn(Some e')} + | Ret_ref, Some dst -> + sseq s.sloc + (sassign s.sloc dst e') + {sdesc = Sreturn None; sloc = s.sloc} + | Ret_value(ty, sz, al), None -> + if translates_to_extended_lvalue e then begin + let tmp = new_temp ~name:"_res" ucharptr in + sseq s.sloc + (sassign s.sloc tmp (ecast ucharptr (eaddrof e'))) + {sdesc = Sreturn (Some (load_result tmp sz al)); sloc = s.sloc} + end else begin + let dst = new_temp ~name:"_res" ty in + sseq s.sloc + (sassign s.sloc (ereinterpret e'.etyp dst) e') + {sdesc = Sreturn (Some dst); sloc = s.sloc} + end + | _, _ -> + assert false + end + | Sblock sl -> + {s with sdesc = Sblock(List.map transf_stmt sl)} + | Sdecl d -> + {s with sdesc = Sdecl(transf_decl env d)} + | Sasm(attr, template, outputs, inputs, clob) -> + {s with sdesc = Sasm(attr, template, + List.map transf_asm_operand outputs, + List.map transf_asm_operand inputs, clob)} + +in + transf_stmt body + +(* Binding arguments to parameters. Returns a triple: + - parameter list + - actions to perform at the beginning of the function + - substitution to apply to the function body +*) + +let rec transf_funparams loc env params = + match params with + | [] -> + ([], sskip, IdentMap.empty) + | (x, tx) :: params -> + let tx' = transf_type env tx in + let (params', actions, subst) = transf_funparams loc env params in + match classify_param env tx with + | Param_unchanged -> + ((x, tx') :: params', + actions, + subst) + | Param_ref_caller -> + let tpx = TPtr(tx', []) in + let ex = { edesc = EVar x; etyp = tpx } in + let estarx = { edesc = EUnop(Oderef, ex); etyp = tx' } in + ((x, tpx) :: params', + actions, + IdentMap.add x estarx subst) + | Param_flattened(n, sz, al) -> + let y = new_temp ~name:x.C.name (ty_buffer n) in + let yparts = list_map_n (fun _ -> Env.fresh_ident x.C.name) n in + let assign_part e p act = + sseq loc (sassign loc e {edesc = EVar p; etyp = uint}) act in + (List.map (fun p -> (p, uint)) yparts @ params', + List.fold_right2 assign_part + (list_map_n (ebuffer_index y) n) + yparts + actions, + IdentMap.add x (ereinterpret tx' y) subst) + +let transf_fundef env f = + reset_temps(); + let ret = transf_type env f.fd_ret in + let (params, actions, subst) = + transf_funparams f.fd_body.sloc env f.fd_params in + let locals = + List.map (fun d -> transf_decl env (subst_decl subst d)) f.fd_locals in + let (attr1, ret1, params1, body1) = + match classify_return env f.fd_ret with + | Ret_scalar -> + (f.fd_attrib, + ret, + params, + transf_funbody env (subst_stmt subst f.fd_body) None) + | Ret_ref -> + let vres = Env.fresh_ident "_res" in + let tres = TPtr(ret, []) in + let eres = {edesc = EVar vres; etyp = tres} in + let eeres = {edesc = EUnop(Oderef, eres); etyp = ret} in + (add_attributes f.fd_attrib attr_structret, + TVoid [], + (vres, tres) :: params, + transf_funbody env (subst_stmt subst f.fd_body) (Some eeres)) + | Ret_value(ty, sz, al) -> + (f.fd_attrib, + ty, + params, + transf_funbody env (subst_stmt subst f.fd_body) None) in + let temps = get_temps() in + {f with fd_attrib = attr1; + fd_ret = ret1; + fd_params = params1; + fd_locals = locals @ temps; + fd_body = sseq f.fd_body.sloc actions body1} + +(* Composites *) + +let transf_composite env su id attr fl = + (attr, List.map (fun f -> {f with fld_typ = transf_type env f.fld_typ}) fl) + +(* Entry point *) + +let program p = + struct_passing_style := + if !Clflags.option_interp + then SP_ref_callee + else !Machine.config.struct_passing_style; + struct_return_style := + if !Clflags.option_interp + then SR_ref + else !Machine.config.struct_return_style; + Transform.program + ~decl:transf_decl + ~fundef:transf_fundef + ~composite:transf_composite + ~typedef:(fun env id ty -> transf_type env ty) + p -- cgit