...
 
Commits (8)
B +threads
......@@ -6,7 +6,7 @@
{
"label": "ocaml",
"type": "shell",
"command": "cd ${fileDirname} && ocaml \"${file}\"",
"command": "cd ${fileDirname} && ocaml -I +threads unix.cma threads.cma \"${file}\"",
"group": {
"kind": "build",
"isDefault": true
......
This diff is collapsed.
This diff is collapsed.
(* testing utilities [do not change] *)
exception SyncDeadlocked
module Event = struct
include Event
let tsync t e =
let timer = new_channel () in
let run_timer () =
Thread.delay t;
poll (send timer None)
in
let _ = Thread.create run_timer () in
match (select [wrap e (fun x -> Some x); receive timer]) with
| Some x -> x
| None -> raise SyncDeadlocked
let tselect t es =
tsync t (choose es)
let sync e = tsync 2. e
let select es = tselect 2. es
end
module Thread = struct
include Thread
let tc = ref 0
let create f a =
tc := !tc + 1;
create f a
end
(*****************************************************************************)
(*************************** START OF HOMEWORK *******************************)
(*****************************************************************************)
open Thread
open Event
(* 13.4 *)
let par_unary f a = failwith "TODO"
let par_binary f a b = failwith "TODO"
(* 13.5 *)
exception OutOfBounds
module Array = struct
type 'a t = unit (* todo *)
let make s v = failwith "TODO"
let size a = failwith "TODO"
let set i v a = failwith "TODO"
let get i a = failwith "TODO"
let resize s v a = failwith "TODO"
let destroy a = failwith "TODO"
end
(* 13.6 *)
exception InvalidOperation
let document_server () = failwith "TODO"
let publish u p doc s = failwith "TODO"
let change_owner u p id owner s = failwith "TODO"
let view u p id s = failwith "TODO"
let add_account u p s = failwith "TODO"
let add_viewer u p id viewer s = failwith "TODO"
(*****************************************************************************)
(**************************** END OF HOMEWORK ********************************)
(*****************************************************************************)
(*****************************************************************************)
(* TESTS [do not change] *)
let reset () =
Thread.tc := 0
let threads_created () =
!Thread.tc
let d_server () =
let s = document_server () in
add_account "user1" "pass1" s;
add_account "user2" "pass2" s;
add_account "user3" "pass3" s;
s
let tests = [
(* 13.4 *)
__LINE_OF__ (fun () -> let pinc = par_unary (fun x -> x + 1) in pinc [8;1;1] = [9;2;2] && threads_created () = 3);
__LINE_OF__ (fun () -> let psof = par_unary string_of_float in psof [7.;1.] = ["7.";"1."] && threads_created () = 2);
__LINE_OF__ (fun () -> let pmul = par_binary ( * ) in pmul [1;2;3] [5;6;2] = [5;12;6] && threads_created () = 3);
__LINE_OF__ (fun () -> let pcon = par_binary ( ^ ) in pcon ["th";"";"ver";"nic"] ["is";"is";"y";"e"] = ["this";"is";"very";"nice"] && threads_created () = 4);
(* 13.5
NOTE: Array's functions cannot be tested in isolation, so if a test for size fails it may very well be due to a mistake in your implementation of make *)
__LINE_OF__ (fun () -> let _ = Array.make 3 "abc" in threads_created () = 1);
__LINE_OF__ (fun () -> let a = Array.make 3 1. in Array.destroy a; threads_created () = 1);
__LINE_OF__ (fun () -> let a = Array.make 3 0 in Array.size a = 3);
__LINE_OF__ (fun () -> let a = Array.make 3 'x' in Array.get 0 a = 'x');
__LINE_OF__ (fun () -> let a = Array.make 3 'x' in try let _ = Array.get 3 a in false with OutOfBounds -> true);
__LINE_OF__ (fun () -> let a = Array.make 3 0 in Array.set 1 5 a; Array.get 0 a = 0 && Array.get 1 a = 5 && Array.get 2 a = 0 && threads_created () = 1);
__LINE_OF__ (fun () -> let a = Array.make 3 'x' in try Array.set 3 'u' a; false with OutOfBounds -> true);
__LINE_OF__ (fun () -> let a = Array.make 3 0 in Array.resize 5 1 a; Array.size a = 5 && Array.get 2 a = 0 && Array.get 3 a = 1 && Array.get 4 a = 1 && threads_created () = 1);
__LINE_OF__ (fun () -> let a = Array.make 3 0 in Array.resize 1 1 a; Array.size a = 1 && Array.get 0 a = 0 && threads_created () = 1);
(* 13.6
NOTE: Document server functions cannot be tested in isolation, so if a test for view fails it may very well be due to a mistake in your implementation of document_server *)
__LINE_OF__ (fun () -> let _ = document_server () in threads_created () = 1); (* basic thread creation *)
__LINE_OF__ (fun () -> let s = document_server () in add_account "user1" "pass1" s; true); (* add correct account *)
__LINE_OF__ (fun () -> let s = d_server () in try add_account "user1" "***" s; false with InvalidOperation -> true); (* account exists already *)
__LINE_OF__ (fun () -> let s = d_server () in publish "user2" "pass2" "My Document" s <> publish "user1" "pass1" "My Document" s); (* publish document *)
__LINE_OF__ (fun () -> let s = d_server () in try let _ = publish "user1" "***" "My Document" s in false with InvalidOperation -> true); (* publish incorrect auth *)
__LINE_OF__ (fun () -> let s = d_server () in try let _ = view "user1" "pass1" 0 s in false with InvalidOperation -> true); (* view invalid document *)
__LINE_OF__ (fun () -> let s = d_server () in let d = publish "user1" "pass1" "text" s in "text" = view "user1" "pass1" d s); (* view correct *)
__LINE_OF__ (fun () -> let s = d_server () in let d = publish "user1" "pass1" "text" s in try let _ = view "user2" "pass2" d s in false with InvalidOperation -> true); (* view, no access *)
__LINE_OF__ (fun () -> let s = d_server () in try add_viewer "user1" "pass1" 0 "user3" s; false with InvalidOperation -> true); (* add viewer invalid document *)
__LINE_OF__ (fun () -> let s = d_server () in let d = publish "user1" "pass1" "text" s in try add_viewer "user1" "***" d "user3" s; false with InvalidOperation -> (try let _ = view "user3" "pass3" d s in false with InvalidOperation -> true)); (* add viewer invalid auth *)
__LINE_OF__ (fun () -> let s = d_server () in let d = publish "user2" "pass2" "text" s in add_viewer "user2" "pass2" d "user1" s; view "user1" "pass1" d s = "text"); (* add viewer correct *)
__LINE_OF__ (fun () -> let s = d_server () in let d = publish "user1" "pass1" "mydoc" s in try change_owner "user1" "***" d "user2" s; false with InvalidOperation -> true); (* change owner invalid auth *)
__LINE_OF__ (fun () -> let s = d_server () in try change_owner "user1" "pass1" 0 "user3" s; false with InvalidOperation -> true); (* change owner invalid document *)
__LINE_OF__ (fun () -> let s = d_server () in let d = publish "user1" "pass1" "mydoc" s in try change_owner "user2" "pass2" d "user2" s; false with InvalidOperation -> true); (* change owner, not owner *)
__LINE_OF__ (fun () -> let s = d_server () in let d = publish "user1" "pass1" "mydoc" s in change_owner "user1" "pass1" d "user3" s; view "user3" "pass3" d s = "mydoc"); (* change owner correct *)
]
let () =
let rec input_lines ch =
(try Some (input_line ch) with _ -> None) (* catch stupid EOF exception *)
|> function Some line -> line :: input_lines ch | None -> []
in
let lines = input_lines (open_in __FILE__) in
let open List in
let open Printf in
let fail l =
let line = nth lines (l-1) in
let test = String.sub line 25 (String.length line - 27) in
printf "test \027[31;m%s\027[0;m (line %d) failed!\n" test l;
in
let test (l, t) =
reset ();
let ok = try t () with e -> print_endline (Printexc.to_string e); false in
if not ok then fail l;
ok
in
let passed = filter (fun x -> x) (map test tests) in
printf "passed %d/%d tests\n" (length passed) (length tests)
open Thread
open Event
(* 13.1 *)
let spawn_counter n = failwith "todo"
let run_counters m n = failwith "todo"
(* 13.2 *)
type blog = string list
type user = string
type pass = string
type message = Post of user * pass * string
| Read of user * blog channel
type t = message channel
(* begin solution *)
let start_server users = failwith "todo"
let post s u p t = failwith "tood"
let read s u = failwith "todo"
(* end solution *)
let test =
let s = start_server [("userA", "passA"); ("userB", "passB")] in
post s "userB" "passB" "Welcome to my OCaml blog.";
post s "userA" "passA" "My name is A and I'm starting my own blog!";
post s "userB" "12345" "I am a hacker attacking B's blog now!";
post s "userB" "passB" "You can have threads in OCaml!";
read s "userB"
(* 13.3 *)
module Future = struct
type 'a t = unit (* todo *)
let create f a = failwith "todo"
let get c = failwith "todo"
let then_ f c = failwith "todo"
let when_any cs = failwith "todo"
let when_all cs = failwith "todo"
end
(* Future example *)
(*
let read_lines filename =
let file = open_in filename in
let rec read_all l =
try
read_all (input_line file :: l)
with End_of_file -> List.rev l
in
let content = read_all [] in
close_in file;
content
let write_file filename content =
let file = open_out filename in
output_string file content;
close_out file
let print_list l =
print_endline (String.concat "\n" l)
let main () =
let f1 = Future.create read_lines "p13.ml" in
let f1 = Future.then_ (List.filter ((<>) "")) f1 in
let f2 = Future.create read_lines "p13_sol.ml" in
let f2 = Future.then_ (List.filter ((<>) "")) f2 in
(* let fany = Future.when_any [f1;f2] in
print_list (Future.get fany)
*)
let fmerged = Future.when_all [f1;f2]
|> Future.then_ (List.fold_left (@) [])
|> Future.then_ (String.concat "\n")
|> Future.then_ (write_file "merged.ml") in
try Future.get fmerged with e -> print_endline "Exception!"
*)
\ No newline at end of file
open Thread
open Event
(* 13.1 *)
(* version 1: chaotic *)
let spawn_counter n =
let rec count i =
if i > n then
()
(*delay 0.1*)
else
let s = Printf.sprintf "Thread %2d: %d" (id (self ())) i in
print_endline s;
(* Printf.printf "Thread %2d: %d\n%!" (id (self())) i; *)
count (i+1)
in
create count 0
let run_counters m n =
let counters = List.init m (fun _ -> spawn_counter n) in
List.iter join counters;
print_newline ()
(* let _ = run_counters 10 10000 *)
(* version 2: main thread orchestration *)
let spawn_counter n c =
let rec count i =
let _ = sync (receive c) in
let s = Printf.sprintf "Thread %2d: %d" (id (self ())) i in
print_endline s;
if i < n then
(sync (send c true);
count (i+1))
else
(sync (send c false))
in
create count 0
let run_counters m n =
let channels = List.init m (fun _ -> new_channel ()) in
let counters = List.map (spawn_counter n) channels in
let rec run = function [] -> ()
| c::cs -> sync (send c true);
let chans = if sync (receive c) then cs @ [c] else cs in
run chans
in
run channels;
List.iter join counters;
print_newline ()
(* let _ = run_counters 10 1000 *)
(* version 3: self organization *)
type cmd = Count | Update_recv of cmd channel
let spawn_counter n rc sc =
let rec count_solo i =
if i <= n then
(let s = Printf.sprintf "Thread %2d: %d" (id (self ())) i in
print_endline s;
count_solo (i+1))
else ()
in
let rec impl i rc sc =
let rc = match sync (receive rc) with Count -> rc
| Update_recv new_rc -> new_rc
in
let s = Printf.sprintf "Thread %2d: %d" (id (self ())) i in
print_endline s;
(* NOTE: we use == here to compare the channel references *)
if rc == sc then count_solo (i+1)
else if i < n then
(sync (send sc Count);
impl (i+1) rc sc)
else
sync (send sc (Update_recv rc))
in
Thread.create (fun () -> impl 0 rc sc) ()
let run_counters m n =
let recv_channels = List.init 10 (fun _ -> new_channel ()) in
let send_channels = (List.tl recv_channels) @ [List.hd recv_channels] in
let curried = List.map2 spawn_counter (List.init m (fun _ -> n)) recv_channels in
let threads = List.map2 (fun f sc -> f sc) curried send_channels in
sync (send (List.hd recv_channels) Count);
List.iter Thread.join threads;
print_newline ()
(* let _ = run_counters 10 100 *)
(* 13.2 *)
type blog = string list
type user = string
type pass = string
type message = Post of user * pass * string
| Read of user * blog channel
type t = message channel
(* begin solution *)
let start_server users =
let c = new_channel () in
let rec server_fun blogs =
let get_blog user = match List.assoc_opt user blogs with
None -> [] | Some b' -> b' in
match sync (receive c) with
| Post (user, pass, text) ->
if List.assoc_opt user users = Some pass then
server_fun ((user, get_blog user @ [text])
::List.remove_assoc user blogs)
else server_fun blogs
| Read (user, answer_c) ->
sync (send answer_c (get_blog user));
server_fun blogs
in
let _ = create server_fun [] in
c
let post s u p t =
sync (send s (Post (u, p, t)))
let read s u =
let answer_c = new_channel () in
sync (send s (Read (u, answer_c)));
sync (receive answer_c)
(* end solution *)
let test =
let s = start_server [("userA", "passA"); ("userB", "passB")] in
post s "userB" "passB" "Welcome to my OCaml blog.";
post s "userA" "passA" "My name is A and I'm starting my own blog!";
post s "userB" "12345" "I am a hacker attacking B's blog now!";
post s "userB" "passB" "You can have threads in OCaml!";
read s "userB"
(* alternative for start_server *)
let (|?) a b = match a with Some x -> x | None -> b
let rec start_server up =
let open List in
let c = new_channel () in
let rec f bs =
match sync (receive c) with
| Post (u, p, b) ->
if assoc_opt u up = Some p then
f ((u, (assoc_opt u bs |? []) @ [b])::remove_assoc u bs)
else
f bs
| Read (u, rc) ->
sync (send rc (assoc_opt u bs |? []));
f bs
in
ignore (create f []);
c
(* 13.3 *)
module Future = struct
type 'a msg = Result of 'a | Ex of exn
type 'a t = 'a msg channel
let create f a =
let c = new_channel () in
let task () =
let r = try Result (f a) with e -> Ex e in
sync (send c r)
in
let _ = Thread.create task () in
c
let get c =
match sync (receive c) with
| Result r -> r
| Ex e -> raise e
let then_ f c =
let c' = new_channel () in
let task () =
let r = match sync (receive c) with
| Result r -> Result (f r)
| Ex e -> Ex e
in
sync (send c' r)
in
let _ = Thread.create task () in
c'
let when_any cs =
let c' = new_channel () in
let task () =
let r = select (List.map receive cs) in
sync (send c' r)
in
let _ = Thread.create task () in
c'
let when_all cs =
let c' = new_channel () in
let task () =
let r = List.fold_left (fun a c -> sync (receive c)::a) [] cs |> List.rev in
match List.find_opt (function Ex _ -> true | _ -> false) r with
| Some (Ex e) -> sync (send c' (Ex e))
| _ -> sync (send c' (Result (List.map (function Result r -> r | _ -> failwith "unreachable") r)))
in
let _ = Thread.create task () in
c'
(* additional stuff *)
let memoize c =
let c' = new_channel () in
let task () =
let r = sync (receive c') in
let rec repeat () =
sync (send c' r);
repeat ()
in
repeat ()
in
let _ = Thread.create task () in
c'
let result_to receiver_c c =
let task () =
match sync (receive c) with
| Result r -> sync (send receiver_c r)
| Ex e -> raise e
in
let _ = Thread.create task () in
()
let get_opt c = poll (receive c)
end
(* Future example *)
let read_lines filename =
let file = open_in filename in
let rec read_all l =
try
read_all (input_line file :: l)
with End_of_file -> List.rev l
in
let content = read_all [] in
close_in file;
content
let write_file filename content =
let file = open_out filename in
output_string file content;
close_out file
let print_list l =
print_endline (String.concat "\n" l)
let main () =
let f1 = Future.create read_lines "Pervasives.html" in
let f1 = Future.then_ (List.filter ((<>) "")) f1 in
let f2 = Future.create read_lines "List.html" in
let f2 = Future.then_ (List.filter ((<>) "")) f2 in
(* let fany = Future.when_any [f1;f2] in
print_list (Future.get fany)
*)
let fmerged = Future.when_all [f1;f2]
|> Future.then_ (List.fold_left (@) [])
|> Future.then_ (String.concat "\n")
|> Future.then_ (write_file "merged.html") in
try Future.get fmerged with e -> print_endline "Exception!"