diff --git a/asmcomp/CSEgen.ml b/asmcomp/CSEgen.ml index 45e32baf0ff9..194aa9125f9a 100644 --- a/asmcomp/CSEgen.ml +++ b/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,7 +255,7 @@ 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) -> @@ -263,7 +263,7 @@ method private cse n i = 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; diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp index 594480cf7ccd..f3dd22746f78 100644 --- a/asmcomp/amd64/emit.mlp +++ b/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)) -> diff --git a/asmcomp/amd64/proc.ml b/asmcomp/amd64/proc.ml index d3f940f725f4..c90c6ec37539 100644 --- a/asmcomp/amd64/proc.ml +++ b/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 diff --git a/asmcomp/amd64/reload.ml b/asmcomp/amd64/reload.ml index f5140faa6e59..b8478c7cffc0 100644 --- a/asmcomp/amd64/reload.ml +++ b/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) diff --git a/asmcomp/amd64/selection.ml b/asmcomp/amd64/selection.ml index 8e4d1cb2bf52..d90d86a61611 100644 --- a/asmcomp/amd64/selection.ml +++ b/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 -> diff --git a/asmcomp/arm/emit.mlp b/asmcomp/arm/emit.mlp index e87f1abe2f08..7e6ec30d2ccf 100644 --- a/asmcomp/arm/emit.mlp +++ b/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))) -> diff --git a/asmcomp/arm/proc.ml b/asmcomp/arm/proc.ml index 0a22a78f90b0..978b3d1e3272 100644 --- a/asmcomp/arm/proc.ml +++ b/asmcomp/arm/proc.ml @@ -252,10 +252,10 @@ let destroyed_at_c_call = 124;125;126;127;128;129;130;131])) let destroyed_at_oper = function - Iop(Icall_ind | Icall_imm _) - | Iop(Iextcall(_, true)) -> + Iop(Icall_ind _ | Icall_imm _) + | Iop(Iextcall { alloc = true; _ }) -> all_phys_regs - | Iop(Iextcall(_, false)) -> + | Iop(Iextcall { alloc = false; _}) -> destroyed_at_c_call | Iop(Ialloc _) -> destroyed_at_alloc @@ -272,14 +272,14 @@ let destroyed_at_raise = all_phys_regs (* Maximal register pressure *) let safe_register_pressure = function - Iextcall(_, _) -> if abi = EABI then 0 else 4 + Iextcall _ -> if abi = EABI then 0 else 4 | Ialloc _ -> if abi = EABI then 0 else 7 | Iconst_symbol _ when !Clflags.pic_code -> 7 | Iintop Imulh when !arch < ARMv6 -> 8 | _ -> 9 let max_register_pressure = function - Iextcall(_, _) -> if abi = EABI then [| 4; 0; 0 |] else [| 4; 8; 8 |] + Iextcall _ -> if abi = EABI then [| 4; 0; 0 |] else [| 4; 8; 8 |] | Ialloc _ -> if abi = EABI then [| 7; 0; 0 |] else [| 7; 8; 8 |] | Iconst_symbol _ when !Clflags.pic_code -> [| 7; 16; 32 |] | Iintoffloat | Ifloatofint @@ -291,9 +291,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, _) + | Iintop(Icheckbound _) | Iintop_imm(Icheckbound _, _) | Ispecific(Ishiftcheckbound _) -> false | _ -> true diff --git a/asmcomp/arm/scheduling.ml b/asmcomp/arm/scheduling.ml index 9d847d4cef0c..4039eaac8b84 100644 --- a/asmcomp/arm/scheduling.ml +++ b/asmcomp/arm/scheduling.ml @@ -58,8 +58,8 @@ method oper_issue_cycles = function | Iintop(Ilsl | Ilsr | Iasr) -> 2 | Iintop(Icomp _) | Iintop_imm(Icomp _, _) -> 3 - | Iintop(Icheckbound) - | Iintop_imm(Icheckbound, _) -> 2 + | Iintop(Icheckbound _) + | Iintop_imm(Icheckbound _, _) -> 2 | Ispecific(Ishiftcheckbound _) -> 3 | Iintop(Imul | Imulh) | Ispecific(Imuladd | Imulsub | Imulhadd) -> 2 diff --git a/asmcomp/arm/selection.ml b/asmcomp/arm/selection.ml index 1be5026d4a84..2eb5717f7468 100644 --- a/asmcomp/arm/selection.ml +++ b/asmcomp/arm/selection.ml @@ -78,7 +78,7 @@ let pseudoregs_for_operation op arg res = (arg', res) (* We use __aeabi_idivmod for Cmodi only, and hence we care only for the remainder in r1, so fix up the destination register. *) - | Iextcall("__aeabi_idivmod", false) -> + | Iextcall { func = "__aeabi_idivmod"; alloc = false; } -> (arg, [|r1|]) (* Other instructions are regular *) | _ -> raise Use_default @@ -107,12 +107,12 @@ method is_immediate n = method! is_simple_expr = function (* inlined floating-point ops are simple if their arguments are *) - | Cop(Cextcall("sqrt", _, _, _), args) when !fpu >= VFPv2 -> + | Cop(Cextcall("sqrt", _, _, _, _), args) when !fpu >= VFPv2 -> List.for_all self#is_simple_expr args (* inlined byte-swap ops are simple if their arguments are *) - | Cop(Cextcall("caml_bswap16_direct", _, _, _), args) when !arch >= ARMv6T2 -> + | Cop(Cextcall("caml_bswap16_direct", _, _, _, _), args) when !arch >= ARMv6T2 -> List.for_all self#is_simple_expr args - | Cop(Cextcall("caml_int32_direct_bswap", _,_,_), args) when !arch >= ARMv6 -> + | Cop(Cextcall("caml_int32_direct_bswap", _,_,_,_), args) when !arch >= ARMv6 -> List.for_all self#is_simple_expr args | e -> super#is_simple_expr e @@ -164,6 +164,9 @@ method select_shift_arith op arithop arithrevop args = | op_args -> op_args end +method private iextcall (func, alloc) = + Iextcall { func; alloc; label_after = Cmm.new_label (); } + method! select_operation op args = match (op, args) with (* Recognize special shift arithmetic *) @@ -196,15 +199,15 @@ method! select_operation op args = (Iintop Imulh, args) (* Turn integer division/modulus into runtime ABI calls *) | (Cdivi, args) -> - (Iextcall("__aeabi_idiv", false), args) + (self#iextcall("__aeabi_idiv", false), args) | (Cmodi, args) -> (* See above for fix up of return register *) - (Iextcall("__aeabi_idivmod", false), args) + (self#iextcall("__aeabi_idivmod", false), args) (* Recognize 16-bit bswap instruction (ARMv6T2 because we need movt) *) - | (Cextcall("caml_bswap16_direct", _, _, _), args) when !arch >= ARMv6T2 -> + | (Cextcall("caml_bswap16_direct", _, _, _, _), args) when !arch >= ARMv6T2 -> (Ispecific(Ibswap 16), args) (* Recognize 32-bit bswap instructions (ARMv6 and above) *) - | (Cextcall("caml_int32_direct_bswap", _, _, _), args) when !arch >= ARMv6 -> + | (Cextcall("caml_int32_direct_bswap", _, _, _, _), args) when !arch >= ARMv6 -> (Ispecific(Ibswap 32), args) (* Turn floating-point operations into runtime ABI calls for softfp *) | (op, args) when !fpu = Soft -> self#select_operation_softfp op args @@ -214,12 +217,12 @@ method! select_operation op args = method private select_operation_softfp op args = match (op, args) with (* Turn floating-point operations into runtime ABI calls *) - | (Caddf, args) -> (Iextcall("__aeabi_dadd", false), args) - | (Csubf, args) -> (Iextcall("__aeabi_dsub", false), args) - | (Cmulf, args) -> (Iextcall("__aeabi_dmul", false), args) - | (Cdivf, args) -> (Iextcall("__aeabi_ddiv", false), args) - | (Cfloatofint, args) -> (Iextcall("__aeabi_i2d", false), args) - | (Cintoffloat, args) -> (Iextcall("__aeabi_d2iz", false), args) + | (Caddf, args) -> (self#iextcall("__aeabi_dadd", false), args) + | (Csubf, args) -> (self#iextcall("__aeabi_dsub", false), args) + | (Cmulf, args) -> (self#iextcall("__aeabi_dmul", false), args) + | (Cdivf, args) -> (self#iextcall("__aeabi_ddiv", false), args) + | (Cfloatofint, args) -> (self#iextcall("__aeabi_i2d", false), args) + | (Cintoffloat, args) -> (self#iextcall("__aeabi_d2iz", false), args) | (Ccmpf comp, args) -> let func = (match comp with Cne (* there's no __aeabi_dcmpne *) @@ -232,13 +235,13 @@ method private select_operation_softfp op args = Cne -> Ceq (* eq 0 => false *) | _ -> Cne (* ne 0 => true *)) in (Iintop_imm(Icomp(Iunsigned comp), 0), - [Cop(Cextcall(func, typ_int, false, Debuginfo.none), args)]) + [Cop(Cextcall(func, typ_int, false, Debuginfo.none, None), args)]) (* Add coercions around loads and stores of 32-bit floats *) | (Cload Single, args) -> - (Iextcall("__aeabi_f2d", false), [Cop(Cload Word_int, args)]) + (self#iextcall("__aeabi_f2d", false), [Cop(Cload Word_int, args)]) | (Cstore (Single, init), [arg1; arg2]) -> let arg2' = - Cop(Cextcall("__aeabi_d2f", typ_int, false, Debuginfo.none), + Cop(Cextcall("__aeabi_d2f", typ_int, false, Debuginfo.none, None), [arg2]) in self#select_operation (Cstore (Word_int, init)) [arg1; arg2'] (* Other operations are regular *) @@ -264,7 +267,7 @@ method private select_operation_vfpv3 op args = | (Csubf, [Cop(Cmulf, args); arg]) -> (Ispecific Imulsubf, arg :: args) (* Recognize floating-point square root *) - | (Cextcall("sqrt", _, false, _), args) -> + | (Cextcall("sqrt", _, false, _, _), args) -> (Ispecific Isqrtf, args) (* Other operations are regular *) | (op, args) -> super#select_operation op args diff --git a/asmcomp/arm64/arch.ml b/asmcomp/arm64/arch.ml index fa40f2537703..633b809c2cb4 100644 --- a/asmcomp/arm64/arch.ml +++ b/asmcomp/arm64/arch.ml @@ -35,12 +35,14 @@ type addressing_mode = (* Specific operations *) type specific_operation = - | Ifar_alloc of int - | Ifar_intop_checkbound - | Ifar_intop_imm_checkbound of int + | Ifar_alloc of { words : int; label_after_call_gc : Cmm.label option; } + | Ifar_intop_checkbound of { label_after_error : Cmm.label option; } + | Ifar_intop_imm_checkbound of + { bound : int; label_after_error : Cmm.label option; } | Ishiftarith of arith_operation * int - | Ishiftcheckbound of int - | Ifar_shiftcheckbound of int + | Ishiftcheckbound of { shift : int; label_after_error : Cmm.label option; } + | Ifar_shiftcheckbound of + { shift : int; label_after_error : Cmm.label option; } | Imuladd (* multiply and add *) | Imulsub (* multiply and subtract *) | Inegmulf (* floating-point negate and multiply *) @@ -96,12 +98,12 @@ let print_addressing printreg addr ppf arg = let print_specific_operation printreg op ppf arg = match op with - | Ifar_alloc n -> - fprintf ppf "(far) alloc %i" n - | Ifar_intop_checkbound -> + | Ifar_alloc { words; label_after_call_gc = _; } -> + fprintf ppf "(far) alloc %i" words + | Ifar_intop_checkbound _ -> fprintf ppf "%a (far) check > %a" printreg arg.(0) printreg arg.(1) - | Ifar_intop_imm_checkbound n -> - fprintf ppf "%a (far) check > %i" printreg arg.(0) n + | Ifar_intop_imm_checkbound { bound; _ } -> + fprintf ppf "%a (far) check > %i" printreg arg.(0) bound | Ishiftarith(op, shift) -> let op_name = function | Ishiftadd -> "+" @@ -112,11 +114,12 @@ let print_specific_operation printreg op ppf arg = else sprintf ">> %i" (-shift) in fprintf ppf "%a %s %a %s" printreg arg.(0) (op_name op) printreg arg.(1) shift_mark - | Ishiftcheckbound n -> - fprintf ppf "check %a >> %i > %a" printreg arg.(0) n printreg arg.(1) - | Ifar_shiftcheckbound n -> + | Ishiftcheckbound { shift; _ } -> + fprintf ppf "check %a >> %i > %a" printreg arg.(0) shift + printreg arg.(1) + | Ifar_shiftcheckbound { shift; _ } -> fprintf ppf - "(far) check %a >> %i > %a" printreg arg.(0) n printreg arg.(1) + "(far) check %a >> %i > %a" printreg arg.(0) shift printreg arg.(1) | Imuladd -> fprintf ppf "(%a * %a) + %a" printreg arg.(0) diff --git a/asmcomp/arm64/emit.mlp b/asmcomp/arm64/emit.mlp index d2e8bbd31890..4e32094fe053 100644 --- a/asmcomp/arm64/emit.mlp +++ b/asmcomp/arm64/emit.mlp @@ -121,8 +121,12 @@ let emit_addressing addr r = (* 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 @@ -141,8 +145,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 *) @@ -167,10 +171,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; @@ -343,8 +347,8 @@ let num_call_gc_and_check_bound_points instr = | Lend -> totals | Lop (Ialloc _) when !fastcode_flag -> loop instr.next (call_gc + 1, check_bound) - | Lop (Iintop Icheckbound) - | Lop (Iintop_imm (Icheckbound, _)) + | Lop (Iintop Icheckbound _) + | Lop (Iintop_imm (Icheckbound _, _)) | Lop (Ispecific (Ishiftcheckbound _)) -> let check_bound = (* When not in debug mode, there is at most one check-bound point. *) @@ -355,7 +359,7 @@ let num_call_gc_and_check_bound_points instr = (* The following four should never be seen, since this function is run before branch relaxation. *) | Lop (Ispecific (Ifar_alloc _)) - | Lop (Ispecific Ifar_intop_checkbound) + | Lop (Ispecific Ifar_intop_checkbound _) | Lop (Ispecific (Ifar_intop_imm_checkbound _)) | Lop (Ispecific (Ifar_shiftcheckbound _)) -> assert false | _ -> loop instr.next totals @@ -401,8 +405,8 @@ module BR = Branch_relaxation.Make (struct let classify_instr = function | Lop (Ialloc _) - | Lop (Iintop Icheckbound) - | Lop (Iintop_imm (Icheckbound, _)) + | Lop (Iintop Icheckbound _) + | Lop (Iintop_imm (Icheckbound _, _)) | Lop (Ispecific (Ishiftcheckbound _)) -> Some Bcc (* The various "far" variants in [specific_operation] don't need to return [Some] here, since their code sequences never contain any @@ -430,29 +434,30 @@ module BR = Branch_relaxation.Make (struct num_instructions_for_intconst n | Lop (Iconst_float _) -> 2 | Lop (Iconst_symbol _) -> 2 - | Lop (Icall_ind) -> 1 + | Lop (Icall_ind _) -> 1 | Lop (Icall_imm _) -> 1 - | Lop (Itailcall_ind) -> epilogue_size () - | Lop (Itailcall_imm s) -> - if s = !function_name then 1 else epilogue_size () - | Lop (Iextcall (_, false)) -> 1 - | Lop (Iextcall (_, true)) -> 3 + | Lop (Itailcall_ind _) -> epilogue_size () + | Lop (Itailcall_imm { func; _ }) -> + if func = !function_name then 1 else epilogue_size () + | Lop (Iextcall { alloc = false; }) -> 1 + | Lop (Iextcall { alloc = true; }) -> 3 | Lop (Istackoffset _) -> 2 | Lop (Iload (size, addr)) | Lop (Istore (size, addr, _)) -> let based = match addr with Iindexed _ -> 0 | Ibased _ -> 1 in based + begin match size with Single -> 2 | _ -> 1 end | Lop (Ialloc _) when !fastcode_flag -> 4 | Lop (Ispecific (Ifar_alloc _)) when !fastcode_flag -> 5 - | Lop (Ialloc num_words) | Lop (Ispecific (Ifar_alloc num_words)) -> + | Lop (Ialloc { words = num_words; _ }) + | Lop (Ispecific (Ifar_alloc { words = num_words; _ })) -> begin match num_words with | 16 | 24 | 32 -> 1 | _ -> 1 + num_instructions_for_intconst (Nativeint.of_int num_words) end | Lop (Iintop (Icomp _)) -> 2 | Lop (Iintop_imm (Icomp _, _)) -> 2 - | Lop (Iintop Icheckbound) -> 2 - | Lop (Ispecific Ifar_intop_checkbound) -> 3 - | Lop (Iintop_imm (Icheckbound, _)) -> 2 + | Lop (Iintop (Icheckbound _)) -> 2 + | Lop (Ispecific (Ifar_intop_checkbound _)) -> 3 + | Lop (Iintop_imm (Icheckbound _, _)) -> 2 | Lop (Ispecific (Ifar_intop_imm_checkbound _)) -> 3 | Lop (Ispecific (Ishiftcheckbound _)) -> 2 | Lop (Ispecific (Ifar_shiftcheckbound _)) -> 3 @@ -496,24 +501,27 @@ module BR = Branch_relaxation.Make (struct | true, Lambda.Raise_notrace -> 4 end - let relax_allocation ~num_words = - Lop (Ispecific (Ifar_alloc num_words)) + let relax_allocation ~num_words ~label_after_call_gc = + Lop (Ispecific (Ifar_alloc { words = num_words; label_after_call_gc; })) - let relax_intop_checkbound () = - Lop (Ispecific Ifar_intop_checkbound) + let relax_intop_checkbound ~label_after_error = + Lop (Ispecific (Ifar_intop_checkbound { label_after_error; })) - let relax_intop_imm_checkbound ~bound = - Lop (Ispecific (Ifar_intop_imm_checkbound bound)) + let relax_intop_imm_checkbound ~bound ~label_after_error = + Lop (Ispecific (Ifar_intop_imm_checkbound { bound; label_after_error; })) let relax_specific_op = function - | Ishiftcheckbound shift -> Lop (Ispecific (Ifar_shiftcheckbound shift)) + | Ishiftcheckbound { shift; label_after_error; } -> + Lop (Ispecific (Ifar_shiftcheckbound { shift; label_after_error; })) | _ -> assert false end) (* Output the assembly code for allocation. *) -let assembly_code_for_allocation i ~n ~far = - let lbl_frame = record_frame_label i.live i.dbg in +let assembly_code_for_allocation ?label_after_call_gc i ~n ~far = + let lbl_frame = + record_frame_label ?label:label_after_call_gc i.live i.dbg + in if !fastcode_flag then begin let lbl_redo = new_label() in let lbl_call_gc = new_label() in @@ -579,25 +587,25 @@ let emit_instr i = end | Lop(Iconst_symbol s) -> emit_load_symbol_addr i.res.(0) s - | Lop(Icall_ind) -> + | Lop(Icall_ind { label_after; }) -> ` blr {emit_reg i.arg.(0)}\n`; - `{record_frame i.live i.dbg}\n` - | Lop(Icall_imm s) -> - ` bl {emit_symbol s}\n`; - `{record_frame i.live i.dbg}\n` - | Lop(Itailcall_ind) -> + `{record_frame i.live i.dbg ~label:label_after}\n` + | Lop(Icall_imm { func; label_after; }) -> + ` bl {emit_symbol func}\n`; + `{record_frame i.live i.dbg ~label:label_after}\n` + | Lop(Itailcall_ind { label_after = _; }) -> output_epilogue (fun () -> ` br {emit_reg i.arg.(0)}\n`) - | Lop(Itailcall_imm s) -> - if s = !function_name then + | Lop(Itailcall_imm { func; label_after = _; }) -> + if func = !function_name then ` b {emit_label !tailrec_entry_point}\n` else - output_epilogue (fun () -> ` b {emit_symbol s}\n`) - | Lop(Iextcall(s, false)) -> - ` bl {emit_symbol s}\n` - | Lop(Iextcall(s, true)) -> - emit_load_symbol_addr reg_x15 s; + output_epilogue (fun () -> ` b {emit_symbol func}\n`) + | Lop(Iextcall { func; alloc = false; label_after = _; }) -> + ` bl {emit_symbol func}\n` + | Lop(Iextcall { func; alloc = true; label_after; }) -> + emit_load_symbol_addr reg_x15 func; ` bl {emit_symbol "caml_c_call"}\n`; - `{record_frame i.live i.dbg}\n` + `{record_frame i.live i.dbg ~label:label_after}\n` | Lop(Istackoffset n) -> assert (n mod 16 = 0); emit_stack_adjustment (-n); @@ -650,44 +658,45 @@ let emit_instr i = | Word_int | Word_val | Double | Double_u -> ` str {emit_reg src}, {emit_addressing addr base}\n` end - | Lop(Ialloc n) -> - assembly_code_for_allocation i ~n ~far:false - | Lop(Ispecific (Ifar_alloc n)) -> - assembly_code_for_allocation i ~n ~far:true + | Lop(Ialloc { words = n; label_after_call_gc; }) -> + assembly_code_for_allocation i ~n ~far:false ?label_after_call_gc + | Lop(Ispecific (Ifar_alloc { words = n; label_after_call_gc; })) -> + assembly_code_for_allocation i ~n ~far:true ?label_after_call_gc | Lop(Iintop(Icomp cmp)) -> ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; ` cset {emit_reg i.res.(0)}, {emit_string (name_for_comparison cmp)}\n` | Lop(Iintop_imm(Icomp cmp, n)) -> ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`; ` cset {emit_reg i.res.(0)}, {emit_string (name_for_comparison cmp)}\n` - | Lop(Iintop Icheckbound) -> - let lbl = bound_error_label i.dbg in + | Lop(Iintop (Icheckbound { label_after_error; })) -> + let lbl = bound_error_label i.dbg ?label:label_after_error in ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; ` b.ls {emit_label lbl}\n` - | Lop(Ispecific Ifar_intop_checkbound) -> - let lbl = bound_error_label i.dbg in + | Lop(Ispecific Ifar_intop_checkbound { label_after_error; }) -> + let lbl = bound_error_label i.dbg ?label:label_after_error in let lbl2 = new_label () in ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; ` b.hi {emit_label lbl2}\n`; ` b {emit_label lbl}\n`; `{emit_label lbl2}:\n`; - | 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 i.dbg ?label:label_after_error in ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`; ` b.ls {emit_label lbl}\n` - | Lop(Ispecific(Ifar_intop_imm_checkbound bound)) -> - let lbl = bound_error_label i.dbg in + | Lop(Ispecific( + Ifar_intop_imm_checkbound { bound; label_after_error; })) -> + let lbl = bound_error_label i.dbg ?label:label_after_error in let lbl2 = new_label () in ` cmp {emit_reg i.arg.(0)}, #{emit_int bound}\n`; ` b.hi {emit_label lbl2}\n`; ` b {emit_label lbl}\n`; `{emit_label lbl2}:\n`; - | Lop(Ispecific(Ishiftcheckbound shift)) -> - let lbl = bound_error_label i.dbg in + | Lop(Ispecific(Ishiftcheckbound { shift; label_after_error; })) -> + let lbl = bound_error_label i.dbg ?label:label_after_error in ` cmp {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, lsr #{emit_int shift}\n`; ` b.cs {emit_label lbl}\n` - | Lop(Ispecific(Ifar_shiftcheckbound shift)) -> - let lbl = bound_error_label i.dbg in + | Lop(Ispecific(Ifar_shiftcheckbound { shift; label_after_error; })) -> + let lbl = bound_error_label i.dbg ?label:label_after_error in let lbl2 = new_label () in ` cmp {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, lsr #{emit_int shift}\n`; ` b.lo {emit_label lbl2}\n`; diff --git a/asmcomp/arm64/proc.ml b/asmcomp/arm64/proc.ml index f4cdeffa4aff..4de1874dd6b4 100644 --- a/asmcomp/arm64/proc.ml +++ b/asmcomp/arm64/proc.ml @@ -184,9 +184,9 @@ let destroyed_at_c_call = 124;125;126;127;128;129;130;131]) let destroyed_at_oper = function - | Iop(Icall_ind | Icall_imm _) | Iop(Iextcall(_, true)) -> + | Iop(Icall_ind _ | Icall_imm _) | Iop(Iextcall { alloc = true; }) -> all_phys_regs - | Iop(Iextcall(_, false)) -> + | Iop(Iextcall { alloc = false; }) -> destroyed_at_c_call | Iop(Ialloc _) -> [| reg_x15 |] @@ -199,12 +199,12 @@ let destroyed_at_raise = all_phys_regs (* Maximal register pressure *) let safe_register_pressure = function - | Iextcall(_, _) -> 8 + | Iextcall _ -> 8 | Ialloc _ -> 25 | _ -> 26 let max_register_pressure = function - | Iextcall(_, _) -> [| 10; 8 |] + | Iextcall _ -> [| 10; 8 |] | Ialloc _ -> [| 25; 32 |] | Iintoffloat | Ifloatofint | Iload(Single, _) | Istore(Single, _, _) -> [| 26; 31 |] @@ -214,9 +214,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, _) + | Iintop(Icheckbound _) | Iintop_imm(Icheckbound _, _) | Ispecific(Ishiftcheckbound _) -> false | _ -> true diff --git a/asmcomp/arm64/selection.ml b/asmcomp/arm64/selection.ml index dba3ae2d5d23..719c5ec223c5 100644 --- a/asmcomp/arm64/selection.ml +++ b/asmcomp/arm64/selection.ml @@ -96,7 +96,7 @@ method is_immediate n = method! is_simple_expr = function (* inlined floating-point ops are simple if their arguments are *) - | Cop(Cextcall(fn, _, _, _), args) when List.mem fn inline_ops -> + | Cop(Cextcall (fn, _, _, _, _), args) when List.mem fn inline_ops -> List.for_all self#is_simple_expr args | e -> super#is_simple_expr e @@ -179,7 +179,8 @@ method! select_operation op args = | Ccheckbound _ -> begin match args with | [Cop(Clsr, [arg1; Cconst_int n]); arg2] when n > 0 && n < 64 -> - (Ispecific(Ishiftcheckbound n), [arg1; arg2]) + (Ispecific(Ishiftcheckbound { shift = n; label_after_error = None; }), + [arg1; arg2]) | _ -> super#select_operation op args end @@ -218,15 +219,15 @@ method! select_operation op args = super#select_operation op args end (* Recognize floating-point square root *) - | Cextcall("sqrt", _, _, _) -> + | Cextcall("sqrt", _, _, _, _) -> (Ispecific Isqrtf, args) (* Recognize bswap instructions *) - | 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"|"caml_nativeint_direct_bswap"), - _, _, _) -> + _, _, _, _) -> (Ispecific (Ibswap 64), args) (* Other operations are regular *) | _ -> diff --git a/asmcomp/branch_relaxation.ml b/asmcomp/branch_relaxation.ml index 4ef0986534d2..6486d19cbcba 100644 --- a/asmcomp/branch_relaxation.ml +++ b/asmcomp/branch_relaxation.ml @@ -51,8 +51,8 @@ module Make (T : Branch_relaxation_intf.S) = struct in match instr.desc with | Lop (Ialloc _) - | Lop (Iintop Icheckbound) - | Lop (Iintop_imm (Icheckbound, _)) + | Lop (Iintop (Icheckbound _)) + | Lop (Iintop_imm (Icheckbound _, _)) | Lop (Ispecific _) -> (* We assume that any branches eligible for relaxation generated by these instructions only branch forward. We further assume @@ -86,20 +86,21 @@ module Make (T : Branch_relaxation_intf.S) = struct fixup did_fix (pc + T.instr_size instr.desc) instr.next else match instr.desc with - | Lop (Ialloc num_words) -> - instr.desc <- T.relax_allocation ~num_words; + | Lop (Ialloc { words = num_words; label_after_call_gc; }) -> + instr.desc <- T.relax_allocation ~num_words ~label_after_call_gc; fixup true (pc + T.instr_size instr.desc) instr.next - | Lop (Iintop Icheckbound) -> - instr.desc <- T.relax_intop_checkbound (); + | Lop (Iintop (Icheckbound { label_after_error; })) -> + instr.desc <- T.relax_intop_checkbound ~label_after_error; fixup true (pc + T.instr_size instr.desc) instr.next - | Lop (Iintop_imm (Icheckbound, bound)) -> - instr.desc <- T.relax_intop_imm_checkbound ~bound; + | Lop (Iintop_imm (Icheckbound { label_after_error; }, bound)) -> + instr.desc + <- T.relax_intop_imm_checkbound ~bound ~label_after_error; fixup true (pc + T.instr_size instr.desc) instr.next | Lop (Ispecific specific) -> instr.desc <- T.relax_specific_op specific; fixup true (pc + T.instr_size instr.desc) instr.next | Lcondbranch (test, lbl) -> - let lbl2 = new_label() in + let lbl2 = Cmm.new_label() in let cont = instr_cons (Lbranch lbl) [||] [||] (instr_cons (Llabel lbl2) [||] [||] instr.next) diff --git a/asmcomp/branch_relaxation_intf.ml b/asmcomp/branch_relaxation_intf.ml index 0bfab4f7e874..3b1fbac5db08 100644 --- a/asmcomp/branch_relaxation_intf.ml +++ b/asmcomp/branch_relaxation_intf.ml @@ -60,8 +60,16 @@ module type S = sig (* Insertion of target-specific code to relax operations that cannot be relaxed generically. It is assumed that these rewrites do not change the size of out-of-line code (cf. branch_relaxation.mli). *) - val relax_allocation : num_words:int -> Linearize.instruction_desc - val relax_intop_checkbound : unit -> Linearize.instruction_desc - val relax_intop_imm_checkbound : bound:int -> Linearize.instruction_desc + val relax_allocation + : num_words:int + -> label_after_call_gc:Cmm.label option + -> Linearize.instruction_desc + val relax_intop_checkbound + : label_after_error:Cmm.label option + -> Linearize.instruction_desc + val relax_intop_imm_checkbound + : bound:int + -> label_after_error:Cmm.label option + -> Linearize.instruction_desc val relax_specific_op : Arch.specific_operation -> Linearize.instruction_desc end diff --git a/asmcomp/cmm.ml b/asmcomp/cmm.ml index 8ac20c1fc82b..8f2f7aa54e2c 100644 --- a/asmcomp/cmm.ml +++ b/asmcomp/cmm.ml @@ -107,6 +107,12 @@ let swap_comparison = function | Clt -> Cgt | Cle -> Cge | Cgt -> Clt | Cge -> Cle +type label = int + +let label_counter = ref 99 + +let new_label() = incr label_counter; !label_counter + type memory_chunk = Byte_unsigned | Byte_signed @@ -122,7 +128,9 @@ type memory_chunk = and operation = Capply of machtype * Debuginfo.t - | Cextcall of string * machtype * bool * Debuginfo.t + | Cextcall of string * machtype * bool * Debuginfo.t * label option + (** If specified, the given label will be placed immediately after the + call (at the same place as any frame descriptor would reference). *) | Cload of memory_chunk | Calloc of Debuginfo.t | Cstore of memory_chunk * Lambda.initialization_or_assignment diff --git a/asmcomp/cmm.mli b/asmcomp/cmm.mli index 96ae4ab2fe24..5e66387dc02f 100644 --- a/asmcomp/cmm.mli +++ b/asmcomp/cmm.mli @@ -83,6 +83,9 @@ type comparison = val negate_comparison: comparison -> comparison val swap_comparison: comparison -> comparison +type label = int +val new_label: unit -> label + type memory_chunk = Byte_unsigned | Byte_signed @@ -98,7 +101,7 @@ type memory_chunk = and operation = Capply of machtype * Debuginfo.t - | Cextcall of string * machtype * bool * Debuginfo.t + | Cextcall of string * machtype * bool * Debuginfo.t * label option | Cload of memory_chunk | Calloc of Debuginfo.t | Cstore of memory_chunk * Lambda.initialization_or_assignment diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index 743170236bb1..7c907ffaf1ff 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -489,8 +489,8 @@ let rec remove_unit = function Clet(id, c1, remove_unit c2) | Cop(Capply (_mty, dbg), args) -> Cop(Capply (typ_void, dbg), args) - | Cop(Cextcall(proc, _mty, alloc, dbg), args) -> - Cop(Cextcall(proc, typ_void, alloc, dbg), args) + | Cop(Cextcall(proc, _mty, alloc, dbg, label_after), args) -> + Cop(Cextcall(proc, typ_void, alloc, dbg, label_after), args) | Cexit (_,_) as c -> c | Ctuple [] as c -> c | c -> Csequence(c, Ctuple []) @@ -587,7 +587,7 @@ let float_array_ref dbg arr ofs = box_float dbg (unboxed_float_array_ref arr ofs) let addr_array_set arr ofs newval = - Cop(Cextcall("caml_modify", typ_void, false, Debuginfo.none), + Cop(Cextcall("caml_modify", typ_void, false, Debuginfo.none, None), [array_indexing log2_size_addr arr ofs; newval]) let int_array_set arr ofs newval = Cop(Cstore (Word_int, Assignment), @@ -618,7 +618,8 @@ let string_length exp = let lookup_tag obj tag = bind "tag" tag (fun tag -> - Cop(Cextcall("caml_get_public_method", typ_val, false, Debuginfo.none), + Cop(Cextcall("caml_get_public_method", typ_val, false, Debuginfo.none, + None), [obj; tag])) let lookup_label obj lab = @@ -646,7 +647,7 @@ let make_alloc_generic set_fn dbg tag wordsize args = | e1::el -> Csequence(set_fn (Cvar id) (Cconst_int idx) e1, fill_fields (idx + 2) el) in Clet(id, - Cop(Cextcall("caml_alloc", typ_val, true, Debuginfo.none), + Cop(Cextcall("caml_alloc", typ_val, true, Debuginfo.none, None), [Cconst_int wordsize; Cconst_int tag]), fill_fields 1 args) end @@ -1714,7 +1715,7 @@ let rec transl env e = and transl_make_array dbg env kind args = match kind with | Pgenarray -> - Cop(Cextcall("caml_make_array", typ_val, true, Debuginfo.none), + Cop(Cextcall("caml_make_array", typ_val, true, Debuginfo.none, None), [make_alloc dbg 0 (List.map (transl env) args)]) | Paddrarray | Pintarray -> make_alloc dbg 0 (List.map (transl env) args) @@ -1752,7 +1753,7 @@ and transl_ccall env prim args dbg = let args = transl_args prim.prim_native_repr_args args in wrap_result (Cop(Cextcall(Primitive.native_name prim, - typ_res, prim.prim_alloc, dbg), args)) + typ_res, prim.prim_alloc, dbg, None), args)) and transl_prim_1 env p arg dbg = match p with @@ -1855,11 +1856,11 @@ and transl_prim_1 env p arg dbg = | Pint32 -> "int32" | Pint64 -> "int64" in box_int dbg bi (Cop(Cextcall(Printf.sprintf "caml_%s_direct_bswap" prim, - typ_int, false, Debuginfo.none), + typ_int, false, Debuginfo.none, None), [transl_unbox_int env bi arg])) | Pbswap16 -> tag_int (Cop(Cextcall("caml_bswap16_direct", typ_int, false, - Debuginfo.none), + Debuginfo.none, None), [untag_int (transl env arg)])) | prim -> fatal_errorf "Cmmgen.transl_prim_1: %a" Printlambda.primitive prim @@ -1870,7 +1871,8 @@ and transl_prim_2 env p arg1 arg2 dbg = Psetfield(n, ptr, init) -> begin match init, ptr with | Assignment, Pointer -> - return_unit(Cop(Cextcall("caml_modify", typ_void, false,Debuginfo.none), + return_unit(Cop(Cextcall("caml_modify", typ_void, false,Debuginfo.none, + None), [field_address (transl env arg1) n; transl env arg2])) | Assignment, Immediate | Initialization, (Immediate | Pointer) -> @@ -2460,7 +2462,7 @@ and transl_letrec env bindings cont = let bsz = List.map (fun (id, exp) -> (id, exp, expr_size Ident.empty exp)) bindings in let op_alloc prim sz = - Cop(Cextcall(prim, typ_val, true, Debuginfo.none), [int_const sz]) in + Cop(Cextcall(prim, typ_val, true, Debuginfo.none, None), [int_const sz]) in let rec init_blocks = function | [] -> fill_nonrec bsz | (id, _exp, RHS_block sz) :: rem -> @@ -2479,7 +2481,8 @@ and transl_letrec env bindings cont = | [] -> cont | (id, exp, (RHS_block _ | RHS_floatblock _)) :: rem -> let op = - Cop(Cextcall("caml_update_dummy", typ_void, false, Debuginfo.none), + Cop(Cextcall("caml_update_dummy", typ_void, false, Debuginfo.none, + None), [Cvar id; transl env exp]) in Csequence(op, fill_blocks rem) | (_id, _exp, RHS_nonrec) :: rem -> diff --git a/asmcomp/comballoc.ml b/asmcomp/comballoc.ml index d37d87ce30a7..1692962379c7 100644 --- a/asmcomp/comballoc.ml +++ b/asmcomp/comballoc.ml @@ -32,12 +32,14 @@ let rec combine i allocstate = match i.desc with Iend | Ireturn | Iexit _ | Iraise _ -> (i, allocated_size allocstate) - | Iop(Ialloc sz) -> + | Iop(Ialloc { words = sz; _ }) -> begin match allocstate with No_alloc -> let (newnext, newsz) = combine i.next (Pending_alloc(i.res.(0), sz)) in - (instr_cons (Iop(Ialloc newsz)) i.arg i.res newnext, 0) + (instr_cons_debug (Iop(Ialloc {words = newsz; + label_after_call_gc = None; })) + i.arg i.res i.dbg newnext, 0) | Pending_alloc(reg, ofs) -> if ofs + sz < Config.max_young_wosize * Arch.size_addr then begin let (newnext, newsz) = @@ -47,11 +49,13 @@ let rec combine i allocstate = end else begin let (newnext, newsz) = combine i.next (Pending_alloc(i.res.(0), sz)) in - (instr_cons (Iop(Ialloc newsz)) i.arg i.res newnext, ofs) + (instr_cons_debug (Iop(Ialloc { words = newsz; + label_after_call_gc = None; })) + i.arg i.res i.dbg newnext, ofs) end end - | Iop(Icall_ind | Icall_imm _ | Iextcall _ | - Itailcall_ind | Itailcall_imm _) -> + | Iop(Icall_ind _ | Icall_imm _ | Iextcall _ | + Itailcall_ind _ | Itailcall_imm _) -> let newnext = combine_restart i.next in (instr_cons_debug i.desc i.arg i.res i.dbg newnext, allocated_size allocstate) diff --git a/asmcomp/deadcode.ml b/asmcomp/deadcode.ml index b86ee9669739..abff69e01ad8 100644 --- a/asmcomp/deadcode.ml +++ b/asmcomp/deadcode.ml @@ -23,7 +23,7 @@ open Mach let rec deadcode i = match i.desc with - | Iend | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) | Iraise _ -> + | Iend | Ireturn | Iop(Itailcall_ind _) | Iop(Itailcall_imm _) | Iraise _ -> (i, Reg.add_set_array i.live i.arg) | Iop op -> let (s, before) = deadcode i.next in diff --git a/asmcomp/emitaux.ml b/asmcomp/emitaux.ml index b333c6cc4534..3879f2415107 100644 --- a/asmcomp/emitaux.ml +++ b/asmcomp/emitaux.ml @@ -132,7 +132,7 @@ let emit_frames a = try Hashtbl.find filenames name with Not_found -> - let lbl = Linearize.new_label () in + let lbl = Cmm.new_label () in Hashtbl.add filenames name lbl; lbl in @@ -140,7 +140,7 @@ let emit_frames a = let rec label_debuginfos key = try fst (Hashtbl.find debuginfos key) with Not_found -> - let lbl = Linearize.new_label () in + let lbl = Cmm.new_label () in let next = match key with | _d, (d' :: ds') -> Some (label_debuginfos (d',ds')) | _d, [] -> None diff --git a/asmcomp/i386/emit.mlp b/asmcomp/i386/emit.mlp index 170029d2110c..7e8ad94e41fd 100644 --- a/asmcomp/i386/emit.mlp +++ b/asmcomp/i386/emit.mlp @@ -193,8 +193,12 @@ let addressing addr typ i 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 @@ -213,8 +217,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 *) @@ -243,10 +247,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 @@ -520,46 +524,46 @@ let emit_instr fallthrough i = | Lop(Iconst_symbol s) -> add_used_symbol s; I.mov (immsym s) (reg i.res.(0)) - | Lop(Icall_ind) -> + | Lop(Icall_ind { label_after; }) -> I.call (reg i.arg.(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 (reg i.arg.(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; - I.jmp (immsym s) + add_used_symbol func; + I.jmp (immsym 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 if system <> S_macosx then - I.mov (immsym s) eax + I.mov (immsym func) eax else begin external_symbols_indirect := - StringSet.add s !external_symbols_indirect; + StringSet.add func !external_symbols_indirect; I.mov (mem_sym DWORD (Printf.sprintf "L%s$non_lazy_ptr" - (emit_symbol s))) eax + (emit_symbol func))) eax end; emit_call "caml_c_call"; - record_frame i.live i.dbg + record_frame i.live i.dbg ~label:label_after end else begin if system <> S_macosx then - emit_call s + emit_call func else begin external_symbols_direct := - StringSet.add s !external_symbols_direct; - I.call (sym (Printf.sprintf "L%s$stub" (emit_symbol s))) + StringSet.add func !external_symbols_direct; + I.call (sym (Printf.sprintf "L%s$stub" (emit_symbol func))) end end | Lop(Istackoffset n) -> @@ -609,7 +613,7 @@ let emit_instr fallthrough i = I.fstp (addressing addr REAL8 i 1) end 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; @@ -634,7 +638,10 @@ let emit_instr fallthrough i = I.mov (int n) eax; 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 (mem32 NONE 4 RAX) (reg i.res.(0)) end | Lop(Iintop(Icomp cmp)) -> @@ -645,12 +652,12 @@ let emit_instr fallthrough i = I.cmp (int n) (reg i.arg.(0)); I.set (cond cmp) al; I.movzx al (reg i.res.(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 (reg i.arg.(1)) (reg i.arg.(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) (reg i.arg.(0)); I.jbe (label lbl) | Lop(Iintop(Idiv | Imod)) -> diff --git a/asmcomp/i386/proc.ml b/asmcomp/i386/proc.ml index 8036de7c5760..879b2b0c9005 100644 --- a/asmcomp/i386/proc.ml +++ b/asmcomp/i386/proc.ml @@ -182,8 +182,9 @@ let destroyed_at_c_call = (* ebx, esi, edi, ebp preserved *) [|eax; ecx; edx|] 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)) -> [| eax; edx |] | Iop(Ialloc _ | Iintop Imulh) -> [| eax |] | Iop(Iintop(Icomp _) | Iintop_imm(Icomp _, _)) -> [| eax |] @@ -198,7 +199,7 @@ let destroyed_at_raise = all_phys_regs let safe_register_pressure _op = 4 let max_register_pressure = function - Iextcall(_, _) -> [| 4; max_int |] + Iextcall _ -> [| 4; max_int |] | Iintop(Idiv | Imod) -> [| 5; max_int |] | Ialloc _ | Iintop(Icomp _) | Iintop_imm(Icomp _, _) | Iintoffloat -> [| 6; max_int |] @@ -208,9 +209,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 diff --git a/asmcomp/i386/reload.ml b/asmcomp/i386/reload.ml index 63034d7a47a4..511b7f1bd6a4 100644 --- a/asmcomp/i386/reload.ml +++ b/asmcomp/i386/reload.ml @@ -40,7 +40,7 @@ method! makereg r = 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 *) if stackp arg.(0) && stackp arg.(1) then ([|arg.(0); self#makereg arg.(1)|], res) diff --git a/asmcomp/i386/selection.ml b/asmcomp/i386/selection.ml index 602d13bd2b95..16199ca64168 100644 --- a/asmcomp/i386/selection.ml +++ b/asmcomp/i386/selection.ml @@ -88,7 +88,7 @@ let rec float_needs = function let n1 = float_needs arg1 in let n2 = float_needs arg2 in if n1 = n2 then 1 + n1 else if n1 > n2 then n1 else n2 - | Cop(Cextcall(fn, _ty_res, _alloc, _dbg), args) + | Cop(Cextcall(fn, _ty_res, _alloc, _dbg, _label), args) when !fast_math && List.mem fn inline_float_ops -> begin match args with [arg] -> float_needs arg @@ -161,7 +161,7 @@ method is_immediate (_n : int) = true method! is_simple_expr e = match e with - | Cop(Cextcall(fn, _, _, _), args) + | Cop(Cextcall(fn, _, _, _, _), args) when !fast_math && List.mem fn inline_float_ops -> (* inlined float ops are simple if their arguments are *) List.for_all self#is_simple_expr args @@ -228,7 +228,7 @@ method! select_operation op args = super#select_operation op args end (* Recognize inlined floating point operations *) - | Cextcall(fn, _ty_res, false, _dbg) + | Cextcall(fn, _ty_res, false, _dbg, _label) when !fast_math && List.mem fn inline_float_ops -> (Ispecific(Ifloatspecial fn), args) (* i386 does not support immediate operands for multiply high signed *) diff --git a/asmcomp/interf.ml b/asmcomp/interf.ml index 637229efb854..28f00c11b21c 100644 --- a/asmcomp/interf.ml +++ b/asmcomp/interf.ml @@ -90,7 +90,7 @@ let build_graph fundecl = | Iop(Imove | Ispill | Ireload) -> add_interf_move i.arg.(0) i.res.(0) i.live; interf i.next - | Iop(Itailcall_ind) -> () + | Iop(Itailcall_ind _) -> () | Iop(Itailcall_imm _) -> () | Iop _ -> add_interf_set i.res i.live; @@ -162,7 +162,7 @@ let build_graph fundecl = | Iop(Ireload) -> add_pref (weight / 4) i.res.(0) i.arg.(0); prefer weight i.next - | Iop(Itailcall_ind) -> () + | Iop(Itailcall_ind _) -> () | Iop(Itailcall_imm _) -> () | Iop _ -> prefer weight i.next diff --git a/asmcomp/linearize.ml b/asmcomp/linearize.ml index 7cf99fe15e45..f9ab5bc74509 100644 --- a/asmcomp/linearize.ml +++ b/asmcomp/linearize.ml @@ -18,11 +18,7 @@ open Reg open Mach -type label = int - -let label_counter = ref 99 - -let new_label() = incr label_counter; !label_counter +type label = Cmm.label type instruction = { mutable desc: instruction_desc; @@ -49,7 +45,7 @@ and instruction_desc = let has_fallthrough = function | Lreturn | Lbranch _ | Lswitch _ | Lraise _ - | Lop Itailcall_ind | Lop (Itailcall_imm _) -> false + | Lop Itailcall_ind _ | Lop (Itailcall_imm _) -> false | _ -> true type fundecl = @@ -113,7 +109,7 @@ let get_label n = match n.desc with Lbranch lbl -> (lbl, n) | Llabel lbl -> (lbl, n) | Lend -> (-1, n) - | _ -> let lbl = new_label() in (lbl, cons_instr (Llabel lbl) n) + | _ -> let lbl = Cmm.new_label() in (lbl, cons_instr (Llabel lbl) n) (* Check the fallthrough label *) let check_label n = match n.desc with @@ -180,7 +176,7 @@ let local_exit k = let rec linear i n = match i.Mach.desc with Iend -> n - | Iop(Itailcall_ind | Itailcall_imm _ as op) -> + | Iop(Itailcall_ind _ | Itailcall_imm _ as op) -> copy_instr (Lop op) i (discard_dead_code n) | Iop(Imove | Ireload | Ispill) when i.Mach.arg.(0).loc = i.Mach.res.(0).loc -> @@ -248,7 +244,7 @@ let rec linear i n = end else copy_instr (Lswitch(Array.map (fun n -> lbl_cases.(n)) index)) i !n2 | Iloop body -> - let lbl_head = new_label() in + let lbl_head = Cmm.new_label() in let n1 = linear i.Mach.next n in let n2 = linear body (cons_instr (Lbranch lbl_head) n1) in cons_instr (Llabel lbl_head) n2 @@ -289,10 +285,6 @@ let rec linear i n = | Iraise k -> copy_instr (Lraise k) i (discard_dead_code n) -let reset () = - label_counter := 99; - exit_label := [] - let fundecl f = { fun_name = f.Mach.fun_name; fun_body = linear f.Mach.fun_body end_instr; diff --git a/asmcomp/linearize.mli b/asmcomp/linearize.mli index 6d6d01cb520c..82fb9581be74 100644 --- a/asmcomp/linearize.mli +++ b/asmcomp/linearize.mli @@ -15,8 +15,7 @@ (* Transformation of Mach code into a list of pseudo-instructions. *) -type label = int -val new_label: unit -> label +type label = Cmm.label type instruction = { mutable desc: instruction_desc; @@ -53,5 +52,4 @@ type fundecl = fun_fast: bool; fun_dbg : Debuginfo.t } -val reset : unit -> unit val fundecl: Mach.fundecl -> fundecl diff --git a/asmcomp/liveness.ml b/asmcomp/liveness.ml index 5986cce1a115..985a739b442c 100644 --- a/asmcomp/liveness.ml +++ b/asmcomp/liveness.ml @@ -39,7 +39,7 @@ let rec live i finally = Iend -> i.live <- finally; finally - | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) -> + | Ireturn | Iop(Itailcall_ind _) | Iop(Itailcall_imm _) -> i.live <- Reg.Set.empty; (* no regs are live across *) Reg.set_of_array i.arg | Iop op -> @@ -56,8 +56,8 @@ let rec live i finally = let across_after = Reg.diff_set_array after i.res in let across = match op with - | Icall_ind | Icall_imm _ | Iextcall _ - | Iintop Icheckbound | Iintop_imm(Icheckbound, _) -> + | Icall_ind _ | Icall_imm _ | Iextcall _ + | Iintop (Icheckbound _) | Iintop_imm(Icheckbound _, _) -> (* The function call may raise an exception, branching to the nearest enclosing try ... with. Similarly for bounds checks. Hence, everything that must be live at the beginning of diff --git a/asmcomp/mach.ml b/asmcomp/mach.ml index 736779c29fb2..fb105c1c24ff 100644 --- a/asmcomp/mach.ml +++ b/asmcomp/mach.ml @@ -15,6 +15,8 @@ (* Representation of machine code by sequences of pseudoinstructions *) +type label = Cmm.label + type integer_comparison = Isigned of Cmm.comparison | Iunsigned of Cmm.comparison @@ -23,7 +25,7 @@ type integer_operation = Iadd | Isub | Imul | Imulh | Idiv | Imod | Iand | Ior | Ixor | Ilsl | Ilsr | Iasr | Icomp of integer_comparison - | Icheckbound + | Icheckbound of { label_after_error : label option; } type test = Itruetest @@ -42,15 +44,15 @@ type operation = | Iconst_float of int64 | Iconst_symbol of string | Iconst_blockheader of nativeint - | Icall_ind - | Icall_imm of string - | Itailcall_ind - | Itailcall_imm of string - | Iextcall of string * bool + | Icall_ind of { label_after : label; } + | Icall_imm of { func : string; label_after : label; } + | Itailcall_ind of { label_after : label; } + | Itailcall_imm of { func : string; label_after : label; } + | Iextcall of { func : string; alloc : bool; label_after : label; } | Istackoffset of int | Iload of Cmm.memory_chunk * Arch.addressing_mode | Istore of Cmm.memory_chunk * Arch.addressing_mode * bool - | Ialloc of int + | Ialloc of { words : int; label_after_call_gc : label option; } | Iintop of integer_operation | Iintop_imm of integer_operation * int | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf @@ -114,7 +116,7 @@ let rec instr_iter f i = f i; match i.desc with Iend -> () - | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) -> () + | Ireturn | Iop(Itailcall_ind _) | Iop(Itailcall_imm _) -> () | Iifthenelse(_tst, ifso, ifnot) -> instr_iter f ifso; instr_iter f ifnot; instr_iter f i.next | Iswitch(_index, cases) -> diff --git a/asmcomp/mach.mli b/asmcomp/mach.mli index d3d912d23300..1806d27d8d62 100644 --- a/asmcomp/mach.mli +++ b/asmcomp/mach.mli @@ -15,6 +15,12 @@ (* Representation of machine code by sequences of pseudoinstructions *) +(** N.B. Backends vary in their treatment of call gc and checkbound + points. If the positioning of any labels associated with these is + important for some new feature in the compiler, the relevant backends' + behaviour should be checked. *) +type label = Cmm.label + type integer_comparison = Isigned of Cmm.comparison | Iunsigned of Cmm.comparison @@ -23,7 +29,7 @@ type integer_operation = Iadd | Isub | Imul | Imulh | Idiv | Imod | Iand | Ior | Ixor | Ilsl | Ilsr | Iasr | Icomp of integer_comparison - | Icheckbound + | Icheckbound of { label_after_error : label option; } type test = Itruetest @@ -42,16 +48,16 @@ type operation = | Iconst_float of int64 | Iconst_symbol of string | Iconst_blockheader of nativeint - | Icall_ind - | Icall_imm of string - | Itailcall_ind - | Itailcall_imm of string - | Iextcall of string * bool (* false = noalloc, true = alloc *) + | Icall_ind of { label_after : label; } + | Icall_imm of { func : string; label_after : label; } + | Itailcall_ind of { label_after : label; } + | Itailcall_imm of { func : string; label_after : label; } + | Iextcall of { func : string; alloc : bool; label_after : label; } | Istackoffset of int | Iload of Cmm.memory_chunk * Arch.addressing_mode | Istore of Cmm.memory_chunk * Arch.addressing_mode * bool (* false = initialization, true = assignment *) - | Ialloc of int + | Ialloc of { words : int; label_after_call_gc : label option; } | Iintop of integer_operation | Iintop_imm of integer_operation * int | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf diff --git a/asmcomp/power/arch.ml b/asmcomp/power/arch.ml index 30bbd4f54d31..2bfb9525eaf0 100644 --- a/asmcomp/power/arch.ml +++ b/asmcomp/power/arch.ml @@ -46,7 +46,8 @@ let command_line_options = [ type specific_operation = Imultaddf (* multiply and add *) | Imultsubf (* multiply and subtract *) - | Ialloc_far of int (* allocation in large functions *) + | Ialloc_far of (* allocation in large functions *) + { words : int; label_after_call_gc : Cmm.label option; } (* Addressing modes *) @@ -110,5 +111,5 @@ let print_specific_operation printreg op ppf arg = | Imultsubf -> fprintf ppf "%a *f %a -f %a" printreg arg.(0) printreg arg.(1) printreg arg.(2) - | Ialloc_far n -> - fprintf ppf "alloc_far %d" n + | Ialloc_far { words; _ } -> + fprintf ppf "alloc_far %d" words diff --git a/asmcomp/power/emit.mlp b/asmcomp/power/emit.mlp index ab8f84df028a..325c6b7d18a2 100644 --- a/asmcomp/power/emit.mlp +++ b/asmcomp/power/emit.mlp @@ -303,8 +303,12 @@ let adjust_stack_offset delta = (* Record live pointers at call points *) -let record_frame live dbg = - let lbl = new_label() in +let record_frame ?label live dbg = + let lbl = + match label with + | None -> new_label() + | Some label -> label + in let live_offset = ref [] in Reg.Set.iter (function @@ -450,15 +454,16 @@ module BR = Branch_relaxation.Make (struct else tocload_size() | Lop(Iconst_float _) -> if abi = ELF32 then 2 else tocload_size() | Lop(Iconst_symbol _) -> if abi = ELF32 then 2 else tocload_size() - | Lop(Icall_ind) -> size 2 5 4 + | Lop(Icall_ind _) -> size 2 5 4 | Lop(Icall_imm _) -> size 1 3 3 - | Lop(Itailcall_ind) -> size 5 7 6 - | Lop(Itailcall_imm s) -> - if s = !function_name + | Lop(Itailcall_ind _) -> size 5 7 6 + | Lop(Itailcall_imm { func; _ }) -> + if func = !function_name then 1 else size 4 (7 + tocload_size()) (6 + tocload_size()) - | Lop(Iextcall(_s, true)) -> size 3 (2 + tocload_size()) (2 + tocload_size()) - | Lop(Iextcall(_s, false)) -> size 1 2 2 + | Lop(Iextcall { alloc = true; _ }) -> + size 3 (2 + tocload_size()) (2 + tocload_size()) + | Lop(Iextcall { alloc = false; _}) -> size 1 2 2 | Lop(Istackoffset _) -> 1 | Lop(Iload(chunk, addr)) -> if chunk = Byte_signed @@ -491,13 +496,14 @@ module BR = Branch_relaxation.Make (struct | Lpoptrap -> 2 | Lraise _ -> 6 - let relax_allocation ~num_words = Lop (Ispecific (Ialloc_far num_words)) + let relax_allocation ~num_words:words ~label_after_call_gc = + Lop (Ispecific (Ialloc_far { words; label_after_call_gc; })) (* [classify_addr], above, never identifies these instructions as needing relaxing. As such, these functions should never be called. *) let relax_specific_op _ = assert false - let relax_intop_checkbound () = assert false - let relax_intop_imm_checkbound ~bound:_ = assert false + let relax_intop_checkbound ~label_after_error:_ = assert false + let relax_intop_imm_checkbound ~bound:_ ~label_after_error:_ = assert false end) (* Output the assembly code for an instruction *) @@ -574,31 +580,31 @@ let emit_instr i = | ELF64v1 | ELF64v2 -> emit_tocload emit_reg i.res.(0) (TocSym s) end - | Lop(Icall_ind) -> + | Lop(Icall_ind { label_after; }) -> begin match abi with | ELF32 -> ` mtctr {emit_reg i.arg.(0)}\n`; ` bctrl\n`; - record_frame i.live i.dbg + record_frame i.live i.dbg ~label:label_after | ELF64v1 -> ` ld 0, 0({emit_reg i.arg.(0)})\n`; (* code pointer *) ` mtctr 0\n`; ` ld 2, 8({emit_reg i.arg.(0)})\n`; (* TOC for callee *) ` bctrl\n`; - record_frame i.live i.dbg; + record_frame i.live i.dbg ~label:label_after; emit_reload_toc() | ELF64v2 -> ` mtctr {emit_reg i.arg.(0)}\n`; ` mr 12, {emit_reg i.arg.(0)}\n`; (* addr of fn in r12 *) ` bctrl\n`; - record_frame i.live i.dbg; + record_frame i.live i.dbg ~label:label_after; emit_reload_toc() end - | Lop(Icall_imm s) -> + | Lop(Icall_imm { func; label_after; }) -> begin match abi with | ELF32 -> - emit_call s; - record_frame i.live i.dbg + emit_call func; + record_frame i.live i.dbg ~label:label_after | ELF64v1 | ELF64v2 -> (* For PPC64, we cannot just emit a "bl s; nop" sequence, because of the following scenario: @@ -617,12 +623,12 @@ let emit_instr i = by the linker, but this is harmless. Cost: 3 instructions if same TOC, 7 if different TOC. Let's try option 2. *) - emit_call s; - record_frame i.live i.dbg; + emit_call func; + record_frame i.live i.dbg ~label:label_after; ` nop\n`; emit_reload_toc() end - | Lop(Itailcall_ind) -> + | Lop(Itailcall_ind { label_after = _; }) -> begin match abi with | ELF32 -> ` mtctr {emit_reg i.arg.(0)}\n` @@ -640,20 +646,20 @@ let emit_instr i = end; emit_free_frame(); ` bctr\n` - | Lop(Itailcall_imm s) -> - if s = !function_name then + | Lop(Itailcall_imm { func; label_after = _; }) -> + if func = !function_name then ` b {emit_label !tailrec_entry_point}\n` else begin begin match abi with | ELF32 -> () | ELF64v1 -> - emit_tocload emit_gpr 11 (TocSym s); + emit_tocload emit_gpr 11 (TocSym func); ` ld 0, 0(11)\n`; (* code pointer *) ` mtctr 0\n`; ` ld 2, 8(11)\n` (* TOC for callee *) | ELF64v2 -> - emit_tocload emit_gpr 12 (TocSym s); (* addr of fn must be in r12 *) + emit_tocload emit_gpr 12 (TocSym func); (* addr of fn must be in r12 *) ` mtctr 12\n` end; if !contains_calls then begin @@ -663,24 +669,24 @@ let emit_instr i = emit_free_frame(); begin match abi with | ELF32 -> - ` b {emit_symbol s}\n` + ` b {emit_symbol func}\n` | ELF64v1 | ELF64v2 -> ` bctr\n` end end - | Lop(Iextcall(s, alloc)) -> + | Lop(Iextcall { func; alloc; }) -> if not alloc then begin - emit_call s; + emit_call func; emit_call_nop() end else begin match abi with | ELF32 -> - ` addis 28, 0, {emit_upper emit_symbol s}\n`; - ` addi 28, 28, {emit_lower emit_symbol s}\n`; + ` addis 28, 0, {emit_upper emit_symbol func}\n`; + ` addi 28, 28, {emit_lower emit_symbol func}\n`; emit_call "caml_c_call"; record_frame i.live i.dbg | ELF64v1 | ELF64v2 -> - emit_tocload emit_gpr 28 (TocSym s); + emit_tocload emit_gpr 28 (TocSym func); emit_call "caml_c_call"; record_frame i.live i.dbg; ` nop\n` @@ -713,16 +719,24 @@ let emit_instr i = | Single -> "stfs" | Double | Double_u -> "stfd" in emit_load_store storeinstr addr i.arg 1 i.arg.(0) - | Lop(Ialloc n) -> - if !call_gc_label = 0 then call_gc_label := new_label(); + | Lop(Ialloc { words = n; label_after_call_gc; }) -> + if !call_gc_label = 0 then begin + match label_after_call_gc with + | None -> call_gc_label := new_label () + | Some label -> call_gc_label := label + end; ` addi 31, 31, {emit_int(-n)}\n`; ` {emit_string cmplg} 31, 30\n`; ` addi {emit_reg i.res.(0)}, 31, {emit_int size_addr}\n`; ` bltl {emit_label !call_gc_label}\n`; (* Exactly 4 instructions after the beginning of the alloc sequence *) record_frame i.live Debuginfo.none - | Lop(Ispecific(Ialloc_far n)) -> - if !call_gc_label = 0 then call_gc_label := new_label(); + | Lop(Ispecific(Ialloc_far { words = n; label_after_call_gc; })) -> + if !call_gc_label = 0 then begin + match label_after_call_gc with + | None -> call_gc_label := new_label () + | Some label -> call_gc_label := label + end; let lbl = new_label() in ` addi 31, 31, {emit_int(-n)}\n`; ` {emit_string cmplg} 31, 30\n`; @@ -746,9 +760,9 @@ let emit_instr i = ` {emit_string cmplg} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; emit_set_comp c i.res.(0) end - | Lop(Iintop Icheckbound) -> + | Lop(Iintop (Icheckbound { label_after_error; })) -> if !Clflags.debug then - record_frame Reg.Set.empty i.dbg; + record_frame Reg.Set.empty i.dbg ?label:label_after_error; ` {emit_string tglle} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` | Lop(Iintop op) -> let instr = name_for_intop op in @@ -764,9 +778,9 @@ let emit_instr i = ` {emit_string cmplg}i {emit_reg i.arg.(0)}, {emit_int n}\n`; emit_set_comp c i.res.(0) end - | Lop(Iintop_imm(Icheckbound, n)) -> + | Lop(Iintop_imm(Icheckbound { label_after_error; }, n)) -> if !Clflags.debug then - record_frame Reg.Set.empty i.dbg; + record_frame Reg.Set.empty i.dbg ?label:label_after_error; ` {emit_string tglle}i {emit_reg i.arg.(0)}, {emit_int n}\n` | Lop(Iintop_imm(op, n)) -> let instr = name_for_intop_imm op in diff --git a/asmcomp/power/proc.ml b/asmcomp/power/proc.ml index 25839b2fe1c4..a5fbd0ed501b 100644 --- a/asmcomp/power/proc.ml +++ b/asmcomp/power/proc.ml @@ -267,8 +267,9 @@ let destroyed_at_c_call = 100; 101; 102; 103; 104; 105; 106; 107; 108; 109; 110; 111; 112]) 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 | _ -> [||] let destroyed_at_raise = all_phys_regs @@ -276,20 +277,20 @@ let destroyed_at_raise = all_phys_regs (* Maximal register pressure *) let safe_register_pressure = function - Iextcall(_, _) -> 15 + Iextcall _ -> 15 | _ -> 23 let max_register_pressure = function - Iextcall(_, _) -> [| 15; 18 |] + Iextcall _ -> [| 15; 18 |] | _ -> [| 23; 30 |] (* Pure operations (without any side effect besides updating their result 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(Imultaddf | Imultsubf) -> true | Ispecific _ -> false | _ -> true diff --git a/asmcomp/printcmm.ml b/asmcomp/printcmm.ml index cc5906767b4c..ae94775852fd 100644 --- a/asmcomp/printcmm.ml +++ b/asmcomp/printcmm.ml @@ -55,7 +55,7 @@ let chunk = function let operation = function | Capply(_ty, d) -> "app" ^ Debuginfo.to_string d - | Cextcall(lbl, _ty, _alloc, d) -> + | Cextcall(lbl, _ty, _alloc, d, _) -> Printf.sprintf "extcall \"%s\"%s" lbl (Debuginfo.to_string d) | Cload c -> Printf.sprintf "load %s" (chunk c) | Calloc d -> "alloc" ^ Debuginfo.to_string d @@ -137,7 +137,7 @@ let rec expr ppf = function List.iter (fun e -> fprintf ppf "@ %a" expr e) el; begin match op with | Capply (mty, _) -> fprintf ppf "@ %a" machtype mty - | Cextcall(_, mty, _, _) -> fprintf ppf "@ %a" machtype mty + | Cextcall(_, mty, _, _, _) -> fprintf ppf "@ %a" machtype mty | _ -> () end; fprintf ppf ")@]" diff --git a/asmcomp/printlinear.ml b/asmcomp/printlinear.ml index fb3d397ba194..52cffa688284 100644 --- a/asmcomp/printlinear.ml +++ b/asmcomp/printlinear.ml @@ -28,7 +28,7 @@ let instr ppf i = | Lend -> () | Lop op -> begin match op with - | Ialloc _ | Icall_ind | Icall_imm _ | Iextcall(_, _) -> + | Ialloc _ | Icall_ind _ | Icall_imm _ | Iextcall _ -> fprintf ppf "@[<1>{%a}@]@," regsetaddr i.live | _ -> () end; diff --git a/asmcomp/printmach.ml b/asmcomp/printmach.ml index 82b95a8b49e9..a51a4c12f410 100644 --- a/asmcomp/printmach.ml +++ b/asmcomp/printmach.ml @@ -87,7 +87,7 @@ let intop = function | Ilsr -> " >>u " | Iasr -> " >>s " | Icomp cmp -> intcomp cmp - | Icheckbound -> " check > " + | Icheckbound _ -> " check > " let test tst ppf arg = match tst with @@ -114,12 +114,12 @@ let operation op arg ppf res = | Iconst_blockheader n -> fprintf ppf "%s" (Nativeint.to_string n) | Iconst_float f -> fprintf ppf "%F" (Int64.float_of_bits f) | Iconst_symbol s -> fprintf ppf "\"%s\"" s - | Icall_ind -> fprintf ppf "call %a" regs arg - | Icall_imm lbl -> fprintf ppf "call \"%s\" %a" lbl regs arg - | Itailcall_ind -> fprintf ppf "tailcall %a" regs arg - | Itailcall_imm lbl -> fprintf ppf "tailcall \"%s\" %a" lbl regs arg - | Iextcall(lbl, alloc) -> - fprintf ppf "extcall \"%s\" %a%s" lbl regs arg + | Icall_ind _ -> fprintf ppf "call %a" regs arg + | Icall_imm { func; _ } -> fprintf ppf "call \"%s\" %a" func regs arg + | Itailcall_ind _ -> fprintf ppf "tailcall %a" regs arg + | Itailcall_imm { func; } -> fprintf ppf "tailcall \"%s\" %a" func regs arg + | Iextcall { func; alloc; _ } -> + fprintf ppf "extcall \"%s\" %a%s" func regs arg (if alloc then "" else " (noalloc)") | Istackoffset n -> fprintf ppf "offset stack %i" n @@ -133,7 +133,7 @@ let operation op arg ppf res = (Array.sub arg 1 (Array.length arg - 1)) reg arg.(0) (if is_assign then "(assign)" else "(init)") - | Ialloc n -> fprintf ppf "alloc %i" n + | Ialloc { words = n; _ } -> fprintf ppf "alloc %i" n | Iintop(op) -> fprintf ppf "%a%s%a" reg arg.(0) (intop op) reg arg.(1) | Iintop_imm(op, n) -> fprintf ppf "%a%s%i" reg arg.(0) (intop op) n | Inegf -> fprintf ppf "-f %a" reg arg.(0) diff --git a/asmcomp/reloadgen.ml b/asmcomp/reloadgen.ml index 0f7e8f8a46b1..939b72918f94 100644 --- a/asmcomp/reloadgen.ml +++ b/asmcomp/reloadgen.ml @@ -83,13 +83,13 @@ method private reload i = However, something needs to be done for the function pointer in indirect calls. *) Iend | Ireturn | Iop(Itailcall_imm _) | Iraise _ -> i - | Iop(Itailcall_ind) -> + | Iop(Itailcall_ind _) -> let newarg = self#makereg1 i.arg in insert_moves i.arg newarg {i with arg = newarg} | Iop(Icall_imm _ | Iextcall _) -> {i with next = self#reload i.next} - | Iop(Icall_ind) -> + | Iop(Icall_ind _) -> let newarg = self#makereg1 i.arg in insert_moves i.arg newarg {i with arg = newarg; next = self#reload i.next} diff --git a/asmcomp/s390x/emit.mlp b/asmcomp/s390x/emit.mlp index 2cd4295b97d8..42a790d61697 100644 --- a/asmcomp/s390x/emit.mlp +++ b/asmcomp/s390x/emit.mlp @@ -154,8 +154,12 @@ let emit_set_comp cmp res = (* Record live pointers at call points *) -let record_frame live dbg = - let lbl = new_label() in +let record_frame ?label live dbg = + let lbl = + match label with + | None -> new_label() + | Some label -> label + in let live_offset = ref [] in Reg.Set.iter (function @@ -196,10 +200,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 Reg.Set.empty dbg in + let lbl_frame = record_frame ?label Reg.Set.empty dbg in bound_error_sites := { bd_lbl = lbl_bound_error; bd_frame = lbl_frame } :: !bound_error_sites; lbl_bound_error @@ -324,26 +328,26 @@ let emit_instr i = ` lgrl {emit_reg i.res.(0)}, {emit_symbol s}@GOTENT\n` else ` larl {emit_reg i.res.(0)}, {emit_symbol s}\n`; - | Lop(Icall_ind) -> + | Lop(Icall_ind { label_after; }) -> ` basr %r14, {emit_reg i.arg.(0)}\n`; - let lbl = record_frame i.live i.dbg in + let lbl = record_frame i.live i.dbg ~label:label_after in `{emit_label lbl}:\n` - | Lop(Icall_imm s) -> + | Lop(Icall_imm { func; label_after; }) -> if !pic_code then - ` brasl %r14, {emit_symbol s}@PLT\n` + ` brasl %r14, {emit_symbol func}@PLT\n` else - ` brasl %r14, {emit_symbol s}\n`; - let lbl = record_frame i.live i.dbg in + ` brasl %r14, {emit_symbol func}\n`; + let lbl = record_frame i.live i.dbg ~label:label_after in `{emit_label lbl}:\n`; - | Lop(Itailcall_ind) -> + | Lop(Itailcall_ind { label_after = _; }) -> let n = frame_size() in if !contains_calls then ` lg %r14, {emit_int(n - size_addr)}(%r15)\n`; emit_stack_adjust (-n); ` br {emit_reg i.arg.(0)}\n` - | Lop(Itailcall_imm s) -> - if s = !function_name then + | Lop(Itailcall_imm { func; label_after = _; }) -> + if func = !function_name then ` brcl 15, {emit_label !tailrec_entry_point}\n` else begin let n = frame_size() in @@ -351,27 +355,27 @@ let emit_instr i = ` lg %r14, {emit_int(n - size_addr)}(%r15)\n`; emit_stack_adjust (-n); if !pic_code then - ` brcl 15, {emit_symbol s}@PLT\n` + ` brcl 15, {emit_symbol func}@PLT\n` else - ` brcl 15, {emit_symbol s}\n` + ` brcl 15, {emit_symbol func}\n` end - | Lop(Iextcall(s, alloc)) -> + | Lop(Iextcall { func; alloc; label_after; }) -> if alloc then begin if !pic_code then begin - ` lgrl %r7, {emit_symbol s}@GOTENT\n`; + ` lgrl %r7, {emit_symbol func}@GOTENT\n`; ` brasl %r14, {emit_symbol "caml_c_call"}@PLT\n` end else begin - ` larl %r7, {emit_symbol s}\n`; + ` larl %r7, {emit_symbol func}\n`; ` brasl %r14, {emit_symbol "caml_c_call"}\n` end; - let lbl = record_frame i.live i.dbg in + let lbl = record_frame i.live i.dbg ~label:label_after in `{emit_label lbl}:\n`; end else begin if !pic_code then - ` brasl %r14, {emit_symbol s}@PLT\n` + ` brasl %r14, {emit_symbol func}@PLT\n` else - ` brasl %r14, {emit_symbol s}\n` + ` brasl %r14, {emit_symbol func}\n` end | Lop(Istackoffset n) -> @@ -408,10 +412,10 @@ let emit_instr i = | Double | Double_u -> "stdy" in emit_load_store storeinstr addr i.arg 1 i.arg.(0) - | Lop(Ialloc n) -> + | Lop(Ialloc { words = n; label_after_call_gc; }) -> let lbl_redo = new_label() in let lbl_call_gc = new_label() in - let lbl_frame = record_frame i.live i.dbg in + let lbl_frame = record_frame i.live i.dbg ?label:label_after_call_gc in call_gc_sites := { gc_lbl = lbl_call_gc; gc_return_lbl = lbl_redo; @@ -464,8 +468,8 @@ let emit_instr i = ` brc {emit_int mask}, {emit_label lbl}\n`; ` lghi {emit_reg i.res.(0)}, 0\n`; `{emit_label lbl}:\n` - | Lop(Iintop Icheckbound) -> - let lbl = bound_error_label i.dbg in + | Lop(Iintop (Icheckbound { label_after_error; })) -> + let lbl = bound_error_label i.dbg ?label:label_after_error in ` clgr {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; ` brcl 12, {emit_label lbl}\n` (* branch if unsigned le *) | Lop(Iintop op) -> @@ -484,8 +488,8 @@ let emit_instr i = ` brc {emit_int mask}, {emit_label lbl}\n`; ` lghi {emit_reg i.res.(0)}, 0\n`; `{emit_label lbl}:\n` - | 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 i.dbg ?label:label_after_error in if n >= 0 then begin ` clgfi {emit_reg i.arg.(0)}, {emit_int n}\n`; ` brcl 12, {emit_label lbl}\n` (* branch if unsigned le *) diff --git a/asmcomp/s390x/proc.ml b/asmcomp/s390x/proc.ml index 3dee61a41ad3..e406ed0f8ba1 100644 --- a/asmcomp/s390x/proc.ml +++ b/asmcomp/s390x/proc.ml @@ -171,8 +171,9 @@ let destroyed_at_c_call = 100; 101; 102; 103; 104; 105; 106; 107]) 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 | _ -> [||] let destroyed_at_raise = all_phys_regs @@ -180,20 +181,20 @@ let destroyed_at_raise = all_phys_regs (* Maximal register pressure *) let safe_register_pressure = function - Iextcall(_, _) -> 4 + Iextcall _ -> 4 | _ -> 9 let max_register_pressure = function - Iextcall(_, _) -> [| 4; 7 |] + Iextcall _ -> [| 4; 7 |] | _ -> [| 9; 15 |] (* Pure operations (without any side effect besides updating their result 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(Imultaddf | Imultsubf) -> true | _ -> true diff --git a/asmcomp/schedgen.ml b/asmcomp/schedgen.ml index e228d1c3c167..89ccd13a39aa 100644 --- a/asmcomp/schedgen.ml +++ b/asmcomp/schedgen.ml @@ -148,9 +148,9 @@ val mutable trywith_nesting = 0 that terminate a basic block. *) method oper_in_basic_block = function - Icall_ind -> false + Icall_ind _ -> false | Icall_imm _ -> false - | Itailcall_ind -> false + | Itailcall_ind _ -> false | Itailcall_imm _ -> false | Iextcall _ -> false | Istackoffset _ -> false @@ -185,8 +185,8 @@ method is_load = function | _ -> false method is_checkbound = function - Iintop Icheckbound -> true - | Iintop_imm(Icheckbound, _) -> true + Iintop (Icheckbound _) -> true + | Iintop_imm(Icheckbound _, _) -> true | _ -> false method private instr_is_store instr = @@ -375,7 +375,7 @@ method schedule_fundecl f = else begin let critical_outputs = match i.desc with - Lop(Icall_ind | Itailcall_ind) -> [| i.arg.(0) |] + Lop(Icall_ind _ | Itailcall_ind _) -> [| i.arg.(0) |] | Lop(Icall_imm _ | Itailcall_imm _ | Iextcall _) -> [||] | Lreturn -> [||] | _ -> i.arg in diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml index 72e59a89eec7..28f1e1d80fba 100644 --- a/asmcomp/selectgen.ml +++ b/asmcomp/selectgen.ml @@ -27,7 +27,7 @@ type environment = (Ident.t, Reg.t array) Tbl.t let oper_result_type = function Capply(ty, _) -> ty - | Cextcall(_s, ty, _alloc, _) -> ty + | Cextcall(_s, ty, _alloc, _, _) -> ty | Cload c -> begin match c with | Word_val -> typ_val @@ -172,7 +172,7 @@ let join_array rs = (* Extract debug info contained in a C-- operation *) let debuginfo_op = function | Capply(_, dbg) -> dbg - | Cextcall(_, _, _, dbg) -> dbg + | Cextcall(_, _, _, dbg, _) -> dbg | Craise (_, dbg) -> dbg | Ccheckbound dbg -> dbg | Calloc dbg -> dbg @@ -241,13 +241,13 @@ method mark_tailcall = () method mark_c_tailcall = () method mark_instr = function - | Iop (Icall_ind | Icall_imm _ | Iextcall _) -> + | Iop (Icall_ind _ | Icall_imm _ | Iextcall _) -> self#mark_call - | Iop (Itailcall_ind | Itailcall_imm _) -> + | Iop (Itailcall_ind _ | Itailcall_imm _) -> self#mark_tailcall | Iop (Ialloc _) -> self#mark_call (* caml_alloc*, caml_garbage_collection *) - | Iop (Iintop Icheckbound | Iintop_imm(Icheckbound, _)) -> + | Iop (Iintop (Icheckbound _) | Iintop_imm(Icheckbound _, _)) -> self#mark_c_tailcall (* caml_ml_array_bound_error *) | Iraise raise_kind -> begin match raise_kind with @@ -266,9 +266,19 @@ method mark_instr = function method select_operation op args = match (op, args) with - (Capply _, Cconst_symbol s :: rem) -> (Icall_imm s, rem) - | (Capply _, _) -> (Icall_ind, args) - | (Cextcall(s, _ty, alloc, _dbg), _) -> (Iextcall(s, alloc), args) + | (Capply _, Cconst_symbol func :: rem) -> + let label_after = Cmm.new_label () in + (Icall_imm { func; label_after; }, rem) + | (Capply _, _) -> + let label_after = Cmm.new_label () in + (Icall_ind { label_after; }, args) + | (Cextcall(func, _ty, alloc, _dbg, label_after), _) -> + let label_after = + match label_after with + | None -> Cmm.new_label () + | Some label_after -> label_after + in + Iextcall { func; alloc; label_after; }, args | (Cload chunk, [arg]) -> let (addr, eloc) = self#select_addressing chunk arg in (Iload(chunk, addr), [eloc]) @@ -286,7 +296,7 @@ method select_operation op args = (Istore(chunk, addr, is_assign), [arg2; eloc]) (* Inversion addr/datum in Istore *) end - | (Calloc _dbg, _) -> (Ialloc 0, args) + | (Calloc _dbg, _) -> Ialloc { words = 0; label_after_call_gc = None; }, args | (Caddi, _) -> self#select_arith_comm Iadd args | (Csubi, _) -> self#select_arith Isub args | (Cmuli, _) -> self#select_arith_comm Imul args @@ -311,7 +321,8 @@ method select_operation op args = | (Cdivf, _) -> (Idivf, args) | (Cfloatofint, _) -> (Ifloatofint, args) | (Cintoffloat, _) -> (Iintoffloat, args) - | (Ccheckbound _, _) -> self#select_arith Icheckbound args + | (Ccheckbound _, _) -> + self#select_arith (Icheckbound { label_after_error = None; }) args | _ -> fatal_error "Selection.select_oper" method private select_arith_comm op = function @@ -530,37 +541,39 @@ method emit_expr env exp = let (new_op, new_args) = self#select_operation op simple_args in let dbg = debuginfo_op op in match new_op with - Icall_ind -> + Icall_ind _ -> let r1 = self#emit_tuple env new_args in let rarg = Array.sub r1 1 (Array.length r1 - 1) in let rd = self#regs_for ty in let (loc_arg, stack_ofs) = Proc.loc_arguments rarg in let loc_res = Proc.loc_results rd in self#insert_move_args rarg loc_arg stack_ofs; - self#insert_debug (Iop Icall_ind) dbg + self#insert_debug (Iop new_op) dbg (Array.append [|r1.(0)|] loc_arg) loc_res; self#insert_move_results loc_res rd stack_ofs; Some rd - | Icall_imm lbl -> + | Icall_imm _ -> let r1 = self#emit_tuple env new_args in let rd = self#regs_for ty in let (loc_arg, stack_ofs) = Proc.loc_arguments r1 in let loc_res = Proc.loc_results rd in self#insert_move_args r1 loc_arg stack_ofs; - self#insert_debug (Iop(Icall_imm lbl)) dbg loc_arg loc_res; + self#insert_debug (Iop new_op) dbg loc_arg loc_res; self#insert_move_results loc_res rd stack_ofs; Some rd - | Iextcall(lbl, alloc) -> + | Iextcall _ -> let (loc_arg, stack_ofs) = self#emit_extcall_args env new_args in let rd = self#regs_for ty in - let loc_res = self#insert_op_debug (Iextcall(lbl, alloc)) dbg - loc_arg (Proc.loc_external_results rd) in + let loc_res = + self#insert_op_debug new_op dbg + loc_arg (Proc.loc_external_results rd) in self#insert_move_results loc_res rd stack_ofs; Some rd - | Ialloc _ -> + | Ialloc { words = _; label_after_call_gc; } -> let rd = self#regs_for typ_val in let size = size_expr env (Ctuple new_args) in - self#insert (Iop(Ialloc size)) [||] rd; + let op = Ialloc { words = size; label_after_call_gc; } in + self#insert_debug (Iop op) dbg [| |] rd; self#emit_stores env new_args rd; Some rd | op -> @@ -771,38 +784,41 @@ method emit_tail env exp = | Some(simple_args, env) -> let (new_op, new_args) = self#select_operation op simple_args in match new_op with - Icall_ind -> + Icall_ind { label_after; } -> let r1 = self#emit_tuple env new_args in let rarg = Array.sub r1 1 (Array.length r1 - 1) in let (loc_arg, stack_ofs) = Proc.loc_arguments rarg in if stack_ofs = 0 then begin + let call = Iop (Itailcall_ind { label_after; }) in self#insert_moves rarg loc_arg; - self#insert (Iop Itailcall_ind) - (Array.append [|r1.(0)|] loc_arg) [||] + self#insert_debug call dbg + (Array.append [|r1.(0)|] loc_arg) [||]; end else begin let rd = self#regs_for ty in let loc_res = Proc.loc_results rd in self#insert_move_args rarg loc_arg stack_ofs; - self#insert_debug (Iop Icall_ind) dbg + self#insert_debug (Iop new_op) dbg (Array.append [|r1.(0)|] loc_arg) loc_res; self#insert(Iop(Istackoffset(-stack_ofs))) [||] [||]; self#insert Ireturn loc_res [||] end - | Icall_imm lbl -> + | Icall_imm { func; label_after; } -> let r1 = self#emit_tuple env new_args in let (loc_arg, stack_ofs) = Proc.loc_arguments r1 in if stack_ofs = 0 then begin + let call = Iop (Itailcall_imm { func; label_after; }) in self#insert_moves r1 loc_arg; - self#insert (Iop(Itailcall_imm lbl)) loc_arg [||] - end else if lbl = !current_function_name then begin + self#insert_debug call dbg loc_arg [||]; + end else if func = !current_function_name then begin + let call = Iop (Itailcall_imm { func; label_after; }) in let loc_arg' = Proc.loc_parameters r1 in self#insert_moves r1 loc_arg'; - self#insert (Iop(Itailcall_imm lbl)) loc_arg' [||] + self#insert_debug call dbg loc_arg' [||]; end else begin let rd = self#regs_for ty in let loc_res = Proc.loc_results rd in self#insert_move_args r1 loc_arg stack_ofs; - self#insert_debug (Iop(Icall_imm lbl)) dbg loc_arg loc_res; + self#insert_debug (Iop new_op) dbg loc_arg loc_res; self#insert(Iop(Istackoffset(-stack_ofs))) [||] [||]; self#insert Ireturn loc_res [||] end diff --git a/asmcomp/sparc/emit.mlp b/asmcomp/sparc/emit.mlp index 76b890e6d2e0..21d5c8cd6554 100644 --- a/asmcomp/sparc/emit.mlp +++ b/asmcomp/sparc/emit.mlp @@ -164,8 +164,12 @@ type frame_descr = let frame_descriptors = ref([] : frame_descr list) -let record_frame live = - let lbl = new_label() in +let record_frame ?label live = + let lbl = + match label with + | None -> new_label() + | Some label -> label + in let live_offset = ref [] in Reg.Set.iter (function @@ -333,37 +337,37 @@ let rec emit_instr i dslot = | Lop(Iconst_symbol s) -> ` sethi %hi({emit_symbol s}), %g1\n`; ` or %g1, %lo({emit_symbol s}), {emit_reg i.res.(0)}\n` - | Lop(Icall_ind) -> - `{record_frame i.live} call {emit_reg i.arg.(0)}\n`; + | Lop(Icall_ind { label_after; }) -> + `{record_frame i.live ~label:label_after} call {emit_reg i.arg.(0)}\n`; fill_delay_slot dslot - | Lop(Icall_imm s) -> - `{record_frame i.live} call {emit_symbol s}\n`; + | Lop(Icall_imm { func; label_after; }) -> + `{record_frame i.live ~label:label_after} call {emit_symbol func}\n`; fill_delay_slot dslot - | Lop(Itailcall_ind) -> + | Lop(Itailcall_ind { label_after = _; }) -> let n = frame_size() in if !contains_calls then ` ld [%sp + {emit_int(n - 4 + 96)}], %o7\n`; ` jmp {emit_reg i.arg.(0)}\n`; ` add %sp, {emit_int n}, %sp\n` (* in delay slot *) - | Lop(Itailcall_imm s) -> + | Lop(Itailcall_imm { func; label_after = _; }) -> let n = frame_size() in - if s = !function_name then begin + if func = !function_name then begin ` b {emit_label !tailrec_entry_point}\n`; fill_delay_slot dslot end else begin if !contains_calls then ` ld [%sp + {emit_int(n - 4 + 96)}], %o7\n`; - ` sethi %hi({emit_symbol s}), %g1\n`; - ` jmp %g1 + %lo({emit_symbol s})\n`; + ` sethi %hi({emit_symbol func}), %g1\n`; + ` jmp %g1 + %lo({emit_symbol func})\n`; ` add %sp, {emit_int n}, %sp\n` (* in delay slot *) end - | Lop(Iextcall(s, alloc)) -> + | Lop(Iextcall { func; alloc; label_after; }) -> if alloc then begin - ` sethi %hi({emit_symbol s}), %g2\n`; - `{record_frame i.live} call {emit_symbol "caml_c_call"}\n`; - ` or %g2, %lo({emit_symbol s}), %g2\n` (* in delay slot *) + ` sethi %hi({emit_symbol func}), %g2\n`; + `{record_frame i.live ~label:label_after} call {emit_symbol "caml_c_call"}\n`; + ` or %g2, %lo({emit_symbol func}), %g2\n` (* in delay slot *) end else begin - ` call {emit_symbol s}\n`; + ` call {emit_symbol func}\n`; fill_delay_slot dslot end | Lop(Istackoffset n) -> @@ -407,7 +411,7 @@ let rec emit_instr i dslot = | _ -> "st" in emit_store storeinstr addr i.arg src end - | Lop(Ialloc n) -> + | Lop(Ialloc { words = n; label_after_call_gc; }) -> if !fastcode_flag then begin let lbl_cont = new_label() in if solaris then begin @@ -420,7 +424,7 @@ let rec emit_instr i dslot = end; ` bgeu {emit_label lbl_cont}\n`; ` add %l6, 4, {emit_reg i.res.(0)}\n`; (* in delay slot *) - `{record_frame i.live} call {emit_symbol "caml_call_gc"}\n`; + `{record_frame i.live ?label:label_after_call_gc} call {emit_symbol "caml_call_gc"}\n`; ` mov {emit_int n}, %g2\n`; (* in delay slot *) ` add %l6, 4, {emit_reg i.res.(0)}\n`; `{emit_label lbl_cont}:\n` @@ -444,7 +448,7 @@ let rec emit_instr i dslot = ` mov 0, {emit_reg i.res.(0)}\n`; `{emit_label lbl}:\n` end - | Lop(Iintop Icheckbound) -> + | Lop(Iintop (Icheckbound _)) -> ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; if solaris then ` tleu 5\n` (* 5 = ST_RANGE_CHECK *) @@ -480,7 +484,7 @@ let rec emit_instr i dslot = ` mov 0, {emit_reg i.res.(0)}\n`; `{emit_label lbl}:\n` end - | Lop(Iintop_imm(Icheckbound, n)) -> + | Lop(Iintop_imm(Icheckbound _, n)) -> ` cmp {emit_reg i.arg.(0)}, {emit_int n}\n`; if solaris then ` tleu 5\n` (* 5 = ST_RANGE_CHECK *) @@ -614,7 +618,7 @@ and fill_delay_slot = function that does not branch. *) let is_one_instr_op = function - Imulh | Idiv | Imod | Icomp _ | Icheckbound -> false + Imulh | Idiv | Imod | Icomp _ | Icheckbound _ -> false | _ -> true let is_one_instr i = @@ -651,15 +655,16 @@ let no_interference res arg = let rec emit_all i = match i with {desc = Lend} -> () - | {next = {desc = Lop(Icall_imm _) | Lop(Iextcall(_, false)) | Lbranch _}} + | {next = {desc = Lop(Icall_imm _) + | Lop(Iextcall { alloc = false; }) | Lbranch _}} when is_one_instr i -> emit_instr i.next (Some i); emit_all i.next.next - | {next = {desc = Lop(Itailcall_imm s)}} - when s = !function_name && is_one_instr i -> + | {next = {desc = Lop(Itailcall_imm { func; _ })}} + when func = !function_name && is_one_instr i -> emit_instr i.next (Some i); emit_all i.next.next - | {next = {desc = Lop(Icall_ind)}} + | {next = {desc = Lop(Icall_ind _)}} when is_one_instr i && no_interference i.res i.next.arg -> emit_instr i.next (Some i); emit_all i.next.next diff --git a/asmcomp/sparc/proc.ml b/asmcomp/sparc/proc.ml index 63d38935e866..9bfba6d59765 100644 --- a/asmcomp/sparc/proc.ml +++ b/asmcomp/sparc/proc.ml @@ -204,8 +204,9 @@ let destroyed_at_c_call = (* %l0-%l4, %i0-%i5 preserved *) 108; 109; 110; 111; 112; 113; 114]) 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 | _ -> [||] let destroyed_at_raise = all_phys_regs @@ -213,20 +214,20 @@ let destroyed_at_raise = all_phys_regs (* Maximal register pressure *) let safe_register_pressure = function - Iextcall(_, _) -> 0 + Iextcall _ -> 0 | _ -> 15 let max_register_pressure = function - Iextcall(_, _) -> [| 11; 0 |] + Iextcall _ -> [| 11; 0 |] | _ -> [| 19; 15 |] (* Pure operations (without any side effect besides updating their result 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 | _ -> true (* Layout of the stack *) diff --git a/asmcomp/sparc/scheduling.ml b/asmcomp/sparc/scheduling.ml index 5935ebf737ce..c169b4750194 100644 --- a/asmcomp/sparc/scheduling.ml +++ b/asmcomp/sparc/scheduling.ml @@ -49,9 +49,9 @@ method oper_issue_cycles = function | Iconst_symbol _ -> 2 | Ialloc _ -> 6 | Iintop(Icomp _) -> 4 - | Iintop(Icheckbound) -> 2 + | Iintop(Icheckbound _) -> 2 | Iintop_imm(Icomp _, _) -> 4 - | Iintop_imm(Icheckbound, _) -> 2 + | Iintop_imm(Icheckbound _, _) -> 2 | Inegf -> 2 | Iabsf -> 2 | Ifloatofint -> 6 diff --git a/asmcomp/sparc/selection.ml b/asmcomp/sparc/selection.ml index 986a2fba53d7..c78a5f6560a5 100644 --- a/asmcomp/sparc/selection.ml +++ b/asmcomp/sparc/selection.ml @@ -38,6 +38,9 @@ method select_addressing _chunk = function | arg -> (Iindexed 0, arg) +method private iextcall (func, alloc) = + Iextcall { func; alloc; label_after = Cmm.new_label (); } + method! select_operation op args = match (op, args) with (* For SPARC V7 multiplication, division and modulus are turned into @@ -45,11 +48,11 @@ method! select_operation op args = For SPARC V8 and V9, use hardware multiplication and division, but C library routine for modulus. *) (Cmuli, _) when !arch_version = SPARC_V7 -> - (Iextcall(".umul", false), args) + (self#iextcall(".umul", false), args) | (Cdivi, _) when !arch_version = SPARC_V7 -> - (Iextcall(".div", false), args) + (self#iextcall(".div", false), args) | (Cmodi, _) -> - (Iextcall(".rem", false), args) + (self#iextcall(".rem", false), args) | _ -> super#select_operation op args diff --git a/asmcomp/spill.ml b/asmcomp/spill.ml index a90a67422f83..4c0231cb2c2a 100644 --- a/asmcomp/spill.ml +++ b/asmcomp/spill.ml @@ -139,10 +139,10 @@ let rec reload i before = match i.desc with Iend -> (i, before) - | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) -> + | Ireturn | Iop(Itailcall_ind _) | Iop(Itailcall_imm _) -> (add_reloads (Reg.inter_set_array before i.arg) i, Reg.Set.empty) - | Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> + | Iop(Icall_ind _ | Icall_imm _ | Iextcall { alloc = true; }) -> (* All regs live across must be spilled *) let (new_next, finally) = reload i.next i.live in (add_reloads (Reg.inter_set_array before i.arg) @@ -286,7 +286,7 @@ let rec spill i finally = match i.desc with Iend -> (i, finally) - | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) -> + | Ireturn | Iop(Itailcall_ind _) | Iop(Itailcall_imm _) -> (i, Reg.Set.empty) | Iop Ireload -> let (new_next, after) = spill i.next finally in @@ -298,8 +298,8 @@ let rec spill i finally = let before1 = Reg.diff_set_array after i.res in let before = match i.desc with - Iop Icall_ind | Iop(Icall_imm _) | Iop(Iextcall _) - | Iop(Iintop Icheckbound) | Iop(Iintop_imm(Icheckbound, _)) -> + Iop(Icall_ind _) | Iop(Icall_imm _) | Iop(Iextcall _) + | Iop(Iintop (Icheckbound _)) | Iop(Iintop_imm(Icheckbound _, _)) -> Reg.Set.union before1 !spill_at_raise | _ -> before1 in diff --git a/asmcomp/split.ml b/asmcomp/split.ml index b64f70431f2e..87588f1fdc52 100644 --- a/asmcomp/split.ml +++ b/asmcomp/split.ml @@ -125,7 +125,7 @@ let rec rename i sub = match i.desc with Iend -> (i, sub) - | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) -> + | Ireturn | Iop(Itailcall_ind _) | Iop(Itailcall_imm _) -> (instr_cons i.desc (subst_regs i.arg sub) [||] i.next, None) | Iop Ireload when i.res.(0).loc = Unknown -> diff --git a/testsuite/tests/asmcomp/parsecmm.mly b/testsuite/tests/asmcomp/parsecmm.mly index 3d2aee9271ca..b87e36471b1a 100644 --- a/testsuite/tests/asmcomp/parsecmm.mly +++ b/testsuite/tests/asmcomp/parsecmm.mly @@ -173,7 +173,7 @@ expr: | LPAREN APPLY expr exprlist machtype RPAREN { Cop(Capply($5, Debuginfo.none), $3 :: List.rev $4) } | LPAREN EXTCALL STRING exprlist machtype RPAREN - { Cop(Cextcall($3, $5, false, Debuginfo.none), List.rev $4) } + { Cop(Cextcall($3, $5, false, Debuginfo.none, None), List.rev $4) } | LPAREN SUBF expr RPAREN { Cop(Cnegf, [$3]) } | LPAREN SUBF expr expr RPAREN { Cop(Csubf, [$3; $4]) } | LPAREN unaryop expr RPAREN { Cop($2, [$3]) }