unikernel/duniverse/ocaml-caqti/benchmarks/benchmark_all.ml

@@ -0,0 +1,30 @@
+(* Copyright (C) 2024  Petter A. Urkedal <paurkedal@gmail.com>
+ *
+ * This library is free software; you can redistribute it and/or modify it
+ * under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or (at your
+ * option) any later version, with the LGPL-3.0 Linking Exception.
+ *
+ * This library is distributed in the hope that it will be useful, but WITHOUT
+ * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ * FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
+ * License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * and the LGPL-3.0 Linking Exception along with this library.  If not, see
+ * <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
+ *)
+
+open Common
+
+module Make (Platform : PLATFORM) = struct
+  module Fetch_many = Benchmark_fetch_many.Make (Platform)
+
+  let cmds = [
+    Fetch_many.main_cmd;
+  ]
+
+  let () =
+    let open Cmdliner in
+    exit Cmd.(eval @@ group (info (Filename.basename Sys.argv.(0))) cmds)
+end

unikernel/duniverse/ocaml-caqti/benchmarks/benchmark_fetch_many.ml

@@ -0,0 +1,104 @@
+(* Copyright (C) 2022--2025  Petter A. Urkedal <paurkedal@gmail.com>
+ *
+ * This library is free software; you can redistribute it and/or modify it
+ * under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or (at your
+ * option) any later version, with the LGPL-3.0 Linking Exception.
+ *
+ * This library is distributed in the hope that it will be useful, but WITHOUT
+ * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ * FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
+ * License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * and the LGPL-3.0 Linking Exception along with this library.  If not, see
+ * <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
+ *)
+
+
+open Bechamel
+open Bechamel.Toolkit
+open Common
+
+let connect_uri = Uri.of_string "postgresql://"
+
+let fetch_many_request =
+  let open Caqti_template.Create in
+  static T.(unit -->* t3 int int (t3 float bool bool)) {|
+    WITH tmp (i) AS (VALUES (0), (1), (2), (3), (4), (5), (6), (7), (8), (9))
+    SELECT a.i, b.i, CAST(c.i AS float), e.i < c.i, e.i < d.i
+    FROM tmp a, tmp b, tmp c, tmp d, tmp e
+  |}
+
+module Make (Platform : PLATFORM) = struct
+  open Platform
+  open Platform.Fiber.Infix
+
+  let test' _ = Staged.stage @@ fun (module C : CONNECTION) ->
+    run_fiber begin fun () ->
+      let aux (_, _, (_, _, _)) = succ in
+      C.fold fetch_many_request aux () 0 >>= or_fail >|= fun count ->
+      assert (count = 100_000)
+    end
+
+  let test stdenv connect_config uris =
+    let allocate i =
+      run_fiber (fun () ->
+        connect stdenv ~config:connect_config (List.nth uris i) >>= or_fail)
+    in
+    let free (module C : CONNECTION) =
+      run_fiber (fun () -> C.disconnect ())
+    in
+    Test.(make_indexed_with_resource uniq)
+      ~name ~args:(List.mapi (fun i _ -> i) uris) ~allocate ~free test'
+
+  (* Benchmark Function *)
+
+  let benchmark context connect_config uris =
+    let ols =
+      Analyze.ols ~bootstrap:0 ~r_square:true ~predictors:Measure.[|run|]
+    in
+    let instances =
+      Instance.[minor_allocated; major_allocated; monotonic_clock]
+    in
+    let cfg =
+      (* TODO: Why does this segfault with ~kde:(Some 1000)? *)
+      Benchmark.cfg ~limit:2000 ~quota:(Time.second 1.0) ()
+    in
+    let raw_results =
+      Benchmark.all cfg instances (test context connect_config uris)
+    in
+    let results =
+      List.map (fun instance -> Analyze.all ols instance raw_results) instances
+    in
+    let results = Analyze.merge ols instances results in
+    (results, raw_results)
+
+  (* TTY Boilerplate *)
+
+  let () =
+    List.iter
+      (fun v -> Bechamel_notty.Unit.add v (Measure.unit v))
+      Instance.[minor_allocated; major_allocated; monotonic_clock]
+
+  let img (window, results) =
+    Bechamel_notty.Multiple.image_of_ols_results ~rect:window
+      ~predictor:Measure.run results
+
+  open Notty_unix
+
+  let main {Testlib.uris; connect_config} =
+    run_main @@ fun context ->
+    let window =
+      match winsize Unix.stdout with
+      | Some (w, h) -> {Bechamel_notty.w; h}
+      | None -> {Bechamel_notty.w = 80; h = 1}
+    in
+    let results, _ = benchmark context connect_config uris in
+    img (window, results) |> eol |> output_image
+
+  let main_cmd =
+    let open Cmdliner in
+    let term = Term.(const main $ Testlib.common_args ()) in
+    Cmd.v (Cmd.info "fetch-many") term
+end

