unikernel/duniverse/base/test/allocation/base_test_allocation.ml

@@ -0,0 +1 @@
+(*_ This library deliberately does not export anything. *)

unikernel/duniverse/base/test/allocation/bin/dune

@@ -0,0 +1,8 @@
+(executables
+ (modes byte exe)
+ (names test_option_array_allocation)
+ (libraries base expect_test_helpers_core compiler-libs.common
+   core_kernel.version_util)
+ (ocamlopt_flags :standard -O3)
+ (preprocess
+  (pps ppx_jane)))

unikernel/duniverse/base/test/allocation/bin/test_option_array_allocation.ml

@@ -0,0 +1,58 @@
+open! Base
+open Option_array
+open Expect_test_helpers_core
+
+let () =
+  let t = of_array [| None |] in
+  assert (
+    require_no_allocation [%here] (fun () ->
+      match get t 0 with
+      | None -> true
+      | Some _ -> false))
+;;
+
+let () =
+  let t = of_array [| Some 0 |] in
+  let get_some () =
+    match get t 0 with
+    | None -> false
+    | Some _ -> true
+  in
+  (* After inlining, [match get t 0 with] is:
+
+     {[
+       match
+         let cheap_option = Uniform_array.get t 0 in
+         if Cheap_option.is_some cheap_option
+         then Some (Cheap_option.value_unsafe cheap_option)
+         else None
+       with
+     ]}
+
+     This situation is called "match-in-match" (the inner [if] is essentially a match).
+     The OCaml compiler and Flambda optimizer don't handle match-in-match well, and so
+     cannot eliminate the allocation of [Some].  Flambda2 is expected to eliminate the
+     allocation, at which point we can [require_no_allocation] (possibly annotating the
+     test with [@tags "fast-flambda"]).
+
+     Note that Flambda 2 only eliminates the allocation in optimized mode.
+     In classic mode, it will remain.  This file is compiled with optimized mode.
+  *)
+  let compiler_eliminates_the_allocation =
+    (* [Version_util.x_library_inlining] is the whole reason this is a separate
+       executable. *)
+    Config.flambda2 && Version_util.x_library_inlining
+  in
+  if compiler_eliminates_the_allocation
+  then assert (require_no_allocation [%here] get_some)
+  else
+    let module Gc = Core.Gc.For_testing in
+    let _, { Gc.Allocation_report.minor_words_allocated; _ } =
+      Gc.measure_allocation get_some
+    in
+    if minor_words_allocated <= 2
+    then ()
+    else
+      failwith
+        (Printf.sprintf "Allocated more words than expected: %d" minor_words_allocated)
+;;

unikernel/duniverse/base/test/allocation/bin/test_option_array_allocation.mli

@@ -0,0 +1 @@
+(*_ This signature is deliberately empty. *)

unikernel/duniverse/base/test/allocation/dune

@@ -0,0 +1,5 @@
+(library
+ (name base_test_allocation)
+ (libraries async base expect_test_helpers_async expect_test_helpers_core)
+ (preprocess
+  (pps ppx_jane)))

unikernel/duniverse/base/test/allocation/test_array_allocation.ml

@@ -0,0 +1,32 @@
+open! Base
+open Expect_test_helpers_core
+
+let%expect_test "Array.sort [||] only allocates when computing bounds" =
+  require_allocation_does_not_exceed (Minor_words 3) [%here] (fun () ->
+    Array.sort ~compare:Int.compare [||]);
+  [%expect {| |}]
+;;
+
+let%expect_test "Array.sort [| 5; 2; 3; 4; 1 |] only allocates when computing bounds" =
+  let arr = [| 5; 2; 3; 4; 1 |] in
+  require_allocation_does_not_exceed (Minor_words 3) [%here] (fun () ->
+    Array.sort ~compare:Int.compare arr);
+  [%expect {| |}]
+;;
+
+let%expect_test "equal does not allocate" =
+  let arr1 = [| 1; 2; 3; 4 |] in
+  let arr2 = [| 1; 2; 4; 3 |] in
+  require
+    [%here]
+    (require_no_allocation [%here] (fun () -> not (Array.equal Int.equal arr1 arr2)));
+  [%expect {| |}]
+;;
+
+let%expect_test "foldi does not allocate" =
+  let arr = [| 1; 2; 3; 4 |] in
+  let f i x y = i + x + y in
+  require
+    [%here]
+    (require_no_allocation [%here] (fun () -> 16 = Array.foldi ~init:0 ~f arr))
+;;

unikernel/duniverse/base/test/allocation/test_array_allocation.mli

@@ -0,0 +1 @@
+(*_ This signature is deliberately empty. *)

unikernel/duniverse/base/test/allocation/test_char_allocation.ml

@@ -0,0 +1,10 @@
+open! Base
+open Expect_test_helpers_core
+
+let%expect_test _ =
+  let x = Sys.opaque_identity 'a' in
+  let y = Sys.opaque_identity 'b' in
+  require_no_allocation [%here] (fun () ->
+    ignore (Sys.opaque_identity (Char.Caseless.equal x y) : bool));
+  [%expect {| |}]
+;;

unikernel/duniverse/base/test/allocation/test_char_allocation.mli

@@ -0,0 +1 @@
+(*_ This signature is deliberately empty. *)

unikernel/duniverse/base/test/allocation/test_float_allocation.ml

@@ -0,0 +1,10 @@
+open! Base
+open Stdio
+open Float
+
+let%expect_test "iround_nearest_exn noalloc" =
+  let t = Sys.opaque_identity 205.414 in
+  Expect_test_helpers_core.require_no_allocation [%here] (fun () -> iround_nearest_exn t)
+  |> printf "%d\n";
+  [%expect {| 205 |}]
+;;

unikernel/duniverse/base/test/allocation/test_float_allocation.mli

@@ -0,0 +1 @@
+(*_ This signature is deliberately empty. *)

unikernel/duniverse/base/test/allocation/test_hashtbl_allocation.ml

@@ -0,0 +1,90 @@
+open! Base
+open Expect_test_helpers_core
+
+let () = Int_conversions.sexp_of_int_style := `Underscores
+
+let%expect_test "find_and_call_1_and_2" =
+  let test x =
+    let t = Hashtbl.create (module Int) ~size:16 ~growth_allowed:false in
+    for i = 0 to x - 1 do
+      Hashtbl.add_exn t ~key:i ~data:(i * 7)
+    done;
+    let if_found a b = assert (a = b) in
+    let if_not_found a b =
+      assert (a = x);
+      assert (b = x * 7)
+    in
+    require_no_allocation [%here] (fun () ->
+      for i = 0 to x do
+        Hashtbl.find_and_call1 t i ~a:(i * 7) ~if_found ~if_not_found
+      done);
+    let if_found ~key ~data:a b =
+      assert (a = b);
+      assert (key = a / 7)
+    in
+    let if_not_found a b =
+      assert (a = x);
+      assert (b = x * 7)
+    in
+    require_no_allocation [%here] (fun () ->
+      for i = 0 to x do
+        Hashtbl.findi_and_call1 t i ~a:(i * 7) ~if_found ~if_not_found
+      done);
+    let if_found a b c =
+      assert (a = b);
+      assert (b = c / 2)
+    in
+    let if_not_found a b c =
+      assert (a = x);
+      assert (b = x * 7);
+      assert (c = x * 14)
+    in
+    require_no_allocation [%here] (fun () ->
+      for i = 0 to x do
+        Hashtbl.find_and_call2 t i ~a:(i * 7) ~b:(i * 14) ~if_found ~if_not_found
+      done);
+    let if_found ~key ~data:a b c =
+      assert (a = b);
+      assert (b = c / 2);
+      assert (key = a / 7)
+    in
+    let if_not_found a b c =
+      assert (a = x);
+      assert (b = x * 7);
+      assert (c = x * 14)
+    in
+    require_no_allocation [%here] (fun () ->
+      for i = 0 to x do
+        Hashtbl.findi_and_call2 t i ~a:(i * 7) ~b:(i * 14) ~if_found ~if_not_found
+      done);
+    print_s (Int.sexp_of_t x)
+  in
+  (* try various load factors, to exercise all branches of matching on the structure of
+     the avl tree *)
+  test 1;
+  test 3;
+  test 10;
+  test 17;
+  test 25;
+  test 29;
+  test 33;
+  test 3133;
+  [%expect {|
+    1
+    3
+    10
+    17
+    25
+    29
+    33
+    3_133
+    |}]
+;;
+
+let%expect_test ("find_or_add shouldn't allocate" [@tags "no-js"]) =
+  let default = Fn.const () in
+  let t = Hashtbl.create (module Int) ~size:16 ~growth_allowed:false in
+  Hashtbl.add_exn t ~key:100 ~data:();
+  require_no_allocation [%here] (fun () -> Hashtbl.find_or_add t 100 ~default);
+  [%expect {| |}]
+;;

unikernel/duniverse/base/test/allocation/test_hashtbl_allocation.mli

@@ -0,0 +1 @@
+(*_ This signature is deliberately empty. *)

unikernel/duniverse/base/test/allocation/test_list_allocation.ml

@@ -0,0 +1,22 @@
+open! Base
+open Expect_test_helpers_core
+
+let%expect_test "is_prefix does not allocate" =
+  let list = Sys.opaque_identity [ 1; 2; 3 ] in
+  let prefix = Sys.opaque_identity [ 1; 2 ] in
+  let equal = Int.equal in
+  let (_ : bool) =
+    require_no_allocation [%here] (fun () -> List.is_prefix list ~equal ~prefix)
+  in
+  [%expect {| |}]
+;;
+
+let%expect_test "is_suffix does not allocate" =
+  let list = Sys.opaque_identity [ 1; 2; 3 ] in
+  let suffix = Sys.opaque_identity [ 2; 3 ] in
+  let equal = Int.equal in
+  let (_ : bool) =
+    require_no_allocation [%here] (fun () -> List.is_suffix list ~equal ~suffix)
+  in
+  [%expect {| |}]
+;;

unikernel/duniverse/base/test/allocation/test_list_allocation.mli

@@ -0,0 +1 @@
+(*_ This signature is deliberately empty. *)

unikernel/duniverse/base/test/allocation/test_option_array_allocation.ml

@@ -0,0 +1,11 @@
+open! Async
+open Expect_test_helpers_async
+
+let%expect_test _ =
+  (* Sadly, the test is sensitive to cross-library inlining, which we can only detect
+     using the build info in version_util, which isn't available while compiling a test.
+     So we delegate the whole test to this executable: *)
+  let%bind () = run "bin/test_option_array_allocation.exe" [] in
+  [%expect {| |}];
+  return ()
+;;

unikernel/duniverse/base/test/allocation/test_option_array_allocation.mli

@@ -0,0 +1 @@
+(*_ This signature is deliberately empty. *)

unikernel/duniverse/base/test/allocation/test_string_allocation.ml

@@ -0,0 +1,182 @@
+open! Base
+open Expect_test_helpers_core
+
+let%expect_test _ =
+  let x = Sys.opaque_identity "one string" in
+  let y = Sys.opaque_identity "another" in
+  require_no_allocation [%here] (fun () ->
+    ignore (Sys.opaque_identity (String.Caseless.equal x y) : bool));
+  [%expect {| |}]
+;;
+
+let%expect_test "empty substring" =
+  let string = String.init 10 ~f:Char.of_int_exn in
+  let test here f =
+    let substring = require_no_allocation here f in
+    assert (String.is_empty substring)
+  in
+  test [%here] (fun () -> String.sub string ~pos:0 ~len:0);
+  test [%here] (fun () -> String.prefix string 0);
+  test [%here] (fun () -> String.suffix string 0);
+  test [%here] (fun () -> String.drop_prefix string 10);
+  test [%here] (fun () -> String.drop_suffix string 10);
+  [%expect {| |}]
+;;
+
+let%expect_test "mem does not allocate" =
+  let string = Sys.opaque_identity "abracadabra" in
+  let char = Sys.opaque_identity 'd' in
+  require_no_allocation [%here] (fun () -> ignore (String.mem string char : bool));
+  [%expect {| |}]
+;;
+
+let%expect_test "fold does not allocate" =
+  let string = Sys.opaque_identity "abracadabra" in
+  let char = Sys.opaque_identity 'd' in
+  let f acc c = if Char.equal c char then true else acc in
+  require_no_allocation [%here] (fun () ->
+    ignore (String.fold string ~init:false ~f : bool));
+  [%expect {| |}]
+;;
+
+let%expect_test "foldi does not allocate" =
+  let string = Sys.opaque_identity "abracadabra" in
+  let char = Sys.opaque_identity 'd' in
+  let f _i acc c = if Char.equal c char then true else acc in
+  require_no_allocation [%here] (fun () ->
+    ignore (String.foldi string ~init:false ~f : bool));
+  [%expect {| |}]
+;;
+
+let%test_module "common prefix and suffix" =
+  (module struct
+    let require_int_equal a b ~message = require_equal [%here] (module Int) a b ~message
+
+    let require_string_equal a b ~message =
+      require_equal [%here] (module String) a b ~message
+    ;;
+
+    let simulate_common_length ~get_common2_length list =
+      let rec loop acc prev list ~get_common2_length =
+        match list with
+        | [] -> acc
+        | head :: tail ->
+          loop (Int.min acc (get_common2_length prev head)) head tail ~get_common2_length
+      in
+      match list with
+      | [] -> 0
+      | [ head ] -> String.length head
+      | head :: tail -> loop Int.max_value head tail ~get_common2_length
+    ;;
+
+    let get_shortest_and_longest list =
+      let compare_by_length a b = Comparable.lift Int.compare ~f:String.length a b in
+      Option.both
+        (List.min_elt list ~compare:compare_by_length)
+        (List.max_elt list ~compare:compare_by_length)
+    ;;
+
+    let test_generic get_common get_common2 get_common_length get_common2_length =
+      Staged.stage (fun list ->
+        let common = get_common list in
+        print_s [%sexp (common : string)];
+        let len = get_common_length list in
+        require_int_equal len (String.length common) ~message:"wrong length";
+        let common2 = List.reduce list ~f:get_common2 |> Option.value ~default:"" in
+        require_string_equal common common2 ~message:"pairwise result mismatch";
+        let len2 = simulate_common_length ~get_common2_length list in
+        require_int_equal len len2 ~message:"pairwise length mismatch";
+        if not (String.is_empty common || List.mem list common ~equal:String.equal)
+        then print_endline "(may allocate)"
+        else (
+          ignore (require_no_allocation [%here] (fun () -> get_common list) : string);
+          Option.iter (get_shortest_and_longest list) ~f:(fun (shortest, longest) ->
+            ignore
+              (require_no_allocation [%here] (fun () -> get_common2 shortest longest)
+                : string);
+            ignore
+              (require_no_allocation [%here] (fun () -> get_common2 longest shortest)
+                : string))))
+    ;;
+
+    let test_prefix =
+      test_generic
+        String.common_prefix
+        String.common_prefix2
+        String.common_prefix_length
+        String.common_prefix2_length
+      |> Staged.unstage
+    ;;
+
+    let test_suffix =
+      test_generic
+        String.common_suffix
+        String.common_suffix2
+        String.common_suffix_length
+        String.common_suffix2_length
+      |> Staged.unstage
+    ;;
+
+    let%expect_test "empty" =
+      test_prefix [];
+      [%expect {| "" |}];
+      test_suffix [];
+      [%expect {| "" |}]
+    ;;
+
+    let%expect_test "singleton" =
+      test_prefix [ "abut" ];
+      [%expect {| abut |}];
+      test_suffix [ "tuba" ];
+      [%expect {| tuba |}]
+    ;;
+
+    let%expect_test "doubleton, alloc" =
+      test_prefix [ "hello"; "help"; "hex" ];
+      [%expect {|
+        he
+        (may allocate)
+        |}];
+      test_suffix [ "crest"; "zest"; "1st" ];
+      [%expect {|
+        st
+        (may allocate)
+        |}]
+    ;;
+
+    let%expect_test "doubleton, no alloc" =
+      test_prefix [ "hello"; "help"; "he" ];
+      [%expect {| he |}];
+      test_suffix [ "crest"; "zest"; "st" ];
+      [%expect {| st |}]
+    ;;
+
+    let%expect_test "many, alloc" =
+      test_prefix [ "this"; "that"; "the other"; "these"; "those"; "thy"; "thou" ];
+      [%expect {|
+        th
+        (may allocate)
+        |}];
+      test_suffix [ "fourth"; "fifth"; "sixth"; "seventh"; "eleventh"; "twelfth" ];
+      [%expect {|
+        th
+        (may allocate)
+        |}]
+    ;;
+
+    let%expect_test "many, no alloc" =
+      test_prefix [ "inconsequential"; "invariant"; "in"; "inner"; "increment" ];
+      [%expect {| in |}];
+      test_suffix [ "fat"; "cat"; "sat"; "at"; "bat" ];
+      [%expect {| at |}]
+    ;;
+
+    let%expect_test "many, nothing in common" =
+      let lorem_ipsum = [ "lorem"; "ipsum"; "dolor"; "sit"; "amet" ] in
+      test_prefix lorem_ipsum;
+      [%expect {| "" |}];
+      test_suffix lorem_ipsum;
+      [%expect {| "" |}]
+    ;;
+  end)
+;;

unikernel/duniverse/base/test/allocation/test_string_allocation.mli

@@ -0,0 +1 @@
+(*_ This signature is deliberately empty. *)

unikernel/duniverse/base/test/allocation/test_type_equal_allocation.ml

@@ -0,0 +1,9 @@
+open! Base
+open Expect_test_helpers_core
+
+let t1 = Type_equal.Id.create ~name:"t1" [%sexp_of: _]
+
+let%expect_test "Type_equal.Id.to_sexp allocation" =
+  require_no_allocation [%here] (fun () ->
+    ignore (Type_equal.Id.to_sexp t1 : 'a -> Sexp.t))
+;;

unikernel/duniverse/base/test/allocation/test_type_equal_allocation.mli

@@ -0,0 +1 @@
+(*_ This signature is deliberately empty. *)

unikernel/duniverse/base/test/allocation/test_zero_alloc.ml

@@ -0,0 +1,20 @@
+let[@zero_alloc] [@inline never] foo x = Base.Printf.failwithf "%d" x ()
+let[@zero_alloc] [@inline never] bar x y = Base.Printf.invalid_argf "%d" (x + y) ()
+
+let%expect_test "foo" =
+  let x = Sys.opaque_identity 5 in
+  (try foo x with
+   | Failure s ->
+     print_string s;
+     print_newline ());
+  [%expect {| 5 |}]
+;;
+
+let%expect_test "bar" =
+  let x = Sys.opaque_identity 5 in
+  (try bar x x with
+   | Invalid_argument s ->
+     print_string s;
+     print_newline ());
+  [%expect {| 10 |}]
+;;

unikernel/duniverse/base/test/allocation/test_zero_alloc.mli

@@ -0,0 +1 @@
+(*_ This signature is deliberately empty. *)