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

Remove Spacetime

master
Nicolás Ojeda Bär 2020-10-08 15:19:31 +02:00
parent eb342da8a9
commit 540996d21e
103 changed files with 87 additions and 5311 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
.depend
View File

@ -2438,7 +2438,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 : \
@ -2446,7 +2445,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 : \
@ -2568,7 +2566,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 : \
@ -2578,7 +2575,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 : \
@ -2601,7 +2597,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 : \
@ -2610,7 +2605,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 : \
@ -2691,7 +2685,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 \
@ -2706,7 +2699,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 \
@ -2817,7 +2809,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 \
@ -2832,7 +2823,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 \
@ -2847,21 +2837,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 \
@ -2869,36 +2855,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 \

4
Makefile
View File

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

6
Makefile.config.in
View File

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

2
asmcomp/amd64/arch.ml
View File

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

137
asmcomp/amd64/emit.mlp
View File

@ -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 =
@ -276,65 +267,42 @@ let record_frame ?label live dbg =
let lbl = record_frame_label ?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 ?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
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 +311,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
@ -582,14 +545,11 @@ let emit_instr fallthrough i =
add_used_symbol func;
emit_call func;
record_frame i.live (Dbg_other i.dbg) ~label:label_after
| Lop(Itailcall_ind { 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
I.jmp (arg i 0)
end
| Lop(Itailcall_imm { func; label_after; }) ->
| Lop(Itailcall_imm { func; label_after = _; }) ->
begin
if func = !function_name then
I.jmp (label !tailrec_entry_point)
@ -599,9 +559,6 @@ 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; }) ->
add_used_symbol func;
@ -620,10 +577,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,7 +625,7 @@ 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; label_after_call_gc; dbginfo }) ->
assert (n <= (Config.max_young_wosize + 1) * Arch.size_addr);
if !fastcode_flag then begin
I.sub (int n) r15;
@ -684,20 +638,11 @@ let emit_instr fallthrough i =
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"
@ -721,20 +666,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 { label_after_error; } )) ->
let lbl = bound_error_label ?label:label_after_error i.dbg in
I.cmp (arg i 1) (arg i 0);
I.jbe (label lbl)
| Lop(Iintop_imm(Icheckbound { 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 { label_after_error; }, n)) ->
let lbl = bound_error_label ?label:label_after_error i.dbg in
I.cmp (int n) (arg i 0);
I.jbe (label lbl)
| Lop(Iintop(Idiv | Imod)) ->
@ -907,9 +844,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 +947,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 +985,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 +1045,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" ];

31
asmcomp/amd64/proc.ml
View File

@ -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,20 +294,11 @@ 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; }) ->
@ -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 |]
| _ ->

4
asmcomp/amd64/selection.ml
View File

@ -129,7 +129,7 @@ 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
@ -181,7 +181,7 @@ method! select_store is_assign addr exp =
| (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 ->
when is_immediate_natint n ->
(Ispecific(Istore_int(n, addr, is_assign)), Ctuple [])
| _ ->
super#select_store is_assign addr exp

2
asmcomp/arm/arch.ml
View File

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

2
asmcomp/arm/proc.ml
View File

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

6
asmcomp/arm64/arch.ml
View File

@ -66,12 +66,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

2
asmcomp/arm64/proc.ml
View File

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

10
asmcomp/asmlink.ml
View File

@ -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 ()
@ -330,14 +327,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

12
asmcomp/cmm_helpers.ml
View File

@ -2628,18 +2628,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 =

4
asmcomp/cmm_helpers.mli
View File

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

5
asmcomp/comballoc.ml
View File

@ -59,7 +59,7 @@ 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;
(instr_cons_debug (Iop(Ialloc {bytes = totalsz;
dbginfo; label_after_call_gc = None; }))
i.arg i.res i.dbg next, allocstate)
end
@ -99,5 +99,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}

16
asmcomp/deadcode.ml
View File

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

2
asmcomp/emitaux.ml
View File

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

2
asmcomp/i386/arch.ml
View File

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

2
asmcomp/i386/proc.ml
View File

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

1
asmcomp/linear.ml
View File

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

1
asmcomp/linear.mli
View File

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

8
asmcomp/linearize.ml
View File

@ -138,10 +138,7 @@ let linear i n contains_calls =
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)
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;

25
asmcomp/liveness.ml
View File

@ -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 _) ->
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. *)
@ -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

47
asmcomp/mach.ml
View File

@ -25,8 +25,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 of { label_after_error : label option; }
type float_comparison = Cmm.float_comparison
@ -57,7 +56,7 @@ type operation =
| 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; }
dbginfo : Debuginfo.alloc_dbginfo; }
| Iintop of integer_operation
| Iintop_imm of integer_operation * int
| Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf
@ -88,20 +87,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;
}
@ -167,40 +158,6 @@ 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 _

26
asmcomp/mach.mli
View File

@ -29,11 +29,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 of { label_after_error : label option; }
type float_comparison = Cmm.float_comparison
@ -65,9 +61,7 @@ type operation =
| 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. *)
dbginfo : Debuginfo.alloc_dbginfo; }
| Iintop of integer_operation
| Iintop_imm of integer_operation * int
| Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf
@ -104,26 +98,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 +118,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

7
asmcomp/power/arch.ml
View File

@ -52,13 +52,6 @@ type specific_operation =
{ 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
(* Addressing modes *)
type addressing_mode =

2
asmcomp/power/proc.ml
View File

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

10
asmcomp/printmach.ml
View File

@ -90,16 +90,13 @@ 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] > "
| Icheckbound { label_after_error; } ->
Printf.sprintf "check[lbl=%s] > "
begin
match label_after_error with
| None -> ""
| Some lbl -> Int.to_string lbl
end
spacetime_index
let test tst ppf arg =
match tst with
@ -143,9 +140,6 @@ let operation op arg ppf res =
(if is_assign then "(assign)" else "(init)")
| 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)

1
asmcomp/proc.mli
View File

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

2
asmcomp/reloadgen.ml
View File

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

3
asmcomp/riscv/arch.ml
View File

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

2
asmcomp/riscv/proc.ml
View File

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

2
asmcomp/s390x/arch.ml
View File

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

2
asmcomp/s390x/proc.ml
View File

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

1
asmcomp/schedgen.ml
View File

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

102
asmcomp/selectgen.ml
View File

@ -437,14 +437,12 @@ method mark_instr = function
(* Default instruction selection for operators *)
method select_allocation bytes =
method private select_allocation bytes =
Ialloc { bytes; label_after_call_gc = None;
dbginfo = []; spacetime_index = 0; }
method select_allocation_args _env = [| |]
dbginfo = []; }
method select_checkbound () =
Icheckbound { spacetime_index = 0; label_after_error = None; }
method select_checkbound_extra_args () = []
method private select_checkbound =
Icheckbound { label_after_error = None; }
method select_operation op args _dbg =
match (op, args) with
@ -505,9 +503,8 @@ 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)
let op = self#select_checkbound in
self#select_arith op args
| _ -> Misc.fatal_error "Selection.select_oper"
method private select_arith_comm op = function
@ -576,15 +573,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 +616,10 @@ 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 =
method private 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 *)
@ -727,11 +711,7 @@ method emit_expr (env:environment) exp =
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 +721,29 @@ 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 = _; label_after_call_gc; } ->
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;
Ialloc { bytes; label_after_call_gc;
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 ->
@ -1087,21 +1059,13 @@ method emit_tail (env:environment) exp =
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
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))) [||] [||];
@ -1112,29 +1076,17 @@ method emit_tail (env:environment) exp =
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
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 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 [||]
@ -1222,16 +1174,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 +1184,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;
}

