Commit 67e8b783 authored by Xavier Leroy's avatar Xavier Leroy
Browse files

Improve performance and configurability for the StructReturn pass.

configure: special ABI value for IA32/MacOSX and PowerPC/Linux
cparser/Machine: special config for PowerPC/Linux
cparser/StructReturn: generate better code for return-as-int
driver/Clflags, driver/Driver: add options -fstruct-return=<convention>
  and -fstruct-passing=<convention> to simplify testing
parent 6f3ac9e1
......@@ -84,7 +84,10 @@ case "$target" in
powerpc-linux|ppc-linux|powerpc-eabi|ppc-eabi)
arch="powerpc"
model="standard"
abi="eabi"
case "$target" in
*-linux) abi="linux";;
*-eabi) abi="eabi";;
esac
system="linux"
cc="${toolprefix}gcc"
cprepro="${toolprefix}gcc -U__GNUC__ -E"
......@@ -154,7 +157,7 @@ case "$target" in
ia32-macosx)
arch="ia32"
model="sse2"
abi="standard"
abi="macosx"
system="macosx"
cc="${toolprefix}gcc -arch i386"
cprepro="${toolprefix}gcc -arch i386 -U__GNUC__ -U__clang__ -U__BLOCKS__ '-D__attribute__(x)=' '-D__asm(x)=' -E"
......
......@@ -187,6 +187,9 @@ let ppc_32_bigendian =
struct_return_as_int = 8;
struct_passing_style = SP_ref_caller }
let ppc_32_bigendian_linux =
{ ppc_32_bigendian with struct_return_as_int = 0 }
let arm_littleendian =
{ ilp32ll64 with name = "arm";
struct_return_as_int = 4;
......
......@@ -69,6 +69,7 @@ val x86_64 : t
val win32 : t
val win64 : t
val ppc_32_bigendian : t
val ppc_32_bigendian_linux : t
val arm_littleendian : t
val gcc_extensions : t -> t
......
......@@ -22,23 +22,29 @@ open C
open Cutil
open Transform
let struct_return_style = ref 0
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 (**r a small composite type, returned as an integer *)
| 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 with
| None -> Ret_ref (* should not happen *)
| Some sz ->
if (!config).struct_return_as_int >= 4 && sz <= 4 then
Ret_value (TInt(IUInt, []))
else if (!config).struct_return_as_int >= 8 && sz <= 8 then
Ret_value (TInt(IULongLong, []))
match sizeof env ty, alignof env ty with
| Some sz, Some al ->
if !struct_return_style >= 4 && sz <= 4 then
Ret_value (TInt(IUInt, []), sz, al)
else if !struct_return_style >= 8 && sz <= 8 then
Ret_value (TInt(IULongLong, []), sz, al)
else Ret_ref
| _, _ ->
Ret_ref (* should not happen *)
end else
Ret_scalar
......@@ -52,7 +58,7 @@ type param_kind =
let classify_param env ty =
if is_composite_type env ty then begin
match (!config).struct_passing_style with
match !struct_passing_style with
| SP_ref_callee -> Param_unchanged
| SP_ref_caller -> Param_ref_caller
| _ ->
......@@ -75,6 +81,7 @@ let list_map_n f n =
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, [])
......@@ -86,13 +93,13 @@ let ebuffer_index base idx =
{ edesc = EBinop(Oindex, base, intconst (Int64.of_int idx) IInt, uintptr);
etyp = uint }
let ereinterpret ty e =
{ edesc = EUnop(Oderef, ecast (TPtr(ty, [])) (eaddrof e)); etyp = ty }
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
......@@ -120,37 +127,59 @@ let load4 base ofs =
let a = ecast uintptr (offsetptr base ofs) in
{ edesc = EUnop(Oderef, a); etyp = uint }
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 + 4 <= sz then
(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))
:: load_words base (ofs + 4) sz al
else if ofs + 3 = sz then
[ 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) ]
else if ofs + 2 = sz then
[ 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) ]
else if ofs + 1 = sz then
[ load1 base ofs 0 3 ]
else
[]
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 =
if sz <= 4 then
load_word base 0 sz al
else if sz <= 8 then 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 else
assert false
(* Rewriting of function types. For the return type:
return kind scalar -> no change
......@@ -172,7 +201,7 @@ let rec transf_type env t =
TFun(tres', None, vararg, attr)
| Ret_ref ->
TFun(TVoid [], None, vararg, add_attributes attr attr_structret)
| Ret_value ty ->
| Ret_value(ty, sz, al) ->
TFun(ty, None, vararg, attr)
end
| TFun(tres, Some args, vararg, attr) ->
......@@ -185,7 +214,7 @@ let rec transf_type env t =
let res = Env.fresh_ident "_res" in
TFun(TVoid [], Some((res, TPtr(tres', [])) :: args'), vararg,
add_attributes attr attr_structret)
| Ret_value ty ->
| Ret_value(ty, sz, al) ->
TFun(ty, Some args', vararg, attr)
end
| TPtr(t1, attr) ->
......@@ -298,7 +327,7 @@ and transf_call env ctx opt_lhs fn args ty =
ecomma {edesc = ECall(fn', eaddrof tmp :: args'); etyp = TVoid []}
(eassign lhs tmp)
end
| Ret_value ty_ret ->
| Ret_value(ty_ret, sz, al) ->
let ecall = {edesc = ECall(fn', args'); etyp = ty_ret} in
begin match ctx, opt_lhs with
| Effects, None ->
......@@ -313,9 +342,12 @@ and transf_call env ctx opt_lhs fn args ty =
(* Function argument of ref_caller kind: take a copy and pass pointer to copy
arg ---> newtemp = arg ... &newtemp
Function argument of flattened(N) kind: copy to array and pass array elts
arg ---> (*((ty *) temparray) = arg ...
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 =
......@@ -379,6 +411,7 @@ let transf_expr ctx e = transf_expr env ctx e in
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 =
......@@ -415,10 +448,18 @@ let rec transf_stmt s =
sseq s.sloc
(sassign s.sloc dst e')
{sdesc = Sreturn None; sloc = s.sloc}
| Ret_value ty, Some dst ->
sseq s.sloc
(sassign s.sloc (ereinterpret e'.etyp dst) e')
{sdesc = Sreturn (Some dst); 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 (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
......@@ -491,12 +532,11 @@ let transf_fundef env f =
TVoid [],
(vres, tres) :: params,
transf_funbody env (subst_stmt subst f.fd_body) (Some eeres))
| Ret_value ty ->
let eres = new_temp ~name:"_res" ty in
| Ret_value(ty, sz, al) ->
(f.fd_attrib,
ty,
params,
transf_funbody env (subst_stmt subst f.fd_body) (Some eres)) in
transf_funbody env (subst_stmt subst f.fd_body) None) in
let temps = get_temps() in
{f with fd_attrib = attr1;
fd_ret = ret1;
......@@ -512,6 +552,18 @@ let transf_composite env su id attr fl =
(* Entry point *)
let program p =
struct_passing_style :=
if !Clflags.option_interp then SP_ref_callee else
begin match !Clflags.option_fstruct_passing_style with
| Some st -> st
| None -> (!config).struct_passing_style
end;
struct_return_style :=
if !Clflags.option_interp then 0 else
begin match !Clflags.option_fstruct_return_style with
| Some st -> st
| None -> (!config).struct_return_as_int
end;
Transform.program
~decl:transf_decl
~fundef:transf_fundef
......
......@@ -17,6 +17,8 @@ let linker_options = ref ([]: string list)
let assembler_options = ref ([]: string list)
let option_flongdouble = ref false
let option_fstruct_return = ref false
let option_fstruct_return_style = ref (None: int option)
let option_fstruct_passing_style = ref (None: Machine.struct_passing_style option)
let option_fbitfields = ref false
let option_fvararg_calls = ref true
let option_funprototyped = ref true
......
......@@ -386,6 +386,10 @@ Language support options (use -fno-<opt> to turn off -f<opt>) :
-fbitfields Emulate bit fields in structs [off]
-flongdouble Treat 'long double' as 'double' [off]
-fstruct-return Emulate returning structs and unions by value [off]
-fstruct-return=<convention>
Set the calling conventions used to return structs by value
-fstruct-passing=<convention>
Set the calling conventions used to pass structs by value
-fvararg-calls Support calls to variable-argument functions [on]
-funprototyped Support calls to old-style functions without prototypes [on]
-fpacked-structs Emulate packed structs [off]
......@@ -527,7 +531,25 @@ let cmdline_actions =
Exact "-quiet", Self (fun _ -> Interp.trace := 0);
Exact "-trace", Self (fun _ -> Interp.trace := 2);
Exact "-random", Self (fun _ -> Interp.mode := Interp.Random);
Exact "-all", Self (fun _ -> Interp.mode := Interp.All)
Exact "-all", Self (fun _ -> Interp.mode := Interp.All);
(* Special -f options *)
Exact "-fstruct-passing=ref-callee",
Self (fun _ -> option_fstruct_passing_style := Some Machine.SP_ref_callee);
Exact "-fstruct-passing=ref-caller",
Self (fun _ -> option_fstruct_return := true;
option_fstruct_passing_style := Some Machine.SP_ref_caller);
Exact "-fstruct-passing=ints",
Self (fun _ -> option_fstruct_return := true;
option_fstruct_passing_style := Some Machine.SP_split_args);
Exact "-fstruct-return=ref",
Self (fun _ -> option_fstruct_return := true;
option_fstruct_return_style := Some 0);
Exact "-fstruct-return=int4",
Self (fun _ -> option_fstruct_return := true;
option_fstruct_return_style := Some 4);
Exact "-fstruct-return=int8",
Self (fun _ -> option_fstruct_return := true;
option_fstruct_return_style := Some 8)
]
(* -f options: come in -f and -fno- variants *)
(* Language support options *)
......@@ -582,9 +604,11 @@ let _ =
Printexc.record_backtrace true;
Machine.config :=
begin match Configuration.arch with
| "powerpc" -> Machine.ppc_32_bigendian
| "powerpc" -> if Configuration.abi = "linux"
then Machine.ppc_32_bigendian_linux
else Machine.ppc_32_bigendian
| "arm" -> Machine.arm_littleendian
| "ia32" -> if Configuration.system = "macosx"
| "ia32" -> if Configuration.abi = "macosx"
then Machine.x86_32_macosx
else Machine.x86_32
| _ -> assert false
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment