Revert ocaml#9103 (removal of Memprof)

Revert "Remove Memprof from the standard library in the 4.10 branch, as this will not be ready for 4.10."

This reverts commit 9e22930.

stdlib/gc.ml

@@ -118,3 +118,34 @@ let create_alarm f =
 
 
 let delete_alarm a = a := false
+
+module Memprof =
+  struct
+    type alloc_kind =
+      | Minor
+      | Major
+      | Unmarshalled
+
+    type sample_info = {
+        n_samples: int; kind: alloc_kind; tag: int;
+        size: int; callstack: Printexc.raw_backtrace;
+    }
+
+    type 'a callback = sample_info -> (Obj.t, 'a) Ephemeron.K1.t option
+
+    type 'a ctrl = {
+        sampling_rate : float;
+        callstack_size : int;
+        callback : 'a callback
+    }
+
+    let stopped_ctrl = {
+        sampling_rate = 0.; callstack_size = 0;
+        callback = fun _ -> assert false
+    }
+
+    external set_ctrl : 'a ctrl -> unit = "caml_memprof_set"
+
+    let start = set_ctrl
+    let stop () = set_ctrl stopped_ctrl
+  end

stdlib/gc.mli

@@ -421,3 +421,83 @@ val create_alarm : (unit -> unit) -> alarm
 val delete_alarm : alarm -> unit
 (** [delete_alarm a] will stop the calls to the function associated
    to [a].  Calling [delete_alarm a] again has no effect. *)
+
+(** [Memprof] is a sampling engine for allocated memory words. Every
+   allocated word has a probability of being sampled equal to a
+   configurable sampling rate. Since blocks are composed of several
+   words, a block can potentially be sampled several times. When a
+   block is sampled (i.e., it contains at least one sample word), a
+   user-defined callback is called.
+
+   This engine makes it possible to implement a low-overhead memory
+   profiler as an OCaml library. *)
+module Memprof :
+  sig
+    type alloc_kind =
+      | Minor
+      | Major
+      | Unmarshalled
+    (** Allocation kinds
+        - [Minor] : the allocation took place in the minor heap.
+        - [Major] : the allocation took place in the major heap.
+        - [Unmarshalled] : the allocation happened while unmarshalling. *)
+
+    type sample_info = {
+        n_samples: int;
+        (** The number of samples in this block. Always >= 1, it is
+           sampled according to a binomial distribution whose
+           parameters are the size of the block (including the header)
+           and the sampling rate. Hence, it is in average equal to the
+           size of the block multiplied by the sampling rate. *)
+        kind: alloc_kind;
+        (** The kind of the allocation. *)
+        tag: int;
+        (** The tag of the allocated block. *)
+        size: int;
+        (** The size of the allocated block, in words (excluding the
+            header). *)
+        callstack: Printexc.raw_backtrace;
+        (** The callstack for the allocation. *)
+    }
+    (** The meta data passed at each callback.  *)
+
+    type 'a callback = sample_info -> (Obj.t, 'a) Ephemeron.K1.t option
+    (** [callback] is the type of callbacks launched by the sampling
+       engine. A callback returns an option over an ephemeron whose
+       key is set to the allocated block for further tracking. After
+       the callback returns, the key of the ephemeron should not be
+       read, since this would change its reachability properties.
+
+       The sampling is temporarily disabled when calling the callback
+       for the current thread. So it does 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, in
+       which case reentrancy has to be taken into account.
+
+       Note that the callback can be postponed slightly after the
+       actual allocation. Therefore, the context of the callback may
+       be slightly different than expected.
+
+       In addition, note that calling [start] or [stop] in a callback
+       can lead to losses of samples. *)
+
+    type 'a ctrl = {
+        sampling_rate : float;
+        (** The sampling rate in samples per word (including headers).
+           Usually, with cheap callbacks, a rate of 0.001 has no
+           visible effect on performance, and 0.01 causes the program
+           to run a few percent slower. *)
+        callstack_size : int;
+        (** The length of the callstack recorded at every sample. *)
+        callback : 'a callback
+        (** The callback to be called at every sample. *)
+    }
+    (** Control data for the sampling engine.  *)
+
+    val start : 'a ctrl -> unit
+    (** Start the sampling with the given parameters. If another
+        sampling is already running, it is stopped. *)
+
+    val stop : unit -> unit
+    (** Stop the sampling. *)
+end

testsuite/tests/statmemprof/arrays_in_major.ml

