Merge pull request ocaml#255 from ocaml-flambda/revert_memprof_tracker

Revert Gc interface changes for memprof tracker

otherlibs/memtrace/memprof_tracer.ml

@@ -32,8 +32,7 @@ let default_report_exn e =
 
 let start ?(report_exn=default_report_exn) ~sampling_rate trace =
   let s = { trace; locked = false; stopped = false; failed = false; report_exn } in
-  let tracker : (_,_) Gc.Memprof.tracker = {
-    alloc_minor = (fun info ->
+  let minor_alloc_callback = (fun (info : Gc.Memprof.allocation) ->
       if lock_tracer s then begin
         match Trace.Writer.put_alloc_with_raw_backtrace trace (Trace.Timestamp.now ())
                 ~length:info.size
@@ -43,8 +42,9 @@ let start ?(report_exn=default_report_exn) ~sampling_rate trace =
         with
         | r -> unlock_tracer s; Some r
         | exception e -> mark_failed s e; None
-      end else None);
-    alloc_major = (fun info ->
+      end else None)
+  in
+  let major_alloc_callback = (fun (info : Gc.Memprof.allocation) ->
       if lock_tracer s then begin
         match Trace.Writer.put_alloc_with_raw_backtrace trace (Trace.Timestamp.now ())
                 ~length:info.size
@@ -54,27 +54,36 @@ let start ?(report_exn=default_report_exn) ~sampling_rate trace =
         with
         | r -> unlock_tracer s; Some r
         | exception e -> mark_failed s e; None
-      end else None);
-    promote = (fun id ->
+      end else None)
+  in
+  let promote_callback = (fun id ->
       if lock_tracer s then
         match Trace.Writer.put_promote trace (Trace.Timestamp.now ()) id with
         | () -> unlock_tracer s; Some id
         | exception e -> mark_failed s e; None
-      else None);
-    dealloc_minor = (fun id ->
+      else None)
+  in
+  let minor_dealloc_callback = (fun id ->
       if lock_tracer s then
         match Trace.Writer.put_collect trace (Trace.Timestamp.now ()) id with
         | () -> unlock_tracer s
-        | exception e -> mark_failed s e);
-    dealloc_major = (fun id ->
+        | exception e -> mark_failed s e)
+  in
+  let major_dealloc_callback = (fun id ->
       if lock_tracer s then
         match Trace.Writer.put_collect trace (Trace.Timestamp.now ()) id with
         | () -> unlock_tracer s
-        | exception e -> mark_failed s e) } in
+        | exception e -> mark_failed s e)
+  in
   Gc.Memprof.start
     ~sampling_rate
     ~callstack_size:max_int
-    tracker;
+    ~minor_alloc_callback
+    ~major_alloc_callback
+    ~promote_callback
+    ~minor_dealloc_callback
+    ~major_dealloc_callback
+    ();
   s
 
 let stop s =

otherlibs/memtrace/vendor

@@ -1,2 +1,7 @@
 This a vendored version of the `src` dir of:
 git@github.com:janestreet/memtrace.git#6c7ed830b3535bcd77be698a5d556fe4a54974ba
+
+Additional patches:
+- Use the 5 arguments interface of Gc.Memprof.start instead of the record one,
+  + see 2805c598a94b3081f887eaf6403b8de4582cb653 for the commit that changed the contents of this directory
+  + see ff6b20098f7f51758d78546af4bb8747cdc8c9f4 for the commit introducing the record representation

runtime/memprof.c

@@ -867,19 +867,17 @@ void caml_memprof_shutdown(void) {
   callstack_buffer_len = 0;
 }
 
-CAMLprim value caml_memprof_start(value lv, value szv, value tracker)
+CAMLprim value caml_memprof_start(value lv, value szv,
+                                  value cb_alloc_minor, value cb_alloc_major,
+                                  value cb_promote,
+                                  value cb_dealloc_minor,
+                                  value cb_dealloc_major)
 {
-  CAMLparam3(lv, szv, tracker);
-
+  CAMLparam5(lv, szv, cb_alloc_minor, cb_alloc_major, cb_promote);
+  CAMLxparam2(cb_dealloc_minor, cb_dealloc_major);
   double l = Double_val(lv);
   intnat sz = Long_val(szv);
 
-  value cb_alloc_minor = Field(tracker, 0);
-  value cb_alloc_major = Field(tracker, 1);
-  value cb_promote = Field(tracker, 2);
-  value cb_dealloc_minor = Field(tracker, 3);
-  value cb_dealloc_major = Field(tracker, 4);
-
   if (started) caml_failwith("Gc.Memprof.start: already started.");
 
   if (sz < 0 || !(l >= 0.) || l > 1.) /* Checks that [l] is not NAN. */
@@ -914,10 +912,11 @@ CAMLprim value caml_memprof_start(value lv, value szv, value tracker)
   CAMLreturn(Val_unit);
 }
 
