Import

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

decoder/dune

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

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

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

lib/camtrail.ml

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

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

lib/dune

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

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

ppx/dune

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

test/Makefile

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

test/dune

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

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 ();
+)