From bfafa7dbc3325749358538a95cbb4831db66b03c Mon Sep 17 00:00:00 2001 From: Alex AUVOLAT Date: Wed, 12 Mar 2014 10:11:12 +0100 Subject: First commit --- .gitignore | 3 + khb/_tags | 3 + khb/khb_ast.ml | 27 ++++++ khb/khs_ast.ml | 36 ++++++++ khb/khs_exec.ml | 225 ++++++++++++++++++++++++++++++++++++++++++++++++++ khb/khs_exec_local.ml | 92 +++++++++++++++++++++ khb/khs_exec_seq.ml | 62 ++++++++++++++ khb/ksh_print.ml | 53 ++++++++++++ khb/test.khb | 67 +++++++++++++++ khb/test.khs | 76 +++++++++++++++++ khb/test.ml | 101 ++++++++++++++++++++++ khb/util.ml | 10 +++ projet.pdf | Bin 0 -> 190381 bytes projet.tgz | Bin 0 -> 1283 bytes src/Makefile | 19 +++++ src/example.ml | 32 +++++++ src/kahn.ml | 152 ++++++++++++++++++++++++++++++++++ src/primes.ml | 42 ++++++++++ 18 files changed, 1000 insertions(+) create mode 100644 .gitignore create mode 100644 khb/_tags create mode 100644 khb/khb_ast.ml create mode 100644 khb/khs_ast.ml create mode 100644 khb/khs_exec.ml create mode 100644 khb/khs_exec_local.ml create mode 100644 khb/khs_exec_seq.ml create mode 100644 khb/ksh_print.ml create mode 100644 khb/test.khb create mode 100644 khb/test.khs create mode 100644 khb/test.ml create mode 100644 khb/util.ml create mode 100644 projet.pdf create mode 100644 projet.tgz create mode 100644 src/Makefile create mode 100644 src/example.ml create mode 100644 src/kahn.ml create mode 100644 src/primes.ml diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..a674ee4 --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +*.byte +*.native +*/_build/* diff --git a/khb/_tags b/khb/_tags new file mode 100644 index 0000000..f36ce04 --- /dev/null +++ b/khb/_tags @@ -0,0 +1,3 @@ +true: use_menhir +<*.byte>: use_unix +<*.native>: use_unix diff --git a/khb/khb_ast.ml b/khb/khb_ast.ml new file mode 100644 index 0000000..fa52ece --- /dev/null +++ b/khb/khb_ast.ml @@ -0,0 +1,27 @@ + +type khb_binop = + | PLUS | MINUS + | TIMES | DIV | MOD + | EQUAL | NEQUAL + | GT | LT | GE | LE + | AND | OR | XOR + | SEND | RECV | ASSIGN | SEQ + +type khb_unop = + | MINUS | NOT + | DEREF | REF + + +type khb_expr = + | BVar of string + | BStr of string + | BInt of int + | BBool of bool + | BUnary of unop * expr + | BBinary of expr * unop * expr + | BTernary of expr * expr * expr + | BCall of string * expr list + | BLoop of expr + | BNewChan + | BPar of expr + | BIndex of expr * expr diff --git a/khb/khs_ast.ml b/khb/khs_ast.ml new file mode 100644 index 0000000..f5b2c8d --- /dev/null +++ b/khb/khs_ast.ml @@ -0,0 +1,36 @@ + +type khs_binop = + | PLUS | MINUS + | TIMES | DIV | MOD + | EQUAL | NEQUAL + | GT | LT | GE | LE + | AND | OR | XOR + +type khs_unop = + | MINUS | NOT + +type khs_expr = + | EEmpty + | EInt of int + | EStr of string + | EBool of bool + | EFrame + | ELocal of string + | EBinary of khs_expr * khs_binop * khs_expr + | EUnary of khs_unop * khs_expr + | ETernary of khs_expr * khs_expr * khs_expr + | ECat of khs_expr * khs_expr + | ELoad of khs_expr + | ENewChan + +type khs_stmt = + | SLabel of string + | SSet of khs_expr * khs_expr + | SGoto of khs_expr + | SPar of khs_expr + (* RECV and SEND do a load on their second argument (the chan), + (ie they expect an address and not a value) *) + | SRecv of khs_expr * khs_expr + | SSend of khs_expr * khs_expr + | SUnset of khs_expr list + | SExit diff --git a/khb/khs_exec.ml b/khb/khs_exec.ml new file mode 100644 index 0000000..ff050c6 --- /dev/null +++ b/khb/khs_exec.ml @@ -0,0 +1,225 @@ +open Util +open Khs_ast + + +type kprog = + { + pinstr: khs_stmt array; + plabels: int Smap.t; + } + +type kbval = + | VNone + | VInt of int + | VBool of bool + | VStr of string +type kval = + | Single of kbval + | Many of kbval Smap.t + +type chanid = kbval + +type kprocstatus = + | PSExec + | PSSend of chanid * kval + | PSRecv of chanid + | PSExecRecvd of kval + | PSDone + +type kproc = + { + xspawn: kproc -> int -> unit; + xnewchan: kproc -> kval; + xprog: kprog; + mutable xvals: kbval Smap.t; + mutable xstatus: kprocstatus; + mutable xpos: int + } + +let psep = "\\" +let framevar = "#" + + +(* Procedures on values *) + +(* Strange semantics : all type conversions are allowed *) +let int_of_kbval = function + | VInt i -> i + | VBool true -> 1 + | VBool false -> 0 + | VNone -> 0 + | VStr s -> int_of_string s +let str_of_kbval = function + | VInt i -> string_of_int i + | VBool true -> "1" + | VBool false -> "0" + | VNone -> "" + | VStr s -> s +let bool_of_kbval = function + | VInt i -> i <> 0 + | VBool b -> b + | VNone -> false + | VStr s -> (int_of_string s) <> 0 + +let kval_of_kbval v = Single v +let kbval_of_kval = function + | Single v -> v + | Many a -> + try Smap.find "" a + with Not_found -> VNone + +let int_of_kval v = int_of_kbval (kbval_of_kval v) +let bool_of_kval v = bool_of_kbval (kbval_of_kval v) +let str_of_kval v = str_of_kbval (kbval_of_kval v) + +let kval_descr = function + | Single v -> "'" ^ str_of_kbval v ^ "'" + | Many a -> + if Smap.cardinal a = 1 then + Smap.fold (fun k v s -> str_of_kbval v) a "" + else + Smap.fold (fun k v s -> s ^ "\n " ^ k ^ " : '" ^ str_of_kbval v ^ "'") + a "{" + ^ "\n}" + +(* Variable loading and setting *) +let load_kval proc key = + let n = String.length key in + let ret = ref Smap.empty in + Smap.iter (fun k v -> + if k = key || + (String.length k > n && + String.sub k 0 (n+1) = key ^ psep) + then + ret := Smap.add (String.sub k n (String.length k - n)) v !ret) + proc.xvals; + (* Format.printf "Load %s : %s@." key (kval_descr (Many (!ret))); *) + Many(!ret) +let save_kval proc key value = + (* Format.printf "Set %s = %s@." key (kval_descr value); *) + match value with + | Single s -> proc.xvals <- Smap.add key s proc.xvals + | Many m -> + Smap.iter + (fun k v -> proc.xvals <- Smap.add (key ^ k) v proc.xvals) + m +let unset_kval proc key = + let n = String.length key in + let f k _ = + k <> key && + (String.length k < n + 1 || + String.sub k 0 (n+1) <> key ^ psep) + in + proc.xvals <- Smap.filter f proc.xvals + +(* Expression evaluation *) +let rec eval_expr proc = function + | EEmpty -> Single VNone + | EInt i -> Single (VInt i) + | EBool b -> Single (VBool b) + | EStr s -> Single (VStr s) + | ELocal l -> + Single(VStr(str_of_kval (load_kval proc framevar) ^ psep ^ l)) + | EFrame -> Single(VStr framevar) + | EBinary(e1, op, e2) -> + let v1, v2 = eval_expr proc e1, eval_expr proc e2 in + let r = match op with + | PLUS -> VInt(int_of_kval v1 + int_of_kval v2) + | MINUS -> VInt(int_of_kval v1 - int_of_kval v2) + | TIMES -> VInt(int_of_kval v1 * int_of_kval v2) + | DIV -> VInt(int_of_kval v1 / int_of_kval v2) + | MOD -> VInt(int_of_kval v1 mod int_of_kval v2) + | EQUAL -> VBool(kbval_of_kval v1 = kbval_of_kval v2) + (* EQUAL does not test values in depth ! *) + | NEQUAL -> VBool(kbval_of_kval v1 <> kbval_of_kval v2) + | GT -> VBool(int_of_kval v1 > int_of_kval v2) + | LT -> VBool(int_of_kval v1 < int_of_kval v2) + | GE -> VBool(int_of_kval v1 >= int_of_kval v2) + | LE -> VBool(int_of_kval v1 <= int_of_kval v2) + | AND -> VBool(bool_of_kval v1 && bool_of_kval v2) + | OR -> VBool(bool_of_kval v1 || bool_of_kval v2) + | XOR -> VBool(bool_of_kval v1 ^^ bool_of_kval v2) + in Single r + | EUnary(op, e) -> + let v = eval_expr proc e in + let r = match op with + | MINUS -> VInt(-(int_of_kval v)) + | NOT -> VBool(not(bool_of_kval v)) + in Single r + | ETernary(cond, e1, e2) -> + if bool_of_kval (eval_expr proc cond) then + eval_expr proc e1 + else + eval_expr proc e2 + | ECat(e1, e2) -> + Single(VStr( + str_of_kval (eval_expr proc e1) + ^ psep + ^ str_of_kval (eval_expr proc e2))) + | ELoad(x) -> + load_kval proc (str_of_kval (eval_expr proc x)) + | ENewChan -> proc.xnewchan proc + +let exec_stmt proc = + match proc.xprog.pinstr.(proc.xpos) with + | SLabel _ -> + proc.xpos <- proc.xpos + 1 (* nothing to do *) + | SSet(var, v) -> + let var = str_of_kval (eval_expr proc var) in + let v = eval_expr proc v in + save_kval proc var v; + proc.xpos <- proc.xpos + 1 + | SGoto pos -> + let pos = str_of_kval (eval_expr proc pos) in + begin + try + proc.xpos <- Smap.find pos proc.xprog.plabels + with Not_found -> + proc.xstatus <- PSDone + end + | SPar pos -> + let pos = str_of_kval (eval_expr proc pos) in + begin + try + proc.xspawn proc (Smap.find pos proc.xprog.plabels) + with Not_found -> () + end; + proc.xpos <- proc.xpos + 1 + | SRecv(var, chan) -> + begin match proc.xstatus with + | PSExec -> + let chan = kbval_of_kval (eval_expr proc (ELoad chan)) in + proc.xstatus <- PSRecv chan + | PSExecRecvd v -> + let var = str_of_kval (eval_expr proc var) in + save_kval proc var v; + proc.xstatus <- PSExec; + proc.xpos <- proc.xpos + 1 + | _ -> assert false + end + | SSend(v, chan) -> + let chan = kbval_of_kval (eval_expr proc (ELoad chan)) in + let v = eval_expr proc v in + proc.xpos <- proc.xpos + 1; + proc.xstatus <- PSSend(chan, v) + | SUnset(l) -> + List.iter (unset_kval proc) + (List.map (fun e -> str_of_kval (eval_expr proc e)) l); + proc.xpos <- proc.xpos + 1; + | SExit -> + proc.xstatus <- PSDone + + +(* Load program, ie find labels *) +let load_program p = + let labels = ref Smap.empty in + Array.iteri + (fun i x -> + match x with + | SLabel l -> labels := Smap.add l i !labels + | _ -> ()) + p; + { pinstr = p; plabels = !labels } + + + diff --git a/khb/khs_exec_local.ml b/khb/khs_exec_local.ml new file mode 100644 index 0000000..fb97b47 --- /dev/null +++ b/khb/khs_exec_local.ml @@ -0,0 +1,92 @@ +open Util +open Khs_ast +open Khs_exec + +(* TODO : channels cannot be communicated over channels, although + it should totally be possible because it's so great and so usefull ! *) + +let childs = ref [] + +let wait_childs () = + Unix.handle_unix_error (fun () -> + List.iter (fun pid -> ignore (Unix.waitpid [] pid)) !childs) + () + +let max_chans = 12 +let ochans = Hashtbl.create 12 +let ochans_time = ref Smap.empty +let get_chan id = + ochans_time := Smap.map (fun v -> v+1) !ochans_time; + ochans_time := Smap.add id 0 !ochans_time; + if Smap.cardinal !ochans_time > max_chans then begin + let maxchan, _ = + Smap.fold + (fun k v (mk, mv) -> if v > mv then (k, v) else (mk, mv)) + !ochans_time ("", 0) in + let i_fd, o_fd = Hashtbl.find ochans maxchan in + Unix.close i_fd; Unix.close o_fd; + Hashtbl.remove ochans maxchan; + ochans_time := Smap.remove maxchan !ochans_time + end; + try + Hashtbl.find ochans id + with Not_found -> + let i, o = Unix.openfile ("/tmp/"^id) [Unix.O_RDONLY] 0, + Unix.openfile ("/tmp/"^id) [Unix.O_WRONLY] 0 in + Hashtbl.add ochans id (i, o); + i, o + +let newchan proc = + let id = "khs_ch_" ^ string_of_int (Random.int 1000000) + ^ "-" ^ string_of_int (Random.int 1000000) in + Unix.mkfifo ("/tmp/" ^ id) 0o666; + Many (Smap.add (psep^"in") (VStr id) + (Smap.add (psep^"out") (VStr id) Smap.empty)) + +let exec_proc proc = + while proc.xstatus <> PSDone do + match proc.xstatus with + | PSDone -> assert false + | PSExec | PSExecRecvd _ -> + exec_stmt proc + | PSSend(c, kv) -> + proc.xstatus <- PSExec; + begin + if c == "stdout" then + Format.printf "%s@." (kval_descr kv) + else + let _, c_out = get_chan c in + Marshal.to_channel (Unix.out_channel_of_descr c_out) kv [] + end + | PSRecv c -> + let c_in, _ = get_chan c in + proc.xstatus <- PSExecRecvd (Marshal.from_channel (Unix.in_channel_of_descr c_in)) + done + +let spawn proc pos = + let pid = Unix.fork () in + if pid = 0 then begin + childs := []; + exec_proc { proc with xpos = pos}; + wait_childs(); + exit 0 + end else + childs := pid::!childs + + + +let exec_program p = + Random.init (int_of_float (Unix.time())); + let proc = { + xspawn = spawn; + xnewchan = newchan; + xprog = p; + xvals = Smap.empty; + xstatus = PSExec; + xpos = 0; + } in + proc.xvals <- Smap.add framevar (VInt 0) proc.xvals; + proc.xvals <- Smap.add "stdout" (VStr "stdout") proc.xvals; + exec_proc proc; + wait_childs() + diff --git a/khb/khs_exec_seq.ml b/khb/khs_exec_seq.ml new file mode 100644 index 0000000..6e34767 --- /dev/null +++ b/khb/khs_exec_seq.ml @@ -0,0 +1,62 @@ +open Util +open Khs_ast +open Khs_exec + +let chans = Hashtbl.create 12 +let ch_id = + let p = ref 0 in + fun () -> p := !p + 1; !p + +let proc = ref [] +let proc_spawned = ref [] + +let spawn proc pos = + proc_spawned := + { proc with xpos = pos }::(!proc_spawned) + +let newchan proc = + let id = ch_id () in + Hashtbl.add chans id (Queue.create()); + Many (Smap.add (psep^"in") (VInt id) + (Smap.add (psep^"out") (VInt id) Smap.empty)) + +let proc_step proc = + match proc.xstatus with + | PSDone -> false + | PSExec | PSExecRecvd _ -> + exec_stmt proc; + true + | PSSend(c, kv) -> + proc.xstatus <- PSExec; + begin + if (int_of_kbval c) == 0 then + Format.printf "%s@." (kval_descr kv) + else + Queue.push kv (Hashtbl.find chans (int_of_kbval c)) + end; + true + | PSRecv(c) -> + let q = Hashtbl.find chans (int_of_kbval c) in + if not (Queue.is_empty q) then + proc.xstatus <- PSExecRecvd (Queue.pop q); + true + +let exec_program p = + let proc0 = { + xspawn = spawn; + xnewchan = newchan; + xprog = p; + xvals = Smap.empty; + xstatus = PSExec; + xpos = 0 + } in + proc0.xvals <- Smap.add framevar (VInt 0) proc0.xvals; + proc0.xvals <- Smap.add "stdout" (VInt 0) proc0.xvals; + proc := [ proc0 ]; + while List.length !proc > 0 do + proc := List.filter proc_step !proc; + proc := !proc_spawned @ !proc; + proc_spawned := []; + done + + diff --git a/khb/ksh_print.ml b/khb/ksh_print.ml new file mode 100644 index 0000000..6b0a7e3 --- /dev/null +++ b/khb/ksh_print.ml @@ -0,0 +1,53 @@ +open Khs_ast + +let rec expr_str = function + | EEmpty -> "()" + | EInt i -> string_of_int i + | EStr s -> "\"" ^ s ^ "\"" + | EBool b -> if b then "true" else "false" + | EFrame -> "#" + | ELocal s -> "." ^ s + | EBinary (e1, op, e2) -> + "(" ^ expr_str e1 ^ + (match op with + | PLUS -> " + " + | MINUS -> " - " + | TIMES -> " * " + | DIV -> " / " + | MOD -> " % " + | EQUAL -> " == " + | NEQUAL -> " != " + | GT -> " > " + | LT -> " < " + | GE -> " >= " + | LE -> " <= " + | AND -> " && " + | OR -> " || " + | XOR -> " ^^ " + ) ^ expr_str e2 ^ ")" + | EUnary (op, e) -> + (match op with + | MINUS -> "-" + | NOT -> "!" + ) ^ expr_str e + | ETernary(c, a, b) -> + "(" ^ expr_str c ^ " ? " ^ expr_str a ^ " : " ^ expr_str b ^ ")" + | ECat(x, y) -> expr_str x ^ "\\" ^ expr_str y + | ELoad(v) -> "@" ^ expr_str v + | ENewChan -> "<>" + +let print_stmt = function + | SLabel s -> Format.printf "%s:@." s + | SSet(k, v) -> Format.printf " %s := %s@." (expr_str k) (expr_str v) + | SGoto l -> Format.printf " < %s >@." (expr_str l) + | SPar l -> Format.printf " | %s |@." (expr_str l) + | SRecv (e, c) -> Format.printf " %s << %s@." (expr_str e) (expr_str c) + | SSend (e, c) -> Format.printf " %s >> %s@." (expr_str e) (expr_str c) + | SUnset l -> + let rec aux = function + | [] -> " ~(" + | [a] -> " ~(" ^ (expr_str a) + | a::b -> (aux b) ^ ", " ^ (expr_str a) + in Format.printf "%s)@." (aux l) + | SExit -> + Format.printf " exit@." diff --git a/khb/test.khb b/khb/test.khb new file mode 100644 index 0000000..f109016 --- /dev/null +++ b/khb/test.khb @@ -0,0 +1,67 @@ +$$ integers (n, nmax, qo) = + (n > nmax ? + (-1) >> qo + : + n >> qo; + become integers(n+1, nmax, qo) + ) + +# Version alternative : +$$ integers (n, nmax, qo) = + ]->[ ( + (n > nmax ? ->[]); + n >> qo; + n = n + 1 + ); + -1 >> qo + +$$ filter (n, qi, qo) = + val << qi; + (val != -1 ? + (val % n != 0 ? + val >> qo + ); + become filter(n, qi, qo) + : + -1 >> qo + ) + +# Version alternative : +$$ filter (n, qi, qo) = + ]->[ ( + val << qi; + (val == -1 ? ->[]); + (val % n != 0 ? val >> qo) + ); + -1 >> qo + +$$ primes (qi) = + val << qi; + (val != -1 ? + val >> stdout; + c = <>; + | become filter(val, qi, c.out) |; + become primes(c.in) + ) + +# Version alternative : +$$ primes (qi) = + ]->[ ( + val << qi; + (val == -1 ? ->[]); + val >> stdout; + c = <>; + | filter(val, qi, c.out) |; + qi = c.in + ) + +$$ main () = + c = <>; + | integers (2, 5000, c.out) |; + primes (c.in) + + + + + + diff --git a/khb/test.khs b/khb/test.khs new file mode 100644 index 0000000..54b9507 --- /dev/null +++ b/khb/test.khs @@ -0,0 +1,76 @@ +proc_integers: + < @fd[f].n > @fd[f].nmax ? _then1 : _else1 > +_then1: + -1 >> @fd[f].qo + < _end1 > +_else1: + @fd[f].n >> @fd[f].qo + fd[f].trtmp.n := @fd[f].n + 1 + fd[f].trtmp.nmax := @fd[f].nmax + fd[f].trtmp.qo := @fd[f].qo + fd[f].n := @fd[f].trtmp.n + fd[f].nmax := @fd[f].trtmp.nmax + fd[f].qo := @fd[f].trtmp.qo + < proc_integers > + < _end1 > +_end1: + fd[f] := "" + ~ (.qo, .nmax, .n) + < @fd[f].return > + + proc_filter: + val << @(fd\@f\qi) + < @val != -1 ? _then2 : _else2 > +_then2: + < @val % @(fd\@f\n) != 0 ? _then3 : _end3 > +_then3: + @val >> @(fd\@f\qo) +_end3: + + <_end2> +_else2: + -1 >> @qo + <_end2> +_end2: + fd[f] := "" + ~ (.qo, .qi, .val, .n) + < @(fd\@f\return) > + +proc_primes: + .val << @.qi + < @.val != -1 ? _then4 : _end4 > +_then4: + @.val >> @stdout + .c := <> + | _par_1 | + .qi := @(.c\in) + +_end4: + fd\@f := "" + ~ (.val, .qi, .c) + < @(fd\@f\return) > +_par_1: + .n := @.val + .qo := @(.c\out) + + +proc_main: + .c := <> + | _par_2 | + fd\(@f+1)\qi := @(.c\in) + f := @f+1 + .return := _ret1 + +_ret1: + f := @f-1 + .tmp_retval := @(fd\(@f+1)) + fd\@f := .tmp_retval + ~(.tmp_retval) + < .return > +_par_2: + .n := 2 + .nmax := 5000 + .qo := @(.c\out) + + + diff --git a/khb/test.ml b/khb/test.ml new file mode 100644 index 0000000..68e3697 --- /dev/null +++ b/khb/test.ml @@ -0,0 +1,101 @@ +open Khs_ast +open Khs_exec + +let primes_khs = [| + SGoto (EStr "proc_main"); + + (* integers *) + SLabel "proc_integers"; + SGoto ( + ETernary( + EBinary(ELoad(ELocal "n"), GT, ELoad(ELocal "nmax")), + EStr "_then1", EStr "_else1")); + + SLabel "_then1"; + SSend(EInt (-1), ELocal "qo"); + SGoto(EStr "_end1"); + + SLabel "_else1"; + SSend(ELoad(ELocal "n"), ELocal "qo"); + SSet(ELocal "n", + EBinary(ELoad(ELocal "n"), PLUS, EInt 1)); + SGoto (EStr "proc_integers"); + + SLabel "_end1"; + SSet(ELocal "retval", EEmpty); + SUnset [ELocal "qo"; ELocal "nmax"; ELocal "n"]; + SGoto(ELoad(ELocal "retpos")); + + (* filter *) + SLabel "proc_filter"; + SRecv(ELocal "val", ELocal "qi"); + SGoto(ETernary( + EBinary(ELoad(ELocal "val"), NEQUAL, EInt (-1)), + EStr "_then2", EStr "_else2")); + + SLabel "_then2"; + SGoto(ETernary( + EBinary(EBinary(ELoad(ELocal "val"), MOD, ELoad(ELocal "n")), NEQUAL, EInt 0), + EStr "_then3", EStr "_end3")); + + SLabel "_then3"; + SSend(ELoad(ELocal "val"), ELocal "qo"); + + SLabel "_end3"; + SGoto(EStr "proc_filter"); + + SLabel "_else2"; + SSend(EInt (-1), ELocal "qo"); + + SSet(ELocal "retval", EEmpty); + SUnset[ELocal "qo"; ELocal "qi"; ELocal "val"; ELocal "n"]; + SGoto(ELoad(ELocal "retpos")); + + (* primes *) + SLabel "proc_primes"; + SRecv(ELocal "val", ELocal "qi"); + SGoto(ETernary( + EBinary(ELoad(ELocal "val"), NEQUAL, EInt(-1)), + EStr "_then4", EStr "_end4")); + + SLabel "_then4"; + SSend(ELoad(ELocal "val"), EStr "stdout"); + SSet(ELocal "c", ENewChan); + SPar(EStr "_par_1"); + SSet(ELocal "qi", ELoad(ECat(ELocal "c", EStr "in"))); + SGoto(EStr "proc_primes"); + + SLabel "_end4"; + SSet(ELocal "retval", EEmpty); + SUnset[ELocal "qi"; ELocal "val"; ELocal "c"]; + SGoto(ELoad(ELocal "retpos")); + + SLabel "_par_1"; + SSet(ELocal "n", ELoad(ELocal "val")); + SSet(ELocal "qo", ELoad(ECat(ELocal "c", EStr "out"))); + SGoto(EStr "proc_filter"); + + + (* main *) + SLabel "proc_main"; + SSet(ELocal "c", ENewChan); + SPar(EStr "_par_2"); + + SSet(ELocal "qi", ELoad(ECat(ELocal "c", EStr "in"))); + SSet(ELocal "retpos", EStr "_ret1"); + SGoto(EStr "proc_primes"); + + SLabel "_par_2"; + SSet(ELocal "n", EInt 2); + SSet(ELocal "nmax", EInt 3000); + SSet(ELocal "qo", ELoad(ECat(ELocal "c", EStr "out"))); + SSet(ELocal "retpos", EStr "_ret1"); + SGoto(EStr "proc_integers"); + + SLabel "_ret1"; + SExit; +|] + +let () = + Array.iter Ksh_print.print_stmt primes_khs; + Khs_exec_seq.exec_program (load_program primes_khs) diff --git a/khb/util.ml b/khb/util.ml new file mode 100644 index 0000000..0d278d6 --- /dev/null +++ b/khb/util.ml @@ -0,0 +1,10 @@ + +module Int = struct + type t = int + let compare = Pervasives.compare +end + +module Smap = Map.Make(String) +module Imap = Map.Make(Int) + +let (^^) a b = (a || b) && (not (a && b)) diff --git a/projet.pdf b/projet.pdf new file mode 100644 index 0000000..c890dd6 Binary files /dev/null and b/projet.pdf differ diff --git a/projet.tgz b/projet.tgz new file mode 100644 index 0000000..948028b Binary files /dev/null and b/projet.tgz differ diff --git a/src/Makefile b/src/Makefile new file mode 100644 index 0000000..ed9aa69 --- /dev/null +++ b/src/Makefile @@ -0,0 +1,19 @@ +OCAMLBUILD=ocamlbuild -classic-display \ + -tags annot,debug,thread \ + -libs unix +TARGET=native + +primes: + $(OCAMLBUILD) primes.$(TARGET) + +example: + $(OCAMLBUILD) example.$(TARGET) + + +clean: + $(OCAMLBUILD) -clean + +realclean: clean + rm -f *~ + +cleanall: realclean diff --git a/src/example.ml b/src/example.ml new file mode 100644 index 0000000..a22f1b9 --- /dev/null +++ b/src/example.ml @@ -0,0 +1,32 @@ +module Example (K : Kahn.S) = struct + module K = K + module Lib = Kahn.Lib(K) + open Lib + + let integers nmax (qo : int K.out_port) : unit K.process = + let rec loop n = + if n > nmax then + K.put (-1) qo + else + (K.put n qo) >>= (fun () -> loop (n + 1)) + in + loop 2 + + let output (qi : int K.in_port) : unit K.process = + let rec loop () = + (K.get qi) >>= (fun v -> + if v <> -1 then + begin Format.printf "%d@." v; loop () end + else K.return ()) + in + loop () + + let main : unit K.process = + (delay K.new_channel ()) >>= + (fun (q_in, q_out) -> K.doco [ integers 10000 q_out ; output q_in ]) + +end + +module E = Example(Kahn.Seq) + +let () = E.K.run E.main diff --git a/src/kahn.ml b/src/kahn.ml new file mode 100644 index 0000000..91b251f --- /dev/null +++ b/src/kahn.ml @@ -0,0 +1,152 @@ +module type S = sig + type 'a process + type 'a in_port + type 'a out_port + + val new_channel: unit -> 'a in_port * 'a out_port + val put: 'a -> 'a out_port -> unit process + val get: 'a in_port -> 'a process + + val doco: unit process list -> unit process + + val return: 'a -> 'a process + val bind: 'a process -> ('a -> 'b process) -> 'b process + + val run: 'a process -> 'a +end + +module Lib (K : S) = struct + + let ( >>= ) x f = K.bind x f + + let delay f x = + K.bind (K.return ()) (fun () -> K.return (f x)) + + let par_map f l = + let rec build_workers l (ports, workers) = + match l with + | [] -> (ports, workers) + | x :: l -> + let qi, qo = K.new_channel () in + build_workers + l + (qi :: ports, + ((delay f x) >>= (fun v -> K.put v qo)) :: workers) + in + let ports, workers = build_workers l ([], []) in + let rec collect l acc qo = + match l with + | [] -> K.put acc qo + | qi :: l -> (K.get qi) >>= (fun v -> collect l (v :: acc) qo) + in + let qi, qo = K.new_channel () in + K.run + ((K.doco ((collect ports [] qo) :: workers)) >>= (fun _ -> K.get qi)) + +end + + +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 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 + +module Seq: S = struct + type 'a process = (('a -> unit) option) -> unit + + type 'a channel = 'a Queue.t + type 'a in_port = 'a channel + type 'a out_port = 'a channel + + type task = unit -> unit + + let tasks = Queue.create () + + let new_channel () = + let q = Queue.create () in + q, q + + let put x c = + fun cont -> + Queue.push x c; + match cont with + | None -> () + | Some cont -> Queue.push cont tasks + + let rec get c = + fun cont -> + try + let v = Queue.pop c in + match cont with + | None -> () + | Some cont -> Queue.push (fun () -> cont v) tasks + with Queue.Empty -> + Queue.push (fun () -> get c cont) tasks + + let doco l = + fun cont -> + List.iter (fun proc -> Queue.push (fun () -> proc None) tasks) l; + match cont with + | None -> () + | Some cont -> Queue.push cont tasks + + let return v = + fun cont -> + match cont with + | None -> () + | Some cont -> Queue.push (fun () -> cont v) tasks + + let bind e f = + fun cont -> + Queue.push (fun () -> e (Some (fun r -> f r cont))) tasks + + let run e = + let ret = ref None in + e (Some (fun v -> ret := Some v)); + while not (Queue.is_empty tasks) do + let task = Queue.pop tasks in + task () + done; + match !ret with + | Some k -> k + | None -> assert false + +end + diff --git a/src/primes.ml b/src/primes.ml new file mode 100644 index 0000000..0911f31 --- /dev/null +++ b/src/primes.ml @@ -0,0 +1,42 @@ +module Primes (K : Kahn.S) = struct + module K = K + module Lib = Kahn.Lib(K) + open K + open Lib + + let integers nmax (qo : int out_port) : unit process = + let rec loop n = + if n > nmax then + put (-1) qo + else + (put n qo) >>= (fun () -> loop (n+1)) + in + loop 2 + + let filter n (qi : int in_port) (qo : int out_port) : unit process = + let rec loop () = + (get qi) >>= (fun v -> + if v <> -1 then + (if v mod n = 0 then return () else put v qo) >>= loop + else + put v qo) + in loop() + + let rec primes (qi : int in_port) : unit process = + (get qi) >>= (fun v -> + if v <> -1 then begin + Format.printf "%d@." v; + (delay new_channel ()) >>= + (fun (qi2, qo2) -> doco [ filter v qi qo2 ; primes qi2 ]) + end else return ()) + + let main : unit process = + (delay new_channel ()) >>= + (fun (q_in, q_out) -> doco [ integers 5000 q_out ; primes q_in ]) + +end + +module P = Primes(Kahn.Seq) + +let () = P.K.run P.main + -- cgit v1.2.3