path: root/src/kahn_th.ml

module Th: S = struct
	type 'a process = (unit -> 'a)

	type 'a channel = { q: 'a Queue.t ; m: Mutex.t; }
	type 'a in_port = 'a channel
	type 'a out_port = 'a channel

	let new_channel () =
		let q = { q = Queue.create (); m = Mutex.create (); } in
		q, q

	let io_read () = ""
	let io_write s = print_string s; flush stdout

	let put v c () =
		Mutex.lock c.m;
		Queue.push v c.q;
		Mutex.unlock c.m;
		Thread.yield ()

	let rec get c () =
		try
			Mutex.lock c.m;
			let v = Queue.pop c.q in
			Mutex.unlock c.m;
			v
		with Queue.Empty ->
			Mutex.unlock c.m;
			Thread.yield ();
			get c ()

	let doco l () =
		let ths = List.map (fun f -> Thread.create f ()) l in
		List.iter (fun th -> Thread.join th) ths

	let return v = (fun () -> v)

	let bind e e' () =
		let v = e () in
		Thread.yield ();
		e' v ()

	let run e = e ()
end