First commit

18 files changed, 1000 insertions, 0 deletions

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:
+    <proc_filter>
+    <_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)
+    <proc_primes>
+_end4:
+    fd\@f := ""
+    ~ (.val, .qi, .c)
+    < @(fd\@f\return) >
+_par_1:
+    .n := @.val
+    .qo := @(.c\out)
+    <proc_filter>
+
+proc_main:
+    .c := <>
+    | _par_2 |
+    fd\(@f+1)\qi := @(.c\in)
+    f := @f+1
+    .return := _ret1
+    <proc_primes>
+_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)
+    <proc_integers>
+
+
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
--- /dev/null
+++ b/projet.pdf
diff --git a/projet.tgz b/projet.tgz
new file mode 100644
index 0000000..948028b
--- /dev/null
+++ b/projet.tgz
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
+