small benchmark (requires: gen, sequence, benchmark)

bench.ml

module G = struct
  type 'a t = unit -> 'a option

  let (--) i j =
    let r = ref i in
    fun () ->
      if !r > j then None
      else (let x = !r in incr r; Some x)

  let map f g =
    fun () -> match g() with
      | None -> None
      | Some x -> Some (f x)

  let rec filter f g () = match g() with
    | None -> None
    | Some x when f x -> Some x
    | Some _ -> filter f g ()

  type 'a state =
    | Start
    | Cur of 'a
    | Stop

  let flat_map f g =
    let state = ref Start in
    let rec aux () = match !state with
      | Start -> next_gen(); aux ()
      | Stop -> None
      | Cur g' ->
        match g'() with
          | None -> next_gen(); aux ()
          | Some _ as res -> res
    and next_gen() = match g() with
      | None -> state := Stop
      | Some x -> state := Cur (f x)
      | exception e -> state := Stop; raise e
    in
    aux

  let rec fold f acc g = match g () with
    | None -> acc
    | Some x -> fold f (f acc x) g
end

let f_gen () =
  let open Gen in
  1 -- 100_000
  |> map (fun x -> x+1)
  |> filter (fun x -> x mod 2 = 0)
  |> flat_map (fun x -> x -- (x+30))
  |> fold (+) 0

let f_gen_noptim () =
  let open Gen in
  1 -- 100_000
  |> Sys.opaque_identity map (fun x -> x+1)
  |> Sys.opaque_identity filter (fun x -> x mod 2 = 0)
  |> Sys.opaque_identity flat_map (fun x -> x -- (x+30))
  |> Sys.opaque_identity fold (+) 0

let f_g () =
  let open G in
  1 -- 100_000
  |> map (fun x -> x+1)
  |> filter (fun x -> x mod 2 = 0)
  |> flat_map (fun x -> x -- (x+30))
  |> fold (+) 0

let f_seq () =
  let open Sequence in
  1 -- 100_000
  |> map (fun x -> x+1)
  |> filter (fun x -> x mod 2 = 0)
  |> flat_map (fun x -> x -- (x+30))
  |> fold (+) 0

let () =
  assert (f_gen_noptim () = f_gen());
  assert (f_g () = f_gen());
  assert (f_seq () = f_gen());
  ()

let () =
  let res =
    (Sys.opaque_identity Benchmark.throughputN) ~repeat:2 3
    [ "gen", Sys.opaque_identity f_gen, ()
    ; "gen_no_optim", Sys.opaque_identity f_gen_noptim, ()
    ; "g", Sys.opaque_identity f_g, ()
    ; "sequence", Sys.opaque_identity f_seq, ()
    ]
  in
  Benchmark.tabulate res
  
  (* ocamlfind opt -O3 -package gen -package sequence -package benchmark -linkpkg -unbox-closures -inline-call-cost 200 bench.ml -o bench *)
  
  (*
  Throughputs for "gen", "gen_no_optim", "g", "sequence" each running 2 times for at least 3 CPU seconds:
         gen:  3.14 WALL ( 3.13 usr +  0.00 sys =  3.13 CPU) @ 126.84/s (n=397)
               3.14 WALL ( 3.13 usr +  0.00 sys =  3.13 CPU) @ 126.84/s (n=397)
gen_no_optim:  3.17 WALL ( 3.16 usr +  0.00 sys =  3.16 CPU) @ 85.67/s (n=271)
               3.17 WALL ( 3.16 usr +  0.00 sys =  3.16 CPU) @ 85.67/s (n=271)
           g:  3.18 WALL ( 3.18 usr +  0.00 sys =  3.18 CPU) @ 140.57/s (n=447)
               3.18 WALL ( 3.17 usr +  0.01 sys =  3.18 CPU) @ 140.71/s (n=447)
    sequence:  3.19 WALL ( 3.18 usr +  0.01 sys =  3.18 CPU) @ 784.08/s (n=2496)
               3.19 WALL ( 3.18 usr +  0.00 sys =  3.19 CPU) @ 783.26/s (n=2496)
               Rate      gen_no_optim          gen            g     sequence
gen_no_optim 85.7+-0.0/s           --         -32%         -39%         -89%
         gen  127+-  0/s          48%           --         -10%         -84%
           g  141+-  0/s          64%          11%           --         -82%
    sequence  784+-  0/s         815%         518%         457%           --
*)