Login

Fibonacci spinner

Help

All of this code is present at spinner and can be cloned locally with Fossil: 

$ fossil clone https://ml.minimaltype.com/
$ cd ml/spinner
$ dune build

fib.ml - an unresponsive application

let rec fib n = if n < 2 then n else fib (n - 1) + fib (n - 2)

let () =
  let n = int_of_string Sys.argv.(1) in
  Printf.printf "Fibonacci(%d) = %d\n" n (fib n)

$ time dune exec bin/fib.exe 45
Fibonacci(45) = 1134903170         

real    0m4.660s
user    0m4.621s
sys     0m0.012s

This works but isn't very satisfying because the command is unresponsive for several seconds during the calculation. Rather than dwell on the calculation, let's explore ways to improve the overall experience.

spin1.ml - fib spins if enough time has passed

let spin =
  let last = ref 0. in
  fun freq ->
    let now = Unix.gettimeofday () in
    if now -. !last > freq then begin
      Printf.printf ".%!";
      last := now
    end

let rec fib n =
  spin 0.1;
  if n < 2 then n else fib (n - 1) + fib (n - 2)

let () =
  let n = int_of_string Sys.argv.(1) in
  Printf.printf "calculating%!";
  Printf.printf "\nFibonacci(%d) = %d\n" n (fib n)

$ time dune exec bin/spin1.exe 45
calculating.....................................................................................................
................................................................................................................
................................................................................................................
................................................................................................................
................................................................................................................
................................................................................................................
................................................................................................................
................................................................................................................
.......................................................................................
Fibonacci(45) = 1134903170

real    1m37.159s
user    1m36.597s
sys     0m0.031s

This prints a dot (.) roughly every tenth of a second while the calculation's ongoing, which makes the wait not as bad! But, the wait is now also 21 times as long because these checks are so expensive. Even if the checks were free, there are many disadvantages to adding a side-effect like this to the function.

spin2.ml - ask a separate program to spin concurrently

(* spin2.ml *)
let rec fib n = if n < 2 then n else fib (n - 1) + fib (n - 2)

let () =
  let n = int_of_string Sys.argv.(2) in
  let pid =
    Unix.(
      create_process Sys.argv.(1) [|Sys.argv.(1); "0.1"|] stdin stdout stderr)
  in
  let r = fib n in
  Unix.kill pid (Sys.signal_to_int Sys.sigint);
  let _ = Unix.waitpid [] pid in
  Printf.printf "\rFibonacci(%d) = %d\n" n r

(* spin2helper.ml *)
let () =
  let freq = float_of_string Sys.argv.(1) in
  let spinner = "-\\|/" in
  let state = ref 0 in
  while true do
    Printf.printf "\r%c%!" spinner.[!state];
    state := (!state + 1) mod 4;
    Unix.sleepf freq
  done

$ time dune exec bin/spin2.exe _build/default/bin/spin2helper.exe 45
Fibonacci(45) = 1134903170         

real    0m4.766s
user    0m4.721s
sys     0m0.016s

This is a big improvement! The spinner's now animated and it doesn't significantly slow down the calculation. The separate spinner could also be reused, and pretty easily in a bash script along with timeout.

But, it's still a hassle to have a separate application.

spin3.ml - ask a clone to spin concurrently

let rec fib n = if n < 2 then n else fib (n - 1) + fib (n - 2)

let () =
  let n = int_of_string Sys.argv.(1) in
  let spinner = "-\\|/" |> String.to_seq |> Seq.cycle |> Seq.to_dispenser in
  let pid = Unix.fork () in
  if pid = 0 then
    while true do
      Printf.printf "\r%c%!" (spinner () |> Option.get);
      Unix.sleepf 0.1
    done;
  let r = fib n in
  Unix.kill pid (Sys.signal_to_int Sys.sigint);
  let _ = Unix.waitpid [] pid in
  Printf.printf "\rFibonacci(%d) = %d\n" n r

This is basically the same as the previous example, including many disadvantages like new potential modes of failure (the calculation dying while the spinner runs forever) and the extra process showing up in ps output, but now the separate process runs within that loop until it's killed.

