A Monad for concurrency

This code is an attempt to port the Haskell code in A poor man’s concurrency monad to OCaml.

The main idea here, is about using a monadic interface to compose (CPS’d) functions. The resulting program can be run concurrently by interleaving and evaluating, on-demand, its constituents.

module Conc = 
struct
  type action = Atom of zaction
                | Fork of (zaction * zaction)
                | Stop
  and zaction  = action lazy_t
 
  (* CPS monad *)
  (* type 'a t = ('a -> action) -> action *)
  let bind f k = fun c -> f (fun a -> k a c)
  let return x = fun c -> c x  
 
  let atom f = fun c -> Atom (lazy (let b = f () in c b))
  let action f = f (fun () -> Stop)
  let fork f = fun c -> Fork (lazy (action f), lazy (c ()))
  let par m1 m2 = fun c -> Fork (lazy (m1 c), lazy (m2 c)) 
  let stop = fun c -> Stop
  let rec round = function
    | [] -> ()
    | (x::xs) -> match x with
        | Atom th -> let y = Lazy.force th in round (xs @ [y])
        | Fork (a1, a2) -> round (xs @ [Lazy.force a1; Lazy.force a2])
        | Stop -> round xs
 
  let run m = round [action m]
end
 
open Conc
 
(* given f and a number n, returns f composed with itself
   n times *)
let rec loop f = function
  | 0 -> stop
  | n -> bind f (fun () -> loop f (n-1))
 
(* example 1, prints "start", then prints the words "cat" 
   and "fish", interleaved, 10 times*)
let write1 s = atom (fun _ -> print_string s)
let example1 : ((unit -> action) -> action) = 
  bind (write1 "start>>>") 
    (fun _ -> bind (fork (loop (write1 "cat") 10)) 
       (fun _ -> (loop (write1 "fish") 10)))
 
 
let explode s =
  let rec exp i l =
    if i < 0 then l else exp (i - 1) (s.[i] :: l) in
  exp (String.length s - 1) []
 
(* write2: string -> ('a -> action) -> action
   prints each character one after the other *)
let write2 s = 
  let rec write2_aux = function
    | []    -> atom (fun _ -> ())
    | c::cs -> bind (atom (fun _ -> print_char c)) 
                    (fun _ -> write2_aux cs)
  in write2_aux (explode s)
 
(* write2: given a string, returns a CPSed function
   which prints each character one after the other *)
let example2 : ((unit -> action) -> action) = 
  bind (write2 "start>>>") 
    (fun _ -> bind (fork (loop (write2 "cat") 10)) 
       (fun _ -> (loop (write2 "fish") 10)))
 
let _ = 
  run example1; 
  print_newline ();
  run example2

Les commentaires sont fermés.