31
asmcomp/selectgen.mli
View File

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

480
asmcomp/spacetime_profiling.ml
View File

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

17
asmcomp/spacetime_profiling.mli
View File

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

1
asmcomp/spill.ml
View File

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

1
asmcomp/split.ml
View File

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

2
compilerlibs/Makefile.compilerlibs
View File

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

188
configure generated vendored
View File

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

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

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

1
manual/README.md
View File

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

1
manual/manual/allfiles.etex
View File

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

4
manual/manual/cmds/Makefile
View File

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

125
manual/manual/cmds/spacetime-chapter.etex
View File

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

3
manual/manual/library/stdlib-blurb.etex
View File

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

1
ocamltest/Makefile
View File

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

14
ocamltest/ocaml_actions.ml
View File

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

4
ocamltest/ocaml_tests.ml
View File

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

2
ocamltest/ocamltest_config.ml.in
View File

@ -47,8 +47,6 @@ let ocamlsrcdir = "%%ocamlsrcdir%%"
let flambda = %%FLAMBDA%%
let spacetime = %%WITH_SPACETIME%%
let ocamlc_default_flags = "%%ocamlcdefaultflags%%"
let ocamlopt_default_flags = "%%ocamloptdefaultflags%%"

3
ocamltest/ocamltest_config.mli
View File

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

2
otherlibs/Makefile
View File

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

5
otherlibs/raw_spacetime_lib/.depend
View File

@ -1,5 +0,0 @@
raw_spacetime_lib.cmo : \
raw_spacetime_lib.cmi
raw_spacetime_lib.cmx : \
raw_spacetime_lib.cmi
raw_spacetime_lib.cmi :

28
otherlibs/raw_spacetime_lib/Makefile
View File

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

668
otherlibs/raw_spacetime_lib/raw_spacetime_lib.ml
View File

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

364
otherlibs/raw_spacetime_lib/raw_spacetime_lib.mli
View File

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

250
otherlibs/raw_spacetime_lib/spacetime_offline.c
View File

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

42
otherlibs/systhreads/st_stubs.c
View File

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

9
runtime/Makefile
View File

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

17
runtime/alloc.c
View File

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

47
runtime/amd64.S
View File

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

51
runtime/amd64nt.asm
View File

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

7
runtime/array.c
View File

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

3
runtime/caml/alloc.h
View File

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

11
runtime/caml/gc.h
View File

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

3
runtime/caml/io.h
View File

@ -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 */
};

3
runtime/caml/m.h.in
View File

@ -78,9 +78,6 @@
#undef PROFINFO_WIDTH
#undef WITH_SPACETIME
#undef ENABLE_CALL_COUNTS
#undef ASM_CFI_SUPPORTED
#undef WITH_FRAME_POINTERS

15
runtime/caml/memory.h
View File

@ -240,26 +240,11 @@ extern void caml_alloc_small_dispatch (intnat wosize, int flags,
#define Alloc_small_with_profinfo(result, wosize, tag, profinfo) \
Alloc_small_aux(result, wosize, tag, profinfo, CAML_DO_TRACK)
#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
extern uintnat caml_spacetime_my_profinfo(struct ext_table**, uintnat);
#define Alloc_small(result, wosize, tag) \
Alloc_small_with_profinfo(result, wosize, tag, \
caml_spacetime_my_profinfo(NULL, wosize))
#define Alloc_small_no_track(result, wosize, tag) \
Alloc_small_aux(result, wosize, tag, \
caml_spacetime_my_profinfo(NULL, wosize), CAML_DONT_TRACK)
#else
#define Alloc_small(result, wosize, tag) \
Alloc_small_with_profinfo(result, wosize, tag, (uintnat) 0)
#define Alloc_small_no_track(result, wosize, tag) \
Alloc_small_aux(result, wosize, tag, (uintnat) 0, CAML_DONT_TRACK)
#endif
/* Deprecated alias for [caml_modify] */
#define Modify(fp,val) caml_modify((fp), (val))

2
runtime/caml/s.h.in
View File

@ -266,8 +266,6 @@
#undef HUGE_PAGE_SIZE
#undef HAS_LIBUNWIND
#undef HAS_BROKEN_PRINTF
#undef HAS_STRERROR

200
runtime/caml/spacetime.h
View File

@ -1,200 +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. */
/* */
/**************************************************************************/
#ifndef CAML_SPACETIME_H
#define CAML_SPACETIME_H
#include "io.h"
#include "misc.h"
#include "stack.h"
/* Runtime support for Spacetime profiling.
* This header file is not intended for the casual user.
*
* The implementation is split into three files:
* 1. spacetime.c: core management of the instrumentation;
* 2. spacetime_snapshot.c: the taking of heap snapshots;
* 3. spacetime_offline.c: functions that are also used when examining
* saved profiling data.
*/
typedef enum {
CALL,
ALLOCATION
} c_node_type;
/* All pointers between nodes point at the word immediately after the
GC headers, and everything is traversable using the normal OCaml rules.
On entry to an OCaml function:
If the node hole pointer register has the bottom bit set, then the function
is being tail called or called from a self-recursive call site:
- If the node hole is empty, the callee must create a new node and link
it into the tail chain. The node hole pointer will point at the tail
chain.
- Otherwise the node should be used as normal.
Otherwise (not a tail call):
- If the node hole is empty, the callee must create a new node, but the
tail chain is untouched.
- Otherwise the node should be used as normal.
*/
/* Classification of nodes (OCaml or C) with corresponding GC tags. */
#define OCaml_node_tag 0
#define C_node_tag 1
#define Is_ocaml_node(node) (Is_block(node) && Tag_val(node) == OCaml_node_tag)
#define Is_c_node(node) (Is_block(node) && Tag_val(node) == C_node_tag)
/* The header words are:
1. The node program counter.
2. The tail link. */
#define Node_num_header_words 2
/* The "node program counter" at the start of an OCaml node. */
#define Node_pc(node) (Field(node, 0))
#define Encode_node_pc(pc) (((value) pc) | 1)
#define Decode_node_pc(encoded_pc) ((void*) (encoded_pc & ~1))
/* The circular linked list of tail-called functions within OCaml nodes. */
#define Tail_link(node) (Field(node, 1))
/* The convention for pointers from OCaml nodes to other nodes. There are
two special cases:
1. [Val_unit] means "uninitialized", and further, that this is not a
tail call point. (Tail call points are pre-initialized, as in case 2.)
2. If the bottom bit is set, and the value is not [Val_unit], this is a
tail call point. */
#define Encode_tail_caller_node(node) ((node) | 1)
#define Decode_tail_caller_node(node) ((node) & ~1)
#define Is_tail_caller_node_encoded(node) (((node) & 1) == 1)
/* Allocation points within OCaml nodes.
The "profinfo" value looks exactly like a black Infix_tag header.
This enables us to point just after it and return such pointer as a valid
OCaml value. (Used for the list of all allocation points. We could do
without this and instead just encode the list pointers as integers, but
this would mean that the structure was destroyed on marshalling. This
might not be a great problem since it is intended that the total counts
be obtained via snapshots, but it seems neater and easier to use
Infix_tag.
The "count" is just an OCaml integer giving the total number of words
(including headers) allocated at the point.
The "pointer to next allocation point" points to the "count" word of the
next allocation point in the linked list of all allocation points.
There is no special encoding needed by virtue of the [Infix_tag] trick. */
#define Alloc_point_profinfo(node, offset) (Field(node, offset))
#define Alloc_point_count(node, offset) (Field(node, offset + 1))
#define Alloc_point_next_ptr(node, offset) (Field(node, offset + 2))
/* Direct call points (tail or non-tail) within OCaml nodes.
They hold a pointer to the child node and (if the compiler was so
configured) a call count.
The call site and callee are both recorded in the shape. */
#define Direct_callee_node(node,offset) (Field(node, offset))
#define Direct_call_count(node,offset) (Field(node, offset + 1))
#define Encode_call_point_pc(pc) (((value) pc) | 1)
#define Decode_call_point_pc(pc) ((void*) (((value) pc) & ~((uintnat) 1)))
/* Indirect call points (tail or non-tail) within OCaml nodes.
They hold a linked list of (PC upon entry to the callee, pointer to
child node) pairs. The linked list is encoded using C nodes and should
be thought of as part of the OCaml node itself. */
#define Indirect_num_fields 1
#define Indirect_pc_linked_list(node,offset) (Field(node, offset))
/* Encodings of the program counter value within a C node. */
#define Encode_c_node_pc_for_call(pc) ((((value) pc) << 2) | 3)
#define Encode_c_node_pc_for_alloc_point(pc) ((((value) pc) << 2) | 1)
#define Decode_c_node_pc(pc) ((void*) (((uintnat) (pc)) >> 2))
typedef struct {
/* The layout and encoding of this structure must match that of the
allocation points within OCaml nodes, so that the linked list
traversal across all allocation points works correctly. */
value profinfo; /* encoded using [Infix_tag] (see above) */
value count;
/* [next] is [Val_unit] for the end of the list.
Otherwise it points at the second word of this [allocation_point]
structure. */
value next;
} allocation_point;
typedef struct {
value callee_node;
value call_count;
} call_point;
typedef struct {
/* CR-soon mshinwell: delete [gc_header], all the offset arithmetic will
then go away */
uintnat gc_header;
uintnat pc; /* see above for encodings */
union {
call_point call; /* for CALL */
allocation_point allocation; /* for ALLOCATION */
} data;
value next; /* [Val_unit] for the end of the list */
} c_node; /* CR-soon mshinwell: rename to dynamic_node */
typedef struct shape_table {
uint64_t* table;
struct shape_table* next;
} shape_table;
extern uint64_t** caml_spacetime_static_shape_tables;
extern shape_table* caml_spacetime_dynamic_shape_tables;
typedef struct ext_table* spacetime_unwind_info_cache;
extern value caml_spacetime_trie_root;
extern value* caml_spacetime_trie_node_ptr;
extern value* caml_spacetime_finaliser_trie_root;
extern allocation_point* caml_all_allocation_points;
extern void caml_spacetime_initialize(void);
extern uintnat caml_spacetime_my_profinfo(
spacetime_unwind_info_cache*, uintnat);
extern c_node_type caml_spacetime_classify_c_node(c_node* node);
extern c_node* caml_spacetime_c_node_of_stored_pointer(value);
extern c_node* caml_spacetime_c_node_of_stored_pointer_not_null(value);
extern value caml_spacetime_stored_pointer_of_c_node(c_node* node);
extern void caml_spacetime_register_thread(value*, value*);
extern void caml_spacetime_register_shapes(void*);
extern value caml_spacetime_frame_table(void);
extern value caml_spacetime_shape_table(void);
extern void caml_spacetime_save_snapshot (struct channel *chan,
double time_override,
int use_time_override);
extern value caml_spacetime_timestamp(double time_override,
int use_time_override);
extern void caml_spacetime_automatic_snapshot (void);
/* For use in runtime functions that are executed from OCaml
code, to save the overhead of using libunwind every time. */
#ifdef WITH_SPACETIME
#define Get_my_profinfo_with_cached_backtrace(profinfo, size) \
do { \
static spacetime_unwind_info_cache spacetime_unwind_info = NULL; \
profinfo = caml_spacetime_my_profinfo(&spacetime_unwind_info, size); \
} \
while (0);
#else
#define Get_my_profinfo_with_cached_backtrace(profinfo, size) \
profinfo = (uintnat) 0;
#endif
#endif /* CAML_SPACETIME_H */

3
runtime/caml/stack.h
View File

@ -81,9 +81,6 @@ struct caml_context {
char * bottom_of_stack; /* beginning of OCaml stack chunk */
uintnat last_retaddr; /* last return address in OCaml code */
value * gc_regs; /* pointer to register block */
#ifdef WITH_SPACETIME
void* trie_node;
#endif
};
/* Structure of frame descriptors */

4
runtime/dune
View File

@ -22,7 +22,7 @@
lexing.c md5.c meta.c memprof.c obj.c parsing.c signals.c str.c sys.c
callback.c weak.c
finalise.c stacks.c dynlink.c backtrace_byt.c backtrace.c
spacetime_byt.c afl.c
afl.c
bigarray.c eventlog.c)
(action (with-stdout-to %{targets} (run %{dep:gen_primitives.sh}))))
@ -44,7 +44,7 @@
floats.c str.c array.c io.c extern.c intern.c hash.c sys.c meta.c parsing.c
gc_ctrl.c md5.c obj.c
lexing.c callback.c debugger.c weak.c compact.c finalise.c custom.c dynlink.c
spacetime_byt.c afl.c unix.c win32.c bigarray.c main.c memprof.c domain.c
afl.c unix.c win32.c bigarray.c main.c memprof.c domain.c
skiplist.c codefrag.c
)
(action

8
runtime/dynlink_nat.c
View File

@ -26,9 +26,6 @@
#include "caml/osdeps.h"
#include "caml/fail.h"
#include "caml/signals.h"
#ifdef WITH_SPACETIME
#include "caml/spacetime.h"
#endif
#include "caml/hooks.h"
@ -111,11 +108,6 @@ CAMLprim value caml_natdynlink_run(value handle_v, value symbol) {
sym = optsym("__frametable");
if (NULL != sym) caml_register_frametable(sym);
#ifdef WITH_SPACETIME
sym = optsym("__spacetime_shapes");
if (NULL != sym) caml_spacetime_register_shapes(sym);
#endif
sym = optsym("__gc_roots");
if (NULL != sym) caml_register_dyn_global(sym);

16
runtime/finalise.c
View File

@ -25,9 +25,6 @@
#include "caml/mlvalues.h"
#include "caml/roots.h"
#include "caml/signals.h"
#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
#include "caml/spacetime.h"
#endif
struct final {
value fun;
@ -170,9 +167,6 @@ value caml_final_do_calls_exn (void)
{
struct final f;
value res;
#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
void* saved_spacetime_trie_node_ptr;
#endif
if (!running_finalisation_function && to_do_hd != NULL){
if (caml_finalise_begin_hook != NULL) (*caml_finalise_begin_hook) ();
@ -189,17 +183,7 @@ value caml_final_do_calls_exn (void)
-- to_do_hd->size;
f = to_do_hd->item[to_do_hd->size];
running_finalisation_function = 1;
#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
/* We record the finaliser's execution separately.
(The code of [caml_callback_exn] will do the hard work of finding
the correct place in the trie.) */
saved_spacetime_trie_node_ptr = caml_spacetime_trie_node_ptr;
caml_spacetime_trie_node_ptr = caml_spacetime_finaliser_trie_root;
#endif
res = caml_callback_exn (f.fun, f.val + f.offset);
#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
caml_spacetime_trie_node_ptr = saved_spacetime_trie_node_ptr;
#endif
running_finalisation_function = 0;
if (Is_exception_result (res)) return res;
}

2
runtime/gen_primitives.sh
View File

@ -24,7 +24,7 @@ export LC_ALL=C
for prim in \
alloc array compare extern floats gc_ctrl hash intern interp ints io \
lexing md5 meta memprof obj parsing signals str sys callback weak \
finalise stacks dynlink backtrace_byt backtrace spacetime_byt afl \
finalise stacks dynlink backtrace_byt backtrace afl \
bigarray eventlog
do
sed -n -e 's/^CAMLprim value \([a-z0-9_][a-z0-9_]*\).*/\1/p' "$prim.c"

16
runtime/intern.c
View File

@ -372,7 +372,7 @@ static void intern_rec(value *dest)
} else {
v = Val_hp(intern_dest);
if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v;
*intern_dest = Make_header_allocated_here(size, tag, intern_color);
*intern_dest = Make_header(size, tag, intern_color);
intern_dest += 1 + size;
/* For objects, we need to freshen the oid */
if (tag == Object_tag) {
@ -402,7 +402,7 @@ static void intern_rec(value *dest)
size = (len + sizeof(value)) / sizeof(value);
v = Val_hp(intern_dest);
if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v;
*intern_dest = Make_header_allocated_here(size, String_tag, intern_color);
*intern_dest = Make_header(size, String_tag, intern_color);
intern_dest += 1 + size;
Field(v, size - 1) = 0;
ofs_ind = Bsize_wsize(size) - 1;
@ -474,8 +474,8 @@ static void intern_rec(value *dest)
case CODE_DOUBLE_BIG:
v = Val_hp(intern_dest);
if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v;
*intern_dest = Make_header_allocated_here(Double_wosize, Double_tag,
intern_color);
*intern_dest = Make_header(Double_wosize, Double_tag,
intern_color);
intern_dest += 1 + Double_wosize;
readfloat((double *) v, code);
break;
@ -486,8 +486,8 @@ static void intern_rec(value *dest)
size = len * Double_wosize;
v = Val_hp(intern_dest);
if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v;
*intern_dest = Make_header_allocated_here(size, Double_array_tag,
intern_color);
*intern_dest = Make_header(size, Double_array_tag,
intern_color);
intern_dest += 1 + size;
readfloats((double *) v, len, code);
break;
@ -570,8 +570,8 @@ static void intern_rec(value *dest)
size = 1 + (size + sizeof(value) - 1) / sizeof(value);
v = Val_hp(intern_dest);
if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v;
*intern_dest = Make_header_allocated_here(size, Custom_tag,
intern_color);
*intern_dest = Make_header(size, Custom_tag,
intern_color);
Custom_ops_val(v) = ops;
if (ops->finalize != NULL && Is_young(v)) {

18
runtime/memory.c
View File

@ -404,7 +404,7 @@ static value *expand_heap (mlsize_t request)
}else{
Field (Val_hp (prev), 0) = (value) NULL;
if (remain == 1) {
Hd_hp (hp) = Make_header_allocated_here (0, 0, Caml_white);
Hd_hp (hp) = Make_header (0, 0, Caml_white);
}
}
CAMLassert (Wosize_hp (mem) >= request);
@ -560,21 +560,6 @@ CAMLexport value caml_alloc_shr_for_minor_gc (mlsize_t wosize,
}
#endif /* WITH_PROFINFO */
#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
#include "caml/spacetime.h"
CAMLexport value caml_alloc_shr (mlsize_t wosize, tag_t tag)
{
return caml_alloc_shr_with_profinfo (wosize, tag,
caml_spacetime_my_profinfo (NULL, wosize));
}
CAMLexport value caml_alloc_shr_no_track_noexc (mlsize_t wosize, tag_t tag)
{
return caml_alloc_shr_aux (wosize, tag, 0, 0,
caml_spacetime_my_profinfo (NULL, wosize));
}
#else
CAMLexport value caml_alloc_shr (mlsize_t wosize, tag_t tag)
{
return caml_alloc_shr_aux (wosize, tag, 1, 1, NO_PROFINFO);
@ -584,7 +569,6 @@ CAMLexport value caml_alloc_shr_no_track_noexc (mlsize_t wosize, tag_t tag)
{
return caml_alloc_shr_aux (wosize, tag, 0, 0, NO_PROFINFO);
}
#endif
/* Dependent memory is all memory blocks allocated out of the heap
that depend on the GC (and finalizers) for deallocation.

8
runtime/minor_gc.c
View File

@ -31,9 +31,6 @@
#include "caml/signals.h"
#include "caml/weak.h"
#include "caml/memprof.h"
#ifdef WITH_SPACETIME
#include "caml/spacetime.h"
#endif
#include "caml/eventlog.h"
/* Pointers into the minor heap.
@ -536,11 +533,6 @@ void caml_alloc_small_dispatch (intnat wosize, int flags,
callbacks. */
CAML_EV_COUNTER (EV_C_FORCE_MINOR_ALLOC_SMALL, 1);
caml_gc_dispatch ();
#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
if (caml_young_ptr == caml_young_alloc_end) {
caml_spacetime_automatic_snapshot();
}
#endif
}
/* Re-do the allocation: we now have enough space in the minor heap. */

3
runtime/misc.c
View File

@ -93,9 +93,6 @@ CAMLexport void caml_fatal_error (char *msg, ...)
abort();
}
/* If you change the caml_ext_table* functions, also update
runtime/spacetime_nat.c:find_trie_node_from_libunwind. */
void caml_ext_table_init(struct ext_table * tbl, int init_capa)
{
tbl->size = 0;

7
runtime/obj.c
View File

@ -29,7 +29,6 @@
#include "caml/mlvalues.h"
#include "caml/prims.h"
#include "caml/signals.h"
#include "caml/spacetime.h"
CAMLprim value caml_obj_tag(value arg)
{
@ -133,7 +132,6 @@ CAMLprim value caml_obj_block(value tag, value size)
return res;
}
/* Spacetime profiling assumes that this function is only called from OCaml. */
CAMLprim value caml_obj_with_tag(value new_tag_v, value arg)
{
CAMLparam2 (new_tag_v, arg);
@ -148,9 +146,7 @@ CAMLprim value caml_obj_with_tag(value new_tag_v, value arg)
res = caml_alloc(sz, tg);
memcpy(Bp_val(res), Bp_val(arg), sz * sizeof(value));
} else if (sz <= Max_young_wosize) {
uintnat profinfo;
Get_my_profinfo_with_cached_backtrace(profinfo, sz);
res = caml_alloc_small_with_my_or_given_profinfo(sz, tg, profinfo);
res = caml_alloc_small(sz, tg);
for (i = 0; i < sz; i++) Field(res, i) = Field(arg, i);
} else {
res = caml_alloc_shr(sz, tg);
@ -164,7 +160,6 @@ CAMLprim value caml_obj_with_tag(value new_tag_v, value arg)
CAMLreturn (res);
}
/* Spacetime profiling assumes that this function is only called from OCaml. */
CAMLprim value caml_obj_dup(value arg)
{
return caml_obj_with_tag(Val_long(Tag_val(arg)), arg);

48
runtime/signals.c
View File

@ -33,10 +33,6 @@
#include "caml/memprof.h"
#include "caml/finalise.h"
#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
#include "caml/spacetime.h"
#endif
#ifndef NSIG
#define NSIG 64
#endif
@ -206,9 +202,6 @@ value caml_execute_signal_exn(int signal_number, int in_signal_handler)
{
value res;
value handler;
#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
void* saved_spacetime_trie_node_ptr;
#endif
#ifdef POSIX_SIGNALS
sigset_t nsigs, sigs;
/* Block the signal before executing the handler, and record in sigs
@ -217,36 +210,10 @@ value caml_execute_signal_exn(int signal_number, int in_signal_handler)
sigaddset(&nsigs, signal_number);
caml_sigmask_hook(SIG_BLOCK, &nsigs, &sigs);
#endif
#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
/* We record the signal handler's execution separately, in the same
trie used for finalisers. */
saved_spacetime_trie_node_ptr
= caml_spacetime_trie_node_ptr;
caml_spacetime_trie_node_ptr
= caml_spacetime_finaliser_trie_root;
#endif
#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
/* Handled action may have no associated handler, which we interpret
as meaning the signal should be handled by a call to exit. This is
used to allow spacetime profiles to be completed on interrupt */
if (caml_signal_handlers == 0) {
res = caml_sys_exit(Val_int(2));
} else {
handler = Field(caml_signal_handlers, signal_number);
if (!Is_block(handler)) {
res = caml_sys_exit(Val_int(2));
} else {
#else
handler = Field(caml_signal_handlers, signal_number);
#endif
res = caml_callback_exn(
handler,
Val_int(caml_rev_convert_signal_number(signal_number)));
#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
}
}
caml_spacetime_trie_node_ptr = saved_spacetime_trie_node_ptr;
#endif
#ifdef POSIX_SIGNALS
if (! in_signal_handler) {
/* Restore the original signal mask */
@ -496,23 +463,8 @@ CAMLprim value caml_install_signal_handler(value signal_number, value action)
res = Val_int(1);
break;
case 2: /* was Signal_handle */
#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
/* Handled action may have no associated handler
which we treat as Signal_default */
if (caml_signal_handlers == 0) {
res = Val_int(0);
} else {
if (!Is_block(Field(caml_signal_handlers, sig))) {
res = Val_int(0);
} else {
res = caml_alloc_small (1, 0);
Field(res, 0) = Field(caml_signal_handlers, sig);
}
}
#else
res = caml_alloc_small (1, 0);
Field(res, 0) = Field(caml_signal_handlers, sig);
#endif
break;
default: /* error in caml_set_signal_action */
caml_sys_error(NO_ARG);

1
runtime/signals_nat.c
View File

@ -34,7 +34,6 @@
#include "caml/signals_machdep.h"
#include "signals_osdep.h"
#include "caml/stack.h"
#include "caml/spacetime.h"
#include "caml/memprof.h"
#include "caml/finalise.h"

41
runtime/spacetime_byt.c
View File

@ -1,41 +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 "caml/fail.h"
#include "caml/mlvalues.h"
#include "caml/io.h"
#include "caml/spacetime.h"
CAMLprim value caml_spacetime_only_works_for_native_code(value foo, ...)
{
caml_failwith("Spacetime profiling only works for native code");
}
uintnat caml_spacetime_my_profinfo (spacetime_unwind_info_cache * cached,
uintnat wosize)
{
return 0;
}
CAMLprim value caml_spacetime_enabled (value v_unit)
{
return Val_false; /* running in bytecode */
}
CAMLprim value caml_register_channel_for_spacetime (value v_channel)
{
return Val_unit;
}

1147
runtime/spacetime_nat.c
View File

File diff suppressed because it is too large Load Diff

575
runtime/spacetime_snapshot.c
View File

@ -1,575 +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/backtrace_prim.h"
#include "caml/config.h"
#include "caml/custom.h"
#include "caml/fail.h"
#include "caml/gc.h"
#include "caml/gc_ctrl.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"
#ifdef WITH_SPACETIME
/* The following structures must match the type definitions in the
[Spacetime] module. */
typedef struct {
/* (GC header here.) */
value minor_words;
value promoted_words;
value major_words;
value minor_collections;
value major_collections;
value heap_words;
value heap_chunks;
value compactions;
value top_heap_words;
} gc_stats;
typedef struct {
value profinfo;
value num_blocks;
value num_words_including_headers;
} snapshot_entry;
typedef struct {
/* (GC header here.) */
snapshot_entry entries[0];
} snapshot_entries;
typedef struct {
/* (GC header here.) */
value time;
value gc_stats;
value entries;
value words_scanned;
value words_scanned_with_profinfo;
value total_allocations;
} snapshot;
typedef struct {
uintnat num_blocks;
uintnat num_words_including_headers;
} raw_snapshot_entry;
static value allocate_outside_heap_with_tag(mlsize_t size_in_bytes, tag_t tag)
{
/* CR-soon mshinwell: this function should live somewhere else */
header_t* block;
CAMLassert(size_in_bytes % sizeof(value) == 0);
block = caml_stat_alloc(sizeof(header_t) + size_in_bytes);
*block = Make_header(size_in_bytes / sizeof(value), tag, Caml_black);
return (value) &block[1];
}
static value allocate_outside_heap(mlsize_t size_in_bytes)
{
CAMLassert(size_in_bytes > 0);
return allocate_outside_heap_with_tag(size_in_bytes, 0);
}
static value take_gc_stats(void)
{
value v_stats;
gc_stats* stats;
v_stats = allocate_outside_heap(sizeof(gc_stats));
stats = (gc_stats*) v_stats;
stats->minor_words = Val_long(Caml_state->stat_minor_words);
stats->promoted_words = Val_long(Caml_state->stat_promoted_words);
stats->major_words =
Val_long(((uintnat) Caml_state->stat_major_words)
+ ((uintnat) caml_allocated_words));
stats->minor_collections = Val_long(Caml_state->stat_minor_collections);
stats->major_collections = Val_long(Caml_state->stat_major_collections);
stats->heap_words = Val_long(Caml_state->stat_heap_wsz / sizeof(value));
stats->heap_chunks = Val_long(Caml_state->stat_heap_chunks);
stats->compactions = Val_long(Caml_state->stat_compactions);
stats->top_heap_words =
Val_long(Caml_state->stat_top_heap_wsz / sizeof(value));
return v_stats;
}
static value get_total_allocations(void)
{
value v_total_allocations = Val_unit;
allocation_point* total = caml_all_allocation_points;
while (total != NULL) {
value v_total;
v_total = allocate_outside_heap_with_tag(3 * sizeof(value), 0);
/* [v_total] is of type [Raw_spacetime_lib.total_allocations]. */
Field(v_total, 0) = Val_long(Profinfo_hd(total->profinfo));
Field(v_total, 1) = total->count;
Field(v_total, 2) = v_total_allocations;
v_total_allocations = v_total;
CAMLassert (total->next == Val_unit
|| (Is_block(total->next) && Tag_val(total->next) == Infix_tag));
if (total->next == Val_unit) {
total = NULL;
}
else {
total = (allocation_point*) Hp_val(total->next);
}
}
return v_total_allocations;
}
static value take_snapshot(double time_override, int use_time_override)
{
value v_snapshot;
snapshot* heap_snapshot;
value v_entries;
snapshot_entries* entries;
char* chunk;
value gc_stats;
uintnat index;
uintnat target_index;
value v_time;
double time;
uintnat profinfo;
uintnat num_distinct_profinfos;
/* Fixed size buffer to avoid needing a hash table: */
static raw_snapshot_entry* raw_entries = NULL;
uintnat words_scanned = 0;
uintnat words_scanned_with_profinfo = 0;
value v_total_allocations;
if (!use_time_override) {
time = caml_sys_time_unboxed(Val_unit);
}
else {
time = time_override;
}
gc_stats = take_gc_stats();
if (raw_entries == NULL) {
size_t size = (PROFINFO_MASK + 1) * sizeof(raw_snapshot_entry);
raw_entries = caml_stat_alloc(size);
memset(raw_entries, '\0', size);
} else {
size_t size = (PROFINFO_MASK + 1) * sizeof(raw_snapshot_entry);
memset(raw_entries, '\0', size);
}
num_distinct_profinfos = 0;
/* CR-someday mshinwell: consider reintroducing minor heap scanning,
properly from roots, which would then give a snapshot function
that doesn't do a minor GC. Although this may not be that important
and potentially not worth the effort (it's quite tricky). */
/* Scan the major heap. */
chunk = caml_heap_start;
while (chunk != NULL) {
char* hp;
char* limit;
hp = chunk;
limit = chunk + Chunk_size (chunk);
while (hp < limit) {
header_t hd = Hd_hp (hp);
switch (Color_hd(hd)) {
case Caml_blue:
break;
default:
if (Wosize_hd(hd) > 0) { /* ignore atoms */
profinfo = Profinfo_hd(hd);
words_scanned += Whsize_hd(hd);
if (profinfo > 0 && profinfo < PROFINFO_MASK) {
words_scanned_with_profinfo += Whsize_hd(hd);
CAMLassert (raw_entries[profinfo].num_blocks >= 0);
if (raw_entries[profinfo].num_blocks == 0) {
num_distinct_profinfos++;
}
raw_entries[profinfo].num_blocks++;
raw_entries[profinfo].num_words_including_headers +=
Whsize_hd(hd);
}
}
break;
}
hp += Bhsize_hd (hd);
CAMLassert (hp <= limit);
}
chunk = Chunk_next (chunk);
}
if (num_distinct_profinfos > 0) {
v_entries = allocate_outside_heap(
num_distinct_profinfos*sizeof(snapshot_entry));
entries = (snapshot_entries*) v_entries;
target_index = 0;
for (index = 0; index <= PROFINFO_MASK; index++) {
CAMLassert(raw_entries[index].num_blocks >= 0);
if (raw_entries[index].num_blocks > 0) {
CAMLassert(target_index < num_distinct_profinfos);
entries->entries[target_index].profinfo = Val_long(index);
entries->entries[target_index].num_blocks
= Val_long(raw_entries[index].num_blocks);
entries->entries[target_index].num_words_including_headers
= Val_long(raw_entries[index].num_words_including_headers);
target_index++;
}
}
} else {
v_entries = Atom(0);
}
CAMLassert(sizeof(double) == sizeof(value));
v_time = allocate_outside_heap_with_tag(sizeof(double), Double_tag);
Store_double_val(v_time, time);
v_snapshot = allocate_outside_heap(sizeof(snapshot));
heap_snapshot = (snapshot*) v_snapshot;
v_total_allocations = get_total_allocations();
heap_snapshot->time = v_time;
heap_snapshot->gc_stats = gc_stats;
heap_snapshot->entries = v_entries;
heap_snapshot->words_scanned
= Val_long(words_scanned);
heap_snapshot->words_scanned_with_profinfo
= Val_long(words_scanned_with_profinfo);
heap_snapshot->total_allocations = v_total_allocations;
return v_snapshot;
}
void caml_spacetime_save_snapshot (struct channel *chan, double time_override,
int use_time_override)
{
value v_snapshot;
value v_total_allocations;
snapshot* heap_snapshot;
Lock(chan);
v_snapshot = take_snapshot(time_override, use_time_override);
caml_output_val(chan, Val_long(0), Val_long(0));
caml_extern_allow_out_of_heap = 1;
caml_output_val(chan, v_snapshot, Val_long(0));
caml_extern_allow_out_of_heap = 0;
Unlock(chan);
heap_snapshot = (snapshot*) v_snapshot;
caml_stat_free(Hp_val(heap_snapshot->time));
caml_stat_free(Hp_val(heap_snapshot->gc_stats));
if (Wosize_val(heap_snapshot->entries) > 0) {
caml_stat_free(Hp_val(heap_snapshot->entries));
}
v_total_allocations = heap_snapshot->total_allocations;
while (v_total_allocations != Val_unit) {
value next = Field(v_total_allocations, 2);
caml_stat_free(Hp_val(v_total_allocations));
v_total_allocations = next;
}
caml_stat_free(Hp_val(v_snapshot));
}
CAMLprim value caml_spacetime_take_snapshot(value v_time_opt, value v_channel)
{
struct channel * channel = Channel(v_channel);
double time_override = 0.0;
int use_time_override = 0;
if (Is_block(v_time_opt)) {
time_override = Double_field(Field(v_time_opt, 0), 0);
use_time_override = 1;
}
caml_spacetime_save_snapshot(channel, time_override, use_time_override);
return Val_unit;
}
extern struct custom_operations caml_int64_ops; /* ints.c */
static value
allocate_int64_outside_heap(uint64_t i)
{
value v;
v = allocate_outside_heap_with_tag(2 * sizeof(value), Custom_tag);
Custom_ops_val(v) = &caml_int64_ops;
Int64_val(v) = i;
return v;
}
static value
copy_string_outside_heap(char const *s)
{
int len;
mlsize_t wosize, offset_index;
value result;
len = strlen(s);
wosize = (len + sizeof (value)) / sizeof (value);
result = allocate_outside_heap_with_tag(wosize * sizeof(value), String_tag);
Field (result, wosize - 1) = 0;
offset_index = Bsize_wsize (wosize) - 1;
Byte (result, offset_index) = offset_index - len;
memmove(Bytes_val(result), s, len);
return result;
}
static value
allocate_loc_outside_heap(struct caml_loc_info li)
{
value result;
if (li.loc_valid) {
result = allocate_outside_heap_with_tag(5 * sizeof(value), 0);
Field(result, 0) = Val_bool(li.loc_is_raise);
Field(result, 1) = copy_string_outside_heap(li.loc_filename);
Field(result, 2) = Val_int(li.loc_lnum);
Field(result, 3) = Val_int(li.loc_startchr);
Field(result, 4) = Val_int(li.loc_endchr);
} else {
result = allocate_outside_heap_with_tag(sizeof(value), 1);
Field(result, 0) = Val_bool(li.loc_is_raise);
}
return result;
}
value caml_spacetime_timestamp(double time_override, int use_time_override)
{
double time;
value v_time;
if (!use_time_override) {
time = caml_sys_time_unboxed(Val_unit);
}
else {
time = time_override;
}
v_time = allocate_outside_heap_with_tag(sizeof(double), Double_tag);
Store_double_val(v_time, time);
return v_time;
}
value caml_spacetime_frame_table(void)
{
/* Flatten the frame table into a single associative list. */
value list = Val_long(0); /* the empty list */
uintnat i;
if (!caml_debug_info_available()) {
return list;
}
if (caml_frame_descriptors == NULL) {
caml_init_frame_descriptors();
}
for (i = 0; i <= caml_frame_descriptors_mask; i++) {
frame_descr* descr = caml_frame_descriptors[i];
if (descr != NULL) {
value location, return_address, pair, new_list_element, location_list;
struct caml_loc_info li;
debuginfo dbg;
if (descr->frame_size != 0xffff) {
dbg = caml_debuginfo_extract(descr);
if (dbg != NULL) {
location_list = Val_unit;
while (dbg != NULL) {
value list_element;
caml_debuginfo_location(dbg, &li);
location = allocate_loc_outside_heap(li);
list_element =
allocate_outside_heap_with_tag(2 * sizeof(value), 0 /* (::) */);
Field(list_element, 0) = location;
Field(list_element, 1) = location_list;
location_list = list_element;
dbg = caml_debuginfo_next(dbg);
}
return_address = allocate_int64_outside_heap(descr->retaddr);
pair = allocate_outside_heap_with_tag(2 * sizeof(value), 0);
Field(pair, 0) = return_address;
Field(pair, 1) = location_list;
new_list_element =
allocate_outside_heap_with_tag(2 * sizeof(value), 0 /* (::) */);
Field(new_list_element, 0) = pair;
Field(new_list_element, 1) = list;
list = new_list_element;
}
}
}
}
return list;
}
static void add_unit_to_shape_table(uint64_t *unit_table, value *list)
{
/* This function reverses the order of the lists giving the layout of each
node; however, spacetime_profiling.ml ensures they are emitted in
reverse order, so at the end of it all they're not reversed. */
uint64_t* ptr = unit_table;
while (*ptr != (uint64_t) 0) {
value new_list_element, pair, function_address, layout;
function_address =
allocate_int64_outside_heap(*ptr++);
layout = Val_long(0); /* the empty list */
while (*ptr != (uint64_t) 0) {
int tag;
int stored_tag;
value part_of_shape;
value new_part_list_element;
value location;
int has_extra_argument = 0;
stored_tag = *ptr++;
/* CR-soon mshinwell: share with emit.mlp */
switch (stored_tag) {
case 1: /* direct call to given location */
tag = 0;
has_extra_argument = 1; /* the address of the callee */
break;
case 2: /* indirect call to given location */
tag = 1;
break;
case 3: /* allocation at given location */
tag = 2;
break;
default:
CAMLassert(0);
abort(); /* silence compiler warning */
}
location = allocate_int64_outside_heap(*ptr++);
part_of_shape = allocate_outside_heap_with_tag(
sizeof(value) * (has_extra_argument ? 2 : 1), tag);
Field(part_of_shape, 0) = location;
if (has_extra_argument) {
Field(part_of_shape, 1) =
allocate_int64_outside_heap(*ptr++);
}
new_part_list_element =
allocate_outside_heap_with_tag(2 * sizeof(value), 0 /* (::) */);
Field(new_part_list_element, 0) = part_of_shape;
Field(new_part_list_element, 1) = layout;
layout = new_part_list_element;
}
pair = allocate_outside_heap_with_tag(2 * sizeof(value), 0);
Field(pair, 0) = function_address;
Field(pair, 1) = layout;
new_list_element =
allocate_outside_heap_with_tag(2 * sizeof(value), 0 /* (::) */);
Field(new_list_element, 0) = pair;
Field(new_list_element, 1) = *list;
*list = new_list_element;
ptr++;
}
}
value caml_spacetime_shape_table(void)
{
value list;
uint64_t* unit_table;
shape_table *dynamic_table;
uint64_t** static_table;
/* Flatten the hierarchy of shape tables into a single associative list
mapping from function symbols to node layouts. The node layouts are
themselves lists. */
list = Val_long(0); /* the empty list */
/* Add static shape tables */
static_table = caml_spacetime_static_shape_tables;
while (*static_table != (uint64_t) 0) {
unit_table = *static_table++;
add_unit_to_shape_table(unit_table, &list);
}
/* Add dynamic shape tables */
dynamic_table = caml_spacetime_dynamic_shape_tables;
while (dynamic_table != NULL) {
unit_table = dynamic_table->table;
add_unit_to_shape_table(unit_table, &list);
dynamic_table = dynamic_table->next;
}
return list;
}
#else
CAMLprim value caml_spacetime_take_snapshot(value v_time_opt, value v_channel)
{
return Val_unit;
}
#endif

4
runtime/startup_aux.c
View File

@ -60,11 +60,7 @@ void caml_init_atom_table(void)
caml_stat_alloc_aligned_noexc(request, 0, &b);
for(i = 0; i < 256; i++) {
#ifdef NATIVE_CODE
caml_atom_table[i] = Make_header_allocated_here(0, i, Caml_black);
#else
caml_atom_table[i] = Make_header(0, i, Caml_black);
#endif
}
if (caml_page_table_add(In_static_data,
caml_atom_table, caml_atom_table + 256 + 1) != 0) {

6
runtime/startup_nat.c
View File

@ -39,9 +39,6 @@
#include "caml/stack.h"
#include "caml/startup_aux.h"
#include "caml/sys.h"
#ifdef WITH_SPACETIME
#include "caml/spacetime.h"
#endif
#ifdef HAS_UI
#include "caml/ui.h"
#endif
@ -127,9 +124,6 @@ value caml_startup_common(char_os **argv, int pooling)
if (!caml_startup_aux(pooling))
return Val_unit;
#ifdef WITH_SPACETIME
caml_spacetime_initialize();
#endif
caml_init_frame_descriptors();
caml_init_locale();
#if defined(_MSC_VER) && __STDC_SECURE_LIB__ >= 200411L

8
runtime/unix.c
View File

@ -88,17 +88,9 @@ int caml_write_fd(int fd, int flags, void * buf, int n)
{
int retcode;
again:
#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
if (flags & CHANNEL_FLAG_BLOCKING_WRITE) {
retcode = write(fd, buf, n);
} else {
#endif
caml_enter_blocking_section_no_pending();
retcode = write(fd, buf, n);
caml_leave_blocking_section();
#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
}
#endif
if (retcode == -1) {
if (errno == EINTR) return Io_interrupted;
if ((errno == EAGAIN || errno == EWOULDBLOCK) && n > 1) {

8
runtime/win32.c
View File

@ -109,17 +109,9 @@ int caml_write_fd(int fd, int flags, void * buf, int n)
{
int retcode;
if ((flags & CHANNEL_FLAG_FROM_SOCKET) == 0) {
#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
if (flags & CHANNEL_FLAG_BLOCKING_WRITE) {
retcode = write(fd, buf, n);
} else {
#endif
caml_enter_blocking_section_no_pending();
retcode = write(fd, buf, n);
caml_leave_blocking_section();
#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
}
#endif
if (retcode == -1) caml_sys_io_error(NO_ARG);
} else {
caml_enter_blocking_section_no_pending();

7
stdlib/.depend
View File

@ -608,13 +608,6 @@ stdlib__set.cmx : \
stdlib__set.cmi
stdlib__set.cmi : \
stdlib__seq.cmi
stdlib__spacetime.cmo : \
stdlib__gc.cmi \
stdlib__spacetime.cmi
stdlib__spacetime.cmx : \
stdlib__gc.cmx \
stdlib__spacetime.cmi
stdlib__spacetime.cmi :
stdlib__stack.cmo : \
stdlib__seq.cmi \
stdlib__list.cmi \

2
stdlib/StdlibModules
View File

@ -38,7 +38,7 @@ STDLIB_MODS=\
printexc fun gc digest random hashtbl weak \
format scanf callback camlinternalOO oo camlinternalMod genlex ephemeron \
filename complex arrayLabels listLabels bytesLabels stringLabels moreLabels \
stdLabels spacetime bigarray
stdLabels bigarray
STDLIB_MODULES=\
$(foreach module, $(STDLIB_MODS), $(call add_stdlib_prefix,$(module)))

91
stdlib/spacetime.ml
View File

@ -1,91 +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. *)
(* *)
(**************************************************************************)
external spacetime_enabled : unit -> bool
= "caml_spacetime_enabled" [@@noalloc]
let enabled = spacetime_enabled ()
let if_spacetime_enabled f =
if enabled then f () else ()
module Series = struct
type t = {
channel : out_channel;
mutable closed : bool;
}
external write_magic_number : out_channel -> unit
= "caml_spacetime_only_works_for_native_code"
"caml_spacetime_write_magic_number"
external register_channel_for_spacetime : out_channel -> unit
= "caml_register_channel_for_spacetime"
let create ~path =
if spacetime_enabled () then begin
let channel = open_out path in
register_channel_for_spacetime channel;
let t =
{ channel = channel;
closed = false;
}
in
write_magic_number t.channel;
t
end else begin
{ channel = stdout; (* arbitrary value *)
closed = true;
}
end
external save_event : ?time:float -> out_channel -> event_name:string -> unit
= "caml_spacetime_only_works_for_native_code"
"caml_spacetime_save_event"
let save_event ?time t ~event_name =
if_spacetime_enabled (fun () ->
save_event ?time t.channel ~event_name)
external save_trie : ?time:float -> out_channel -> unit
= "caml_spacetime_only_works_for_native_code"
"caml_spacetime_save_trie"
let save_and_close ?time t =
if_spacetime_enabled (fun () ->
if t.closed then failwith "Series is closed";
save_trie ?time t.channel;
close_out t.channel;
t.closed <- true)
end
module Snapshot = struct
external take : ?time:float -> out_channel -> unit
= "caml_spacetime_only_works_for_native_code"
"caml_spacetime_take_snapshot"
let take ?time { Series.closed; channel } =
if_spacetime_enabled (fun () ->
if closed then failwith "Series is closed";
Gc.minor ();
take ?time channel)
end
external save_event_for_automatic_snapshots : event_name:string -> unit
= "caml_spacetime_only_works_for_native_code"
"caml_spacetime_save_event_for_automatic_snapshots"
let save_event_for_automatic_snapshots ~event_name =
if_spacetime_enabled (fun () ->
save_event_for_automatic_snapshots ~event_name)

99
stdlib/spacetime.mli
View File

@ -1,99 +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. *)
(* *)
(**************************************************************************)
(** Profiling of a program's space behaviour over time.
Currently only supported on x86-64 platforms running 64-bit code.
To use the functions in this module you must:
- configure the compiler with "-spacetime";
- compile to native code.
Without these conditions being satisfied the functions in this module
will have no effect.
Instead of manually taking profiling heap snapshots with this module it is
possible to use an automatic snapshot facility that writes profiling
information at fixed intervals to a file. To enable this, all that needs to
be done is to build the relevant program using a compiler configured with
-spacetime; and set the environment variable OCAML_SPACETIME_INTERVAL to an
integer number of milliseconds giving the interval between profiling heap
snapshots. This interval should not be made excessively small relative to
the running time of the program. A typical interval to start with might be
1/100 of the running time of the program. The program must exit "normally"
(i.e. by calling [exit], with whatever exit code, rather than being
abnormally terminated by a signal) so that the snapshot file is
correctly completed.
When using the automatic snapshot mode the profiling output is written
to a file called "spacetime-<pid>" where <pid> is the process ID of the
program. (If the program forks and continues executing then multiple
files may be produced with different pid numbers.) The profiling output
is by default written to the current working directory when the program
starts. This may be customised by setting the OCAML_SPACETIME_SNAPSHOT_DIR
environment variable to the name of the desired directory.
If using automatic snapshots the presence of the
[save_event_for_automatic_snapshots] function, below, should be noted.
The functions in this module are thread safe.
For functions to decode the information recorded by the profiler,
see the Spacetime offline library in otherlibs/. *)
(** [enabled] is [true] if the compiler is configured with spacetime and [false]
otherwise *)
val enabled : bool
module Series : sig
(** Type representing a file that will hold a series of heap snapshots
together with additional information required to interpret those
snapshots. *)
type t
(** [create ~path] creates a series file at [path]. *)
val create : path:string -> t
(** [save_event] writes an event, which is an arbitrary string, into the
given series file. This may be used for identifying particular points
during program execution when analysing the profile.
The optional [time] parameter is as for {!Snapshot.take}.
*)
val save_event : ?time:float -> t -> event_name:string -> unit
(** [save_and_close series] writes information into [series] required for
interpreting the snapshots that [series] contains and then closes the
[series] file. This function must be called to produce a valid series
file.
The optional [time] parameter is as for {!Snapshot.take}.
*)
val save_and_close : ?time:float -> t -> unit
end
module Snapshot : sig
(** [take series] takes a snapshot of the profiling annotations on the values
in the minor and major heaps, together with GC stats, and write the
result to the [series] file. This function triggers a minor GC but does
not allocate any memory itself.
If the optional [time] is specified, it will be used instead of the
result of {!Sys.time} as the timestamp of the snapshot. Such [time]s
should start from zero and be monotonically increasing. This parameter
is intended to be used so that snapshots can be correlated against wall
clock time (which is not supported in the standard library) rather than
elapsed CPU time.
*)
val take : ?time:float -> Series.t -> unit
end
(** Like {!Series.save_event}, but writes to the automatic snapshot file.
This function is a no-op if OCAML_SPACETIME_INTERVAL was not set. *)
val save_event_for_automatic_snapshots : event_name:string -> unit

1
stdlib/stdlib.ml
View File

@ -617,7 +617,6 @@ module Result = Result
module Scanf = Scanf
module Seq = Seq
module Set = Set
module Spacetime = Spacetime
module Stack = Stack
module StdLabels = StdLabels
module Stream = Stream

1
stdlib/stdlib.mli
View File

@ -1396,7 +1396,6 @@ module Result = Result
module Scanf = Scanf
module Seq = Seq
module Set = Set
module Spacetime = Spacetime
module Stack = Stack
module StdLabels = StdLabels
module Stream = Stream

1
toplevel/dune
View File

@ -37,7 +37,6 @@
(targets ocaml.byte)
(action (run %{ocaml_where}/expunge %{dep:topstart.exe} %{targets}
; FIXME: inlined $(STDLIB_MODULES) ... minus Labels ones ...
stdlib__Spacetime
stdlib__Arg
stdlib__Array
; stdlib__ArrayLabels

Some files were not shown because too many files have changed in this diff Show More