Browse Source

Import

master
Frédéric Bour 2 years ago
commit
992c63f7ca
  1. 0
      camtrail.opam
  2. 97
      decoder/decoder.ml
  3. 2
      decoder/dune
  4. 13
      dune-project
  5. 6
      lib/_build/log
  6. 1
      lib/camtrail.ml
  7. 96
      lib/camtrail_stubs.c
  8. 6
      lib/dune
  9. 101
      ppx/camtrail_ppx.ml
  10. 5
      ppx/dune
  11. 2
      test/Makefile
  12. 5
      test/dune
  13. 12
      test/test.ml

0
camtrail.opam

97
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

2
decoder/dune

@ -0,0 +1,2 @@
(executable
(name decoder))

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

6
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

1
lib/camtrail.ml

@ -0,0 +1 @@
external enter : string -> unit = "camtrail_enter" [@@ocaml.noalloc]

96
lib/camtrail_stubs.c

@ -0,0 +1,96 @@
#include <time.h>
#include <stdlib.h>
#include <stdio.h>
#include <string.h>
#include <caml/mlvalues.h>
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;
}

6
lib/dune

@ -0,0 +1,6 @@
(library
(name camtrail)
(public_name camtrail)
(wrapped false)
(modules camtrail)
(foreign_stubs (language c) (names camtrail_stubs)))

101
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
})

5
ppx/dune

@ -0,0 +1,5 @@
(library
(name camtrail_ppx)
(public_name camtrail.ppx)
(libraries ocaml-migrate-parsetree)
(kind ppx_rewriter))

2
test/Makefile

@ -0,0 +1,2 @@
all:
dune build ./test.exe

5
test/dune

@ -0,0 +1,5 @@
(executable
(name test)
(modules test)
(libraries camtrail)
(preprocess (pps camtrail.ppx)))

12
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 ();
)
Loading…
Cancel
Save