@@ -0,0 +1,140 @@
+(* TEST
+   flags = "-g"
+   compare_programs = "false"
+*)
+
+open Gc.Memprof
+
+let root = ref []
+let[@inline never] allocate_arrays lo hi cnt keep =
+  assert (lo >= 300);  (* Will be allocated in major heap. *)
+  for j = 0 to cnt-1 do
+    for i = lo to hi do
+      root := Array.make i 0 :: !root
+    done;
+    if not keep then root := []
+  done
+
+let check_nosample () =
+  Printf.printf "check_nosample\n%!";
+  start {
+      sampling_rate = 0.;
+      callstack_size = 10;
+      callback = fun _ ->
+        Printf.printf "Callback called with sampling_rate = 0\n";
+        assert(false)
+  };
+  allocate_arrays 300 3000 1 false
+
+let () = check_nosample ()
+
+let check_ephe_full_major () =
+  Printf.printf "check_ephe_full_major\n%!";
+  let ephes = ref [] in
+  start {
+    sampling_rate = 0.01;
+    callstack_size = 10;
+    callback = fun _ ->
+      let res = Ephemeron.K1.create () in
+      ephes := res :: !ephes;
+      Some res
+  };
+  allocate_arrays 300 3000 1 true;
+  stop ();
+  List.iter (fun e -> assert (Ephemeron.K1.check_key e)) !ephes;
+  Gc.full_major ();
+  List.iter (fun e -> assert (Ephemeron.K1.check_key e)) !ephes;
+  root := [];
+  Gc.full_major ();
+  List.iter (fun e -> assert (not (Ephemeron.K1.check_key e))) !ephes
+
+let () = check_ephe_full_major ()
+
+let check_no_nested () =
+  Printf.printf "check_no_nested\n%!";
+  let in_callback = ref false in
+  start {
+      (* FIXME: we should use 1. to make sure the block is sampled,
+       but the runtime does an infinite loop in native mode in this
+       case. This bug will go away when the sampling of natively
+       allocated will be correctly implemented. *)
+      sampling_rate = 0.5;
+      callstack_size = 10;
+      callback = fun _ ->
+        assert (not !in_callback);
+        in_callback := true;
+        allocate_arrays 300 300 100 false;
+        in_callback := false;
+        None
+  };
+  allocate_arrays 300 300 100 false;
+  stop ()
+
+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 {
+      sampling_rate = rate;
+      callstack_size = 10;
+      callback = fun info ->
+        (* We also allocate the list constructor in the minor heap. *)
+        if info.kind = Major then begin
+          assert (info.tag = 0);
+          assert (info.size >= lo && info.size <= hi);
+          assert (info.n_samples > 0);
+          smp := !smp + info.n_samples
+        end;
+        None
+    };
+  allocate_arrays lo hi cnt false;
+  stop ();
+
+  (* The probability distribution of the number of samples follows a
+     binomial distribution of parameters tot_alloc and rate. Given
+     that tot_alloc*rate and tot_alloc*(1-rate) are large (i.e., >
+     100), this distribution is approximately equal to a normal
+     distribution. We compute a 1e-8 confidence interval for !smp
+     using quantiles of the normal distribution, and check that we are
+     in this confidence interval. *)
+  let tot_alloc = cnt*(lo+hi+2)*(hi-lo+1)/2 in
+  assert (float tot_alloc *. rate > 100. &&
+          float tot_alloc *. (1. -. rate) > 100.);
+  let mean = float tot_alloc *. rate in
+  let stddev = sqrt (float tot_alloc *. rate *. (1. -. rate)) in
+  (* This assertion has probability to fail close to 1e-8. *)
+  assert (abs_float (mean -. float !smp) <= stddev *. 5.7)
+
+let () =
+  check_distrib 300 3000 3 0.00001;
+  check_distrib 300 3000 1 0.0001;
+  check_distrib 300 3000 1 0.01;
+  check_distrib 300 3000 1 0.9;
+  check_distrib 300 300 100000 0.1;
+  check_distrib 300000 300000 30 0.1
+
+let[@inline never] check_callstack () =
+  Printf.printf "check_callstack\n%!";
+  let callstack = ref None in
+  start {
+      (* FIXME: we should use 1. to make sure the block is sampled,
+       but the runtime does an infinite loop in native mode in this
+       case. This bug will go away when the sampling of natively
+       allocated will be correctly implemented. *)
+      sampling_rate = 0.5;
+      callstack_size = 10;
+      callback = fun info ->
+        if info.kind = Major then callstack := Some info.callstack;
+        None
+    };
+  allocate_arrays 300 300 100 false;
+  stop ();
+  match !callstack with
+  | None -> assert false
+  | Some cs -> Printexc.print_raw_backtrace stdout cs
+
+let () = check_callstack ()
+
+let () =
+  Printf.printf "OK !\n"

testsuite/tests/statmemprof/arrays_in_major.reference

@@ -0,0 +1,14 @@
+check_nosample
+check_ephe_full_major
+check_no_nested
+check_distrib 300 3000 3 0.000010
+check_distrib 300 3000 1 0.000100
+check_distrib 300 3000 1 0.010000
+check_distrib 300 3000 1 0.900000
+check_distrib 300 300 100000 0.100000
+check_distrib 300000 300000 30 0.100000
+check_callstack
+Raised by primitive operation at file "arrays_in_major.ml", line 13, characters 14-28
+Called from file "arrays_in_major.ml", line 131, characters 2-35
+Called from file "arrays_in_major.ml", line 137, characters 9-27
+OK !