From 992c63f7caf3a6de085bf85ff2ce36775ad17c7f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Bour?= Date: Thu, 2 Apr 2020 12:51:26 +0200 Subject: [PATCH] Import --- camtrail.opam | 0 decoder/decoder.ml | 97 +++++++++++++++++++++++++++++++++++++++++ decoder/dune | 2 + dune-project | 13 ++++++ lib/_build/log | 6 +++ lib/camtrail.ml | 1 + lib/camtrail_stubs.c | 96 ++++++++++++++++++++++++++++++++++++++++ lib/dune | 6 +++ ppx/camtrail_ppx.ml | 101 +++++++++++++++++++++++++++++++++++++++++++ ppx/dune | 5 +++ test/Makefile | 2 + test/dune | 5 +++ test/test.ml | 12 +++++ 13 files changed, 346 insertions(+) create mode 100644 camtrail.opam create mode 100644 decoder/decoder.ml create mode 100644 decoder/dune create mode 100644 dune-project create mode 100644 lib/_build/log create mode 100644 lib/camtrail.ml create mode 100644 lib/camtrail_stubs.c create mode 100644 lib/dune create mode 100644 ppx/camtrail_ppx.ml create mode 100644 ppx/dune create mode 100644 test/Makefile create mode 100644 test/dune create mode 100644 test/test.ml diff --git a/camtrail.opam b/camtrail.opam new file mode 100644 index 0000000..e69de29 diff --git a/decoder/decoder.ml b/decoder/decoder.ml new file mode 100644 index 0000000..ab5f723 --- /dev/null +++ b/decoder/decoder.ml @@ -0,0 +1,97 @@ +let trace_path = Sys.argv.(1) +let index_path = trace_path ^ ".idx" + +let read_int32 ic = + let b0 = input_byte ic in + let b1 = input_byte ic in + let b2 = input_byte ic in + let b3 = input_byte ic in + Int32.( + logor (shift_left (of_int b0) 0) @@ + logor (shift_left (of_int b1) 8) @@ + logor (shift_left (of_int b2) 16) @@ + (shift_left (of_int b3) 24) + ) + +let read_int64 ic = + let b0 = input_byte ic in + let b1 = input_byte ic in + let b2 = input_byte ic in + let b3 = input_byte ic in + let b4 = input_byte ic in + let b5 = input_byte ic in + let b6 = input_byte ic in + let b7 = input_byte ic in + Int64.( + logor (shift_left (of_int b0) 0) @@ + logor (shift_left (of_int b1) 8) @@ + logor (shift_left (of_int b2) 16) @@ + logor (shift_left (of_int b3) 24) @@ + logor (shift_left (of_int b4) 32) @@ + logor (shift_left (of_int b5) 40) @@ + logor (shift_left (of_int b6) 48) @@ + (shift_left (of_int b7) 56) + ) + +let index = + let read_entry ic = + let length = Int32.to_int @@ read_int32 ic in + assert (length > 4); + let index = Int32.to_int @@ read_int32 ic in + let name = really_input_string ic (length - 4) in + (index, name) + in + let read_entries ic = + let entries = ref [] in + (try + while true do + let entry = read_entry ic in + entries := entry :: !entries; + done + with End_of_file -> ()); + !entries + in + let make_index entries = + let table = Array.make (List.length entries) "" in + List.iter (fun (index, name) -> + assert (index >= 1024); + table.(index - 1024) <- name + ) entries; + table + in + let ic = open_in_bin index_path in + let entries = read_entries ic in + close_in_noerr ic; + make_index entries + +let () = + let ic = open_in_bin trace_path in + let fold_event ic f acc = + let read_event ic = + let atom = Int32.to_int @@ read_int32 ic in + let sp = read_int32 ic in + let time = read_int64 ic in + (index.(atom - 1024), sp, time) + in + let acc = ref acc in + try + while true do acc := f !acc (read_event ic) done; + !acc + with End_of_file -> !acc + in + let rec add_sp (sp : int32) time1 time0 = function + | (sp', time0) :: rest when sp >= sp' -> + add_sp sp time1 time0 rest + | sps -> ((sp, time1) :: sps, Int64.sub time1 time0) + in + let _ = + fold_event ic (fun lastsps (atom, sp, time) -> + let lastsps, delta = add_sp sp time time lastsps in + let indent = String.make (List.length lastsps) ' ' in + if delta > 0L then + print_endline (indent ^ Int64.to_string delta ^ " ns"); + print_endline (indent ^ "- " ^ atom); + lastsps + ) [] + in + close_in_noerr ic diff --git a/decoder/dune b/decoder/dune new file mode 100644 index 0000000..4d87633 --- /dev/null +++ b/decoder/dune @@ -0,0 +1,2 @@ +(executable + (name decoder)) diff --git a/dune-project b/dune-project new file mode 100644 index 0000000..5656ac7 --- /dev/null +++ b/dune-project @@ -0,0 +1,13 @@ +(lang dune 2.4) +(generate_opam_files true) + +(name camtrail) +(source (github let-def/camtrail)) +(license MIT) +(authors "Frédéric Bour") +(maintainers "fred@tarides.com") + +(package + (name camtrail) + (synopsis "Lighweight tracing for OCaml programs") + (depends dune)) diff --git a/lib/_build/log b/lib/_build/log new file mode 100644 index 0000000..dd9a508 --- /dev/null +++ b/lib/_build/log @@ -0,0 +1,6 @@ +# dune build camtrail.cmxa +# OCAMLPARAM: unset +# Workspace root: /home/def/Work/camtrail/lib +$ /usr/bin/nproc > /tmp/dunee5dd1b.output 2> /dev/null +# Auto-detected concurrency: 8 +# disable binary cache diff --git a/lib/camtrail.ml b/lib/camtrail.ml new file mode 100644 index 0000000..106dc80 --- /dev/null +++ b/lib/camtrail.ml @@ -0,0 +1 @@ +external enter : string -> unit = "camtrail_enter" [@@ocaml.noalloc] diff --git a/lib/camtrail_stubs.c b/lib/camtrail_stubs.c new file mode 100644 index 0000000..b23dfbb --- /dev/null +++ b/lib/camtrail_stubs.c @@ -0,0 +1,96 @@ +#include +#include +#include +#include +#include + +static int trail_initialized = 0; +static FILE *trail_index = NULL; +static FILE *trail_trace = NULL; +static uint32_t trail_next_atom = 0; + +typedef struct { + uint32_t atom; + uint32_t sp; + uint64_t time; +} event_t; + +#define TRAIL_BUFFER_SIZE 4096 +static int trail_buffer_index = 0; +static event_t trail_buffer[TRAIL_BUFFER_SIZE]; + +static uint64_t trail_gettime(void) +{ + struct timespec tp; + //clock_gettime(CLOCK_MONOTONIC_COARSE, &tp); + clock_gettime(CLOCK_MONOTONIC, &tp); + return tp.tv_sec * 1000000000 + tp.tv_nsec; +} + +static void trail_flush(void) +{ + fwrite(trail_buffer, sizeof(event_t), trail_buffer_index, trail_trace); + trail_buffer_index = 0; +} + +static void trail_atexit(void) +{ + trail_flush(); + fclose(trail_index); + fclose(trail_trace); +} + +static void trail_initialize(void) +{ + char *trace_file = getenv("CAMTRAIL_FILE"); + if (trace_file) + { + char index_file[1024]; + strncpy(index_file, trace_file, 1023); + strncat(index_file, ".idx", 1023); + index_file[1023] = '\0'; + trail_index = fopen(index_file, "wb"); + trail_trace = fopen(trace_file, "wb"); + atexit(&trail_atexit); + } + trail_initialized = 1; +} + +static uint32_t trail_alloc_atom(value name) +{ + uint32_t *buffer = (uint32_t*)String_val(name); + uint32_t result = 1024 + trail_next_atom; + trail_next_atom += 1; + *(uint32_t*)name = result; + + uint32_t length = caml_string_length(name); + fwrite(&length, 4, 1, trail_index); + fwrite(buffer, length, 1, trail_index); + + return result; +} + +static event_t *trail_next_event(void) +{ + if (trail_buffer_index == TRAIL_BUFFER_SIZE) + { + trail_flush(); + trail_buffer_index = 0; + } + return &trail_buffer[trail_buffer_index++]; +} + +CAMLprim value camtrail_enter(value name) +{ + if (!trail_initialized) trail_initialize(); + if (!trail_trace) return Val_unit; + + uint32_t atom = *(uint32_t*)String_val(name); + if (!atom) atom = trail_alloc_atom(name); + event_t *event = trail_next_event(); + event->atom = atom; + event->sp = (uintptr_t)(void*)&name; + event->time = trail_gettime(); + + return Val_unit; +} diff --git a/lib/dune b/lib/dune new file mode 100644 index 0000000..44cef88 --- /dev/null +++ b/lib/dune @@ -0,0 +1,6 @@ +(library + (name camtrail) + (public_name camtrail) + (wrapped false) + (modules camtrail) + (foreign_stubs (language c) (names camtrail_stubs))) diff --git a/ppx/camtrail_ppx.ml b/ppx/camtrail_ppx.ml new file mode 100644 index 0000000..3e38de0 --- /dev/null +++ b/ppx/camtrail_ppx.ml @@ -0,0 +1,101 @@ +open Migrate_parsetree + +open Ast_408 +open Parsetree + +let ocaml_version = Versions.ocaml_408 + +(* Traversal: + - when crossing a module or let-binding, + remember the name to construct a path + - when crossing a function, + remember that to log the call when we reach the body +*) + +let camtrail_prim = Longident.Ldot (Longident.Lident "Camtrail", "enter") + +let traverse_fun path mapper = + let rec aux expr = + match expr.pexp_desc with + | Pexp_fun (label, default, pattern, body) -> + let default = match default with + | None -> None + | Some expr -> Some (Ast_mapper.default_mapper.expr mapper expr) + in + let pattern = Ast_mapper.default_mapper.pat mapper pattern in + let body = aux body in + {expr with pexp_desc = Pexp_fun (label, default, pattern, body)} + | Pexp_function cases -> + let cases = List.map (fun { pc_lhs; pc_guard; pc_rhs } -> + let pc_lhs = Ast_mapper.default_mapper.pat mapper pc_lhs in + let pc_guard = match pc_guard with + | None -> None + | Some expr -> Some (Ast_mapper.default_mapper.expr mapper expr) + in + let pc_rhs = aux pc_rhs in + { pc_lhs; pc_guard; pc_rhs } + ) cases + in + {expr with pexp_desc = Pexp_function cases} + | Pexp_newtype (name, body) -> + {expr with pexp_desc = Pexp_newtype (name, aux body)} + | _ -> + let open Ast_helper in + let loc = {expr.pexp_loc with loc_ghost = true} in + let name = + let pos = loc.loc_start in + "\000\000\000\000" ^ + String.concat "." (List.rev path) ^ ":" ^ + string_of_int pos.pos_lnum ^ "." ^ + string_of_int (pos.pos_cnum - pos.pos_bol) + in + Exp.sequence ~loc:expr.pexp_loc + (Exp.apply ~loc + (Exp.ident (Location.mkloc camtrail_prim loc)) + [Asttypes.Nolabel, Exp.constant ~loc (Const.string name)]) + (Ast_mapper.default_mapper.expr mapper expr) + in + aux + +let rec mapper_for_path path = { + Ast_mapper.default_mapper with + expr = (fun self expr -> + match expr.pexp_desc with + | Pexp_fun _ | Pexp_function _ -> traverse_fun path self expr + | Pexp_letmodule (name, mexpr, body) -> + let mexpr = + let path = name.txt :: path in + let mapper = mapper_for_path path in + mapper.Ast_mapper.module_expr mapper mexpr + in + let body = Ast_mapper.default_mapper.expr self body in + {expr with pexp_desc = Pexp_letmodule (name, mexpr, body)} + | _ -> Ast_mapper.default_mapper.expr self expr + ); + module_binding = (fun _self mb -> + let mapper = mapper_for_path (mb.pmb_name.txt :: path) in + Ast_mapper.default_mapper.module_binding mapper mb + ); + value_binding = (fun self vb -> + let mapper = + match vb.pvb_pat.ppat_desc with + | Ppat_var name -> mapper_for_path (name.txt :: path) + | _ -> self + in + Ast_mapper.default_mapper.value_binding mapper vb + ); +} + +let () = + Driver.register ~name:"camtrail.ppx" ocaml_version + (fun _ _ -> {Ast_mapper.default_mapper with + structure = fun _ -> function + | [] -> [] + | (x :: _) as str -> + let name = x.pstr_loc.loc_start.pos_fname in + let name = Filename.basename name in + let name = Filename.remove_extension name in + let name = String.capitalize_ascii name in + let mapper = mapper_for_path [name] in + mapper.structure mapper str + }) diff --git a/ppx/dune b/ppx/dune new file mode 100644 index 0000000..0e02845 --- /dev/null +++ b/ppx/dune @@ -0,0 +1,5 @@ +(library + (name camtrail_ppx) + (public_name camtrail.ppx) + (libraries ocaml-migrate-parsetree) + (kind ppx_rewriter)) diff --git a/test/Makefile b/test/Makefile new file mode 100644 index 0000000..99e1279 --- /dev/null +++ b/test/Makefile @@ -0,0 +1,2 @@ +all: + dune build ./test.exe diff --git a/test/dune b/test/dune new file mode 100644 index 0000000..43b9b1b --- /dev/null +++ b/test/dune @@ -0,0 +1,5 @@ +(executable + (name test) + (modules test) + (libraries camtrail) + (preprocess (pps camtrail.ppx))) diff --git a/test/test.ml b/test/test.ml new file mode 100644 index 0000000..644ea88 --- /dev/null +++ b/test/test.ml @@ -0,0 +1,12 @@ +let rec fib n = if n <= 1 then n else fib (n - 1) + fib (n - 2) + +let a () = print_endline "a" +let b () = print_endline "b" +let c () = print_endline "c" + +let () = ( + print_int (fib 20); + a (); + b (); + c (); +)