Hack StructReturn to better adhere to PowerPC and ARM calling conventions.

git-svn-id: https://yquem.inria.fr/compcert/svn/compcert/trunk@2382 fca1b0fc-160b-0410-b1d3-a4f43f01ea2e

3 files changed, 142 insertions, 67 deletions

diff --git a/cparser/Machine.ml b/cparser/Machine.ml
index 7696444..374e1bb 100644
--- a/cparser/Machine.ml
+++ b/cparser/Machine.ml
@@ -42,7 +42,8 @@ type t = {
   alignof_void: int option;
   alignof_fun: int option;
   bigendian: bool;
-  bitfields_msb_first: bool
+  bitfields_msb_first: bool;
+  struct_return_as_int: int
 }
 
 let ilp32ll64 = {
@@ -72,7 +73,8 @@ let ilp32ll64 = {
   alignof_void = None;
   alignof_fun = None;
   bigendian = false;
-  bitfields_msb_first = false
+  bitfields_msb_first = false;
+  struct_return_as_int = 0
 }
 
 let i32lpll64 = {
@@ -102,7 +104,8 @@ let i32lpll64 = {
   alignof_void = None;
   alignof_fun = None;
   bigendian = false;
-  bitfields_msb_first = false
+  bitfields_msb_first = false;
+  struct_return_as_int = 0
 }
 
 let il32pll64 = {
@@ -132,20 +135,26 @@ let il32pll64 = {
   alignof_void = None;
   alignof_fun = None;
   bigendian = false;
-  bitfields_msb_first = false
+  bitfields_msb_first = false;
+  struct_return_as_int = 0
 }
 
 (* Canned configurations for some ABIs *)
 
 let x86_32 =
-  { ilp32ll64 with char_signed = true; name = "x86_32" }
+  { ilp32ll64 with name = "x86_32"; char_signed = true }
 let x86_64 =
-  { i32lpll64 with char_signed = true; name = "x86_64" }
+  { i32lpll64 with name = "x86_64"; char_signed = true }
 let win64 =
-  { il32pll64 with char_signed = true; name = "x86_64" }
+  { il32pll64 with name = "x86_64"; char_signed = true }
 let ppc_32_bigendian =
-  { ilp32ll64 with bigendian = true; bitfields_msb_first = true; name = "powerpc" }
-let arm_littleendian = { ilp32ll64 with name = "arm" }
+  { ilp32ll64 with name = "powerpc";
+                   bigendian = true;
+                   bitfields_msb_first = true;
+                   struct_return_as_int = 8 }
+let arm_littleendian =
+  { ilp32ll64 with name = "arm";
+                   struct_return_as_int = 4 }
 
 (* Add GCC extensions re: sizeof and alignof *)
 
diff --git a/cparser/Machine.mli b/cparser/Machine.mli
index b621d4c..0381bfc 100644
--- a/cparser/Machine.mli
+++ b/cparser/Machine.mli
@@ -42,7 +42,8 @@ type t = {
   alignof_void: int option;
   alignof_fun: int option;
   bigendian: bool;
-  bitfields_msb_first: bool
+  bitfields_msb_first: bool;
+  struct_return_as_int: int
 }
 
 val ilp32ll64 : t
diff --git a/cparser/StructReturn.ml b/cparser/StructReturn.ml
index ef3e591..647e27a 100644
--- a/cparser/StructReturn.ml
+++ b/cparser/StructReturn.ml
@@ -14,13 +14,36 @@
 (* *********************************************************************)
 
 (* Eliminate structs and unions being returned by value as function results *)
-(* This is a simpler special case of [StructByValue]. *)
 
+open Machine
 open C
 open Cutil
 open Transform
 
-(* In function result types, struct s -> void + add 1st parameter struct s *
+(* 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 *)
+
+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, []))
+        else Ret_ref
+  end else
+    Ret_scalar
+
+(* Rewriting of function types.
+      return kind scalar   -> no change
+      return kind ref      -> return type void + add 1st parameter struct s *
+      return kind value(t) -> return type t.
    Try to preserve original typedef names when no change.
 *)
 
@@ -28,16 +51,24 @@ let rec transf_type env t =
   match unroll env t with
   | TFun(tres, None, vararg, attr) ->
       let tres' = transf_type env tres in
-      TFun((if is_composite_type env tres then TVoid [] else tres'),
-           None, vararg, attr)
+      let tres'' =
+        match classify_return env tres with
+        | Ret_scalar -> tres'
+        | Ret_ref -> TVoid []
+        | Ret_value ty -> ty in
+      TFun(tres'', None, vararg, attr)
   | TFun(tres, Some args, vararg, attr) ->
       let args' = List.map (transf_funarg env) args in
       let tres' = transf_type env tres in
-      if is_composite_type env tres then begin
-        let res = Env.fresh_ident "_res" in
-        TFun(TVoid [], Some((res, TPtr(tres', [])) :: args'), vararg, attr)
-      end else
-        TFun(tres', Some args', vararg, attr)
+      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, attr)
+      | Ret_value ty ->
+          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)
@@ -50,6 +81,9 @@ and transf_funarg env (id, t) = (id, transf_type env t)
 
 (* Expressions: transform calls + rewrite the types *)
 
+let ereinterpret ty e =
+  { edesc = EUnop(Oderef, ecast (TPtr(ty, [])) (eaddrof e)); etyp = ty }
+
 let rec transf_expr env ctx e =
   let newty = transf_type env e.etyp in
   match e.edesc with
@@ -63,9 +97,8 @@ let rec transf_expr env ctx e =
       {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(Oassign, lhs, {edesc = ECall(fn, args)}, ty) ->
+      transf_call env ctx (Some 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) ->
@@ -81,39 +114,59 @@ let rec transf_expr env ctx e =
   | 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_expr env Val) args);
-         etyp = newty}
-
-(* Function calls returning a composite: add first argument.
+      transf_call env ctx None fn args e.etyp
+
+(* Function calls returning a composite by reference: add first argument.
     ctx = Effects:   lv = f(...)     -> f(&lv, ...)      [copy optimization]
                      f(...)          -> f(&newtemp, ...)
     ctx = Val:       lv = f(...)     -> f(&newtemp, ...), lv = newtemp
                      f(...)          -> f(&newtemp, ...), newtemp
+   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_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_expr env Val) 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 {edesc = ECall(fn, eaddrof tmp :: args); etyp = TVoid []}
-             (eassign lhs tmp)
+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 args' = List.map (transf_expr env Val) args in
+  let opt_eassign e =
+    match opt_lhs with
+    | None -> e
+    | Some lhs -> eassign (transf_expr env Val lhs) e in
+  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 []}
+      | 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 {edesc = ECall(fn', eaddrof tmp :: args'); etyp = TVoid []}
+                 (eassign lhs' tmp)
+      end
+  | Ret_value ty_ret ->
+      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
 
 (* Initializers *)
 
@@ -139,8 +192,10 @@ let transf_funbody env body optres =
 
 let transf_expr ctx e = transf_expr env ctx e in
 
-(* Function returns: if return type is struct or union,
-     return x      -> _res = x; return
+(* Function returns:
+     return kind scalar    -> return e
+     return kind ref       -> _res = x; return
+     return kind value ty  -> *((struct s * )_res) = x; return _res
 *)
 
 let rec transf_stmt s =
@@ -169,14 +224,20 @@ let rec transf_stmt s =
   | Sgoto lbl -> s
   | Sreturn None -> s
   | Sreturn(Some e) ->
-      let e = transf_expr Val e in
-      begin match optres with
-      | None ->
-          {s with sdesc = Sreturn(Some e)}
-      | Some dst ->
+      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)
+            (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}
+      | _, _ ->
+          assert false
       end
   | Sblock sl ->
       {s with sdesc = Sblock(List.map transf_stmt sl)}
@@ -193,16 +254,20 @@ let transf_fundef env f =
   let params =
     List.map (fun (id, ty) -> (id, transf_type env ty)) f.fd_params in
   let (ret1, params1, body1) =
-    if is_composite_type env ret then begin
-      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
-      (TVoid [],
-       (vres, tres) :: params,
-       transf_funbody env f.fd_body (Some eeres))
-    end else
-      (ret, params, transf_funbody env f.fd_body None) in
+    match classify_return env f.fd_ret with
+    | Ret_scalar ->
+        (ret, params, transf_funbody env 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
+        (TVoid [],
+         (vres, tres) :: params,
+         transf_funbody env f.fd_body (Some eeres))
+    | Ret_value ty ->
+        let eres = new_temp ~name:"_res" ty in
+        (ty, params, transf_funbody env f.fd_body (Some eres)) in
   let temps = get_temps() in
   {f with fd_ret = ret1; fd_params = params1;
           fd_locals = f.fd_locals @ temps; fd_body = body1}