Backport ocaml/ocaml#10595 from upstream/trunk (#471)

backend/amd64/emit.mlp

@@ -103,6 +103,7 @@ let slot_offset loc cl =
       then !stack_offset + n * 8
       else !stack_offset + (num_stack_slots.(0) + n) * 8
   | Outgoing n -> n
+  | Domainstate _ -> assert false (* not a stack slot *)
 
 let emit_stack_offset n =
   if n < 0
@@ -206,14 +207,18 @@ let emit_Llabel fallthrough lbl =
 
 (* Output a pseudo-register *)
 
+let x86_data_type_for_stack_slot = function
+  | Float -> REAL8
+  | _ -> QWORD
+
 let reg = function
   | { loc = Reg.Reg r } -> register_name r
-  | { loc = Stack s; typ = Float } as r ->
-      let ofs = slot_offset s (register_class r) in
-      mem64 REAL8 ofs RSP
-  | { loc = Stack s } as r ->
+  | { loc = Stack (Domainstate n); typ = ty } ->
+      let ofs = n + Domainstate.(idx_of_field Domain_extra_params) * 8 in
+      mem64 (x86_data_type_for_stack_slot ty) ofs R14
+  | { loc = Stack s; typ = ty } as r ->
       let ofs = slot_offset s (register_class r) in
-      mem64 QWORD ofs RSP
+      mem64 (x86_data_type_for_stack_slot ty) ofs RSP
   | { loc = Unknown } ->
       assert false
 

backend/amd64/proc.ml

@@ -77,8 +77,6 @@ let win64 = Arch.win64
      the GC regs block).
 *)
 
-let max_arguments_for_tailcalls = 10
-
 let int_reg_name =
   match Config.ccomp_type with
   | "msvc" ->
@@ -158,12 +156,15 @@ let word_addressed = false
 
 (* Calling conventions *)
 
-let calling_conventions first_int last_int first_float last_float make_stack
+let size_domainstate_args = 64 * size_int
+
+let calling_conventions first_int last_int first_float last_float
+                        make_stack first_stack
                         arg =
   let loc = Array.make (Array.length arg) Reg.dummy in
   let int = ref first_int in
   let float = ref first_float in
-  let ofs = ref 0 in
+  let ofs = ref first_stack in
   for i = 0 to Array.length arg - 1 do
     match arg.(i) with
     | Val | Int | Addr as ty ->
@@ -184,21 +185,32 @@ let calling_conventions first_int last_int first_float last_float make_stack
           ofs := !ofs + size_float
         end
   done;
-  (loc, Misc.align !ofs 16)  (* keep stack 16-aligned *)
-
-let incoming ofs = Incoming ofs
-let outgoing ofs = Outgoing ofs
+  (loc, Misc.align (max 0 !ofs) 16)  (* keep stack 16-aligned *)
+
+let incoming ofs =
+  if ofs >= 0
+  then Incoming ofs
+  else Domainstate (ofs + size_domainstate_args)
+let outgoing ofs =
+  if ofs >= 0
+  then Outgoing ofs
+  else Domainstate (ofs + size_domainstate_args)
 let not_supported _ofs = fatal_error "Proc.loc_results: cannot call"
 
 let loc_arguments arg =
-  calling_conventions 0 9 100 109 outgoing arg
+  calling_conventions 0 9 100 109 outgoing (- size_domainstate_args) arg
 let loc_parameters arg =
   let (loc, _ofs) =
-    calling_conventions 0 9 100 109 incoming arg
+    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 res in loc
+  let (loc, _ofs) =
+    calling_conventions 0 0 100 100 not_supported 0 res
+  in loc
+
+let max_arguments_for_tailcalls = 10 (* in regs *) + 64 (* in domain state *)
 
 (* C calling conventions under Unix:
      first integer args in rdi, rsi, rdx, rcx, r8, r9
@@ -214,10 +226,10 @@ let loc_results res =
      Return value in rax or xmm0. *)
 
 let loc_external_results res =
-  let (loc, _ofs) = calling_conventions 0 0 100 100 not_supported res in loc
+  let (loc, _ofs) = calling_conventions 0 0 100 100 not_supported 0 res in loc
 
 let unix_loc_external_arguments arg =
-  calling_conventions 2 7 100 107 outgoing arg
+  calling_conventions 2 7 100 107 outgoing 0 arg
 
 let win64_int_external_arguments =
   [| 5 (*rcx*); 4 (*rdx*); 6 (*r8*); 7 (*r9*) |]

