Labels after calls, call GC points and checkbound points (again) (oca…

…ml#660)

asmcomp/CSEgen.ml

@@ -223,15 +223,15 @@ method class_of_operation op =
   | Imove | Ispill | Ireload -> assert false   (* treated specially *)
   | Iconst_int _ | Iconst_float _ | Iconst_symbol _
   | Iconst_blockheader _ -> Op_pure
-  | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _
+  | Icall_ind _ | Icall_imm _ | Itailcall_ind _ | Itailcall_imm _
   | Iextcall _ -> assert false                 (* treated specially *)
   | Istackoffset _ -> Op_other
   | Iload(_,_) -> Op_load
   | Istore(_,_,asg) -> Op_store asg
   | Ialloc _ -> assert false                   (* treated specially *)
-  | Iintop(Icheckbound) -> Op_checkbound
+  | Iintop(Icheckbound _) -> Op_checkbound
   | Iintop _ -> Op_pure
-  | Iintop_imm(Icheckbound, _) -> Op_checkbound
+  | Iintop_imm(Icheckbound _, _) -> Op_checkbound
   | Iintop_imm(_, _) -> Op_pure
   | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf
   | Ifloatofint | Iintoffloat -> Op_pure
@@ -255,15 +255,15 @@ method private kill_loads n =
 
 method private cse n i =
   match i.desc with
-  | Iend | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _)
+  | Iend | Ireturn | Iop(Itailcall_ind _) | Iop(Itailcall_imm _)
   | Iexit _ | Iraise _ ->
       i
   | Iop (Imove | Ispill | Ireload) ->
       (* For moves, we associate the same value number to the result reg
          as to the argument reg. *)
       let n1 = set_move n i.arg.(0) i.res.(0) in
       {i with next = self#cse n1 i.next}
-  | Iop (Icall_ind | Icall_imm _ | Iextcall _) ->
+  | Iop (Icall_ind _ | Icall_imm _ | Iextcall _) ->
       (* For function calls, we should at least forget:
          - equations involving memory loads, since the callee can
            perform arbitrary memory stores;

asmcomp/amd64/emit.mlp

@@ -243,8 +243,12 @@ let addressing addr typ i n =
 
 (* Record live pointers at call points -- see Emitaux *)
 
-let record_frame_label live dbg =
-  let lbl = new_label() in
+let record_frame_label ?label live dbg =
+  let lbl =
+    match label with
+    | None -> new_label()
+    | Some label -> label
+  in
   let live_offset = ref [] in
   Reg.Set.iter
     (function
@@ -264,8 +268,8 @@ let record_frame_label live dbg =
       fd_debuginfo = dbg } :: !frame_descriptors;
   lbl
 
-let record_frame live dbg =
-  let lbl = record_frame_label live dbg in
+let record_frame ?label live dbg =
+  let lbl = record_frame_label ?label live dbg in
   def_label lbl
 
 (* Record calls to the GC -- we've moved them out of the way *)
@@ -294,10 +298,10 @@ type bound_error_call =
 let bound_error_sites = ref ([] : bound_error_call list)
 let bound_error_call = ref 0
 
-let bound_error_label dbg =
+let bound_error_label ?label dbg =
   if !Clflags.debug then begin
     let lbl_bound_error = new_label() in
-    let lbl_frame = record_frame_label Reg.Set.empty dbg in
+    let lbl_frame = record_frame_label ?label Reg.Set.empty dbg in
     bound_error_sites :=
       { bd_lbl = lbl_bound_error; bd_frame = lbl_frame } :: !bound_error_sites;
     lbl_bound_error
@@ -482,32 +486,32 @@ let emit_instr fallthrough i =
   | Lop(Iconst_symbol s) ->
       add_used_symbol s;
       load_symbol_addr s (res i 0)
-  | Lop(Icall_ind) ->
+  | Lop(Icall_ind { label_after; }) ->
       I.call (arg i 0);
-      record_frame i.live i.dbg
-  | Lop(Icall_imm s) ->
-      add_used_symbol s;
-      emit_call s;
-      record_frame i.live i.dbg
-  | Lop(Itailcall_ind) ->
+      record_frame i.live i.dbg ~label:label_after
+  | Lop(Icall_imm { func; label_after; }) ->
+      add_used_symbol func;
+      emit_call func;
+      record_frame i.live i.dbg ~label:label_after
+  | Lop(Itailcall_ind { label_after = _; }) ->
       output_epilogue begin fun () ->
         I.jmp (arg i 0)
       end
-  | Lop(Itailcall_imm s) ->
-      if s = !function_name then
+  | Lop(Itailcall_imm { func; label_after = _; }) ->
+      if func = !function_name then
         I.jmp (label !tailrec_entry_point)
       else begin
         output_epilogue begin fun () ->
-          add_used_symbol s;
-          emit_jump s
+          add_used_symbol func;
+          emit_jump func
         end
       end
-  | Lop(Iextcall(s, alloc)) ->
-      add_used_symbol s;
+  | Lop(Iextcall { func; alloc; label_after; }) ->
+      add_used_symbol func;
       if alloc then begin
-        load_symbol_addr s rax;
+        load_symbol_addr func rax;
         emit_call "caml_c_call";
-        record_frame i.live i.dbg;
+        record_frame i.live i.dbg ~label:label_after;
         if system <> S_win64 then begin
           (* TODO: investigate why such a diff.
              This comes from:
@@ -520,7 +524,7 @@ let emit_instr fallthrough i =
           I.mov (mem64 QWORD 0 R11) r15
         end;
       end else
-        emit_call s
+        emit_call func
   | Lop(Istackoffset n) ->
       if n < 0
       then I.add (int (-n)) rsp
@@ -567,7 +571,7 @@ let emit_instr fallthrough i =
       | Double | Double_u ->
           I.movsd (arg i 0) (addressing addr REAL8 i 1)
       end
-  | Lop(Ialloc n) ->
+  | Lop(Ialloc { words = n; label_after_call_gc; }) ->
       if !fastcode_flag then begin
         let lbl_redo = new_label() in
         def_label lbl_redo;
@@ -594,7 +598,10 @@ let emit_instr fallthrough i =
             I.mov (int n) rax;
             emit_call "caml_allocN"
         end;
-        record_frame i.live Debuginfo.none;
+        let label =
+          record_frame_label ?label:label_after_call_gc i.live Debuginfo.none
+        in
+        def_label label;
         I.lea (mem64 NONE 8 R15) (res i 0)
       end
   | Lop(Iintop(Icomp cmp)) ->
@@ -605,12 +612,12 @@ let emit_instr fallthrough i =
       I.cmp (int n) (arg i 0);
       I.set (cond cmp) al;
       I.movzx al (res i 0)
-  | Lop(Iintop Icheckbound) ->
-      let lbl = bound_error_label i.dbg in
+  | Lop(Iintop (Icheckbound { label_after_error; } )) ->
+      let lbl = bound_error_label ?label:label_after_error i.dbg in
       I.cmp (arg i 1) (arg i 0);
       I.jbe (label lbl)
-  | Lop(Iintop_imm(Icheckbound, n)) ->
-      let lbl = bound_error_label i.dbg in
+  | Lop(Iintop_imm(Icheckbound { label_after_error; }, n)) ->
+      let lbl = bound_error_label ?label:label_after_error i.dbg in
       I.cmp (int n) (arg i 0);
       I.jbe (label lbl)
   | Lop(Iintop(Idiv | Imod)) ->

asmcomp/amd64/proc.ml

@@ -263,8 +263,9 @@ let destroyed_at_c_call =
        108;109;110;111;112;113;114;115])
 
 let destroyed_at_oper = function
-    Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs
-  | Iop(Iextcall(_, false)) -> destroyed_at_c_call
+    Iop(Icall_ind _ | Icall_imm _ | Iextcall { alloc = true; }) ->
+    all_phys_regs
+  | Iop(Iextcall { alloc = false; }) -> destroyed_at_c_call
   | Iop(Iintop(Idiv | Imod)) | Iop(Iintop_imm((Idiv | Imod), _))
         -> [| rax; rdx |]
   | Iop(Istore(Single, _, _)) -> [| rxmm15 |]
@@ -285,11 +286,11 @@ let destroyed_at_raise = all_phys_regs
 
 
 let safe_register_pressure = function
-    Iextcall(_,_) -> if win64 then if fp then 7 else 8 else 0
+    Iextcall _ -> if win64 then if fp then 7 else 8 else 0
   | _ -> if fp then 10 else 11
 
 let max_register_pressure = function
-    Iextcall(_, _) ->
+    Iextcall _ ->
       if win64 then
         if fp then [| 7; 10 |]  else [| 8; 10 |]
         else
@@ -306,9 +307,9 @@ let max_register_pressure = function
    registers). *)
 
 let op_is_pure = function