Forking also introduces many new potential errors of its own: unwanted sharing of resources and unwanted sharing of code paths (what if the clone escapes that loop somehow?). Forking's especially risky in the context of OS threads. I once had a very unpleasant production bug in Apache in which a mistimed fork() turned a linked list into a circular list, resulting in a CPU busywait when a function walked it.

Forking also complicates use of OCaml runtime features:

spin4.ml - Concurrent ML (fail: forked runtime)

let rec fib n = if n < 2 then n else fib (n - 1) + fib (n - 2)

let () =
  let n = int_of_string Sys.argv.(1) in
  let rec spinner = '-' :: '\\' :: '|' :: '/' :: spinner in
  let chan = Event.new_channel () in
  let rec spin steps =
    match Event.poll (Event.receive chan), steps with
    | _, [] -> assert false
    | None, step :: steps ->
      Printf.printf "\r%c%!" step;
      Thread.delay 0.1;
      spin steps
    | Some _, _ -> exit 0
  in
  let pid = Unix.fork () in
  if pid = 0 then spin spinner;
  let f = fib n in

  (* foreshadowing: *)
  Printf.printf "\nstopping\n%!";

  Event.sync (Event.send chan true);
  let _ = Unix.waitpid [] pid in
  Printf.printf "\rFibonacci(%d) = %d\n" n f

$ dune exec bin/spin4.exe 45
-                                  
stopping
|^C

Here, rather than kill the spinner, the main program tries to tell the spinner to stop with a channel. But, that Event.sync never completes because nothing ever reads the channel. The spinner has its own channel that nothing ever writes to. Unix.fork duplicated too much!

Let's fork one last time:

spin5.ml - talking to the clone over a pipe

let rec fib n = if n < 2 then n else fib (n - 1) + fib (n - 2)

let () =
  let n = int_of_string Sys.argv.(1) in
  let outpipe, inpipe = Unix.pipe () in
  let pid = Unix.fork () in
  if pid = 0 then begin
    let state = ref 0 in
    while
      let r, _, _ = Unix.select [outpipe] [] [] 0.2 in
      List.is_empty r
    do
      Printf.printf "\rcalculating%s  %!" (String.sub "..." 0 !state);
      state := (!state + 1) mod 4
    done;
    exit 0
  end;
  let f = fib n in
  ignore (Unix.write_substring inpipe "done" 0 4);
  let _ = Unix.waitpid [] pid in
  Printf.printf "\rFibonacci(%d) = %d\n" n f

Here, the child waits about 0.2s for a message from the parent, spinning after not getting one. The message isn't checked, but more elaborate typed communication is possible with Marshal: 

utop # type msg = Start | Stop | Spinner of string;;
type msg = Start | Stop | Spinner of string
utop # let (m:msg) = let s = Marshal.to_string (Spinner ".oO") [] in Marshal.from_string s 0;;
val m : msg = Spinner ".oO"

But let's try Event again, with Thread:

spin6.ml - Concurrent ML (fail: no output)

let rec fib n = if n < 2 then n else fib (n - 1) + fib (n - 2)

type msg = Stop

let spinner secs =
  let chan = Event.new_channel () in
  let steps = "-\\|/" in
  let rec loop step =
    match Event.poll (Event.receive chan) with
    | Some Stop -> ()
    | None ->
      Printf.printf "\r%c%!" steps.[step];
      Thread.delay secs;
      loop ((step + 1) mod 4)
  in
  let thread = Thread.create (fun () -> loop 0) () in
  chan, thread

let () =
  let chan, thread = spinner 0.08 in
  let n = fib (int_of_string Sys.argv.(1)) in
  Event.sync (Event.send chan Stop);
  Printf.printf "\rFibonacci(%s) = %d\n" Sys.argv.(1) n;
  Thread.join thread

This behaves exactly like the original fib.ml, running silently until it prints fib's answer. When I first wrote this, I found Event and Thread's documentation from browsing the OCaml library list of modules, and the module documentation is light on description. And although my use of "Concurrent ML" might strongly imply a poor fit for the problem at hand, the module documentation uses words like "Thread" and "channel" that are commonly associated with parallel programming. The threads library section of the manual is clearer:

Only one thread at a time is allowed to run OCaml code on a particular domain

While fib runs, spinner can't. And even if you get the latter to run first, it immediately yields control.

Well, what if you get fib to yield control?

spin7.ml - Concurrent ML (fail: slow)

type msg = Stop

let spinner secs =
  let chan = Event.new_channel () in
  let steps = "-\\|/" in
  let rec loop step =
    match Event.poll (Event.receive chan) with
    | Some Stop -> ()
    | None ->
      Printf.printf "\r%c%!" steps.[step];
      Thread.delay secs;
      loop ((step + 1) mod 4)
  in
  let thread = Thread.create (fun () -> loop 0) () in
  chan, thread

let rec fib n =
  Thread.yield ();
  if n < 2 then n else fib (n - 1) + fib (n - 2)

let () =
  let chan, thread = spinner 0.08 in
  let n = fib (int_of_string Sys.argv.(1)) in
  Event.sync (Event.send chan Stop);
  Printf.printf "\rFibonacci(%s) = %d\n" Sys.argv.(1) n;
  Thread.join thread

$ time dune exec bin/spin7.exe 45
Fibonacci(45) = 1134903170         

real    0m23.437s
user    0m23.280s
sys     0m0.022s

It's not nearly as slow as the earlier modification to fib, but it's still several times slower than the original program.

The restriction is "Only one thread at a time is allowed to run OCaml code on a particular domain". What if the calculation isn't in OCaml code?

spin8.ml - Concurrent ML with C releasing the runtime

type msg = Stop

let spinner secs =
  let chan = Event.new_channel () in
  let steps = "⠋⠙⠹⠸⠼⠴⠦⠧⠇⠏" in
  let step_width = String.length "⠋" in
  let rec loop step =
    match Event.poll (Event.receive chan) with
    | Some Stop -> ()
    | None ->
      Printf.printf "\r%s%!" (String.sub steps step step_width);
      Thread.delay secs;
      loop ((step + step_width) mod String.length steps)
  in
  let thread = Thread.create (fun () -> loop 0) () in
  chan, thread

external fib : int -> int = "fib" [@@noalloc]

let () =
  let chan, thread = spinner 0.08 in
  let n = fib (int_of_string Sys.argv.(1)) in
  Event.sync (Event.send chan Stop);
  Printf.printf "\rFibonacci(%s) = %d\n" Sys.argv.(1) n;
  Thread.join thread

#include <caml/bigarray.h>
#include <caml/memory.h>
#include <caml/mlvalues.h>
#include <caml/threads.h>
#include <stdio.h>

long fib_c(long n) {
  if (n < 2)
    return n;
  return fib_c(n - 1) + fib_c(n - 2);
}

CAMLprim value fib(value vn) {
  CAMLparam1(vn);
  long n = Long_val(vn);
  caml_release_runtime_system();
  n = fib_c(n);
  caml_acquire_runtime_system();
  CAMLreturn(Val_long(n));
}

$ time dune exec bin/spin8.exe 45
Fibonacci(45) = 1134903170         

real    0m1.490s
user    0m1.399s
sys     0m0.016s

Here, the spinning is done in OCaml looks pretty nice, and the calculation is all in C with the runtime released to let OCaml spin. This is also the fastest solution provided!

But, it's been clear for a while that these Concurrent ML modules aren't suited for work like this. OCaml 5.x has domains.

spin9.ml - Domain(slib) of spin6.ml

let rec fib n = if n < 2 then n else fib (n - 1) + fib (n - 2)

module Chan = Domainslib.Chan

type msg = Stop

let spinner secs =
  let chan = Chan.make_bounded 1 in
  let steps = "-\\|/" in
  let rec loop step =
    match Chan.recv_poll chan with
    | Some Stop -> ()
    | None ->
      Printf.printf "\r%c%!" steps.[step];
      Unix.sleepf secs;
      loop ((step + 1) mod 4)
  in
  let thread = Domain.spawn (fun () -> loop 0) in
  chan, thread