backend/arm64/emit.mlp

@@ -118,13 +118,18 @@ let slot_offset loc cl =
   | Outgoing n ->
       assert (n >= 0);
       n
+  | Domainstate _ -> assert false (* not a satck slot *)
 
 (* Output a stack reference *)
 
 let emit_stack r =
   match r.loc with
+  | Stack (Domainstate n) ->
+      let ofs = n + Domainstate.(idx_of_field Domain_extra_params) * 8 in
+      `[{emit_reg reg_domain_state_ptr}, #{emit_int ofs}]`
   | Stack s ->
-      let ofs = slot_offset s (register_class r) in `[sp, #{emit_int ofs}]`
+      let ofs = slot_offset s (register_class r) in
+      `[sp, #{emit_int ofs}]`
   | _ -> fatal_error "Emit.emit_stack"
 
 (* Output an addressing mode *)

backend/arm64/proc.ml

@@ -108,6 +108,8 @@ let stack_slot slot ty =
 
 (* Calling conventions *)
 
+let size_domainstate_args = 64 * size_int
+
 let loc_int last_int make_stack int ofs =
   if !int <= last_int then begin
     let l = phys_reg !int in
@@ -139,43 +141,52 @@ let loc_int32 last_int make_stack int ofs =
   end
 
 let calling_conventions
-    first_int last_int first_float last_float make_stack arg =
+    first_int last_int first_float last_float make_stack first_stack arg =
   let loc = Array.make (Array.length arg) Reg.dummy in
   let int = ref first_int in
   let float = ref first_float in
-  let ofs = ref 0 in
+  let ofs = ref first_stack in
   for i = 0 to Array.length arg - 1 do
     match arg.(i) with
     | Val | Int | Addr ->
         loc.(i) <- loc_int last_int make_stack int ofs
     | Float ->
         loc.(i) <- loc_float last_float make_stack float ofs
   done;
-  (loc, Misc.align !ofs 16)  (* keep stack 16-aligned *)
-
-let incoming ofs = Incoming ofs
-let outgoing ofs = Outgoing ofs
+  (loc, Misc.align (max 0 !ofs) 16)  (* keep stack 16-aligned *)
+
+let incoming ofs =
+  if ofs >= 0
+  then Incoming ofs
+  else Domainstate (ofs + size_domainstate_args)
+let outgoing ofs =
+  if ofs >= 0
+  then Outgoing ofs
+  else Domainstate (ofs + size_domainstate_args)
 let not_supported _ofs = fatal_error "Proc.loc_results: cannot call"
 
 (* OCaml calling convention:
      first integer args in r0...r15
      first float args in d0...d15
-     remaining args on stack.
+     remaining args in domain area, then on stack.
    Return values in r0...r15 or d0...d15. *)
 
-let max_arguments_for_tailcalls = 16
+let max_arguments_for_tailcalls = 16 (* in regs *) + 64 (* in domain state *)
+
 let last_int_register = if macosx then 7 else 15
 
 let loc_arguments arg =
-  calling_conventions 0 last_int_register 100 115 outgoing arg
+  calling_conventions 0 last_int_register 100 115
+                      outgoing (- size_domainstate_args) arg
 let loc_parameters arg =
   let (loc, _) =
-    calling_conventions 0 last_int_register 100 115 incoming arg
+    calling_conventions 0 last_int_register 100 115
+                        incoming (- size_domainstate_args) arg
   in
   loc
 let loc_results res =
   let (loc, _) =
-    calling_conventions 0 last_int_register 100 115 not_supported res
+    calling_conventions 0 last_int_register 100 115 not_supported 0 res
   in
   loc
 
@@ -209,7 +220,7 @@ let loc_external_arguments ty_args =
   external_calling_conventions 0 7 100 107 outgoing ty_args
 
 let loc_external_results res =
-  let (loc, _) = calling_conventions 0 1 100 100 not_supported res in loc
+  let (loc, _) = calling_conventions 0 1 100 100 not_supported 0 res in loc
 
 let loc_exn_bucket = phys_reg 0
 

backend/printmach.ml

@@ -40,6 +40,8 @@ let reg ppf r =
       fprintf ppf "[si%i]" s
   | Stack(Outgoing s) ->
       fprintf ppf "[so%i]" s