unikernel/duniverse/ocaml-caqti/benchmarks/benchmark_stream.ml

@@ -0,0 +1,92 @@
+(* Copyright (C) 2019--2025  Petter A. Urkedal <paurkedal@gmail.com>
+ *
+ * This library is free software; you can redistribute it and/or modify it
+ * under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or (at your
+ * option) any later version, with the LGPL-3.0 Linking Exception.
+ *
+ * This library is distributed in the hope that it will be useful, but WITHOUT
+ * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ * FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
+ * License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * and the LGPL-3.0 Linking Exception along with this library.  If not, see
+ * <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
+ *)
+
+open Lwt.Infix
+open Lwt.Syntax
+
+let data = List.init 100_000 begin fun i ->
+  let x = float_of_int (i + 1) in
+  1.0 /. (x *. x)
+end
+
+module Stream_blocking = Caqti_platform.Stream.Make (struct
+  type 'a t = 'a
+  let return x = x
+  module Infix = struct
+    let (>>=) x f = f x
+    let (>|=) x f = f x
+  end
+end)
+
+module Stream_lwt = Caqti_platform.Stream.Make (Lwt)
+
+let rec seq_of_list xs () =
+  (match xs with
+   | [] -> Seq.Nil
+   | x :: xs' -> Seq.Cons (x, seq_of_list xs'))
+
+let test_list () =
+  let _ : float = List.fold_left (+.) 0.0 data in
+  ()
+
+let test_seq =
+  let seq = seq_of_list data in
+  fun () ->
+    let _ : float = Seq.fold_left (+.) 0.0 seq in
+    ()
+
+let test_stream_blocking =
+  let stream = Stream_blocking.of_list data in
+  fun () ->
+    let (_ : float) =
+      (Stream_blocking.fold ~f:(+.) stream 0.0 |> function
+       | Ok x -> x
+       | Error (`Congested (c : Caqti_error.counit)) -> (match c with _ -> .))
+      [@ocaml.warning "-56"] (* coded for backwards compatibility *)
+    in
+    ()
+
+let test_stream_lwt =
+  let stream = Stream_lwt.of_list data in
+  fun () -> Lwt_main.run begin
+    let* (_ : float) =
+      (Stream_lwt.fold ~f:(+.) stream 0.0 >|= function
+       | Ok x -> x
+       | Error (`Congested (c : Caqti_error.counit)) -> (match c with _ -> .))
+      [@ocaml.warning "-56"] (* coded for backwards compatibility *)
+    in
+    Lwt.return_unit
+  end
+
+(*
+let test_lwt_stream =
+  let stream = Lwt_stream.of_list data in (* OBS: Not re-iterable. *)
+  fun () -> Lwt_main.run begin
+    let* (_ : float) = Lwt_stream.fold (+.) stream 0.0 in
+    Lwt.return_unit
+  end
+*)
+
+let () =
+  let res = Benchmark.throughputN 30 [
+    "List", test_list, ();
+    "Seq", test_seq, ();
+    "Stream_blocking", test_stream_blocking, ();
+    "Stream_lwt", test_stream_lwt, ();
+  ] in
+  print_newline ();
+  Benchmark.tabulate res

unikernel/duniverse/ocaml-caqti/benchmarks/common.ml