let () =
  let chan, thread = spinner 0.08 in
  let n = fib (int_of_string Sys.argv.(1)) in
  Chan.send chan Stop;
  Printf.printf "\rFibonacci(%s) = %d\n" Sys.argv.(1) n;
  Domain.join thread

This is exactly the Concurrent ML spin6.ml attempt, but with Domain instead of Thread and Domainslib.Chan instead of Event.

Unix.sleepf is actually how Thread.delay is implemented. A feature I keep missing in these concurrency libraries, that I expected from Erlang, is a timeout when waiting on a channel. It seems that sleeps like this are a bit of a problem, so let's try an alternative with Unix itimers:

spin10.ml - Domainslib.Task with interval timer

let rec fib n = if n < 2 then n else fib (n - 1) + fib (n - 2)

module Task = Domainslib.Task

let start = Unix.gettimeofday ()
let spin _ = Printf.printf "\rfibbing: %.1f s%!" (Unix.gettimeofday () -. start)

let () =
  let n = int_of_string Sys.argv.(1) in
  let pool = Task.setup_pool ~num_domains:2 () in
  Sys.(set_signal sigalrm (Signal_handle spin));
  let _ = Unix.(setitimer ITIMER_REAL {it_interval = 0.1; it_value = 0.1}) in
  let r =
    Task.(run pool (fun () -> async pool (fun () -> fib n) |> await pool))
  in
  Sys.(set_signal sigalrm Signal_ignore);
  Task.teardown_pool pool;
  Printf.printf "\rFibonacci(%d) = %d\n" n r

This works, but signal handlers are a bit of a pain, requiring this Domainslib.Task pool to free the runtime to handle the signals.

Let's try some higher-level libraries.

spin11.ml - Moonpool.Background_thread

let rec fib n = if n < 2 then n else fib (n - 1) + fib (n - 2)

module Cycle = struct
  type 'a t = ( :: ) : 'a * 'a t -> 'a t
end

let rec steps = Cycle.('-' :: '\\' :: '|' :: '/' :: steps)

let rec spinner fut Cycle.(step :: steps) =
  Printf.printf "\r%c%!" step;
  match Moonpool.Fut.peek fut with
  | Some r -> r
  | None ->
    Thread.delay 0.1;
    spinner fut steps

let () =
  let n = int_of_string Sys.argv.(1) in
  let pool = Moonpool.Background_thread.create () in
  [%defer Moonpool.Background_thread.shutdown pool];
  match spinner (Moonpool.Fut.spawn ~on:pool (fun () -> fib n)) steps with
  | Error bt ->
    Format.printf "\rFibonacci(%d) = FAILED: %a\n" n Moonpool.Exn_bt.pp bt
  | Ok r -> Printf.printf "\rFibonacci(%d) = %d\n" n r

I really like this version with Moonpool, but it's still an awkward fit with the Fut.peek loop.

spin12.ml - Eio.Fiber.first

let rec fib n = if n < 2 then n else fib (n - 1) + fib (n - 2)

let spin clock =
  "-\\|/"
  |> String.to_seq
  |> Seq.cycle
  |> Seq.iter (fun c ->
      Printf.printf "\r%c%!" c;
      Eio.Time.sleep clock 0.1);
  assert false

let () =
  let n = int_of_string Sys.argv.(1) in
  let r =
    Eio_main.run (fun env ->
        let clock = Eio.Stdenv.clock env in
        let mgr = Eio.Stdenv.domain_mgr env in
        Eio.Fiber.first
          (fun () -> Eio.Domain_manager.run mgr (fun () -> spin clock))
          (fun () -> fib n))
  in
  Printf.printf "\rFibonacci(%d) = %d\n" n r

eio has, in Eio.Fiber.first, a feature that nearly exactly fits the task: it returns the value of whichever of the two functions returns first, which is always fib n since the spinner doesn't terminate, and then it stops the incomplete functions.

spin ends in that assert false to prevent it from typing incompatibly as unit.