flambda-backend: Backend changes for multiple returns (ocaml-flambda#…

…1268)

asmcomp/amd64/proc.ml

@@ -202,8 +202,11 @@ let loc_parameters arg =
   let (loc, _ofs) =
     calling_conventions 0 9 100 109 incoming (- size_domainstate_args) arg
   in loc
-let loc_results res =
-  let (loc, _ofs) = calling_conventions 0 0 100 100 not_supported 0 res
+let loc_results_call res =
+  calling_conventions 0 9 100 109 outgoing (- size_domainstate_args) res
+let loc_results_return res =
+  let (loc, _ofs) =
+    calling_conventions 0 9 100 109 incoming (- size_domainstate_args) res
   in loc
 
 let max_arguments_for_tailcalls = 10 (* in regs *) + 64 (* in domain state *)

asmcomp/arm/proc.ml

@@ -192,8 +192,13 @@ let loc_parameters arg =
     calling_conventions 0 7 100 115 incoming (- size_domainstate_args) arg
   in loc
 
-let loc_results res =
-  let (loc, _) = calling_conventions 0 7 100 115 not_supported 0 res in loc
+let loc_results_call res =
+  calling_conventions 0 7 100 115 outgoing (- size_domainstate_args) res
+
+let loc_results_return res =
+  let (loc, _) =
+    calling_conventions 0 7 100 115 incoming (- size_domainstate_args) res
+  in loc
 
 (* C calling convention:
      first integer args in r0...r3

asmcomp/arm64/proc.ml

@@ -183,9 +183,13 @@ let loc_parameters arg =
                         incoming (- size_domainstate_args) arg
   in
   loc
-let loc_results res =
+let loc_results_call res =
+  calling_conventions 0 last_int_register 100 115
+                      outgoing (- size_domainstate_args) res
+let loc_results_return res =
   let (loc, _) =
-    calling_conventions 0 last_int_register 100 115 not_supported 0 res
+    calling_conventions 0 last_int_register 100 115
+                        incoming (- size_domainstate_args) res
   in
   loc
 

asmcomp/cmm_helpers.ml

@@ -3283,3 +3283,5 @@ let kind_of_layout (layout : Lambda.layout) =
   | Punboxed_float -> Vfloat
   | Punboxed_int _ -> Vint
   | Pvalue kind -> Vval kind
+
+let make_tuple l = match l with [e] -> e | _ -> Ctuple l

asmcomp/cmm_helpers.mli

@@ -749,3 +749,5 @@ val kind_of_layout : Lambda.layout -> value_kind
 val machtype_of_layout : Lambda.layout -> machtype
 
 val machtype_of_layout_changing_tagged_int_to_val : Lambda.layout -> machtype
+
+val make_tuple : expression list -> expression

asmcomp/i386/proc.ml

@@ -144,8 +144,16 @@ let loc_arguments arg =
   calling_conventions 0 5 100 99 outgoing arg
 let loc_parameters arg =
   let (loc, _ofs) = calling_conventions 0 5 100 99 incoming arg in loc
-let loc_results res =
-  let (loc, _ofs) = calling_conventions 0 5 100 100 not_supported res in loc
+
+(* CR vlaviron: The old code used to allow a single float register for
+   the return registers (even though the case was never used). I've
+   chosen to forbid it to match the convention for parameters.
+   Unboxed float return values will thus end up either on the reserved
+   region of the domain state or on the stack. *)
+let loc_results_call res =
+  calling_conventions 0 5 100 99 outgoing res
+let loc_results_return res =
+  let (loc, _ofs) = calling_conventions 0 5 100 99 incoming res in loc
 
 let max_arguments_for_tailcalls =
   6 (* in registers *) + 64 (* in domain state *)

asmcomp/power/proc.ml

@@ -173,8 +173,12 @@ let loc_parameters arg =
     calling_conventions 0 15 100 112 incoming (- size_domainstate_args) arg
   in loc
 
-let loc_results res =
-  let (loc, _ofs) = calling_conventions 0 15 100 112 not_supported 0 res
+let loc_results_call res =
+    calling_conventions 0 15 100 112 outgoing (- size_domainstate_args) res
+
+let loc_results_return res =
+  let (loc, _ofs) =
+    calling_conventions 0 15 100 112 incoming (- size_domainstate_args) res
   in loc
 
 (* C calling conventions for ELF32:

asmcomp/proc.mli

@@ -29,8 +29,9 @@ val rotate_registers: bool
 
 (* Calling conventions *)
 val loc_arguments: Cmm.machtype -> Reg.t array * int
-val loc_results: Cmm.machtype -> Reg.t array
+val loc_results_call: Cmm.machtype -> Reg.t array * int
 val loc_parameters: Cmm.machtype -> Reg.t array
+val loc_results_return: Cmm.machtype -> Reg.t array
 (* For argument number [n] split across multiple registers, the target-specific
    implementation of [loc_external_arguments] must return [regs] such that
    [regs.(n).(0)] is to hold the part of the value at the lowest address. *)

asmcomp/riscv/proc.ml

@@ -178,9 +178,12 @@ let loc_parameters arg =
   in
   loc
 
-let loc_results res =
+let loc_results_call res =
+  calling_conventions 0 15 110 125 outgoing (- size_domainstate_args) res
+
+let loc_results_return res =
   let (loc, _ofs) =
-    calling_conventions 0 15 110 125 not_supported 0 res
+    calling_conventions 0 15 110 125 incoming (- size_domainstate_args) res
   in
   loc
 

asmcomp/s390x/proc.ml

@@ -143,8 +143,12 @@ let loc_parameters arg =
   let (loc, _ofs) =
     calling_conventions 0 7 100 103 incoming (- size_domainstate_args) arg
   in loc
-let loc_results res =
-  let (loc, _ofs) = calling_conventions 0 7 100 103 not_supported 0 res in loc
+let loc_results_call res =
+  calling_conventions 0 7 100 103 outgoing (- size_domainstate_args) res
+let loc_results_return res =
+  let (loc, _ofs) =
+    calling_conventions 0 7 100 103 incoming (- size_domainstate_args) res
+  in loc
 
 (*   C calling conventions under SVR4:
      use GPR 2-6 and FPR 0,2,4,6 just like ML calling conventions.

asmcomp/selectgen.ml

@@ -651,10 +651,10 @@ method insert_move_args env arg loc stacksize =
   self#insert_moves env arg loc
 
 method insert_move_results env loc res stacksize =
+  self#insert_moves env loc res;
   if stacksize <> 0 then begin
     self#insert env (Iop(Istackoffset(-stacksize))) [||] [||]
-  end;
-  self#insert_moves env loc res
+  end
 
 (* Add an Iop opcode. Can be overridden by processor description
    to insert moves before and after the operation, i.e. for two-address
@@ -797,8 +797,9 @@ method emit_expr_aux (env:environment) exp :
               let rarg = Array.sub r1 1 (Array.length r1 - 1) in
               let rd = self#regs_for ty in
               self#insert_endregions_until env ~suffix:unclosed_regions env.regions;
-              let (loc_arg, stack_ofs) = Proc.loc_arguments (Reg.typv rarg) in
-              let loc_res = Proc.loc_results (Reg.typv rd) in
+              let (loc_arg, stack_ofs_args) = Proc.loc_arguments (Reg.typv rarg) in
+              let (loc_res, stack_ofs_res) = Proc.loc_results_call (Reg.typv rd) in
+              let stack_ofs = Stdlib.Int.max stack_ofs_args stack_ofs_res in
               self#insert_move_args env rarg loc_arg stack_ofs;
               self#insert_debug env (Iop new_op) dbg
                           (Array.append [|r1.(0)|] loc_arg) loc_res;
@@ -808,8 +809,9 @@ method emit_expr_aux (env:environment) exp :
               let r1 = self#emit_tuple env new_args in
               let rd = self#regs_for ty in
               self#insert_endregions_until env ~suffix:unclosed_regions env.regions;
-              let (loc_arg, stack_ofs) = Proc.loc_arguments (Reg.typv r1) in
-              let loc_res = Proc.loc_results (Reg.typv rd) in
+              let (loc_arg, stack_ofs_args) = Proc.loc_arguments (Reg.typv r1) in
+              let (loc_res, stack_ofs_res) = Proc.loc_results_call (Reg.typv rd) in
+              let stack_ofs = Stdlib.Int.max stack_ofs_args stack_ofs_res in
               self#insert_move_args env r1 loc_arg stack_ofs;
               self#insert_debug env (Iop new_op) dbg loc_arg loc_res;
               self#insert_move_results env loc_res rd stack_ofs;
@@ -1158,7 +1160,7 @@ method private insert_return (env:environment) r =
     None -> ()
   | Some (r, unclosed_regions) ->
       self#insert_endregions env unclosed_regions;
-      let loc = Proc.loc_results (Reg.typv r) in
+      let loc = Proc.loc_results_return (Reg.typv r) in
       self#insert_moves env r loc;
       self#insert env Ireturn loc [||]
 
@@ -1200,17 +1202,18 @@ method emit_tail (env:environment) exp =
           match new_op with
             Icall_ind ->
               let r1 = self#emit_tuple env new_args in
+              let rd = self#regs_for ty in
               let rarg = Array.sub r1 1 (Array.length r1 - 1) in
               self#insert_endregions env env.regions;
-              let (loc_arg, stack_ofs) = Proc.loc_arguments (Reg.typv rarg) in
+              let (loc_arg, stack_ofs_args) = Proc.loc_arguments (Reg.typv rarg) in
+              let (loc_res, stack_ofs_res) = Proc.loc_results_call (Reg.typv rd) in
+              let stack_ofs = Stdlib.Int.max stack_ofs_args stack_ofs_res in
               if stack_ofs = 0 then begin
                 let call = Iop (Itailcall_ind) in
                 self#insert_moves env rarg loc_arg;
                 self#insert_debug env call dbg
                             (Array.append [|r1.(0)|] loc_arg) [||];
               end else begin
-                let rd = self#regs_for ty in
-                let loc_res = Proc.loc_results (Reg.typv rd) in
                 self#insert_move_args env rarg loc_arg stack_ofs;
                 self#insert_debug env (Iop new_op) dbg
                             (Array.append [|r1.(0)|] loc_arg) loc_res;
@@ -1219,8 +1222,11 @@ method emit_tail (env:environment) exp =
               end
           | Icall_imm { func; } ->
               let r1 = self#emit_tuple env new_args in
+              let rd = self#regs_for ty in
               self#insert_endregions env env.regions;
-              let (loc_arg, stack_ofs) = Proc.loc_arguments (Reg.typv r1) in
+              let (loc_arg, stack_ofs_args) = Proc.loc_arguments (Reg.typv r1) in
+              let (loc_res, stack_ofs_res) = Proc.loc_results_call (Reg.typv rd) in
+              let stack_ofs = Stdlib.Int.max stack_ofs_args stack_ofs_res in
               if stack_ofs = 0 then begin
                 let call = Iop (Itailcall_imm { func; }) in
                 self#insert_moves env r1 loc_arg;
@@ -1231,8 +1237,6 @@ method emit_tail (env:environment) exp =
                 self#insert_moves env r1 loc_arg';
                 self#insert_debug env call dbg loc_arg' [||];
               end else begin
-                let rd = self#regs_for ty in
-                let loc_res = Proc.loc_results (Reg.typv rd) in
                 self#insert_move_args env r1 loc_arg stack_ofs;
                 self#insert_debug env (Iop new_op) dbg loc_arg loc_res;
                 self#insert env (Iop(Istackoffset(-stack_ofs))) [||] [||];