Safepoints

.depend

@@ -2173,6 +2173,7 @@ asmcomp/asmgen.cmo : \
     asmcomp/printlinear.cmi \
     asmcomp/printcmm.cmi \
     typing/primitive.cmi \
+    asmcomp/polling.cmi \
     utils/misc.cmi \
     asmcomp/mach.cmi \
     parsing/location.cmi \
@@ -2215,6 +2216,7 @@ asmcomp/asmgen.cmx : \
     asmcomp/printlinear.cmx \
     asmcomp/printcmm.cmx \
     typing/primitive.cmx \
+    asmcomp/polling.cmx \
     utils/misc.cmx \
     asmcomp/mach.cmx \
     parsing/location.cmx \
@@ -2386,10 +2388,12 @@ asmcomp/branch_relaxation.cmi : \
 asmcomp/branch_relaxation_intf.cmo : \
     asmcomp/linear.cmi \
     lambda/debuginfo.cmi \
+    asmcomp/cmm.cmi \
     asmcomp/arch.cmo
 asmcomp/branch_relaxation_intf.cmx : \
     asmcomp/linear.cmx \
     lambda/debuginfo.cmx \
+    asmcomp/cmm.cmx \
     asmcomp/arch.cmx
 asmcomp/cmm.cmo : \
     utils/targetint.cmi \
@@ -2783,6 +2787,21 @@ asmcomp/mach.cmi : \
     asmcomp/cmm.cmi \
     parsing/asttypes.cmi \
     asmcomp/arch.cmo
+asmcomp/polling.cmo : \
+    utils/misc.cmi \
+    asmcomp/mach.cmi \
+    asmcomp/dataflow.cmi \
+    asmcomp/cmm.cmi \
+    asmcomp/polling.cmi
+asmcomp/polling.cmx : \
+    utils/misc.cmx \
+    asmcomp/mach.cmx \
+    asmcomp/dataflow.cmx \
+    asmcomp/cmm.cmx \
+    asmcomp/polling.cmi
+asmcomp/polling.cmi : \
+    utils/misc.cmi \
+    asmcomp/mach.cmi
 asmcomp/printcmm.cmo : \
     utils/targetint.cmi \
     lambda/lambda.cmi \
@@ -2945,6 +2964,7 @@ asmcomp/scheduling.cmi : \
 asmcomp/selectgen.cmo : \
     asmcomp/reg.cmi \
     asmcomp/proc.cmi \
+    asmcomp/polling.cmi \
     utils/numbers.cmi \
     utils/misc.cmi \
     asmcomp/mach.cmi \
@@ -2958,6 +2978,7 @@ asmcomp/selectgen.cmo : \
 asmcomp/selectgen.cmx : \
     asmcomp/reg.cmx \
     asmcomp/proc.cmx \
+    asmcomp/polling.cmx \
     utils/numbers.cmx \
     utils/misc.cmx \
     asmcomp/mach.cmx \
@@ -2970,6 +2991,7 @@ asmcomp/selectgen.cmx : \
     asmcomp/selectgen.cmi
 asmcomp/selectgen.cmi : \
     asmcomp/reg.cmi \
+    utils/misc.cmi \
     asmcomp/mach.cmi \
     lambda/debuginfo.cmi \
     asmcomp/cmm.cmi \
@@ -2993,6 +3015,7 @@ asmcomp/selection.cmx : \
     asmcomp/arch.cmx \
     asmcomp/selection.cmi
 asmcomp/selection.cmi : \
+    utils/misc.cmi \
     asmcomp/mach.cmi \
     asmcomp/cmm.cmi
 asmcomp/spill.cmo : \

Changes

@@ -3,6 +3,13 @@ Working version
 
 ### Language features:
 
+- #10039: Safepoints
+  Add poll points to native generated code. These are effectively
+  zero-sized allocations and fix some signal and remembered set
+  issues. Also multicore prerequisite.
+  (Sadiq Jaffer, Damien Doligez, Mark Shinwell, Anmol Sahoo, Stephen Dolan,
+  Xavier Leroy reviewed by ??)
+
 - #9331: Improve error messages for functor application and functor types.
   (Florian Angeletti and Gabriel Radanne, review by Leo White)
 

asmcomp/CSEgen.ml

@@ -228,7 +228,7 @@ method class_of_operation op =
   | Istackoffset _ -> Op_other
   | Iload(_,_,mut) -> Op_load mut
   | Istore(_,_,asg) -> Op_store asg
