Linearize: for Trywith, remove the jump/call to the handler (ocaml#2237)

asmcomp/amd64/emit.mlp

@@ -865,14 +865,22 @@ let emit_instr fallthrough i =
                          ConstLabel lbl))
       done;
       D.text ()
-  | Lsetuptrap lbl ->
-      I.call (label lbl)
-  | Lpushtrap ->
-      cfi_adjust_cfa_offset 8;
-      I.push r14;
-      cfi_adjust_cfa_offset 8;
-      I.mov rsp r14;
-      stack_offset := !stack_offset + 16
+  | Lentertrap ->
+      ()
+  | Lpushtrap { lbl_handler; } ->
+      let load_label_addr s arg =
+        if !Clflags.pic_code then
+          I.lea (mem64_rip NONE (emit_label s)) arg
+        else
+          I.mov (sym (emit_label s)) arg
+      in
+      cfi_adjust_cfa_offset 16;
+      I.sub (int 16) rsp;
+      stack_offset := !stack_offset + 16;
+      I.mov r14 (mem64 QWORD 0 RSP);
+      load_label_addr lbl_handler r14;
+      I.mov r14 (mem64 QWORD 8 RSP);
+      I.mov rsp r14
   | Lpoptrap ->
       I.pop r14;
       cfi_adjust_cfa_offset (-8);
@@ -890,7 +898,8 @@ let emit_instr fallthrough i =
       | Cmm.Raise_notrace ->
           I.mov r14 rsp;
           I.pop r14;
-          I.ret ()
+          I.pop r11;
+          I.jmp r11
       end
 
 let rec emit_all fallthrough i =

asmcomp/arm/emit.mlp

@@ -285,6 +285,14 @@ let symbol_literals = ref ([] : (string * label) list)
 (* Total space (in words) occupied by pending literals *)
 let size_literals = ref 0
 
+(* Pending offset computations : {lbl; dst; src;} --> lbl: .word dst-(src+N) *)
+type offset_computation =
+  { lbl : label;
+    dst : label;
+    src : label;
+  }
+let offset_literals = ref ([] : offset_computation list)
+
 (* Label a floating-point literal *)
 let float_literal f =
   try
@@ -312,6 +320,13 @@ let symbol_literal s =
     symbol_literals := (s, lbl) :: !symbol_literals;
     lbl
 
+(* Add an offset computation *)
+let offset_literal dst src =
+  let lbl = new_label() in
+  size_literals := !size_literals + 1;
+  offset_literals := { lbl; dst; src; } :: !offset_literals;
+  lbl
+
 (* Emit all pending literals *)
 let emit_literals() =
   if !float_literals <> [] then begin
@@ -337,6 +352,17 @@ let emit_literals() =
     gotrel_literals := [];
     symbol_literals := []
   end;
