Parallel processing in F# - concurrency

I'm playing around with async in F#. Does this look right, or am I mangling things?
let time f =
let before = System.DateTime.Now
f () |> ignore
let after = System.DateTime.Now
after - before;;
let rec fib = function 0 | 1 -> 1
| n -> fib (n - 1) + fib (n - 2);;
let source = [45; 40; 45; 40]
let synchronous = time <| fun () -> List.map fib source
let para = time <| fun () -> source
|> List.map (fun n -> async {ignore <| fib n})
|> Async.Parallel
|> Async.RunSynchronously
In particular, how do I return results from an async block? Do I have to use mutable state?
Update: here's another approach:
#r "FSharp.PowerPack.Parallel.Seq.dll"
open Microsoft.FSharp.Collections
let pseq = time <| fun () -> source
|> PSeq.map fib
|> PSeq.toList

Firstly, it's a bit of an anti-pattern to use async for parallel CPU processing. See these questions and answers for more information:
Why shouldn't I use F# asynchronous workflows for parallelism?
Task Parallel Library vs Async Workflows
Secondly, your fib function should be re-written to be tail recursive, here's an example from here (including changing to BigInt):
let fib n =
let rec loop acc1 acc2 = function
| n when n = 0I -> acc1
| n -> loop acc2 (acc1 + acc2) (n - 1I)
loop 0I 1I n
Finally, the full code:
let source = [| 45I; 40I; 45I; 40I |]
let sync = time <| fun () -> Array.map fib source
let para = time <| fun () -> Array.Parallel.map fib source
Note that in both cases an Array of the results is returned, you're just throwing it away in your time function. How about a time function that returns both the time and the result?
let time f =
let watch = new System.Diagnostics.Stopwatch()
watch.Start()
let res = f ()
watch.Stop()
(res, watch.ElapsedMilliseconds)
Usage remains the same, but now showing results:
printfn "Sync: %A in %ims" (fst sync) (snd sync)
printfn "Para: %A in %ims" (fst para) (snd para)

Related

Why this program dosen't halt when only need to iterating throught a finite stream?