-  | Ialloc _ -> assert false                   (* treated specially *)
+  | Ialloc _ | Ipoll _ -> assert false     (* treated specially *)
   | Iintop(Icheckbound) -> Op_checkbound
   | Iintop _ -> Op_pure
   | Iintop_imm(Icheckbound, _) -> Op_checkbound
@@ -280,14 +280,14 @@ method private cse n i =
   | Iop Iopaque ->
       (* Assume arbitrary side effects from Iopaque *)
       {i with next = self#cse empty_numbering i.next}
-  | Iop (Ialloc _) ->
+  | Iop (Ialloc _) | Iop (Ipoll _) ->
       (* For allocations, we must avoid extending the live range of a
          pseudoregister across the allocation if this pseudoreg
          is a derived heap pointer (a pointer into the heap that does
          not point to the beginning of a Caml block).  PR#6484 is an
          example of this situation.  Such pseudoregs have type [Addr].
          Pseudoregs with types other than [Addr] can be kept.
-         Moreover, allocation can trigger the asynchronous execution
+         Moreover, allocations and polls can trigger the asynchronous execution
          of arbitrary Caml code (finalizer, signal handler, context
          switch), which can contain non-initializing stores.
          Hence, all equations over mutable loads must be removed. *)

asmcomp/amd64/emit.mlp

@@ -614,6 +614,27 @@ let emit_instr env fallthrough i =
         def_label label;
         I.lea (mem64 NONE 8 R15) (res i 0)
       end
+  | Lop(Ipoll { return_label }) ->
+      I.cmp (domain_field Domainstate.Domain_young_limit) r15;
+      let gc_call_label = new_label () in
+      let lbl_after_poll = match return_label with
+                  | None -> new_label()
+                  | Some(lbl) -> lbl in
+      let lbl_frame =
+        record_frame_label env i.live (Dbg_alloc [])
+      in
+      begin match return_label with
+      | None -> I.jbe (label gc_call_label)
+      | Some return_label -> I.ja (label return_label)
+      end;
+      env.call_gc_sites <-
+        { gc_lbl = gc_call_label;
+          gc_return_lbl = lbl_after_poll;
+          gc_frame_lbl = lbl_frame; } :: env.call_gc_sites;
+      begin match return_label with
+      | None -> def_label lbl_after_poll
+      | Some _ -> I.jmp (label gc_call_label)
+      end
   | Lop(Iintop(Icomp cmp)) ->
       I.cmp (arg i 1) (arg i 0);
       I.set (cond cmp) al;
@@ -763,7 +784,8 @@ let emit_instr env fallthrough i =
 
       begin match system with
       | S_mingw64 | S_cygwin -> D.section [".rdata"] (Some "dr") []
-      | S_macosx | S_win64 -> () (* with LLVM/OS X and MASM, use the text segment *)
+      | S_macosx | S_win64 -> ()
+        (* with LLVM/OS X and MASM, use the text segment *)
       | _ -> D.section [".rodata"] None []
       end;
       D.align 4;

asmcomp/amd64/proc.ml

@@ -71,9 +71,9 @@ let win64 = Arch.win64
        3. C callee-saved registers.
      This translates to the set { r10, r11 }.  These registers hence cannot
      be used for OCaml parameter passing and must also be marked as
-     destroyed across [Ialloc] (otherwise a call to caml_call_gc@PLT might
-     clobber these two registers before the assembly stub saves them into
-     the GC regs block).
+     destroyed across [Ialloc] and [Ipoll] (otherwise a call to
+     caml_call_gc@PLT might clobber these two registers before the assembly
+     stub saves them into the GC regs block).
 *)
 
 let max_arguments_for_tailcalls = 10
@@ -294,7 +294,7 @@ let destroyed_at_c_call =
        100;101;102;103;104;105;106;107;
        108;109;110;111;112;113;114;115])
 
-let destroyed_at_alloc =
+let destroyed_at_alloc_or_poll =
   if X86_proc.use_plt then
     destroyed_by_plt_stub
   else
@@ -307,7 +307,7 @@ let destroyed_at_oper = function
   | Iop(Iintop(Idiv | Imod)) | Iop(Iintop_imm((Idiv | Imod), _))
         -> [| rax; rdx |]
   | Iop(Istore(Single, _, _)) -> [| rxmm15 |]
-  | Iop(Ialloc _) -> destroyed_at_alloc
+  | Iop(Ialloc _ | Ipoll _) -> destroyed_at_alloc_or_poll
   | Iop(Iintop(Imulh | Icomp _) | Iintop_imm((Icomp _), _))
         -> [| rax |]
   | Iswitch(_, _) -> [| rax; rdx |]
