Merge pull request #9948 from nojb/remove_spacetime
The Spacetime memory profiler is not going to be supported in Multicore OCaml, and is already broken by some of the related changes in OCaml 4.12. The core development team decided to remove Spacetime support from OCaml 4.12.master
commit
86c8a98f3c
46
.depend
46
.depend
|
@ -2265,12 +2265,10 @@ asmcomp/branch_relaxation.cmi : \
|
|||
asmcomp/branch_relaxation_intf.cmo : \
|
||||
asmcomp/linear.cmi \
|
||||
lambda/debuginfo.cmi \
|
||||
asmcomp/cmm.cmi \
|
||||
asmcomp/arch.cmo
|
||||
asmcomp/branch_relaxation_intf.cmx : \
|
||||
asmcomp/linear.cmx \
|
||||
lambda/debuginfo.cmx \
|
||||
asmcomp/cmm.cmx \
|
||||
asmcomp/arch.cmx
|
||||
asmcomp/cmm.cmo : \
|
||||
utils/targetint.cmi \
|
||||
|
@ -2442,7 +2440,6 @@ asmcomp/deadcode.cmo : \
|
|||
asmcomp/proc.cmi \
|
||||
utils/numbers.cmi \
|
||||
asmcomp/mach.cmi \
|
||||
utils/config.cmi \
|
||||
asmcomp/cmm.cmi \
|
||||
asmcomp/deadcode.cmi
|
||||
asmcomp/deadcode.cmx : \
|
||||
|
@ -2450,7 +2447,6 @@ asmcomp/deadcode.cmx : \
|
|||
asmcomp/proc.cmx \
|
||||
utils/numbers.cmx \
|
||||
asmcomp/mach.cmx \
|
||||
utils/config.cmx \
|
||||
asmcomp/cmm.cmx \
|
||||
asmcomp/deadcode.cmi
|
||||
asmcomp/deadcode.cmi : \
|
||||
|
@ -2572,7 +2568,6 @@ asmcomp/linearize.cmo : \
|
|||
asmcomp/mach.cmi \
|
||||
asmcomp/linear.cmi \
|
||||
lambda/debuginfo.cmi \
|
||||
utils/config.cmi \
|
||||
asmcomp/cmm.cmi \
|
||||
asmcomp/linearize.cmi
|
||||
asmcomp/linearize.cmx : \
|
||||
|
@ -2582,7 +2577,6 @@ asmcomp/linearize.cmx : \
|
|||
asmcomp/mach.cmx \
|
||||
asmcomp/linear.cmx \
|
||||
lambda/debuginfo.cmx \
|
||||
utils/config.cmx \
|
||||
asmcomp/cmm.cmx \
|
||||
asmcomp/linearize.cmi
|
||||
asmcomp/linearize.cmi : \
|
||||
|
@ -2605,7 +2599,6 @@ asmcomp/liveness.cmo : \
|
|||
asmcomp/printmach.cmi \
|
||||
utils/misc.cmi \
|
||||
asmcomp/mach.cmi \
|
||||
utils/config.cmi \
|
||||
asmcomp/cmm.cmi \
|
||||
asmcomp/liveness.cmi
|
||||
asmcomp/liveness.cmx : \
|
||||
|
@ -2614,7 +2607,6 @@ asmcomp/liveness.cmx : \
|
|||
asmcomp/printmach.cmx \
|
||||
utils/misc.cmx \
|
||||
asmcomp/mach.cmx \
|
||||
utils/config.cmx \
|
||||
asmcomp/cmm.cmx \
|
||||
asmcomp/liveness.cmi
|
||||
asmcomp/liveness.cmi : \
|
||||
|
@ -2695,7 +2687,6 @@ asmcomp/printmach.cmo : \
|
|||
lambda/lambda.cmi \
|
||||
asmcomp/interval.cmi \
|
||||
lambda/debuginfo.cmi \
|
||||
utils/config.cmi \
|
||||
asmcomp/cmm.cmi \
|
||||
utils/clflags.cmi \
|
||||
middle_end/backend_var.cmi \
|
||||
|
@ -2710,7 +2701,6 @@ asmcomp/printmach.cmx : \
|
|||
lambda/lambda.cmx \
|
||||
asmcomp/interval.cmx \
|
||||
lambda/debuginfo.cmx \
|
||||
utils/config.cmx \
|
||||
asmcomp/cmm.cmx \
|
||||
utils/clflags.cmx \
|
||||
middle_end/backend_var.cmx \
|
||||
|
@ -2821,7 +2811,6 @@ asmcomp/selectgen.cmo : \
|
|||
asmcomp/mach.cmi \
|
||||
lambda/lambda.cmi \
|
||||
lambda/debuginfo.cmi \
|
||||
utils/config.cmi \
|
||||
asmcomp/cmm.cmi \
|
||||
middle_end/backend_var.cmi \
|
||||
parsing/asttypes.cmi \
|
||||
|
@ -2836,7 +2825,6 @@ asmcomp/selectgen.cmx : \
|
|||
asmcomp/mach.cmx \
|
||||
lambda/lambda.cmx \
|
||||
lambda/debuginfo.cmx \
|
||||
utils/config.cmx \
|
||||
asmcomp/cmm.cmx \
|
||||
middle_end/backend_var.cmx \
|
||||
parsing/asttypes.cmi \
|
||||
|
@ -2851,21 +2839,17 @@ asmcomp/selectgen.cmi : \
|
|||
parsing/asttypes.cmi \
|
||||
asmcomp/arch.cmo
|
||||
asmcomp/selection.cmo : \
|
||||
asmcomp/spacetime_profiling.cmi \
|
||||
asmcomp/selectgen.cmi \
|
||||
asmcomp/proc.cmi \
|
||||
asmcomp/mach.cmi \
|
||||
utils/config.cmi \
|
||||
asmcomp/cmm.cmi \
|
||||
utils/clflags.cmi \
|
||||
asmcomp/arch.cmo \
|
||||
asmcomp/selection.cmi
|
||||
asmcomp/selection.cmx : \
|
||||
asmcomp/spacetime_profiling.cmx \
|
||||
asmcomp/selectgen.cmx \
|
||||
asmcomp/proc.cmx \
|
||||
asmcomp/mach.cmx \
|
||||
utils/config.cmx \
|
||||
asmcomp/cmm.cmx \
|
||||
utils/clflags.cmx \
|
||||
asmcomp/arch.cmx \
|
||||
|
@ -2873,36 +2857,6 @@ asmcomp/selection.cmx : \
|
|||
asmcomp/selection.cmi : \
|
||||
asmcomp/mach.cmi \
|
||||
asmcomp/cmm.cmi
|
||||
asmcomp/spacetime_profiling.cmo : \
|
||||
asmcomp/selectgen.cmi \
|
||||
asmcomp/proc.cmi \
|
||||
utils/misc.cmi \
|
||||
asmcomp/mach.cmi \
|
||||
lambda/lambda.cmi \
|
||||
lambda/debuginfo.cmi \
|
||||
utils/config.cmi \
|
||||
asmcomp/cmm_helpers.cmi \
|
||||
asmcomp/cmm.cmi \
|
||||
middle_end/backend_var.cmi \
|
||||
parsing/asttypes.cmi \
|
||||
asmcomp/arch.cmo \
|
||||
asmcomp/spacetime_profiling.cmi
|
||||
asmcomp/spacetime_profiling.cmx : \
|
||||
asmcomp/selectgen.cmx \
|
||||
asmcomp/proc.cmx \
|
||||
utils/misc.cmx \
|
||||
asmcomp/mach.cmx \
|
||||
lambda/lambda.cmx \
|
||||
lambda/debuginfo.cmx \
|
||||
utils/config.cmx \
|
||||
asmcomp/cmm_helpers.cmx \
|
||||
asmcomp/cmm.cmx \
|
||||
middle_end/backend_var.cmx \
|
||||
parsing/asttypes.cmi \
|
||||
asmcomp/arch.cmx \
|
||||
asmcomp/spacetime_profiling.cmi
|
||||
asmcomp/spacetime_profiling.cmi : \
|
||||
asmcomp/selectgen.cmi
|
||||
asmcomp/spill.cmo : \
|
||||
asmcomp/reg.cmi \
|
||||
asmcomp/proc.cmi \
|
||||
|
|
5
Changes
5
Changes
|
@ -319,6 +319,11 @@ Working version
|
|||
various broken cli behaviours.
|
||||
(Daniel Bünzli, review by Nicolás Ojeda Bär)
|
||||
|
||||
### Debugging and profiling:
|
||||
|
||||
- #9948: Remove Spacetime.
|
||||
(Nicolás Ojeda Bär, review by Stephen Dolan and Xavier Leroy)
|
||||
|
||||
### Manual and documentation:
|
||||
|
||||
- #9468: HACKING.adoc: using dune to get merlin's support
|
||||
|
|
4
Makefile
4
Makefile
|
@ -746,7 +746,7 @@ clean::
|
|||
$(MAKE) -C runtime clean
|
||||
rm -f stdlib/libcamlrun.a stdlib/libcamlrun.lib
|
||||
|
||||
otherlibs_all := bigarray dynlink raw_spacetime_lib \
|
||||
otherlibs_all := bigarray dynlink \
|
||||
str systhreads unix win32unix
|
||||
subdirs := debugger lex ocamldoc ocamltest stdlib tools \
|
||||
$(addprefix otherlibs/, $(otherlibs_all)) \
|
||||
|
@ -944,7 +944,7 @@ VERSIONS=$(shell git tag|grep '^[0-9]*.[0-9]*.[0-9]*$$'|grep -v '^[12].')
|
|||
lintapidiff:
|
||||
$(MAKE) -C tools lintapidiff.opt
|
||||
git ls-files -- 'otherlibs/*/*.mli' 'stdlib/*.mli' |\
|
||||
grep -Ev internal\|obj\|spacetime\|stdLabels\|moreLabels |\
|
||||
grep -Ev internal\|obj\|stdLabels\|moreLabels |\
|
||||
tools/lintapidiff.opt $(VERSIONS)
|
||||
|
||||
# Tools
|
||||
|
|
|
@ -165,7 +165,6 @@ INSTALL_BYTECODE_PROGRAMS=@install_bytecode_programs@
|
|||
# dynlink Dynamic linking (bytecode and native)
|
||||
# (win32)unix Unix system calls
|
||||
# str Regular expressions and high-level string processing
|
||||
# raw_spacetime_lib Parsing of spacetime traces
|
||||
# systhreads Same as threads, requires POSIX threads
|
||||
OTHERLIBRARIES=@otherlibraries@
|
||||
|
||||
|
@ -225,13 +224,8 @@ WITH_OCAMLDOC=@ocamldoc@
|
|||
WITH_OCAMLTEST=@ocamltest@
|
||||
ASM_CFI_SUPPORTED=@asm_cfi_supported@
|
||||
WITH_FRAME_POINTERS=@frame_pointers@
|
||||
WITH_SPACETIME=@spacetime@
|
||||
ENABLE_CALL_COUNTS=@call_counts@
|
||||
WITH_PROFINFO=@profinfo@
|
||||
PROFINFO_WIDTH=@profinfo_width@
|
||||
LIBUNWIND_AVAILABLE=@libunwind_available@
|
||||
LIBUNWIND_INCLUDE_FLAGS=@libunwind_include_flags@
|
||||
LIBUNWIND_LINK_FLAGS=@libunwind_link_flags@
|
||||
WITH_FPIC=@fpic@
|
||||
TARGET=@target@
|
||||
HOST=@host@
|
||||
|
|
|
@ -222,15 +222,15 @@ method class_of_operation op =
|
|||
match op with
|
||||
| Imove | Ispill | Ireload -> assert false (* treated specially *)
|
||||
| Iconst_int _ | Iconst_float _ | Iconst_symbol _ -> 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;
|
||||
|
|
|
@ -92,7 +92,7 @@ and instrument = function
|
|||
(* these are base cases and have no logging *)
|
||||
| Cconst_int _ | Cconst_natint _ | Cconst_float _
|
||||
| Cconst_symbol _
|
||||
| Cblockheader _ | Cvar _ as c -> c
|
||||
| Cvar _ as c -> c
|
||||
|
||||
let instrument_function c dbg =
|
||||
with_afl_logging c dbg
|
||||
|
@ -103,7 +103,7 @@ let instrument_initialiser c dbg =
|
|||
calls *)
|
||||
with_afl_logging
|
||||
(Csequence
|
||||
(Cop (Cextcall ("caml_setup_afl", typ_int, [], false, None),
|
||||
(Cop (Cextcall ("caml_setup_afl", typ_int, [], false),
|
||||
[Cconst_int (0, dbg ())],
|
||||
dbg ()),
|
||||
c))
|
||||
|
|
|
@ -50,8 +50,6 @@ type specific_operation =
|
|||
and float_operation =
|
||||
Ifloatadd | Ifloatsub | Ifloatmul | Ifloatdiv
|
||||
|
||||
let spacetime_node_hole_pointer_is_live_before _specific_op = false
|
||||
|
||||
(* Sizes, endianness *)
|
||||
|
||||
let big_endian = false
|
||||
|
|
|
@ -172,16 +172,7 @@ let emit_label lbl =
|
|||
|
||||
let label s = sym (emit_label s)
|
||||
|
||||
(* For Spacetime, keep track of code labels that have been emitted. *)
|
||||
let used_labels = ref Int.Set.empty
|
||||
|
||||
let mark_used lbl =
|
||||
if Config.spacetime && not (Int.Set.mem lbl !used_labels) then begin
|
||||
used_labels := Int.Set.add lbl !used_labels
|
||||
end
|
||||
|
||||
let def_label ?typ s =
|
||||
mark_used s;
|
||||
D.label ?typ (emit_label s)
|
||||
|
||||
let emit_Llabel fallthrough lbl =
|
||||
|
@ -250,12 +241,8 @@ let addressing addr typ i n =
|
|||
|
||||
(* Record live pointers at call points -- see Emitaux *)
|
||||
|
||||
let record_frame_label ?label live dbg =
|
||||
let lbl =
|
||||
match label with
|
||||
| None -> new_label()
|
||||
| Some label -> label
|
||||
in
|
||||
let record_frame_label live dbg =
|
||||
let lbl = new_label () in
|
||||
let live_offset = ref [] in
|
||||
Reg.Set.iter
|
||||
(function
|
||||
|
@ -272,69 +259,46 @@ let record_frame_label ?label live dbg =
|
|||
~live_offset:!live_offset dbg;
|
||||
lbl
|
||||
|
||||
let record_frame ?label live dbg =
|
||||
let lbl = record_frame_label ?label live dbg in
|
||||
let record_frame live dbg =
|
||||
let lbl = record_frame_label live dbg in
|
||||
def_label lbl
|
||||
|
||||
(* Spacetime instrumentation *)
|
||||
|
||||
let spacetime_before_uninstrumented_call ~node_ptr ~index =
|
||||
(* At the moment, [node_ptr] is pointing at the node for the current
|
||||
OCaml function. Get hold of the node itself and move the pointer
|
||||
forwards, saving it into the distinguished register. This is used
|
||||
for instrumentation of function calls (e.g. caml_call_gc and bounds
|
||||
check failures) not inserted until this stage of the compiler
|
||||
pipeline. *)
|
||||
I.mov node_ptr (reg Proc.loc_spacetime_node_hole);
|
||||
assert (index >= 2);
|
||||
I.add (int (index * 8)) (reg Proc.loc_spacetime_node_hole)
|
||||
|
||||
(* Record calls to the GC -- we've moved them out of the way *)
|
||||
|
||||
type gc_call =
|
||||
{ gc_lbl: label; (* Entry label *)
|
||||
gc_return_lbl: label; (* Where to branch after GC *)
|
||||
gc_frame: label; (* Label of frame descriptor *)
|
||||
gc_spacetime : (X86_ast.arg * int) option;
|
||||
(* Spacetime node hole pointer and index *)
|
||||
}
|
||||
|
||||
let call_gc_sites = ref ([] : gc_call list)
|
||||
|
||||
let emit_call_gc gc =
|
||||
def_label gc.gc_lbl;
|
||||
begin match gc.gc_spacetime with
|
||||
| None -> assert (not Config.spacetime)
|
||||
| Some (node_ptr, index) ->
|
||||
assert Config.spacetime;
|
||||
spacetime_before_uninstrumented_call ~node_ptr ~index
|
||||
end;
|
||||
emit_call "caml_call_gc";
|
||||
def_label gc.gc_frame;
|
||||
I.jmp (label gc.gc_return_lbl)
|
||||
|
||||
(* Record calls to caml_ml_array_bound_error.
|
||||
In -g mode, or when using Spacetime profiling, we maintain one call to
|
||||
In -g mode we maintain one call to
|
||||
caml_ml_array_bound_error per bound check site. Without -g, we can share
|
||||
a single call. *)
|
||||
|
||||
type bound_error_call =
|
||||
{ bd_lbl: label; (* Entry label *)
|
||||
bd_frame: label; (* Label of frame descriptor *)
|
||||
bd_spacetime : (X86_ast.arg * int) option;
|
||||
(* As for [gc_call]. *)
|
||||
}
|
||||
|
||||
let bound_error_sites = ref ([] : bound_error_call list)
|
||||
let bound_error_call = ref 0
|
||||
|
||||
let bound_error_label ?label dbg ~spacetime =
|
||||
if !Clflags.debug || Config.spacetime then begin
|
||||
let bound_error_label dbg =
|
||||
if !Clflags.debug then begin
|
||||
let lbl_bound_error = new_label() in
|
||||
let lbl_frame = record_frame_label ?label Reg.Set.empty (Dbg_other dbg) in
|
||||
let lbl_frame = record_frame_label Reg.Set.empty (Dbg_other dbg) in
|
||||
bound_error_sites :=
|
||||
{ bd_lbl = lbl_bound_error; bd_frame = lbl_frame;
|
||||
bd_spacetime = spacetime; } :: !bound_error_sites;
|
||||
{ bd_lbl = lbl_bound_error; bd_frame = lbl_frame; } :: !bound_error_sites;
|
||||
lbl_bound_error
|
||||
end else begin
|
||||
if !bound_error_call = 0 then bound_error_call := new_label();
|
||||
|
@ -343,11 +307,6 @@ let bound_error_label ?label dbg ~spacetime =
|
|||
|
||||
let emit_call_bound_error bd =
|
||||
def_label bd.bd_lbl;
|
||||
begin match bd.bd_spacetime with
|
||||
| None -> ()
|
||||
| Some (node_ptr, index) ->
|
||||
spacetime_before_uninstrumented_call ~node_ptr ~index
|
||||
end;
|
||||
emit_call "caml_ml_array_bound_error";
|
||||
def_label bd.bd_frame
|
||||
|
||||
|
@ -575,21 +534,16 @@ let emit_instr fallthrough i =
|
|||
| Lop(Iconst_symbol s) ->
|
||||
add_used_symbol s;
|
||||
load_symbol_addr s (res i 0)
|
||||
| Lop(Icall_ind { label_after; }) ->
|
||||
| Lop(Icall_ind) ->
|
||||
I.call (arg i 0);
|
||||
record_frame i.live (Dbg_other i.dbg) ~label:label_after
|
||||
| Lop(Icall_imm { func; label_after; }) ->
|
||||
record_frame i.live (Dbg_other i.dbg)
|
||||
| Lop(Icall_imm { func; }) ->
|
||||
add_used_symbol func;
|
||||
emit_call func;
|
||||
record_frame i.live (Dbg_other i.dbg) ~label:label_after
|
||||
| Lop(Itailcall_ind { label_after; }) ->
|
||||
output_epilogue begin fun () ->
|
||||
I.jmp (arg i 0);
|
||||
if Config.spacetime then begin
|
||||
record_frame Reg.Set.empty (Dbg_other i.dbg) ~label:label_after
|
||||
end
|
||||
end
|
||||
| Lop(Itailcall_imm { func; label_after; }) ->
|
||||
record_frame i.live (Dbg_other i.dbg)
|
||||
| Lop(Itailcall_ind) ->
|
||||
output_epilogue (fun () -> I.jmp (arg i 0))
|
||||
| Lop(Itailcall_imm { func; }) ->
|
||||
begin
|
||||
if func = !function_name then
|
||||
I.jmp (label !tailrec_entry_point)
|
||||
|
@ -599,16 +553,13 @@ let emit_instr fallthrough i =
|
|||
emit_jump func
|
||||
end
|
||||
end
|
||||
end;
|
||||
if Config.spacetime then begin
|
||||
record_frame Reg.Set.empty (Dbg_other i.dbg) ~label:label_after
|
||||
end
|
||||
| Lop(Iextcall { func; alloc; label_after; }) ->
|
||||
| Lop(Iextcall { func; alloc; }) ->
|
||||
add_used_symbol func;
|
||||
if alloc then begin
|
||||
load_symbol_addr func rax;
|
||||
emit_call "caml_c_call";
|
||||
record_frame i.live (Dbg_other i.dbg) ~label:label_after;
|
||||
record_frame i.live (Dbg_other i.dbg);
|
||||
if system <> S_win64 then begin
|
||||
(* TODO: investigate why such a diff.
|
||||
This comes from:
|
||||
|
@ -620,10 +571,7 @@ let emit_instr fallthrough i =
|
|||
I.mov (domain_field Domainstate.Domain_young_ptr) r15
|
||||
end
|
||||
end else begin
|
||||
emit_call func;
|
||||
if Config.spacetime then begin
|
||||
record_frame Reg.Set.empty (Dbg_other i.dbg) ~label:label_after
|
||||
end
|
||||
emit_call func
|
||||
end
|
||||
| Lop(Istackoffset n) ->
|
||||
if n < 0
|
||||
|
@ -671,33 +619,24 @@ let emit_instr fallthrough i =
|
|||
| Double | Double_u ->
|
||||
I.movsd (arg i 0) (addressing addr REAL8 i 1)
|
||||
end
|
||||
| Lop(Ialloc { bytes = n; label_after_call_gc; spacetime_index; dbginfo }) ->
|
||||
| Lop(Ialloc { bytes = n; dbginfo }) ->
|
||||
assert (n <= (Config.max_young_wosize + 1) * Arch.size_addr);
|
||||
if !fastcode_flag then begin
|
||||
I.sub (int n) r15;
|
||||
I.cmp (domain_field Domainstate.Domain_young_limit) r15;
|
||||
let lbl_call_gc = new_label() in
|
||||
let lbl_frame =
|
||||
record_frame_label ?label:label_after_call_gc i.live (Dbg_alloc dbginfo)
|
||||
record_frame_label i.live (Dbg_alloc dbginfo)
|
||||
in
|
||||
I.jb (label lbl_call_gc);
|
||||
let lbl_after_alloc = new_label() in
|
||||
def_label lbl_after_alloc;
|
||||
I.lea (mem64 NONE 8 R15) (res i 0);
|
||||
let gc_spacetime =
|
||||
if not Config.spacetime then None
|
||||
else Some (arg i 0, spacetime_index)
|
||||
in
|
||||
call_gc_sites :=
|
||||
{ gc_lbl = lbl_call_gc;
|
||||
gc_return_lbl = lbl_after_alloc;
|
||||
gc_frame = lbl_frame;
|
||||
gc_spacetime; } :: !call_gc_sites
|
||||
gc_frame = lbl_frame; } :: !call_gc_sites
|
||||
end else begin
|
||||
if Config.spacetime then begin
|
||||
spacetime_before_uninstrumented_call ~node_ptr:(arg i 0)
|
||||
~index:spacetime_index;
|
||||
end;
|
||||
begin match n with
|
||||
| 16 -> emit_call "caml_alloc1"
|
||||
| 24 -> emit_call "caml_alloc2"
|
||||
|
@ -706,10 +645,7 @@ let emit_instr fallthrough i =
|
|||
I.sub (int n) r15;
|
||||
emit_call "caml_allocN"
|
||||
end;
|
||||
let label =
|
||||
record_frame_label ?label:label_after_call_gc i.live
|
||||
(Dbg_alloc dbginfo)
|
||||
in
|
||||
let label = record_frame_label i.live (Dbg_alloc dbginfo) in
|
||||
def_label label;
|
||||
I.lea (mem64 NONE 8 R15) (res i 0)
|
||||
end
|
||||
|
@ -721,20 +657,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 { label_after_error; spacetime_index; } )) ->
|
||||
let spacetime =
|
||||
if not Config.spacetime then None
|
||||
else Some (arg i 2, spacetime_index)
|
||||
in
|
||||
let lbl = bound_error_label ?label:label_after_error i.dbg ~spacetime in
|
||||
| Lop(Iintop (Icheckbound)) ->
|
||||
let lbl = bound_error_label i.dbg in
|
||||
I.cmp (arg i 1) (arg i 0);
|
||||
I.jbe (label lbl)
|
||||
| Lop(Iintop_imm(Icheckbound { label_after_error; spacetime_index; }, n)) ->
|
||||
let spacetime =
|
||||
if not Config.spacetime then None
|
||||
else Some (arg i 1, spacetime_index)
|
||||
in
|
||||
let lbl = bound_error_label ?label:label_after_error i.dbg ~spacetime in
|
||||
| Lop(Iintop_imm(Icheckbound, n)) ->
|
||||
let lbl = bound_error_label i.dbg in
|
||||
I.cmp (int n) (arg i 0);
|
||||
I.jbe (label lbl)
|
||||
| Lop(Iintop(Idiv | Imod)) ->
|
||||
|
@ -907,9 +835,6 @@ let emit_instr fallthrough i =
|
|||
cfi_adjust_cfa_offset (-8);
|
||||
stack_offset := !stack_offset - 16
|
||||
| Lraise k ->
|
||||
(* No Spacetime instrumentation is required for [caml_raise_exn] and
|
||||
[caml_reraise_exn]. The only function called that might affect the
|
||||
trie is [caml_stash_backtrace], and it does not. *)
|
||||
begin match k with
|
||||
| Lambda.Raise_regular ->
|
||||
I.mov (int 0) (domain_field Domainstate.Domain_backtrace_pos);
|
||||
|
@ -1013,7 +938,6 @@ let begin_assembly() =
|
|||
reset_imp_table();
|
||||
float_constants := [];
|
||||
all_functions := [];
|
||||
used_labels := Int.Set.empty;
|
||||
if system = S_win64 then begin
|
||||
D.extrn "caml_call_gc" NEAR;
|
||||
D.extrn "caml_c_call" NEAR;
|
||||
|
@ -1052,44 +976,6 @@ let begin_assembly() =
|
|||
if system = S_macosx then I.nop (); (* PR#4690 *)
|
||||
()
|
||||
|
||||
let emit_spacetime_shapes () =
|
||||
D.data ();
|
||||
D.align 8;
|
||||
emit_global_label "spacetime_shapes";
|
||||
List.iter (fun fundecl ->
|
||||
(* CR-someday mshinwell: some of this should be platform independent *)
|
||||
begin match fundecl.fun_spacetime_shape with
|
||||
| None -> ()
|
||||
| Some shape ->
|
||||
(* Instrumentation that refers to dead code may have been eliminated. *)
|
||||
match List.filter (fun (_, l) -> Int.Set.mem l !used_labels) shape with
|
||||
| [] -> ()
|
||||
| shape ->
|
||||
let funsym = emit_symbol fundecl.fun_name in
|
||||
D.comment ("Shape for " ^ funsym ^ ":");
|
||||
D.qword (ConstLabel funsym);
|
||||
List.iter (fun (part_of_shape, label) ->
|
||||
let tag =
|
||||
match part_of_shape with
|
||||
| Direct_call_point _ -> 1
|
||||
| Indirect_call_point -> 2
|
||||
| Allocation_point -> 3
|
||||
in
|
||||
D.qword (Const (Int64.of_int tag));
|
||||
D.qword (ConstLabel (emit_label label));
|
||||
begin match part_of_shape with
|
||||
| Direct_call_point { callee; } ->
|
||||
D.qword (ConstLabel (emit_symbol callee))
|
||||
| Indirect_call_point -> ()
|
||||
| Allocation_point -> ()
|
||||
end)
|
||||
shape;
|
||||
D.qword (Const 0L)
|
||||
end)
|
||||
!all_functions;
|
||||
D.qword (Const 0L);
|
||||
D.comment "End of Spacetime shapes."
|
||||
|
||||
let end_assembly() =
|
||||
if !float_constants <> [] then begin
|
||||
begin match system with
|
||||
|
@ -1150,10 +1036,6 @@ let end_assembly() =
|
|||
D.size frametable (ConstSub (ConstThis, ConstLabel frametable))
|
||||
end;
|
||||
|
||||
if Config.spacetime then begin
|
||||
emit_spacetime_shapes ()
|
||||
end;
|
||||
|
||||
if system = S_linux then
|
||||
(* Mark stack as non-executable, PR#4564 *)
|
||||
D.section [".note.GNU-stack"] (Some "") [ "%progbits" ];
|
||||
|
|
|
@ -138,7 +138,6 @@ let rax = phys_reg 0
|
|||
let rdx = phys_reg 4
|
||||
let r10 = phys_reg 10
|
||||
let r11 = phys_reg 11
|
||||
let r13 = phys_reg 9
|
||||
let rbp = phys_reg 12
|
||||
let rxmm15 = phys_reg 115
|
||||
|
||||
|
@ -190,21 +189,16 @@ let incoming ofs = Incoming ofs
|
|||
let outgoing ofs = Outgoing ofs
|
||||
let not_supported _ofs = fatal_error "Proc.loc_results: cannot call"
|
||||
|
||||
let max_int_args_in_regs () =
|
||||
if Config.spacetime then 9 else 10
|
||||
|
||||
let loc_arguments arg =
|
||||
calling_conventions 0 ((max_int_args_in_regs ()) - 1) 100 109 outgoing arg
|
||||
calling_conventions 0 9 100 109 outgoing arg
|
||||
let loc_parameters arg =
|
||||
let (loc, _ofs) =
|
||||
calling_conventions 0 ((max_int_args_in_regs ()) - 1) 100 109 incoming arg
|
||||
calling_conventions 0 9 100 109 incoming arg
|
||||
in
|
||||
loc
|
||||
let loc_results res =
|
||||
let (loc, _ofs) = calling_conventions 0 0 100 100 not_supported res in loc
|
||||
|
||||
let loc_spacetime_node_hole = r13
|
||||
|
||||
(* C calling conventions under Unix:
|
||||
first integer args in rdi, rsi, rdx, rcx, r8, r9
|
||||
first float args in xmm0 ... xmm7
|
||||
|
@ -300,23 +294,14 @@ let destroyed_at_c_call =
|
|||
100;101;102;103;104;105;106;107;
|
||||
108;109;110;111;112;113;114;115])
|
||||
|
||||
let destroyed_by_spacetime_at_alloc =
|
||||
if Config.spacetime then
|
||||
[| loc_spacetime_node_hole |]
|
||||
else
|
||||
[| |]
|
||||
|
||||
let destroyed_at_alloc =
|
||||
let regs =
|
||||
if X86_proc.use_plt then
|
||||
destroyed_by_plt_stub
|
||||
else
|
||||
[| r11 |]
|
||||
in
|
||||
Array.concat [regs; destroyed_by_spacetime_at_alloc]
|
||||
if X86_proc.use_plt then
|
||||
destroyed_by_plt_stub
|
||||
else
|
||||
[| r11 |]
|
||||
|
||||
let destroyed_at_oper = function
|
||||
Iop(Icall_ind _ | Icall_imm _ | Iextcall { alloc = true; }) ->
|
||||
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), _))
|
||||
|
@ -325,10 +310,6 @@ let destroyed_at_oper = function
|
|||
| Iop(Ialloc _) -> destroyed_at_alloc
|
||||
| Iop(Iintop(Imulh | Icomp _) | Iintop_imm((Icomp _), _))
|
||||
-> [| rax |]
|
||||
| Iop (Iintop (Icheckbound _)) when Config.spacetime ->
|
||||
[| loc_spacetime_node_hole |]
|
||||
| Iop (Iintop_imm(Icheckbound _, _)) when Config.spacetime ->
|
||||
[| loc_spacetime_node_hole |]
|
||||
| Iswitch(_, _) -> [| rax; rdx |]
|
||||
| Itrywith _ -> [| r11 |]
|
||||
| _ ->
|
||||
|
@ -371,9 +352,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 _|Isextend32|Izextend32) -> true
|
||||
| Ispecific _ -> false
|
||||
| _ -> true
|
||||
|
|
|
@ -65,7 +65,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)
|
||||
|
|
|
@ -129,11 +129,11 @@ let is_immediate_natint n = n <= 0x7FFF_FFFFn && n >= -0x8000_0000n
|
|||
|
||||
class selector = object (self)
|
||||
|
||||
inherit Spacetime_profiling.instruction_selection as super
|
||||
inherit Selectgen.selector_generic as super
|
||||
|
||||
method! is_immediate op n =
|
||||
match op with
|
||||
| Iadd | Isub | Imul | Iand | Ior | Ixor | Icomp _ | Icheckbound _ ->
|
||||
| Iadd | Isub | Imul | Iand | Ior | Ixor | Icomp _ | Icheckbound ->
|
||||
is_immediate n
|
||||
| _ ->
|
||||
super#is_immediate op n
|
||||
|
@ -142,7 +142,7 @@ method is_immediate_test _cmp n = is_immediate n
|
|||
|
||||
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
|
||||
|
@ -151,7 +151,7 @@ method! is_simple_expr e =
|
|||
|
||||
method! effects_of e =
|
||||
match e with
|
||||
| Cop(Cextcall(fn, _, _, _, _), args, _)
|
||||
| Cop(Cextcall(fn, _, _, _), args, _)
|
||||
when List.mem fn inline_ops ->
|
||||
Selectgen.Effect_and_coeffect.join_list_map args self#effects_of
|
||||
| _ ->
|
||||
|
@ -180,9 +180,6 @@ method! select_store is_assign addr exp =
|
|||
(Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple [])
|
||||
| (Cconst_natint (n, _dbg)) when is_immediate_natint n ->
|
||||
(Ispecific(Istore_int(n, addr, is_assign)), Ctuple [])
|
||||
| (Cblockheader(n, _dbg))
|
||||
when is_immediate_natint n && not Config.spacetime ->
|
||||
(Ispecific(Istore_int(n, addr, is_assign)), Ctuple [])
|
||||
| _ ->
|
||||
super#select_store is_assign addr exp
|
||||
|
||||
|
@ -204,7 +201,7 @@ method! select_operation op args dbg =
|
|||
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], _dbg)] ->
|
||||
let (addr, arg) = self#select_addressing chunk loc in
|
||||
|
@ -224,12 +221,12 @@ method! select_operation op args dbg =
|
|||
| _ ->
|
||||
super#select_operation op args dbg
|
||||
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)
|
||||
(* Recognize sign extension *)
|
||||
| Casr ->
|
||||
|
|
|
@ -141,8 +141,6 @@ and shift_operation =
|
|||
| Ishiftlogicalright
|
||||
| Ishiftarithmeticright
|
||||
|
||||
let spacetime_node_hole_pointer_is_live_before _specific_op = false
|
||||
|
||||
(* Sizes, endianness *)
|
||||
|
||||
let big_endian = false
|
||||
|
|
|
@ -105,12 +105,8 @@ let emit_addressing addr r n =
|
|||
|
||||
(* Record live pointers at call points *)
|
||||
|
||||
let record_frame_label ?label live dbg =
|
||||
let lbl =
|
||||
match label with
|
||||
| None -> new_label()
|
||||
| Some label -> label
|
||||
in
|
||||
let record_frame_label live dbg =
|
||||
let lbl = new_label () in
|
||||
let live_offset = ref [] in
|
||||
Reg.Set.iter
|
||||
(function
|
||||
|
@ -126,8 +122,8 @@ let record_frame_label ?label live dbg =
|
|||
~live_offset:!live_offset dbg;
|
||||
lbl
|
||||
|
||||
let record_frame ?label live dbg =
|
||||
let lbl = record_frame_label ?label live dbg in `{emit_label lbl}:`
|
||||
let record_frame live dbg =
|
||||
let lbl = record_frame_label live dbg in `{emit_label lbl}:`
|
||||
|
||||
(* Record calls to the GC -- we've moved them out of the way *)
|
||||
|
||||
|
@ -152,10 +148,10 @@ type bound_error_call =
|
|||
|
||||
let bound_error_sites = ref ([] : bound_error_call list)
|
||||
|
||||
let bound_error_label ?label dbg =
|
||||
let bound_error_label dbg =
|
||||
if !Clflags.debug || !bound_error_sites = [] then begin
|
||||
let lbl_bound_error = new_label() in
|
||||
let lbl_frame = record_frame_label ?label Reg.Set.empty (Dbg_other dbg) in
|
||||
let lbl_frame = record_frame_label Reg.Set.empty (Dbg_other dbg) in
|
||||
bound_error_sites :=
|
||||
{ bd_lbl = lbl_bound_error;
|
||||
bd_frame_lbl = lbl_frame } :: !bound_error_sites;
|
||||
|
@ -539,25 +535,25 @@ let emit_instr i =
|
|||
end; 1
|
||||
| Lop(Iconst_symbol s) ->
|
||||
emit_load_symbol_addr i.res.(0) s
|
||||
| Lop(Icall_ind { label_after; }) ->
|
||||
| Lop(Icall_ind) ->
|
||||
if !arch >= ARMv5 then begin
|
||||
` blx {emit_reg i.arg.(0)}\n`;
|
||||
`{record_frame i.live (Dbg_other i.dbg) ~label:label_after}\n`; 1
|
||||
`{record_frame i.live (Dbg_other i.dbg)}\n`; 1
|
||||
end else begin
|
||||
` mov lr, pc\n`;
|
||||
` bx {emit_reg i.arg.(0)}\n`;
|
||||
`{record_frame i.live (Dbg_other i.dbg) ~label:label_after}\n`; 2
|
||||
`{record_frame i.live (Dbg_other i.dbg)}\n`; 2
|
||||
end
|
||||
| Lop(Icall_imm { func; label_after; }) ->
|
||||
| Lop(Icall_imm { func; }) ->
|
||||
` {emit_call func}\n`;
|
||||
`{record_frame i.live (Dbg_other i.dbg) ~label:label_after}\n`; 1
|
||||
| Lop(Itailcall_ind { label_after = _; }) ->
|
||||
`{record_frame i.live (Dbg_other i.dbg)}\n`; 1
|
||||
| Lop(Itailcall_ind) ->
|
||||
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 { func; label_after = _; }) ->
|
||||
| Lop(Itailcall_imm { func; }) ->
|
||||
if func = !function_name then begin
|
||||
` b {emit_label !tailrec_entry_point}\n`; 1
|
||||
end else begin
|
||||
|
@ -569,10 +565,10 @@ let emit_instr i =
|
|||
end
|
||||
| Lop(Iextcall { func; alloc = false; }) ->
|
||||
` {emit_call func}\n`; 1
|
||||
| Lop(Iextcall { func; alloc = true; label_after; }) ->
|
||||
| Lop(Iextcall { func; alloc = true; }) ->
|
||||
let ninstr = emit_load_symbol_addr (phys_reg 7 (* r7 *)) func in
|
||||
` {emit_call "caml_c_call"}\n`;
|
||||
`{record_frame i.live (Dbg_other i.dbg) ~label:label_after}\n`;
|
||||
`{record_frame i.live (Dbg_other i.dbg)}\n`;
|
||||
1 + ninstr
|
||||
| Lop(Istackoffset n) ->
|
||||
assert (n mod 8 = 0);
|
||||
|
@ -642,9 +638,9 @@ 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 { bytes = n; label_after_call_gc; dbginfo }) ->
|
||||
| Lop(Ialloc { bytes = n; dbginfo }) ->
|
||||
let lbl_frame =
|
||||
record_frame_label i.live (Dbg_alloc dbginfo) ?label:label_after_call_gc
|
||||
record_frame_label i.live (Dbg_alloc dbginfo)
|
||||
in
|
||||
if !fastcode_flag then begin
|
||||
let ninstr = decompose_intconst
|
||||
|
@ -682,12 +678,12 @@ let emit_instr i =
|
|||
| Lop(Iintop_imm(Icomp cmp, n)) ->
|
||||
` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`;
|
||||
1 + emit_set_condition cmp i.res.(0)
|
||||
| Lop(Iintop (Icheckbound { label_after_error; } )) ->
|
||||
let lbl = bound_error_label ?label:label_after_error i.dbg in
|
||||
| Lop(Iintop (Icheckbound)) ->
|
||||
let lbl = bound_error_label 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 { label_after_error; }, n)) ->
|
||||
let lbl = bound_error_label ?label:label_after_error i.dbg in
|
||||
| Lop(Iintop_imm(Icheckbound, n)) ->
|
||||
let lbl = bound_error_label i.dbg in
|
||||
` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`;
|
||||
` bls {emit_label lbl}\n`; 2
|
||||
| Lop(Ispecific(Ishiftcheckbound(shiftop, n))) ->
|
||||
|
|
|
@ -107,8 +107,6 @@ let phys_reg n =
|
|||
let stack_slot slot ty =
|
||||
Reg.at_location ty (Stack slot)
|
||||
|
||||
let loc_spacetime_node_hole = Reg.dummy (* Spacetime unsupported *)
|
||||
|
||||
(* Calling conventions *)
|
||||
|
||||
let loc_int last_int make_stack int ofs =
|
||||
|
@ -289,7 +287,7 @@ let destroyed_at_c_call =
|
|||
124;125;126;127;128;129;130;131]))
|
||||
|
||||
let destroyed_at_oper = function
|
||||
Iop(Icall_ind _ | Icall_imm _)
|
||||
Iop(Icall_ind | Icall_imm _)
|
||||
| Iop(Iextcall { alloc = true; _ }) ->
|
||||
all_phys_regs
|
||||
| Iop(Iextcall { alloc = false; _}) ->
|
||||
|
@ -335,9 +333,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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -104,7 +104,7 @@ method! regs_for tyv =
|
|||
|
||||
method! is_immediate op n =
|
||||
match op with
|
||||
| Iadd | Isub | Iand | Ior | Ixor | Icomp _ | Icheckbound _ ->
|
||||
| Iadd | Isub | Iand | Ior | Ixor | Icomp _ | Icheckbound ->
|
||||
Arch.is_immediate (Int32.of_int n)
|
||||
| _ ->
|
||||
super#is_immediate op n
|
||||
|
@ -114,25 +114,25 @@ method is_immediate_test _op 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, _)
|
||||
| Cop(Cextcall("caml_bswap16_direct", _, _, _), args, _)
|
||||
when !arch >= ARMv6T2 ->
|
||||
List.for_all self#is_simple_expr args
|
||||
| Cop(Cextcall("caml_int32_direct_bswap", _, _, _, _), args, _)
|
||||
| Cop(Cextcall("caml_int32_direct_bswap", _, _, _), args, _)
|
||||
when !arch >= ARMv6 ->
|
||||
List.for_all self#is_simple_expr args
|
||||
| e -> super#is_simple_expr e
|
||||
|
||||
method! effects_of e =
|
||||
match e with
|
||||
| Cop(Cextcall("sqrt", _, _, _, _), args, _) when !fpu >= VFPv2 ->
|
||||
| Cop(Cextcall("sqrt", _, _, _), args, _) when !fpu >= VFPv2 ->
|
||||
Selectgen.Effect_and_coeffect.join_list_map args self#effects_of
|
||||
| Cop(Cextcall("caml_bswap16_direct", _, _, _, _), args, _)
|
||||
| Cop(Cextcall("caml_bswap16_direct", _, _, _), args, _)
|
||||
when !arch >= ARMv6T2 ->
|
||||
Selectgen.Effect_and_coeffect.join_list_map args self#effects_of
|
||||
| Cop(Cextcall("caml_int32_direct_bswap",_ ,_ , _, _), args, _)
|
||||
| Cop(Cextcall("caml_int32_direct_bswap",_ ,_ , _), args, _)
|
||||
when !arch >= ARMv6 ->
|
||||
Selectgen.Effect_and_coeffect.join_list_map args self#effects_of
|
||||
| e -> super#effects_of e
|
||||
|
@ -187,8 +187,7 @@ method select_shift_arith op dbg arithop arithrevop args =
|
|||
end
|
||||
|
||||
method private iextcall func ty_res ty_args =
|
||||
Iextcall { func; ty_res; ty_args;
|
||||
alloc = false; label_after = Cmm.new_label (); }
|
||||
Iextcall { func; ty_res; ty_args; alloc = false; }
|
||||
|
||||
method! select_operation op args dbg =
|
||||
match (op, args) with
|
||||
|
@ -224,10 +223,10 @@ method! select_operation op args dbg =
|
|||
(* See above for fix up of return register *)
|
||||
(self#iextcall "__aeabi_idivmod" typ_int [], 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)
|
||||
| (Cextcall("caml_int32_direct_bswap", _, _, _), args)
|
||||
when !arch >= ARMv6 ->
|
||||
(Ispecific(Ibswap 32), args)
|
||||
(* Turn floating-point operations into runtime ABI calls for softfp *)
|
||||
|
@ -265,7 +264,7 @@ method private select_operation_softfp op args dbg =
|
|||
| CFnge -> Ceq, "__aeabi_dcmpge"
|
||||
in
|
||||
(Iintop_imm(Icomp(Iunsigned comp), 0),
|
||||
[Cop(Cextcall(func, typ_int, [XFloat;XFloat], false, None),
|
||||
[Cop(Cextcall(func, typ_int, [XFloat;XFloat], false),
|
||||
args, dbg)])
|
||||
(* Add coercions around loads and stores of 32-bit floats *)
|
||||
| (Cload (Single, mut), args) ->
|
||||
|
@ -273,7 +272,7 @@ method private select_operation_softfp op args dbg =
|
|||
[Cop(Cload (Word_int, mut), args, dbg)])
|
||||
| (Cstore (Single, init), [arg1; arg2]) ->
|
||||
let arg2' =
|
||||
Cop(Cextcall("__aeabi_d2f", typ_int, [XFloat], false, None),
|
||||
Cop(Cextcall("__aeabi_d2f", typ_int, [XFloat], false),
|
||||
[arg2], dbg) in
|
||||
self#select_operation (Cstore (Word_int, init)) [arg1; arg2'] dbg
|
||||
(* Other operations are regular *)
|
||||
|
@ -299,7 +298,7 @@ method private select_operation_vfpv3 op args dbg =
|
|||
| (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 dbg
|
||||
|
|
|
@ -42,15 +42,12 @@ type cmm_label = int
|
|||
(* Do not introduce a dependency to Cmm *)
|
||||
|
||||
type specific_operation =
|
||||
| Ifar_alloc of { bytes : int; label_after_call_gc : cmm_label option;
|
||||
dbginfo : Debuginfo.alloc_dbginfo }
|
||||
| Ifar_intop_checkbound of { label_after_error : cmm_label option; }
|
||||
| Ifar_intop_imm_checkbound of
|
||||
{ bound : int; label_after_error : cmm_label option; }
|
||||
| Ifar_alloc of { bytes : int; dbginfo : Debuginfo.alloc_dbginfo }
|
||||
| Ifar_intop_checkbound
|
||||
| Ifar_intop_imm_checkbound of { bound : int; }
|
||||
| Ishiftarith of arith_operation * int
|
||||
| Ishiftcheckbound of { shift : int; label_after_error : cmm_label option; }
|
||||
| Ifar_shiftcheckbound of
|
||||
{ shift : int; label_after_error : cmm_label option; }
|
||||
| Ishiftcheckbound of { shift : int; }
|
||||
| Ifar_shiftcheckbound of { shift : int; }
|
||||
| Imuladd (* multiply and add *)
|
||||
| Imulsub (* multiply and subtract *)
|
||||
| Inegmulf (* floating-point negate and multiply *)
|
||||
|
@ -66,12 +63,6 @@ and arith_operation =
|
|||
Ishiftadd
|
||||
| Ishiftsub
|
||||
|
||||
let spacetime_node_hole_pointer_is_live_before = function
|
||||
| Ifar_alloc _ | Ifar_intop_checkbound _ | Ifar_intop_imm_checkbound _
|
||||
| Ishiftarith _ | Ishiftcheckbound _ | Ifar_shiftcheckbound _ -> false
|
||||
| Imuladd | Imulsub | Inegmulf | Imuladdf | Inegmuladdf | Imulsubf
|
||||
| Inegmulsubf | Isqrtf | Ibswap _ | Imove32 -> false
|
||||
|
||||
(* Sizes, endianness *)
|
||||
|
||||
let big_endian = false
|
||||
|
@ -113,11 +104,11 @@ let print_addressing printreg addr ppf arg =
|
|||
|
||||
let print_specific_operation printreg op ppf arg =
|
||||
match op with
|
||||
| Ifar_alloc { bytes; label_after_call_gc = _; } ->
|
||||
| Ifar_alloc { bytes; } ->
|
||||
fprintf ppf "(far) alloc %i" bytes
|
||||
| Ifar_intop_checkbound _ ->
|
||||
| Ifar_intop_checkbound ->
|
||||
fprintf ppf "%a (far) check > %a" printreg arg.(0) printreg arg.(1)
|
||||
| Ifar_intop_imm_checkbound { bound; _ } ->
|
||||
| Ifar_intop_imm_checkbound { bound; } ->
|
||||
fprintf ppf "%a (far) check > %i" printreg arg.(0) bound
|
||||
| Ishiftarith(op, shift) ->
|
||||
let op_name = function
|
||||
|
@ -129,10 +120,10 @@ 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 { shift; _ } ->
|
||||
| Ishiftcheckbound { shift; } ->
|
||||
fprintf ppf "check %a >> %i > %a" printreg arg.(0) shift
|
||||
printreg arg.(1)
|
||||
| Ifar_shiftcheckbound { shift; _ } ->
|
||||
| Ifar_shiftcheckbound { shift; } ->
|
||||
fprintf ppf
|
||||
"(far) check %a >> %i > %a" printreg arg.(0) shift printreg arg.(1)
|
||||
| Imuladd ->
|
||||
|
|
|
@ -146,12 +146,8 @@ let emit_addressing addr r =
|
|||
|
||||
(* Record live pointers at call points *)
|
||||
|
||||
let record_frame_label ?label live dbg =
|
||||
let lbl =
|
||||
match label with
|
||||
| None -> new_label()
|
||||
| Some label -> label
|
||||
in
|
||||
let record_frame_label live dbg =
|
||||
let lbl = new_label () in
|
||||
let live_offset = ref [] in
|
||||
Reg.Set.iter
|
||||
(function
|
||||
|
@ -167,8 +163,8 @@ let record_frame_label ?label live dbg =
|
|||
~live_offset:!live_offset dbg;
|
||||
lbl
|
||||
|
||||
let record_frame ?label live dbg =
|
||||
let lbl = record_frame_label ?label live dbg in `{emit_label lbl}:`
|
||||
let record_frame live dbg =
|
||||
let lbl = record_frame_label live dbg in `{emit_label lbl}:`
|
||||
|
||||
(* Record calls to the GC -- we've moved them out of the way *)
|
||||
|
||||
|
@ -193,10 +189,10 @@ type bound_error_call =
|
|||
|
||||
let bound_error_sites = ref ([] : bound_error_call list)
|
||||
|
||||
let bound_error_label ?label dbg =
|
||||
let bound_error_label dbg =
|
||||
if !Clflags.debug || !bound_error_sites = [] then begin
|
||||
let lbl_bound_error = new_label() in
|
||||
let lbl_frame = record_frame_label ?label Reg.Set.empty (Dbg_other dbg) in
|
||||
let lbl_frame = record_frame_label Reg.Set.empty (Dbg_other dbg) in
|
||||
bound_error_sites :=
|
||||
{ bd_lbl = lbl_bound_error;
|
||||
bd_frame_lbl = lbl_frame } :: !bound_error_sites;
|
||||
|
@ -405,8 +401,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. *)
|
||||
|
@ -417,7 +413,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
|
||||
|
@ -463,8 +459,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
|
||||
|
@ -497,9 +493,9 @@ 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_ind) -> epilogue_size ()
|
||||
| Lop (Itailcall_imm { func; _ }) ->
|
||||
if func = !function_name then 1 else epilogue_size ()
|
||||
| Lop (Iextcall { alloc = false; }) -> 1
|
||||
|
@ -520,9 +516,9 @@ module BR = Branch_relaxation.Make (struct
|
|||
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
|
||||
|
@ -569,26 +565,26 @@ module BR = Branch_relaxation.Make (struct
|
|||
| Lambda.Raise_notrace -> 4
|
||||
end
|
||||
|
||||
let relax_allocation ~num_bytes ~label_after_call_gc ~dbginfo =
|
||||
Lop (Ispecific (Ifar_alloc { bytes = num_bytes; label_after_call_gc; dbginfo }))
|
||||
let relax_allocation ~num_bytes ~dbginfo =
|
||||
Lop (Ispecific (Ifar_alloc { bytes = num_bytes; dbginfo }))
|
||||
|
||||
let relax_intop_checkbound ~label_after_error =
|
||||
Lop (Ispecific (Ifar_intop_checkbound { label_after_error; }))
|
||||
let relax_intop_checkbound () =
|
||||
Lop (Ispecific (Ifar_intop_checkbound))
|
||||
|
||||
let relax_intop_imm_checkbound ~bound ~label_after_error =
|
||||
Lop (Ispecific (Ifar_intop_imm_checkbound { bound; label_after_error; }))
|
||||
let relax_intop_imm_checkbound ~bound =
|
||||
Lop (Ispecific (Ifar_intop_imm_checkbound { bound; }))
|
||||
|
||||
let relax_specific_op = function
|
||||
| Ishiftcheckbound { shift; label_after_error; } ->
|
||||
Lop (Ispecific (Ifar_shiftcheckbound { shift; label_after_error; }))
|
||||
| Ishiftcheckbound { shift; } ->
|
||||
Lop (Ispecific (Ifar_shiftcheckbound { shift; }))
|
||||
| _ -> assert false
|
||||
end)
|
||||
|
||||
(* Output the assembly code for allocation. *)
|
||||
|
||||
let assembly_code_for_allocation ~label_after_call_gc i ~n ~far ~dbginfo =
|
||||
let assembly_code_for_allocation i ~n ~far ~dbginfo =
|
||||
let lbl_frame =
|
||||
record_frame_label ?label:label_after_call_gc i.live (Dbg_alloc dbginfo)
|
||||
record_frame_label i.live (Dbg_alloc dbginfo)
|
||||
in
|
||||
if !fastcode_flag then begin
|
||||
let lbl_after_alloc = new_label() in
|
||||
|
@ -700,25 +696,25 @@ let emit_instr i =
|
|||
end
|
||||
| Lop(Iconst_symbol s) ->
|
||||
emit_load_symbol_addr i.res.(0) s
|
||||
| Lop(Icall_ind { label_after; }) ->
|
||||
| Lop(Icall_ind) ->
|
||||
` blr {emit_reg i.arg.(0)}\n`;
|
||||
`{record_frame i.live (Dbg_other i.dbg) ~label:label_after}\n`
|
||||
| Lop(Icall_imm { func; label_after; }) ->
|
||||
`{record_frame i.live (Dbg_other i.dbg)}\n`
|
||||
| Lop(Icall_imm { func; }) ->
|
||||
` bl {emit_symbol func}\n`;
|
||||
`{record_frame i.live (Dbg_other i.dbg) ~label:label_after}\n`
|
||||
| Lop(Itailcall_ind { label_after = _; }) ->
|
||||
`{record_frame i.live (Dbg_other i.dbg)}\n`
|
||||
| Lop(Itailcall_ind) ->
|
||||
output_epilogue (fun () -> ` br {emit_reg i.arg.(0)}\n`)
|
||||
| Lop(Itailcall_imm { func; label_after = _; }) ->
|
||||
| Lop(Itailcall_imm { func; }) ->
|
||||
if func = !function_name then
|
||||
` b {emit_label !tailrec_entry_point}\n`
|
||||
else
|
||||
output_epilogue (fun () -> ` b {emit_symbol func}\n`)
|
||||
| Lop(Iextcall { func; alloc = false; label_after = _; }) ->
|
||||
| Lop(Iextcall { func; alloc = false; }) ->
|
||||
` bl {emit_symbol func}\n`
|
||||
| Lop(Iextcall { func; alloc = true; label_after; }) ->
|
||||
| Lop(Iextcall { func; alloc = true; }) ->
|
||||
emit_load_symbol_addr reg_x8 func;
|
||||
` bl {emit_symbol "caml_c_call"}\n`;
|
||||
`{record_frame i.live (Dbg_other i.dbg) ~label:label_after}\n`
|
||||
`{record_frame i.live (Dbg_other i.dbg)}\n`
|
||||
| Lop(Istackoffset n) ->
|
||||
assert (n mod 16 = 0);
|
||||
emit_stack_adjustment (-n);
|
||||
|
@ -773,10 +769,10 @@ let emit_instr i =
|
|||
| Word_int | Word_val | Double | Double_u ->
|
||||
` str {emit_reg src}, {emit_addressing addr base}\n`
|
||||
end
|
||||
| Lop(Ialloc { bytes = n; label_after_call_gc; dbginfo }) ->
|
||||
assembly_code_for_allocation i ~n ~far:false ~label_after_call_gc ~dbginfo
|
||||
| Lop(Ispecific (Ifar_alloc { bytes = n; label_after_call_gc; dbginfo })) ->
|
||||
assembly_code_for_allocation i ~n ~far:true ~label_after_call_gc ~dbginfo
|
||||
| Lop(Ialloc { bytes = n; dbginfo }) ->
|
||||
assembly_code_for_allocation i ~n ~far:false ~dbginfo
|
||||
| Lop(Ispecific (Ifar_alloc { bytes = n; dbginfo })) ->
|
||||
assembly_code_for_allocation i ~n ~far:true ~dbginfo
|
||||
| Lop(Iintop_imm(Iadd, n)) ->
|
||||
emit_addimm i.res.(0) i.arg.(0) n
|
||||
| Lop(Iintop_imm(Isub, n)) ->
|
||||
|
@ -787,35 +783,35 @@ let emit_instr i =
|
|||
| Lop(Iintop_imm(Icomp cmp, n)) ->
|
||||
emit_cmpimm i.arg.(0) n;
|
||||
` cset {emit_reg i.res.(0)}, {emit_string (name_for_comparison cmp)}\n`
|
||||
| Lop(Iintop (Icheckbound { label_after_error; })) ->
|
||||
let lbl = bound_error_label i.dbg ?label:label_after_error in
|
||||
| Lop(Iintop (Icheckbound)) ->
|
||||
let lbl = bound_error_label i.dbg in
|
||||
` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
|
||||
` b.ls {emit_label lbl}\n`
|
||||
| Lop(Ispecific Ifar_intop_checkbound { label_after_error; }) ->
|
||||
let lbl = bound_error_label i.dbg ?label:label_after_error in
|
||||
| Lop(Ispecific Ifar_intop_checkbound) ->
|
||||
let lbl = bound_error_label i.dbg 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 { label_after_error; }, n)) ->
|
||||
let lbl = bound_error_label i.dbg ?label:label_after_error in
|
||||
| Lop(Iintop_imm(Icheckbound, n)) ->
|
||||
let lbl = bound_error_label i.dbg in
|
||||
emit_cmpimm i.arg.(0) n;
|
||||
` b.ls {emit_label lbl}\n`
|
||||
| Lop(Ispecific(
|
||||
Ifar_intop_imm_checkbound { bound; label_after_error; })) ->
|
||||
let lbl = bound_error_label i.dbg ?label:label_after_error in
|
||||
Ifar_intop_imm_checkbound { bound; })) ->
|
||||
let lbl = bound_error_label i.dbg 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; label_after_error; })) ->
|
||||
let lbl = bound_error_label i.dbg ?label:label_after_error in
|
||||
| Lop(Ispecific(Ishiftcheckbound { shift; })) ->
|
||||
let lbl = bound_error_label i.dbg 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; label_after_error; })) ->
|
||||
let lbl = bound_error_label i.dbg ?label:label_after_error in
|
||||
| Lop(Ispecific(Ifar_shiftcheckbound { shift; })) ->
|
||||
let lbl = bound_error_label i.dbg 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`;
|
||||
|
|
|
@ -105,8 +105,6 @@ let reg_d7 = phys_reg 107
|
|||
let stack_slot slot ty =
|
||||
Reg.at_location ty (Stack slot)
|
||||
|
||||
let loc_spacetime_node_hole = Reg.dummy (* Spacetime unsupported *)
|
||||
|
||||
(* Calling conventions *)
|
||||
|
||||
let loc_int last_int make_stack int ofs =
|
||||
|
@ -254,7 +252,7 @@ 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 { alloc = true; }) ->
|
||||
| Iop(Icall_ind | Icall_imm _) | Iop(Iextcall { alloc = true; }) ->
|
||||
all_phys_regs
|
||||
| Iop(Iextcall { alloc = false; }) ->
|
||||
destroyed_at_c_call
|
||||
|
@ -286,9 +284,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
|
||||
|
||||
|
|
|
@ -110,18 +110,18 @@ method! is_immediate op n =
|
|||
match op with
|
||||
| Iadd | Isub -> n <= 0xFFF_FFF && n >= -0xFFF_FFF
|
||||
| Iand | Ior | Ixor -> is_logical_immediate n
|
||||
| Icomp _ | Icheckbound _ -> is_immediate n
|
||||
| Icomp _ | Icheckbound -> is_immediate n
|
||||
| _ -> super#is_immediate op 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
|
||||
|
||||
method! effects_of e =
|
||||
match e with
|
||||
| Cop(Cextcall (fn, _, _, _, _), args, _) when List.mem fn inline_ops ->
|
||||
| Cop(Cextcall (fn, _, _, _), args, _) when List.mem fn inline_ops ->
|
||||
Selectgen.Effect_and_coeffect.join_list_map args self#effects_of
|
||||
| e -> super#effects_of e
|
||||
|
||||
|
@ -194,7 +194,7 @@ method! select_operation op args dbg =
|
|||
| Ccheckbound ->
|
||||
begin match args with
|
||||
| [Cop(Clsr, [arg1; Cconst_int (n, _)], _); arg2] when n > 0 && n < 64 ->
|
||||
(Ispecific(Ishiftcheckbound { shift = n; label_after_error = None; }),
|
||||
(Ispecific(Ishiftcheckbound { shift = n; }),
|
||||
[arg1; arg2])
|
||||
| _ ->
|
||||
super#select_operation op args dbg
|
||||
|
@ -223,15 +223,15 @@ method! select_operation op args dbg =
|
|||
super#select_operation op args dbg
|
||||
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 *)
|
||||
| _ ->
|
||||
|
|
|
@ -267,9 +267,6 @@ let make_startup_file ~ppf_dump units_list ~crc_interfaces =
|
|||
compile_phrase(Cmm_helpers.code_segment_table("_startup" :: name_list));
|
||||
let all_names = "_startup" :: "_system" :: name_list in
|
||||
compile_phrase (Cmm_helpers.frame_table all_names);
|
||||
if Config.spacetime then begin
|
||||
compile_phrase (Cmm_helpers.spacetime_shapes all_names);
|
||||
end;
|
||||
if !Clflags.output_complete_object then
|
||||
force_linking_of_startup ~ppf_dump;
|
||||
Emit.end_assembly ()
|
||||
|
@ -331,14 +328,9 @@ let call_linker file_list startup_file output_name =
|
|||
and main_obj_runtime = !Clflags.output_complete_object
|
||||
in
|
||||
let files = startup_file :: (List.rev file_list) in
|
||||
let libunwind =
|
||||
if not Config.spacetime then []
|
||||
else if not Config.libunwind_available then []
|
||||
else String.split_on_char ' ' Config.libunwind_link_flags
|
||||
in
|
||||
let files, c_lib =
|
||||
if (not !Clflags.output_c_object) || main_dll || main_obj_runtime then
|
||||
files @ (List.rev !Clflags.ccobjs) @ runtime_lib () @ libunwind,
|
||||
files @ (List.rev !Clflags.ccobjs) @ runtime_lib (),
|
||||
(if !Clflags.nopervasives || (main_obj_runtime && not main_dll)
|
||||
then "" else Config.native_c_libraries)
|
||||
else
|
||||
|
|
|
@ -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,16 +86,15 @@ 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 { bytes = num_bytes; label_after_call_gc; dbginfo }) ->
|
||||
instr.desc <- T.relax_allocation ~num_bytes
|
||||
~dbginfo ~label_after_call_gc;
|
||||
| Lop (Ialloc { bytes = num_bytes; dbginfo }) ->
|
||||
instr.desc <- T.relax_allocation ~num_bytes ~dbginfo;
|
||||
fixup true (pc + T.instr_size instr.desc) instr.next
|
||||
| Lop (Iintop (Icheckbound { label_after_error; })) ->
|
||||
instr.desc <- T.relax_intop_checkbound ~label_after_error;
|
||||
| Lop (Iintop (Icheckbound)) ->
|
||||
instr.desc <- T.relax_intop_checkbound ();
|
||||
fixup true (pc + T.instr_size instr.desc) instr.next
|
||||
| Lop (Iintop_imm (Icheckbound { label_after_error; }, bound)) ->
|
||||
| Lop (Iintop_imm (Icheckbound, bound)) ->
|
||||
instr.desc
|
||||
<- T.relax_intop_imm_checkbound ~bound ~label_after_error;
|
||||
<- 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;
|
||||
|
|
|
@ -62,15 +62,13 @@ module type S = sig
|
|||
the size of out-of-line code (cf. branch_relaxation.mli). *)
|
||||
val relax_allocation
|
||||
: num_bytes:int
|
||||
-> label_after_call_gc:Cmm.label option
|
||||
-> dbginfo:Debuginfo.alloc_dbginfo
|
||||
-> Linear.instruction_desc
|
||||
val relax_intop_checkbound
|
||||
: label_after_error:Cmm.label option
|
||||
: unit
|
||||
-> Linear.instruction_desc
|
||||
val relax_intop_imm_checkbound
|
||||
: bound:int
|
||||
-> label_after_error:Cmm.label option
|
||||
-> Linear.instruction_desc
|
||||
val relax_specific_op : Arch.specific_operation -> Linear.instruction_desc
|
||||
end
|
||||
|
|
|
@ -150,9 +150,7 @@ type memory_chunk =
|
|||
|
||||
and operation =
|
||||
Capply of machtype
|
||||
| Cextcall of string * machtype * exttype list * bool * label option
|
||||
(** If specified, the given label will be placed immediately after the
|
||||
call (at the same place as any frame descriptor would reference). *)
|
||||
| Cextcall of string * machtype * exttype list * bool
|
||||
| Cload of memory_chunk * Asttypes.mutable_flag
|
||||
| Calloc
|
||||
| Cstore of memory_chunk * Lambda.initialization_or_assignment
|
||||
|
@ -173,7 +171,6 @@ type expression =
|
|||
| Cconst_natint of nativeint * Debuginfo.t
|
||||
| Cconst_float of float * Debuginfo.t
|
||||
| Cconst_symbol of string * Debuginfo.t
|
||||
| Cblockheader of nativeint * Debuginfo.t
|
||||
| Cvar of Backend_var.t
|
||||
| Clet of Backend_var.With_provenance.t * expression * expression
|
||||
| Clet_mut of Backend_var.With_provenance.t * machtype
|
||||
|
@ -261,7 +258,6 @@ let iter_shallow_tail f = function
|
|||
| Cconst_natint _
|
||||
| Cconst_float _
|
||||
| Cconst_symbol _
|
||||
| Cblockheader _
|
||||
| Cvar _
|
||||
| Cassign _
|
||||
| Ctuple _
|
||||
|
@ -298,7 +294,6 @@ let rec map_tail f = function
|
|||
| Cconst_natint _
|
||||
| Cconst_float _
|
||||
| Cconst_symbol _
|
||||
| Cblockheader _
|
||||
| Cvar _
|
||||
| Cassign _
|
||||
| Ctuple _
|
||||
|
@ -335,7 +330,6 @@ let map_shallow f = function
|
|||
| Cconst_natint _
|
||||
| Cconst_float _
|
||||
| Cconst_symbol _
|
||||
| Cblockheader _
|
||||
| Cvar _
|
||||
as c ->
|
||||
c
|
||||
|
|
|
@ -140,7 +140,7 @@ type memory_chunk =
|
|||
|
||||
and operation =
|
||||
Capply of machtype
|
||||
| Cextcall of string * machtype * exttype list * bool * label option
|
||||
| Cextcall of string * machtype * exttype list * bool
|
||||
(** The [machtype] is the machine type of the result.
|
||||
The [exttype list] describes the unboxing types of the arguments.
|
||||
An empty list means "all arguments are machine words [XInt]". *)
|
||||
|
@ -170,7 +170,6 @@ and expression =
|
|||
| Cconst_natint of nativeint * Debuginfo.t
|
||||
| Cconst_float of float * Debuginfo.t
|
||||
| Cconst_symbol of string * Debuginfo.t
|
||||
| Cblockheader of nativeint * Debuginfo.t
|
||||
| Cvar of Backend_var.t
|
||||
| Clet of Backend_var.With_provenance.t * expression * expression
|
||||
| Clet_mut of Backend_var.With_provenance.t * machtype
|
||||
|
|
|
@ -24,8 +24,7 @@ open Arch
|
|||
|
||||
let bind name arg fn =
|
||||
match arg with
|
||||
Cvar _ | Cconst_int _ | Cconst_natint _ | Cconst_symbol _
|
||||
| Cblockheader _ -> fn arg
|
||||
Cvar _ | Cconst_int _ | Cconst_natint _ | Cconst_symbol _ -> fn arg
|
||||
| _ -> let id = V.create_local name in Clet(VP.create id, arg, fn (Cvar id))
|
||||
|
||||
let bind_load name arg fn =
|
||||
|
@ -35,8 +34,7 @@ let bind_load name arg fn =
|
|||
|
||||
let bind_nonvar name arg fn =
|
||||
match arg with
|
||||
Cconst_int _ | Cconst_natint _ | Cconst_symbol _
|
||||
| Cblockheader _ -> fn arg
|
||||
Cconst_int _ | Cconst_natint _ | Cconst_symbol _ -> fn arg
|
||||
| _ -> let id = V.create_local name in Clet(VP.create id, arg, fn (Cvar id))
|
||||
|
||||
let caml_black = Nativeint.shift_left (Nativeint.of_int 3) 8
|
||||
|
@ -82,15 +80,15 @@ let closure_info ~arity ~startenv =
|
|||
(add (shift_left (of_int startenv) 1)
|
||||
1n))
|
||||
|
||||
let alloc_float_header dbg = Cblockheader (float_header, dbg)
|
||||
let alloc_floatarray_header len dbg = Cblockheader (floatarray_header len, dbg)
|
||||
let alloc_closure_header sz dbg = Cblockheader (white_closure_header sz, dbg)
|
||||
let alloc_infix_header ofs dbg = Cblockheader (infix_header ofs, dbg)
|
||||
let alloc_float_header dbg = Cconst_natint (float_header, dbg)
|
||||
let alloc_floatarray_header len dbg = Cconst_natint (floatarray_header len, dbg)
|
||||
let alloc_closure_header sz dbg = Cconst_natint (white_closure_header sz, dbg)
|
||||
let alloc_infix_header ofs dbg = Cconst_natint (infix_header ofs, dbg)
|
||||
let alloc_closure_info ~arity ~startenv dbg =
|
||||
Cblockheader (closure_info ~arity ~startenv, dbg)
|
||||
let alloc_boxedint32_header dbg = Cblockheader (boxedint32_header, dbg)
|
||||
let alloc_boxedint64_header dbg = Cblockheader (boxedint64_header, dbg)
|
||||
let alloc_boxedintnat_header dbg = Cblockheader (boxedintnat_header, dbg)
|
||||
Cconst_natint (closure_info ~arity ~startenv, dbg)
|
||||
let alloc_boxedint32_header dbg = Cconst_natint (boxedint32_header, dbg)
|
||||
let alloc_boxedint64_header dbg = Cconst_natint (boxedint64_header, dbg)
|
||||
let alloc_boxedintnat_header dbg = Cconst_natint (boxedintnat_header, dbg)
|
||||
|
||||
(* Integers *)
|
||||
|
||||
|
@ -563,7 +561,7 @@ let box_float dbg c = Cop(Calloc, [alloc_float_header dbg; c], dbg)
|
|||
let unbox_float dbg =
|
||||
map_tail
|
||||
(function
|
||||
| Cop(Calloc, [Cblockheader (hdr, _); c], _)
|
||||
| Cop(Calloc, [Cconst_natint (hdr, _); c], _)
|
||||
when Nativeint.equal hdr float_header ->
|
||||
c
|
||||
| Cconst_symbol (s, _dbg) as cmm ->
|
||||
|
@ -613,8 +611,8 @@ let rec remove_unit = function
|
|||
Clet(id, c1, remove_unit c2)
|
||||
| Cop(Capply _mty, args, dbg) ->
|
||||
Cop(Capply typ_void, args, dbg)
|
||||
| Cop(Cextcall(proc, _ty_res, ty_args, alloc, label_after), args, dbg) ->
|
||||
Cop(Cextcall(proc, typ_void, ty_args, alloc, label_after), args, dbg)
|
||||
| Cop(Cextcall(proc, _ty_res, ty_args, alloc), args, dbg) ->
|
||||
Cop(Cextcall(proc, typ_void, ty_args, alloc), args, dbg)
|
||||
| Cexit (_,_) as c -> c
|
||||
| Ctuple [] as c -> c
|
||||
| c -> Csequence(c, Ctuple [])
|
||||
|
@ -736,10 +734,10 @@ let float_array_ref arr ofs dbg =
|
|||
box_float dbg (unboxed_float_array_ref arr ofs dbg)
|
||||
|
||||
let addr_array_set arr ofs newval dbg =
|
||||
Cop(Cextcall("caml_modify", typ_void, [], false, None),
|
||||
Cop(Cextcall("caml_modify", typ_void, [], false),
|
||||
[array_indexing log2_size_addr arr ofs dbg; newval], dbg)
|
||||
let addr_array_initialize arr ofs newval dbg =
|
||||
Cop(Cextcall("caml_initialize", typ_void, [], false, None),
|
||||
Cop(Cextcall("caml_initialize", typ_void, [], false),
|
||||
[array_indexing log2_size_addr arr ofs dbg; newval], dbg)
|
||||
let int_array_set arr ofs newval dbg =
|
||||
Cop(Cstore (Word_int, Lambda.Assignment),
|
||||
|
@ -775,7 +773,7 @@ let bigstring_length ba dbg =
|
|||
|
||||
let lookup_tag obj tag dbg =
|
||||
bind "tag" tag (fun tag ->
|
||||
Cop(Cextcall("caml_get_public_method", typ_val, [], false, None),
|
||||
Cop(Cextcall("caml_get_public_method", typ_val, [], false),
|
||||
[obj; tag],
|
||||
dbg))
|
||||
|
||||
|
@ -797,7 +795,7 @@ let call_cached_method obj tag cache pos args dbg =
|
|||
|
||||
let make_alloc_generic set_fn dbg tag wordsize args =
|
||||
if wordsize <= Config.max_young_wosize then
|
||||
Cop(Calloc, Cblockheader(block_header tag wordsize, dbg) :: args, dbg)
|
||||
Cop(Calloc, Cconst_natint(block_header tag wordsize, dbg) :: args, dbg)
|
||||
else begin
|
||||
let id = V.create_local "*alloc*" in
|
||||
let rec fill_fields idx = function
|
||||
|
@ -805,14 +803,14 @@ let make_alloc_generic set_fn dbg tag wordsize args =
|
|||
| e1::el -> Csequence(set_fn (Cvar id) (Cconst_int (idx, dbg)) e1 dbg,
|
||||
fill_fields (idx + 2) el) in
|
||||
Clet(VP.create id,
|
||||
Cop(Cextcall("caml_alloc", typ_val, [], true, None),
|
||||
Cop(Cextcall("caml_alloc", typ_val, [], true),
|
||||
[Cconst_int (wordsize, dbg); Cconst_int (tag, dbg)], dbg),
|
||||
fill_fields 1 args)
|
||||
end
|
||||
|
||||
let make_alloc dbg tag args =
|
||||
let addr_array_init arr ofs newval dbg =
|
||||
Cop(Cextcall("caml_initialize", typ_void, [], false, None),
|
||||
Cop(Cextcall("caml_initialize", typ_void, [], false),
|
||||
[array_indexing log2_size_addr arr ofs dbg; newval], dbg)
|
||||
in
|
||||
make_alloc_generic addr_array_init dbg tag (List.length args) args
|
||||
|
@ -1032,13 +1030,13 @@ let split_int64_for_32bit_target arg dbg =
|
|||
|
||||
let alloc_matches_boxed_int bi ~hdr ~ops =
|
||||
match (bi : Primitive.boxed_integer), hdr, ops with
|
||||
| Pnativeint, Cblockheader (hdr, _dbg), Cconst_symbol (sym, _) ->
|
||||
| Pnativeint, Cconst_natint (hdr, _dbg), Cconst_symbol (sym, _) ->
|
||||
Nativeint.equal hdr boxedintnat_header
|
||||
&& String.equal sym caml_nativeint_ops
|
||||
| Pint32, Cblockheader (hdr, _dbg), Cconst_symbol (sym, _) ->
|
||||
| Pint32, Cconst_natint (hdr, _dbg), Cconst_symbol (sym, _) ->
|
||||
Nativeint.equal hdr boxedint32_header
|
||||
&& String.equal sym caml_int32_ops
|
||||
| Pint64, Cblockheader (hdr, _dbg), Cconst_symbol (sym, _) ->
|
||||
| Pint64, Cconst_natint (hdr, _dbg), Cconst_symbol (sym, _) ->
|
||||
Nativeint.equal hdr boxedint64_header
|
||||
&& String.equal sym caml_int64_ops
|
||||
| (Pnativeint | Pint32 | Pint64), _, _ -> false
|
||||
|
@ -2155,12 +2153,12 @@ let bbswap bi arg dbg =
|
|||
| Pint64 -> "int64", XInt64
|
||||
in
|
||||
Cop(Cextcall(Printf.sprintf "caml_%s_direct_bswap" prim,
|
||||
typ_int, [tyarg], false, None),
|
||||
typ_int, [tyarg], false),
|
||||
[arg],
|
||||
dbg)
|
||||
|
||||
let bswap16 arg dbg =
|
||||
(Cop(Cextcall("caml_bswap16_direct", typ_int, [], false, None),
|
||||
(Cop(Cextcall("caml_bswap16_direct", typ_int, [], false),
|
||||
[arg],
|
||||
dbg))
|
||||
|
||||
|
@ -2186,12 +2184,12 @@ let setfield n ptr init arg1 arg2 dbg =
|
|||
match assignment_kind ptr init with
|
||||
| Caml_modify ->
|
||||
return_unit dbg
|
||||
(Cop(Cextcall("caml_modify", typ_void, [], false, None),
|
||||
(Cop(Cextcall("caml_modify", typ_void, [], false),
|
||||
[field_address arg1 n dbg; arg2],
|
||||
dbg))
|
||||
| Caml_initialize ->
|
||||
return_unit dbg
|
||||
(Cop(Cextcall("caml_initialize", typ_void, [], false, None),
|
||||
(Cop(Cextcall("caml_initialize", typ_void, [], false),
|
||||
[field_address arg1 n dbg; arg2],
|
||||
dbg))
|
||||
| Simple ->
|
||||
|
@ -2628,18 +2626,6 @@ let frame_table namelist =
|
|||
List.map mksym namelist
|
||||
@ [cint_zero])
|
||||
|
||||
(* Generate the master table of Spacetime shapes *)
|
||||
|
||||
let spacetime_shapes namelist =
|
||||
let mksym name =
|
||||
Csymbol_address (
|
||||
Compilenv.make_symbol ~unitname:name (Some "spacetime_shapes"))
|
||||
in
|
||||
Cdata(Cglobal_symbol "caml_spacetime_shapes" ::
|
||||
Cdefine_symbol "caml_spacetime_shapes" ::
|
||||
List.map mksym namelist
|
||||
@ [cint_zero])
|
||||
|
||||
(* Generate the table of module data and code segments *)
|
||||
|
||||
let segment_table namelist symbol begname endname =
|
||||
|
|
|
@ -600,10 +600,6 @@ val globals_map:
|
|||
from the given compilation units *)
|
||||
val frame_table: string list -> phrase
|
||||
|
||||
(** Generate the caml_spacetime_shapes table, referencing the spacetime shapes
|
||||
from the given compilation units *)
|
||||
val spacetime_shapes: string list -> phrase
|
||||
|
||||
(** Generate the tables for data and code positions respectively of the given
|
||||
compilation units *)
|
||||
val data_segment_table: string list -> phrase
|
||||
|
|
|
@ -314,10 +314,10 @@ let is_unboxed_number_cmm ~strict cmm =
|
|||
r := join_unboxed_number_kind ~strict !r k
|
||||
in
|
||||
let rec aux = function
|
||||
| Cop(Calloc, [Cblockheader (hdr, _); _], dbg)
|
||||
| Cop(Calloc, [Cconst_natint (hdr, _); _], dbg)
|
||||
when Nativeint.equal hdr float_header ->
|
||||
notify (Boxed (Boxed_float dbg, false))
|
||||
| Cop(Calloc, [Cblockheader (hdr, _); Cconst_symbol (ops, _); _], dbg) ->
|
||||
| Cop(Calloc, [Cconst_natint (hdr, _); Cconst_symbol (ops, _); _], dbg) ->
|
||||
if Nativeint.equal hdr boxedintnat_header
|
||||
&& String.equal ops caml_nativeint_ops
|
||||
then
|
||||
|
@ -729,7 +729,7 @@ and transl_catch env nfail ids body handler dbg =
|
|||
and transl_make_array dbg env kind args =
|
||||
match kind with
|
||||
| Pgenarray ->
|
||||
Cop(Cextcall("caml_make_array", typ_val, [], true, None),
|
||||
Cop(Cextcall("caml_make_array", typ_val, [], true),
|
||||
[make_alloc dbg 0 (List.map (transl env) args)], dbg)
|
||||
| Paddrarray | Pintarray ->
|
||||
make_alloc dbg 0 (List.map (transl env) args)
|
||||
|
@ -779,7 +779,7 @@ and transl_ccall env prim args dbg =
|
|||
let typ_args, args = transl_args prim.prim_native_repr_args args in
|
||||
wrap_result
|
||||
(Cop(Cextcall(Primitive.native_name prim,
|
||||
typ_res, typ_args, prim.prim_alloc, None), args, dbg))
|
||||
typ_res, typ_args, prim.prim_alloc), args, dbg))
|
||||
|
||||
and transl_prim_1 env p arg dbg =
|
||||
match p with
|
||||
|
@ -1319,7 +1319,7 @@ and transl_letrec env bindings cont =
|
|||
bindings
|
||||
in
|
||||
let op_alloc prim args =
|
||||
Cop(Cextcall(prim, typ_val, [], true, None), args, dbg) in
|
||||
Cop(Cextcall(prim, typ_val, [], true), args, dbg) in
|
||||
let rec init_blocks = function
|
||||
| [] -> fill_nonrec bsz
|
||||
| (id, _exp, RHS_block sz) :: rem ->
|
||||
|
@ -1345,7 +1345,7 @@ and transl_letrec env bindings cont =
|
|||
| [] -> cont
|
||||
| (id, exp, (RHS_block _ | RHS_infix _ | RHS_floatblock _)) :: rem ->
|
||||
let op =
|
||||
Cop(Cextcall("caml_update_dummy", typ_void, [], false, None),
|
||||
Cop(Cextcall("caml_update_dummy", typ_void, [], false),
|
||||
[Cvar (VP.var id); transl env exp], dbg) in
|
||||
Csequence(op, fill_blocks rem)
|
||||
| (_id, _exp, RHS_nonrec) :: rem ->
|
||||
|
|
|
@ -59,12 +59,11 @@ let rec combine i allocstate =
|
|||
else instr_cons_debug (Iop(Iintop_imm(Iadd, offset))) i.res
|
||||
i.res i.dbg next
|
||||
in
|
||||
(instr_cons_debug (Iop(Ialloc {bytes = totalsz; spacetime_index = 0;
|
||||
dbginfo; label_after_call_gc = None; }))
|
||||
(instr_cons_debug (Iop(Ialloc {bytes = totalsz; dbginfo; }))
|
||||
i.arg i.res i.dbg next, allocstate)
|
||||
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,
|
||||
allocstate)
|
||||
|
@ -99,5 +98,4 @@ and combine_restart i =
|
|||
let (newi, _) = combine i No_alloc in newi
|
||||
|
||||
let fundecl f =
|
||||
if Config.spacetime then f
|
||||
else {f with fun_body = combine_restart f.fun_body}
|
||||
{f with fun_body = combine_restart f.fun_body}
|
||||
|
|
|
@ -37,28 +37,22 @@ let append a b =
|
|||
| _ -> append a b
|
||||
|
||||
let rec deadcode i =
|
||||
let arg =
|
||||
if Config.spacetime
|
||||
&& Mach.spacetime_node_hole_pointer_is_live_before i
|
||||
then Array.append i.arg [| Proc.loc_spacetime_node_hole |]
|
||||
else i.arg
|
||||
in
|
||||
match i.desc with
|
||||
| Iend | Ireturn | Iop(Itailcall_ind _) | Iop(Itailcall_imm _) | Iraise _ ->
|
||||
let regs = Reg.add_set_array i.live arg in
|
||||
| Iend | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) | Iraise _ ->
|
||||
let regs = Reg.add_set_array i.live i.arg in
|
||||
{ i; regs; exits = Int.Set.empty; }
|
||||
| Iop op ->
|
||||
let s = deadcode i.next in
|
||||
if Proc.op_is_pure op (* no side effects *)
|
||||
&& Reg.disjoint_set_array s.regs i.res (* results are not used after *)
|
||||
&& not (Proc.regs_are_volatile arg) (* no stack-like hard reg *)
|
||||
&& not (Proc.regs_are_volatile i.arg) (* no stack-like hard reg *)
|
||||
&& not (Proc.regs_are_volatile i.res) (* is involved *)
|
||||
then begin
|
||||
assert (Array.length i.res > 0); (* sanity check *)
|
||||
s
|
||||
end else begin
|
||||
{ i = {i with next = s.i};
|
||||
regs = Reg.add_set_array i.live arg;
|
||||
regs = Reg.add_set_array i.live i.arg;
|
||||
exits = s.exits;
|
||||
}
|
||||
end
|
||||
|
@ -67,7 +61,7 @@ let rec deadcode i =
|
|||
let ifnot' = deadcode ifnot in
|
||||
let s = deadcode i.next in
|
||||
{ i = {i with desc = Iifthenelse(test, ifso'.i, ifnot'.i); next = s.i};
|
||||
regs = Reg.add_set_array i.live arg;
|
||||
regs = Reg.add_set_array i.live i.arg;
|
||||
exits = Int.Set.union s.exits
|
||||
(Int.Set.union ifso'.exits ifnot'.exits);
|
||||
}
|
||||
|
@ -76,7 +70,7 @@ let rec deadcode i =
|
|||
let cases' = Array.map (fun c -> c.i) dc in
|
||||
let s = deadcode i.next in
|
||||
{ i = {i with desc = Iswitch(index, cases'); next = s.i};
|
||||
regs = Reg.add_set_array i.live arg;
|
||||
regs = Reg.add_set_array i.live i.arg;
|
||||
exits = Array.fold_left
|
||||
(fun acc c -> Int.Set.union acc c.exits) s.exits dc;
|
||||
}
|
||||
|
|
|
@ -95,7 +95,7 @@ let rec available_regs (instr : M.instruction)
|
|||
match instr.desc with
|
||||
| Iend -> None, ok avail_before
|
||||
| Ireturn -> None, unreachable
|
||||
| Iop (Itailcall_ind _) | Iop (Itailcall_imm _) ->
|
||||
| Iop (Itailcall_ind) | Iop (Itailcall_imm _) ->
|
||||
Some (ok Reg_with_debug_info.Set.empty), unreachable
|
||||
| Iop (Iname_for_debugger { ident; which_parameter; provenance;
|
||||
is_assignment; }) ->
|
||||
|
@ -197,7 +197,7 @@ let rec available_regs (instr : M.instruction)
|
|||
[Available_ranges.Make_ranges.end_pos_offset]. *)
|
||||
let made_unavailable_2 =
|
||||
match op with
|
||||
| Icall_ind _ | Icall_imm _ | Ialloc _ ->
|
||||
| Icall_ind | Icall_imm _ | Ialloc _ ->
|
||||
RD.Set.filter (fun reg ->
|
||||
let holds_immediate = RD.holds_non_pointer reg in
|
||||
let on_stack = RD.assigned_to_stack reg in
|
||||
|
|
|
@ -185,7 +185,7 @@ let emit_frames a =
|
|||
| Dbg_other d | Dbg_raise d ->
|
||||
if Debuginfo.is_none d then 0 else 1
|
||||
| Dbg_alloc dbgs ->
|
||||
if !Clflags.debug && not Config.spacetime &&
|
||||
if !Clflags.debug &&
|
||||
List.exists (fun d ->
|
||||
not (Debuginfo.is_none d.Debuginfo.alloc_dbg)) dbgs
|
||||
then 3 else 2
|
||||
|
|
|
@ -52,8 +52,6 @@ type specific_operation =
|
|||
and float_operation =
|
||||
Ifloatadd | Ifloatsub | Ifloatsubrev | Ifloatmul | Ifloatdiv | Ifloatdivrev
|
||||
|
||||
let spacetime_node_hole_pointer_is_live_before _specific_op = false
|
||||
|
||||
(* Sizes, endianness *)
|
||||
|
||||
let big_endian = false
|
||||
|
|
|
@ -200,12 +200,8 @@ let addressing addr typ i n =
|
|||
|
||||
(* Record live pointers at call points *)
|
||||
|
||||
let record_frame_label ?label live dbg =
|
||||
let lbl =
|
||||
match label with
|
||||
| None -> new_label()
|
||||
| Some label -> label
|
||||
in
|
||||
let record_frame_label live dbg =
|
||||
let lbl = new_label () in
|
||||
let live_offset = ref [] in
|
||||
Reg.Set.iter
|
||||
(function
|
||||
|
@ -221,8 +217,8 @@ let record_frame_label ?label live dbg =
|
|||
~live_offset:!live_offset dbg;
|
||||
lbl
|
||||
|
||||
let record_frame ?label live dbg =
|
||||
let lbl = record_frame_label ?label live dbg in
|
||||
let record_frame live dbg =
|
||||
let lbl = record_frame_label live dbg in
|
||||
def_label lbl
|
||||
|
||||
(* Record calls to the GC -- we've moved them out of the way *)
|
||||
|
@ -251,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 ?label dbg =
|
||||
let bound_error_label dbg =
|
||||
if !Clflags.debug then begin
|
||||
let lbl_bound_error = new_label() in
|
||||
let lbl_frame = record_frame_label ?label Reg.Set.empty (Dbg_other dbg) in
|
||||
let lbl_frame = record_frame_label Reg.Set.empty (Dbg_other dbg) in
|
||||
bound_error_sites :=
|
||||
{ bd_lbl = lbl_bound_error; bd_frame = lbl_frame } :: !bound_error_sites;
|
||||
lbl_bound_error
|
||||
|
@ -538,18 +534,16 @@ let emit_instr fallthrough i =
|
|||
| Lop(Iconst_symbol s) ->
|
||||
add_used_symbol s;
|
||||
I.mov (immsym s) (reg i.res.(0))
|
||||
| Lop(Icall_ind { label_after; }) ->
|
||||
| Lop(Icall_ind) ->
|
||||
I.call (reg i.arg.(0));
|
||||
record_frame i.live (Dbg_other i.dbg) ~label:label_after
|
||||
| Lop(Icall_imm { func; label_after; }) ->
|
||||
record_frame i.live (Dbg_other i.dbg)
|
||||
| Lop(Icall_imm { func; }) ->
|
||||
add_used_symbol func;
|
||||
emit_call func;
|
||||
record_frame i.live (Dbg_other i.dbg) ~label:label_after
|
||||
| Lop(Itailcall_ind { label_after = _; }) ->
|
||||
output_epilogue begin fun () ->
|
||||
I.jmp (reg i.arg.(0))
|
||||
end
|
||||
| Lop(Itailcall_imm { func; label_after = _; }) ->
|
||||
record_frame i.live (Dbg_other i.dbg)
|
||||
| Lop(Itailcall_ind) ->
|
||||
output_epilogue (fun () -> I.jmp (reg i.arg.(0)))
|
||||
| Lop(Itailcall_imm { func; }) ->
|
||||
if func = !function_name then
|
||||
I.jmp (label !tailrec_entry_point)
|
||||
else begin
|
||||
|
@ -558,12 +552,12 @@ let emit_instr fallthrough i =
|
|||
I.jmp (immsym func)
|
||||
end
|
||||
end
|
||||
| Lop(Iextcall { func; alloc; label_after; }) ->
|
||||
| Lop(Iextcall { func; alloc; }) ->
|
||||
add_used_symbol func;
|
||||
if alloc then begin
|
||||
I.mov (immsym func) eax;
|
||||
emit_call "caml_c_call";
|
||||
record_frame i.live (Dbg_other i.dbg) ~label:label_after
|
||||
record_frame i.live (Dbg_other i.dbg)
|
||||
end else begin
|
||||
emit_call func
|
||||
end
|
||||
|
@ -614,7 +608,7 @@ let emit_instr fallthrough i =
|
|||
I.fstp (addressing addr REAL8 i 1)
|
||||
end
|
||||
end
|
||||
| Lop(Ialloc { bytes = n; label_after_call_gc; dbginfo }) ->
|
||||
| Lop(Ialloc { bytes = n; dbginfo }) ->
|
||||
if !fastcode_flag then begin
|
||||
load_domain_state ebx;
|
||||
I.mov (domain_field Domain_young_ptr RBX) eax;
|
||||
|
@ -623,7 +617,7 @@ let emit_instr fallthrough i =
|
|||
I.cmp (domain_field Domain_young_limit RBX) eax;
|
||||
let lbl_call_gc = new_label() in
|
||||
let lbl_frame =
|
||||
record_frame_label ?label:label_after_call_gc
|
||||
record_frame_label
|
||||
i.live (Dbg_alloc dbginfo) in
|
||||
I.jb (label lbl_call_gc);
|
||||
let lbl_after_alloc = new_label() in
|
||||
|
@ -643,7 +637,7 @@ let emit_instr fallthrough i =
|
|||
emit_call "caml_allocN"
|
||||
end;
|
||||
let label =
|
||||
record_frame_label ?label:label_after_call_gc
|
||||
record_frame_label
|
||||
i.live (Dbg_alloc dbginfo)
|
||||
in
|
||||
def_label label;
|
||||
|
@ -657,12 +651,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 { label_after_error; } )) ->
|
||||
let lbl = bound_error_label ?label:label_after_error i.dbg in
|
||||
| Lop(Iintop (Icheckbound)) ->
|
||||
let lbl = bound_error_label i.dbg in
|
||||
I.cmp (reg i.arg.(1)) (reg i.arg.(0));
|
||||
I.jbe (label lbl)
|
||||
| Lop(Iintop_imm(Icheckbound { label_after_error; }, n)) ->
|
||||
let lbl = bound_error_label ?label:label_after_error i.dbg in
|
||||
| Lop(Iintop_imm(Icheckbound, n)) ->
|
||||
let lbl = bound_error_label i.dbg in
|
||||
I.cmp (int n) (reg i.arg.(0));
|
||||
I.jbe (label lbl)
|
||||
| Lop(Iintop(Idiv | Imod)) ->
|
||||
|
|
|
@ -95,8 +95,6 @@ let edx = phys_reg 3
|
|||
let stack_slot slot ty =
|
||||
Reg.at_location ty (Stack slot)
|
||||
|
||||
let loc_spacetime_node_hole = Reg.dummy (* Spacetime unsupported *)
|
||||
|
||||
(* Instruction selection *)
|
||||
|
||||
let word_addressed = false
|
||||
|
@ -201,7 +199,7 @@ let destroyed_at_c_call = (* ebx, esi, edi, ebp preserved *)
|
|||
[|eax; ecx; edx|]
|
||||
|
||||
let destroyed_at_oper = function
|
||||
Iop(Icall_ind _ | Icall_imm _ | Iextcall { alloc = true; _}) ->
|
||||
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 |]
|
||||
|
@ -232,9 +230,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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -89,7 +89,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, _ty_args, _alloc, _label), args, _dbg)
|
||||
| Cop(Cextcall(fn, _ty_res, _ty_args, _alloc), args, _dbg)
|
||||
when !fast_math && List.mem fn inline_float_ops ->
|
||||
begin match args with
|
||||
[arg] -> float_needs arg
|
||||
|
@ -160,7 +160,7 @@ inherit Selectgen.selector_generic as super
|
|||
|
||||
method! is_immediate op n =
|
||||
match op with
|
||||
| Iadd | Isub | Imul | Iand | Ior | Ixor | Icomp _ | Icheckbound _ ->
|
||||
| Iadd | Isub | Imul | Iand | Ior | Ixor | Icomp _ | Icheckbound ->
|
||||
true
|
||||
| _ ->
|
||||
super#is_immediate op n
|
||||
|
@ -169,7 +169,7 @@ method is_immediate_test _cmp _n = 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
|
||||
|
@ -178,7 +178,7 @@ method! is_simple_expr e =
|
|||
|
||||
method! effects_of e =
|
||||
match e with
|
||||
| Cop(Cextcall(fn, _, _, _, _), args, _)
|
||||
| Cop(Cextcall(fn, _, _, _), args, _)
|
||||
when !fast_math && List.mem fn inline_float_ops ->
|
||||
Selectgen.Effect_and_coeffect.join_list_map args self#effects_of
|
||||
| _ ->
|
||||
|
@ -201,7 +201,7 @@ method! select_store is_assign addr exp =
|
|||
match exp with
|
||||
Cconst_int (n, _) ->
|
||||
(Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple [])
|
||||
| (Cconst_natint (n, _) | Cblockheader (n, _)) ->
|
||||
| Cconst_natint (n, _) ->
|
||||
(Ispecific(Istore_int(n, addr, is_assign)), Ctuple [])
|
||||
| Cconst_symbol (s, _) ->
|
||||
(Ispecific(Istore_symbol(s, addr, is_assign)), Ctuple [])
|
||||
|
@ -240,7 +240,7 @@ method! select_operation op args dbg =
|
|||
super#select_operation op args dbg
|
||||
end
|
||||
(* Recognize inlined floating point operations *)
|
||||
| Cextcall(fn, _ty_res, _ty_args, false, _label)
|
||||
| Cextcall(fn, _ty_res, _ty_args, false)
|
||||
when !fast_math && List.mem fn inline_float_ops ->
|
||||
(Ispecific(Ifloatspecial fn), args)
|
||||
(* Default *)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -130,8 +130,8 @@ let build_intervals fd =
|
|||
update_interval_position_by_instr intervals i !pos;
|
||||
begin match i.desc with
|
||||
Iend -> ()
|
||||
| Iop(Icall_ind _ | Icall_imm _ | Iextcall{alloc = true; _}
|
||||
| Itailcall_ind _ | Itailcall_imm _) ->
|
||||
| Iop(Icall_ind | Icall_imm _ | Iextcall{alloc = true; _}
|
||||
| Itailcall_ind | Itailcall_imm _) ->
|
||||
walk_instruction i.next
|
||||
| Iop _ ->
|
||||
insert_destroyed_at_oper intervals i !pos;
|
||||
|
|
|
@ -44,7 +44,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 =
|
||||
|
@ -52,7 +52,6 @@ type fundecl =
|
|||
fun_body: instruction;
|
||||
fun_fast: bool;
|
||||
fun_dbg : Debuginfo.t;
|
||||
fun_spacetime_shape : Mach.spacetime_shape option;
|
||||
fun_tailrec_entry_point_label : label;
|
||||
fun_contains_calls: bool;
|
||||
fun_num_stack_slots: int array;
|
||||
|
|
|
@ -53,7 +53,6 @@ type fundecl =
|
|||
fun_body: instruction;
|
||||
fun_fast: bool;
|
||||
fun_dbg : Debuginfo.t;
|
||||
fun_spacetime_shape : Mach.spacetime_shape option;
|
||||
fun_tailrec_entry_point_label : label;
|
||||
fun_contains_calls: bool;
|
||||
fun_num_stack_slots: int array;
|
||||
|
|
|
@ -137,11 +137,8 @@ let linear i n contains_calls =
|
|||
let rec linear i n =
|
||||
match i.Mach.desc with
|
||||
Iend -> n
|
||||
| Iop(Itailcall_ind _ | Itailcall_imm _ as op) ->
|
||||
if not Config.spacetime then
|
||||
copy_instr (Lop op) i (discard_dead_code n)
|
||||
else
|
||||
copy_instr (Lop op) i (linear i.Mach.next n)
|
||||
| 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 ->
|
||||
linear i.Mach.next n
|
||||
|
@ -248,7 +245,7 @@ let linear i n contains_calls =
|
|||
get_label (cons_instr Lentertrap (linear handler n1))
|
||||
in
|
||||
incr try_depth;
|
||||
assert (i.Mach.arg = [| |] || Config.spacetime);
|
||||
assert (i.Mach.arg = [| |]);
|
||||
let n3 = cons_instr (Lpushtrap { lbl_handler; })
|
||||
(linear body
|
||||
(cons_instr
|
||||
|
@ -331,7 +328,6 @@ let fundecl f =
|
|||
fun_body;
|
||||
fun_fast = not (List.mem Cmm.Reduce_code_size f.Mach.fun_codegen_options);
|
||||
fun_dbg = f.Mach.fun_dbg;
|
||||
fun_spacetime_shape = f.Mach.fun_spacetime_shape;
|
||||
fun_tailrec_entry_point_label;
|
||||
fun_contains_calls = contains_calls;
|
||||
fun_num_stack_slots = f.Mach.fun_num_stack_slots;
|
||||
|
|
|
@ -35,24 +35,18 @@ let rec live i finally =
|
|||
before the instruction sequence.
|
||||
The instruction i is annotated by the set of registers live across
|
||||
the instruction. *)
|
||||
let arg =
|
||||
if Config.spacetime
|
||||
&& Mach.spacetime_node_hole_pointer_is_live_before i
|
||||
then Array.append i.arg [| Proc.loc_spacetime_node_hole |]
|
||||
else i.arg
|
||||
in
|
||||
match i.desc with
|
||||
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 arg
|
||||
Reg.set_of_array i.arg
|
||||
| Iop op ->
|
||||
let after = live i.next finally in
|
||||
if Proc.op_is_pure op (* no side effects *)
|
||||
&& Reg.disjoint_set_array after i.res (* results are not used after *)
|
||||
&& not (Proc.regs_are_volatile arg) (* no stack-like hard reg *)
|
||||
&& not (Proc.regs_are_volatile i.arg) (* no stack-like hard reg *)
|
||||
&& not (Proc.regs_are_volatile i.res) (* is involved *)
|
||||
then begin
|
||||
(* This operation is dead code. Ignore its arguments. *)
|
||||
|
@ -62,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 _ | Ialloc _
|
||||
| Iintop (Icheckbound _) | Iintop_imm(Icheckbound _, _) ->
|
||||
| Icall_ind | Icall_imm _ | Iextcall _ | Ialloc _
|
||||
| Iintop (Icheckbound) | Iintop_imm(Icheckbound, _) ->
|
||||
(* The function call may raise an exception, branching to the
|
||||
nearest enclosing try ... with. Similarly for bounds checks
|
||||
and allocation (for the latter: finalizers may throw
|
||||
|
@ -74,13 +68,13 @@ let rec live i finally =
|
|||
| _ ->
|
||||
across_after in
|
||||
i.live <- across;
|
||||
Reg.add_set_array across arg
|
||||
Reg.add_set_array across i.arg
|
||||
end
|
||||
| Iifthenelse(_test, ifso, ifnot) ->
|
||||
let at_join = live i.next finally in
|
||||
let at_fork = Reg.Set.union (live ifso at_join) (live ifnot at_join) in
|
||||
i.live <- at_fork;
|
||||
Reg.add_set_array at_fork arg
|
||||
Reg.add_set_array at_fork i.arg
|
||||
| Iswitch(_index, cases) ->
|
||||
let at_join = live i.next finally in
|
||||
let at_fork = ref Reg.Set.empty in
|
||||
|
@ -88,7 +82,7 @@ let rec live i finally =
|
|||
at_fork := Reg.Set.union !at_fork (live cases.(i) at_join)
|
||||
done;
|
||||
i.live <- !at_fork;
|
||||
Reg.add_set_array !at_fork arg
|
||||
Reg.add_set_array !at_fork i.arg
|
||||
| Icatch(rec_flag, handlers, body) ->
|
||||
let at_join = live i.next finally in
|
||||
let aux (nfail,handler) (nfail', before_handler) =
|
||||
|
@ -140,7 +134,7 @@ let rec live i finally =
|
|||
before_body
|
||||
| Iraise _ ->
|
||||
i.live <- !live_at_raise;
|
||||
Reg.add_set_array !live_at_raise arg
|
||||
Reg.add_set_array !live_at_raise i.arg
|
||||
|
||||
let reset () =
|
||||
live_at_raise := Reg.Set.empty;
|
||||
|
@ -148,13 +142,8 @@ let reset () =
|
|||
|
||||
let fundecl f =
|
||||
let initially_live = live f.fun_body Reg.Set.empty in
|
||||
(* Sanity check: only function parameters (and the Spacetime node hole
|
||||
register, if profiling) can be live at entrypoint *)
|
||||
(* Sanity check: only function parameters can be live at entrypoint *)
|
||||
let wrong_live = Reg.Set.diff initially_live (Reg.set_of_array f.fun_args) in
|
||||
let wrong_live =
|
||||
if not Config.spacetime then wrong_live
|
||||
else Reg.Set.remove Proc.loc_spacetime_node_hole wrong_live
|
||||
in
|
||||
if not (Reg.Set.is_empty wrong_live) then begin
|
||||
Misc.fatal_errorf "@[Liveness.fundecl:@\n%a@]"
|
||||
Printmach.regset wrong_live
|
||||
|
|
|
@ -15,8 +15,6 @@
|
|||
|
||||
(* Representation of machine code by sequences of pseudoinstructions *)
|
||||
|
||||
type label = Cmm.label
|
||||
|
||||
type integer_comparison =
|
||||
Isigned of Cmm.integer_comparison
|
||||
| Iunsigned of Cmm.integer_comparison
|
||||
|
@ -25,8 +23,7 @@ type integer_operation =
|
|||
Iadd | Isub | Imul | Imulh | Idiv | Imod
|
||||
| Iand | Ior | Ixor | Ilsl | Ilsr | Iasr
|
||||
| Icomp of integer_comparison
|
||||
| Icheckbound of { label_after_error : label option;
|
||||
spacetime_index : int; }
|
||||
| Icheckbound
|
||||
|
||||
type float_comparison = Cmm.float_comparison
|
||||
|
||||
|
@ -46,18 +43,17 @@ type operation =
|
|||
| Iconst_int of nativeint
|
||||
| Iconst_float of int64
|
||||
| Iconst_symbol of string
|
||||
| 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; }
|
||||
| Icall_ind
|
||||
| Icall_imm of { func : string; }
|
||||
| Itailcall_ind
|
||||
| Itailcall_imm of { func : string; }
|
||||
| Iextcall of { func : string;
|
||||
ty_res : Cmm.machtype; ty_args : Cmm.exttype list;
|
||||
alloc : bool; label_after : label; }
|
||||
alloc : bool; }
|
||||
| Istackoffset of int
|
||||
| Iload of Cmm.memory_chunk * Arch.addressing_mode
|
||||
| Istore of Cmm.memory_chunk * Arch.addressing_mode * bool
|
||||
| Ialloc of { bytes : int; label_after_call_gc : label option;
|
||||
dbginfo : Debuginfo.alloc_dbginfo; spacetime_index : int; }
|
||||
| Ialloc of { bytes : int; dbginfo : Debuginfo.alloc_dbginfo; }
|
||||
| Iintop of integer_operation
|
||||
| Iintop_imm of integer_operation * int
|
||||
| Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf
|
||||
|
@ -88,20 +84,12 @@ and instruction_desc =
|
|||
| Itrywith of instruction * instruction
|
||||
| Iraise of Lambda.raise_kind
|
||||
|
||||
type spacetime_part_of_shape =
|
||||
| Direct_call_point of { callee : string; }
|
||||
| Indirect_call_point
|
||||
| Allocation_point
|
||||
|
||||
type spacetime_shape = (spacetime_part_of_shape * Cmm.label) list
|
||||
|
||||
type fundecl =
|
||||
{ fun_name: string;
|
||||
fun_args: Reg.t array;
|
||||
fun_body: instruction;
|
||||
fun_codegen_options : Cmm.codegen_option list;
|
||||
fun_dbg : Debuginfo.t;
|
||||
fun_spacetime_shape : spacetime_shape option;
|
||||
fun_num_stack_slots: int array;
|
||||
fun_contains_calls: bool;
|
||||
}
|
||||
|
@ -148,7 +136,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) ->
|
||||
|
@ -167,43 +155,9 @@ let rec instr_iter f i =
|
|||
| _ ->
|
||||
instr_iter f i.next
|
||||
|
||||
let spacetime_node_hole_pointer_is_live_before insn =
|
||||
match insn.desc with
|
||||
| Iop op ->
|
||||
begin match op with
|
||||
| Icall_ind _ | Icall_imm _ | Itailcall_ind _ | Itailcall_imm _ -> true
|
||||
| Iextcall { alloc; } -> alloc
|
||||
| Ialloc _ ->
|
||||
(* Allocations are special: the call to [caml_call_gc] requires some
|
||||
instrumentation code immediately prior, but this is not inserted until
|
||||
the emitter (since the call is not visible prior to that in any IR).
|
||||
As such, none of the Mach / Linearize analyses will ever see that
|
||||
we use the node hole pointer for these, and we do not need to say
|
||||
that it is live at such points. *)
|
||||
false
|
||||
| Iintop op | Iintop_imm (op, _) ->
|
||||
begin match op with
|
||||
| Icheckbound _
|
||||
(* [Icheckbound] doesn't need to return [true] for the same reason as
|
||||
[Ialloc]. *)
|
||||
| Iadd | Isub | Imul | Imulh | Idiv | Imod
|
||||
| Iand | Ior | Ixor | Ilsl | Ilsr | Iasr
|
||||
| Icomp _ -> false
|
||||
end
|
||||
| Ispecific specific_op ->
|
||||
Arch.spacetime_node_hole_pointer_is_live_before specific_op
|
||||
| Imove | Ispill | Ireload | Iconst_int _ | Iconst_float _
|
||||
| Iconst_symbol _ | Istackoffset _ | Iload _ | Istore _
|
||||
| Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf
|
||||
| Ifloatofint | Iintoffloat
|
||||
| Iname_for_debugger _ -> false
|
||||
end
|
||||
| Iend | Ireturn | Iifthenelse _ | Iswitch _ | Icatch _
|
||||
| Iexit _ | Itrywith _ | Iraise _ -> false
|
||||
|
||||
let operation_can_raise op =
|
||||
match op with
|
||||
| Icall_ind _ | Icall_imm _ | Iextcall _
|
||||
| Iintop (Icheckbound _) | Iintop_imm (Icheckbound _, _)
|
||||
| Icall_ind | Icall_imm _ | Iextcall _
|
||||
| Iintop (Icheckbound) | Iintop_imm (Icheckbound, _)
|
||||
| Ialloc _ -> true
|
||||
| _ -> false
|
||||
|
|
|
@ -15,12 +15,6 @@
|
|||
|
||||
(* 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.integer_comparison
|
||||
| Iunsigned of Cmm.integer_comparison
|
||||
|
@ -29,11 +23,7 @@ type integer_operation =
|
|||
Iadd | Isub | Imul | Imulh | Idiv | Imod
|
||||
| Iand | Ior | Ixor | Ilsl | Ilsr | Iasr
|
||||
| Icomp of integer_comparison
|
||||
| Icheckbound of { label_after_error : label option;
|
||||
spacetime_index : int; }
|
||||
(** For Spacetime only, [Icheckbound] operations take two arguments, the
|
||||
second being the pointer to the trie node for the current function
|
||||
(and the first being as per non-Spacetime mode). *)
|
||||
| Icheckbound
|
||||
|
||||
type float_comparison = Cmm.float_comparison
|
||||
|
||||
|
@ -53,21 +43,18 @@ type operation =
|
|||
| Iconst_int of nativeint
|
||||
| Iconst_float of int64
|
||||
| Iconst_symbol of string
|
||||
| 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; }
|
||||
| Icall_ind
|
||||
| Icall_imm of { func : string; }
|
||||
| Itailcall_ind
|
||||
| Itailcall_imm of { func : string; }
|
||||
| Iextcall of { func : string;
|
||||
ty_res : Cmm.machtype; ty_args : Cmm.exttype list;
|
||||
alloc : bool; label_after : label; }
|
||||
alloc : bool; }
|
||||
| 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 { bytes : int; label_after_call_gc : label option;
|
||||
dbginfo : Debuginfo.alloc_dbginfo; spacetime_index : int; }
|
||||
(** For Spacetime only, Ialloc instructions take one argument, being the
|
||||
pointer to the trie node for the current function. *)
|
||||
| Ialloc of { bytes : int; dbginfo : Debuginfo.alloc_dbginfo; }
|
||||
| Iintop of integer_operation
|
||||
| Iintop_imm of integer_operation * int
|
||||
| Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf
|
||||
|
@ -104,26 +91,12 @@ and instruction_desc =
|
|||
| Itrywith of instruction * instruction
|
||||
| Iraise of Lambda.raise_kind
|
||||
|
||||
type spacetime_part_of_shape =
|
||||
| Direct_call_point of { callee : string; (* the symbol *) }
|
||||
| Indirect_call_point
|
||||
| Allocation_point
|
||||
|
||||
(** A description of the layout of a Spacetime profiling node associated with
|
||||
a given function. Each call and allocation point instrumented within
|
||||
the function is marked with a label in the code and assigned a place
|
||||
within the node. This information is stored within the executable and
|
||||
extracted when the user saves a profile. The aim is to minimise runtime
|
||||
memory usage within the nodes and increase performance. *)
|
||||
type spacetime_shape = (spacetime_part_of_shape * Cmm.label) list
|
||||
|
||||
type fundecl =
|
||||
{ fun_name: string;
|
||||
fun_args: Reg.t array;
|
||||
fun_body: instruction;
|
||||
fun_codegen_options : Cmm.codegen_option list;
|
||||
fun_dbg : Debuginfo.t;
|
||||
fun_spacetime_shape : spacetime_shape option;
|
||||
fun_num_stack_slots: int array;
|
||||
fun_contains_calls: bool;
|
||||
}
|
||||
|
@ -138,6 +111,4 @@ val instr_cons_debug:
|
|||
instruction -> instruction
|
||||
val instr_iter: (instruction -> unit) -> instruction -> unit
|
||||
|
||||
val spacetime_node_hole_pointer_is_live_before : instruction -> bool
|
||||
|
||||
val operation_can_raise : operation -> bool
|
||||
|
|
|
@ -49,15 +49,7 @@ type specific_operation =
|
|||
Imultaddf (* multiply and add *)
|
||||
| Imultsubf (* multiply and subtract *)
|
||||
| Ialloc_far of (* allocation in large functions *)
|
||||
{ bytes : int; label_after_call_gc : int (*Cmm.label*) option;
|
||||
dbginfo : Debuginfo.alloc_dbginfo }
|
||||
|
||||
(* note: we avoid introducing a dependency to Cmm since this dep
|
||||
is not detected when "make depend" is run under amd64 *)
|
||||
|
||||
let spacetime_node_hole_pointer_is_live_before = function
|
||||
| Imultaddf | Imultsubf -> false
|
||||
| Ialloc_far _ -> true
|
||||
{ bytes : int; dbginfo : Debuginfo.alloc_dbginfo }
|
||||
|
||||
(* Addressing modes *)
|
||||
|
||||
|
|
|
@ -310,12 +310,8 @@ let adjust_stack_offset delta =
|
|||
|
||||
(* Record live pointers at call points *)
|
||||
|
||||
let record_frame ?label live dbg =
|
||||
let lbl =
|
||||
match label with
|
||||
| None -> new_label()
|
||||
| Some label -> label
|
||||
in
|
||||
let record_frame live dbg =
|
||||
let lbl = new_label() in
|
||||
let live_offset = ref [] in
|
||||
Reg.Set.iter
|
||||
(function
|
||||
|
@ -474,9 +470,9 @@ 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_ind) -> size 5 7 6
|
||||
| Lop(Itailcall_imm { func; _ }) ->
|
||||
if func = !function_name
|
||||
then 1
|
||||
|
@ -518,14 +514,14 @@ module BR = Branch_relaxation.Make (struct
|
|||
| Lpoptrap -> 2
|
||||
| Lraise _ -> 6
|
||||
|
||||
let relax_allocation ~num_bytes:bytes ~label_after_call_gc ~dbginfo =
|
||||
Lop (Ispecific (Ialloc_far { bytes; label_after_call_gc; dbginfo }))
|
||||
let relax_allocation ~num_bytes:bytes ~dbginfo =
|
||||
Lop (Ispecific (Ialloc_far { bytes; dbginfo }))
|
||||
|
||||
(* [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 ~label_after_error:_ = assert false
|
||||
let relax_intop_imm_checkbound ~bound:_ ~label_after_error:_ = assert false
|
||||
let relax_intop_checkbound () = assert false
|
||||
let relax_intop_imm_checkbound ~bound:_ = assert false
|
||||
end)
|
||||
|
||||
(* Output the assembly code for an instruction *)
|
||||
|
@ -619,31 +615,31 @@ let emit_instr i =
|
|||
| ELF64v1 | ELF64v2 ->
|
||||
emit_tocload emit_reg i.res.(0) (TocSym s)
|
||||
end
|
||||
| Lop(Icall_ind { label_after; }) ->
|
||||
| Lop(Icall_ind) ->
|
||||
begin match abi with
|
||||
| ELF32 ->
|
||||
` mtctr {emit_reg i.arg.(0)}\n`;
|
||||
` bctrl\n`;
|
||||
record_frame i.live (Dbg_other i.dbg) ~label:label_after
|
||||
record_frame i.live (Dbg_other i.dbg)
|
||||
| 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 (Dbg_other i.dbg) ~label:label_after;
|
||||
record_frame i.live (Dbg_other i.dbg);
|
||||
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 (Dbg_other i.dbg) ~label:label_after;
|
||||
record_frame i.live (Dbg_other i.dbg);
|
||||
emit_reload_toc()
|
||||
end
|
||||
| Lop(Icall_imm { func; label_after; }) ->
|
||||
| Lop(Icall_imm { func; }) ->
|
||||
begin match abi with
|
||||
| ELF32 ->
|
||||
emit_call func;
|
||||
record_frame i.live (Dbg_other i.dbg) ~label:label_after
|
||||
record_frame i.live (Dbg_other i.dbg)
|
||||
| ELF64v1 | ELF64v2 ->
|
||||
(* For PPC64, we cannot just emit a "bl s; nop" sequence, because
|
||||
of the following scenario:
|
||||
|
@ -663,11 +659,11 @@ let emit_instr i =
|
|||
Cost: 3 instructions if same TOC, 7 if different TOC.
|
||||
Let's try option 2. *)
|
||||
emit_call func;
|
||||
record_frame i.live (Dbg_other i.dbg) ~label:label_after;
|
||||
record_frame i.live (Dbg_other i.dbg);
|
||||
` nop\n`;
|
||||
emit_reload_toc()
|
||||
end
|
||||
| Lop(Itailcall_ind { label_after = _; }) ->
|
||||
| Lop(Itailcall_ind) ->
|
||||
begin match abi with
|
||||
| ELF32 ->
|
||||
` mtctr {emit_reg i.arg.(0)}\n`
|
||||
|
@ -685,7 +681,7 @@ let emit_instr i =
|
|||
end;
|
||||
emit_free_frame();
|
||||
` bctr\n`
|
||||
| Lop(Itailcall_imm { func; label_after = _; }) ->
|
||||
| Lop(Itailcall_imm { func; }) ->
|
||||
if func = !function_name then
|
||||
` b {emit_label !tailrec_entry_point}\n`
|
||||
else begin
|
||||
|
@ -758,23 +754,15 @@ let emit_instr i =
|
|||
| Single -> "stfs"
|
||||
| Double | Double_u -> "stfd" in
|
||||
emit_load_store storeinstr addr i.arg 1 i.arg.(0)
|
||||
| Lop(Ialloc { bytes = n; label_after_call_gc; dbginfo }) ->
|
||||
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;
|
||||
| Lop(Ialloc { bytes = n; dbginfo }) ->
|
||||
if !call_gc_label = 0 then call_gc_label := new_label ();
|
||||
` addi 31, 31, {emit_int(-n)}\n`;
|
||||
` {emit_string cmplg} 31, 30\n`;
|
||||
` bltl {emit_label !call_gc_label}\n`;
|
||||
record_frame i.live (Dbg_alloc dbginfo);
|
||||
` addi {emit_reg i.res.(0)}, 31, {emit_int size_addr}\n`;
|
||||
| Lop(Ispecific(Ialloc_far { bytes = n; label_after_call_gc; dbginfo })) ->
|
||||
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;
|
||||
| Lop(Ispecific(Ialloc_far { bytes = n; dbginfo })) ->
|
||||
if !call_gc_label = 0 then call_gc_label := new_label ();
|
||||
let lbl = new_label() in
|
||||
` addi 31, 31, {emit_int(-n)}\n`;
|
||||
` {emit_string cmplg} 31, 30\n`;
|
||||
|
@ -797,9 +785,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 { label_after_error; })) ->
|
||||
| Lop(Iintop (Icheckbound)) ->
|
||||
if !Clflags.debug then
|
||||
record_frame Reg.Set.empty (Dbg_other i.dbg) ?label:label_after_error;
|
||||
record_frame Reg.Set.empty (Dbg_other i.dbg);
|
||||
` {emit_string tglle} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
|
||||
| Lop(Iintop op) ->
|
||||
let instr = name_for_intop op in
|
||||
|
@ -815,9 +803,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 { label_after_error; }, n)) ->
|
||||
| Lop(Iintop_imm(Icheckbound, n)) ->
|
||||
if !Clflags.debug then
|
||||
record_frame Reg.Set.empty (Dbg_other i.dbg) ?label:label_after_error;
|
||||
record_frame Reg.Set.empty (Dbg_other i.dbg);
|
||||
` {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
|
||||
|
|
|
@ -91,8 +91,6 @@ let phys_reg n =
|
|||
let stack_slot slot ty =
|
||||
Reg.at_location ty (Stack slot)
|
||||
|
||||
let loc_spacetime_node_hole = Reg.dummy (* Spacetime unsupported *)
|
||||
|
||||
(* Calling conventions *)
|
||||
|
||||
let loc_int last_int make_stack reg_use_stack int ofs =
|
||||
|
@ -303,7 +301,7 @@ 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 { alloc = true; _ }) ->
|
||||
Iop(Icall_ind | Icall_imm _ | Iextcall { alloc = true; _ }) ->
|
||||
all_phys_regs
|
||||
| Iop(Iextcall { alloc = false; _ }) -> destroyed_at_c_call
|
||||
| _ -> [||]
|
||||
|
@ -326,9 +324,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(Imultaddf | Imultsubf) -> true
|
||||
| Ispecific _ -> false
|
||||
| _ -> true
|
||||
|
|
|
@ -63,7 +63,7 @@ method! is_immediate op n =
|
|||
| Isub -> is_immediate (-n) (* turned into add opposite *)
|
||||
| Iand | Ior | Ixor -> is_immediate_logical n
|
||||
| Icomp c -> self#is_immediate_test c n
|
||||
| Icheckbound _ -> 0 <= n && n <= 0x7FFF
|
||||
| Icheckbound -> 0 <= n && n <= 0x7FFF
|
||||
(* twlle takes a 16-bit signed immediate but performs an unsigned compare *)
|
||||
| _ -> super#is_immediate op n
|
||||
|
||||
|
|
|
@ -116,7 +116,7 @@ let location d =
|
|||
|
||||
let operation d = function
|
||||
| Capply _ty -> "app" ^ location d
|
||||
| Cextcall(lbl, _ty_res, _ty_args, _alloc, _) ->
|
||||
| Cextcall(lbl, _ty_res, _ty_args, _alloc) ->
|
||||
Printf.sprintf "extcall \"%s\"%s" lbl (location d)
|
||||
| Cload (c, Asttypes.Immutable) -> Printf.sprintf "load %s" (chunk c)
|
||||
| Cload (c, Asttypes.Mutable) -> Printf.sprintf "load_mut %s" (chunk c)
|
||||
|
@ -161,9 +161,6 @@ let rec expr ppf = function
|
|||
| Cconst_int (n, _dbg) -> fprintf ppf "%i" n
|
||||
| Cconst_natint (n, _dbg) ->
|
||||
fprintf ppf "%s" (Nativeint.to_string n)
|
||||
| Cblockheader(n, d) ->
|
||||
fprintf ppf "block-hdr(%s)%s"
|
||||
(Nativeint.to_string n) (location d)
|
||||
| Cconst_float (n, _dbg) -> fprintf ppf "%F" n
|
||||
| Cconst_symbol (s, _dbg) -> fprintf ppf "\"%s\"" s
|
||||
| Cvar id -> V.print ppf id
|
||||
|
@ -222,7 +219,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(_, ty_res, ty_args, _, _) ->
|
||||
| Cextcall(_, ty_res, ty_args, _) ->
|
||||
fprintf ppf "@ %a" extcall_signature (ty_res, ty_args)
|
||||
| _ -> ()
|
||||
end;
|
||||
|
|
|
@ -30,7 +30,7 @@ let instr ppf i =
|
|||
fprintf ppf "prologue"
|
||||
| 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;
|
||||
|
|
|
@ -90,16 +90,7 @@ let intop = function
|
|||
| Ilsr -> " >>u "
|
||||
| Iasr -> " >>s "
|
||||
| Icomp cmp -> intcomp cmp
|
||||
| Icheckbound { label_after_error; spacetime_index; } ->
|
||||
if not Config.spacetime then " check > "
|
||||
else
|
||||
Printf.sprintf "check[lbl=%s,index=%d] > "
|
||||
begin
|
||||
match label_after_error with
|
||||
| None -> ""
|
||||
| Some lbl -> Int.to_string lbl
|
||||
end
|
||||
spacetime_index
|
||||
| Icheckbound -> Printf.sprintf "check > "
|
||||
|
||||
let test tst ppf arg =
|
||||
match tst with
|
||||
|
@ -122,9 +113,9 @@ let operation op arg ppf res =
|
|||
| Iconst_int 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 { func; _ } -> fprintf ppf "call \"%s\" %a" func regs arg
|
||||
| Itailcall_ind _ -> fprintf ppf "tailcall %a" 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
|
||||
|
@ -141,11 +132,8 @@ 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 { bytes = n; _ } ->
|
||||
| Ialloc { bytes = n; } ->
|
||||
fprintf ppf "alloc %i" n;
|
||||
if Config.spacetime then begin
|
||||
fprintf ppf "(spacetime node = %a)" reg arg.(0)
|
||||
end
|
||||
| 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)
|
||||
|
|
|
@ -37,7 +37,6 @@ val loc_parameters: Cmm.machtype -> Reg.t array
|
|||
val loc_external_arguments: Cmm.exttype list -> Reg.t array array * int
|
||||
val loc_external_results: Cmm.machtype -> Reg.t array
|
||||
val loc_exn_bucket: Reg.t
|
||||
val loc_spacetime_node_hole: Reg.t
|
||||
|
||||
(* The maximum number of arguments of an OCaml to OCaml function call for
|
||||
which it is guaranteed there will be no arguments passed on the stack.
|
||||
|
|
|
@ -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}
|
||||
|
@ -128,7 +128,7 @@ method fundecl f num_stack_slots =
|
|||
let new_body = self#reload f.fun_body in
|
||||
({fun_name = f.fun_name; fun_args = f.fun_args;
|
||||
fun_body = new_body; fun_codegen_options = f.fun_codegen_options;
|
||||
fun_dbg = f.fun_dbg; fun_spacetime_shape = f.fun_spacetime_shape;
|
||||
fun_dbg = f.fun_dbg;
|
||||
fun_contains_calls = f.fun_contains_calls;
|
||||
fun_num_stack_slots = Array.copy num_stack_slots;
|
||||
},
|
||||
|
|
|
@ -27,9 +27,6 @@ type specific_operation =
|
|||
| Imultaddf of bool (* multiply, optionally negate, and add *)
|
||||
| Imultsubf of bool (* multiply, optionally negate, and subtract *)
|
||||
|
||||
let spacetime_node_hole_pointer_is_live_before = function
|
||||
| Imultaddf _ | Imultsubf _ -> false
|
||||
|
||||
(* Addressing modes *)
|
||||
|
||||
type addressing_mode =
|
||||
|
|
|
@ -143,12 +143,8 @@ let emit_float_store src ofs =
|
|||
|
||||
(* Record live pointers at call points *)
|
||||
|
||||
let record_frame_label ?label live dbg =
|
||||
let lbl =
|
||||
match label with
|
||||
| None -> new_label()
|
||||
| Some label -> label
|
||||
in
|
||||
let record_frame_label live dbg =
|
||||
let lbl = new_label () in
|
||||
let live_offset = ref [] in
|
||||
Reg.Set.iter
|
||||
(function
|
||||
|
@ -165,8 +161,8 @@ let record_frame_label ?label live dbg =
|
|||
~live_offset:!live_offset dbg;
|
||||
lbl
|
||||
|
||||
let record_frame ?label live dbg =
|
||||
let lbl = record_frame_label ?label live dbg in
|
||||
let record_frame live dbg =
|
||||
let lbl = record_frame_label live dbg in
|
||||
`{emit_label lbl}:\n`
|
||||
|
||||
(* Record calls to the GC -- we've moved them out of the way *)
|
||||
|
@ -194,10 +190,10 @@ type bound_error_call =
|
|||
|
||||
let bound_error_sites = ref ([] : bound_error_call list)
|
||||
|
||||
let bound_error_label ?label dbg =
|
||||
let bound_error_label dbg =
|
||||
if !Clflags.debug || !bound_error_sites = [] then begin
|
||||
let lbl_bound_error = new_label() in
|
||||
let lbl_frame = record_frame_label ?label Reg.Set.empty (Dbg_other dbg) in
|
||||
let lbl_frame = record_frame_label Reg.Set.empty (Dbg_other dbg) in
|
||||
bound_error_sites :=
|
||||
{ bd_lbl = lbl_bound_error;
|
||||
bd_frame_lbl = lbl_frame } :: !bound_error_sites;
|
||||
|
@ -311,18 +307,18 @@ let emit_instr i =
|
|||
` fld {emit_reg i.res.(0)}, {emit_label lbl}, {emit_reg reg_tmp}\n`
|
||||
| Lop(Iconst_symbol s) ->
|
||||
` la {emit_reg i.res.(0)}, {emit_symbol s}\n`
|
||||
| Lop(Icall_ind {label_after = label}) ->
|
||||
| Lop(Icall_ind) ->
|
||||
` jalr {emit_reg i.arg.(0)}\n`;
|
||||
record_frame ~label i.live (Dbg_other i.dbg)
|
||||
| Lop(Icall_imm {func; label_after = label}) ->
|
||||
record_frame i.live (Dbg_other i.dbg)
|
||||
| Lop(Icall_imm {func}) ->
|
||||
` {emit_call func}\n`;
|
||||
record_frame ~label i.live (Dbg_other i.dbg)
|
||||
| Lop(Itailcall_ind {label_after = _}) ->
|
||||
record_frame i.live (Dbg_other i.dbg)
|
||||
| Lop(Itailcall_ind) ->
|
||||
let n = frame_size() in
|
||||
if !contains_calls then reload_ra n;
|
||||
emit_stack_adjustment n;
|
||||
` jr {emit_reg i.arg.(0)}\n`
|
||||
| Lop(Itailcall_imm {func; label_after = _}) ->
|
||||
| Lop(Itailcall_imm {func}) ->
|
||||
if func = !function_name then begin
|
||||
` j {emit_label !tailrec_entry_point}\n`
|
||||
end else begin
|
||||
|
@ -331,11 +327,11 @@ let emit_instr i =
|
|||
emit_stack_adjustment n;
|
||||
` {emit_tail func}\n`
|
||||
end
|
||||
| Lop(Iextcall{func; alloc = true; label_after = label}) ->
|
||||
| Lop(Iextcall{func; alloc = true}) ->
|
||||
` la {emit_reg reg_t2}, {emit_symbol func}\n`;
|
||||
` {emit_call "caml_c_call"}\n`;
|
||||
record_frame ~label i.live (Dbg_other i.dbg)
|
||||
| Lop(Iextcall{func; alloc = false; label_after = _}) ->
|
||||
record_frame i.live (Dbg_other i.dbg)
|
||||
| Lop(Iextcall{func; alloc = false}) ->
|
||||
` {emit_call func}\n`
|
||||
| Lop(Istackoffset n) ->
|
||||
assert (n mod 16 = 0);
|
||||
|
@ -373,8 +369,8 @@ let emit_instr i =
|
|||
| Double | Double_u -> "fsd"
|
||||
in
|
||||
` {emit_string instr} {emit_reg i.arg.(0)}, {emit_int ofs}({emit_reg i.arg.(1)})\n`
|
||||
| Lop(Ialloc {bytes; label_after_call_gc = label; dbginfo}) ->
|
||||
let lbl_frame_lbl = record_frame_label ?label i.live (Dbg_alloc dbginfo) in
|
||||
| Lop(Ialloc {bytes; dbginfo}) ->
|
||||
let lbl_frame_lbl = record_frame_label i.live (Dbg_alloc dbginfo) in
|
||||
let lbl_after_alloc = new_label () in
|
||||
let lbl_call_gc = new_label () in
|
||||
let n = -bytes in
|
||||
|
@ -420,8 +416,8 @@ let emit_instr i =
|
|||
` sltu {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`;
|
||||
` xori {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, 1\n`;
|
||||
end
|
||||
| Lop(Iintop (Icheckbound {label_after_error = label; _})) ->
|
||||
let lbl = bound_error_label ?label i.dbg in
|
||||
| Lop(Iintop (Icheckbound)) ->
|
||||
let lbl = bound_error_label i.dbg in
|
||||
` bleu {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_label lbl}\n`
|
||||
| Lop(Iintop op) ->
|
||||
let instr = name_for_intop op in
|
||||
|
|
|
@ -154,8 +154,6 @@ let not_supported _ = fatal_error "Proc.loc_results: cannot call"
|
|||
|
||||
let max_arguments_for_tailcalls = 16
|
||||
|
||||
let loc_spacetime_node_hole = Reg.dummy (* Spacetime unsupported *)
|
||||
|
||||
(* OCaml calling convention:
|
||||
first integer args in a0 .. a7, s2 .. s9
|
||||
first float args in fa0 .. fa7, fs2 .. fs9
|
||||
|
@ -246,7 +244,7 @@ let destroyed_at_alloc =
|
|||
else [| |]
|
||||
|
||||
let destroyed_at_oper = function
|
||||
| Iop(Icall_ind _ | Icall_imm _ | Iextcall{alloc = true; _}) -> all_phys_regs
|
||||
| Iop(Icall_ind | Icall_imm _ | Iextcall{alloc = true; _}) -> all_phys_regs
|
||||
| Iop(Iextcall{alloc = false; _}) -> destroyed_at_c_call
|
||||
| Iop(Ialloc _) -> destroyed_at_alloc
|
||||
| Iop(Istore(Single, _, _)) -> [| phys_reg 100 |]
|
||||
|
@ -271,9 +269,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(Imultaddf _ | Imultsubf _) -> true
|
||||
| _ -> true
|
||||
|
||||
|
|
|
@ -35,8 +35,6 @@ type specific_operation =
|
|||
Imultaddf (* multiply and add *)
|
||||
| Imultsubf (* multiply and subtract *)
|
||||
|
||||
let spacetime_node_hole_pointer_is_live_before _specific_op = false
|
||||
|
||||
(* Addressing modes *)
|
||||
|
||||
type addressing_mode =
|
||||
|
|
|
@ -168,12 +168,8 @@ let emit_set_comp cmp res =
|
|||
|
||||
(* Record live pointers at call points *)
|
||||
|
||||
let record_frame_label ?label live dbg =
|
||||
let lbl =
|
||||
match label with
|
||||
| None -> new_label()
|
||||
| Some label -> label
|
||||
in
|
||||
let record_frame_label live dbg =
|
||||
let lbl = new_label() in
|
||||
let live_offset = ref [] in
|
||||
Reg.Set.iter
|
||||
(function
|
||||
|
@ -189,8 +185,8 @@ let record_frame_label ?label live dbg =
|
|||
~live_offset:!live_offset dbg;
|
||||
lbl
|
||||
|
||||
let record_frame ?label live dbg =
|
||||
let lbl = record_frame_label ?label live dbg in
|
||||
let record_frame live dbg =
|
||||
let lbl = record_frame_label live dbg in
|
||||
`{emit_label lbl}:`
|
||||
|
||||
(* Record calls to caml_call_gc, emitted out of line. *)
|
||||
|
@ -215,10 +211,10 @@ type bound_error_call =
|
|||
let bound_error_sites = ref ([] : bound_error_call list)
|
||||
let bound_error_call = ref 0
|
||||
|
||||
let bound_error_label ?label dbg =
|
||||
let bound_error_label dbg =
|
||||
if !Clflags.debug then begin
|
||||
let lbl_bound_error = new_label() in
|
||||
let lbl_frame = record_frame_label ?label Reg.Set.empty (Dbg_other dbg) in
|
||||
let lbl_frame = record_frame_label Reg.Set.empty (Dbg_other dbg) in
|
||||
bound_error_sites :=
|
||||
{ bd_lbl = lbl_bound_error; bd_frame = lbl_frame } :: !bound_error_sites;
|
||||
lbl_bound_error
|
||||
|
@ -355,20 +351,20 @@ let emit_instr i =
|
|||
` ld {emit_reg i.res.(0)}, 0(%r1)\n`
|
||||
| Lop(Iconst_symbol s) ->
|
||||
emit_load_symbol_addr i.res.(0) s
|
||||
| Lop(Icall_ind { label_after; }) ->
|
||||
| Lop(Icall_ind) ->
|
||||
` basr %r14, {emit_reg i.arg.(0)}\n`;
|
||||
`{record_frame i.live (Dbg_other i.dbg) ~label:label_after}\n`
|
||||
`{record_frame i.live (Dbg_other i.dbg)}\n`
|
||||
|
||||
| Lop(Icall_imm { func; label_after; }) ->
|
||||
| Lop(Icall_imm { func; }) ->
|
||||
emit_call func;
|
||||
`{record_frame i.live (Dbg_other i.dbg) ~label:label_after}\n`
|
||||
| Lop(Itailcall_ind { label_after = _; }) ->
|
||||
`{record_frame i.live (Dbg_other i.dbg)}\n`
|
||||
| Lop(Itailcall_ind) ->
|
||||
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 { func; label_after = _; }) ->
|
||||
| Lop(Itailcall_imm { func; }) ->
|
||||
if func = !function_name then
|
||||
` brcl 15, {emit_label !tailrec_entry_point}\n`
|
||||
else begin
|
||||
|
@ -382,12 +378,12 @@ let emit_instr i =
|
|||
` brcl 15, {emit_symbol func}\n`
|
||||
end
|
||||
|
||||
| Lop(Iextcall { func; alloc; label_after; }) ->
|
||||
| Lop(Iextcall { func; alloc; }) ->
|
||||
if not alloc then emit_call func
|
||||
else begin
|
||||
emit_load_symbol_addr reg_r7 func;
|
||||
emit_call "caml_c_call";
|
||||
`{record_frame i.live (Dbg_other i.dbg) ~label:label_after}\n`
|
||||
`{record_frame i.live (Dbg_other i.dbg)}\n`
|
||||
end
|
||||
|
||||
| Lop(Istackoffset n) ->
|
||||
|
@ -424,11 +420,11 @@ let emit_instr i =
|
|||
| Double | Double_u -> "stdy" in
|
||||
emit_load_store storeinstr addr i.arg 1 i.arg.(0)
|
||||
|
||||
| Lop(Ialloc { bytes = n; label_after_call_gc; dbginfo }) ->
|
||||
| Lop(Ialloc { bytes = n; dbginfo }) ->
|
||||
let lbl_after_alloc = new_label() in
|
||||
let lbl_call_gc = new_label() in
|
||||
let lbl_frame =
|
||||
record_frame_label i.live (Dbg_alloc dbginfo) ?label:label_after_call_gc
|
||||
record_frame_label i.live (Dbg_alloc dbginfo)
|
||||
in
|
||||
call_gc_sites :=
|
||||
{ gc_lbl = lbl_call_gc;
|
||||
|
@ -483,8 +479,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 { label_after_error; })) ->
|
||||
let lbl = bound_error_label i.dbg ?label:label_after_error in
|
||||
| Lop(Iintop (Icheckbound)) ->
|
||||
let lbl = bound_error_label i.dbg 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) ->
|
||||
|
@ -503,8 +499,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 { label_after_error; }, n)) ->
|
||||
let lbl = bound_error_label i.dbg ?label:label_after_error in
|
||||
| Lop(Iintop_imm(Icheckbound, n)) ->
|
||||
let lbl = bound_error_label i.dbg 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 *)
|
||||
|
|
|
@ -94,8 +94,6 @@ let phys_reg n =
|
|||
let stack_slot slot ty =
|
||||
Reg.at_location ty (Stack slot)
|
||||
|
||||
let loc_spacetime_node_hole = Reg.dummy (* Spacetime unsupported *)
|
||||
|
||||
(* Calling conventions *)
|
||||
|
||||
let calling_conventions
|
||||
|
@ -190,7 +188,7 @@ let destroyed_at_c_call =
|
|||
100; 101; 102; 103; 104; 105; 106; 107])
|
||||
|
||||
let destroyed_at_oper = function
|
||||
Iop(Icall_ind _ | Icall_imm _ | Iextcall { alloc = true; _ }) ->
|
||||
Iop(Icall_ind | Icall_imm _ | Iextcall { alloc = true; _ }) ->
|
||||
all_phys_regs
|
||||
| Iop(Iextcall { alloc = false; _ }) -> destroyed_at_c_call
|
||||
| _ -> [||]
|
||||
|
@ -215,9 +213,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(Imultaddf | Imultsubf) -> true
|
||||
| _ -> true
|
||||
|
||||
|
|
|
@ -77,7 +77,7 @@ method! is_immediate op n =
|
|||
| Iand -> n <= -1 && n >= -0x1_0000_0000
|
||||
| Ior | Ixor -> is_immediate_logical n
|
||||
| Icomp c -> self#is_immediate_test c n
|
||||
| Icheckbound _ -> is_immediate_logical n (* unsigned comparison *)
|
||||
| Icheckbound -> is_immediate_logical n (* unsigned comparison *)
|
||||
| _ -> super#is_immediate op n
|
||||
|
||||
method select_addressing _chunk exp =
|
||||
|
|
|
@ -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 =
|
||||
|
@ -376,7 +376,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
|
||||
|
@ -391,7 +391,6 @@ method schedule_fundecl f =
|
|||
fun_body = new_body;
|
||||
fun_fast = f.fun_fast;
|
||||
fun_dbg = f.fun_dbg;
|
||||
fun_spacetime_shape = f.fun_spacetime_shape;
|
||||
fun_tailrec_entry_point_label = f.fun_tailrec_entry_point_label;
|
||||
fun_contains_calls = f.fun_contains_calls;
|
||||
fun_num_stack_slots = f.fun_num_stack_slots;
|
||||
|
|
|
@ -66,7 +66,7 @@ let env_empty = {
|
|||
|
||||
let oper_result_type = function
|
||||
Capply ty -> ty
|
||||
| Cextcall(_s, ty_res, _ty_args, _alloc, _) -> ty_res
|
||||
| Cextcall(_s, ty_res, _ty_args, _alloc) -> ty_res
|
||||
| Cload (c, _) ->
|
||||
begin match c with
|
||||
| Word_val -> typ_val
|
||||
|
@ -107,7 +107,6 @@ let size_expr (env:environment) exp =
|
|||
| Cconst_symbol _ ->
|
||||
Arch.size_addr
|
||||
| Cconst_float _ -> Arch.size_float
|
||||
| Cblockheader _ -> Arch.size_int
|
||||
| Cvar id ->
|
||||
begin try
|
||||
V.Map.find id localenv
|
||||
|
@ -314,7 +313,6 @@ method is_simple_expr = function
|
|||
| Cconst_natint _ -> true
|
||||
| Cconst_float _ -> true
|
||||
| Cconst_symbol _ -> true
|
||||
| Cblockheader _ -> true
|
||||
| Cvar _ -> true
|
||||
| Ctuple el -> List.for_all self#is_simple_expr el
|
||||
| Clet(_id, arg, body) | Clet_mut(_id, _, arg, body) ->
|
||||
|
@ -350,7 +348,6 @@ method effects_of exp =
|
|||
let module EC = Effect_and_coeffect in
|
||||
match exp with
|
||||
| Cconst_int _ | Cconst_natint _ | Cconst_float _ | Cconst_symbol _
|
||||
| Cblockheader _
|
||||
| Cvar _ -> EC.none
|
||||
| Ctuple el -> EC.join_list_map el self#effects_of
|
||||
| Clet (_id, arg, body) | Clet_mut (_id, _, arg, body) ->
|
||||
|
@ -413,13 +410,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
|
||||
|
@ -437,30 +434,14 @@ method mark_instr = function
|
|||
|
||||
(* Default instruction selection for operators *)
|
||||
|
||||
method select_allocation bytes =
|
||||
Ialloc { bytes; label_after_call_gc = None;
|
||||
dbginfo = []; spacetime_index = 0; }
|
||||
method select_allocation_args _env = [| |]
|
||||
|
||||
method select_checkbound () =
|
||||
Icheckbound { spacetime_index = 0; label_after_error = None; }
|
||||
method select_checkbound_extra_args () = []
|
||||
|
||||
method select_operation op args _dbg =
|
||||
match (op, args) with
|
||||
| (Capply _, Cconst_symbol (func, _dbg) :: rem) ->
|
||||
let label_after = Cmm.new_label () in
|
||||
(Icall_imm { func; label_after; }, rem)
|
||||
(Icall_imm { func; }, rem)
|
||||
| (Capply _, _) ->
|
||||
let label_after = Cmm.new_label () in
|
||||
(Icall_ind { label_after; }, args)
|
||||
| (Cextcall(func, ty_res, ty_args, alloc, label_after), _) ->
|
||||
let label_after =
|
||||
match label_after with
|
||||
| None -> Cmm.new_label ()
|
||||
| Some label_after -> label_after
|
||||
in
|
||||
Iextcall { func; ty_res; ty_args; alloc; label_after; }, args
|
||||
(Icall_ind, args)
|
||||
| (Cextcall(func, ty_res, ty_args, alloc), _) ->
|
||||
Iextcall { func; ty_res; ty_args; alloc; }, args
|
||||
| (Cload (chunk, _mut), [arg]) ->
|
||||
let (addr, eloc) = self#select_addressing chunk arg in
|
||||
(Iload(chunk, addr), [eloc])
|
||||
|
@ -479,7 +460,7 @@ method select_operation op args _dbg =
|
|||
(Istore(chunk, addr, is_assign), [arg2; eloc])
|
||||
(* Inversion addr/datum in Istore *)
|
||||
end
|
||||
| (Calloc, _) -> (self#select_allocation 0), args
|
||||
| (Calloc, _) -> (Ialloc {bytes = 0; dbginfo = []}), args
|
||||
| (Caddi, _) -> self#select_arith_comm Iadd args
|
||||
| (Csubi, _) -> self#select_arith Isub args
|
||||
| (Cmuli, _) -> self#select_arith_comm Imul args
|
||||
|
@ -505,9 +486,7 @@ method select_operation op args _dbg =
|
|||
| (Cfloatofint, _) -> (Ifloatofint, args)
|
||||
| (Cintoffloat, _) -> (Iintoffloat, args)
|
||||
| (Ccheckbound, _) ->
|
||||
let extra_args = self#select_checkbound_extra_args () in
|
||||
let op = self#select_checkbound () in
|
||||
self#select_arith op (args @ extra_args)
|
||||
self#select_arith Icheckbound args
|
||||
| _ -> Misc.fatal_error "Selection.select_oper"
|
||||
|
||||
method private select_arith_comm op = function
|
||||
|
@ -576,15 +555,12 @@ method insert_debug _env desc dbg arg res =
|
|||
method insert _env desc arg res =
|
||||
instr_seq <- instr_cons desc arg res instr_seq
|
||||
|
||||
method extract_core ~end_instr =
|
||||
method extract =
|
||||
let rec extract res i =
|
||||
if i == dummy_instr
|
||||
then res
|
||||
else extract {i with next = res} i.next in
|
||||
extract end_instr instr_seq
|
||||
|
||||
method extract =
|
||||
self#extract_core ~end_instr:(end_instr ())
|
||||
extract (end_instr ()) instr_seq
|
||||
|
||||
(* Insert a sequence of moves from one pseudoreg set to another. *)
|
||||
|
||||
|
@ -622,20 +598,6 @@ method insert_op_debug env op dbg rs rd =
|
|||
method insert_op env op rs rd =
|
||||
self#insert_op_debug env op Debuginfo.none rs rd
|
||||
|
||||
method emit_blockheader env n _dbg =
|
||||
let r = self#regs_for typ_int in
|
||||
Some(self#insert_op env (Iconst_int n) [||] r)
|
||||
|
||||
method about_to_emit_call _env _insn _arg _dbg = None
|
||||
|
||||
(* Prior to a function call, update the Spacetime node hole pointer hard
|
||||
register. *)
|
||||
|
||||
method private maybe_emit_spacetime_move env ~spacetime_reg =
|
||||
Option.iter (fun reg ->
|
||||
self#insert_moves env reg [| Proc.loc_spacetime_node_hole |])
|
||||
spacetime_reg
|
||||
|
||||
(* Add the instructions for the given expression
|
||||
at the end of the self sequence *)
|
||||
|
||||
|
@ -660,8 +622,6 @@ method emit_expr (env:environment) exp =
|
|||
adding this register to the frame table would be redundant *)
|
||||
let r = self#regs_for typ_int in
|
||||
Some(self#insert_op env (Iconst_symbol n) [||] r)
|
||||
| Cblockheader(n, dbg) ->
|
||||
self#emit_blockheader env n dbg
|
||||
| Cvar v ->
|
||||
begin try
|
||||
Some(env_find v env)
|
||||
|
@ -721,17 +681,13 @@ method emit_expr (env:environment) exp =
|
|||
let ty = oper_result_type op in
|
||||
let (new_op, new_args) = self#select_operation op simple_args dbg 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 (Reg.typv rarg) in
|
||||
let loc_res = Proc.loc_results (Reg.typv rd) in
|
||||
let spacetime_reg =
|
||||
self#about_to_emit_call env (Iop new_op) [| r1.(0) |] dbg
|
||||
in
|
||||
self#insert_move_args env rarg loc_arg stack_ofs;
|
||||
self#maybe_emit_spacetime_move env ~spacetime_reg;
|
||||
self#insert_debug env (Iop new_op) dbg
|
||||
(Array.append [|r1.(0)|] loc_arg) loc_res;
|
||||
self#insert_move_results env loc_res rd stack_ofs;
|
||||
|
@ -741,37 +697,28 @@ method emit_expr (env:environment) exp =
|
|||
let rd = self#regs_for ty in
|
||||
let (loc_arg, stack_ofs) = Proc.loc_arguments (Reg.typv r1) in
|
||||
let loc_res = Proc.loc_results (Reg.typv rd) in
|
||||
let spacetime_reg =
|
||||
self#about_to_emit_call env (Iop new_op) [| |] dbg
|
||||
in
|
||||
self#insert_move_args env r1 loc_arg stack_ofs;
|
||||
self#maybe_emit_spacetime_move env ~spacetime_reg;
|
||||
self#insert_debug env (Iop new_op) dbg loc_arg loc_res;
|
||||
self#insert_move_results env loc_res rd stack_ofs;
|
||||
Some rd
|
||||
| Iextcall { ty_args; _} ->
|
||||
let spacetime_reg =
|
||||
self#about_to_emit_call env (Iop new_op) [| |] dbg in
|
||||
let (loc_arg, stack_ofs) =
|
||||
self#emit_extcall_args env ty_args new_args in
|
||||
self#maybe_emit_spacetime_move env ~spacetime_reg;
|
||||
let rd = self#regs_for ty in
|
||||
let loc_res =
|
||||
self#insert_op_debug env new_op dbg
|
||||
loc_arg (Proc.loc_external_results (Reg.typv rd)) in
|
||||
self#insert_move_results env loc_res rd stack_ofs;
|
||||
Some rd
|
||||
| Ialloc { bytes = _; spacetime_index; label_after_call_gc; } ->
|
||||
| Ialloc { bytes = _; } ->
|
||||
let rd = self#regs_for typ_val in
|
||||
let bytes = size_expr env (Ctuple new_args) in
|
||||
assert (bytes mod Arch.size_addr = 0);
|
||||
let alloc_words = bytes / Arch.size_addr in
|
||||
let op =
|
||||
Ialloc { bytes; spacetime_index; label_after_call_gc;
|
||||
dbginfo = [{alloc_words; alloc_dbg = dbg}] }
|
||||
Ialloc { bytes; dbginfo = [{alloc_words; alloc_dbg = dbg}] }
|
||||
in
|
||||
let args = self#select_allocation_args env in
|
||||
self#insert_debug env (Iop op) dbg args rd;
|
||||
self#insert_debug env (Iop op) dbg [||] rd;
|
||||
self#emit_stores env new_args rd;
|
||||
Some rd
|
||||
| op ->
|
||||
|
@ -1081,60 +1028,40 @@ method emit_tail (env:environment) exp =
|
|||
| Some(simple_args, env) ->
|
||||
let (new_op, new_args) = self#select_operation op simple_args dbg in
|
||||
match new_op with
|
||||
Icall_ind { label_after; } ->
|
||||
Icall_ind ->
|
||||
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 (Reg.typv rarg) in
|
||||
if stack_ofs = 0 then begin
|
||||
let call = Iop (Itailcall_ind { label_after; }) in
|
||||
let spacetime_reg =
|
||||
self#about_to_emit_call env call [| r1.(0) |] dbg
|
||||
in
|
||||
let call = Iop (Itailcall_ind) in
|
||||
self#insert_moves env rarg loc_arg;
|
||||
self#maybe_emit_spacetime_move env ~spacetime_reg;
|
||||
self#insert_debug env call dbg
|
||||
(Array.append [|r1.(0)|] loc_arg) [||];
|
||||
end else begin
|
||||
let rd = self#regs_for ty in
|
||||
let loc_res = Proc.loc_results (Reg.typv rd) in
|
||||
let spacetime_reg =
|
||||
self#about_to_emit_call env (Iop new_op) [| r1.(0) |] dbg
|
||||
in
|
||||
self#insert_move_args env rarg loc_arg stack_ofs;
|
||||
self#maybe_emit_spacetime_move env ~spacetime_reg;
|
||||
self#insert_debug env (Iop new_op) dbg
|
||||
(Array.append [|r1.(0)|] loc_arg) loc_res;
|
||||
self#insert env (Iop(Istackoffset(-stack_ofs))) [||] [||];
|
||||
self#insert env Ireturn loc_res [||]
|
||||
end
|
||||
| Icall_imm { func; label_after; } ->
|
||||
| Icall_imm { func; } ->
|
||||
let r1 = self#emit_tuple env new_args in
|
||||
let (loc_arg, stack_ofs) = Proc.loc_arguments (Reg.typv r1) in
|
||||
if stack_ofs = 0 then begin
|
||||
let call = Iop (Itailcall_imm { func; label_after; }) in
|
||||
let spacetime_reg =
|
||||
self#about_to_emit_call env call [| |] dbg
|
||||
in
|
||||
let call = Iop (Itailcall_imm { func; }) in
|
||||
self#insert_moves env r1 loc_arg;
|
||||
self#maybe_emit_spacetime_move env ~spacetime_reg;
|
||||
self#insert_debug env call dbg loc_arg [||];
|
||||
end else if func = !current_function_name then begin
|
||||
let call = Iop (Itailcall_imm { func; label_after; }) in
|
||||
let call = Iop (Itailcall_imm { func; }) in
|
||||
let loc_arg' = Proc.loc_parameters (Reg.typv r1) in
|
||||
let spacetime_reg =
|
||||
self#about_to_emit_call env call [| |] dbg
|
||||
in
|
||||
self#insert_moves env r1 loc_arg';
|
||||
self#maybe_emit_spacetime_move env ~spacetime_reg;
|
||||
self#insert_debug env call dbg loc_arg' [||];
|
||||
end else begin
|
||||
let rd = self#regs_for ty in
|
||||
let loc_res = Proc.loc_results (Reg.typv rd) in
|
||||
let spacetime_reg =
|
||||
self#about_to_emit_call env (Iop new_op) [| |] dbg
|
||||
in
|
||||
self#insert_move_args env r1 loc_arg stack_ofs;
|
||||
self#maybe_emit_spacetime_move env ~spacetime_reg;
|
||||
self#insert_debug env (Iop new_op) dbg loc_arg loc_res;
|
||||
self#insert env (Iop(Istackoffset(-stack_ofs))) [||] [||];
|
||||
self#insert env Ireturn loc_res [||]
|
||||
|
@ -1210,7 +1137,6 @@ method emit_tail (env:environment) exp =
|
|||
end
|
||||
| Cop _
|
||||
| Cconst_int _ | Cconst_natint _ | Cconst_float _ | Cconst_symbol _
|
||||
| Cblockheader _
|
||||
| Cvar _
|
||||
| Cassign _
|
||||
| Ctuple _
|
||||
|
@ -1222,16 +1148,8 @@ method private emit_tail_sequence env exp =
|
|||
s#emit_tail env exp;
|
||||
s#extract
|
||||
|
||||
(* Insertion of the function prologue *)
|
||||
|
||||
method insert_prologue _f ~loc_arg ~rarg ~spacetime_node_hole:_ ~env =
|
||||
self#insert_moves env loc_arg rarg;
|
||||
None
|
||||
|
||||
(* Sequentialization of a function definition *)
|
||||
|
||||
method initial_env () = env_empty
|
||||
|
||||
method emit_fundecl f =
|
||||
current_function_name := f.Cmm.fun_name;
|
||||
let rargs =
|
||||
|
@ -1240,37 +1158,19 @@ method emit_fundecl f =
|
|||
f.Cmm.fun_args in
|
||||
let rarg = Array.concat rargs in
|
||||
let loc_arg = Proc.loc_parameters (Reg.typv rarg) in
|
||||
(* To make it easier to add the Spacetime instrumentation code, we
|
||||
first emit the body and extract the resulting instruction sequence;
|
||||
then we emit the prologue followed by any Spacetime instrumentation. The
|
||||
sequence resulting from extracting the latter (prologue + instrumentation)
|
||||
together is then simply prepended to the body. *)
|
||||
let env =
|
||||
List.fold_right2
|
||||
(fun (id, _ty) r env -> env_add id r env)
|
||||
f.Cmm.fun_args rargs (self#initial_env ()) in
|
||||
let spacetime_node_hole, env =
|
||||
if not Config.spacetime then None, env
|
||||
else begin
|
||||
let reg = self#regs_for typ_int in
|
||||
let node_hole = V.create_local "spacetime_node_hole" in
|
||||
Some (node_hole, reg), env_add (VP.create node_hole) reg env
|
||||
end
|
||||
in
|
||||
f.Cmm.fun_args rargs env_empty in
|
||||
self#insert_moves env loc_arg rarg;
|
||||
self#emit_tail env f.Cmm.fun_body;
|
||||
let body = self#extract in
|
||||
instr_seq <- dummy_instr;
|
||||
let fun_spacetime_shape =
|
||||
self#insert_prologue f ~loc_arg ~rarg ~spacetime_node_hole ~env
|
||||
in
|
||||
let body = self#extract_core ~end_instr:body in
|
||||
instr_iter (fun instr -> self#mark_instr instr.Mach.desc) body;
|
||||
{ fun_name = f.Cmm.fun_name;
|
||||
fun_args = loc_arg;
|
||||
fun_body = body;
|
||||
fun_codegen_options = f.Cmm.fun_codegen_options;
|
||||
fun_dbg = f.Cmm.fun_dbg;
|
||||
fun_spacetime_shape;
|
||||
fun_num_stack_slots = Array.make Proc.num_register_classes 0;
|
||||
fun_contains_calls = !contains_calls;
|
||||
}
|
||||
|
|
|
@ -139,15 +139,13 @@ class virtual selector_generic : object
|
|||
above; overloading this is useful if Ispecific instructions need
|
||||
marking *)
|
||||
|
||||
(* The following method is the entry point and should not be overridden
|
||||
(except by [Spacetime_profiling]). *)
|
||||
(* The following method is the entry point and should not be overridden. *)
|
||||
method emit_fundecl : Cmm.fundecl -> Mach.fundecl
|
||||
|
||||
(* The following methods should not be overridden. They cannot be
|
||||
declared "private" in the current implementation because they
|
||||
are not always applied to "self", but ideally they should be private. *)
|
||||
method extract : Mach.instruction
|
||||
method extract_core : end_instr:Mach.instruction -> Mach.instruction
|
||||
method insert :
|
||||
environment -> Mach.instruction_desc -> Reg.t array -> Reg.t array -> unit
|
||||
method insert_debug :
|
||||
|
@ -163,33 +161,6 @@ class virtual selector_generic : object
|
|||
environment -> Cmm.expression -> Reg.t array option
|
||||
method emit_tail : environment -> Cmm.expression -> unit
|
||||
|
||||
(* Only for the use of [Spacetime_profiling]. *)
|
||||
method select_allocation : int -> Mach.operation
|
||||
method select_allocation_args : environment -> Reg.t array
|
||||
method select_checkbound : unit -> Mach.integer_operation
|
||||
method select_checkbound_extra_args : unit -> Cmm.expression list
|
||||
method emit_blockheader
|
||||
: environment
|
||||
-> nativeint
|
||||
-> Debuginfo.t
|
||||
-> Reg.t array option
|
||||
method about_to_emit_call
|
||||
: environment
|
||||
-> Mach.instruction_desc
|
||||
-> Reg.t array
|
||||
-> Debuginfo.t
|
||||
-> Reg.t array option
|
||||
method initial_env : unit -> environment
|
||||
method insert_prologue
|
||||
: Cmm.fundecl
|
||||
-> loc_arg:Reg.t array
|
||||
-> rarg:Reg.t array
|
||||
-> spacetime_node_hole:(Backend_var.t * Reg.t array) option
|
||||
-> env:environment
|
||||
-> Mach.spacetime_shape option
|
||||
|
||||
val mutable instr_seq : Mach.instruction
|
||||
|
||||
(* [contains_calls] is declared as a reference instance variable,
|
||||
instead of a mutable boolean instance variable,
|
||||
because the traversal uses functional object copies. *)
|
||||
|
|
|
@ -1,480 +0,0 @@
|
|||
(**************************************************************************)
|
||||
(* *)
|
||||
(* OCaml *)
|
||||
(* *)
|
||||
(* Mark Shinwell and Leo White, Jane Street Europe *)
|
||||
(* *)
|
||||
(* Copyright 2015--2018 Jane Street Group LLC *)
|
||||
(* *)
|
||||
(* All rights reserved. This file is distributed under the terms of *)
|
||||
(* the GNU Lesser General Public License version 2.1, with the *)
|
||||
(* special exception on linking described in the file LICENSE. *)
|
||||
(* *)
|
||||
(**************************************************************************)
|
||||
|
||||
[@@@ocaml.warning "+a-4-30-40-41-42"]
|
||||
|
||||
module V = Backend_var
|
||||
module VP = Backend_var.With_provenance
|
||||
|
||||
let node_num_header_words = 2 (* [Node_num_header_words] in the runtime. *)
|
||||
let index_within_node = ref node_num_header_words
|
||||
(* The [lazy]s are to ensure that we don't create [V.t]s at toplevel
|
||||
when not using Spacetime profiling. (This could cause stamps to differ
|
||||
between bytecode and native .cmis when no .mli is present, e.g.
|
||||
arch.ml.) *)
|
||||
let spacetime_node = ref (lazy (Cmm.Cvar (V.create_local "dummy")))
|
||||
let spacetime_node_ident = ref (lazy (V.create_local "dummy"))
|
||||
let current_function_label = ref None
|
||||
let direct_tail_call_point_indexes = ref []
|
||||
|
||||
let reverse_shape = ref ([] : Mach.spacetime_shape)
|
||||
|
||||
(* CR-someday mshinwell: This code could be updated to use [placeholder_dbg] as
|
||||
in [Cmmgen]. *)
|
||||
let cconst_int i = Cmm.Cconst_int (i, Debuginfo.none)
|
||||
let cconst_natint i = Cmm_helpers.natint_const_untagged Debuginfo.none i
|
||||
let cconst_symbol s = Cmm.Cconst_symbol (s, Debuginfo.none)
|
||||
|
||||
let something_was_instrumented () =
|
||||
!index_within_node > node_num_header_words
|
||||
|
||||
let next_index_within_node ~part_of_shape ~label =
|
||||
let index = !index_within_node in
|
||||
begin match part_of_shape with
|
||||
| Mach.Direct_call_point _ ->
|
||||
incr index_within_node;
|
||||
if Config.enable_call_counts then begin
|
||||
incr index_within_node
|
||||
end
|
||||
| Mach.Indirect_call_point ->
|
||||
incr index_within_node
|
||||
| Mach.Allocation_point ->
|
||||
incr index_within_node;
|
||||
incr index_within_node;
|
||||
incr index_within_node
|
||||
end;
|
||||
reverse_shape := (part_of_shape, label) :: !reverse_shape;
|
||||
index
|
||||
|
||||
let reset ~spacetime_node_ident:ident ~function_label =
|
||||
index_within_node := node_num_header_words;
|
||||
spacetime_node := lazy (Cmm.Cvar ident);
|
||||
spacetime_node_ident := lazy ident;
|
||||
direct_tail_call_point_indexes := [];
|
||||
current_function_label := Some function_label;
|
||||
reverse_shape := []
|
||||
|
||||
let code_for_function_prologue ~function_name ~fun_dbg:dbg ~node_hole =
|
||||
let node = V.create_local "node" in
|
||||
let new_node = V.create_local "new_node" in
|
||||
let must_allocate_node = V.create_local "must_allocate_node" in
|
||||
let is_new_node = V.create_local "is_new_node" in
|
||||
let no_tail_calls = List.length !direct_tail_call_point_indexes < 1 in
|
||||
let open Cmm in
|
||||
let initialize_direct_tail_call_points_and_return_node =
|
||||
let new_node_encoded = V.create_local "new_node_encoded" in
|
||||
(* The callee node pointers within direct tail call points must initially
|
||||
point back at the start of the current node and be marked as per
|
||||
[Encode_tail_caller_node] in the runtime. *)
|
||||
let indexes = !direct_tail_call_point_indexes in
|
||||
let body =
|
||||
List.fold_left (fun init_code index ->
|
||||
(* Cf. [Direct_callee_node] in the runtime. *)
|
||||
let offset_in_bytes = index * Arch.size_addr in
|
||||
Csequence (
|
||||
Cop (Cstore (Word_int, Lambda.Assignment),
|
||||
[Cop (Caddi, [Cvar new_node; cconst_int offset_in_bytes], dbg);
|
||||
Cvar new_node_encoded], dbg),
|
||||
init_code))
|
||||
(Cvar new_node)
|
||||
indexes
|
||||
in
|
||||
match indexes with
|
||||
| [] -> body
|
||||
| _ ->
|
||||
Clet (VP.create new_node_encoded,
|
||||
(* Cf. [Encode_tail_caller_node] in the runtime. *)
|
||||
Cop (Cor, [Cvar new_node; cconst_int 1], dbg),
|
||||
body)
|
||||
in
|
||||
let pc = V.create_local "pc" in
|
||||
Clet (VP.create node,
|
||||
Cop (Cload (Word_int, Asttypes.Mutable), [Cvar node_hole], dbg),
|
||||
Clet (VP.create must_allocate_node,
|
||||
Cop (Cand, [Cvar node; cconst_int 1], dbg),
|
||||
Cifthenelse (
|
||||
Cop (Ccmpi Cne, [Cvar must_allocate_node; cconst_int 1], dbg),
|
||||
dbg,
|
||||
Cvar node,
|
||||
dbg,
|
||||
Clet (VP.create is_new_node,
|
||||
Clet (VP.create pc, cconst_symbol function_name,
|
||||
Cop (Cextcall ("caml_spacetime_allocate_node",
|
||||
typ_int, [], false, None),
|
||||
[cconst_int (1 (* header *) + !index_within_node);
|
||||
Cvar pc;
|
||||
Cvar node_hole;
|
||||
],
|
||||
dbg)),
|
||||
Clet (VP.create new_node,
|
||||
Cop (Cload (Word_int, Asttypes.Mutable), [Cvar node_hole], dbg),
|
||||
if no_tail_calls then Cvar new_node
|
||||
else
|
||||
Cifthenelse (
|
||||
Cop (Ccmpi Ceq, [Cvar is_new_node; cconst_int 0], dbg),
|
||||
dbg,
|
||||
Cvar new_node,
|
||||
dbg,
|
||||
initialize_direct_tail_call_points_and_return_node,
|
||||
dbg))),
|
||||
dbg)))
|
||||
|
||||
let code_for_blockheader ~value's_header ~node ~dbg =
|
||||
let num_words = Nativeint.shift_right_logical value's_header 10 in
|
||||
let existing_profinfo = V.create_local "existing_profinfo" in
|
||||
let existing_count = V.create_local "existing_count" in
|
||||
let profinfo = V.create_local "profinfo" in
|
||||
let address_of_profinfo = V.create_local "address_of_profinfo" in
|
||||
let label = Cmm.new_label () in
|
||||
let index_within_node =
|
||||
next_index_within_node ~part_of_shape:Mach.Allocation_point ~label
|
||||
in
|
||||
let offset_into_node = Arch.size_addr * index_within_node in
|
||||
let open Cmm in
|
||||
let generate_new_profinfo =
|
||||
(* This will generate a static branch to a function that should usually
|
||||
be in the cache, which hopefully gives a good code size/performance
|
||||
balance.
|
||||
The "Some label" is important: it provides the link between the shape
|
||||
table, the allocation point, and the frame descriptor table---enabling
|
||||
the latter table to be used for resolving a program counter at such
|
||||
a point to a location.
|
||||
*)
|
||||
Cop (Cextcall ("caml_spacetime_generate_profinfo", typ_int, [],
|
||||
false, Some label),
|
||||
[Cvar address_of_profinfo;
|
||||
cconst_int (index_within_node + 1)],
|
||||
dbg)
|
||||
in
|
||||
(* Check if we have already allocated a profinfo value for this allocation
|
||||
point with the current backtrace. If so, use that value; if not,
|
||||
allocate a new one. *)
|
||||
Clet (VP.create address_of_profinfo,
|
||||
Cop (Caddi, [
|
||||
Cvar node;
|
||||
cconst_int offset_into_node;
|
||||
], dbg),
|
||||
Clet (VP.create existing_profinfo,
|
||||
Cop (Cload (Word_int, Asttypes.Mutable), [Cvar address_of_profinfo],
|
||||
dbg),
|
||||
Clet (VP.create profinfo,
|
||||
Cifthenelse (
|
||||
Cop (Ccmpi Cne, [Cvar existing_profinfo; cconst_int 1 (* () *)], dbg),
|
||||
dbg,
|
||||
Cvar existing_profinfo,
|
||||
dbg,
|
||||
generate_new_profinfo,
|
||||
dbg),
|
||||
Clet (VP.create existing_count,
|
||||
Cop (Cload (Word_int, Asttypes.Mutable), [
|
||||
Cop (Caddi,
|
||||
[Cvar address_of_profinfo; cconst_int Arch.size_addr], dbg)
|
||||
], dbg),
|
||||
Csequence (
|
||||
Cop (Cstore (Word_int, Lambda.Assignment),
|
||||
[Cop (Caddi,
|
||||
[Cvar address_of_profinfo; cconst_int Arch.size_addr], dbg);
|
||||
Cop (Caddi, [
|
||||
Cvar existing_count;
|
||||
(* N.B. "*2" since the count is an OCaml integer.
|
||||
The "1 +" is to count the value's header. *)
|
||||
cconst_int (2 * (1 + Nativeint.to_int num_words));
|
||||
], dbg);
|
||||
], dbg),
|
||||
(* [profinfo] looks like a black [Infix_tag] header. Instead of
|
||||
having to mask [profinfo] before ORing it with the desired
|
||||
header, we can use an XOR trick, to keep code size down. *)
|
||||
let value's_header =
|
||||
Nativeint.logxor value's_header
|
||||
(Nativeint.logor
|
||||
((Nativeint.logor (Nativeint.of_int Obj.infix_tag)
|
||||
(Nativeint.shift_left 3n (* <- Caml_black *) 8)))
|
||||
(Nativeint.shift_left
|
||||
(* The following is the [Infix_offset_val], in words. *)
|
||||
(Nativeint.of_int (index_within_node + 1)) 10))
|
||||
in
|
||||
Cop (Cxor, [Cvar profinfo; cconst_natint value's_header], dbg))))))
|
||||
|
||||
type callee =
|
||||
| Direct of string
|
||||
| Indirect of Cmm.expression
|
||||
|
||||
let code_for_call ~node ~callee ~is_tail ~label dbg =
|
||||
(* We treat self recursive calls as tail calls to avoid blow-ups in the
|
||||
graph. *)
|
||||
let is_self_recursive_call =
|
||||
match callee with
|
||||
| Direct callee ->
|
||||
begin match !current_function_label with
|
||||
| None -> Misc.fatal_error "[current_function_label] not set"
|
||||
| Some label -> String.equal callee label
|
||||
end
|
||||
| Indirect _ -> false
|
||||
in
|
||||
let is_tail = is_tail || is_self_recursive_call in
|
||||
let index_within_node =
|
||||
match callee with
|
||||
| Direct callee ->
|
||||
next_index_within_node
|
||||
~part_of_shape:(Mach.Direct_call_point { callee; })
|
||||
~label
|
||||
| Indirect _ ->
|
||||
next_index_within_node ~part_of_shape:Mach.Indirect_call_point ~label
|
||||
in
|
||||
begin match callee with
|
||||
(* If this is a direct tail call point, we need to note down its index,
|
||||
so the correct initialization code can be emitted in the prologue. *)
|
||||
| Direct _ when is_tail ->
|
||||
direct_tail_call_point_indexes :=
|
||||
index_within_node::!direct_tail_call_point_indexes
|
||||
| Direct _ | Indirect _ -> ()
|
||||
end;
|
||||
let place_within_node = V.create_local "place_within_node" in
|
||||
let open Cmm in
|
||||
Clet (VP.create place_within_node,
|
||||
Cop (Caddi, [node; cconst_int (index_within_node * Arch.size_addr)], dbg),
|
||||
(* The following code returns the address that is to be moved into the
|
||||
(hard) node hole pointer register immediately before the call.
|
||||
(That move is inserted in [Selectgen].) *)
|
||||
match callee with
|
||||
| Direct _callee ->
|
||||
if Config.enable_call_counts then begin
|
||||
let count_addr = V.create_local "call_count_addr" in
|
||||
let count = V.create_local "call_count" in
|
||||
Clet (VP.create count_addr,
|
||||
Cop (Caddi, [Cvar place_within_node; cconst_int Arch.size_addr], dbg),
|
||||
Clet (VP.create count,
|
||||
Cop (Cload (Word_int, Asttypes.Mutable), [Cvar count_addr], dbg),
|
||||
Csequence (
|
||||
Cop (Cstore (Word_int, Lambda.Assignment),
|
||||
(* Adding 2 really means adding 1; the count is encoded
|
||||
as an OCaml integer. *)
|
||||
[Cvar count_addr; Cop (Caddi, [Cvar count; cconst_int 2], dbg)],
|
||||
dbg),
|
||||
Cvar place_within_node)))
|
||||
end else begin
|
||||
Cvar place_within_node
|
||||
end
|
||||
| Indirect callee ->
|
||||
let caller_node =
|
||||
if is_tail then node
|
||||
else cconst_int 1 (* [Val_unit] *)
|
||||
in
|
||||
Cop (Cextcall ("caml_spacetime_indirect_node_hole_ptr",
|
||||
typ_int, [], false, None),
|
||||
[callee; Cvar place_within_node; caller_node],
|
||||
dbg))
|
||||
|
||||
class virtual instruction_selection = object (self)
|
||||
inherit Selectgen.selector_generic as super
|
||||
|
||||
(* [disable_instrumentation] ensures that we don't try to instrument the
|
||||
instrumentation... *)
|
||||
val mutable disable_instrumentation = false
|
||||
|
||||
method private instrument_direct_call ~env ~func ~is_tail ~label_after dbg =
|
||||
let instrumentation =
|
||||
code_for_call
|
||||
~node:(Lazy.force !spacetime_node)
|
||||
~callee:(Direct func)
|
||||
~is_tail
|
||||
~label:label_after
|
||||
dbg
|
||||
in
|
||||
match self#emit_expr env instrumentation with
|
||||
| None -> assert false
|
||||
| Some reg -> Some reg
|
||||
|
||||
method private instrument_indirect_call ~env ~callee ~is_tail
|
||||
~label_after dbg =
|
||||
(* [callee] is a pseudoregister, so we have to bind it in the environment
|
||||
and reference the variable to which it is bound. *)
|
||||
let callee_ident = V.create_local "callee" in
|
||||
let env = Selectgen.env_add (VP.create callee_ident) [| callee |] env in
|
||||
let instrumentation =
|
||||
code_for_call
|
||||
~node:(Lazy.force !spacetime_node)
|
||||
~callee:(Indirect (Cmm.Cvar callee_ident))
|
||||
~is_tail
|
||||
~label:label_after
|
||||
dbg
|
||||
in
|
||||
match self#emit_expr env instrumentation with
|
||||
| None -> assert false
|
||||
| Some reg -> Some reg
|
||||
|
||||
method private can_instrument () =
|
||||
Config.spacetime && not disable_instrumentation
|
||||
|
||||
method! about_to_emit_call env desc arg dbg =
|
||||
if not (self#can_instrument ()) then None
|
||||
else
|
||||
let module M = Mach in
|
||||
match desc with
|
||||
| M.Iop (M.Icall_imm { func; label_after; }) ->
|
||||
assert (Array.length arg = 0);
|
||||
self#instrument_direct_call ~env ~func ~is_tail:false ~label_after dbg
|
||||
| M.Iop (M.Icall_ind { label_after; }) ->
|
||||
assert (Array.length arg = 1);
|
||||
self#instrument_indirect_call ~env ~callee:arg.(0)
|
||||
~is_tail:false ~label_after dbg
|
||||
| M.Iop (M.Itailcall_imm { func; label_after; }) ->
|
||||
assert (Array.length arg = 0);
|
||||
self#instrument_direct_call ~env ~func ~is_tail:true ~label_after dbg
|
||||
| M.Iop (M.Itailcall_ind { label_after; }) ->
|
||||
assert (Array.length arg = 1);
|
||||
self#instrument_indirect_call ~env ~callee:arg.(0)
|
||||
~is_tail:true ~label_after dbg
|
||||
| M.Iop (M.Iextcall { func; alloc = true; label_after; _}) ->
|
||||
(* N.B. No need to instrument "noalloc" external calls. *)
|
||||
assert (Array.length arg = 0);
|
||||
self#instrument_direct_call ~env ~func ~is_tail:false ~label_after dbg
|
||||
| _ -> None
|
||||
|
||||
method private instrument_blockheader ~env ~value's_header ~dbg =
|
||||
let instrumentation =
|
||||
code_for_blockheader
|
||||
~node:(Lazy.force !spacetime_node_ident)
|
||||
~value's_header ~dbg
|
||||
in
|
||||
self#emit_expr env instrumentation
|
||||
|
||||
method private emit_prologue f ~node_hole ~env =
|
||||
(* We don't need the prologue unless we inserted some instrumentation.
|
||||
This corresponds to adding the prologue if the function contains one
|
||||
or more call or allocation points. *)
|
||||
if something_was_instrumented () then begin
|
||||
let prologue_cmm =
|
||||
code_for_function_prologue ~function_name:f.Cmm.fun_name ~node_hole
|
||||
~fun_dbg:f.Cmm.fun_dbg
|
||||
in
|
||||
disable_instrumentation <- true;
|
||||
let node_temp_reg =
|
||||
match self#emit_expr env prologue_cmm with
|
||||
| None ->
|
||||
Misc.fatal_error "Spacetime prologue instruction \
|
||||
selection did not yield a destination register"
|
||||
| Some node_temp_reg -> node_temp_reg
|
||||
in
|
||||
disable_instrumentation <- false;
|
||||
let node = Lazy.force !spacetime_node_ident in
|
||||
let node_reg = Selectgen.env_find node env in
|
||||
self#insert_moves env node_temp_reg node_reg
|
||||
end
|
||||
|
||||
method! emit_blockheader env n dbg =
|
||||
if self#can_instrument () then begin
|
||||
disable_instrumentation <- true;
|
||||
let result = self#instrument_blockheader ~env ~value's_header:n ~dbg in
|
||||
disable_instrumentation <- false;
|
||||
result
|
||||
end else begin
|
||||
super#emit_blockheader env n dbg
|
||||
end
|
||||
|
||||
method! select_allocation bytes =
|
||||
if self#can_instrument () then begin
|
||||
(* Leave space for a direct call point. We cannot easily insert any
|
||||
instrumentation code, so the fields are filled in instead by
|
||||
[caml_spacetime_caml_garbage_collection]. *)
|
||||
let label = Cmm.new_label () in
|
||||
let index =
|
||||
next_index_within_node
|
||||
~part_of_shape:(Mach.Direct_call_point { callee = "caml_call_gc"; })
|
||||
~label
|
||||
in
|
||||
Mach.Ialloc {
|
||||
bytes;
|
||||
dbginfo = [];
|
||||
label_after_call_gc = Some label;
|
||||
spacetime_index = index;
|
||||
}
|
||||
end else begin
|
||||
super#select_allocation bytes
|
||||
end
|
||||
|
||||
method! select_allocation_args env =
|
||||
if self#can_instrument () then begin
|
||||
let regs = Selectgen.env_find (Lazy.force !spacetime_node_ident) env in
|
||||
match regs with
|
||||
| [| reg |] -> [| reg |]
|
||||
| _ -> failwith "Expected one register only for spacetime_node_ident"
|
||||
end else begin
|
||||
super#select_allocation_args env
|
||||
end
|
||||
|
||||
method! select_checkbound () =
|
||||
(* This follows [select_allocation], above. *)
|
||||
if self#can_instrument () then begin
|
||||
let label = Cmm.new_label () in
|
||||
let index =
|
||||
next_index_within_node
|
||||
~part_of_shape:(
|
||||
Mach.Direct_call_point { callee = "caml_ml_array_bound_error"; })
|
||||
~label
|
||||
in
|
||||
Mach.Icheckbound {
|
||||
label_after_error = Some label;
|
||||
spacetime_index = index;
|
||||
}
|
||||
end else begin
|
||||
super#select_checkbound ()
|
||||
end
|
||||
|
||||
method! select_checkbound_extra_args () =
|
||||
if self#can_instrument () then begin
|
||||
(* This follows [select_allocation_args], above. *)
|
||||
[Cmm.Cvar (Lazy.force !spacetime_node_ident)]
|
||||
end else begin
|
||||
super#select_checkbound_extra_args ()
|
||||
end
|
||||
|
||||
method! initial_env () =
|
||||
let env = super#initial_env () in
|
||||
if Config.spacetime then
|
||||
Selectgen.env_add (VP.create (Lazy.force !spacetime_node_ident))
|
||||
(self#regs_for Cmm.typ_int) env
|
||||
else
|
||||
env
|
||||
|
||||
method! emit_fundecl f =
|
||||
if Config.spacetime then begin
|
||||
disable_instrumentation <- false;
|
||||
let node = V.create_local "spacetime_node" in
|
||||
reset ~spacetime_node_ident:node ~function_label:f.Cmm.fun_name
|
||||
end;
|
||||
super#emit_fundecl f
|
||||
|
||||
method! insert_prologue f ~loc_arg ~rarg ~spacetime_node_hole ~env =
|
||||
let fun_spacetime_shape =
|
||||
super#insert_prologue f ~loc_arg ~rarg ~spacetime_node_hole ~env
|
||||
in
|
||||
(* CR-soon mshinwell: add check to make sure the node size doesn't exceed
|
||||
the chunk size of the allocator *)
|
||||
if not Config.spacetime then fun_spacetime_shape
|
||||
else begin
|
||||
let node_hole, node_hole_reg =
|
||||
match spacetime_node_hole with
|
||||
| None -> assert false
|
||||
| Some (node_hole, reg) -> node_hole, reg
|
||||
in
|
||||
self#insert_moves env [| Proc.loc_spacetime_node_hole |] node_hole_reg;
|
||||
self#emit_prologue f ~node_hole ~env;
|
||||
match !reverse_shape with
|
||||
| [] -> None
|
||||
(* N.B. We do not reverse the shape list, since the function that
|
||||
reconstructs it (caml_spacetime_shape_table) reverses it again. *)
|
||||
| reverse_shape -> Some reverse_shape
|
||||
end
|
||||
end
|
|
@ -1,17 +0,0 @@
|
|||
(**************************************************************************)
|
||||
(* *)
|
||||
(* OCaml *)
|
||||
(* *)
|
||||
(* Mark Shinwell and Leo White, Jane Street Europe *)
|
||||
(* *)
|
||||
(* Copyright 2015--2016 Jane Street Group LLC *)
|
||||
(* *)
|
||||
(* All rights reserved. This file is distributed under the terms of *)
|
||||
(* the GNU Lesser General Public License version 2.1, with the *)
|
||||
(* special exception on linking described in the file LICENSE. *)
|
||||
(* *)
|
||||
(**************************************************************************)
|
||||
|
||||
(** Insertion of instrumentation code for Spacetime profiling. *)
|
||||
|
||||
class virtual instruction_selection : Selectgen.selector_generic
|
|
@ -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 { alloc = 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)
|
||||
|
@ -294,7 +294,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
|
||||
|
@ -306,8 +306,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(Ialloc _)
|
||||
| Iop(Iintop (Icheckbound _)) | Iop(Iintop_imm((Icheckbound _), _)) ->
|
||||
Iop(Icall_ind) | Iop(Icall_imm _) | Iop(Iextcall _) | Iop(Ialloc _)
|
||||
| Iop(Iintop (Icheckbound)) | Iop(Iintop_imm(Icheckbound, _)) ->
|
||||
Reg.Set.union before1 !spill_at_raise
|
||||
| _ ->
|
||||
before1 in
|
||||
|
@ -431,7 +431,6 @@ let fundecl f =
|
|||
fun_body = new_body;
|
||||
fun_codegen_options = f.fun_codegen_options;
|
||||
fun_dbg = f.fun_dbg;
|
||||
fun_spacetime_shape = f.fun_spacetime_shape;
|
||||
fun_num_stack_slots = f.fun_num_stack_slots;
|
||||
fun_contains_calls = f.fun_contains_calls;
|
||||
}
|
||||
|
|
|
@ -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_debug i.desc (subst_regs i.arg sub) [||] i.dbg i.next,
|
||||
None)
|
||||
| Iop Ireload when i.res.(0).loc = Unknown ->
|
||||
|
@ -219,7 +219,6 @@ let fundecl f =
|
|||
fun_body = new_body;
|
||||
fun_codegen_options = f.fun_codegen_options;
|
||||
fun_dbg = f.fun_dbg;
|
||||
fun_spacetime_shape = f.fun_spacetime_shape;
|
||||
fun_num_stack_slots = f.fun_num_stack_slots;
|
||||
fun_contains_calls = f.fun_contains_calls;
|
||||
}
|
||||
|
|
BIN
boot/ocamlc
BIN
boot/ocamlc
Binary file not shown.
BIN
boot/ocamllex
BIN
boot/ocamllex
Binary file not shown.
|
@ -135,7 +135,7 @@ ASMCOMP=\
|
|||
asmcomp/cmmgen.cmo \
|
||||
asmcomp/interval.cmo \
|
||||
asmcomp/printmach.cmo asmcomp/selectgen.cmo \
|
||||
asmcomp/spacetime_profiling.cmo asmcomp/selection.cmo \
|
||||
asmcomp/selection.cmo \
|
||||
asmcomp/comballoc.cmo \
|
||||
asmcomp/CSEgen.cmo asmcomp/CSE.cmo \
|
||||
asmcomp/liveness.cmo \
|
||||
|
|
|
@ -731,8 +731,6 @@ ac_ct_LD
|
|||
LD
|
||||
DEFAULT_STRING
|
||||
WINDOWS_UNICODE_MODE
|
||||
LIBUNWIND_LIB_DIR
|
||||
LIBUNWIND_INCLUDE_DIR
|
||||
DLLIBS
|
||||
PARTIALLD
|
||||
target_os
|
||||
|
@ -763,11 +761,6 @@ windows_unicode
|
|||
max_testsuite_dir_retries
|
||||
flambda_invariants
|
||||
flambda
|
||||
libunwind_link_flags
|
||||
libunwind_include_flags
|
||||
libunwind_available
|
||||
call_counts
|
||||
spacetime
|
||||
frame_pointers
|
||||
profinfo_width
|
||||
profinfo
|
||||
|
@ -889,7 +882,6 @@ enable_dependency_generation
|
|||
enable_instrumented_runtime
|
||||
enable_vmthreads
|
||||
enable_systhreads
|
||||
with_libunwind
|
||||
enable_graph_lib
|
||||
enable_str_lib
|
||||
enable_unix_lib
|
||||
|
@ -899,8 +891,6 @@ enable_ocamltest
|
|||
enable_frame_pointers
|
||||
enable_naked_pointers
|
||||
enable_naked_pointers_checker
|
||||
enable_spacetime
|
||||
enable_call_counts
|
||||
enable_cfi
|
||||
enable_installing_source_artifacts
|
||||
enable_installing_bytecode_programs
|
||||
|
@ -931,8 +921,6 @@ AS
|
|||
ASPP
|
||||
PARTIALLD
|
||||
DLLIBS
|
||||
LIBUNWIND_INCLUDE_DIR
|
||||
LIBUNWIND_LIB_DIR
|
||||
WINDOWS_UNICODE_MODE
|
||||
DEFAULT_STRING
|
||||
CC
|
||||
|
@ -1574,8 +1562,6 @@ Optional Features:
|
|||
do not allow naked pointers
|
||||
--enable-naked-pointers-checker
|
||||
enable the naked pointers checker
|
||||
--enable-spacetime build the spacetime profiler
|
||||
--disable-call-counts disable the call counts in spacetime
|
||||
--disable-cfi disable the CFI directives in assembly files
|
||||
--enable-installing-source-artifacts
|
||||
install *.cmt* and *.mli files
|
||||
|
@ -1607,7 +1593,6 @@ Optional Features:
|
|||
Optional Packages:
|
||||
--with-PACKAGE[=ARG] use PACKAGE [ARG=yes]
|
||||
--without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no)
|
||||
--without-libunwind disable libunwind support for Spacetime profiling
|
||||
--with-target-bindir location of binary programs on target system
|
||||
--with-afl use the AFL fuzzer
|
||||
--with-pic[=PKGS] try to use only PIC/non-PIC objects [default=use
|
||||
|
@ -1625,10 +1610,6 @@ Some influential environment variables:
|
|||
PARTIALLD how to build partial (relocatable) object files
|
||||
DLLIBS which libraries to use (in addition to -ldl) to load dynamic
|
||||
libs
|
||||
LIBUNWIND_INCLUDE_DIR
|
||||
location of header files for libunwind
|
||||
LIBUNWIND_LIB_DIR
|
||||
location of library files for libunwind
|
||||
WINDOWS_UNICODE_MODE
|
||||
how to handle Unicode under Windows: ansi, compatible
|
||||
DEFAULT_STRING
|
||||
|
@ -2937,11 +2918,6 @@ VERSION=4.12.0+dev0-2020-04-22
|
|||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
@ -3143,17 +3119,6 @@ if test "${enable_systhreads+set}" = set; then :
|
|||
fi
|
||||
|
||||
|
||||
|
||||
# Check whether --with-libunwind was given.
|
||||
if test "${with_libunwind+set}" = set; then :
|
||||
withval=$with_libunwind;
|
||||
fi
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# Check whether --enable-graph-lib was given.
|
||||
if test "${enable_graph_lib+set}" = set; then :
|
||||
enableval=$enable_graph_lib; as_fn_error $? "The graphics library is no longer distributed with OCaml \
|
||||
|
@ -3212,18 +3177,6 @@ if test "${enable_naked_pointers_checker+set}" = set; then :
|
|||
fi
|
||||
|
||||
|
||||
# Check whether --enable-spacetime was given.
|
||||
if test "${enable_spacetime+set}" = set; then :
|
||||
enableval=$enable_spacetime;
|
||||
fi
|
||||
|
||||
|
||||
# Check whether --enable-call-counts was given.
|
||||
if test "${enable_call_counts+set}" = set; then :
|
||||
enableval=$enable_call_counts;
|
||||
fi
|
||||
|
||||
|
||||
# Check whether --enable-cfi was given.
|
||||
if test "${enable_cfi+set}" = set; then :
|
||||
enableval=$enable_cfi;
|
||||
|
@ -14101,10 +14054,6 @@ else
|
|||
PACKLD="$PARTIALLD -o \$(EMPTY)"
|
||||
fi
|
||||
|
||||
if test $arch != "none" && $arch64 ; then :
|
||||
otherlibraries="$otherlibraries raw_spacetime_lib"
|
||||
fi
|
||||
|
||||
# Disable PIE at link time when ocamlopt does not produce position-independent
|
||||
# code and the system produces PIE executables by default and demands PIC
|
||||
# object files to do so.
|
||||
|
@ -16753,143 +16702,6 @@ fi
|
|||
|
||||
|
||||
|
||||
# Spacetime profiling, including libunwind detection
|
||||
|
||||
# The number of bits used for profiling information is configurable here.
|
||||
# The more bits used for profiling, the smaller will be Max_wosize.
|
||||
# Note that PROFINFO_WIDTH must still be defined even if not configuring
|
||||
# for Spacetime (see comment in runtime/caml/mlvalues.h on [Profinfo_hd]).
|
||||
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether to build spacetime" >&5
|
||||
$as_echo_n "checking whether to build spacetime... " >&6; }
|
||||
if test x"$enable_spacetime" != "xyes" ; then :
|
||||
spacetime=false
|
||||
call_counts=true # as in original script but should probably be false
|
||||
libunwind_available=false
|
||||
libunwind_include_flags=
|
||||
libunwind_link_flags=
|
||||
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
|
||||
$as_echo "no" >&6; }
|
||||
else
|
||||
case $arch in #(
|
||||
amd64) :
|
||||
spacetime_supported=true ;; #(
|
||||
*) :
|
||||
spacetime_supported=false ;;
|
||||
esac
|
||||
if $spacetime_supported; then :
|
||||
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5
|
||||
$as_echo "yes" >&6; }
|
||||
spacetime=true
|
||||
profinfo=true
|
||||
profinfo_width=26
|
||||
$as_echo "#define WITH_SPACETIME 1" >>confdefs.h
|
||||
|
||||
if test x"$enable_call_counts" != "xno"; then :
|
||||
call_counts=true
|
||||
$as_echo "#define ENABLE_CALL_COUNTS 1" >>confdefs.h
|
||||
|
||||
else
|
||||
call_counts=false
|
||||
fi
|
||||
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether to use libunwind" >&5
|
||||
$as_echo_n "checking whether to use libunwind... " >&6; }
|
||||
if test x"$with_libunwind" = "xno"; then :
|
||||
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: disabled" >&5
|
||||
$as_echo "disabled" >&6; }
|
||||
else
|
||||
if test x"$with_libunwind" = "x"; then :
|
||||
libunwind_requested=false
|
||||
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: if available" >&5
|
||||
$as_echo "if available" >&6; }
|
||||
else
|
||||
libunwind_requested=true
|
||||
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: requested" >&5
|
||||
$as_echo "requested" >&6; }
|
||||
if test x"$with_libunwind" != "xyes"; then :
|
||||
if test x"$LIBUNWIND_INCLUDE_DIR" = "x"; then :
|
||||
LIBUNWIND_INCLUDE_DIR="$with_libunwind/include"
|
||||
fi
|
||||
if test x"$LIBUNWIND_LIB_DIR" = "x"; then :
|
||||
LIBUNWIND_LIB_DIR="$with_libunwind/lib"
|
||||
fi
|
||||
|
||||
fi
|
||||
|
||||
fi
|
||||
if test "$system" = "macosx"; then :
|
||||
if test x"$LIBUNWIND_INCLUDE_DIR" != x -o \
|
||||
x"$LIBUNWIND_LIB_DIR" != x; then :
|
||||
{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: On MacOSX, specifying paths for libunwind headers or libraries is strongly discouraged. It is recommended to rely on the defaults provided by the configure script" >&5
|
||||
$as_echo "$as_me: WARNING: On MacOSX, specifying paths for libunwind headers or libraries is strongly discouraged. It is recommended to rely on the defaults provided by the configure script" >&2;}
|
||||
fi
|
||||
fi
|
||||
|
||||
if test x"$LIBUNWIND_INCLUDE_DIR" != x; then :
|
||||
libunwind_include_flags="-I$LIBUNWIND_INCLUDE_DIR"
|
||||
else
|
||||
libunwind_include_flags=""
|
||||
fi
|
||||
|
||||
case "$system" in #(
|
||||
"macosx") :
|
||||
libunwind_link_flags="-framework System" ;; #(
|
||||
*) :
|
||||
libunwind_link_flags="-lunwind -lunwind-x86_64" ;;
|
||||
esac
|
||||
|
||||
if test x"$LIBUNWIND_LIB_DIR" != x; then :
|
||||
libunwind_link_flags="-L$LIBUNWIND_LIB_DIR $libunwind_link_flags"
|
||||
fi
|
||||
|
||||
|
||||
SAVED_CFLAGS="$CFLAGS"
|
||||
SAVED_LDFLAGS="$LDFLAGS"
|
||||
CFLAGS="$CFLAGS $libunwind_include_flags"
|
||||
LDFLAGS="$LDFLAGS $libunwind_link_flags"
|
||||
ac_fn_c_check_header_mongrel "$LINENO" "libunwind.h" "ac_cv_header_libunwind_h" "$ac_includes_default"
|
||||
if test "x$ac_cv_header_libunwind_h" = xyes; then :
|
||||
$as_echo "#define HAS_LIBUNWIND 1" >>confdefs.h
|
||||
|
||||
libunwind_available=true
|
||||
else
|
||||
libunwind_available=false
|
||||
fi
|
||||
|
||||
|
||||
LDFLAGS="$SAVED_LDFLAGS"
|
||||
CFLAGS="$SAVED_CFLAGS"
|
||||
|
||||
|
||||
if $libunwind_requested && ! $libunwind_available; then :
|
||||
as_fn_error $? "libunwind was requested but can not be found" "$LINENO" 5
|
||||
fi
|
||||
|
||||
# We need unwinding information at runtime, but since we use
|
||||
# -no_compact_unwind, we also need -keep_dwarf_unwind otherwise
|
||||
# the OS X linker will chuck away the DWARF-like (.eh_frame)
|
||||
# information. (Older versions of OS X don't provide this.)
|
||||
|
||||
if $libunwind_available && test x"$system" = "xmacosx"; then :
|
||||
extra_flags="-Wl,-keep_dwarf_unwind"
|
||||
mkexe="$mkexe $extra_flags"
|
||||
mksharedlib="$mksharedlib $extra_flags"
|
||||
fi
|
||||
fi
|
||||
|
||||
else
|
||||
if test x"$enable_spacetime" = "xyes"; then :
|
||||
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: requested but not supported" >&5
|
||||
$as_echo "requested but not supported" >&6; }
|
||||
as_fn_error $? "exiting" "$LINENO" 5
|
||||
else
|
||||
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
|
||||
$as_echo "no" >&6; }
|
||||
fi
|
||||
|
||||
fi
|
||||
|
||||
fi
|
||||
|
||||
cat >>confdefs.h <<_ACEOF
|
||||
#define PROFINFO_WIDTH $profinfo_width
|
||||
_ACEOF
|
||||
|
|
110
configure.ac
110
configure.ac
|
@ -150,11 +150,6 @@ AC_SUBST([install_source_artifacts])
|
|||
AC_SUBST([profinfo])
|
||||
AC_SUBST([profinfo_width])
|
||||
AC_SUBST([frame_pointers])
|
||||
AC_SUBST([spacetime])
|
||||
AC_SUBST([call_counts])
|
||||
AC_SUBST([libunwind_available])
|
||||
AC_SUBST([libunwind_include_flags])
|
||||
AC_SUBST([libunwind_link_flags])
|
||||
AC_SUBST([flambda])
|
||||
AC_SUBST([flambda_invariants])
|
||||
AC_SUBST([max_testsuite_dir_retries])
|
||||
|
@ -242,16 +237,6 @@ AC_ARG_ENABLE([systhreads],
|
|||
[AS_HELP_STRING([--disable-systhreads],
|
||||
[disable the Win32/POSIX threads library])])
|
||||
|
||||
AC_ARG_WITH([libunwind],
|
||||
[AS_HELP_STRING([--without-libunwind],
|
||||
[disable libunwind support for Spacetime profiling])])
|
||||
|
||||
AC_ARG_VAR([LIBUNWIND_INCLUDE_DIR],
|
||||
[location of header files for libunwind])
|
||||
|
||||
AC_ARG_VAR([LIBUNWIND_LIB_DIR],
|
||||
[location of library files for libunwind])
|
||||
|
||||
AC_ARG_ENABLE([graph-lib], [],
|
||||
[AC_MSG_ERROR([The graphics library is no longer distributed with OCaml \
|
||||
since version 4.09. It is now distributed as a separate "graphics" package: \
|
||||
|
@ -292,14 +277,6 @@ AC_ARG_ENABLE([naked-pointers-checker],
|
|||
[AS_HELP_STRING([--enable-naked-pointers-checker],
|
||||
[enable the naked pointers checker])])
|
||||
|
||||
AC_ARG_ENABLE([spacetime],
|
||||
[AS_HELP_STRING([--enable-spacetime],
|
||||
[build the spacetime profiler])])
|
||||
|
||||
AC_ARG_ENABLE([call-counts],
|
||||
[AS_HELP_STRING([--disable-call-counts],
|
||||
[disable the call counts in spacetime])])
|
||||
|
||||
AC_ARG_ENABLE([cfi],
|
||||
[AS_HELP_STRING([--disable-cfi],
|
||||
[disable the CFI directives in assembly files])])
|
||||
|
@ -1042,9 +1019,6 @@ AS_IF([test -z "$PARTIALLD"],
|
|||
[PACKLD="$DIRECT_LD -r$PACKLD_FLAGS -o \$(EMPTY)"])],
|
||||
[PACKLD="$PARTIALLD -o \$(EMPTY)"])
|
||||
|
||||
AS_IF([test $arch != "none" && $arch64 ],
|
||||
[otherlibraries="$otherlibraries raw_spacetime_lib"])
|
||||
|
||||
# Disable PIE at link time when ocamlopt does not produce position-independent
|
||||
# code and the system produces PIE executables by default and demands PIC
|
||||
# object files to do so.
|
||||
|
@ -1717,90 +1691,6 @@ AS_IF([test x"$enable_naked_pointers_checker" = "xyes" ],
|
|||
## Check for mmap support for huge pages and contiguous heap
|
||||
OCAML_MMAP_SUPPORTS_HUGE_PAGES
|
||||
|
||||
# Spacetime profiling, including libunwind detection
|
||||
|
||||
# The number of bits used for profiling information is configurable here.
|
||||
# The more bits used for profiling, the smaller will be Max_wosize.
|
||||
# Note that PROFINFO_WIDTH must still be defined even if not configuring
|
||||
# for Spacetime (see comment in runtime/caml/mlvalues.h on [Profinfo_hd]).
|
||||
AC_MSG_CHECKING([whether to build spacetime])
|
||||
AS_IF([test x"$enable_spacetime" != "xyes" ],
|
||||
[spacetime=false
|
||||
call_counts=true # as in original script but should probably be false
|
||||
libunwind_available=false
|
||||
libunwind_include_flags=
|
||||
libunwind_link_flags=
|
||||
AC_MSG_RESULT([no])],
|
||||
[AS_CASE([$arch],
|
||||
[amd64], [spacetime_supported=true],
|
||||
[spacetime_supported=false])
|
||||
AS_IF([$spacetime_supported],
|
||||
[AC_MSG_RESULT([yes])
|
||||
spacetime=true
|
||||
profinfo=true
|
||||
profinfo_width=26
|
||||
AC_DEFINE([WITH_SPACETIME])
|
||||
AS_IF([test x"$enable_call_counts" != "xno"],
|
||||
[call_counts=true
|
||||
AC_DEFINE([ENABLE_CALL_COUNTS])],
|
||||
[call_counts=false])
|
||||
AC_MSG_CHECKING([whether to use libunwind])
|
||||
AS_IF([test x"$with_libunwind" = "xno"],
|
||||
[AC_MSG_RESULT([disabled])],
|
||||
[AS_IF([test x"$with_libunwind" = "x"],
|
||||
[libunwind_requested=false
|
||||
AC_MSG_RESULT([if available])],
|
||||
[libunwind_requested=true
|
||||
AC_MSG_RESULT([requested])
|
||||
AS_IF([test x"$with_libunwind" != "xyes"],
|
||||
[AS_IF([test x"$LIBUNWIND_INCLUDE_DIR" = "x"],
|
||||
[LIBUNWIND_INCLUDE_DIR="$with_libunwind/include"])
|
||||
AS_IF([test x"$LIBUNWIND_LIB_DIR" = "x"],
|
||||
[LIBUNWIND_LIB_DIR="$with_libunwind/lib"])
|
||||
])
|
||||
])
|
||||
AS_IF([test "$system" = "macosx"],
|
||||
[AS_IF([test x"$LIBUNWIND_INCLUDE_DIR" != x -o \
|
||||
x"$LIBUNWIND_LIB_DIR" != x],
|
||||
[AC_MSG_WARN(m4_normalize([
|
||||
On MacOSX, specifying paths for libunwind headers or libraries
|
||||
is strongly discouraged. It is recommended to rely on the
|
||||
defaults provided by the configure script
|
||||
]))])])
|
||||
|
||||
AS_IF([test x"$LIBUNWIND_INCLUDE_DIR" != x],
|
||||
[libunwind_include_flags="-I$LIBUNWIND_INCLUDE_DIR"],
|
||||
[libunwind_include_flags=""])
|
||||
|
||||
AS_CASE(["$system"],
|
||||
["macosx"], [libunwind_link_flags="-framework System"],
|
||||
[libunwind_link_flags="-lunwind -lunwind-x86_64"])
|
||||
|
||||
AS_IF([test x"$LIBUNWIND_LIB_DIR" != x],
|
||||
[libunwind_link_flags="-L$LIBUNWIND_LIB_DIR $libunwind_link_flags"])
|
||||
|
||||
OCAML_CHECK_LIBUNWIND
|
||||
|
||||
AS_IF([$libunwind_requested && ! $libunwind_available],
|
||||
[AC_MSG_ERROR([libunwind was requested but can not be found])])
|
||||
|
||||
# We need unwinding information at runtime, but since we use
|
||||
# -no_compact_unwind, we also need -keep_dwarf_unwind otherwise
|
||||
# the OS X linker will chuck away the DWARF-like (.eh_frame)
|
||||
# information. (Older versions of OS X don't provide this.)
|
||||
|
||||
AS_IF([$libunwind_available && test x"$system" = "xmacosx"],
|
||||
[extra_flags="-Wl,-keep_dwarf_unwind"
|
||||
mkexe="$mkexe $extra_flags"
|
||||
mksharedlib="$mksharedlib $extra_flags"])])
|
||||
],
|
||||
[AS_IF([test x"$enable_spacetime" = "xyes"],
|
||||
[AC_MSG_RESULT([requested but not supported])
|
||||
AC_MSG_ERROR([exiting])],
|
||||
[AC_MSG_RESULT([no])])
|
||||
])
|
||||
])
|
||||
|
||||
AC_DEFINE_UNQUOTED([PROFINFO_WIDTH], [$profinfo_width])
|
||||
AS_IF([$profinfo], [AC_DEFINE([WITH_PROFINFO])])
|
||||
|
||||
|
|
2
dune
2
dune
|
@ -152,7 +152,7 @@
|
|||
CSE CSEgen
|
||||
deadcode domainstate emit emitaux interf interval linear linearize linscan
|
||||
liveness mach printcmm printlinear printmach proc reg reload reloadgen
|
||||
schedgen scheduling selectgen selection spacetime_profiling spill split
|
||||
schedgen scheduling selectgen selection spill split
|
||||
strmatch x86_ast x86_dsl x86_gas x86_masm x86_proc
|
||||
|
||||
;; asmcomp/debug/
|
||||
|
|
|
@ -85,7 +85,6 @@ chapters (or sometimes sections) are mapped to a distinct `.etex` file:
|
|||
- The ocamlbuild compilation manager: `ocamlbuild.etex`
|
||||
- Interfacing C with OCaml: `intf-c.etex`
|
||||
- Optimisation with Flambda: `flambda.etex`
|
||||
- Memory profiling with Spacetime: `spacetime-chapter.etex`
|
||||
- Fuzzing with afl-fuzz: `afl-fuzz.etex`
|
||||
- Runtime tracing with the instrumented runtime: `instrumented-runtime.etex`
|
||||
|
||||
|
|
|
@ -71,7 +71,6 @@ and as a
|
|||
% \input emacs.tex
|
||||
\input{intf-c.tex}
|
||||
\input{flambda.tex}
|
||||
\input{spacetime-chapter.tex}
|
||||
\input{afl-fuzz.tex}
|
||||
\input{instrumented-runtime.tex}
|
||||
|
||||
|
|
|
@ -12,10 +12,10 @@ TRANSF = $(SET_LD_PATH) $(OCAMLRUN) $(TOOLS)/transf
|
|||
|
||||
FILES = comp.tex top.tex runtime.tex native.tex lexyacc.tex intf-c.tex \
|
||||
ocamldep.tex profil.tex debugger.tex browser.tex ocamldoc.tex \
|
||||
warnings-help.tex ocamlbuild.tex flambda.tex spacetime-chapter.tex \
|
||||
warnings-help.tex ocamlbuild.tex flambda.tex \
|
||||
afl-fuzz.tex instrumented-runtime.tex unified-options.tex
|
||||
|
||||
WITH_TRANSF = top.tex intf-c.tex flambda.tex spacetime-chapter.tex \
|
||||
WITH_TRANSF = top.tex intf-c.tex flambda.tex \
|
||||
afl-fuzz.tex lexyacc.tex debugger.tex
|
||||
|
||||
WITH_CAMLEXAMPLE = instrumented-runtime.tex ocamldoc.tex
|
||||
|
|
|
@ -1,125 +0,0 @@
|
|||
\chapter{Memory profiling with Spacetime}
|
||||
%HEVEA\cutname{spacetime.html}
|
||||
|
||||
\section{s:spacetime-overview}{Overview}
|
||||
|
||||
Spacetime is the name given to functionality within the OCaml compiler that
|
||||
provides for accurate profiling of the memory behaviour of a program.
|
||||
Using Spacetime it is possible to determine the source of memory leaks
|
||||
and excess memory allocation quickly and easily. Excess allocation slows
|
||||
programs down both by imposing a higher load on the garbage collector and
|
||||
reducing the cache locality of the program's code. Spacetime provides
|
||||
full backtraces for every allocation that occurred on the OCaml heap
|
||||
during the lifetime of the program including those in C stubs.
|
||||
|
||||
Spacetime only analyses the memory behaviour of a program with respect to
|
||||
the OCaml heap allocators and garbage collector. It does not analyse
|
||||
allocation on the C heap. Spacetime does not affect the memory behaviour
|
||||
of a program being profiled with the exception of any change caused by the
|
||||
overhead of profiling (see section\ \ref{s:spacetime-runtimeoverhead})---for example
|
||||
the program running slower might cause it to allocate less memory in total.
|
||||
|
||||
Spacetime is currently only available for x86-64 targets and has only been
|
||||
tested on Linux systems (although it is expected to work on most modern
|
||||
Unix-like systems and provision has been made for running under
|
||||
Windows). It is expected that the set of supported platforms will
|
||||
be extended in the future.
|
||||
|
||||
\section{s:spacetime-howto}{How to use it}
|
||||
|
||||
\subsection{ss:spacetime-building}{Building}
|
||||
|
||||
To use Spacetime it is necessary to use an OCaml compiler that was
|
||||
configured with the {\tt -spacetime} option. It is not possible to select
|
||||
Spacetime on a per-source-file basis or for a subset of files in a project;
|
||||
all files involved in the executable being profiled must be built with the
|
||||
Spacetime compiler. Only native code compilation is supported (not
|
||||
bytecode).
|
||||
|
||||
If the {\tt libunwind} library is not available on the system then it will
|
||||
not be possible for Spacetime to profile allocations occurring within
|
||||
C stubs. If the {\tt libunwind} library is available but in an unusual
|
||||
location then that location may be specified to the {\tt configure} script
|
||||
using the {\tt -libunwinddir} option (or alternatively, using separate
|
||||
{\tt -libunwindinclude} and {\tt -libunwindlib} options).
|
||||
|
||||
OPAM switches will be provided for Spacetime-configured compilers.
|
||||
|
||||
Once the appropriate compiler has been selected the program should be
|
||||
built as normal (ensuring that all files are built with the Spacetime
|
||||
compiler---there is currently no protection to ensure this is the case, but
|
||||
it is essential). For many uses it will not be necessary to change the
|
||||
code of the program to use the profiler.
|
||||
|
||||
Spacetime-configured compilers run slower and occupy more memory than their
|
||||
counterparts. It is hoped this will be fixed in the future as part of
|
||||
improved cross compilation support.
|
||||
|
||||
\subsection{ss:spacetime-running}{Running}
|
||||
|
||||
Programs built with Spacetime instrumentation have a dependency on
|
||||
the {\tt libunwind} library unless that was unavailable at configure time or
|
||||
the {\tt -disable-libunwind} option was specified
|
||||
(see section\ \ref{s:spacetime-runtimeoverhead}).
|
||||
|
||||
Setting the {\tt OCAML\_SPACETIME\_INTERVAL} environment variable to an
|
||||
integer representing a number of milliseconds before running a program built
|
||||
with Spacetime will cause memory profiling to be in operation when the
|
||||
program is started. The contents of the OCaml heap will be sampled each
|
||||
time the number of milliseconds that the program has spent executing since the
|
||||
last sample exceeds the given number. (Note that the time base is combined
|
||||
user plus system time---{\em not} wall clock time. This peculiarity may be
|
||||
changed in future.)
|
||||
|
||||
The program being profiled must exit normally or be caused to exit using
|
||||
the {\tt SIGINT} signal (e.g. by pressing Ctrl+C). When the program exits
|
||||
files will be written in the directory that was the working directory when
|
||||
the program was started. One Spacetime file will be written for each
|
||||
process that was involved, indexed by process ID; there will normally only
|
||||
be one such. The Spacetime files may be substantial. The directory to which
|
||||
they are written may be overridden by setting
|
||||
the {\tt OCAML\_SPACETIME\_SNAPSHOT\_DIR} environment variable before the
|
||||
program is started.
|
||||
|
||||
Instead of using the automatic snapshot facility described above it is also
|
||||
possible to manually control Spacetime profiling. (The environment variables
|
||||
{\tt OCAML\_SPACETIME\_INTERVAL} and {\tt OCAML\_SPACETIME\_SNAPSHOT\_DIR}
|
||||
are then not relevant.) Full documentation as regards this method of profiling
|
||||
is provided in the standard library documentation (section\ \ref{c:stdlib})
|
||||
for the {\tt Spacetime} module.
|
||||
|
||||
\subsection{ss:spacetime-analysis}{Analysis}
|
||||
|
||||
The compiler distribution does not itself provide the facility for analysing
|
||||
Spacetime output files; this is left to external tools. The first such tool
|
||||
will appear in OPAM as a package called {\tt prof_spacetime}. That tool will
|
||||
provide interactive graphical and terminal-based visualisation of
|
||||
the results of profiling.
|
||||
|
||||
\section{s:spacetime-runtimeoverhead}{Runtime overhead}
|
||||
|
||||
The runtime overhead imposed by Spacetime varies considerably depending on
|
||||
the particular program being profiled. The overhead may be as low as
|
||||
ten percent---but more usually programs should be expected to run at perhaps
|
||||
a third or quarter of their normal speed. It is expected that this overhead
|
||||
will be reduced in future versions of the compiler.
|
||||
|
||||
Execution speed of instrumented programs may be increased by using a compiler
|
||||
configured with the {\tt -disable-libunwind} option. This prevents collection
|
||||
of profiling information from C stubs.
|
||||
|
||||
Programs running with Spacetime instrumentation consume significantly more
|
||||
memory than their non-instrumented counterparts. It is expected that this
|
||||
memory overhead will also be reduced in the future.
|
||||
|
||||
\section{s:spacetime-dev}{For developers}
|
||||
|
||||
The compiler distribution provides an ``{\tt otherlibs}'' library called
|
||||
{\tt raw\_spacetime\_lib} for decoding Spacetime files. This library
|
||||
provides facilities to read not only memory profiling information but also
|
||||
the full dynamic call graph of the profiled program which is written into
|
||||
Spacetime output files.
|
||||
|
||||
A library package {\tt spacetime\_lib} will be provided in OPAM
|
||||
to provide an interface for decoding profiling information at a higher
|
||||
level than that provided by {\tt raw\_spacetime\_lib}.
|
|
@ -98,7 +98,6 @@ be called from C \\
|
|||
"Filename" & p.~\pageref{Filename} & operations on file names \\
|
||||
"Gc" & p.~\pageref{Gc} & memory management control and statistics \\
|
||||
"Printexc" & p.~\pageref{Printexc} & a catch-all exception handler \\
|
||||
"Spacetime" & p.~\pageref{Spacetime} & memory profiler \\
|
||||
"Sys" & p.~\pageref{Sys} & system interface \\
|
||||
\end{tabular}
|
||||
\subsubsection{sss:stdlib-misc}{Misc:}
|
||||
|
@ -153,7 +152,6 @@ be called from C \\
|
|||
\item \ahref{libref/Scanf.html}{Module \texttt{Scanf}: formatted input functions}
|
||||
\item \ahref{libref/Seq.html}{Module \texttt{Seq}: functional iterators}
|
||||
\item \ahref{libref/Set.html}{Module \texttt{Set}: sets over ordered types}
|
||||
\item \ahref{libref/Spacetime.html}{Module \texttt{Spacetime}: memory profiler}
|
||||
\item \ahref{libref/Stack.html}{Module \texttt{Stack}: last-in first-out stacks}
|
||||
\item \ahref{libref/StdLabels.html}{Module \texttt{StdLabels}: Include modules \texttt{Array}, \texttt{List} and \texttt{String} with labels}
|
||||
\item \ahref{libref/Stream.html}{Module \texttt{Stream}: streams and parsers}
|
||||
|
@ -210,7 +208,6 @@ be called from C \\
|
|||
\input{Scanf.tex}
|
||||
\input{Seq.tex}
|
||||
\input{Set.tex}
|
||||
\input{Spacetime.tex}
|
||||
\input{Stack.tex}
|
||||
\input{StdLabels.tex}
|
||||
\input{Stream.tex}
|
||||
|
|
|
@ -268,7 +268,6 @@ ocamltest_config.ml: ocamltest_config.ml.in Makefile ../Makefile.config
|
|||
$(call SUBST_STRING,ocamloptdefaultflags) \
|
||||
$(call SUBST_STRING,ocamlsrcdir) \
|
||||
$(call SUBST,FLAMBDA) \
|
||||
$(call SUBST,WITH_SPACETIME) \
|
||||
$(call SUBST,FORCE_SAFE_STRING) \
|
||||
$(call SUBST,FLAT_FLOAT_ARRAY) \
|
||||
$(call SUBST,WITH_OCAMLDOC) \
|
||||
|
|
|
@ -1123,18 +1123,6 @@ let no_flambda = make
|
|||
"support for flambda disabled"
|
||||
"support for flambda enabled")
|
||||
|
||||
let spacetime = Actions.make
|
||||
"spacetime"
|
||||
(Actions_helpers.pass_or_skip Ocamltest_config.spacetime
|
||||
"support for spacetime enabled"
|
||||
"support for spacetime disabled")
|
||||
|
||||
let no_spacetime = make
|
||||
"no-spacetime"
|
||||
(Actions_helpers.pass_or_skip (not Ocamltest_config.spacetime)
|
||||
"support for spacetime disabled"
|
||||
"support for spacetime enabled")
|
||||
|
||||
let shared_libraries = Actions.make
|
||||
"shared-libraries"
|
||||
(Actions_helpers.pass_or_skip Ocamltest_config.shared_libraries
|
||||
|
@ -1374,8 +1362,6 @@ let _ =
|
|||
no_flat_float_array;
|
||||
flambda;
|
||||
no_flambda;
|
||||
spacetime;
|
||||
no_spacetime;
|
||||
shared_libraries;
|
||||
no_shared_libraries;
|
||||
native_compiler;
|
||||
|
|
|
@ -107,9 +107,6 @@ let ocamldoc =
|
|||
let asmgen_skip_on_bytecode_only =
|
||||
Actions_helpers.skip_with_reason "native compiler disabled"
|
||||
|
||||
let asmgen_skip_on_spacetime =
|
||||
Actions_helpers.skip_with_reason "not ported to Spacetime yet"
|
||||
|
||||
let msvc64 =
|
||||
Ocamltest_config.ccomptype = "msvc" && Ocamltest_config.arch="amd64"
|
||||
|
||||
|
@ -118,7 +115,6 @@ let asmgen_skip_on_msvc64 =
|
|||
|
||||
let asmgen_actions =
|
||||
if Ocamltest_config.arch="none" then [asmgen_skip_on_bytecode_only]
|
||||
else if Ocamltest_config.spacetime then [asmgen_skip_on_spacetime]
|
||||
else if msvc64 then [asmgen_skip_on_msvc64]
|
||||
else [
|
||||
setup_simple_build_env;
|
||||
|
|
|
@ -47,8 +47,6 @@ let ocamlsrcdir = "%%ocamlsrcdir%%"
|
|||
|
||||
let flambda = %%FLAMBDA%%
|
||||
|
||||
let spacetime = %%WITH_SPACETIME%%
|
||||
|
||||
let ocamlc_default_flags = "%%ocamlcdefaultflags%%"
|
||||
let ocamlopt_default_flags = "%%ocamloptdefaultflags%%"
|
||||
|
||||
|
|
|
@ -70,9 +70,6 @@ val ocamlsrcdir : string
|
|||
val flambda : bool
|
||||
(** Whether flambda has been enabled at configure time *)
|
||||
|
||||
val spacetime : bool
|
||||
(** Whether Spacetime profiling has been enabled at configure time *)
|
||||
|
||||
val safe_string : bool
|
||||
(** Whether the compiler was configured with -safe-string *)
|
||||
|
||||
|
|
|
@ -16,7 +16,7 @@
|
|||
ROOTDIR=..
|
||||
include $(ROOTDIR)/Makefile.common
|
||||
|
||||
OTHERLIBRARIES ?= bigarray dynlink raw_spacetime_lib str systhreads \
|
||||
OTHERLIBRARIES ?= bigarray dynlink str systhreads \
|
||||
unix win32unix
|
||||
|
||||
# $1: target name to dispatch to all otherlibs/*/Makefile
|
||||
|
|
|
@ -1,5 +0,0 @@
|
|||
raw_spacetime_lib.cmo : \
|
||||
raw_spacetime_lib.cmi
|
||||
raw_spacetime_lib.cmx : \
|
||||
raw_spacetime_lib.cmi
|
||||
raw_spacetime_lib.cmi :
|
|
@ -1,28 +0,0 @@
|
|||
#**************************************************************************
|
||||
#* *
|
||||
#* OCaml *
|
||||
#* *
|
||||
#* Xavier Leroy, projet Cristal, INRIA Rocquencourt *
|
||||
#* *
|
||||
#* Copyright 1999 Institut National de Recherche en Informatique et *
|
||||
#* en Automatique. *
|
||||
#* *
|
||||
#* All rights reserved. This file is distributed under the terms of *
|
||||
#* the GNU Lesser General Public License version 2.1, with the *
|
||||
#* special exception on linking described in the file LICENSE. *
|
||||
#* *
|
||||
#**************************************************************************
|
||||
|
||||
# Makefile for Raw_spacetime_lib
|
||||
|
||||
LIBNAME=raw_spacetime_lib
|
||||
COBJS=spacetime_offline.$(O)
|
||||
CAMLOBJS=raw_spacetime_lib.cmo
|
||||
|
||||
include ../Makefile.otherlibs.common
|
||||
|
||||
.PHONY: depend
|
||||
depend:
|
||||
$(CAMLRUN) $(ROOTDIR)/boot/ocamlc -depend -slash *.mli *.ml > .depend
|
||||
|
||||
include .depend
|
|
@ -1,668 +0,0 @@
|
|||
(**************************************************************************)
|
||||
(* *)
|
||||
(* OCaml *)
|
||||
(* *)
|
||||
(* Mark Shinwell and Leo White, Jane Street Europe *)
|
||||
(* *)
|
||||
(* Copyright 2015--2017 Jane Street Group LLC *)
|
||||
(* *)
|
||||
(* All rights reserved. This file is distributed under the terms of *)
|
||||
(* the GNU Lesser General Public License version 2.1, with the *)
|
||||
(* special exception on linking described in the file LICENSE. *)
|
||||
(* *)
|
||||
(**************************************************************************)
|
||||
|
||||
module Gc_stats : sig
|
||||
type t
|
||||
|
||||
val minor_words : t -> int
|
||||
val promoted_words : t -> int
|
||||
val major_words : t -> int
|
||||
val minor_collections : t -> int
|
||||
val major_collections : t -> int
|
||||
val heap_words : t -> int
|
||||
val heap_chunks : t -> int
|
||||
val compactions : t -> int
|
||||
val top_heap_words : t -> int
|
||||
end = struct
|
||||
type t = {
|
||||
minor_words : int;
|
||||
promoted_words : int;
|
||||
major_words : int;
|
||||
minor_collections : int;
|
||||
major_collections : int;
|
||||
heap_words : int;
|
||||
heap_chunks : int;
|
||||
compactions : int;
|
||||
top_heap_words : int;
|
||||
}
|
||||
|
||||
let minor_words t = t.minor_words
|
||||
let promoted_words t = t.promoted_words
|
||||
let major_words t = t.major_words
|
||||
let minor_collections t = t.minor_collections
|
||||
let major_collections t = t.major_collections
|
||||
let heap_words t = t.heap_words
|
||||
let heap_chunks t = t.heap_chunks
|
||||
let compactions t = t.compactions
|
||||
let top_heap_words t = t.top_heap_words
|
||||
end
|
||||
|
||||
module Program_counter = struct
|
||||
module OCaml = struct
|
||||
type t = Int64.t
|
||||
|
||||
let to_int64 t = t
|
||||
end
|
||||
|
||||
module Foreign = struct
|
||||
type t = Int64.t
|
||||
|
||||
let to_int64 t = t
|
||||
end
|
||||
end
|
||||
|
||||
module Function_identifier = struct
|
||||
type t = Int64.t
|
||||
|
||||
let to_int64 t = t
|
||||
end
|
||||
|
||||
module Function_entry_point = struct
|
||||
type t = Int64.t
|
||||
|
||||
let to_int64 t = t
|
||||
end
|
||||
|
||||
module Int64_map = Map.Make (Int64)
|
||||
|
||||
module Frame_table = struct
|
||||
type raw = (Int64.t * (Printexc.Slot.t list)) list
|
||||
|
||||
type t = Printexc.Slot.t list Int64_map.t
|
||||
|
||||
let demarshal chn : t =
|
||||
let raw : raw = Marshal.from_channel chn in
|
||||
List.fold_left (fun map (pc, rev_location_list) ->
|
||||
Int64_map.add pc (List.rev rev_location_list) map)
|
||||
Int64_map.empty
|
||||
raw
|
||||
|
||||
let find_exn = Int64_map.find
|
||||
end
|
||||
|
||||
module Shape_table = struct
|
||||
type part_of_shape =
|
||||
| Direct_call of { call_site : Int64.t; callee : Int64.t; }
|
||||
| Indirect_call of Int64.t
|
||||
| Allocation_point of Int64.t
|
||||
|
||||
let _ = Direct_call { call_site = 0L; callee = 0L; }
|
||||
let _ = Indirect_call 0L
|
||||
let _ = Allocation_point 0L
|
||||
|
||||
type raw = (Int64.t * (part_of_shape list)) list
|
||||
|
||||
type t = {
|
||||
shapes : part_of_shape list Int64_map.t;
|
||||
call_counts : bool;
|
||||
}
|
||||
|
||||
let part_of_shape_size t = function
|
||||
| Direct_call _ -> if t.call_counts then 2 else 1
|
||||
| Indirect_call _ -> 1
|
||||
| Allocation_point _ -> 3
|
||||
|
||||
let demarshal chn ~call_counts : t =
|
||||
let raw : raw = Marshal.from_channel chn in
|
||||
let shapes =
|
||||
List.fold_left (fun map (key, data) -> Int64_map.add key data map)
|
||||
Int64_map.empty
|
||||
raw
|
||||
in
|
||||
{ shapes;
|
||||
call_counts;
|
||||
}
|
||||
|
||||
let find_exn func_id t = Int64_map.find func_id t.shapes
|
||||
let call_counts t = t.call_counts
|
||||
end
|
||||
|
||||
module Annotation = struct
|
||||
type t = int
|
||||
|
||||
let to_int t = t
|
||||
end
|
||||
|
||||
module Trace = struct
|
||||
type node
|
||||
type ocaml_node
|
||||
type foreign_node
|
||||
type uninstrumented_node
|
||||
|
||||
type t = node option
|
||||
type trace = t
|
||||
|
||||
(* This function unmarshals into malloc blocks, which mean that we
|
||||
obtain a straightforward means of writing [compare] on [node]s. *)
|
||||
external unmarshal : in_channel -> 'a
|
||||
= "caml_spacetime_unmarshal_trie"
|
||||
|
||||
let unmarshal in_channel =
|
||||
let trace = unmarshal in_channel in
|
||||
if trace = () then
|
||||
None
|
||||
else
|
||||
Some ((Obj.magic trace) : node)
|
||||
|
||||
let foreign_node_is_null (node : foreign_node) =
|
||||
((Obj.magic node) : unit) == ()
|
||||
|
||||
external node_num_header_words : unit -> int
|
||||
= "caml_spacetime_node_num_header_words" [@@noalloc]
|
||||
|
||||
let num_header_words = lazy (node_num_header_words ())
|
||||
|
||||
module OCaml = struct
|
||||
type field_iterator = {
|
||||
node : ocaml_node;
|
||||
offset : int;
|
||||
part_of_shape : Shape_table.part_of_shape;
|
||||
remaining_layout : Shape_table.part_of_shape list;
|
||||
shape_table : Shape_table.t;
|
||||
}
|
||||
|
||||
module Allocation_point = struct
|
||||
type t = field_iterator
|
||||
|
||||
let program_counter t =
|
||||
match t.part_of_shape with
|
||||
| Shape_table.Allocation_point call_site -> call_site
|
||||
| _ -> assert false
|
||||
|
||||
external annotation : ocaml_node -> int -> Annotation.t
|
||||
= "caml_spacetime_ocaml_allocation_point_annotation"
|
||||
[@@noalloc]
|
||||
|
||||
let annotation t = annotation t.node t.offset
|
||||
|
||||
external count : ocaml_node -> int -> int
|
||||
= "caml_spacetime_ocaml_allocation_point_count"
|
||||
[@@noalloc]
|
||||
|
||||
let num_words_including_headers t = count t.node t.offset
|
||||
end
|
||||
|
||||
module Direct_call_point = struct
|
||||
type _ t = field_iterator
|
||||
|
||||
let call_site t =
|
||||
match t.part_of_shape with
|
||||
| Shape_table.Direct_call { call_site; _ } -> call_site
|
||||
| _ -> assert false
|
||||
|
||||
let callee t =
|
||||
match t.part_of_shape with
|
||||
| Shape_table.Direct_call { callee; _ } -> callee
|
||||
| _ -> assert false
|
||||
|
||||
external callee_node : ocaml_node -> int -> 'target
|
||||
= "caml_spacetime_ocaml_direct_call_point_callee_node"
|
||||
|
||||
let callee_node (type target) (t : target t) : target =
|
||||
callee_node t.node t.offset
|
||||
|
||||
external call_count : ocaml_node -> int -> int
|
||||
= "caml_spacetime_ocaml_direct_call_point_call_count"
|
||||
|
||||
let call_count t =
|
||||
if Shape_table.call_counts t.shape_table then
|
||||
Some (call_count t.node t.offset)
|
||||
else
|
||||
None
|
||||
end
|
||||
|
||||
module Indirect_call_point = struct
|
||||
type t = field_iterator
|
||||
|
||||
let call_site t =
|
||||
match t.part_of_shape with
|
||||
| Shape_table.Indirect_call call_site -> call_site
|
||||
| _ -> assert false
|
||||
|
||||
module Callee = struct
|
||||
(* CR-soon mshinwell: we should think about the names again. This is
|
||||
a "c_node" but it isn't foreign. *)
|
||||
type t = {
|
||||
node : foreign_node;
|
||||
call_counts : bool;
|
||||
}
|
||||
|
||||
let is_null t = foreign_node_is_null t.node
|
||||
|
||||
(* CR-soon mshinwell: maybe rename ...c_node_call_site -> c_node_pc,
|
||||
since it isn't a call site in this case. *)
|
||||
external callee : foreign_node -> Function_entry_point.t
|
||||
= "caml_spacetime_c_node_call_site"
|
||||
|
||||
let callee t = callee t.node
|
||||
|
||||
(* This can return a node satisfying "is_null" in the case of an
|
||||
uninitialised tail call point. See the comment in the C code. *)
|
||||
external callee_node : foreign_node -> node
|
||||
= "caml_spacetime_c_node_callee_node" [@@noalloc]
|
||||
|
||||
let callee_node t = callee_node t.node
|
||||
|
||||
external call_count : foreign_node -> int
|
||||
= "caml_spacetime_c_node_call_count"
|
||||
|
||||
let call_count t =
|
||||
if t.call_counts then Some (call_count t.node)
|
||||
else None
|
||||
|
||||
external next : foreign_node -> foreign_node
|
||||
= "caml_spacetime_c_node_next" [@@noalloc]
|
||||
|
||||
let next t =
|
||||
let next = { t with node = next t.node; } in
|
||||
if foreign_node_is_null next.node then None
|
||||
else Some next
|
||||
end
|
||||
|
||||
external callees : ocaml_node -> int -> foreign_node
|
||||
= "caml_spacetime_ocaml_indirect_call_point_callees"
|
||||
[@@noalloc]
|
||||
|
||||
let callees t =
|
||||
let callees =
|
||||
{ Callee.
|
||||
node = callees t.node t.offset;
|
||||
call_counts = Shape_table.call_counts t.shape_table;
|
||||
}
|
||||
in
|
||||
if Callee.is_null callees then None
|
||||
else Some callees
|
||||
end
|
||||
|
||||
module Field = struct
|
||||
type t = field_iterator
|
||||
|
||||
type direct_call_point =
|
||||
| To_ocaml of ocaml_node Direct_call_point.t
|
||||
| To_foreign of foreign_node Direct_call_point.t
|
||||
| To_uninstrumented of
|
||||
uninstrumented_node Direct_call_point.t
|
||||
|
||||
type classification =
|
||||
| Allocation of Allocation_point.t
|
||||
| Direct_call of direct_call_point
|
||||
| Indirect_call of Indirect_call_point.t
|
||||
|
||||
external classify_direct_call_point : ocaml_node -> int -> int
|
||||
= "caml_spacetime_classify_direct_call_point"
|
||||
[@@noalloc]
|
||||
|
||||
let classify t =
|
||||
match t.part_of_shape with
|
||||
| Shape_table.Direct_call _callee ->
|
||||
let direct_call_point =
|
||||
match classify_direct_call_point t.node t.offset with
|
||||
| 0 ->
|
||||
(* We should never classify uninitialised call points here. *)
|
||||
assert false
|
||||
| 1 -> To_ocaml t
|
||||
| 2 -> To_foreign t
|
||||
| _ -> assert false
|
||||
in
|
||||
Direct_call direct_call_point
|
||||
| Shape_table.Indirect_call _ -> Indirect_call t
|
||||
| Shape_table.Allocation_point _ -> Allocation t
|
||||
|
||||
(* CR-soon mshinwell: change to "is_unused"? *)
|
||||
let is_uninitialised t =
|
||||
let offset_to_node_hole =
|
||||
match t.part_of_shape with
|
||||
| Shape_table.Direct_call _ -> Some 0
|
||||
| Shape_table.Indirect_call _ -> Some 0
|
||||
| Shape_table.Allocation_point _ -> None
|
||||
in
|
||||
match offset_to_node_hole with
|
||||
| None -> false
|
||||
| Some offset_to_node_hole ->
|
||||
(* There are actually two cases:
|
||||
1. A normal unused node hole, which says Val_unit;
|
||||
2. An unused tail call point. This will contain a pointer to the
|
||||
start of the current node, but it also has the bottom bit
|
||||
set. *)
|
||||
let offset = t.offset + offset_to_node_hole in
|
||||
Obj.is_int (Obj.field (Obj.repr t.node) offset)
|
||||
|
||||
let rec next t =
|
||||
match t.remaining_layout with
|
||||
| [] -> None
|
||||
| part_of_shape::remaining_layout ->
|
||||
let size =
|
||||
Shape_table.part_of_shape_size t.shape_table t.part_of_shape
|
||||
in
|
||||
let offset = t.offset + size in
|
||||
assert (offset < Obj.size (Obj.repr t.node));
|
||||
let t =
|
||||
{ node = t.node;
|
||||
offset;
|
||||
part_of_shape;
|
||||
remaining_layout;
|
||||
shape_table = t.shape_table;
|
||||
}
|
||||
in
|
||||
skip_uninitialised t
|
||||
|
||||
and skip_uninitialised t =
|
||||
if not (is_uninitialised t) then Some t
|
||||
else next t
|
||||
end
|
||||
|
||||
module Node = struct
|
||||
type t = ocaml_node
|
||||
|
||||
external function_identifier : t -> Function_identifier.t
|
||||
= "caml_spacetime_ocaml_function_identifier"
|
||||
|
||||
external next_in_tail_call_chain : t -> t
|
||||
= "caml_spacetime_ocaml_tail_chain" [@@noalloc]
|
||||
|
||||
external compare : t -> t -> int
|
||||
= "caml_spacetime_compare_node" [@@noalloc]
|
||||
|
||||
let fields t ~shape_table =
|
||||
let id = function_identifier t in
|
||||
match Shape_table.find_exn id shape_table with
|
||||
| exception Not_found -> None
|
||||
| [] -> None
|
||||
| part_of_shape::remaining_layout ->
|
||||
let t =
|
||||
{ node = t;
|
||||
offset = Lazy.force num_header_words;
|
||||
part_of_shape;
|
||||
remaining_layout;
|
||||
shape_table;
|
||||
}
|
||||
in
|
||||
Field.skip_uninitialised t
|
||||
end
|
||||
end
|
||||
|
||||
module Foreign = struct
|
||||
module Node = struct
|
||||
type t = foreign_node
|
||||
|
||||
external compare : t -> t -> int
|
||||
= "caml_spacetime_compare_node" [@@noalloc]
|
||||
|
||||
let fields t =
|
||||
if foreign_node_is_null t then None
|
||||
else Some t
|
||||
end
|
||||
|
||||
module Allocation_point = struct
|
||||
type t = foreign_node
|
||||
|
||||
external program_counter : t -> Program_counter.Foreign.t
|
||||
(* This is not a mistake; the same C function works. *)
|
||||
= "caml_spacetime_c_node_call_site"
|
||||
|
||||
external annotation : t -> Annotation.t
|
||||
= "caml_spacetime_c_node_profinfo" [@@noalloc]
|
||||
|
||||
external num_words_including_headers : t -> int
|
||||
= "caml_spacetime_c_node_allocation_count" [@@noalloc]
|
||||
end
|
||||
|
||||
module Call_point = struct
|
||||
type t = foreign_node
|
||||
|
||||
external call_site : t -> Program_counter.Foreign.t
|
||||
= "caml_spacetime_c_node_call_site"
|
||||
|
||||
(* May return a null node. See comment above and the C code. *)
|
||||
external callee_node : t -> node
|
||||
= "caml_spacetime_c_node_callee_node" [@@noalloc]
|
||||
end
|
||||
|
||||
module Field = struct
|
||||
type t = foreign_node
|
||||
|
||||
type classification =
|
||||
| Allocation of Allocation_point.t
|
||||
| Call of Call_point.t
|
||||
|
||||
external is_call : t -> bool
|
||||
= "caml_spacetime_c_node_is_call" [@@noalloc]
|
||||
|
||||
let classify t =
|
||||
if is_call t then Call t
|
||||
else Allocation t
|
||||
|
||||
external next : t -> t
|
||||
= "caml_spacetime_c_node_next" [@@noalloc]
|
||||
|
||||
let next t =
|
||||
let next = next t in
|
||||
if foreign_node_is_null next then None
|
||||
else Some next
|
||||
end
|
||||
end
|
||||
|
||||
module Node = struct
|
||||
module T = struct
|
||||
type t = node
|
||||
|
||||
external compare : t -> t -> int
|
||||
= "caml_spacetime_compare_node" [@@noalloc]
|
||||
end
|
||||
|
||||
include T
|
||||
|
||||
type classification =
|
||||
| OCaml of OCaml.Node.t
|
||||
| Foreign of Foreign.Node.t
|
||||
|
||||
external is_ocaml_node : t -> bool
|
||||
= "caml_spacetime_is_ocaml_node" [@@noalloc]
|
||||
|
||||
let classify t =
|
||||
if is_ocaml_node t then OCaml ((Obj.magic t) : ocaml_node)
|
||||
else Foreign ((Obj.magic t) : foreign_node)
|
||||
|
||||
let of_ocaml_node (node : ocaml_node) : t = Obj.magic node
|
||||
let of_foreign_node (node : foreign_node) : t = Obj.magic node
|
||||
|
||||
module Map = Map.Make (T)
|
||||
module Set = Set.Make (T)
|
||||
end
|
||||
|
||||
let root t = t
|
||||
end
|
||||
|
||||
module Heap_snapshot = struct
|
||||
|
||||
module Entries = struct
|
||||
type t = int array (* == "struct snapshot_entries" *)
|
||||
|
||||
let length t =
|
||||
let length = Array.length t in
|
||||
assert (length mod 3 = 0);
|
||||
length / 3
|
||||
|
||||
let annotation t idx = t.(idx*3)
|
||||
let num_blocks t idx = t.(idx*3 + 1)
|
||||
let num_words_including_headers t idx = t.(idx*3 + 2)
|
||||
end
|
||||
|
||||
type total_allocations =
|
||||
| End
|
||||
| Total of {
|
||||
annotation : Annotation.t;
|
||||
count : int;
|
||||
next : total_allocations;
|
||||
}
|
||||
|
||||
let (_ : total_allocations) = (* suppress compiler warning *)
|
||||
Total { annotation = 0; count = 0; next = End; }
|
||||
|
||||
type t = {
|
||||
timestamp : float;
|
||||
gc_stats : Gc_stats.t;
|
||||
entries : Entries.t;
|
||||
words_scanned : int;
|
||||
words_scanned_with_profinfo : int;
|
||||
total_allocations : total_allocations;
|
||||
}
|
||||
|
||||
type heap_snapshot = t
|
||||
|
||||
let timestamp t = t.timestamp
|
||||
let gc_stats t = t.gc_stats
|
||||
let entries t = t.entries
|
||||
let words_scanned t = t.words_scanned
|
||||
let words_scanned_with_profinfo t = t.words_scanned_with_profinfo
|
||||
|
||||
module Total_allocation = struct
|
||||
type t = total_allocations (* [End] is forbidden *)
|
||||
|
||||
let annotation = function
|
||||
| End -> assert false
|
||||
| Total { annotation; _ } -> annotation
|
||||
|
||||
let num_words_including_headers = function
|
||||
| End -> assert false
|
||||
| Total { count; _ } -> count
|
||||
|
||||
let next = function
|
||||
| End -> assert false
|
||||
| Total { next = End; _ } -> None
|
||||
| Total { next; _ } -> Some next
|
||||
end
|
||||
|
||||
let total_allocations t =
|
||||
match t.total_allocations with
|
||||
| End -> None
|
||||
| (Total _) as totals -> Some totals
|
||||
|
||||
module Event = struct
|
||||
type t = {
|
||||
event_name : string;
|
||||
time : float;
|
||||
}
|
||||
|
||||
let event_name t = t.event_name
|
||||
let timestamp t = t.time
|
||||
end
|
||||
|
||||
module Series = struct
|
||||
type t = {
|
||||
num_snapshots : int;
|
||||
time_of_writer_close : float;
|
||||
frame_table : Frame_table.t;
|
||||
shape_table : Shape_table.t;
|
||||
traces_by_thread : Trace.t array;
|
||||
finaliser_traces_by_thread : Trace.t array;
|
||||
snapshots : heap_snapshot array;
|
||||
events : Event.t list;
|
||||
call_counts : bool;
|
||||
}
|
||||
|
||||
(* The order of these constructors must match the C code. *)
|
||||
type what_comes_next =
|
||||
| Snapshot
|
||||
| Traces
|
||||
| Event
|
||||
|
||||
(* Suppress compiler warning 37. *)
|
||||
let _ : what_comes_next list = [Snapshot; Traces; Event;]
|
||||
|
||||
let rec read_snapshots_and_events chn snapshots events =
|
||||
let next : what_comes_next = Marshal.from_channel chn in
|
||||
match next with
|
||||
| Snapshot ->
|
||||
let snapshot : heap_snapshot = Marshal.from_channel chn in
|
||||
read_snapshots_and_events chn (snapshot :: snapshots) events
|
||||
| Event ->
|
||||
let event_name : string = Marshal.from_channel chn in
|
||||
let time : float = Marshal.from_channel chn in
|
||||
let event = { Event. event_name; time; } in
|
||||
read_snapshots_and_events chn snapshots (event :: events)
|
||||
| Traces ->
|
||||
(Array.of_list (List.rev snapshots)), List.rev events
|
||||
|
||||
let read ~path =
|
||||
let chn = open_in_bin path in
|
||||
let magic_number : int = Marshal.from_channel chn in
|
||||
let magic_number_base = magic_number land 0xffff_ffff in
|
||||
let version_number = (magic_number lsr 32) land 0xffff in
|
||||
let features = (magic_number lsr 48) land 0xffff in
|
||||
if magic_number_base <> 0xace00ace then begin
|
||||
failwith "Raw_spacetime_lib: not a Spacetime profiling file"
|
||||
end else begin
|
||||
match version_number with
|
||||
| 0 ->
|
||||
let call_counts =
|
||||
match features with
|
||||
| 0 -> false
|
||||
| 1 -> true
|
||||
| _ ->
|
||||
failwith "Raw_spacetime_lib: unknown Spacetime profiling file \
|
||||
feature set"
|
||||
in
|
||||
let snapshots, events = read_snapshots_and_events chn [] [] in
|
||||
let num_snapshots = Array.length snapshots in
|
||||
let time_of_writer_close : float = Marshal.from_channel chn in
|
||||
let frame_table = Frame_table.demarshal chn in
|
||||
let shape_table = Shape_table.demarshal chn ~call_counts in
|
||||
let num_threads : int = Marshal.from_channel chn in
|
||||
let traces_by_thread = Array.init num_threads (fun _ -> None) in
|
||||
let finaliser_traces_by_thread =
|
||||
Array.init num_threads (fun _ -> None)
|
||||
in
|
||||
for thread = 0 to num_threads - 1 do
|
||||
let trace : Trace.t = Trace.unmarshal chn in
|
||||
let finaliser_trace : Trace.t = Trace.unmarshal chn in
|
||||
traces_by_thread.(thread) <- trace;
|
||||
finaliser_traces_by_thread.(thread) <- finaliser_trace
|
||||
done;
|
||||
close_in chn;
|
||||
{ num_snapshots;
|
||||
time_of_writer_close;
|
||||
frame_table;
|
||||
shape_table;
|
||||
traces_by_thread;
|
||||
finaliser_traces_by_thread;
|
||||
snapshots;
|
||||
events;
|
||||
call_counts;
|
||||
}
|
||||
| _ ->
|
||||
failwith "Raw_spacetime_lib: unknown Spacetime profiling file \
|
||||
version number"
|
||||
end
|
||||
|
||||
type trace_kind = Normal | Finaliser
|
||||
|
||||
let num_threads t = Array.length t.traces_by_thread
|
||||
|
||||
let trace t ~kind ~thread_index =
|
||||
if thread_index < 0 || thread_index >= num_threads t then None
|
||||
else
|
||||
match kind with
|
||||
| Normal -> Some t.traces_by_thread.(thread_index)
|
||||
| Finaliser -> Some t.finaliser_traces_by_thread.(thread_index)
|
||||
|
||||
let num_snapshots t = t.num_snapshots
|
||||
let snapshot t ~index = t.snapshots.(index)
|
||||
let frame_table t = t.frame_table
|
||||
let shape_table t = t.shape_table
|
||||
let time_of_writer_close t = t.time_of_writer_close
|
||||
let events t = t.events
|
||||
let has_call_counts t = t.call_counts
|
||||
end
|
||||
end
|
|
@ -1,364 +0,0 @@
|
|||
(**************************************************************************)
|
||||
(* *)
|
||||
(* OCaml *)
|
||||
(* *)
|
||||
(* Mark Shinwell and Leo White, Jane Street Europe *)
|
||||
(* *)
|
||||
(* Copyright 2015--2017 Jane Street Group LLC *)
|
||||
(* *)
|
||||
(* All rights reserved. This file is distributed under the terms of *)
|
||||
(* the GNU Lesser General Public License version 2.1, with the *)
|
||||
(* special exception on linking described in the file LICENSE. *)
|
||||
(* *)
|
||||
(**************************************************************************)
|
||||
|
||||
(** Access to the information recorded by the [Spacetime]
|
||||
module. (It is intended that this module will be used by
|
||||
post-processors rather than users wishing to understand their
|
||||
programs.)
|
||||
For 64-bit targets only.
|
||||
This module may be used from any program, not just one compiled
|
||||
with a compiler configured for Spacetime. *)
|
||||
|
||||
module Gc_stats : sig
|
||||
type t
|
||||
|
||||
val minor_words : t -> int
|
||||
val promoted_words : t -> int
|
||||
val major_words : t -> int
|
||||
val minor_collections : t -> int
|
||||
val major_collections : t -> int
|
||||
val heap_words : t -> int
|
||||
val heap_chunks : t -> int
|
||||
val compactions : t -> int
|
||||
val top_heap_words : t -> int
|
||||
end
|
||||
|
||||
module Annotation : sig
|
||||
(** An annotation written into a value's header. These may be looked up
|
||||
in a [Trace.t] (see below). *)
|
||||
type t
|
||||
|
||||
(* CR-someday mshinwell: consider using tag and size to increase the
|
||||
available space of annotations. Need to be careful of [Obj.truncate].
|
||||
Could also randomise the tags on records.
|
||||
*)
|
||||
|
||||
val to_int : t -> int
|
||||
end
|
||||
|
||||
module Program_counter : sig
|
||||
module OCaml : sig
|
||||
type t
|
||||
|
||||
val to_int64 : t -> Int64.t
|
||||
end
|
||||
|
||||
module Foreign : sig
|
||||
type t
|
||||
|
||||
val to_int64 : t -> Int64.t
|
||||
end
|
||||
|
||||
end
|
||||
|
||||
module Frame_table : sig
|
||||
(* CR-someday mshinwell: move to [Gc] if dependencies permit? *)
|
||||
(** A value of type [t] corresponds to the frame table of a running
|
||||
OCaml program. The table is indexed by program counter address
|
||||
(typically, but not always when using Spacetime, return addresses). *)
|
||||
type t
|
||||
|
||||
(** Find the location, including any inlined frames, corresponding to the
|
||||
given program counter address. Raises [Not_found] if the location
|
||||
could not be resolved. *)
|
||||
val find_exn : Program_counter.OCaml.t -> t -> Printexc.Slot.t list
|
||||
end
|
||||
|
||||
module Function_entry_point : sig
|
||||
type t
|
||||
|
||||
val to_int64 : t -> Int64.t
|
||||
end
|
||||
|
||||
module Function_identifier : sig
|
||||
type t
|
||||
(* CR-soon mshinwell: same as [Function_entry_point] now *)
|
||||
val to_int64 : t -> Int64.t
|
||||
end
|
||||
|
||||
module Shape_table : sig
|
||||
type t
|
||||
end
|
||||
|
||||
module Trace : sig
|
||||
(** A value of type [t] holds the dynamic call structure of the program
|
||||
(i.e. which functions have called which other functions) together with
|
||||
information required to decode profiling annotations written into
|
||||
values' headers. *)
|
||||
type t
|
||||
type trace = t
|
||||
|
||||
type node
|
||||
type ocaml_node
|
||||
type foreign_node
|
||||
type uninstrumented_node
|
||||
|
||||
module OCaml : sig
|
||||
module Allocation_point : sig
|
||||
(** A value of type [t] corresponds to an allocation point in OCaml
|
||||
code. *)
|
||||
type t
|
||||
|
||||
(** The program counter at (or close to) the allocation site. *)
|
||||
val program_counter : t -> Program_counter.OCaml.t
|
||||
|
||||
(** The annotation written into the headers of boxed values allocated
|
||||
at the given allocation site. *)
|
||||
val annotation : t -> Annotation.t
|
||||
|
||||
(** The total number of words allocated at this point. *)
|
||||
val num_words_including_headers : t -> int
|
||||
end
|
||||
|
||||
module Direct_call_point : sig
|
||||
(** A value of type ['target t] corresponds to a direct (i.e. known
|
||||
at compile time) call point in OCaml code. ['target] is the type
|
||||
of the node corresponding to the callee. *)
|
||||
type 'target t
|
||||
|
||||
(** The program counter at (or close to) the call site. *)
|
||||
val call_site : _ t -> Program_counter.OCaml.t
|
||||
|
||||
(** The address of the first instruction of the callee. *)
|
||||
val callee : _ t -> Function_entry_point.t
|
||||
|
||||
(** The node corresponding to the callee. *)
|
||||
val callee_node : 'target t -> 'target
|
||||
|
||||
(** The number of times the callee was called. Only available if the
|
||||
compiler that recorded the Spacetime profile was configured with
|
||||
"-with-spacetime-call-counts". [None] will be returned otherwise. *)
|
||||
val call_count : _ t -> int option
|
||||
end
|
||||
|
||||
module Indirect_call_point : sig
|
||||
(** A value of type [t] corresponds to an indirect call point in OCaml
|
||||
code. Each such value contains a list of callees to which the
|
||||
call point has branched. *)
|
||||
type t
|
||||
|
||||
(** The program counter at (or close to) the call site. *)
|
||||
val call_site : t -> Program_counter.OCaml.t
|
||||
|
||||
module Callee : sig
|
||||
type t
|
||||
|
||||
(** The address of the first instruction of the callee. *)
|
||||
val callee : t -> Function_entry_point.t
|
||||
|
||||
(** The node corresponding to the callee. *)
|
||||
val callee_node : t -> node
|
||||
|
||||
(** The number of times the callee was called. This returns [None] in
|
||||
the same circumstances as [Direct_call_point.call_count], above. *)
|
||||
val call_count : t -> int option
|
||||
|
||||
(** Move to the next callee to which this call point has branched.
|
||||
[None] is returned when the end of the list is reached. *)
|
||||
val next : t -> t option
|
||||
end
|
||||
|
||||
(** The list of callees to which this indirect call point has
|
||||
branched. *)
|
||||
val callees : t -> Callee.t option
|
||||
end
|
||||
|
||||
module Field : sig
|
||||
(** A value of type [t] enables iteration through the contents
|
||||
("fields") of an OCaml node. *)
|
||||
type t
|
||||
|
||||
type direct_call_point =
|
||||
| To_ocaml of ocaml_node Direct_call_point.t
|
||||
| To_foreign of foreign_node Direct_call_point.t
|
||||
(* CR-soon mshinwell: once everything's finished, "uninstrumented"
|
||||
should be able to go away. Let's try to do this after the
|
||||
first release. *)
|
||||
| To_uninstrumented of
|
||||
uninstrumented_node Direct_call_point.t
|
||||
|
||||
type classification =
|
||||
| Allocation of Allocation_point.t
|
||||
| Direct_call of direct_call_point
|
||||
| Indirect_call of Indirect_call_point.t
|
||||
|
||||
val classify : t -> classification
|
||||
val next : t -> t option
|
||||
end
|
||||
|
||||
module Node : sig
|
||||
(** A node corresponding to an invocation of a function written in
|
||||
OCaml. *)
|
||||
type t = ocaml_node
|
||||
|
||||
val compare : t -> t -> int
|
||||
|
||||
(** A unique identifier for the function corresponding to this node. *)
|
||||
val function_identifier : t -> Function_identifier.t
|
||||
|
||||
(** This function traverses a circular list. *)
|
||||
val next_in_tail_call_chain : t -> t
|
||||
|
||||
val fields : t -> shape_table:Shape_table.t -> Field.t option
|
||||
end
|
||||
end
|
||||
|
||||
module Foreign : sig
|
||||
module Allocation_point : sig
|
||||
(** A value of type [t] corresponds to an allocation point in non-OCaml
|
||||
code. *)
|
||||
type t
|
||||
|
||||
val program_counter : t -> Program_counter.Foreign.t
|
||||
val annotation : t -> Annotation.t
|
||||
val num_words_including_headers : t -> int
|
||||
end
|
||||
|
||||
module Call_point : sig
|
||||
(** A value of type [t] corresponds to a call point from non-OCaml
|
||||
code (to either non-OCaml code, or OCaml code via the usual
|
||||
assembly veneer). Call counts are not available for such nodes. *)
|
||||
type t
|
||||
|
||||
(** N.B. The address of the callee (of type [Function_entry_point.t]) is
|
||||
not available. It must be recovered during post-processing. *)
|
||||
val call_site : t -> Program_counter.Foreign.t
|
||||
val callee_node : t -> node
|
||||
end
|
||||
|
||||
module Field : sig
|
||||
(** A value of type [t] enables iteration through the contents ("fields")
|
||||
of a C node. *)
|
||||
type t
|
||||
|
||||
type classification = private
|
||||
| Allocation of Allocation_point.t
|
||||
| Call of Call_point.t
|
||||
|
||||
val classify : t -> classification
|
||||
val next : t -> t option
|
||||
end
|
||||
|
||||
module Node : sig
|
||||
(** A node corresponding to an invocation of a function written in C
|
||||
(or any other language that is not OCaml). *)
|
||||
type t = foreign_node
|
||||
|
||||
val compare : t -> t -> int
|
||||
|
||||
val fields : t -> Field.t option
|
||||
|
||||
end
|
||||
|
||||
end
|
||||
|
||||
module Node : sig
|
||||
(** Either an OCaml or a foreign node; or an indication that this
|
||||
is a branch of the graph corresponding to uninstrumented
|
||||
code. *)
|
||||
type t = node
|
||||
|
||||
val compare : t -> t -> int
|
||||
|
||||
type classification = private
|
||||
| OCaml of OCaml.Node.t
|
||||
| Foreign of Foreign.Node.t
|
||||
|
||||
val classify : t -> classification
|
||||
|
||||
val of_ocaml_node : OCaml.Node.t -> t
|
||||
val of_foreign_node : Foreign.Node.t -> t
|
||||
|
||||
module Set : Set.S with type elt = t
|
||||
module Map : Map.S with type key = t
|
||||
end
|
||||
|
||||
(** Obtains the root of the graph for traversal. [None] is returned if
|
||||
the graph is empty. *)
|
||||
val root : t -> Node.t option
|
||||
end
|
||||
|
||||
module Heap_snapshot : sig
|
||||
type t
|
||||
type heap_snapshot = t
|
||||
|
||||
module Entries : sig
|
||||
(** An immutable array of the total number of blocks (= boxed
|
||||
values) and the total number of words occupied by such blocks
|
||||
(including their headers) for each profiling annotation in
|
||||
the heap. *)
|
||||
type t
|
||||
|
||||
val length : t -> int
|
||||
val annotation : t -> int -> Annotation.t
|
||||
val num_blocks : t -> int -> int
|
||||
val num_words_including_headers : t -> int -> int
|
||||
|
||||
end
|
||||
|
||||
(** The timestamp of a snapshot. The units are as for [Sys.time]
|
||||
(unless custom timestamps are being provided, cf. the [Spacetime] module
|
||||
in the standard library). *)
|
||||
val timestamp : t -> float
|
||||
|
||||
val gc_stats : t -> Gc_stats.t
|
||||
val entries : t -> Entries.t
|
||||
val words_scanned : t -> int
|
||||
val words_scanned_with_profinfo : t -> int
|
||||
|
||||
module Total_allocation : sig
|
||||
type t
|
||||
|
||||
val annotation : t -> Annotation.t
|
||||
val num_words_including_headers : t -> int
|
||||
val next : t -> t option
|
||||
end
|
||||
|
||||
(** Total allocations across *all threads*. *)
|
||||
(* CR-someday mshinwell: change the relevant variables to be thread-local *)
|
||||
val total_allocations : t -> Total_allocation.t option
|
||||
|
||||
module Event : sig
|
||||
type t
|
||||
|
||||
val event_name : t -> string
|
||||
val timestamp : t -> float
|
||||
end
|
||||
|
||||
module Series : sig
|
||||
type t
|
||||
|
||||
(** At present, the [Trace.t] associated with a [Series.t] cannot be
|
||||
garbage collected or freed. This should not be a problem, since
|
||||
the intention is that a post-processor reads the trace and outputs
|
||||
another format. *)
|
||||
val read : path:string -> t
|
||||
|
||||
val time_of_writer_close : t -> float
|
||||
val num_threads : t -> int
|
||||
|
||||
type trace_kind = Normal | Finaliser
|
||||
val trace : t -> kind:trace_kind -> thread_index:int -> Trace.t option
|
||||
|
||||
val frame_table : t -> Frame_table.t
|
||||
val shape_table : t -> Shape_table.t
|
||||
val num_snapshots : t -> int
|
||||
val snapshot : t -> index:int -> heap_snapshot
|
||||
val events : t -> Event.t list
|
||||
|
||||
(** Returns [true] iff call count information was recorded in the
|
||||
series. *)
|
||||
val has_call_counts : t -> bool
|
||||
end
|
||||
end
|
|
@ -1,250 +0,0 @@
|
|||
/**************************************************************************/
|
||||
/* */
|
||||
/* OCaml */
|
||||
/* */
|
||||
/* Mark Shinwell and Leo White, Jane Street Europe */
|
||||
/* */
|
||||
/* Copyright 2013--2016, Jane Street Group, LLC */
|
||||
/* */
|
||||
/* All rights reserved. This file is distributed under the terms of */
|
||||
/* the GNU Lesser General Public License version 2.1, with the */
|
||||
/* special exception on linking described in the file LICENSE. */
|
||||
/* */
|
||||
/**************************************************************************/
|
||||
|
||||
#define CAML_INTERNALS
|
||||
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <limits.h>
|
||||
#include <math.h>
|
||||
|
||||
#include "caml/alloc.h"
|
||||
#include "caml/config.h"
|
||||
#include "caml/fail.h"
|
||||
#include "caml/gc.h"
|
||||
#include "caml/intext.h"
|
||||
#include "caml/major_gc.h"
|
||||
#include "caml/memory.h"
|
||||
#include "caml/minor_gc.h"
|
||||
#include "caml/misc.h"
|
||||
#include "caml/mlvalues.h"
|
||||
#include "caml/roots.h"
|
||||
#include "caml/signals.h"
|
||||
#include "caml/stack.h"
|
||||
#include "caml/sys.h"
|
||||
#include "caml/spacetime.h"
|
||||
|
||||
#include "caml/s.h"
|
||||
|
||||
#define SPACETIME_PROFINFO_WIDTH 26
|
||||
#define Spacetime_profinfo_hd(hd) \
|
||||
(Gen_profinfo_hd(SPACETIME_PROFINFO_WIDTH, hd))
|
||||
|
||||
#ifdef ARCH_SIXTYFOUR
|
||||
|
||||
/* CR-someday lwhite: The following two definitions are copied from spacetime.c
|
||||
because they are needed here, but must be inlined in spacetime.c
|
||||
for performance. Perhaps a macro or "static inline" would be
|
||||
more appropriate. */
|
||||
|
||||
c_node* caml_spacetime_offline_c_node_of_stored_pointer_not_null
|
||||
(value node_stored)
|
||||
{
|
||||
CAMLassert(Is_c_node(node_stored));
|
||||
return (c_node*) Hp_val(node_stored);
|
||||
}
|
||||
|
||||
c_node_type caml_spacetime_offline_classify_c_node(c_node* node)
|
||||
{
|
||||
return (node->pc & 2) ? CALL : ALLOCATION;
|
||||
}
|
||||
|
||||
CAMLprim value caml_spacetime_compare_node(
|
||||
value node1, value node2)
|
||||
{
|
||||
CAMLassert(!Is_in_value_area(node1));
|
||||
CAMLassert(!Is_in_value_area(node2));
|
||||
|
||||
if (node1 == node2) {
|
||||
return Val_long(0);
|
||||
}
|
||||
if (node1 < node2) {
|
||||
return Val_long(-1);
|
||||
}
|
||||
return Val_long(1);
|
||||
}
|
||||
|
||||
CAMLprim value caml_spacetime_unmarshal_trie (value v_channel)
|
||||
{
|
||||
return caml_input_value_to_outside_heap(v_channel);
|
||||
}
|
||||
|
||||
CAMLprim value caml_spacetime_node_num_header_words(value unit)
|
||||
{
|
||||
return Val_long(Node_num_header_words);
|
||||
}
|
||||
|
||||
CAMLprim value caml_spacetime_is_ocaml_node(value node)
|
||||
{
|
||||
CAMLassert(Is_ocaml_node(node) || Is_c_node(node));
|
||||
return Val_bool(Is_ocaml_node(node));
|
||||
}
|
||||
|
||||
CAMLprim value caml_spacetime_ocaml_function_identifier(value node)
|
||||
{
|
||||
CAMLassert(Is_ocaml_node(node));
|
||||
return caml_copy_int64((uint64_t) Decode_node_pc(Node_pc(node)));
|
||||
}
|
||||
|
||||
CAMLprim value caml_spacetime_ocaml_tail_chain(value node)
|
||||
{
|
||||
CAMLassert(Is_ocaml_node(node));
|
||||
return Tail_link(node);
|
||||
}
|
||||
|
||||
CAMLprim value caml_spacetime_classify_direct_call_point
|
||||
(value node, value offset)
|
||||
{
|
||||
uintnat field;
|
||||
value callee_node;
|
||||
|
||||
CAMLassert(Is_ocaml_node(node));
|
||||
|
||||
field = Long_val(offset);
|
||||
|
||||
callee_node = Direct_callee_node(node, field);
|
||||
if (!Is_block(callee_node)) {
|
||||
/* An unused call point (may be a tail call point). */
|
||||
return Val_long(0);
|
||||
} else if (Is_ocaml_node(callee_node)) {
|
||||
return Val_long(1); /* direct call point to OCaml code */
|
||||
} else {
|
||||
return Val_long(2); /* direct call point to non-OCaml code */
|
||||
}
|
||||
}
|
||||
|
||||
CAMLprim value caml_spacetime_ocaml_allocation_point_annotation
|
||||
(value node, value offset)
|
||||
{
|
||||
uintnat profinfo_shifted;
|
||||
profinfo_shifted = (uintnat) Alloc_point_profinfo(node, Long_val(offset));
|
||||
return Val_long(Spacetime_profinfo_hd(profinfo_shifted));
|
||||
}
|
||||
|
||||
CAMLprim value caml_spacetime_ocaml_allocation_point_count
|
||||
(value node, value offset)
|
||||
{
|
||||
value count = Alloc_point_count(node, Long_val(offset));
|
||||
CAMLassert(!Is_block(count));
|
||||
return count;
|
||||
}
|
||||
|
||||
CAMLprim value caml_spacetime_ocaml_direct_call_point_callee_node
|
||||
(value node, value offset)
|
||||
{
|
||||
return Direct_callee_node(node, Long_val(offset));
|
||||
}
|
||||
|
||||
CAMLprim value caml_spacetime_ocaml_direct_call_point_call_count
|
||||
(value node, value offset)
|
||||
{
|
||||
return Direct_call_count(node, Long_val(offset));
|
||||
}
|
||||
|
||||
CAMLprim value caml_spacetime_ocaml_indirect_call_point_callees
|
||||
(value node, value offset)
|
||||
{
|
||||
value callees = Indirect_pc_linked_list(node, Long_val(offset));
|
||||
CAMLassert(Is_block(callees));
|
||||
CAMLassert(Is_c_node(callees));
|
||||
return callees;
|
||||
}
|
||||
|
||||
CAMLprim value caml_spacetime_c_node_is_call(value node)
|
||||
{
|
||||
c_node* c_node;
|
||||
CAMLassert(node != (value) NULL);
|
||||
CAMLassert(Is_c_node(node));
|
||||
c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node);
|
||||
switch (caml_spacetime_offline_classify_c_node(c_node)) {
|
||||
case CALL: return Val_true;
|
||||
case ALLOCATION: return Val_false;
|
||||
}
|
||||
CAMLassert(0);
|
||||
return Val_unit; /* silence compiler warning */
|
||||
}
|
||||
|
||||
CAMLprim value caml_spacetime_c_node_next(value node)
|
||||
{
|
||||
c_node* c_node;
|
||||
|
||||
CAMLassert(node != (value) NULL);
|
||||
CAMLassert(Is_c_node(node));
|
||||
c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node);
|
||||
CAMLassert(c_node->next == Val_unit || Is_c_node(c_node->next));
|
||||
return c_node->next;
|
||||
}
|
||||
|
||||
CAMLprim value caml_spacetime_c_node_call_site(value node)
|
||||
{
|
||||
c_node* c_node;
|
||||
CAMLassert(node != (value) NULL);
|
||||
CAMLassert(Is_c_node(node));
|
||||
c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node);
|
||||
return caml_copy_int64((uint64_t) Decode_c_node_pc(c_node->pc));
|
||||
}
|
||||
|
||||
CAMLprim value caml_spacetime_c_node_callee_node(value node)
|
||||
{
|
||||
c_node* c_node;
|
||||
CAMLassert(node != (value) NULL);
|
||||
CAMLassert(Is_c_node(node));
|
||||
c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node);
|
||||
CAMLassert(caml_spacetime_offline_classify_c_node(c_node) == CALL);
|
||||
/* This might be an uninitialised tail call point: for example if an OCaml
|
||||
callee was indirectly called but the callee wasn't instrumented (e.g. a
|
||||
leaf function that doesn't allocate). */
|
||||
if (Is_tail_caller_node_encoded(c_node->data.call.callee_node)) {
|
||||
return Val_unit;
|
||||
}
|
||||
return c_node->data.call.callee_node;
|
||||
}
|
||||
|
||||
CAMLprim value caml_spacetime_c_node_call_count(value node)
|
||||
{
|
||||
c_node* c_node;
|
||||
CAMLassert(node != (value) NULL);
|
||||
CAMLassert(Is_c_node(node));
|
||||
c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node);
|
||||
CAMLassert(caml_spacetime_offline_classify_c_node(c_node) == CALL);
|
||||
if (Is_tail_caller_node_encoded(c_node->data.call.callee_node)) {
|
||||
return Val_long(0);
|
||||
}
|
||||
return c_node->data.call.call_count;
|
||||
}
|
||||
|
||||
CAMLprim value caml_spacetime_c_node_profinfo(value node)
|
||||
{
|
||||
c_node* c_node;
|
||||
CAMLassert(node != (value) NULL);
|
||||
CAMLassert(Is_c_node(node));
|
||||
c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node);
|
||||
CAMLassert(caml_spacetime_offline_classify_c_node(c_node) == ALLOCATION);
|
||||
CAMLassert(!Is_block(c_node->data.allocation.profinfo));
|
||||
return Val_long(Spacetime_profinfo_hd(c_node->data.allocation.profinfo));
|
||||
}
|
||||
|
||||
CAMLprim value caml_spacetime_c_node_allocation_count(value node)
|
||||
{
|
||||
c_node* c_node;
|
||||
CAMLassert(node != (value) NULL);
|
||||
CAMLassert(Is_c_node(node));
|
||||
c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node);
|
||||
CAMLassert(caml_spacetime_offline_classify_c_node(c_node) == ALLOCATION);
|
||||
CAMLassert(!Is_block(c_node->data.allocation.count));
|
||||
return c_node->data.allocation.count;
|
||||
}
|
||||
|
||||
#endif
|
|
@ -39,10 +39,6 @@
|
|||
/* threads.h is *not* included since it contains the _external_ declarations for
|
||||
the caml_c_thread_register and caml_c_thread_unregister functions. */
|
||||
|
||||
#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
|
||||
#include "caml/spacetime.h"
|
||||
#endif
|
||||
|
||||
#ifndef NATIVE_CODE
|
||||
/* Initial size of bytecode stack when a thread is created (4 Ko) */
|
||||
#define Thread_stack_size (Stack_size / 4)
|
||||
|
@ -84,12 +80,6 @@ struct caml_thread_struct {
|
|||
char * exception_pointer; /* Saved value of Caml_state->exception_pointer */
|
||||
struct caml__roots_block * local_roots; /* Saved value of local_roots */
|
||||
struct longjmp_buffer * exit_buf; /* For thread exit */
|
||||
#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
|
||||
value internal_spacetime_trie_root;
|
||||
value internal_spacetime_finaliser_trie_root;
|
||||
value* spacetime_trie_node_ptr;
|
||||
value* spacetime_finaliser_trie_root;
|
||||
#endif
|
||||
#else
|
||||
value * stack_low; /* The execution stack for this thread */
|
||||
value * stack_high;
|
||||
|
@ -194,12 +184,6 @@ Caml_inline void caml_thread_save_runtime_state(void)
|
|||
curr_thread->last_retaddr = Caml_state->last_return_address;
|
||||
curr_thread->gc_regs = Caml_state->gc_regs;
|
||||
curr_thread->exception_pointer = Caml_state->exception_pointer;
|
||||
#ifdef WITH_SPACETIME
|
||||
curr_thread->spacetime_trie_node_ptr
|
||||
= caml_spacetime_trie_node_ptr;
|
||||
curr_thread->spacetime_finaliser_trie_root
|
||||
= caml_spacetime_finaliser_trie_root;
|
||||
#endif
|
||||
#else
|
||||
curr_thread->stack_low = Caml_state->stack_low;
|
||||
curr_thread->stack_high = Caml_state->stack_high;
|
||||
|
@ -223,12 +207,6 @@ Caml_inline void caml_thread_restore_runtime_state(void)
|
|||
Caml_state->last_return_address = curr_thread->last_retaddr;
|
||||
Caml_state->gc_regs = curr_thread->gc_regs;
|
||||
Caml_state->exception_pointer = curr_thread->exception_pointer;
|
||||
#ifdef WITH_SPACETIME
|
||||
caml_spacetime_trie_node_ptr
|
||||
= curr_thread->spacetime_trie_node_ptr;
|
||||
caml_spacetime_finaliser_trie_root
|
||||
= curr_thread->spacetime_finaliser_trie_root;
|
||||
#endif
|
||||
#else
|
||||
Caml_state->stack_low = curr_thread->stack_low;
|
||||
Caml_state->stack_high = curr_thread->stack_high;
|
||||
|
@ -358,20 +336,6 @@ static caml_thread_t caml_thread_new_info(void)
|
|||
th->exception_pointer = NULL;
|
||||
th->local_roots = NULL;
|
||||
th->exit_buf = NULL;
|
||||
#ifdef WITH_SPACETIME
|
||||
/* CR-someday mshinwell: The commented-out changes here are for multicore,
|
||||
where we think we should have one trie per domain. */
|
||||
th->internal_spacetime_trie_root = Val_unit;
|
||||
th->spacetime_trie_node_ptr =
|
||||
&caml_spacetime_trie_root; /* &th->internal_spacetime_trie_root; */
|
||||
th->internal_spacetime_finaliser_trie_root = Val_unit;
|
||||
th->spacetime_finaliser_trie_root
|
||||
= caml_spacetime_finaliser_trie_root;
|
||||
/* &th->internal_spacetime_finaliser_trie_root; */
|
||||
caml_spacetime_register_thread(
|
||||
th->spacetime_trie_node_ptr,
|
||||
th->spacetime_finaliser_trie_root);
|
||||
#endif
|
||||
#else
|
||||
/* Allocate the stacks */
|
||||
th->stack_low = (value *) caml_stat_alloc(Thread_stack_size);
|
||||
|
@ -423,13 +387,7 @@ static void caml_thread_remove_info(caml_thread_t th)
|
|||
caml_stat_free(th->stack_low);
|
||||
#endif
|
||||
if (th->backtrace_buffer != NULL) caml_stat_free(th->backtrace_buffer);
|
||||
#ifndef WITH_SPACETIME
|
||||
caml_stat_free(th);
|
||||
/* CR-soon mshinwell: consider what to do about the Spacetime trace. Could
|
||||
perhaps have a hook to save a snapshot on thread termination.
|
||||
For the moment we can't even free [th], since it contains the trie
|
||||
roots. */
|
||||
#endif
|
||||
}
|
||||
|
||||
/* Reinitialize the thread machinery after a fork() (PR#4577) */
|
||||
|
|
|
@ -25,7 +25,7 @@ BYTECODE_C_SOURCES := $(addsuffix .c, \
|
|||
signals_byt printexc backtrace_byt backtrace compare ints eventlog \
|
||||
floats str array io extern intern hash sys meta parsing gc_ctrl md5 obj \
|
||||
lexing callback debugger weak compact finalise custom dynlink \
|
||||
spacetime_byt afl $(UNIX_OR_WIN32) bigarray main memprof domain \
|
||||
afl $(UNIX_OR_WIN32) bigarray main memprof domain \
|
||||
skiplist codefrag)
|
||||
|
||||
NATIVE_C_SOURCES := $(addsuffix .c, \
|
||||
|
@ -34,7 +34,7 @@ NATIVE_C_SOURCES := $(addsuffix .c, \
|
|||
floats str array io extern intern hash sys parsing gc_ctrl eventlog md5 obj \
|
||||
lexing $(UNIX_OR_WIN32) printexc callback weak compact finalise custom \
|
||||
globroots backtrace_nat backtrace dynlink_nat debugger meta \
|
||||
dynlink clambda_checks spacetime_nat spacetime_snapshot afl bigarray \
|
||||
dynlink clambda_checks afl bigarray \
|
||||
memprof domain skiplist codefrag)
|
||||
|
||||
GENERATED_HEADERS := caml/opnames.h caml/version.h caml/jumptbl.h
|
||||
|
@ -138,16 +138,13 @@ ifeq "$(UNIX_OR_WIN32)" "unix"
|
|||
OC_NATIVE_CPPFLAGS += -DMODEL_$(MODEL)
|
||||
endif
|
||||
|
||||
OC_NATIVE_CPPFLAGS += -DSYS_$(SYSTEM) $(IFLEXDIR) $(LIBUNWIND_INCLUDE_FLAGS)
|
||||
OC_NATIVE_CPPFLAGS += -DSYS_$(SYSTEM) $(IFLEXDIR)
|
||||
|
||||
OC_DEBUG_CPPFLAGS=-DDEBUG
|
||||
OC_INSTR_CPPFLAGS=-DCAML_INSTR
|
||||
|
||||
ifeq "$(TOOLCHAIN)" "msvc"
|
||||
ASMFLAGS=
|
||||
ifeq ($(WITH_SPACETIME),true)
|
||||
ASMFLAGS=/DWITH_SPACETIME
|
||||
endif
|
||||
endif
|
||||
|
||||
ASPPFLAGS = -DSYS_$(SYSTEM) -I$(ROOTDIR)/runtime
|
||||
|
|
|
@ -69,23 +69,6 @@ CAMLexport value caml_alloc_small (mlsize_t wosize, tag_t tag)
|
|||
return result;
|
||||
}
|
||||
|
||||
CAMLexport value caml_alloc_small_with_my_or_given_profinfo (mlsize_t wosize,
|
||||
tag_t tag, uintnat profinfo)
|
||||
{
|
||||
if (profinfo == 0) {
|
||||
return caml_alloc_small(wosize, tag);
|
||||
}
|
||||
else {
|
||||
value result;
|
||||
|
||||
CAMLassert (wosize > 0);
|
||||
CAMLassert (wosize <= Max_young_wosize);
|
||||
CAMLassert (tag < 256);
|
||||
Alloc_small_with_profinfo (result, wosize, tag, profinfo);
|
||||
return result;
|
||||
}
|
||||
}
|
||||
|
||||
/* [n] is a number of words (fields) */
|
||||
CAMLexport value caml_alloc_tuple(mlsize_t n)
|
||||
{
|
||||
|
|
|
@ -345,9 +345,6 @@ LBL(caml_call_gc):
|
|||
movq %rsp, Caml_state(gc_regs)
|
||||
/* Save young_ptr */
|
||||
movq %r15, Caml_state(young_ptr)
|
||||
#ifdef WITH_SPACETIME
|
||||
STORE_VAR(%r13, caml_spacetime_trie_node_ptr)
|
||||
#endif
|
||||
/* Save floating-point registers */
|
||||
subq $(16*8), %rsp; CFI_ADJUST (16*8);
|
||||
movsd %xmm0, 0*8(%rsp)
|
||||
|
@ -457,11 +454,6 @@ LBL(caml_c_call):
|
|||
movq %rsp, Caml_state(bottom_of_stack)
|
||||
/* equivalent to pushing last return address */
|
||||
subq $8, %rsp; CFI_ADJUST(8)
|
||||
#ifdef WITH_SPACETIME
|
||||
/* Record the trie node hole pointer that corresponds to
|
||||
[Caml_state->last_return_address] */
|
||||
STORE_VAR(%r13, caml_spacetime_trie_node_ptr)
|
||||
#endif
|
||||
/* Touch the stack to trigger a recoverable segfault
|
||||
if insufficient space remains */
|
||||
subq $(STACK_PROBE_SIZE), %rsp; CFI_ADJUST(STACK_PROBE_SIZE);
|
||||
|
@ -489,29 +481,10 @@ FUNCTION(G(caml_start_program))
|
|||
/* Common code for caml_start_program and caml_callback* */
|
||||
LBL(caml_start_program):
|
||||
/* Build a callback link */
|
||||
#ifdef WITH_SPACETIME
|
||||
PUSH_VAR(caml_spacetime_trie_node_ptr)
|
||||
#else
|
||||
subq $8, %rsp; CFI_ADJUST (8) /* stack 16-aligned */
|
||||
#endif
|
||||
pushq Caml_state(gc_regs); CFI_ADJUST(8)
|
||||
pushq Caml_state(last_return_address); CFI_ADJUST(8)
|
||||
pushq Caml_state(bottom_of_stack); CFI_ADJUST(8)
|
||||
#ifdef WITH_SPACETIME
|
||||
/* Save arguments to caml_callback* */
|
||||
pushq %rax; CFI_ADJUST (8)
|
||||
pushq %rbx; CFI_ADJUST (8)
|
||||
pushq %rdi; CFI_ADJUST (8)
|
||||
pushq %rsi; CFI_ADJUST (8)
|
||||
/* No need to push %r12: it's callee-save. */
|
||||
movq %r12, C_ARG_1
|
||||
LEA_VAR(caml_start_program, C_ARG_2)
|
||||
call GCALL(caml_spacetime_c_to_ocaml)
|
||||
popq %rsi; CFI_ADJUST (-8)
|
||||
popq %rdi; CFI_ADJUST (-8)
|
||||
popq %rbx; CFI_ADJUST (-8)
|
||||
popq %rax; CFI_ADJUST (-8)
|
||||
#endif
|
||||
/* Setup alloc ptr */
|
||||
movq Caml_state(young_ptr), %r15
|
||||
/* Build an exception handler */
|
||||
|
@ -519,9 +492,6 @@ LBL(caml_start_program):
|
|||
pushq %r13; CFI_ADJUST(8)
|
||||
pushq Caml_state(exception_pointer); CFI_ADJUST(8)
|
||||
movq %rsp, Caml_state(exception_pointer)
|
||||
#ifdef WITH_SPACETIME
|
||||
LOAD_VAR(caml_spacetime_trie_node_ptr, %r13)
|
||||
#endif
|
||||
/* Call the OCaml code */
|
||||
call *%r12
|
||||
LBL(107):
|
||||
|
@ -535,11 +505,7 @@ LBL(109):
|
|||
popq Caml_state(bottom_of_stack); CFI_ADJUST(-8)
|
||||
popq Caml_state(last_return_address); CFI_ADJUST(-8)
|
||||
popq Caml_state(gc_regs); CFI_ADJUST(-8)
|
||||
#ifdef WITH_SPACETIME
|
||||
POP_VAR(caml_spacetime_trie_node_ptr)
|
||||
#else
|
||||
addq $8, %rsp; CFI_ADJUST (-8);
|
||||
#endif
|
||||
/* Restore callee-save registers. */
|
||||
POP_CALLEE_SAVE_REGS
|
||||
/* Return to caller. */
|
||||
|
@ -708,19 +674,6 @@ G(caml_system__frametable):
|
|||
.quad 0
|
||||
.string "amd64.S"
|
||||
|
||||
#ifdef WITH_SPACETIME
|
||||
.data
|
||||
.globl G(caml_system__spacetime_shapes)
|
||||
.align EIGHT_ALIGN
|
||||
G(caml_system__spacetime_shapes):
|
||||
.quad G(caml_start_program)
|
||||
.quad 2 /* indirect call point to OCaml code */
|
||||
.quad LBL(107) /* in caml_start_program / caml_callback* */
|
||||
.quad 0 /* end of shapes for caml_start_program */
|
||||
.quad 0 /* end of shape table */
|
||||
.align EIGHT_ALIGN
|
||||
#endif
|
||||
|
||||
#if defined(SYS_macosx)
|
||||
.literal16
|
||||
#elif defined(SYS_mingw64) || defined(SYS_cygwin)
|
||||
|
|
|
@ -26,10 +26,6 @@
|
|||
EXTRN caml_program: NEAR
|
||||
EXTRN caml_array_bound_error: NEAR
|
||||
EXTRN caml_stash_backtrace: NEAR
|
||||
IFDEF WITH_SPACETIME
|
||||
EXTRN caml_spacetime_trie_node_ptr: QWORD
|
||||
EXTRN caml_spacetime_c_to_ocaml: NEAR
|
||||
ENDIF
|
||||
|
||||
INCLUDE domain_state64.inc
|
||||
|
||||
|
@ -57,9 +53,6 @@ caml_call_gc:
|
|||
add rsp, 01000h
|
||||
; Save young_ptr
|
||||
Store_young_ptr r15
|
||||
IFDEF WITH_SPACETIME
|
||||
mov caml_spacetime_trie_node_ptr, r13
|
||||
ENDIF
|
||||
; Build array of registers, save it into Caml_state(gc_regs)
|
||||
push rbp
|
||||
push r11
|
||||
|
@ -173,11 +166,6 @@ caml_c_call:
|
|||
pop r12
|
||||
Store_last_return_address r12
|
||||
Store_bottom_of_stack rsp
|
||||
IFDEF WITH_SPACETIME
|
||||
; Record the trie node hole pointer that corresponds to
|
||||
; [Caml_state(last_return_address)]
|
||||
mov caml_spacetime_trie_node_ptr, r13
|
||||
ENDIF
|
||||
; Touch the stack to trigger a recoverable segfault
|
||||
; if insufficient space remains
|
||||
sub rsp, 01000h
|
||||
|
@ -225,29 +213,10 @@ caml_start_program:
|
|||
; Common code for caml_start_program and caml_callback*
|
||||
L106:
|
||||
; Build a callback link
|
||||
IFDEF WITH_SPACETIME
|
||||
push caml_spacetime_trie_node_ptr
|
||||
ELSE
|
||||
sub rsp, 8 ; stack 16-aligned
|
||||
ENDIF
|
||||
Push_gc_regs
|
||||
Push_last_return_address
|
||||
Push_bottom_of_stack
|
||||
IFDEF WITH_SPACETIME
|
||||
; Save arguments to caml_callback
|
||||
push rax
|
||||
push rbx
|
||||
push rdi
|
||||
push rsi
|
||||
; No need to push r12: it is callee-save.
|
||||
mov rcx, r12
|
||||
lea rdx, caml_start_program
|
||||
call caml_spacetime_c_to_ocaml
|
||||
pop rsi
|
||||
pop rdi
|
||||
pop rbx
|
||||
pop rax
|
||||
ENDIF
|
||||
; Setup alloc ptr
|
||||
Load_young_ptr r15
|
||||
; Build an exception handler
|
||||
|
@ -255,9 +224,6 @@ ENDIF
|
|||
push r13
|
||||
Push_exception_pointer
|
||||
Store_exception_pointer rsp
|
||||
IFDEF WITH_SPACETIME
|
||||
mov r13, caml_spacetime_trie_node_ptr
|
||||
ENDIF
|
||||
; Call the OCaml code
|
||||
call r12
|
||||
L107:
|
||||
|
@ -271,11 +237,7 @@ L109:
|
|||
Pop_bottom_of_stack
|
||||
Pop_last_return_address
|
||||
Pop_gc_regs
|
||||
IFDEF WITH_SPACETIME
|
||||
pop caml_spacetime_trie_node_ptr
|
||||
ELSE
|
||||
add rsp, 8
|
||||
ENDIF
|
||||
; Restore callee-save registers.
|
||||
movapd xmm6, OWORD PTR [rsp + 0*16]
|
||||
movapd xmm7, OWORD PTR [rsp + 1*16]
|
||||
|
@ -473,19 +435,6 @@ caml_system__frametable LABEL QWORD
|
|||
WORD 0 ; no roots here
|
||||
ALIGN 8
|
||||
|
||||
IFDEF WITH_SPACETIME
|
||||
.DATA
|
||||
PUBLIC caml_system__spacetime_shapes
|
||||
ALIGN 8
|
||||
caml_system__spacetime_shapes LABEL QWORD
|
||||
QWORD caml_start_program
|
||||
QWORD 2 ; indirect call point to OCaml code
|
||||
QWORD L107 ; in caml_start_program / caml_callback*
|
||||
QWORD 0 ; end of shapes in caml_start_program
|
||||
QWORD 0 ; end of shape table
|
||||
ALIGN 8
|
||||
ENDIF
|
||||
|
||||
PUBLIC caml_negf_mask
|
||||
ALIGN 16
|
||||
caml_negf_mask LABEL QWORD
|
||||
|
|
|
@ -24,8 +24,6 @@
|
|||
#include "caml/mlvalues.h"
|
||||
#include "caml/signals.h"
|
||||
#include "caml/eventlog.h"
|
||||
/* Why is caml/spacetime.h included conditionnally sometimes and not here ? */
|
||||
#include "caml/spacetime.h"
|
||||
|
||||
static const mlsize_t mlsize_t_max = -1;
|
||||
|
||||
|
@ -285,7 +283,6 @@ CAMLprim value caml_floatarray_create(value len)
|
|||
}
|
||||
|
||||
/* [len] is a [value] representing number of words or floats */
|
||||
/* Spacetime profiling assumes that this function is only called from OCaml. */
|
||||
CAMLprim value caml_make_vect(value len, value init)
|
||||
{
|
||||
CAMLparam2 (len, init);
|
||||
|
@ -311,9 +308,7 @@ CAMLprim value caml_make_vect(value len, value init)
|
|||
#endif
|
||||
} else {
|
||||
if (size <= Max_young_wosize) {
|
||||
uintnat profinfo;
|
||||
Get_my_profinfo_with_cached_backtrace(profinfo, size);
|
||||
res = caml_alloc_small_with_my_or_given_profinfo(size, 0, profinfo);
|
||||
res = caml_alloc_small(size, 0);
|
||||
for (i = 0; i < size; i++) Field(res, i) = init;
|
||||
}
|
||||
else if (size > Max_wosize) caml_invalid_argument("Array.make");
|
||||
|
|
|
@ -51,9 +51,6 @@ CAMLextern value caml_alloc_sprintf(const char * format, ...)
|
|||
;
|
||||
CAMLextern value caml_alloc_some(value);
|
||||
|
||||
CAMLextern value caml_alloc_small_with_my_or_given_profinfo (
|
||||
mlsize_t, tag_t, uintnat);
|
||||
|
||||
typedef void (*final_fun)(value);
|
||||
CAMLextern value caml_alloc_final (mlsize_t wosize,
|
||||
final_fun, /*finalization function*/
|
||||
|
|
|
@ -56,17 +56,6 @@
|
|||
Make_header(wosize, tag, color)
|
||||
#endif
|
||||
|
||||
#ifdef WITH_SPACETIME
|
||||
struct ext_table;
|
||||
extern uintnat caml_spacetime_my_profinfo(struct ext_table**, uintnat);
|
||||
#define Make_header_allocated_here(wosize, tag, color) \
|
||||
(Make_header_with_profinfo(wosize, tag, color, \
|
||||
caml_spacetime_my_profinfo(NULL, wosize)) \
|
||||
)
|
||||
#else
|
||||
#define Make_header_allocated_here Make_header
|
||||
#endif
|
||||
|
||||
#define Is_white_val(val) (Color_val(val) == Caml_white)
|
||||
#define Is_blue_val(val) (Color_val(val) == Caml_blue)
|
||||
#define Is_black_val(val) (Color_val(val) == Caml_black)
|
||||
|
|
|
@ -127,17 +127,6 @@ CAMLextern intnat caml_output_value_to_block(value v, value flags,
|
|||
#ifdef CAML_INTERNALS
|
||||
value caml_input_val (struct channel * chan);
|
||||
/* Read a structured value from the channel [chan]. */
|
||||
|
||||
extern value caml_input_value_to_outside_heap (value channel);
|
||||
/* As for [caml_input_value], but the value is unmarshalled into
|
||||
malloc blocks that are not added to the heap. Not for the
|
||||
casual user. */
|
||||
|
||||
extern int caml_extern_allow_out_of_heap;
|
||||
/* Permit the marshaller to traverse structures that look like OCaml
|
||||
values but do not live in the OCaml heap. */
|
||||
|
||||
extern value caml_output_value(value vchan, value v, value flags);
|
||||
#endif /* CAML_INTERNALS */
|
||||
|
||||
CAMLextern value caml_input_val_from_string (value str, intnat ofs);
|
||||
|
|
|
@ -52,9 +52,6 @@ struct channel {
|
|||
|
||||
enum {
|
||||
CHANNEL_FLAG_FROM_SOCKET = 1, /* For Windows */
|
||||
#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
|
||||
CHANNEL_FLAG_BLOCKING_WRITE = 2, /* Don't release master lock when writing */
|
||||
#endif
|
||||
CHANNEL_FLAG_MANAGED_BY_GC = 4, /* Free and close using GC finalization */
|
||||
CHANNEL_TEXT_MODE = 8, /* "Text mode" for Windows and Cygwin */
|
||||
};
|
||||
|
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue