diff --git a/.depend b/.depend index 8c6f183c9..b85de6533 100644 --- a/.depend +++ b/.depend @@ -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 \ diff --git a/Makefile b/Makefile index 1bb15a174..287346ab0 100644 --- a/Makefile +++ b/Makefile @@ -746,7 +746,7 @@ clean:: $(MAKE) -C runtime clean rm -f stdlib/libcamlrun.a stdlib/libcamlrun.lib -otherlibs_all := bigarray dynlink raw_spacetime_lib \ +otherlibs_all := bigarray dynlink \ str systhreads unix win32unix subdirs := debugger lex ocamldoc ocamltest stdlib tools \ $(addprefix otherlibs/, $(otherlibs_all)) \ @@ -944,7 +944,7 @@ VERSIONS=$(shell git tag|grep '^[0-9]*.[0-9]*.[0-9]*$$'|grep -v '^[12].') lintapidiff: $(MAKE) -C tools lintapidiff.opt git ls-files -- 'otherlibs/*/*.mli' 'stdlib/*.mli' |\ - grep -Ev internal\|obj\|spacetime\|stdLabels\|moreLabels |\ + grep -Ev internal\|obj\|stdLabels\|moreLabels |\ tools/lintapidiff.opt $(VERSIONS) # Tools diff --git a/Makefile.config.in b/Makefile.config.in index 26741a5b2..6252b5dc4 100644 --- a/Makefile.config.in +++ b/Makefile.config.in @@ -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@ diff --git a/asmcomp/amd64/arch.ml b/asmcomp/amd64/arch.ml index effe32ed1..581db3dbb 100644 --- a/asmcomp/amd64/arch.ml +++ b/asmcomp/amd64/arch.ml @@ -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 diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp index d9c5eb6e6..60b24838d 100644 --- a/asmcomp/amd64/emit.mlp +++ b/asmcomp/amd64/emit.mlp @@ -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" ]; diff --git a/asmcomp/amd64/proc.ml b/asmcomp/amd64/proc.ml index fe798e13f..7b19ea3f9 100644 --- a/asmcomp/amd64/proc.ml +++ b/asmcomp/amd64/proc.ml @@ -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 |] | _ -> diff --git a/asmcomp/amd64/selection.ml b/asmcomp/amd64/selection.ml index 76d5c15e3..7b2bcd055 100644 --- a/asmcomp/amd64/selection.ml +++ b/asmcomp/amd64/selection.ml @@ -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 diff --git a/asmcomp/arm/arch.ml b/asmcomp/arm/arch.ml index becfff389..4b884da6e 100644 --- a/asmcomp/arm/arch.ml +++ b/asmcomp/arm/arch.ml @@ -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 diff --git a/asmcomp/arm/proc.ml b/asmcomp/arm/proc.ml index 2c79f380f..09d0cd057 100644 --- a/asmcomp/arm/proc.ml +++ b/asmcomp/arm/proc.ml @@ -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 = diff --git a/asmcomp/arm64/arch.ml b/asmcomp/arm64/arch.ml index 41edd3e4a..205d09c6d 100644 --- a/asmcomp/arm64/arch.ml +++ b/asmcomp/arm64/arch.ml @@ -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 diff --git a/asmcomp/arm64/proc.ml b/asmcomp/arm64/proc.ml index e259d2038..2e3f756ea 100644 --- a/asmcomp/arm64/proc.ml +++ b/asmcomp/arm64/proc.ml @@ -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 = diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml index d994f552a..9d32ae90d 100644 --- a/asmcomp/asmlink.ml +++ b/asmcomp/asmlink.ml @@ -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 diff --git a/asmcomp/cmm_helpers.ml b/asmcomp/cmm_helpers.ml index 3594b9513..4c42a5064 100644 --- a/asmcomp/cmm_helpers.ml +++ b/asmcomp/cmm_helpers.ml @@ -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 = diff --git a/asmcomp/cmm_helpers.mli b/asmcomp/cmm_helpers.mli index 6463edc27..debc84b4f 100644 --- a/asmcomp/cmm_helpers.mli +++ b/asmcomp/cmm_helpers.mli @@ -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 diff --git a/asmcomp/comballoc.ml b/asmcomp/comballoc.ml index 6d7e536e5..91ac4a711 100644 --- a/asmcomp/comballoc.ml +++ b/asmcomp/comballoc.ml @@ -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} diff --git a/asmcomp/deadcode.ml b/asmcomp/deadcode.ml index 2550639da..c308e426d 100644 --- a/asmcomp/deadcode.ml +++ b/asmcomp/deadcode.ml @@ -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; } diff --git a/asmcomp/emitaux.ml b/asmcomp/emitaux.ml index 9a1e62146..2e4664e87 100644 --- a/asmcomp/emitaux.ml +++ b/asmcomp/emitaux.ml @@ -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 diff --git a/asmcomp/i386/arch.ml b/asmcomp/i386/arch.ml index ba76a8258..17876c46f 100644 --- a/asmcomp/i386/arch.ml +++ b/asmcomp/i386/arch.ml @@ -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 diff --git a/asmcomp/i386/proc.ml b/asmcomp/i386/proc.ml index 5d3f0546c..bd9d6a991 100644 --- a/asmcomp/i386/proc.ml +++ b/asmcomp/i386/proc.ml @@ -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 diff --git a/asmcomp/linear.ml b/asmcomp/linear.ml index 37cf92003..6071beabf 100644 --- a/asmcomp/linear.ml +++ b/asmcomp/linear.ml @@ -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; diff --git a/asmcomp/linear.mli b/asmcomp/linear.mli index 2d1ce9430..2f52c2095 100644 --- a/asmcomp/linear.mli +++ b/asmcomp/linear.mli @@ -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; diff --git a/asmcomp/linearize.ml b/asmcomp/linearize.ml index 31b992a46..50e64762d 100644 --- a/asmcomp/linearize.ml +++ b/asmcomp/linearize.ml @@ -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; diff --git a/asmcomp/liveness.ml b/asmcomp/liveness.ml index 2da5b160b..fbdfe479c 100644 --- a/asmcomp/liveness.ml +++ b/asmcomp/liveness.ml @@ -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 diff --git a/asmcomp/mach.ml b/asmcomp/mach.ml index 248c8185c..16399081b 100644 --- a/asmcomp/mach.ml +++ b/asmcomp/mach.ml @@ -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 _ diff --git a/asmcomp/mach.mli b/asmcomp/mach.mli index d3cdd7a93..bdc76b00a 100644 --- a/asmcomp/mach.mli +++ b/asmcomp/mach.mli @@ -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 diff --git a/asmcomp/power/arch.ml b/asmcomp/power/arch.ml index 07bf8dbfd..0749f2593 100644 --- a/asmcomp/power/arch.ml +++ b/asmcomp/power/arch.ml @@ -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 = diff --git a/asmcomp/power/proc.ml b/asmcomp/power/proc.ml index 5ee902f6a..2b98274df 100644 --- a/asmcomp/power/proc.ml +++ b/asmcomp/power/proc.ml @@ -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 = diff --git a/asmcomp/printmach.ml b/asmcomp/printmach.ml index 39128955a..26b8c171b 100644 --- a/asmcomp/printmach.ml +++ b/asmcomp/printmach.ml @@ -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) diff --git a/asmcomp/proc.mli b/asmcomp/proc.mli index 835ca1d0a..a92b1e9c9 100644 --- a/asmcomp/proc.mli +++ b/asmcomp/proc.mli @@ -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. diff --git a/asmcomp/reloadgen.ml b/asmcomp/reloadgen.ml index bea7bafa7..f760bbb87 100644 --- a/asmcomp/reloadgen.ml +++ b/asmcomp/reloadgen.ml @@ -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; }, diff --git a/asmcomp/riscv/arch.ml b/asmcomp/riscv/arch.ml index c6ade5279..415c47925 100644 --- a/asmcomp/riscv/arch.ml +++ b/asmcomp/riscv/arch.ml @@ -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 = diff --git a/asmcomp/riscv/proc.ml b/asmcomp/riscv/proc.ml index ce190a721..252557e12 100644 --- a/asmcomp/riscv/proc.ml +++ b/asmcomp/riscv/proc.ml @@ -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 diff --git a/asmcomp/s390x/arch.ml b/asmcomp/s390x/arch.ml index 84d52d644..a6353fdf9 100644 --- a/asmcomp/s390x/arch.ml +++ b/asmcomp/s390x/arch.ml @@ -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 = diff --git a/asmcomp/s390x/proc.ml b/asmcomp/s390x/proc.ml index 2c6c35733..7ac669b64 100644 --- a/asmcomp/s390x/proc.ml +++ b/asmcomp/s390x/proc.ml @@ -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 diff --git a/asmcomp/schedgen.ml b/asmcomp/schedgen.ml index 966dbbec1..4315467ce 100644 --- a/asmcomp/schedgen.ml +++ b/asmcomp/schedgen.ml @@ -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; diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml index eab014b65..1f62fd1dd 100644 --- a/asmcomp/selectgen.ml +++ b/asmcomp/selectgen.ml @@ -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; } diff --git a/asmcomp/selectgen.mli b/asmcomp/selectgen.mli index 2f53ef17a..c657e109b 100644 --- a/asmcomp/selectgen.mli +++ b/asmcomp/selectgen.mli @@ -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. *) diff --git a/asmcomp/spacetime_profiling.ml b/asmcomp/spacetime_profiling.ml deleted file mode 100644 index 696f2385a..000000000 --- a/asmcomp/spacetime_profiling.ml +++ /dev/null @@ -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 diff --git a/asmcomp/spacetime_profiling.mli b/asmcomp/spacetime_profiling.mli deleted file mode 100644 index 16c691480..000000000 --- a/asmcomp/spacetime_profiling.mli +++ /dev/null @@ -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 diff --git a/asmcomp/spill.ml b/asmcomp/spill.ml index da739f973..3e88406d9 100644 --- a/asmcomp/spill.ml +++ b/asmcomp/spill.ml @@ -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; } diff --git a/asmcomp/split.ml b/asmcomp/split.ml index 87c9c71f6..29046c9cc 100644 --- a/asmcomp/split.ml +++ b/asmcomp/split.ml @@ -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; } diff --git a/compilerlibs/Makefile.compilerlibs b/compilerlibs/Makefile.compilerlibs index 6e29c2e91..2f52c3712 100644 --- a/compilerlibs/Makefile.compilerlibs +++ b/compilerlibs/Makefile.compilerlibs @@ -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 \ diff --git a/configure b/configure index bafcde3f9..9973d480b 100755 --- a/configure +++ b/configure @@ -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 diff --git a/configure.ac b/configure.ac index 07f99740f..0744dee22 100644 --- a/configure.ac +++ b/configure.ac @@ -150,11 +150,6 @@ AC_SUBST([install_source_artifacts]) AC_SUBST([profinfo]) AC_SUBST([profinfo_width]) AC_SUBST([frame_pointers]) -AC_SUBST([spacetime]) -AC_SUBST([call_counts]) -AC_SUBST([libunwind_available]) -AC_SUBST([libunwind_include_flags]) -AC_SUBST([libunwind_link_flags]) AC_SUBST([flambda]) AC_SUBST([flambda_invariants]) AC_SUBST([max_testsuite_dir_retries]) @@ -242,16 +237,6 @@ AC_ARG_ENABLE([systhreads], [AS_HELP_STRING([--disable-systhreads], [disable the Win32/POSIX threads library])]) -AC_ARG_WITH([libunwind], - [AS_HELP_STRING([--without-libunwind], - [disable libunwind support for Spacetime profiling])]) - -AC_ARG_VAR([LIBUNWIND_INCLUDE_DIR], - [location of header files for libunwind]) - -AC_ARG_VAR([LIBUNWIND_LIB_DIR], - [location of library files for libunwind]) - AC_ARG_ENABLE([graph-lib], [], [AC_MSG_ERROR([The graphics library is no longer distributed with OCaml \ since version 4.09. It is now distributed as a separate "graphics" package: \ @@ -292,14 +277,6 @@ AC_ARG_ENABLE([naked-pointers-checker], [AS_HELP_STRING([--enable-naked-pointers-checker], [enable the naked pointers checker])]) -AC_ARG_ENABLE([spacetime], - [AS_HELP_STRING([--enable-spacetime], - [build the spacetime profiler])]) - -AC_ARG_ENABLE([call-counts], - [AS_HELP_STRING([--disable-call-counts], - [disable the call counts in spacetime])]) - AC_ARG_ENABLE([cfi], [AS_HELP_STRING([--disable-cfi], [disable the CFI directives in assembly files])]) @@ -1042,9 +1019,6 @@ AS_IF([test -z "$PARTIALLD"], [PACKLD="$DIRECT_LD -r$PACKLD_FLAGS -o \$(EMPTY)"])], [PACKLD="$PARTIALLD -o \$(EMPTY)"]) -AS_IF([test $arch != "none" && $arch64 ], - [otherlibraries="$otherlibraries raw_spacetime_lib"]) - # Disable PIE at link time when ocamlopt does not produce position-independent # code and the system produces PIE executables by default and demands PIC # object files to do so. @@ -1717,90 +1691,6 @@ AS_IF([test x"$enable_naked_pointers_checker" = "xyes" ], ## Check for mmap support for huge pages and contiguous heap OCAML_MMAP_SUPPORTS_HUGE_PAGES -# Spacetime profiling, including libunwind detection - -# The number of bits used for profiling information is configurable here. -# The more bits used for profiling, the smaller will be Max_wosize. -# Note that PROFINFO_WIDTH must still be defined even if not configuring -# for Spacetime (see comment in runtime/caml/mlvalues.h on [Profinfo_hd]). -AC_MSG_CHECKING([whether to build spacetime]) -AS_IF([test x"$enable_spacetime" != "xyes" ], - [spacetime=false - call_counts=true # as in original script but should probably be false - libunwind_available=false - libunwind_include_flags= - libunwind_link_flags= - AC_MSG_RESULT([no])], - [AS_CASE([$arch], - [amd64], [spacetime_supported=true], - [spacetime_supported=false]) - AS_IF([$spacetime_supported], - [AC_MSG_RESULT([yes]) - spacetime=true - profinfo=true - profinfo_width=26 - AC_DEFINE([WITH_SPACETIME]) - AS_IF([test x"$enable_call_counts" != "xno"], - [call_counts=true - AC_DEFINE([ENABLE_CALL_COUNTS])], - [call_counts=false]) - AC_MSG_CHECKING([whether to use libunwind]) - AS_IF([test x"$with_libunwind" = "xno"], - [AC_MSG_RESULT([disabled])], - [AS_IF([test x"$with_libunwind" = "x"], - [libunwind_requested=false - AC_MSG_RESULT([if available])], - [libunwind_requested=true - AC_MSG_RESULT([requested]) - AS_IF([test x"$with_libunwind" != "xyes"], - [AS_IF([test x"$LIBUNWIND_INCLUDE_DIR" = "x"], - [LIBUNWIND_INCLUDE_DIR="$with_libunwind/include"]) - AS_IF([test x"$LIBUNWIND_LIB_DIR" = "x"], - [LIBUNWIND_LIB_DIR="$with_libunwind/lib"]) - ]) - ]) - AS_IF([test "$system" = "macosx"], - [AS_IF([test x"$LIBUNWIND_INCLUDE_DIR" != x -o \ - x"$LIBUNWIND_LIB_DIR" != x], - [AC_MSG_WARN(m4_normalize([ - On MacOSX, specifying paths for libunwind headers or libraries - is strongly discouraged. It is recommended to rely on the - defaults provided by the configure script - ]))])]) - - AS_IF([test x"$LIBUNWIND_INCLUDE_DIR" != x], - [libunwind_include_flags="-I$LIBUNWIND_INCLUDE_DIR"], - [libunwind_include_flags=""]) - - AS_CASE(["$system"], - ["macosx"], [libunwind_link_flags="-framework System"], - [libunwind_link_flags="-lunwind -lunwind-x86_64"]) - - AS_IF([test x"$LIBUNWIND_LIB_DIR" != x], - [libunwind_link_flags="-L$LIBUNWIND_LIB_DIR $libunwind_link_flags"]) - - OCAML_CHECK_LIBUNWIND - - AS_IF([$libunwind_requested && ! $libunwind_available], - [AC_MSG_ERROR([libunwind was requested but can not be found])]) - - # We need unwinding information at runtime, but since we use - # -no_compact_unwind, we also need -keep_dwarf_unwind otherwise - # the OS X linker will chuck away the DWARF-like (.eh_frame) - # information. (Older versions of OS X don't provide this.) - - AS_IF([$libunwind_available && test x"$system" = "xmacosx"], - [extra_flags="-Wl,-keep_dwarf_unwind" - mkexe="$mkexe $extra_flags" - mksharedlib="$mksharedlib $extra_flags"])]) - ], - [AS_IF([test x"$enable_spacetime" = "xyes"], - [AC_MSG_RESULT([requested but not supported]) - AC_MSG_ERROR([exiting])], - [AC_MSG_RESULT([no])]) - ]) - ]) - AC_DEFINE_UNQUOTED([PROFINFO_WIDTH], [$profinfo_width]) AS_IF([$profinfo], [AC_DEFINE([WITH_PROFINFO])]) diff --git a/dune b/dune index cafbcda20..7e277e368 100644 --- a/dune +++ b/dune @@ -152,7 +152,7 @@ CSE CSEgen deadcode domainstate emit emitaux interf interval linear linearize linscan liveness mach printcmm printlinear printmach proc reg reload reloadgen - schedgen scheduling selectgen selection spacetime_profiling spill split + schedgen scheduling selectgen selection spill split strmatch x86_ast x86_dsl x86_gas x86_masm x86_proc ;; asmcomp/debug/ diff --git a/manual/README.md b/manual/README.md index f66403384..c021406fd 100644 --- a/manual/README.md +++ b/manual/README.md @@ -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` diff --git a/manual/manual/allfiles.etex b/manual/manual/allfiles.etex index a218470b4..f99503aca 100644 --- a/manual/manual/allfiles.etex +++ b/manual/manual/allfiles.etex @@ -71,7 +71,6 @@ and as a % \input emacs.tex \input{intf-c.tex} \input{flambda.tex} -\input{spacetime-chapter.tex} \input{afl-fuzz.tex} \input{instrumented-runtime.tex} diff --git a/manual/manual/cmds/Makefile b/manual/manual/cmds/Makefile index b65221283..bfab02a3d 100644 --- a/manual/manual/cmds/Makefile +++ b/manual/manual/cmds/Makefile @@ -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 diff --git a/manual/manual/cmds/spacetime-chapter.etex b/manual/manual/cmds/spacetime-chapter.etex deleted file mode 100644 index 5b75eb86d..000000000 --- a/manual/manual/cmds/spacetime-chapter.etex +++ /dev/null @@ -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}. diff --git a/manual/manual/library/stdlib-blurb.etex b/manual/manual/library/stdlib-blurb.etex index bdc0df04b..666a1423f 100644 --- a/manual/manual/library/stdlib-blurb.etex +++ b/manual/manual/library/stdlib-blurb.etex @@ -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} diff --git a/ocamltest/Makefile b/ocamltest/Makefile index ec1ac4cbd..731d459ec 100644 --- a/ocamltest/Makefile +++ b/ocamltest/Makefile @@ -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) \ diff --git a/ocamltest/ocaml_actions.ml b/ocamltest/ocaml_actions.ml index 71524c0ce..9b8419b82 100644 --- a/ocamltest/ocaml_actions.ml +++ b/ocamltest/ocaml_actions.ml @@ -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; diff --git a/ocamltest/ocaml_tests.ml b/ocamltest/ocaml_tests.ml index d84eeb43f..90f8eb984 100644 --- a/ocamltest/ocaml_tests.ml +++ b/ocamltest/ocaml_tests.ml @@ -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; diff --git a/ocamltest/ocamltest_config.ml.in b/ocamltest/ocamltest_config.ml.in index 35819c47d..98c7ac1b8 100644 --- a/ocamltest/ocamltest_config.ml.in +++ b/ocamltest/ocamltest_config.ml.in @@ -47,8 +47,6 @@ let ocamlsrcdir = "%%ocamlsrcdir%%" let flambda = %%FLAMBDA%% -let spacetime = %%WITH_SPACETIME%% - let ocamlc_default_flags = "%%ocamlcdefaultflags%%" let ocamlopt_default_flags = "%%ocamloptdefaultflags%%" diff --git a/ocamltest/ocamltest_config.mli b/ocamltest/ocamltest_config.mli index c5b4ba0ca..8ca93d1b7 100644 --- a/ocamltest/ocamltest_config.mli +++ b/ocamltest/ocamltest_config.mli @@ -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 *) diff --git a/otherlibs/Makefile b/otherlibs/Makefile index e5df38319..0da6669b7 100644 --- a/otherlibs/Makefile +++ b/otherlibs/Makefile @@ -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 diff --git a/otherlibs/raw_spacetime_lib/.depend b/otherlibs/raw_spacetime_lib/.depend deleted file mode 100644 index be2b89ee1..000000000 --- a/otherlibs/raw_spacetime_lib/.depend +++ /dev/null @@ -1,5 +0,0 @@ -raw_spacetime_lib.cmo : \ - raw_spacetime_lib.cmi -raw_spacetime_lib.cmx : \ - raw_spacetime_lib.cmi -raw_spacetime_lib.cmi : diff --git a/otherlibs/raw_spacetime_lib/Makefile b/otherlibs/raw_spacetime_lib/Makefile deleted file mode 100644 index a6b637887..000000000 --- a/otherlibs/raw_spacetime_lib/Makefile +++ /dev/null @@ -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 diff --git a/otherlibs/raw_spacetime_lib/raw_spacetime_lib.ml b/otherlibs/raw_spacetime_lib/raw_spacetime_lib.ml deleted file mode 100644 index 5ee81fc2b..000000000 --- a/otherlibs/raw_spacetime_lib/raw_spacetime_lib.ml +++ /dev/null @@ -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 diff --git a/otherlibs/raw_spacetime_lib/raw_spacetime_lib.mli b/otherlibs/raw_spacetime_lib/raw_spacetime_lib.mli deleted file mode 100644 index 6bdffffe9..000000000 --- a/otherlibs/raw_spacetime_lib/raw_spacetime_lib.mli +++ /dev/null @@ -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 diff --git a/otherlibs/raw_spacetime_lib/spacetime_offline.c b/otherlibs/raw_spacetime_lib/spacetime_offline.c deleted file mode 100644 index d022c5de2..000000000 --- a/otherlibs/raw_spacetime_lib/spacetime_offline.c +++ /dev/null @@ -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 -#include -#include -#include -#include - -#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 diff --git a/otherlibs/systhreads/st_stubs.c b/otherlibs/systhreads/st_stubs.c index 2e369cd7c..d3b93b2a3 100644 --- a/otherlibs/systhreads/st_stubs.c +++ b/otherlibs/systhreads/st_stubs.c @@ -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) */ diff --git a/runtime/Makefile b/runtime/Makefile index f688af70a..1abf2c8cd 100644 --- a/runtime/Makefile +++ b/runtime/Makefile @@ -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 diff --git a/runtime/alloc.c b/runtime/alloc.c index 6d3518dea..189d309d3 100644 --- a/runtime/alloc.c +++ b/runtime/alloc.c @@ -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) { diff --git a/runtime/amd64.S b/runtime/amd64.S index 056b39cd4..a542a62a7 100644 --- a/runtime/amd64.S +++ b/runtime/amd64.S @@ -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) diff --git a/runtime/amd64nt.asm b/runtime/amd64nt.asm index d34631ab3..a625e2a3a 100644 --- a/runtime/amd64nt.asm +++ b/runtime/amd64nt.asm @@ -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 diff --git a/runtime/array.c b/runtime/array.c index 37af6b7f6..c43edbbc8 100644 --- a/runtime/array.c +++ b/runtime/array.c @@ -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"); diff --git a/runtime/caml/alloc.h b/runtime/caml/alloc.h index 3ca3c03ce..13f0fac2f 100644 --- a/runtime/caml/alloc.h +++ b/runtime/caml/alloc.h @@ -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*/ diff --git a/runtime/caml/gc.h b/runtime/caml/gc.h index 358981a47..854f9dba8 100644 --- a/runtime/caml/gc.h +++ b/runtime/caml/gc.h @@ -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) diff --git a/runtime/caml/io.h b/runtime/caml/io.h index 7b5fe2fd9..29868e701 100644 --- a/runtime/caml/io.h +++ b/runtime/caml/io.h @@ -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 */ }; diff --git a/runtime/caml/m.h.in b/runtime/caml/m.h.in index e12946fb8..1c3dee177 100644 --- a/runtime/caml/m.h.in +++ b/runtime/caml/m.h.in @@ -78,9 +78,6 @@ #undef PROFINFO_WIDTH -#undef WITH_SPACETIME -#undef ENABLE_CALL_COUNTS - #undef ASM_CFI_SUPPORTED #undef WITH_FRAME_POINTERS diff --git a/runtime/caml/memory.h b/runtime/caml/memory.h index eaa2e3c28..a7d594d5d 100644 --- a/runtime/caml/memory.h +++ b/runtime/caml/memory.h @@ -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)) diff --git a/runtime/caml/s.h.in b/runtime/caml/s.h.in index 3aa4ad938..2460577db 100644 --- a/runtime/caml/s.h.in +++ b/runtime/caml/s.h.in @@ -266,8 +266,6 @@ #undef HUGE_PAGE_SIZE -#undef HAS_LIBUNWIND - #undef HAS_BROKEN_PRINTF #undef HAS_STRERROR diff --git a/runtime/caml/spacetime.h b/runtime/caml/spacetime.h deleted file mode 100644 index 1d9733795..000000000 --- a/runtime/caml/spacetime.h +++ /dev/null @@ -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 */ diff --git a/runtime/caml/stack.h b/runtime/caml/stack.h index 6b7df0e67..9c182ee6a 100644 --- a/runtime/caml/stack.h +++ b/runtime/caml/stack.h @@ -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 */ diff --git a/runtime/dune b/runtime/dune index cc84c1378..3b4e2cc1d 100644 --- a/runtime/dune +++ b/runtime/dune @@ -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 diff --git a/runtime/dynlink_nat.c b/runtime/dynlink_nat.c index 6a824d35a..dba30c384 100644 --- a/runtime/dynlink_nat.c +++ b/runtime/dynlink_nat.c @@ -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); diff --git a/runtime/finalise.c b/runtime/finalise.c index 455f91aed..46e1b7dd4 100644 --- a/runtime/finalise.c +++ b/runtime/finalise.c @@ -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; } diff --git a/runtime/gen_primitives.sh b/runtime/gen_primitives.sh index 8816ccb41..a727d5c25 100755 --- a/runtime/gen_primitives.sh +++ b/runtime/gen_primitives.sh @@ -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" diff --git a/runtime/intern.c b/runtime/intern.c index 651c5ab57..9c3715144 100644 --- a/runtime/intern.c +++ b/runtime/intern.c @@ -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)) { diff --git a/runtime/memory.c b/runtime/memory.c index b68176c97..e9fbfe461 100644 --- a/runtime/memory.c +++ b/runtime/memory.c @@ -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. diff --git a/runtime/minor_gc.c b/runtime/minor_gc.c index 42acd6356..478bf46f3 100644 --- a/runtime/minor_gc.c +++ b/runtime/minor_gc.c @@ -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. */ diff --git a/runtime/misc.c b/runtime/misc.c index 397bd7cff..e817a6cc4 100644 --- a/runtime/misc.c +++ b/runtime/misc.c @@ -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; diff --git a/runtime/obj.c b/runtime/obj.c index 8cb560ddc..453041550 100644 --- a/runtime/obj.c +++ b/runtime/obj.c @@ -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); diff --git a/runtime/signals.c b/runtime/signals.c index 82b27e4f4..92d517e79 100644 --- a/runtime/signals.c +++ b/runtime/signals.c @@ -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); diff --git a/runtime/signals_nat.c b/runtime/signals_nat.c index 0e7c3ebe3..8b64ab452 100644 --- a/runtime/signals_nat.c +++ b/runtime/signals_nat.c @@ -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" diff --git a/runtime/spacetime_byt.c b/runtime/spacetime_byt.c deleted file mode 100644 index e31c514ef..000000000 --- a/runtime/spacetime_byt.c +++ /dev/null @@ -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; -} diff --git a/runtime/spacetime_nat.c b/runtime/spacetime_nat.c deleted file mode 100644 index ce8720477..000000000 --- a/runtime/spacetime_nat.c +++ /dev/null @@ -1,1147 +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 -#include -#include -#include -#include -#include -#include -#include -#include -#include "caml/config.h" -#ifdef HAS_UNISTD -#include -#endif -#ifdef _WIN32 -#include /* for _getpid */ -#include /* for _wgetcwd */ -#endif - -#include "caml/alloc.h" -#include "caml/backtrace_prim.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/osdeps.h" -#include "caml/roots.h" -#include "caml/signals.h" -#include "caml/stack.h" -#include "caml/sys.h" -#include "caml/spacetime.h" - -#ifdef WITH_SPACETIME - -/* We force "noinline" in certain places to be sure we know how many - frames there will be on the stack. */ -#ifdef _MSC_VER -#define NOINLINE __declspec(noinline) -#else -#define NOINLINE __attribute__((noinline)) -#endif - -#ifdef HAS_LIBUNWIND -#define UNW_LOCAL_ONLY -#include "libunwind.h" -#endif - -static int automatic_snapshots = 0; -static double snapshot_interval = 0.0; -static double next_snapshot_time = 0.0; -static struct channel *snapshot_channel; -static int pid_when_snapshot_channel_opened; - -static char* start_of_free_node_block; -static char* end_of_free_node_block; - -typedef struct per_thread { - value* trie_node_root; - value* finaliser_trie_node_root; - struct per_thread* next; -} per_thread; - -/* List of tries corresponding to threads that have been created. */ -/* CR-soon mshinwell: just include the main trie in this list. */ -static per_thread* per_threads = NULL; -static int num_per_threads = 0; - -/* [caml_spacetime_shapes] is defined in the startup file. */ -extern uint64_t* caml_spacetime_shapes; - -uint64_t** caml_spacetime_static_shape_tables = NULL; -shape_table* caml_spacetime_dynamic_shape_tables = NULL; - -static uintnat caml_spacetime_profinfo = (uintnat) 0; - -value caml_spacetime_trie_root = Val_unit; -value* caml_spacetime_trie_node_ptr = &caml_spacetime_trie_root; - -static value caml_spacetime_finaliser_trie_root_main_thread = Val_unit; -value* caml_spacetime_finaliser_trie_root - = &caml_spacetime_finaliser_trie_root_main_thread; - -/* CR-someday mshinwell: think about thread safety of the manipulation of - this list for multicore */ -allocation_point* caml_all_allocation_points = NULL; - -static const uintnat chunk_size = 1024 * 1024; - -#ifdef _WIN32 -#define strdup_os wcsdup -#else -#define strdup_os strdup -#endif - -static void reinitialise_free_node_block(void) -{ - size_t index; - - start_of_free_node_block = (char*) caml_stat_alloc_noexc(chunk_size); - end_of_free_node_block = start_of_free_node_block + chunk_size; - - for (index = 0; index < chunk_size / sizeof(value); index++) { - ((value*) start_of_free_node_block)[index] = Val_unit; - } -} - -#ifndef O_BINARY -#define O_BINARY 0 -#endif - -enum { - FEATURE_CALL_COUNTS = 1, -}; - -static uint16_t version_number = 0; -static uint32_t magic_number_base = 0xace00ace; - -static void caml_spacetime_write_magic_number_internal(struct channel* chan) -{ - value magic_number; - uint16_t features = 0; - -#ifdef ENABLE_CALL_COUNTS - features |= FEATURE_CALL_COUNTS; -#endif - - magic_number = - Val_long(((uint64_t) magic_number_base) - | (((uint64_t) version_number) << 32) - | (((uint64_t) features) << 48)); - - Lock(chan); - caml_output_val(chan, magic_number, Val_long(0)); - Unlock(chan); -} - -CAMLprim value caml_spacetime_write_magic_number(value v_channel) -{ - caml_spacetime_write_magic_number_internal(Channel(v_channel)); - return Val_unit; -} - -static char_os* automatic_snapshot_dir; - -static void open_snapshot_channel(void) -{ - int fd; - char_os filename[8192]; - int pid; - int filename_len = sizeof(filename)/sizeof(char_os); -#ifdef _WIN32 - pid = _getpid(); -#else - pid = getpid(); -#endif - snprintf_os(filename, filename_len, T("%s/spacetime-%d"), - automatic_snapshot_dir, pid); - filename[filename_len-1] = '\0'; - fd = open_os(filename, O_WRONLY | O_CREAT | O_TRUNC | O_BINARY, 0666); - if (fd == -1) { - automatic_snapshots = 0; - } - else { - snapshot_channel = caml_open_descriptor_out(fd); - snapshot_channel->flags |= CHANNEL_FLAG_BLOCKING_WRITE; - pid_when_snapshot_channel_opened = pid; - caml_spacetime_write_magic_number_internal(snapshot_channel); - } -} - -static void maybe_reopen_snapshot_channel(void) -{ - /* This function should be used before writing to the automatic snapshot - channel. It detects whether we have forked since the channel was opened. - If so, we close the old channel (ignoring any errors just in case the - old fd has been closed, e.g. in a double-fork situation where the middle - process has a loop to manually close all fds and no Spacetime snapshot - was written during that time) and then open a new one. */ - - int pid; -#ifdef _WIN32 - pid = _getpid(); -#else - pid = getpid(); -#endif - - if (pid != pid_when_snapshot_channel_opened) { - caml_close_channel(snapshot_channel); - open_snapshot_channel(); - } -} - -/* Defined later */ -static void caml_spacetime_automatic_save(void); - -void caml_spacetime_initialize(void) -{ - /* Note that this is called very early (even prior to GC initialisation). */ - - char_os *ap_interval; - - reinitialise_free_node_block(); - - caml_spacetime_static_shape_tables = &caml_spacetime_shapes; - - ap_interval = caml_secure_getenv (T("OCAML_SPACETIME_INTERVAL")); - if (ap_interval != NULL) { - unsigned int interval = 0; - sscanf_os(ap_interval, T("%u"), &interval); - if (interval != 0) { - double time; - char_os cwd[4096]; - char_os* user_specified_automatic_snapshot_dir; - int dir_ok = 1; - - user_specified_automatic_snapshot_dir = - caml_secure_getenv(T("OCAML_SPACETIME_SNAPSHOT_DIR")); - - if (user_specified_automatic_snapshot_dir == NULL) { -#if defined(HAS_GETCWD) - if (getcwd_os(cwd, sizeof(cwd)/sizeof(char_os)) == NULL) { - dir_ok = 0; - } -#else - dir_ok = 0; -#endif - if (dir_ok) { - automatic_snapshot_dir = strdup_os(cwd); - } - } - else { - automatic_snapshot_dir = - strdup_os(user_specified_automatic_snapshot_dir); - } - - if (dir_ok) { - automatic_snapshots = 1; - open_snapshot_channel(); - if (automatic_snapshots) { -#ifdef SIGINT - /* Catch interrupt so that the profile can be completed. - We do this by marking the signal as handled without - specifying an actual handler. This causes the signal - to be handled by a call to exit. */ - caml_set_signal_action(SIGINT, 2); -#endif - snapshot_interval = interval / 1e3; - time = caml_sys_time_unboxed(Val_unit); - next_snapshot_time = time + snapshot_interval; - atexit(&caml_spacetime_automatic_save); - } - } - } - } -} - -void caml_spacetime_register_shapes(void* dynlinked_table) -{ - shape_table* table; - table = (shape_table*) caml_stat_alloc_noexc(sizeof(shape_table)); - if (table == NULL) { - fprintf(stderr, "Out of memory whilst registering shape table"); - abort(); - } - table->table = (uint64_t*) dynlinked_table; - table->next = caml_spacetime_dynamic_shape_tables; - caml_spacetime_dynamic_shape_tables = table; -} - -void caml_spacetime_register_thread( - value* trie_node_root, value* finaliser_trie_node_root) -{ - per_thread* thr; - - thr = (per_thread*) caml_stat_alloc_noexc(sizeof(per_thread)); - if (thr == NULL) { - fprintf(stderr, "Out of memory while registering thread for profiling\n"); - abort(); - } - thr->next = per_threads; - per_threads = thr; - - thr->trie_node_root = trie_node_root; - thr->finaliser_trie_node_root = finaliser_trie_node_root; - - /* CR-soon mshinwell: record thread ID (and for the main thread too) */ - - num_per_threads++; -} - -static void caml_spacetime_save_event_internal (value v_time_opt, - struct channel* chan, - value v_event_name) -{ - value v_time; - 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; - } - v_time = caml_spacetime_timestamp(time_override, use_time_override); - - Lock(chan); - caml_output_val(chan, Val_long(2), Val_long(0)); - caml_output_val(chan, v_event_name, Val_long(0)); - caml_extern_allow_out_of_heap = 1; - caml_output_val(chan, v_time, Val_long(0)); - caml_extern_allow_out_of_heap = 0; - Unlock(chan); - - caml_stat_free(Hp_val(v_time)); -} - -CAMLprim value caml_spacetime_save_event (value v_time_opt, - value v_channel, - value v_event_name) -{ - struct channel* chan = Channel(v_channel); - - caml_spacetime_save_event_internal(v_time_opt, chan, v_event_name); - - return Val_unit; -} - - -static void save_trie (struct channel *chan, double time_override, - int use_time_override) -{ - value v_time, v_frames, v_shapes; - /* CR-someday mshinwell: The commented-out changes here are for multicore, - where we think we should have one trie per domain. */ - /* int num_marshalled = 0; - per_thread* thr = per_threads; */ - - Lock(chan); - - caml_output_val(chan, Val_long(1), Val_long(0)); - - v_time = caml_spacetime_timestamp(time_override, use_time_override); - v_frames = caml_spacetime_frame_table(); - v_shapes = caml_spacetime_shape_table(); - - caml_extern_allow_out_of_heap = 1; - caml_output_val(chan, v_time, Val_long(0)); - caml_output_val(chan, v_frames, Val_long(0)); - caml_output_val(chan, v_shapes, Val_long(0)); - caml_extern_allow_out_of_heap = 0; - - caml_output_val(chan, Val_long(1) /* Val_long(num_per_threads + 1) */, - Val_long(0)); - - /* Marshal both the main and finaliser tries, for all threads that have - been created, to an [out_channel]. This can be done by using the - extern.c code as usual, since the trie looks like standard OCaml values; - but we must allow it to traverse outside the heap. */ - - caml_extern_allow_out_of_heap = 1; - caml_output_val(chan, caml_spacetime_trie_root, Val_long(0)); - caml_output_val(chan, - caml_spacetime_finaliser_trie_root_main_thread, Val_long(0)); - /* while (thr != NULL) { - caml_output_val(chan, *(thr->trie_node_root), Val_long(0)); - caml_output_val(chan, *(thr->finaliser_trie_node_root), - Val_long(0)); - thr = thr->next; - num_marshalled++; - } - CAMLassert(num_marshalled == num_per_threads); */ - caml_extern_allow_out_of_heap = 0; - - Unlock(chan); -} - -CAMLprim value caml_spacetime_save_trie (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; - } - - save_trie(channel, time_override, use_time_override); - - return Val_unit; -} - -c_node_type caml_spacetime_classify_c_node(c_node* node) -{ - return (node->pc & 2) ? CALL : ALLOCATION; -} - -c_node* caml_spacetime_c_node_of_stored_pointer(value node_stored) -{ - CAMLassert(node_stored == Val_unit || Is_c_node(node_stored)); - return (node_stored == Val_unit) ? NULL : (c_node*) Hp_val(node_stored); -} - -c_node* caml_spacetime_c_node_of_stored_pointer_not_null( - value node_stored) -{ - CAMLassert(Is_c_node(node_stored)); - return (c_node*) Hp_val(node_stored); -} - -value caml_spacetime_stored_pointer_of_c_node(c_node* c_node) -{ - value node; - CAMLassert(c_node != NULL); - node = Val_hp(c_node); - CAMLassert(Is_c_node(node)); - return node; -} - -#ifdef HAS_LIBUNWIND -static int pc_inside_c_node_matches(c_node* node, void* pc) -{ - return Decode_c_node_pc(node->pc) == pc; -} -#endif - -static value allocate_uninitialized_ocaml_node(int size_including_header) -{ - void* node; - uintnat size; - - CAMLassert(size_including_header >= 3); - node = caml_stat_alloc(sizeof(uintnat) * size_including_header); - - size = size_including_header * sizeof(value); - - node = (void*) start_of_free_node_block; - if (end_of_free_node_block - start_of_free_node_block < size) { - reinitialise_free_node_block(); - node = (void*) start_of_free_node_block; - CAMLassert(end_of_free_node_block - start_of_free_node_block >= size); - } - - start_of_free_node_block += size; - - /* We don't currently rely on [uintnat] alignment, but we do need some - alignment, so just be sure. */ - CAMLassert (((uintnat) node) % sizeof(uintnat) == 0); - return Val_hp(node); -} - -static value find_tail_node(value node, void* callee) -{ - /* Search the tail chain within [node] (which corresponds to an invocation - of a caller of [callee]) to determine whether it contains a tail node - corresponding to [callee]. Returns any such node, or [Val_unit] if no - such node exists. */ - - value starting_node; - value pc; - value found = Val_unit; - - starting_node = node; - pc = Encode_node_pc(callee); - - do { - CAMLassert(Is_ocaml_node(node)); - if (Node_pc(node) == pc) { - found = node; - } - else { - node = Tail_link(node); - } - } while (found == Val_unit && starting_node != node); - - return found; -} - -CAMLprim value caml_spacetime_allocate_node( - int size_including_header, void* pc, value* node_hole) -{ - value node; - value caller_node = Val_unit; - - node = *node_hole; - /* The node hole should either contain [Val_unit], indicating that this - function was not tail called and we have not been to this point in the - trie before; or it should contain a value encoded using - [Encoded_tail_caller_node] that points at the node of a caller - that tail called the current function. (Such a value is necessary to - be able to find the start of the caller's node, and hence its tail - chain, so we as a tail-called callee can link ourselves in.) */ - CAMLassert(Is_tail_caller_node_encoded(node)); - - if (node != Val_unit) { - value tail_node; - /* The callee was tail called. Find whether there already exists a node - for it in the tail call chain within the caller's node. The caller's - node must always be an OCaml node. */ - caller_node = Decode_tail_caller_node(node); - tail_node = find_tail_node(caller_node, pc); - if (tail_node != Val_unit) { - /* This tail calling sequence has happened before; just fill the hole - with the existing node and return. */ - *node_hole = tail_node; - return 0; /* indicates an existing node was returned */ - } - } - - node = allocate_uninitialized_ocaml_node(size_including_header); - Hd_val(node) = - Make_header(size_including_header - 1, OCaml_node_tag, Caml_black); - CAMLassert((((uintnat) pc) % 1) == 0); - Node_pc(node) = Encode_node_pc(pc); - /* If the callee was tail called, then the tail link field will link this - new node into an existing tail chain. Otherwise, it is initialized with - the empty tail chain, i.e. the one pointing directly at [node]. */ - if (caller_node == Val_unit) { - Tail_link(node) = node; - } - else { - Tail_link(node) = Tail_link(caller_node); - Tail_link(caller_node) = node; - } - - /* The callee node pointers for direct tail call points are - initialized from code emitted by the OCaml compiler. This is done to - avoid having to pass this function a description of which nodes are - direct tail call points. (We cannot just count them and put them at the - beginning of the node because we need the indexes of elements within the - node during instruction selection before we have found all call points.) - - All other fields have already been initialised by - [reinitialise_free_node_block]. - */ - - *node_hole = node; - - return 1; /* indicates a new node was created */ -} - -static c_node* allocate_c_node(void) -{ - c_node* node; - size_t index; - - node = (c_node*) start_of_free_node_block; - if (end_of_free_node_block - start_of_free_node_block < sizeof(c_node)) { - reinitialise_free_node_block(); - node = (c_node*) start_of_free_node_block; - CAMLassert(end_of_free_node_block - start_of_free_node_block - >= sizeof(c_node)); - } - start_of_free_node_block += sizeof(c_node); - - CAMLassert((sizeof(c_node) % sizeof(uintnat)) == 0); - - /* CR-soon mshinwell: remove this and pad the structure properly */ - for (index = 0; index < sizeof(c_node) / sizeof(value); index++) { - ((value*) node)[index] = Val_unit; - } - - node->gc_header = - Make_header(sizeof(c_node)/sizeof(uintnat) - 1, C_node_tag, Caml_black); - node->data.call.callee_node = Val_unit; - node->data.call.call_count = Val_long(0); - node->next = Val_unit; - - return node; -} - -/* Since a given indirect call site either always yields tail calls or - always yields non-tail calls, the output of - [caml_spacetime_indirect_node_hole_ptr] is uniquely determined by its - first two arguments (the callee and the node hole). We cache these - to increase performance of recursive functions containing an indirect - call (e.g. [List.map] when not inlined). */ -static void* last_indirect_node_hole_ptr_callee; -static value* last_indirect_node_hole_ptr_node_hole; -static call_point* last_indirect_node_hole_ptr_result; - -CAMLexport value* caml_spacetime_indirect_node_hole_ptr - (void* callee, value* node_hole, value caller_node) -{ - /* Find the address of the node hole for an indirect call to [callee]. - If [caller_node] is not [Val_unit], it is a pointer to the caller's - node, and indicates that this is a tail call site. */ - - c_node* c_node; - value encoded_callee; - - if (callee == last_indirect_node_hole_ptr_callee - && node_hole == last_indirect_node_hole_ptr_node_hole) { -#ifdef ENABLE_CALL_COUNTS - last_indirect_node_hole_ptr_result->call_count = - Val_long (Long_val (last_indirect_node_hole_ptr_result->call_count) + 1); -#endif - return &(last_indirect_node_hole_ptr_result->callee_node); - } - - last_indirect_node_hole_ptr_callee = callee; - last_indirect_node_hole_ptr_node_hole = node_hole; - - encoded_callee = Encode_c_node_pc_for_call(callee); - - while (*node_hole != Val_unit) { - CAMLassert(((uintnat) *node_hole) % sizeof(value) == 0); - - c_node = caml_spacetime_c_node_of_stored_pointer_not_null(*node_hole); - - CAMLassert(c_node != NULL); - CAMLassert(caml_spacetime_classify_c_node(c_node) == CALL); - - if (c_node->pc == encoded_callee) { -#ifdef ENABLE_CALL_COUNTS - c_node->data.call.call_count = - Val_long (Long_val(c_node->data.call.call_count) + 1); -#endif - last_indirect_node_hole_ptr_result = &(c_node->data.call); - return &(last_indirect_node_hole_ptr_result->callee_node); - } - else { - node_hole = &c_node->next; - } - } - - c_node = allocate_c_node(); - c_node->pc = encoded_callee; - - if (caller_node != Val_unit) { - /* This is a tail call site. - Perform the initialization equivalent to that emitted by - [Spacetime.code_for_function_prologue] for direct tail call - sites. */ - c_node->data.call.callee_node = Encode_tail_caller_node(caller_node); - } - - *node_hole = caml_spacetime_stored_pointer_of_c_node(c_node); - - CAMLassert(((uintnat) *node_hole) % sizeof(value) == 0); - CAMLassert(*node_hole != Val_unit); - -#ifdef ENABLE_CALL_COUNTS - c_node->data.call.call_count = - Val_long (Long_val(c_node->data.call.call_count) + 1); -#endif - last_indirect_node_hole_ptr_result = &(c_node->data.call); - - return &(last_indirect_node_hole_ptr_result->callee_node); -} - -/* Some notes on why caml_call_gc doesn't need a distinguished node. - (Remember that thread switches are irrelevant here because each thread - has its own trie.) - - caml_call_gc only invokes OCaml functions in the following circumstances: - 1. running an OCaml finaliser; - 2. executing an OCaml signal handler; - 3. executing memprof callbacks. - All of these are done on the finaliser trie. Furthermore, all of - these invocations start via caml_callback; the code in this file for - handling that (caml_spacetime_c_to_ocaml) correctly copes with that by - attaching a single "caml_start_program" node that can cope with any - number of indirect OCaml calls from that point. - - caml_call_gc may also invoke C functions that cause allocation. All of - these (assuming libunwind support is present) will cause a chain of - c_node structures to be attached to the trie, starting at the node hole - passed to caml_call_gc from OCaml code. These structures are extensible - and can thus accommodate any number of C backtraces leading from - caml_call_gc. -*/ -/* CR-soon mshinwell: it might in fact be the case now that nothing called - from caml_call_gc will do any allocation that ends up on the trie. We - can revisit this after the first release. */ - -static NOINLINE void* find_trie_node_from_libunwind(int for_allocation, - uintnat wosize, struct ext_table** cached_frames) -{ -#ifdef HAS_LIBUNWIND - /* Given that [Caml_state->last_return_address] is the most recent call site - in OCaml code, and that we are now in C (or other) code called from that - site, obtain a backtrace using libunwind and graft the most recent - portion (everything back to but not including [last_return_address]) - onto the trie. See the important comment below regarding the fact that - call site, and not callee, addresses are recorded during this process. - - If [for_allocation] is non-zero, the final node recorded will be for - an allocation, and the returned pointer is to the allocation node. - Otherwise, no node is recorded for the innermost frame, and the - returned pointer is a pointer to the *node hole* where a node for that - frame should be attached. - - If [for_allocation] is non-zero then [wosize] must give the size in - words, excluding the header, of the value being allocated. - - If [cached_frames != NULL] then: - 1. If [*cached_frames] is NULL then save the captured backtrace in a - newly-allocated table and store the pointer to that table in - [*cached_frames]; - 2. Otherwise use [*cached_frames] as the unwinding information. - The intention is that when the context is known (e.g. a function such - as [caml_make_vect] known to have been directly invoked from OCaml), - we can avoid expensive calls to libunwind. - */ - - unw_cursor_t cur; - unw_context_t ctx; - int ret; - int innermost_frame; - int frame; - static struct ext_table frames_local; - struct ext_table* frames; - static int ext_table_initialised = 0; - int have_frames_already = 0; - value* node_hole; - c_node* node = NULL; - int initial_table_size = 1000; - int must_initialise_node_for_allocation = 0; - - if (!cached_frames) { - if (!ext_table_initialised) { - caml_ext_table_init(&frames_local, initial_table_size); - ext_table_initialised = 1; - } - else { - caml_ext_table_clear(&frames_local, 0); - } - frames = &frames_local; - } else { - if (*cached_frames) { - frames = *cached_frames; - have_frames_already = 1; - } - else { - frames = - (struct ext_table*) caml_stat_alloc_noexc(sizeof(struct ext_table)); - if (!frames) { - caml_fatal_error("not enough memory for ext_table allocation"); - } - caml_ext_table_init(frames, initial_table_size); - *cached_frames = frames; - } - } - - if (!have_frames_already) { - /* Get the stack backtrace as far as [Caml_state->last_return_address]. */ - - ret = unw_getcontext(&ctx); - if (ret != UNW_ESUCCESS) { - return NULL; - } - - ret = unw_init_local(&cur, &ctx); - if (ret != UNW_ESUCCESS) { - return NULL; - } - - while ((ret = unw_step(&cur)) > 0) { - unw_word_t ip; - unw_get_reg(&cur, UNW_REG_IP, &ip); - if (Caml_state->last_return_address == (uintnat) ip) { - break; - } - else { - /* Inlined some of [caml_ext_table_add] for speed. */ - if (frames->size < frames->capacity) { - frames->contents[frames->size++] = (void*) ip; - } else { - caml_ext_table_add(frames, (void*) ip); - } - } - } - } - - /* We always need to ignore the frames for: - #0 find_trie_node_from_libunwind - #1 caml_spacetime_c_to_ocaml - Further, if this is not an allocation point, we should not create the - node for the current C function that triggered us (i.e. frame #2). */ - innermost_frame = for_allocation ? 1 : 2; - - if (frames->size - 1 < innermost_frame) { - /* Insufficiently many frames (maybe no frames) returned from - libunwind; just don't do anything. */ - return NULL; - } - - node_hole = caml_spacetime_trie_node_ptr; - /* Note that if [node_hole] is filled, then it must point to a C node, - since it is not possible for there to be a call point in an OCaml - function that sometimes calls C and sometimes calls OCaml. */ - - for (frame = frames->size - 1; frame >= innermost_frame; frame--) { - c_node_type expected_type; - void* pc = frames->contents[frame]; - CAMLassert (pc != (void*) Caml_state->last_return_address); - - if (!for_allocation) { - expected_type = CALL; - } - else { - expected_type = (frame > innermost_frame ? CALL : ALLOCATION); - } - - if (*node_hole == Val_unit) { - node = allocate_c_node(); - /* Note: for CALL nodes, the PC is the program counter at each call - site. We do not store program counter addresses of the start of - callees, unlike for OCaml nodes. This means that some trie nodes - will become conflated. These can be split during post-processing by - working out which function each call site was in. */ - node->pc = (expected_type == CALL ? Encode_c_node_pc_for_call(pc) - : Encode_c_node_pc_for_alloc_point(pc)); - *node_hole = caml_spacetime_stored_pointer_of_c_node(node); - if (expected_type == ALLOCATION) { - must_initialise_node_for_allocation = 1; - } - } - else { - c_node* prev; - int found = 0; - - node = caml_spacetime_c_node_of_stored_pointer_not_null(*node_hole); - CAMLassert(node != NULL); - CAMLassert(node->next == Val_unit - || (((uintnat) (node->next)) % sizeof(value) == 0)); - - prev = NULL; - - while (!found && node != NULL) { - if (caml_spacetime_classify_c_node(node) == expected_type - && pc_inside_c_node_matches(node, pc)) { - found = 1; - } - else { - prev = node; - node = caml_spacetime_c_node_of_stored_pointer(node->next); - } - } - if (!found) { - CAMLassert(prev != NULL); - node = allocate_c_node(); - node->pc = (expected_type == CALL ? Encode_c_node_pc_for_call(pc) - : Encode_c_node_pc_for_alloc_point(pc)); - if (expected_type == ALLOCATION) { - must_initialise_node_for_allocation = 1; - } - prev->next = caml_spacetime_stored_pointer_of_c_node(node); - } - } - - CAMLassert(node != NULL); - - CAMLassert(caml_spacetime_classify_c_node(node) == expected_type); - CAMLassert(pc_inside_c_node_matches(node, pc)); - node_hole = &node->data.call.callee_node; - } - - if (must_initialise_node_for_allocation) { - caml_spacetime_profinfo++; - if (caml_spacetime_profinfo > PROFINFO_MASK) { - /* Profiling counter overflow. */ - caml_spacetime_profinfo = PROFINFO_MASK; - } - node->data.allocation.profinfo = - Make_header_with_profinfo( - /* "-1" because [c_node] has the GC header as its first - element. */ - offsetof(c_node, data.allocation.count)/sizeof(value) - 1, - Infix_tag, - Caml_black, - caml_spacetime_profinfo); - node->data.allocation.count = Val_long(0); - - /* Add the new allocation point into the linked list of all allocation - points. */ - if (caml_all_allocation_points != NULL) { - node->data.allocation.next = - (value) &caml_all_allocation_points->count; - } else { - node->data.allocation.next = Val_unit; - } - caml_all_allocation_points = &node->data.allocation; - } - - if (for_allocation) { - CAMLassert(caml_spacetime_classify_c_node(node) == ALLOCATION); - CAMLassert(caml_spacetime_c_node_of_stored_pointer(node->next) != node); - CAMLassert(Profinfo_hd(node->data.allocation.profinfo) > 0); - node->data.allocation.count = - Val_long(Long_val(node->data.allocation.count) + (1 + wosize)); - } - - CAMLassert(node->next != (value) NULL); - - return for_allocation ? (void*) node : (void*) node_hole; -#else - return NULL; -#endif -} - -void caml_spacetime_c_to_ocaml(void* ocaml_entry_point, - void* identifying_pc_for_caml_start_program) -{ - /* Called in [caml_start_program] and [caml_callback*] when we are about - to cross from C into OCaml. [ocaml_entry_point] is the branch target. - This situation is handled by ensuring the presence of a new OCaml node - for the callback veneer; the node contains a single indirect call point - which accumulates the [ocaml_entry_point]s. - - The layout of the node is described in the "system shape table"; see - amd64.S. - */ - - value node; - - /* Update the trie with the current backtrace, as far back as - [Caml_state->last_return_address], and leave the node hole pointer at - the correct place for attachment of a [caml_start_program] node. */ - -#ifdef HAS_LIBUNWIND - value* node_temp; - node_temp = (value*) find_trie_node_from_libunwind(0, 0, NULL); - if (node_temp != NULL) { - caml_spacetime_trie_node_ptr = node_temp; - } -#endif - - if (*caml_spacetime_trie_node_ptr == Val_unit) { - uintnat size_including_header; - - size_including_header = - 1 /* GC header */ + Node_num_header_words + Indirect_num_fields; - - node = allocate_uninitialized_ocaml_node(size_including_header); - Hd_val(node) = - Make_header(size_including_header - 1, OCaml_node_tag, Caml_black); - CAMLassert((((uintnat) identifying_pc_for_caml_start_program) % 1) == 0); - Node_pc(node) = Encode_node_pc(identifying_pc_for_caml_start_program); - Tail_link(node) = node; - Indirect_pc_linked_list(node, Node_num_header_words) = Val_unit; - *caml_spacetime_trie_node_ptr = node; - } - else { - node = *caml_spacetime_trie_node_ptr; - /* If there is a node here already, it should never be an initialized - (but as yet unused) tail call point, since calls from OCaml into C - are never tail calls (and no C -> C call is marked as tail). */ - CAMLassert(!Is_tail_caller_node_encoded(node)); - } - - CAMLassert(Is_ocaml_node(node)); - CAMLassert(Decode_node_pc(Node_pc(node)) - == identifying_pc_for_caml_start_program); - CAMLassert(Tail_link(node) == node); - CAMLassert(Wosize_val(node) == Node_num_header_words + Indirect_num_fields); - - /* Search the node to find the node hole corresponding to the indirect - call to the OCaml function. */ - caml_spacetime_trie_node_ptr = - caml_spacetime_indirect_node_hole_ptr( - ocaml_entry_point, - &Indirect_pc_linked_list(node, Node_num_header_words), - Val_unit); - CAMLassert(*caml_spacetime_trie_node_ptr == Val_unit - || Is_ocaml_node(*caml_spacetime_trie_node_ptr)); -} - -CAMLexport uintnat caml_spacetime_generate_profinfo (void* profinfo_words, - uintnat index_within_node) -{ - /* Called from code that creates a value's header inside an OCaml - function. */ - - value node; - uintnat profinfo; - - caml_spacetime_profinfo++; - if (caml_spacetime_profinfo > PROFINFO_MASK) { - /* Profiling counter overflow. */ - caml_spacetime_profinfo = PROFINFO_MASK; - } - profinfo = caml_spacetime_profinfo; - - /* CR-someday mshinwell: we could always use the [struct allocation_point] - overlay instead of the macros now. */ - - /* [node] isn't really a node; it points into the middle of - one---specifically to the "profinfo" word of an allocation point. - It's done like this to avoid re-calculating the place in the node - (which already has to be done in the OCaml-generated code run before - this function). */ - node = (value) profinfo_words; - CAMLassert(Alloc_point_profinfo(node, 0) == Val_unit); - - /* The profinfo value is stored shifted to reduce the number of - instructions required on the OCaml side. It also enables us to use - [Infix_tag] to obtain valid value pointers into the middle of nodes, - which is used for the linked list of all allocation points. */ - profinfo = Make_header_with_profinfo( - index_within_node, Infix_tag, Caml_black, profinfo); - - CAMLassert(!Is_block(profinfo)); - Alloc_point_profinfo(node, 0) = profinfo; - /* The count is set to zero by the initialisation when the node was - created (see above). */ - CAMLassert(Alloc_point_count(node, 0) == Val_long(0)); - - /* Add the new allocation point into the linked list of all allocation - points. */ - if (caml_all_allocation_points != NULL) { - Alloc_point_next_ptr(node, 0) = (value) &caml_all_allocation_points->count; - } - else { - CAMLassert(Alloc_point_next_ptr(node, 0) == Val_unit); - } - caml_all_allocation_points = (allocation_point*) node; - - return profinfo; -} - -uintnat caml_spacetime_my_profinfo (struct ext_table** cached_frames, - uintnat wosize) -{ - /* Return the profinfo value that should be written into a value's header - during an allocation from C. This may necessitate extending the trie - with information obtained from libunwind. */ - - c_node* node; - uintnat profinfo = 0; - - node = find_trie_node_from_libunwind(1, wosize, cached_frames); - if (node != NULL) { - profinfo = ((uintnat) (node->data.allocation.profinfo)) >> PROFINFO_SHIFT; - } - - return profinfo; /* N.B. not shifted by PROFINFO_SHIFT */ -} - -void caml_spacetime_automatic_snapshot (void) -{ - if (automatic_snapshots) { - double start_time, end_time; - start_time = caml_sys_time_unboxed(Val_unit); - if (start_time >= next_snapshot_time) { - maybe_reopen_snapshot_channel(); - caml_spacetime_save_snapshot(snapshot_channel, 0.0, 0); - end_time = caml_sys_time_unboxed(Val_unit); - next_snapshot_time = end_time + snapshot_interval; - } - } -} - -CAMLprim value caml_spacetime_save_event_for_automatic_snapshots - (value v_event_name) -{ - if (automatic_snapshots) { - maybe_reopen_snapshot_channel(); - caml_spacetime_save_event_internal (Val_unit, snapshot_channel, - v_event_name); - } - return Val_unit; -} - -static void caml_spacetime_automatic_save (void) -{ - /* Called from [atexit]. */ - - if (automatic_snapshots) { - automatic_snapshots = 0; - maybe_reopen_snapshot_channel(); - save_trie(snapshot_channel, 0.0, 0); - caml_flush(snapshot_channel); - caml_close_channel(snapshot_channel); - } -} - -CAMLprim value caml_spacetime_enabled (value v_unit) -{ - return Val_true; -} - -CAMLprim value caml_register_channel_for_spacetime (value v_channel) -{ - struct channel* channel = Channel(v_channel); - channel->flags |= CHANNEL_FLAG_BLOCKING_WRITE; - return Val_unit; -} - -#else - -/* Functions for when the compiler was not configured with - "--enable-spacetime". */ - -CAMLprim value caml_spacetime_write_magic_number(value v_channel) -{ - return Val_unit; -} - -CAMLprim value caml_spacetime_enabled (value v_unit) -{ - return Val_false; -} - -CAMLprim value caml_spacetime_save_event (value v_time_opt, - value v_channel, - value v_event_name) -{ - return Val_unit; -} - -CAMLprim value caml_spacetime_save_event_for_automatic_snapshots - (value v_event_name) -{ - return Val_unit; -} - -CAMLprim value caml_spacetime_save_trie (value v_time_opt, value v_channel) -{ - return Val_unit; -} - -CAMLprim value caml_register_channel_for_spacetime (value v_channel) -{ - return Val_unit; -} - -#endif diff --git a/runtime/spacetime_snapshot.c b/runtime/spacetime_snapshot.c deleted file mode 100644 index a76465f30..000000000 --- a/runtime/spacetime_snapshot.c +++ /dev/null @@ -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 -#include -#include -#include -#include - -#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 diff --git a/runtime/startup_aux.c b/runtime/startup_aux.c index ba15a30bf..ff6c8fba3 100644 --- a/runtime/startup_aux.c +++ b/runtime/startup_aux.c @@ -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) { diff --git a/runtime/startup_nat.c b/runtime/startup_nat.c index 4f9cf214d..722f834b1 100644 --- a/runtime/startup_nat.c +++ b/runtime/startup_nat.c @@ -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 diff --git a/runtime/unix.c b/runtime/unix.c index e381690b0..a33717738 100644 --- a/runtime/unix.c +++ b/runtime/unix.c @@ -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) { diff --git a/runtime/win32.c b/runtime/win32.c index 3b140db2b..c7d3c50c2 100644 --- a/runtime/win32.c +++ b/runtime/win32.c @@ -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(); diff --git a/stdlib/.depend b/stdlib/.depend index b2d514c46..6af3a5eee 100644 --- a/stdlib/.depend +++ b/stdlib/.depend @@ -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 \ diff --git a/stdlib/StdlibModules b/stdlib/StdlibModules index a49bfa140..4f475ba87 100644 --- a/stdlib/StdlibModules +++ b/stdlib/StdlibModules @@ -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))) diff --git a/stdlib/spacetime.ml b/stdlib/spacetime.ml deleted file mode 100644 index 3e8abe1d0..000000000 --- a/stdlib/spacetime.ml +++ /dev/null @@ -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) diff --git a/stdlib/spacetime.mli b/stdlib/spacetime.mli deleted file mode 100644 index 1f770905d..000000000 --- a/stdlib/spacetime.mli +++ /dev/null @@ -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-" where 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 diff --git a/stdlib/stdlib.ml b/stdlib/stdlib.ml index 3c942cb98..5daaf0867 100644 --- a/stdlib/stdlib.ml +++ b/stdlib/stdlib.ml @@ -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 diff --git a/stdlib/stdlib.mli b/stdlib/stdlib.mli index 8afb798d6..28c1381eb 100644 --- a/stdlib/stdlib.mli +++ b/stdlib/stdlib.mli @@ -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 diff --git a/toplevel/dune b/toplevel/dune index d1a96d607..dff689b31 100644 --- a/toplevel/dune +++ b/toplevel/dune @@ -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 diff --git a/utils/Makefile b/utils/Makefile index 56d67e425..871fc2fe5 100644 --- a/utils/Makefile +++ b/utils/Makefile @@ -61,8 +61,6 @@ config.ml: config.mlp $(ROOTDIR)/Makefile.config Makefile $(call SUBST_QUOTE,FLEXDLL_DIR) \ $(call SUBST,HOST) \ $(call SUBST_STRING,LIBDIR) \ - $(call SUBST,LIBUNWIND_AVAILABLE) \ - $(call SUBST,LIBUNWIND_LINK_FLAGS) \ $(call SUBST_STRING,MKDLL) \ $(call SUBST_STRING,MKEXE) \ $(call SUBST_STRING,FLEXLINK_LDFLAGS) \ @@ -85,8 +83,6 @@ config.ml: config.mlp $(ROOTDIR)/Makefile.config Makefile $(call SUBST,TARGET) \ $(call SUBST,WITH_FRAME_POINTERS) \ $(call SUBST,WITH_PROFINFO) \ - $(call SUBST,WITH_SPACETIME) \ - $(call SUBST,ENABLE_CALL_COUNTS) \ $(call SUBST,FLAT_FLOAT_ARRAY) \ $(call SUBST,FUNCTION_SECTIONS) \ $(call SUBST,CC_HAS_DEBUG_PREFIX_MAP) \ diff --git a/utils/config.mli b/utils/config.mli index d50761ceb..81fa423f0 100644 --- a/utils/config.mli +++ b/utils/config.mli @@ -197,12 +197,6 @@ val flambda : bool val with_flambda_invariants : bool (** Whether the invariants checks for flambda are enabled *) -val spacetime : bool -(** Whether the compiler was configured for Spacetime profiling *) - -val enable_call_counts : bool -(** Whether call counts are to be available when Spacetime profiling *) - val profinfo : bool (** Whether the compiler was configured for profiling *) @@ -210,12 +204,6 @@ val profinfo_width : int (** How many bits are to be used in values' headers for profiling information *) -val libunwind_available : bool -(** Whether the libunwind library is available on the target *) - -val libunwind_link_flags : string -(** Linker flags to use libunwind *) - val safe_string: bool (** Whether the compiler was configured with -force-safe-string; in that case, the -unsafe-string compile-time option is unavailable diff --git a/utils/config.mlp b/utils/config.mlp index 8e4f79d2b..07763f845 100644 --- a/utils/config.mlp +++ b/utils/config.mlp @@ -124,10 +124,6 @@ let system = "%%SYSTEM%%" let asm = "%%ASM%%" let asm_cfi_supported = %%ASM_CFI_SUPPORTED%% let with_frame_pointers = %%WITH_FRAME_POINTERS%% -let spacetime = %%WITH_SPACETIME%% -let enable_call_counts = %%ENABLE_CALL_COUNTS%% -let libunwind_available = %%LIBUNWIND_AVAILABLE%% -let libunwind_link_flags = "%%LIBUNWIND_LINK_FLAGS%%" let profinfo = %%WITH_PROFINFO%% let profinfo_width = %%PROFINFO_WIDTH%% @@ -194,7 +190,6 @@ let configuration_variables = p "host" host; p "target" target; p_bool "flambda" flambda; - p_bool "spacetime" spacetime; p_bool "safe_string" safe_string; p_bool "default_safe_string" default_safe_string; p_bool "flat_float_array" flat_float_array;