-/* not used anymore, the prototype is only kept until the next bootstrap */
 CAMLprim value caml_memprof_start_byt(value* argv, int argn)
 {
-  return(Val_unit);
+  CAMLassert(argn == 7);
+  return caml_memprof_start(argv[0], argv[1], argv[2], argv[3],
+                            argv[4], argv[5], argv[6]);
 }
 
 CAMLprim value caml_memprof_stop(value unit)

stdlib/gc.ml

@@ -127,31 +127,27 @@ module Memprof =
         unmarshalled : bool;
         callstack : Printexc.raw_backtrace }
 
-    type ('minor, 'major) tracker = {
-      alloc_minor: allocation -> 'minor option;
-      alloc_major: allocation -> 'major option;
-      promote: 'minor -> 'major option;
-      dealloc_minor: 'minor -> unit;
-      dealloc_major: 'major -> unit;
-    }
-
-    let null_tracker = {
-      alloc_minor = (fun _ -> None);
-      alloc_major = (fun _ -> None);
-      promote = (fun _ -> None);
-      dealloc_minor = (fun _ -> ());
-      dealloc_major = (fun _ -> ());
-    }
-
     external c_start :
-      float -> int -> ('minor, 'major) tracker -> unit
-      = "caml_memprof_start"
+      float -> int ->
+      (allocation -> 'minor option) ->
+      (allocation -> 'major option) ->
+      ('minor -> 'major option) ->
+      ('minor -> unit) ->
+      ('major -> unit) ->
+      unit
+      = "caml_memprof_start_byt" "caml_memprof_start"
 
     let start
       ~sampling_rate
       ?(callstack_size = max_int)
-      tracker =
-      c_start sampling_rate callstack_size tracker
+      ?(minor_alloc_callback = fun _ -> None)
+      ?(major_alloc_callback = fun _ -> None)
+      ?(promote_callback = fun _ -> None)
+      ?(minor_dealloc_callback = fun _ -> ())
+      ?(major_dealloc_callback = fun _ -> ()) () =
+      c_start sampling_rate callstack_size minor_alloc_callback
+              major_alloc_callback promote_callback minor_dealloc_callback
+              major_dealloc_callback
 
     external stop : unit -> unit = "caml_memprof_stop"
   end

stdlib/gc.mli

@@ -458,32 +458,15 @@ module Memprof :
        type of records passed to the callback triggered by the
        sampling of an allocation. *)
 
-    type ('minor, 'major) tracker = {
-      alloc_minor: allocation -> 'minor option;
-      alloc_major: allocation -> 'major option;
-      promote: 'minor -> 'major option;
-      dealloc_minor: 'minor -> unit;
-      dealloc_major: 'major -> unit;
-    }
-    (**
-       A [('minor, 'major) tracker] describes how memprof should track
-       sampled blocks over their lifetime, keeping a user-defined piece
-       of metadata for each of them: ['minor] is the type of metadata
-       to keep for minor blocks, and ['major] the type of metadata
-       for major blocks.
-
-       If an allocation-tracking or promotion-tracking function returns [None],
-       memprof stops tracking the corresponding value.
-     *)
-
-    val null_tracker: ('minor, 'major) tracker
-    (** Default callbacks simply return [None] or [()] *)
-
     val start :
       sampling_rate:float ->
       ?callstack_size:int ->
-      ('minor, 'major) tracker ->
-      unit
+      ?minor_alloc_callback:(allocation -> 'minor option) ->
+      ?major_alloc_callback:(allocation -> 'major option) ->
+      ?promote_callback:('minor -> 'major option) ->
+      ?minor_dealloc_callback:('minor -> unit) ->
+      ?major_dealloc_callback:('major -> unit) ->
+      unit -> unit
     (** Start the sampling with the given parameters. Fails if
        sampling is already active.
 
@@ -495,10 +478,14 @@ module Memprof :
        The parameter [callstack_size] is the length of the callstack
        recorded at every sample. Its default is [max_int].
 
-       The parameter [tracker] determines how to track sampled blocks
-       over their lifetime in the minor and major heap.
+       The parameters *[_callback] are functions called when an event
+       occurs on a sampled block. If such a callback returns [None],
+       then the tracking of this particular block is cancelled. If
+       they return [Some v], then the value [v] will be passed to the
+       next callback for this block. Default callbacks simply return
+       [None] or [()].
 
-       Sampling is temporarily disabled when calling a callback
+       The sampling is temporarily disabled when calling a callback
        for the current thread. So they do not need to be reentrant if
        the program is single-threaded. However, if threads are used,
        it is possible that a context switch occurs during a callback,

testsuite/tests/statmemprof/arrays_in_major.ml

@@ -17,12 +17,12 @@ let[@inline never] allocate_arrays lo hi cnt keep =
 
 let check_nosample () =
   Printf.printf "check_nosample\n%!";
-  let alloc _ =
+  let cb _ =
     Printf.printf "Callback called with sampling_rate = 0\n";
     assert(false)
   in
-  start ~callstack_size:10 ~sampling_rate:0.
-    { null_tracker with alloc_minor = alloc; alloc_major = alloc; };
+  start ~callstack_size:10 ~minor_alloc_callback:cb ~major_alloc_callback:cb
+        ~sampling_rate:0. ();
   allocate_arrays 300 3000 1 false;
   stop ()
 
@@ -36,26 +36,25 @@ let check_counts_full_major force_promote =
   let npromote = ref 0 in
   let ndealloc_minor = ref 0 in
   let ndealloc_major = ref 0 in
-  start ~callstack_size:10 ~sampling_rate:0.01
-    {
-      alloc_minor = (fun _ ->
-        if not !enable then None
-        else Some (incr nalloc_minor)
-      );
-      alloc_major = (fun _ ->
-        if not !enable then None
-        else Some (incr nalloc_major)
-      );
-      promote = (fun _ ->
-        Some (incr npromote)
-      );
-      dealloc_minor = (fun _ ->
-        incr ndealloc_minor
-      );
-      dealloc_major = (fun _ ->
-        incr ndealloc_major
-      );
-    };
+  start ~callstack_size:10
+        ~minor_alloc_callback:(fun _ ->
+          if !enable then begin
+              incr nalloc_minor;
+              Some ()
+          end else
+            None)
+        ~major_alloc_callback:(fun _ ->
+           if !enable then begin
+             incr nalloc_major;
+             Some ()
+           end else
+             None)
+        ~promote_callback:(fun _ ->
+           incr npromote;
+           Some ())
+        ~minor_dealloc_callback:(fun _ -> incr ndealloc_minor)
+        ~major_dealloc_callback:(fun _ -> incr ndealloc_major)
+        ~sampling_rate:0.01 ();
   allocate_arrays 300 3000 1 true;
   enable := false;
   assert (!ndealloc_minor = 0 && !ndealloc_major = 0);
@@ -92,14 +91,11 @@ let check_no_nested () =
     ()
   in
   let cb' _ = cb (); Some () in
-  start ~callstack_size:10 ~sampling_rate:1.
-    {
-      alloc_minor = cb';
-      alloc_major = cb';
-      promote = cb';
-      dealloc_minor = cb;
-      dealloc_major = cb;
-    };
+  start ~callstack_size:10
+        ~minor_alloc_callback:cb' ~major_alloc_callback:cb'
+        ~promote_callback:cb' ~minor_dealloc_callback:cb
+        ~major_dealloc_callback:cb
+        ~sampling_rate:1. ();
   allocate_arrays 300 300 100 false;
   stop ()
 
@@ -108,16 +104,15 @@ let () = check_no_nested ()
 let check_distrib lo hi cnt rate =
   Printf.printf "check_distrib %d %d %d %f\n%!" lo hi cnt rate;
   let smp = ref 0 in
-  start ~callstack_size:10 ~sampling_rate:rate
-    { null_tracker with
-      alloc_major = (fun info ->
-        assert (info.size >= lo && info.size <= hi);
-        assert (info.n_samples > 0);
-        assert (not info.unmarshalled);
-        smp := !smp + info.n_samples;
-        None
-      );
-    };
+  start ~callstack_size:10
+        ~major_alloc_callback:(fun info ->
+           assert (info.size >= lo && info.size <= hi);
+           assert (info.n_samples > 0);
+           assert (not info.unmarshalled);
+           smp := !smp + info.n_samples;
+           None
+        )
+        ~sampling_rate:rate ();
   allocate_arrays lo hi cnt false;
   stop ();