+  if !offset_literals <> [] then begin
+    (* Additions using the pc register read a value 4 or 8 bytes greater than
+       the instruction's address, depending on the thumb setting *)
+    let offset = if !thumb then 4 else 8 in
+    `	.align	2\n`;
+    List.iter
+      (fun { lbl; dst; src; } ->
+         `{emit_label lbl}:	.word	{emit_label dst}-({emit_label src}+{emit_int offset})\n`)
+      !offset_literals;
+    offset_literals := []
+  end;
   size_literals := 0
 
 (* Emit code to load the address of a symbol *)
@@ -406,6 +432,17 @@ let emit_profile() =
       2
   | _ -> 0
 
+
+(* Emit code to load the address of a label in the lr register *)
+let emit_load_handler_address handler =
+  (* PIC code *)
+  let lbl_src = new_label() in
+  let lbl_offset = offset_literal handler lbl_src in
+  `	ldr	lr, {emit_label lbl_offset}\n`;
+  `{emit_label lbl_src}:\n`;
+  `	add	lr, pc, lr\n`;
+  2
+
 (* Output the assembly code for an instruction *)
 
 let emit_instr i =
@@ -838,13 +875,14 @@ let emit_instr i =
           done;
           2 + Array.length jumptbl
         end
-    | Lsetuptrap lbl ->
-        `	bl	{emit_label lbl}\n`; 1
-    | Lpushtrap ->
+    | Lentertrap ->
+        0
+    | Lpushtrap { lbl_handler; } ->
+        let s = emit_load_handler_address lbl_handler in
         stack_offset := !stack_offset + 8;
         `	push	\{trap_ptr, lr}\n`;
         cfi_adjust_cfa_offset 8;
-        `	mov	trap_ptr, sp\n`; 2
+        `	mov	trap_ptr, sp\n`; s + 2
     | Lpoptrap ->
         `	pop	\{trap_ptr, lr}\n`;
         cfi_adjust_cfa_offset (-8);

asmcomp/arm64/emit.mlp

@@ -494,8 +494,8 @@ module BR = Branch_relaxation.Make (struct
         + begin match lbl1 with None -> 0 | Some _ -> 1 end
         + begin match lbl2 with None -> 0 | Some _ -> 1 end
     | Lswitch jumptbl -> 3 + Array.length jumptbl
-    | Lsetuptrap _ -> 2
-    | Lpushtrap -> 3
+    | Lentertrap -> 0
+    | Lpushtrap _ -> 4
     | Lpoptrap -> 1
     | Lraise k ->
       begin match k with
@@ -873,12 +873,10 @@ let emit_instr i =
             `	.word	{emit_label jumptbl.(j)} - {emit_label lbltbl}\n`
         done
 *)
-    | Lsetuptrap lbl ->
-        let lblnext = new_label() in
-        `	adr	{emit_reg reg_tmp1}, {emit_label lblnext}\n`;
-        `	b	{emit_label lbl}\n`;
-        `{emit_label lblnext}:\n`
-    | Lpushtrap ->
+    | Lentertrap ->
+        ()
+    | Lpushtrap { lbl_handler; } ->
+        `	adr	{emit_reg reg_tmp1}, {emit_label lbl_handler}\n`;
         stack_offset := !stack_offset + 16;
         `	str	{emit_reg reg_trap_ptr}, [sp, -16]!\n`;
         `	str	{emit_reg reg_tmp1}, [sp, #8]\n`;

asmcomp/i386/emit.mlp

@@ -880,9 +880,10 @@ let emit_instr fallthrough i =
         D.long (ConstLabel (emit_label jumptbl.(i)))
       done;
       D.text ()
-  | Lsetuptrap lbl ->
-      I.call (label lbl)
-  | Lpushtrap ->
+  | Lentertrap ->
+      ()
+  | Lpushtrap { lbl_handler; } ->
+      I.push (label lbl_handler);
       if trap_frame_size > 8 then
         I.sub (int (trap_frame_size - 8)) esp;
       I.push (sym32 "caml_exception_pointer");
@@ -904,7 +905,8 @@ let emit_instr fallthrough i =
           I.pop (sym32 "caml_exception_pointer");
           if trap_frame_size > 8 then
             I.add (int (trap_frame_size - 8)) esp;
-          I.ret ()
+          I.pop ebx;
+          I.jmp ebx
       end
 
 let rec emit_all fallthrough i =

asmcomp/linearize.ml

@@ -39,8 +39,8 @@ and instruction_desc =
   | Lcondbranch of test * label
   | Lcondbranch3 of label option * label option * label option
   | Lswitch of label array
-  | Lsetuptrap of label
-  | Lpushtrap
+  | Lentertrap
+  | Lpushtrap of { lbl_handler : label; }
   | Lpoptrap
   | Lraise of Cmm.raise_kind
 
@@ -130,7 +130,7 @@ let rec discard_dead_code n =
   | Llabel _ -> n
 (* Do not discard Lpoptrap/Lpushtrap or Istackoffset instructions,
    as this may cause a stack imbalance later during assembler generation. *)
-  | Lpoptrap | Lpushtrap -> n
+  | Lpoptrap | Lpushtrap _ -> n
   | Lop(Istackoffset _) -> n
   | _ -> discard_dead_code n.next
 
@@ -281,9 +281,11 @@ let rec linear i n =
          only to inform the later pass about this stack offset
          (corresponding to N traps).
        *)
+      let lbl_dummy = lbl in
       let rec loop i tt =
         if t = tt then i
-        else loop (cons_instr Lpushtrap i) (tt - 1)
+        else
+          loop (cons_instr (Lpushtrap { lbl_handler = lbl_dummy; }) i) (tt - 1)
       in
       let n1 = loop (linear i.Mach.next n) !try_depth in
       let rec loop i tt =
@@ -293,14 +295,19 @@ let rec linear i n =
       loop (add_branch lbl n1) !try_depth
   | Itrywith(body, handler) ->
       let (lbl_join, n1) = get_label (linear i.Mach.next n) in
+      let (lbl_handler, n2) =
+        get_label (cons_instr Lentertrap (linear handler n1))
+      in
       incr try_depth;
       assert (i.Mach.arg = [| |] || Config.spacetime);
-      let (lbl_body, n2) =
-        get_label (instr_cons Lpushtrap i.Mach.arg [| |]
-                    (linear body (cons_instr Lpoptrap n1))) in
+      let n3 = cons_instr (Lpushtrap { lbl_handler; })
+                 (linear body
+                    (cons_instr
+                       Lpoptrap
+                       (add_branch lbl_join n2))) in
       decr try_depth;