@@ -0,0 +1,43 @@
+(* Copyright (C) 2024  Petter A. Urkedal <paurkedal@gmail.com>
+ *
+ * This library is free software; you can redistribute it and/or modify it
+ * under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or (at your
+ * option) any later version, with the LGPL-3.0 Linking Exception.
+ *
+ * This library is distributed in the hope that it will be useful, but WITHOUT
+ * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ * FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
+ * License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * and the LGPL-3.0 Linking Exception along with this library.  If not, see
+ * <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
+ *)
+
+module type PLATFORM = sig
+  type context
+  module Fiber : sig
+    type +'a t
+    module Infix : sig
+      val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+      val (>|=) : 'a t -> ('a -> 'b) -> 'b t
+    end
+  end
+  val name : string
+  val run_fiber : (unit -> 'a Fiber.t) -> 'a
+  val run_main : (context -> 'a) -> 'a
+  val or_fail : ('a, [< Caqti_error.t]) result -> 'a Fiber.t
+
+  module Stream : Caqti_stream_sig.S with type 'a fiber := 'a Fiber.t
+
+  module type CONNECTION = Caqti_connection_sig.S
+    with type 'a fiber := 'a Fiber.t
+     and type ('a, 'err) stream := ('a, 'err) Stream.t
+
+  type connection = (module CONNECTION)
+
+  val connect :
+    ?config: Caqti_connect_config.t -> context -> Uri.t ->
+    (connection, [> Caqti_error.load_or_connect]) result Fiber.t
+end

unikernel/duniverse/ocaml-caqti/benchmarks/dune

@@ -0,0 +1,69 @@
+; Singular benchmark
+
+(executable
+ (name benchmark_stream)
+ (modules benchmark_stream)
+ (libraries benchmark caqti caqti.platform lwt lwt.unix))
+
+; Main benchmark suite with executables for concurrency flavours
+
+(library
+ (name benchmark_all)
+ (flags (:standard -alert -caqti_unstable))
+ (modules
+    common
+    benchmark_fetch_many
+    benchmark_all)
+ (libraries
+    bechamel
+    bechamel-notty
+    caqti
+    caqti.plugin
+    notty.unix
+    testlib))
+
+(executable
+ (name main_blocking)
+ (modules main_blocking)
+ (libraries
+    benchmark_all
+    caqti.blocking
+    unix))
+
+(executable
+ (name main_eio_unix)
+ (modules main_eio_unix)
+ (enabled_if (>= %{ocaml_version} "5.0"))
+ (libraries
+    benchmark_all
+    caqti-eio.unix
+    caqti-tls-eio
+    eio
+    eio_main
+    mirage-crypto-rng.unix))
+
+(executable
+ (name main_lwt_unix)
+ (modules main_lwt_unix)
+ (libraries
+    benchmark_all
+    caqti-lwt
+    caqti-lwt.unix
+    caqti-tls-lwt.unix
+    lwt
+    lwt.unix))
+
+(executable
+ (name main_miou_unix)
+ (modules main_miou_unix)
+ (libraries
+    benchmark_all
+    caqti-miou
+    caqti_miou_unix
+    caqti-tls-miou
+    miou
+    miou.unix
+    mirage-crypto-rng-miou-unix
+    threads))
+
+; TODO: Can we run async under a benchamel test?

unikernel/duniverse/ocaml-caqti/benchmarks/main_blocking.ml

@@ -0,0 +1,32 @@
+(* Copyright (C) 2022--2024  Petter A. Urkedal <paurkedal@gmail.com>
+ *
+ * This library is free software; you can redistribute it and/or modify it
+ * under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or (at your
+ * option) any later version, with the LGPL-3.0 Linking Exception.
+ *
+ * This library is distributed in the hope that it will be useful, but WITHOUT
+ * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ * FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
+ * License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * and the LGPL-3.0 Linking Exception along with this library.  If not, see
+ * <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
+ *)
+
+include Benchmark_all.Make (struct
+  let name = "blocking"
+  module Fiber = struct
+    type 'a t = 'a
+    module Infix = struct
+      let (>>=) x f = f x
+      let (>|=) x f = f x
+    end
+  end
+  type context = unit
+  let run_fiber f = f ()
+  let run_main f = f ()
+  include Caqti_blocking
+  let connect ?config () uri = connect ?config uri
+end)

unikernel/duniverse/ocaml-caqti/benchmarks/main_eio_unix.ml

@@ -0,0 +1,45 @@
+(* Copyright (C) 2022--2025  Petter A. Urkedal <paurkedal@gmail.com>
+ *
+ * This library is free software; you can redistribute it and/or modify it
+ * under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or (at your
+ * option) any later version, with the LGPL-3.0 Linking Exception.
+ *
+ * This library is distributed in the hope that it will be useful, but WITHOUT
+ * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ * FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
+ * License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * and the LGPL-3.0 Linking Exception along with this library.  If not, see
+ * <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
+ *)
+
+open Eio.Std
+
+include Benchmark_all.Make (struct
+  let name = "eio-unix"
+
+  module Fiber = struct
+    type 'a t = 'a
+    module Infix = struct
+      let (>>=) x f = f x
+      let (>|=) x f = f x
+    end
+  end
+
+  type context = Caqti_eio.stdenv * Switch.t
+
+  let run_fiber f = f ()
+
+  let run_main f =
+    Mirage_crypto_rng_unix.use_default ();
+    Eio_main.run @@ fun stdenv ->
+    Switch.run @@ fun sw ->
+    f ((stdenv :> Caqti_eio.stdenv), sw)
+
+  include Caqti_eio
+  include Caqti_eio_unix
+
+  let connect ?config (stdenv, sw) uri = connect ?config ~sw ~stdenv uri
+end)

unikernel/duniverse/ocaml-caqti/benchmarks/main_lwt_unix.ml

@@ -0,0 +1,27 @@
+(* Copyright (C) 2022--2024  Petter A. Urkedal <paurkedal@gmail.com>
+ *
+ * This library is free software; you can redistribute it and/or modify it
+ * under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or (at your
+ * option) any later version, with the LGPL-3.0 Linking Exception.
+ *
+ * This library is distributed in the hope that it will be useful, but WITHOUT
+ * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ * FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
+ * License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * and the LGPL-3.0 Linking Exception along with this library.  If not, see
+ * <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
+ *)
+
+include Benchmark_all.Make (struct
+  let name = "lwt-unix"
+  module Fiber = Lwt
+  type context = unit
+  let run_fiber f = Lwt_main.run (f ())
+  let run_main f = f ()
+  include Caqti_lwt
+  include Caqti_lwt_unix
+  let connect ?config () uri = connect ?config uri
+end)

unikernel/duniverse/ocaml-caqti/benchmarks/main_miou_unix.ml

@@ -0,0 +1,44 @@
+(* Copyright (C) 2022--2024  Petter A. Urkedal <paurkedal@gmail.com>
+ *
+ * This library is free software; you can redistribute it and/or modify it
+ * under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or (at your
+ * option) any later version, with the LGPL-3.0 Linking Exception.
+ *
+ * This library is distributed in the hope that it will be useful, but WITHOUT
+ * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ * FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
+ * License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * and the LGPL-3.0 Linking Exception along with this library.  If not, see
+ * <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
+ *)
+
+include Benchmark_all.Make (struct
+  let name = "miou-unix"
+
+  module Fiber = struct
+    type 'a t = 'a
+    module Infix = struct
+      let (>>=) x f = f x
+      let (>|=) x f = f x
+    end
+  end
+
+  type context = Caqti_miou.switch
+
+  let run_fiber f = f ()
+
+  let run_main f =
+    Miou_unix.run @@ fun () ->
+    Caqti_miou.Switch.run @@ fun sw ->
+    let rng = Mirage_crypto_rng_miou_unix.(initialize (module Pfortuna)) in
+    let finally () = Mirage_crypto_rng_miou_unix.kill rng in
+    Fun.protect ~finally (fun () -> f sw)
+
+  include Caqti_miou
+  include Caqti_miou_unix
+
+  let connect ?config sw uri = connect ?config ~sw uri
+end)