@@ -339,7 +339,7 @@ let max_register_pressure = function
         if fp then [| 3; 0 |] else  [| 4; 0 |]
   | Iintop(Idiv | Imod) | Iintop_imm((Idiv | Imod), _) ->
     if fp then [| 10; 16 |] else [| 11; 16 |]
-  | Ialloc _ ->
+  | Ialloc _ | Ipoll _ ->
     if fp then [| 11 - num_destroyed_by_plt_stub; 16 |]
     else [| 12 - num_destroyed_by_plt_stub; 16 |]
   | Iintop(Icomp _) | Iintop_imm((Icomp _), _) ->

asmcomp/amd64/selection.ml

@@ -282,4 +282,5 @@ method! insert_op_debug env op dbg rs rd =
 
 end
 
-let fundecl f = (new selector)#emit_fundecl f
+let fundecl ~future_funcnames f =
+  (new selector)#emit_fundecl ~future_funcnames f

asmcomp/arm/emit.mlp

@@ -622,6 +622,11 @@ let emit_instr env i =
           `{emit_label lbl_frame}:	add	{emit_reg i.res.(0)}, alloc_ptr, #4\n`;
           1 + ninstr
         end
+    | Lop(Ipoll { return_label }) ->
+        begin match return_label with
+          None -> 0
+        | Some lbl -> `     b    {emit_label lbl}\n`; 1
+        end
     | Lop(Iintop(Icomp cmp)) ->
         `	cmp	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
         1 + emit_set_condition cmp i.res.(0)

asmcomp/arm/selection.ml

@@ -328,4 +328,5 @@ method! insert_op_debug env op dbg rs rd =
 
 end
 
-let fundecl f = (new selector)#emit_fundecl f
+let fundecl ~future_funcnames f =
+  (new selector)#emit_fundecl ~future_funcnames f

asmcomp/arm64/arch.ml

@@ -42,6 +42,7 @@ type cmm_label = int
   (* Do not introduce a dependency to Cmm *)
 
 type specific_operation =
+  | Ifar_poll of { return_label: cmm_label option }
   | Ifar_alloc of { bytes : int; dbginfo : Debuginfo.alloc_dbginfo }
   | Ifar_intop_checkbound
   | Ifar_intop_imm_checkbound of { bound : int; }
@@ -105,6 +106,8 @@ let print_addressing printreg addr ppf arg =
 
 let print_specific_operation printreg op ppf arg =
   match op with
+  | Ifar_poll _ ->
+    fprintf ppf "(far) poll"
   | Ifar_alloc { bytes; } ->
     fprintf ppf "(far) alloc %i" bytes
   | Ifar_intop_checkbound ->

asmcomp/arm64/emit.mlp

@@ -354,6 +354,8 @@ let num_call_gc_and_check_bound_points env =
     | Lend -> totals
     | Lop (Ialloc _) when env.f.fun_fast ->
       loop instr.next (call_gc + 1, check_bound)
+    | Lop (Ipoll _) ->
+      loop instr.next (call_gc + 1, check_bound)
     | Lop (Iintop Icheckbound)
     | Lop (Iintop_imm (Icheckbound, _))
     | Lop (Ispecific (Ishiftcheckbound _)) ->
@@ -366,6 +368,7 @@ let num_call_gc_and_check_bound_points env =
     (* The following four should never be seen, since this function is run
        before branch relaxation. *)
     | Lop (Ispecific (Ifar_alloc _))
+    | Lop (Ispecific (Ifar_poll _))
     | Lop (Ispecific Ifar_intop_checkbound)
     | Lop (Ispecific (Ifar_intop_imm_checkbound _))
     | Lop (Ispecific (Ifar_shiftcheckbound _)) -> assert false
@@ -412,6 +415,7 @@ module BR = Branch_relaxation.Make (struct
 
     let classify_instr = function
       | Lop (Ialloc _)
+      | Lop (Ipoll _)
       | Lop (Iintop Icheckbound)
       | Lop (Iintop_imm (Icheckbound, _))
       | Lop (Ispecific (Ishiftcheckbound _)) -> Some Bcc
@@ -459,6 +463,8 @@ module BR = Branch_relaxation.Make (struct
       based + begin match size with Single -> 2 | _ -> 1 end
     | Lop (Ialloc _) when f.fun_fast -> 5
     | Lop (Ispecific (Ifar_alloc _)) when f.fun_fast -> 6
+    | Lop (Ipoll _) -> 3
+    | Lop (Ispecific (Ifar_poll _)) -> 4
     | Lop (Ialloc { bytes = num_bytes; _ })
     | Lop (Ispecific (Ifar_alloc { bytes = num_bytes; _ })) ->
       begin match num_bytes with
@@ -517,6 +523,9 @@ module BR = Branch_relaxation.Make (struct
       | Lambda.Raise_notrace -> 4
       end
 
+  let relax_poll ~return_label =
+    Lop (Ispecific (Ifar_poll { return_label }))
+
   let relax_allocation ~num_bytes ~dbginfo =
     Lop (Ispecific (Ifar_alloc { bytes = num_bytes; dbginfo }))
 
@@ -574,6 +583,38 @@ let assembly_code_for_allocation env i ~n ~far ~dbginfo =
     `{emit_label lbl_frame}:	add	{emit_reg i.res.(0)}, {emit_reg reg_alloc_ptr}, #8\n`
   end
 
