Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Labels after calls, call GC points and checkbound points (#644)

master
Mark Shinwell 2016-07-01 15:16:03 +01:00 committed by GitHub
parent 2f9081e4e9
commit 432f87f077
27 changed files with 199 additions and 163 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
asmcomp/CSEgen.ml
View File

@ -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;

63
asmcomp/amd64/emit.mlp
View File

@ -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)) ->

13
asmcomp/amd64/proc.ml
View File

@ -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

2
asmcomp/amd64/reload.ml
View File

@ -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)

12
asmcomp/amd64/selection.ml
View File

@ -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 ->

12
asmcomp/branch_relaxation.ml
View File

@ -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,20 @@ 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) ->
| Lop (Ialloc { words = num_words; _ }) ->
instr.desc <- T.relax_allocation ~num_words;
fixup true (pc + T.instr_size instr.desc) instr.next
| Lop (Iintop Icheckbound) ->
| Lop (Iintop (Icheckbound _)) ->
instr.desc <- T.relax_intop_checkbound ();
fixup true (pc + T.instr_size instr.desc) instr.next
| Lop (Iintop_imm (Icheckbound, bound)) ->
| Lop (Iintop_imm (Icheckbound _, bound)) ->
instr.desc <- T.relax_intop_imm_checkbound ~bound;
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)

10
asmcomp/cmm.ml
View File

@ -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

5
asmcomp/cmm.mli
View File

@ -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

27
asmcomp/cmmgen.ml
View File

@ -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 ->

14
asmcomp/comballoc.ml
View File

@ -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)

2
asmcomp/deadcode.ml
View File

@ -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

4
asmcomp/emitaux.ml
View File

@ -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

4
asmcomp/interf.ml
View File

@ -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

18
asmcomp/linearize.ml
View File

@ -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;

4
asmcomp/linearize.mli
View File

@ -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

6
asmcomp/liveness.ml
View File

@ -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

18
asmcomp/mach.ml
View File

@ -23,7 +23,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 : Cmm.label option; }
type test =
Itruetest
@ -34,6 +34,8 @@ type test =
| Ioddtest
| Ieventest
type label = Cmm.label
type operation =
Imove
| Ispill
@ -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 : Cmm.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) ->

16
asmcomp/mach.mli
View File

@ -23,7 +23,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 : Cmm.label option; }
type test =
Itruetest
@ -34,6 +34,8 @@ type test =
| Ioddtest
| Ieventest
type label = Cmm.label
type operation =
Imove
| Ispill
@ -42,16 +44,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 : Cmm.label option; }
| Iintop of integer_operation
| Iintop_imm of integer_operation * int
| Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf

4
asmcomp/printcmm.ml
View File

@ -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 ")@]"

2
asmcomp/printlinear.ml
View File

@ -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;

16
asmcomp/printmach.ml
View File

@ -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)

4
asmcomp/reloadgen.ml
View File

@ -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}

10
asmcomp/schedgen.ml
View File

@ -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

72
asmcomp/selectgen.ml
View File

@ -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

10
asmcomp/spill.ml
View File

@ -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

2
asmcomp/split.ml
View File

@ -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 ->

2
testsuite/tests/asmcomp/parsecmm.mly
View File

@ -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]) }