-  | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _
+  | Icall_ind _ | Icall_imm _ | Itailcall_ind _ | Itailcall_imm _
   | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _
-  | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) -> false
+  | Iintop(Icheckbound _) | Iintop_imm(Icheckbound _, _) -> false
   | Ispecific(Ilea _) -> true
   | Ispecific _ -> false
   | _ -> true

asmcomp/amd64/reload.ml

@@ -66,7 +66,7 @@ inherit Reloadgen.reload_generic as super
 
 method! reload_operation op arg res =
   match op with
-  | Iintop(Iadd|Isub|Iand|Ior|Ixor|Icomp _|Icheckbound) ->
+  | Iintop(Iadd|Isub|Iand|Ior|Ixor|Icomp _|Icheckbound _) ->
       (* One of the two arguments can reside in the stack, but not both *)
       if stackp arg.(0) && stackp arg.(1)
       then ([|arg.(0); self#makereg arg.(1)|], res)

asmcomp/amd64/selection.ml

@@ -131,7 +131,7 @@ method is_immediate_natint n = n <= 0x7FFFFFFFn && n >= -0x80000000n
 
 method! is_simple_expr e =
   match e with
-  | Cop(Cextcall(fn, _, _, _), args)
+  | Cop(Cextcall (fn, _, _, _, _), args)
     when List.mem fn inline_ops ->
       (* inlined ops are simple if their arguments are *)
       List.for_all self#is_simple_expr args
@@ -189,7 +189,7 @@ method! select_operation op args =
       self#select_floatarith true Imulf Ifloatmul args
   | Cdivf ->
       self#select_floatarith false Idivf Ifloatdiv args
-  | Cextcall("sqrt", _, false, _) ->
+  | Cextcall("sqrt", _, false, _, _) ->
      begin match args with
        [Cop(Cload (Double|Double_u as chunk), [loc])] ->
          let (addr, arg) = self#select_addressing chunk loc in
@@ -209,12 +209,12 @@ method! select_operation op args =
       | _ ->
           super#select_operation op args
       end
-  | Cextcall("caml_bswap16_direct", _, _, _) ->
+  | Cextcall("caml_bswap16_direct", _, _, _, _) ->
       (Ispecific (Ibswap 16), args)
-  | Cextcall("caml_int32_direct_bswap", _, _, _) ->
+  | Cextcall("caml_int32_direct_bswap", _, _, _, _) ->
       (Ispecific (Ibswap 32), args)
-  | Cextcall("caml_int64_direct_bswap", _, _, _)
-  | Cextcall("caml_nativeint_direct_bswap", _, _, _) ->
+  | Cextcall("caml_int64_direct_bswap", _, _, _, _)
+  | Cextcall("caml_nativeint_direct_bswap", _, _, _, _) ->
       (Ispecific (Ibswap 64), args)
   (* AMD64 does not support immediate operands for multiply high signed *)
   | Cmulhi ->

asmcomp/arm/emit.mlp

@@ -102,8 +102,12 @@ let emit_addressing addr r n =
 
 (* Record live pointers at call points *)
 
-let record_frame_label live dbg =
-  let lbl = new_label() in
+let record_frame_label ?label live dbg =
+  let lbl =
+    match label with
+    | None -> new_label()
+    | Some label -> label
+  in
   let live_offset = ref [] in
   Reg.Set.iter
     (function
@@ -122,8 +126,8 @@ let record_frame_label live dbg =
       fd_debuginfo = dbg } :: !frame_descriptors;
   lbl
 
-let record_frame live dbg =
-  let lbl = record_frame_label live dbg in `{emit_label lbl}:`
+let record_frame ?label live dbg =
+  let lbl = record_frame_label ?label live dbg in `{emit_label lbl}:`
 
 (* Record calls to the GC -- we've moved them out of the way *)
 
@@ -148,10 +152,10 @@ type bound_error_call =
 
 let bound_error_sites = ref ([] : bound_error_call list)
 
-let bound_error_label dbg =
+let bound_error_label ?label dbg =
   if !Clflags.debug || !bound_error_sites = [] then begin
     let lbl_bound_error = new_label() in
-    let lbl_frame = record_frame_label Reg.Set.empty dbg in
+    let lbl_frame = record_frame_label ?label Reg.Set.empty dbg in
     bound_error_sites :=
       { bd_lbl = lbl_bound_error;
         bd_frame_lbl = lbl_frame } :: !bound_error_sites;
@@ -438,40 +442,40 @@ let emit_instr i =
         end; 1
     | Lop(Iconst_symbol s) ->
         emit_load_symbol_addr i.res.(0) s
-    | Lop(Icall_ind) ->
+    | Lop(Icall_ind { label_after; }) ->
         if !arch >= ARMv5 then begin
           `	blx	{emit_reg i.arg.(0)}\n`;
-          `{record_frame i.live i.dbg}\n`; 1
+          `{record_frame i.live i.dbg ~label:label_after}\n`; 1
         end else begin
           `	mov	lr, pc\n`;
           `	bx	{emit_reg i.arg.(0)}\n`;
-          `{record_frame i.live i.dbg}\n`; 2
+          `{record_frame i.live i.dbg ~label:label_after}\n`; 2
         end
-    | Lop(Icall_imm s) ->
-        `	{emit_call s}\n`;
-        `{record_frame i.live i.dbg}\n`; 1
-    | Lop(Itailcall_ind) ->
+    | Lop(Icall_imm { func; label_after; }) ->
+        `	{emit_call func}\n`;
+        `{record_frame i.live i.dbg ~label:label_after}\n`; 1
+    | Lop(Itailcall_ind { label_after = _; }) ->
         output_epilogue begin fun () ->
           if !contains_calls then
             `	ldr	lr, [sp, #{emit_int (-4)}]\n`;
           `	bx	{emit_reg i.arg.(0)}\n`; 2
         end
-    | Lop(Itailcall_imm s) ->
-        if s = !function_name then begin
+    | Lop(Itailcall_imm { func; label_after = _; }) ->
+        if func = !function_name then begin
           `	b	{emit_label !tailrec_entry_point}\n`; 1
         end else begin
           output_epilogue begin fun () ->
             if !contains_calls then
               `	ldr	lr, [sp, #{emit_int (-4)}]\n`;
-            `	{emit_jump s}\n`; 2
+            `	{emit_jump func}\n`; 2
           end
         end
-    | Lop(Iextcall(s, false)) ->
-        `	{emit_call s}\n`; 1
-    | Lop(Iextcall(s, true)) ->
-        let ninstr = emit_load_symbol_addr (phys_reg 7 (* r7 *)) s in
+    | Lop(Iextcall { func; alloc = false; }) ->
+        `	{emit_call func}\n`; 1
+    | Lop(Iextcall { func; alloc = true; label_after; }) ->
+        let ninstr = emit_load_symbol_addr (phys_reg 7 (* r7 *)) func in
         `	{emit_call "caml_c_call"}\n`;
-        `{record_frame i.live i.dbg}\n`;
+        `{record_frame i.live i.dbg ~label:label_after}\n`;
         1 + ninstr
     | Lop(Istackoffset n) ->
         assert (n mod 8 = 0);
@@ -541,8 +545,10 @@ let emit_instr i =
           | Double_u -> "fstd"
           | _ (* 32-bit quantities *) -> "str" in
         `	{emit_string instr}	{emit_reg r}, {emit_addressing addr i.arg 1}\n`; 1
-    | Lop(Ialloc n) ->
-        let lbl_frame = record_frame_label i.live i.dbg in
+    | Lop(Ialloc { words = n; label_after_call_gc; }) ->
+        let lbl_frame =
+          record_frame_label i.live i.dbg ?label:label_after_call_gc
+        in
         if !fastcode_flag then begin
           let lbl_redo = new_label() in
           `{emit_label lbl_redo}:`;
@@ -585,12 +591,12 @@ let emit_instr i =
         `	ite	{emit_string compthen}\n`;
         `	mov{emit_string	compthen}	{emit_reg i.res.(0)}, #1\n`;
         `	mov{emit_string compelse}	{emit_reg i.res.(0)}, #0\n`; 4
-    | Lop(Iintop Icheckbound) ->
-        let lbl = bound_error_label i.dbg in
+    | Lop(Iintop (Icheckbound { label_after_error; } )) ->
+        let lbl = bound_error_label ?label:label_after_error i.dbg in
         `	cmp	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
         `	bls	{emit_label lbl}\n`; 2
-    | Lop(Iintop_imm(Icheckbound, n)) ->
-        let lbl = bound_error_label i.dbg in
+    | Lop(Iintop_imm(Icheckbound { label_after_error; }, n)) ->
+        let lbl = bound_error_label ?label:label_after_error i.dbg in
         `	cmp	{emit_reg i.arg.(0)}, #{emit_int n}\n`;
         `	bls	{emit_label lbl}\n`; 2
     | Lop(Ispecific(Ishiftcheckbound(shiftop, n))) ->