I'm trying to get a list of primes of two digits by running these codes in LearnOcaml. The codes compile if I restrict the parameter of the listify method, which returns a list from a stream, to be less than 20. Otherwise, it either never halt or return "Exception: Js_of_ocaml__Js.Error _.". I don't think the code is semantically wrong. So I'm
wondering if anyone can help resolve the problem?
type 'a stream = Eos | StrCons of 'a*(unit -> 'a stream)
(*integers from n onwards*)
let rec nums_from n =
StrCons(n,fun () -> nums_from (n+1))
let rec filterStr (test : 'a -> bool) (s: 'a stream) =
match s with
|Eos -> Eos
|StrCons(q,w) -> if test q then StrCons(q,fun ()-> filterStr test (w ()))
else filterStr test (w ())
(*Remove all numbers mod p*)
let sift p =
filterStr (fun x -> x mod p <> 0)
(*Sieves*)
let rec sieves s =
match s with
|Eos ->Eos
|StrCons(x,g) -> StrCons(x, fun ()-> sieves (sift x (g ())))
(*primes*)
let allprimes = sieves (nums_from 2)
let rec listify s n=
if n =0 then [] else
match s with
|Eos -> []
|StrCons(q,w) -> q::(listify (w ()) (n-1))
let twodigitsprimes = filterStr (fun x -> x > 10&& x<100) allprimes
let twodigitsprimeslist= listify twodigitsprimes 21
It appears that filterStr is looping while trying to create the StrCons that represents the next element after the 21st. Since there are only 21 2-digit primes, this will loop forever.
Note that when listify is called with n = 0, the StrCons has already been constructed; it just isn't examined. But the StrCons for this case diverges (and OCaml is a strict language).
You can get things to work using this version of listify:
let rec listify s n =
if n = 0 then []
else
match s with
| Eos -> []
| StrCons (q, w) ->
if n = 1 then [q] else q :: listify (w ()) (n - 1)

number of 5-digits numbers with no repeating digits bigger than 12345

I'm a beginner in OCaml and algorithms.
I'm trying to get the number of 5 digits numbers with no repeating digits bigger than 12345.
Here is what I did in OCaml, I tried to make as tail recursive as possible, and I also used streams. But still, due to size, it stack overflowed:
type 'a stream = Eos | StrCons of 'a * (unit -> 'a stream)
let rec numberfrom n= StrCons (n, fun ()-> numberfrom (n+1))
let nats = numberfrom 1
let rec listify st n f=
match st with
|Eos ->f []
|StrCons (m, a) ->if n=1 then f [m] else listify (a ()) (n-1) (fun y -> f (m::y))
let rec filter (test: 'a-> bool) (s: 'a stream) : 'a stream=
match s with
|Eos -> Eos
|StrCons(q,w) -> if test q then StrCons(q, fun ()->filter test (w ()))
else filter test (w ())
let rec check_dup l=
match l with
| [] -> false
| h::t->
let x = (List.filter (fun x -> x = h) t) in
if (x == []) then
check_dup t
else
true;;
let digits2 d =
let rec dig acc d =
if d < 10 then d::acc
else dig ((d mod 10)::acc) (d/10) in
dig [] d
let size a=
let rec helper n aa=
match aa with
|Eos-> n
|StrCons (q,w) -> helper (n+1) (w())
in helper 0 a
let result1 = filter (fun x -> x<99999 && x>=12345 && (not (check_dup (digits2 x)))) nats
(* unterminating : size result1 *)
(*StackOverflow: listify result1 10000 (fun x->x) *)
I can't reproduce your reported problem. When I load up your code I see this:
# List.length (listify result1 10000 (fun x -> x));;
- : int = 10000
# List.length (listify result1 26831 (fun x -> x));;
- : int = 26831
It's possible your system is more resource constrained than mine.
Let me just say that the usual way to code a tail recursive function is to build the list up in reverse, then reverse it at the end. That might look something like this:
let listify2 st n =
let rec ilist accum st k =
match st with
| Eos -> List.rev accum
| StrCons (m, a) ->
if k = 1 then List.rev (m :: accum)
else ilist (m :: accum) (a ()) (k - 1)
in
if n = 0 then []
else ilist [] st n
You still have the problem that listify doesn't terminate if you ask for more elements than there are in the stream. It might be better to introduce a method to detect the end of the stream and return Eos at that point. For example, the filter function might accept a function that returns three possible values (the element should be filtered out, the element should not be filtered out, the stream should end).
The problem is that the size of your stream result1 is undefined.
Indeed, nats is an never-ending stream: it never returns Eos.
However, filtering a never-ending stream results in another never-ending stream
since a filtered stream only returns Eos after the underlying stream does so:
let rec filter (test: 'a-> bool) (s: 'a stream) : 'a stream=
match s with
| Eos -> Eos
| StrCons(q,w) -> if test q then StrCons(q, fun ()->filter test (w ()))
else filter test (w ())
Consequently, size result1 is stuck trying to reach the end of integers.
Note also that, in recent version of the standard library, your type stream is called Seq.node.

How can I cast a back to a type a value was before?

Very often when writing generic code in F# I come by a situation similar to this (I know this is quite inefficient, just for demonstration purposes):
let isPrime n =
let sq = n |> float |> sqrt |> int
{2..sq} |> Seq.forall (fun d -> n % d <> 0)
For many problems I can use statically resolved types and get even a performance boost due to inlining.
let inline isPrime (n:^a) =
let two = LanguagePrimitives.GenericOne + LanguagePrimitives.GenericOne
let sq = n |> float |> sqrt |> int
{two..sq} |> Seq.forall (fun d -> n % d <> LanguagePrimitives.GenericZero)
The code above won't compile because of the upper sequence limit being a float. Nongenerically, I could just cast back to int for example.
But the compiler won't let me use any of these:
let sq = n |> float |> sqrt :> ^a
let sq = n |> float |> sqrt :?> ^a
and these two lead to a InvalidCastException:
let sq = n |> float |> sqrt |> box |> :?> ^a
let sq = n |> float |> sqrt |> box |> unbox
Also, upcast and downcast are forbidden.
let sq = System.Convert.ChangeType(n |> float |> sqrt, n.GetType()) :?> ^a works, but seems very cumbersome to me.
Is there a way that I overlooked or do I really have to use the last version? Because the last one will also break for bigint, which I need quite often.
With the trick from FsControl, we can define generic function fromFloat:
open FsControl.Core
type FromFloat = FromFloat with
static member instance (FromFloat, _:int32 ) = fun (x:float) -> int x
static member instance (FromFloat, _:int64 ) = fun (x:float) -> int64 x
static member instance (FromFloat, _:bigint ) = fun (x:float) -> bigint x
let inline fromFloat (x:float):^a = Inline.instance FromFloat x
let inline isPrime (n:^a) =
let two = LanguagePrimitives.GenericOne + LanguagePrimitives.GenericOne
let sq = n |> float |> sqrt |> fromFloat
{two..sq} |> Seq.forall (fun d -> n % d <> LanguagePrimitives.GenericZero)
printfn "%A" <| isPrime 71
printfn "%A" <| isPrime 6L
printfn "%A" <| isPrime 23I
Inline.instance was defined here.

How to set a timeout for tests with OUnit?

I have some tests on infinite lazy structures that might run indefinitely if the tested function is not correctly implemented, but I can’t find in the OUnit docs how to set a timeout on tests.
If you're using OUnit2, the following should work:
let tests =
"suite" >::: [OUnitTest.TestCase (
OUnitTest.Short,
(fun _ -> assert_equal 2 (1+1))
);
OUnitTest.TestCase (
OUnitTest.Long,
(fun _ -> assert_equal 4 (2+2))
)]
The type test_length is defined as:
type test_length =
| Immediate
| Short
| Long
| Huge
| Custom_length of float
I don't think that oUnit provides this functionality. I remember having to do this a while back and this is the quick hack I've come up with:
let race seconds ~f =
let ch = Event.new_channel () in
let timeout = Thread.create (fun () ->
Thread.delay seconds;
`Time_out |> Event.send ch |> Event.sync
) () in
let tf = Thread.create (fun () ->
`Result (f ()) |> Event.send ch |> Event.sync) () in
let res = ch |> Event.receive |> Event.sync in
try
Thread.kill timeout;
Thread.kill tf;
res
with _ -> res
let () =
let big_sum () =
let arr = Array.init 1_000_000 (fun x -> x) in
Array.fold_left (+) 0 arr in
match race 0.0001 ~f:big_sum with
| `Time_out -> print_endline "time to upgrade";
| `Result x -> Printf.printf "sum is: %d\n" x
This worked well enough for my use case but I'd definitely would not recommend using this if only because race will not work as you'd expect if ~f does no allocations or calls Thread.yield manually.

ocaml memoization failed when applied to Fibonacci series

I tried to use memoization technique to optimize the caculation of Fibonacci. My code is:
let memo f =
let vtable = ref [] in
let rec match_function x vt=
match vt with
|(x',y)::_ when x=x' -> y
|_::l ->
match_function x l
|[] ->
let y = (f x) in
vtable := (x,y):: !vtable;
y
in
(fun x -> (match_function x !vtable));;
let rec ggfib = function
0|1 as i -> i
|x -> ggfib(x-1) + ggfib(x-2);;
let memoggfib = memo ggfib;;
let running_time f x =
let start_time = Sys.time () in
let y = f x in
let finish_time = Sys.time() in
Printf.printf "Time lapse:%f\n" (finish_time -. start_time);
y;;
running_time ggfib 30;;
running_time memoggfib 30;;
The output is:
Time lapse:0.357187
Time lapse:0.353663
The difference is not that much.. Why?? And even worse, when I tried to calculate Fibonacci at 40 using
running_time ggfib 40;;
running_time memoggfib 40;;
The program appears to run into a infinite loop and stop outputting.
What is wrong here? What problem I did not take care of?
I changed the code above, to introduce a 'static' vtable for memoization.
let rec ggfib = function
0|1 as i -> i
|x -> ggfib(x-1) + ggfib(x-2);;
let running_time x0 =
let vtable = ref [] in
let start_time = Sys.time () in
let x = ref 1 in
let rec match_function ff x vt=
match vt with
|(x',y)::_ when x=x' -> y
|_::l ->
match_function ff x l
|[] ->
let y = (ff x) in
vtable := (x,y):: !vtable;
y
in
let y=ref 1 in
while !x<x0 do
y:= match_function ggfib !x !vtable;
x:=!x+1;
done;
let finish_time = Sys.time() in
Printf.printf "Time lapse:%f\n" (finish_time -. start_time);
y;;
let running_time2 x0=
let start_time = Sys.time () in
let x = ref 1 in
while !x<x0 do
ggfib !x;
x:=!x+1;
done;
let finish_time = Sys.time() in
Printf.printf "Time lapse:%f\n" (finish_time -. start_time);;
running_time 40;;
running_time2 30;;
It still acts as the basically same. I didn't see a significant improvement....
Time lapse:0.581918
Time lapse:0.577813
It looks to me like you're just memoizing the outermost calls. The inner calls are to ggfib, not to (memo ggfib).
When you call memoggfib, the memo function will remember the value of the outermost call. However, the inner calls are handled by ggfib (the function that you passed to memo). If you look at the definition of ggfib, you see that it calls itself. It doesn't call (memo ggfib).
I don't see a way to turn an ordinary (recursive) function into a memoized one. It won't automatically call the memoized version of itself internally.
If you start with a function that's intended to be memoized, I still see problems "tying the knot".
(* a "derecursified" version of fibonacci: recursive calls are
replaced by calls to a function passed as parameter *)
let rec fib_derec f = function
| 0|1 as i -> i
| n -> f (n - 1) + f (n - 2)
(* to get the fibonacci back we need to compute a fixpoint:
fib_derec should get passed 'fib' as parameter,
which we will define in term of fib_derec
*)
let rec fib n = fib_derec fib n
let test = Array.init 10 fib
(* [|0; 1; 1; 2; 3; 5; 8; 13; 21; 34|] *)
(* we can make this construction generic *)
let rec fix derec input = derec (fix derec) input
let fib = fix fib_derec
let test = Array.init 10 fib
(* [|0; 1; 1; 2; 3; 5; 8; 13; 21; 34|] *)
(* Trick: we can use this tying-the-knot operator to insert
memoization "between the recursive calls" of the recursive function *)
let rec memo_fix table derec =
fun input ->
try Hashtbl.find table input with Not_found ->
let result = derec (memo_fix table derec) input in
Hashtbl.add table input result;
result
let fib_table = Hashtbl.create 100
let fib = memo_fix fib_table fib_derec
let test = Array.init 10 fib
(* [|0; 1; 1; 2; 3; 5; 8; 13; 21; 34|] *)
let test2 = fib 1000
(* -591372213: overflow, but quick result *)