+  | Stack(Domainstate s) ->
+      fprintf ppf "[ds%i]" s
   end
 
 let regs ppf v =

backend/reg.ml

@@ -56,6 +56,7 @@ and stack_location =
     Local of int
   | Incoming of int
   | Outgoing of int
+  | Domainstate of int
 
 type reg = t
 
@@ -250,9 +251,11 @@ let equal_stack_location left right =
   | Local left, Local right -> Int.equal left right
   | Incoming left, Incoming right -> Int.equal left right
   | Outgoing left, Outgoing right -> Int.equal left right
-  | Local _, (Incoming _ | Outgoing _)
-  | Incoming _, (Local _ | Outgoing _)
-  | Outgoing _, (Local _ | Incoming _) ->
+  | Domainstate left, Domainstate right -> Int.equal left right
+  | Local _, (Incoming _ | Outgoing _ | Domainstate _)
+  | Incoming _, (Local _ | Outgoing _ | Domainstate _)
+  | Outgoing _, (Local _ | Incoming _ | Domainstate _)
+  | Domainstate _, (Local _ | Incoming _ | Outgoing _)->
     false
 
 let equal_location left right =

backend/reg.mli

@@ -42,6 +42,29 @@ and stack_location =
     Local of int
   | Incoming of int
   | Outgoing of int
+  | Domainstate of int
+
+(* The [stack_location] describes the location of pseudo-registers
+   that reside in memory.
+ - [Local] is a local variable or spilled register residing in the stack frame
+   of the current function
+ - [Incoming] is a function parameter that was passed on the stack.
+   This is the callee's view: the location is just above the callee's
+   stack frame, in the caller's stack frame.
+ - [Outgoing] is a function call argument that is passed on the stack.
+   This is the caller's view: the location is at the bottom of the
+   caller's stack frame.
+ - [Domainstate] is a function call argument that is passed not on stack
+   but in the [extra_params] section of the domain state
+   (see file [../runtime/caml/domain_state.*]).  Unlike arguments passed
+   on stack, arguments passed via the domain state are compatible with
+   tail calls.  However, domain state locations are shared between
+   all functions that run in a given domain, hence they are not preserved
+   by function calls or thread context switches.  The caller stores
+   arguments in the domain state immediately before the call, and the
+   first thing the callee does is copy them to registers or [Local]
+   stack locations.  Neither GC nor thread context switches can occur
+   between these two times. *)
 
 val dummy: t
 val create: Cmm.machtype_component -> t

ocaml/Changes

@@ -1,3 +1,15 @@
+
+OCaml 4.14, maintenance version
+-------------------------------
+
+### Code generation and optimizations:
+
+- #10595: Tail calls with up to 64 arguments are guaranteed to be compiled
+  as tail calls.  To this end, memory locations in the domain state
+  are used for passing arguments that do not fit in registers.
+  (Xavier Leroy, review by Vincent Laviron)
+
+
 OCaml 4.12, maintenance version
 -------------------------------
 

ocaml/asmcomp/amd64/emit.mlp

@@ -97,6 +97,7 @@ let slot_offset loc cl =
       then !stack_offset + n * 8
       else !stack_offset + (num_stack_slots.(0) + n) * 8
   | Outgoing n -> n
+  | Domainstate _ -> assert false (* not a stack slot *)
 
 let emit_stack_offset n =
   if n < 0
@@ -200,14 +201,18 @@ let emit_Llabel fallthrough lbl =
 
 (* Output a pseudo-register *)
 
+let x86_data_type_for_stack_slot = function
+  | Float -> REAL8
+  | _ -> QWORD
+
 let reg = function
   | { loc = Reg.Reg r } -> register_name r
-  | { loc = Stack s; typ = Float } as r ->
-      let ofs = slot_offset s (register_class r) in
-      mem64 REAL8 ofs RSP
-  | { loc = Stack s } as r ->
+  | { loc = Stack (Domainstate n); typ = ty } ->
+      let ofs = n + Domainstate.(idx_of_field Domain_extra_params) * 8 in
+      mem64 (x86_data_type_for_stack_slot ty) ofs R14
+  | { loc = Stack s; typ = ty } as r ->
       let ofs = slot_offset s (register_class r) in
-      mem64 QWORD ofs RSP
+      mem64 (x86_data_type_for_stack_slot ty) ofs RSP
   | { loc = Unknown } ->
       assert false