-      instr_cons (Lsetuptrap lbl_body) i.Mach.arg [| |]
-        (linear handler (add_branch lbl_join n2))
+      n3
+
   | Iraise k ->
       copy_instr (Lraise k) i (discard_dead_code n)
 

asmcomp/linearize.mli

@@ -36,8 +36,8 @@ and instruction_desc =
   | Lcondbranch of Mach.test * label
   | Lcondbranch3 of label option * label option * label option
   | Lswitch of label array
-  | Lsetuptrap of label
-  | Lpushtrap
+  | Lentertrap
+  | Lpushtrap of { lbl_handler : label; }
   | Lpoptrap
   | Lraise of Cmm.raise_kind
 

asmcomp/power/emit.mlp

@@ -502,8 +502,8 @@ module BR = Branch_relaxation.Make (struct
         + (if lbl1 = None then 0 else 1)
         + (if lbl2 = None then 0 else 1)
     | Lswitch _ -> size 7 (5 + tocload_size()) (5 + tocload_size())
-    | Lsetuptrap _ -> size 1 2 2
-    | Lpushtrap -> size 4 5 5
+    | Lentertrap -> size 0 (tocload_size()) (tocload_size())
+    | Lpushtrap _ -> size 5 (4 + tocload_size()) (4 + tocload_size())
     | Lpoptrap -> 2
     | Lraise _ -> 6
 
@@ -975,24 +975,24 @@ let emit_instr i =
           done;
           emit_string code_space
         end
-    | Lsetuptrap lbl ->
-        `	bl	{emit_label lbl}\n`;
+    | Lentertrap ->
         begin match abi with
         | ELF32 -> ()
         | ELF64v1 | ELF64v2 -> emit_reload_toc()
         end
-    | Lpushtrap ->
+    | Lpushtrap { lbl_handler; } ->
         begin match abi with
         | ELF32 ->
-          `	mflr	0\n`;
-          `	stwu    0, -16(1)\n`;
+          `	addis	11, 0, {emit_upper emit_label lbl_handler}\n`;
+          `	addi	11, 11, {emit_lower emit_label lbl_handler}\n`;
+          `	stwu    11, -16(1)\n`;
           adjust_stack_offset 16;
           `	stw	29, 4(1)\n`;
           `	mr	29, 1\n`
         | ELF64v1 | ELF64v2 ->
-          `	mflr	0\n`;
-          `	addi	1, 1, -32\n`;
-          adjust_stack_offset 32;
+          `	addi	1, 1, {emit_int (-trap_size)}\n`;
+          adjust_stack_offset trap_size;
+          emit_tocload emit_gpr 0 (TocLabel lbl_handler);
           `	std     0, {emit_int trap_handler_offset}(1)\n`;
           `	std	29, {emit_int trap_previous_offset}(1)\n`;
           `	mr	29, 1\n`

asmcomp/printlinear.ml

@@ -59,10 +59,10 @@ let instr ppf i =
        fprintf ppf "case %i: goto %a" i label lblv.(i)
       done;
       fprintf ppf "@,endswitch"
-  | Lsetuptrap lbl ->
-      fprintf ppf "setup trap %a" label lbl
-  | Lpushtrap ->
-      fprintf ppf "push trap"
+  | Lentertrap ->
+      fprintf ppf "enter trap"
+  | Lpushtrap { lbl_handler; } ->
+      fprintf ppf "push trap %a" label lbl_handler
   | Lpoptrap ->
       fprintf ppf "pop trap"
   | Lraise k ->

asmcomp/s390x/emit.mlp

@@ -608,11 +608,12 @@ let emit_instr i =
           `	.long	{emit_label jumptbl.(i)} - {emit_label lbl}\n`
         done;
         emit_string code_space
-    | Lsetuptrap lbl ->
-        `	brasl	%r14, {emit_label lbl}\n`;
-    | Lpushtrap ->
+    | Lentertrap ->
+        ()
+    | Lpushtrap { lbl_handler; } ->
         stack_offset := !stack_offset + 16;
         emit_stack_adjust 16;
+        `	larl	%r14, {emit_label lbl_handler}\n`;
         `	stg	%r14, 0(%r15)\n`;
         `	stg	%r13, {emit_int size_addr}(%r15)\n`;
         `	lgr	%r13, %r15\n`

asmcomp/schedgen.ml

@@ -360,7 +360,8 @@ method schedule_fundecl f =
   let rec schedule i try_nesting =
     match i.desc with
     | Lend -> i
-    | Lpushtrap -> { i with next = schedule i.next (try_nesting + 1) }
+    | Lpushtrap { lbl_handler = _; }
+      -> { i with next = schedule i.next (try_nesting + 1) }
     | Lpoptrap -> { i with next = schedule i.next (try_nesting - 1) }
     | _ ->
         if self#instr_in_basic_block i try_nesting then begin