+let assembly_code_for_poll env i ~far ~return_label =
+  let lbl_frame =
+    record_frame_label env i.live (Dbg_alloc [])
+  in
+  let lbl_call_gc = new_label() in
+  let lbl_after_poll = match return_label with
+  | None -> new_label()
+  | Some lbl -> lbl in
+  let offset = Domainstate.(idx_of_field Domain_young_limit) * 8 in
+    `	ldr	{emit_reg reg_tmp1}, [{emit_reg reg_domain_state_ptr}, #{emit_int offset}]\n`;
+    `	cmp	{emit_reg reg_alloc_ptr}, {emit_reg reg_tmp1}\n`;
+  if not far then begin
+    match return_label with
+    | None -> `	b.ls	{emit_label lbl_call_gc}\n`
+    | Some return_label ->
+      begin
+        ` b.hi {emit_label return_label}\n`;
+        ` b    {emit_label lbl_call_gc}\n`;
+      end
+  end else begin
+    `	b.hi	{emit_label lbl_after_poll}\n`;
+    ` b     {emit_label lbl_call_gc}\n`
+  end;
+  begin match return_label with
+  | None -> `{emit_label lbl_after_poll}:`
+  | _ -> ()
+  end;
+  env.call_gc_sites <-
+    { gc_lbl = lbl_call_gc;
+      gc_return_lbl = lbl_after_poll;
+      gc_frame_lbl = lbl_frame; } :: env.call_gc_sites
+
 (* Output .text section directive, or named .text.caml.<name> if enabled. *)
 
 let emit_named_text_section func_name =
@@ -727,6 +768,10 @@ let emit_instr env i =
         assembly_code_for_allocation env i ~n ~far:false ~dbginfo
     | Lop(Ispecific (Ifar_alloc { bytes = n; dbginfo })) ->
         assembly_code_for_allocation env i ~n ~far:true ~dbginfo
+    | Lop(Ipoll { return_label }) ->
+        assembly_code_for_poll env i ~far:false ~return_label
+    | Lop(Ispecific (Ifar_poll { return_label })) ->
+        assembly_code_for_poll env i ~far:true ~return_label
     | Lop(Iintop_imm(Iadd, n)) ->
         emit_addimm i.res.(0) i.arg.(0) n
     | Lop(Iintop_imm(Isub, n)) ->

asmcomp/arm64/proc.ml

@@ -256,7 +256,7 @@ let destroyed_at_oper = function
       all_phys_regs
   | Iop(Iextcall { alloc = false; }) ->
       destroyed_at_c_call
-  | Iop(Ialloc _) ->
+  | Iop(Ialloc _) | Iop(Ipoll _) ->
       [| reg_x8 |]
   | Iop( Iintoffloat | Ifloatofint
        | Iload(Single, _, _) | Istore(Single, _, _)) ->
@@ -271,12 +271,12 @@ let destroyed_at_reloadretaddr = [| |]
 
 let safe_register_pressure = function
   | Iextcall _ -> 7
-  | Ialloc _ -> 22
+  | Ialloc _ | Ipoll _ -> 22
   | _ -> 23
 
 let max_register_pressure = function
   | Iextcall _ -> [| 7; 8 |]  (* 7 integer callee-saves, 8 FP callee-saves *)
-  | Ialloc _ -> [| 22; 32 |]
+  | Ialloc _ | Ipoll _ -> [| 22; 32 |]
   | Iintoffloat | Ifloatofint
   | Iload(Single, _, _) | Istore(Single, _, _) -> [| 23; 31 |]
   | _ -> [| 23; 32 |]

asmcomp/arm64/selection.ml

@@ -212,4 +212,5 @@ method! insert_move_extcall_arg env ty_arg src dst =
   else self#insert_moves env src dst
 end
 
-let fundecl f = (new selector)#emit_fundecl f
+let fundecl ~future_funcnames f = (new selector)#emit_fundecl
+                                            ~future_funcnames f