Restored join-compilation with simplified typedtree

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/jo400@12889 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

14 files changed, 400 insertions, 339 deletions

diff --git a/boot/ocamlc b/boot/ocamlc
index fbc4ec1bf4..b51e40827d 100755
--- a/boot/ocamlc
+++ b/boot/ocamlc
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index a793a1e2a7..5f9e7553c5 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -32,6 +32,23 @@ type error =
 
 exception Error of Location.t * error
 
+(* Optimisation of channnel send/calls,
+   Done with side effect so as not to distroy code structure *)
+
+let chan_env = ref (Ident.empty)
+
+let add_chan_env ids =
+  chan_env :=
+    List.fold_left
+      (fun k (id,x) -> Ident.add id x k)
+      !chan_env
+      ids
+
+let get_chan_env id =
+  try Some (Ident.find_same id !chan_env)
+  with Not_found -> None
+
+
 (* Forward declaration -- to be filled in by Translmod.transl_module *)
 let transl_module =
   ref((fun cc rootpath modl -> assert false) :
@@ -631,7 +648,7 @@ and transl_exp0 e =
       raise(Error(e.exp_loc, Free_super_var))
   | Texp_ident
       (path, _,
-       {val_kind = Val_reg|Val_self _|Val_channel (_,_)|Val_alone _}) ->
+       {val_kind = Val_reg|Val_self _}) ->
       transl_path path
   | Texp_ident _ -> fatal_error "Translcore.transl_exp: bad Texp_ident"
   | Texp_constant cst ->
@@ -641,8 +658,8 @@ and transl_exp0 e =
         rec_flag pat_expr_list (event_before body (transl_exp body))
 (*> JOCAML *)
   | Texp_def (d,body) ->
-      do_transl_def d (transl_exp body)
-(*>JOCAML*)
+      do_transl_def d (fun () -> transl_exp body)
+(*<JOCAML*)
   | Texp_function (_, pat_expr_list, partial) ->
       let ((kind, params), body) =
         event_function e
@@ -651,20 +668,6 @@ and transl_exp0 e =
             transl_function e.exp_loc !Clflags.native_code repr partial pl)
       in
       Lfunction(kind, params, body)
-(* two small optimizations *)
-  | Texp_apply
-      ({exp_desc = Texp_ident(path, _, {val_kind = Val_alone id})},
-       [_,Some arg,_])
-      ->
-        Lapply (Lvar id,[transl_exp arg],e.exp_loc)
-  | Texp_apply
-      ({exp_desc = Texp_ident(path, _, {val_kind = Val_channel (auto,idx)})},
-       [_,Some arg,_])
-      ->
-        Transljoin.local_send_sync
-	  auto idx (transl_exp arg)
-	  e.exp_loc
-(*<JOCAML*)
   | Texp_apply({exp_desc = Texp_ident(path, _, {val_kind = Val_prim p})}, oargs)
     when List.length oargs >= p.prim_arity
     && List.for_all (fun (_, arg,_) -> arg <> None) oargs ->
@@ -703,7 +706,24 @@ and transl_exp0 e =
             end
       end
   | Texp_apply(funct, oargs) ->
-      event_after e (transl_apply (transl_exp funct) oargs e.exp_loc)
+(* two small optimizations *)
+      begin match funct.exp_desc,oargs with
+      | Texp_ident(Pident id, _, {val_kind = Val_reg}),
+         [_,Some arg,_] ->
+           begin match get_chan_env id with
+           | Some (Alone id) ->
+               Lapply (Lvar id,[transl_exp arg],e.exp_loc)
+           | Some (Chan (id,idx)) ->
+               Transljoin.local_send_sync
+	         id idx (transl_exp arg)
+	         e.exp_loc
+           | None ->
+               event_after e
+                 (transl_apply (transl_exp funct) oargs e.exp_loc)
+           end
+      | _,_ ->
+          event_after e (transl_apply (transl_exp funct) oargs e.exp_loc)
+      end
   | Texp_match({exp_desc = Texp_tuple argl}, pat_expr_list, partial) ->
       Matching.for_multiple_match (id_lam,e.exp_loc)
         (transl_list transl_exp argl)
@@ -930,7 +950,7 @@ and transl_proc die sync p = match p.exp_desc with
       (fun e -> Transljoin.reply_handler sync p transl_exp e)
       rec_flag pat_expr_list (transl_proc die sync body)
 | Texp_def (d,body) ->
-    do_transl_def d (transl_proc die sync body)
+    do_transl_def d (fun () -> transl_proc die sync body)
 | Texp_ifthenelse(cond, ifso, Some ifnot) ->
     Lifthenelse
       (Transljoin.reply_handler sync p transl_exp cond,
@@ -1012,7 +1032,7 @@ and transl_simple_proc die sync p = match p.exp_desc with
       transl_exp
       rec_flag pat_expr_list (transl_simple_proc die sync body)
 | Texp_def (d,body) ->
-    do_transl_def d (transl_simple_proc die sync body)
+    do_transl_def d (fun () -> transl_simple_proc die sync body)
 | Texp_ifthenelse(cond, ifso, Some ifnot) ->
     Lifthenelse
       (transl_exp cond,
@@ -1045,19 +1065,25 @@ and transl_simple_proc die sync p = match p.exp_desc with
     make_sequence
       (transl_simple_proc false sync p1)
       (transl_simple_proc die sync p2)
-| Texp_asyncsend
-    ({exp_desc=Texp_ident (_,_,{val_kind=Val_channel (auto,num)})},e2) ->
-      (if die then Transljoin.local_tail_send_async
-      else Transljoin.local_send_async)
-        auto num (transl_exp e2) p.exp_loc
-| Texp_asyncsend
-    ({exp_desc=Texp_ident (_,_,{val_kind=Val_alone (guard)})},e2) ->
-      (if die then Transljoin.local_tail_send_alone
-      else Transljoin.local_send_alone)
-        guard (transl_exp e2) p.exp_loc
 | Texp_asyncsend (e1,e2) ->
-    (if die then Transljoin.tail_send_async else Transljoin.send_async)
-      (transl_exp e1) (transl_exp e2) p.exp_loc
+    let default e1 e2 =
+      (if die then Transljoin.tail_send_async else Transljoin.send_async)
+      (transl_exp e1) (transl_exp e2) p.exp_loc in
+    begin match e1.exp_desc with
+    | Texp_ident (Pident id,_,{val_kind=Val_reg}) ->
+        begin match get_chan_env id with
+        | Some (Alone id) ->
+            (if die then Transljoin.local_tail_send_alone
+            else Transljoin.local_send_alone)
+              id (transl_exp e2) p.exp_loc
+        | Some (Chan (id,idx)) ->
+            (if die then Transljoin.local_tail_send_async
+            else Transljoin.local_send_async)
+              id idx (transl_exp e2) p.exp_loc
+        | None -> default e1 e2
+        end
+    | _ -> default e1 e2
+    end
 | Texp_reply (e, id) ->
     begin match sync with
     | Some main_id when main_id = id -> transl_exp e
@@ -1080,7 +1106,7 @@ and transl_simple_proc die sync p = match p.exp_desc with
 
 (* Parameter list for a guarded process *)
 
-and transl_reaction (name,_) (Reac reac) =
+and transl_reaction (name,_) reac =
   let (x, _ , actuals, idpats, p) = reac in
 (* Principal continuation, as computed by typing *)
   let sync = Transljoin.principal p in
@@ -1119,14 +1145,15 @@ and transl_reaction (name,_) (Reac reac) =
   x, sync, lam
 
 and transl_dispatcher disp = 
-  let Disp (d_id, chan, cls, partial) = disp in
+  let d_id, (chan,_) , cls, partial = disp in
   let z = Ident.create "#z#" in
-  let rhs chan =
-    if chan.jchannel_sync then match  chan.jchannel_id with
+
+  let rhs (chan,opt) =
+    if chan.jchannel_sync then match opt with
     | Chan (name, i) ->
         Transljoin.local_send_sync name i (Lvar z) Location.none
     | Alone g -> Lapply (Lvar g, [Lvar z],Location.none)
-    else match chan.jchannel_id with
+    else match opt with
     | Chan (name, i) ->
         Transljoin.local_tail_send_async name i
           (Lvar z)  Location.none
@@ -1136,28 +1163,28 @@ and transl_dispatcher disp =
   let body =
     try
       let allchans =
-          List.map
-            (fun (p, chan) -> match chan.jchannel_id with
-            | Chan (auto,i) -> auto,(p,i)
-            | Alone _ -> raise Exit)
-            cls in
-        match allchans with
-        | [] -> assert false
-        | (auto,_)::_ ->
-            let cls =
-              List.map
-                (fun (_,(p,i)) ->
-                  p,Lconst (Const_base (Const_int i)))
-                allchans in
-            (if chan.jchannel_sync then
-              Transljoin.local_send_sync2
-            else
-              Transljoin.local_tail_send_async2)
-              auto
-              (Matching.for_function
-                 (id_lam,Location.none) None (Lvar z)
-                 cls partial)
-              (Lvar z)
+        List.map
+          (fun (p, (chan,opt)) -> match opt with
+          | Chan (auto,i) -> auto,(p,i)
+          | Alone _ -> raise Exit)
+          cls in
+      match allchans with
+      | [] -> assert false
+      | (auto,_)::_ ->
+          let cls =
+            List.map
+              (fun (_,(p,i)) ->
+                p,Lconst (Const_base (Const_int i)))
+              allchans in
+          (if chan.jchannel_sync then
+            Transljoin.local_send_sync2
+          else
+            Transljoin.local_tail_send_async2)
+            auto
+            (Matching.for_function
+               (id_lam,Location.none) None (Lvar z)
+               cls partial)
+            (Lvar z)
     with Exit ->
       let cls = List.map (fun (p, chan) -> p, rhs chan) cls in
       Matching.for_function
@@ -1166,7 +1193,7 @@ and transl_dispatcher disp =
   let lam =  Lfunction (Curried, params, body) in
   d_id, chan, lam
 
-and transl_forwarder (Fwd reac) =
+and transl_forwarder reac =
   let (x, jpat, _, idpats, p) = reac in
   let sync = Transljoin.principal p in
   let body =
@@ -1327,16 +1354,27 @@ and transl_let reply_handler transl_exp rec_flag pat_expr_list body =
       Lletrec(List.map2 transl_case pat_expr_list idlist, body)
 (*> JOCAML *)
 
-and do_transl_def autos body =
-      
+(* Compile pattern matching in join patterns *)
+
+and do_transl_def autos kbody =
+(* Precompile automata, this includes PM compilation *)
+  let autos = List.map Transljoin.compile_auto autos in
+(* Add info and compile body *)
+  let saved_chan_env = !chan_env in
+  List.iter
+    (fun a ->
+      add_chan_env
+        (List.map (fun (id,(_,opt)) ->id,opt) a.cauto_original))
+    autos ;
+  let body = kbody () in
 (* compile (and name) real guarded processes *)
   let reactions =
     List.map
       (fun auto ->
-        if auto.jauto_nchans = 0 then []
+        if auto.cauto_nchans = 0 then []
         else
-          let _,reacs,_ = auto.jauto_desc in
-          List.map (transl_reaction auto.jauto_name) reacs)
+          let reacs = auto.cauto_reactions in
+          List.map (transl_reaction auto.cauto_name) reacs)
       autos in
 
 (* compile firing of guarded processes (aka automaton table) *)
@@ -1358,13 +1396,13 @@ and do_transl_def autos body =
   let disps =
     List.map
       (fun auto ->
-        let disps,_,_ = auto.jauto_desc in
+        let disps = auto.cauto_dispatchers in
         List.map transl_dispatcher disps)
       autos
   and fwds =
     List.map
       (fun auto ->
-        let _,_,fwds = auto.jauto_desc in
+        let fwds = auto.cauto_forwarders in
         List.map transl_forwarder fwds)
       autos in
   let r =
@@ -1376,11 +1414,11 @@ and do_transl_def autos body =
       Transljoin.create_forwarders autos disps fwds r in
 
 (* create channels structures *)
-  let r =
-    List.fold_right Transljoin.create_channels autos r in
+  let r = List.fold_right Transljoin.create_channels autos r in
 (* create automata structures *)
-  let r =
-    List.fold_right Transljoin.create_auto autos r in
+  let r = List.fold_right Transljoin.create_auto autos r in
+(* Restore channel env *)
+  chan_env := saved_chan_env ;
   r
 
 
@@ -1455,7 +1493,7 @@ and transl_record all_labels repres lbl_expr_list opt_init_expr =
 
 (*> JOCAML *)
 (* For external usage *)
-let transl_def d k = do_transl_def d k
+let transl_def d k = do_transl_def d (fun () -> k)
 and transl_let = transl_let id_lam transl_exp
 (*< JOCAML *)
 
diff --git a/bytecomp/transljoin.ml b/bytecomp/transljoin.ml
index ff8267e7d8..7007771a27 100644
--- a/bytecomp/transljoin.ml
+++ b/bytecomp/transljoin.ml
@@ -421,14 +421,130 @@ let as_procs sync e =
 let rec get_chan_rec id = function
  | [] -> raise Not_found
  | (oid,x)::rem ->
-     if id = oid then x else get_chan_rec id rem
+     if Ident.same id oid then x else get_chan_rec id rem
 
-let dump_idx fp (id, _) = fprintf fp "%s" (Ident.unique_name id)
+open Printf
+
+let dump_chan fp chan =
+  fprintf fp "{id=%s, sync=%b}"
+    (Ident.unique_name chan.jchannel_ident)
+    chan.jchannel_sync
 
+let compile_auto a =
+(*
+  eprintf "AUTO:" ;
+  List.iter (fun (_,chan) -> eprintf " %a" dump_chan chan) a.jauto_names ;
+  eprintf "\n%!" ;
+*)
+  let get_chan tag id =
+    try get_chan_rec id a.jauto_names
+    with Not_found ->
+      fatal_error
+        (Printf.sprintf "Transljoin.compile_auto [%s]: %s" tag
+           (Ident.unique_name id)) in
+          
+  let (disps, reacs), new_names = 
+    Joinmatching.compile a.jauto_loc
+      (List.map
+         (fun cl ->
+           let jpats,g = cl.jclause_desc in
+           cl.jclause_loc,jpats,g)
+         a.jauto_desc) in
+(* Allocate new names for dispatchers and guarded processes *)
+  let disps =  List.map (fun disp -> Ident.create "#d#", disp) disps
+  and reacs,fwds = match reacs with
+  | [((_,[_],_),_) as reac] -> (* Case of (single) forwarder *)
+      [],[Ident.create "#f", reac]
+  | _ ->
+      List.map (fun reac -> Ident.create "#g#", reac) reacs, [] in
+(* Automaton names *)
+   let name = Ident.create "#auto#"
+   and name_wrapped = Ident.create "#wrapped#" in
+(* Collect forwarders *)
+  let fwd_names =
+    List.map
+      (fun (d_id,(id,_,_)) ->
+        let chan = get_chan "dispatchers" id in
+        id,(chan,(Alone d_id)))
+      disps in
+  let fwd_names =
+    List.fold_right
+      (fun fwd r ->
+        let g_id,(_old,(patss,_gd)) = fwd in
+         List.fold_right
+          (fun pats r ->
+            List.fold_right
+              (fun pat r ->
+                let jid,_ = pat.jpat_desc in
+                let id = jid.jident_desc in
+                let chan = get_chan "forwarders" id in
+                (id,(chan,Alone g_id))::r)
+              pats r)
+          patss r)
+      fwds fwd_names in
+(* Collect channels *)
+  let is_fwd id =
+    try ignore(get_chan_rec id fwd_names) ; true
+    with Not_found -> false in
+
+(* First orignal names unsplit by compilation, and not a forwarder *)
+  let all_names,nchans =
+    List.fold_right
+      (fun (id,chan) (chans,nchans as k) ->
+        if is_fwd id then k
+        else
+          (id,(chan,Chan (name,nchans)))::chans,nchans+1)
+      a.jauto_names (fwd_names,0) in
+(* Then new names, introduced by pattern matching compilation *)
+  let all_names,nchans =
+     List.fold_right
+      (fun (id,ids) k ->
+        let chan = get_chan "old_name" id in
+        List.fold_right
+          (fun id (chans,nchans) ->
+            let chan = { chan with jchannel_ident = id} in
+            (id,(chan,Chan (name,nchans)))::chans,nchans+1)
+          ids k)
+      new_names (all_names,nchans) in
+(* Original names, with information *)
+  let is_orig id =
+     try ignore(get_chan_rec id a.jauto_names) ; true
+    with Not_found -> false in
+  let original = List.filter (fun (id,_) -> is_orig id) all_names in
+(* Precompile dispatchers *)
+  let disps =
+    let find_channel id =
+      try get_chan_rec id all_names
+      with Not_found ->
+        fatal_error
+        (Printf.sprintf "find_channel: %s"
+           (Ident.unique_name id)) in
+    List.map
+      (fun disp ->
+        let d_id,(chan_id, cls, par) = disp in
+        let chan = find_channel chan_id
+        and cls = List.map (fun (p,id) -> p,find_channel id) cls in
+        d_id,chan,cls,par)
+      disps in
+(* Precompile reactions, little to do: flatten *)
+  let precomp_reac (id,((_loc,pat,e),(pats,bv))) = id,pat,pats,bv,e in
+  let fwds = List.map precomp_reac fwds
+  and reacs = List.map precomp_reac reacs in
+(* Gather everything... *)
+  {
+    cauto_name = name,name_wrapped;
+    cauto_channels = all_names;
+    cauto_nchans = nchans;
+    cauto_original = original;
+    cauto_loc = a.jauto_loc;
+    cauto_dispatchers = disps;
+    cauto_forwarders = fwds;
+    cauto_reactions = reacs;
+  }
 let get_num msg names id =
  try
-   let {jchannel_id=x} = get_chan_rec id names in
-   match x with
+   let _,opt = get_chan_rec id names in
+   match opt with
    | Chan (_,num) -> num
    | _ ->
      fatal_error
@@ -441,8 +557,8 @@ let get_num msg names id =
 
 let get_chan msg names id =
   try
-   let {jchannel_id=x} = get_chan_rec id names in
-   x
+   let _,opt = get_chan_rec id names in
+   opt
  with
  | Not_found ->
      fatal_error
@@ -464,17 +580,18 @@ let rec principal_param ipri params nums = match params, nums with
 let names_block nchans names =
   let t = Array.create nchans "" in
   List.iter
-    (fun (id, {jchannel_id=x}) ->match x with
-    | Chan (_,i) -> t.(i) <- Ident.unique_name id
-    | _ -> ())
+    (fun (id, (_,opt)) ->
+      match opt with
+      | Chan (_,i) -> t.(i) <- Ident.unique_name id
+      | _ -> ())
     names ;
   Lconst
     (Const_block
        (0, Array.fold_right (fun s r -> Const_base (Const_string s)::r) t []))
 
 let create_auto
-   { jauto_name=(auto_name, wrapped_name);
-     jauto_names = names ; jauto_nchans=nchans ; } k =
+   { cauto_name=(auto_name, wrapped_name);
+     cauto_channels = names ; cauto_nchans=nchans ; } k =
   if nchans > 0 then
     Llet
       (Strict, auto_name,
@@ -485,15 +602,14 @@ let create_auto
          (Strict, wrapped_name, wrap_automaton auto_name Location.none, k))
   else k
 
-let create_channels {jauto_name=(raw_name, name) ; jauto_names=names} k =
+let create_channels {cauto_name=(raw_name, name) ; cauto_channels=names} k =
   List.fold_right
-    (fun (id,jc) k ->
-      let {jchannel_sync=sync ; jchannel_id=x} = jc in
-      match x with
+    (fun (id,(jc,opt)) k ->
+      match opt with
       | Chan (_,num) ->
 	  Llet
 	    (StrictOpt, id,
-	     (if sync then
+	     (if jc.jchannel_sync then
                create_sync
 	     else
                create_async) name num Location.none,
@@ -543,10 +659,10 @@ let create_forwarders autos dispss fwdss r =
     List.fold_right
       (fun auto r ->
         List.fold_right
-          (fun (_,chan) r -> match chan.jchannel_id with
+          (fun (_,(chan,opt)) r -> match opt with
           | Alone g -> make_g "fwd" chan g::r
           | Chan (_,_) -> r)
-          auto.jauto_names r)
+          auto.cauto_channels r)
       autos id2g in
 (* patch forwarder data structure *)
    let r =
@@ -707,13 +823,13 @@ let lapply (f,args) = Lapply (f,args,Location.none)
 (* gs is a list of compiled guarded processes *)
 
 let create_table auto gs r =
-  let n_chans = auto.jauto_nchans in
+  let n_chans = auto.cauto_nchans in
   if n_chans =0 then r
   else
-    let name,_ = auto.jauto_name (* wrapped name of automaton *)
-    and names = auto.jauto_names in (* all channels *)
+    let name,_ = auto.cauto_name       (* wrapped name of automaton *)
+    and names = auto.cauto_channels in (* all channels *)
 
-    let rec do_guard (Reac reac) (_, sync, _) k =
+    let rec do_guard reac (_, sync, _) k =
       let (g, _, actual, _, _) = reac in
 
       let create_reaction jpats r =
@@ -773,7 +889,7 @@ let create_table auto gs r =
       let pats = explode actual in
       List.fold_right create_reaction pats k in
 
-    let _, reacs, _ = auto.jauto_desc in
+    let reacs = auto.cauto_reactions in
     Lsequence
       (patch_table name
          (List.fold_right2 do_guard reacs gs []) Location.none,
diff --git a/bytecomp/transljoin.mli b/bytecomp/transljoin.mli
index 027f79ab66..e5066fb547 100644
--- a/bytecomp/transljoin.mli
+++ b/bytecomp/transljoin.mli
@@ -72,25 +72,27 @@ val principal : Typedtree.expression -> Ident.t option
 
 (* Building definitions and locations *)
 
+val compile_auto : Typedtree.joinautomaton -> Typedtree.compiledautomaton
+
 val create_auto : 
-  'a Typedtree.joinautomaton_gen ->
+  Typedtree.compiledautomaton ->
     Lambda.lambda -> Lambda.lambda
 
 val create_channels :
-  'a Typedtree.joinautomaton_gen -> Lambda.lambda -> Lambda.lambda
+    Typedtree.compiledautomaton -> Lambda.lambda -> Lambda.lambda
 
 val create_dispatchers :
      (Ident.t * Typedtree.joinchannel * Lambda.lambda) list ->
        Lambda.lambda -> Lambda.lambda
 
 val create_forwarders :
-    'a Typedtree.joinautomaton_gen list ->
+    Typedtree.compiledautomaton list ->
       (Ident.t * Typedtree.joinchannel * Lambda.lambda) list list ->
          (Ident.t * Lambda.lambda) list list ->
            Lambda.lambda -> Lambda.lambda
 
 val create_table:
-    Typedtree.joinautomaton ->
+    Typedtree.compiledautomaton ->
       (Ident.t * Ident.t option * 'a) list -> Lambda.lambda ->
       Lambda.lambda
             
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index a01c2d1308..9a30d22324 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -132,7 +132,7 @@ and joinautomaton =
 
 and joinclause =
     {pjclause_desc : joinpattern list * expression ;
-    pjclause_loc : Location.t}
+     pjclause_loc : Location.t}
 
 and joinpattern =
   { pjpat_desc: joinpattern_desc;
diff --git a/typing/env.ml b/typing/env.ml
index 8a4fc81d89..9a2c4a2e25 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -1101,13 +1101,6 @@ and add_continuation id desc env  =
 
 
 and remove_continuations t =  {t with continuations = EnvTbl.empty}
-
-let do_purge ((path,d),sl as c) = match d.val_kind with
-  | Val_channel _|Val_alone _ -> (path,{ d with val_kind = Val_reg; }),sl
-  | _ -> c
-
-let remove_channel_info t =
-  { t with values = EnvTbl.map do_purge t.values ; }
 (*< JOCAML *)
 
 let add_local_constraint id info elv env =
diff --git a/typing/env.mli b/typing/env.mli
index 9f551fd367..1fa00b77d7 100644
--- a/typing/env.mli
+++ b/typing/env.mli
@@ -94,8 +94,6 @@ val add_signature: signature -> t -> t
 (*> JOCAML *)
 val add_continuation: Ident.t -> continuation_description -> t -> t
 val remove_continuations: t -> t
-(* Erase channel information *)
-val remove_channel_info: t -> t
 (*< JOCAML *)
 
 (* Insertion of all fields of a signature, relative to the given path.
diff --git a/typing/joinmatching.ml b/typing/joinmatching.ml
index 411f04cfe3..853ff5acf1 100644
--- a/typing/joinmatching.ml
+++ b/typing/joinmatching.ml
@@ -57,7 +57,7 @@ let collect cls =
     | Not_found ->
         Hashtbl.add tbl_id_args jid.jident_desc [arg] in
 
-  let collect_clause ((_, jpats, _),_) =  List.iter collect_jpat jpats in
+  let collect_clause (_, jpats, _) =  List.iter collect_jpat jpats in
   List.iter collect_clause cls;
   let f id args ls = (id,args)::ls in
   Hashtbl.fold f tbl_id_args []
@@ -247,7 +247,7 @@ let y auto_loc ((disp, reac, new_names) as auto) id args =
 	  yfinal auto id par dag
       end
   | _ -> 
-      (* Compute all possible lubs of some patterns fromp pats
+      (* Compute all possible lubs of some patterns from pats
          ref. the F function in Step 1
          pattern list -> pattern list *)
       let rec compute_lubs pats =
@@ -280,15 +280,15 @@ type 'a reaction = Location.t * joinpattern list * 'a
 type dispatcher =
   Ident.t * (pattern * Ident.t) list * partial
 
-type ('a, 'b) guard =
-  ('a reaction * 'b) * (* old clause *)
+type 'a guard =
+  'a reaction  * (* old clause *)
   (joinpattern list list * (* new joinpattern *)
   (Ident.t * Typedtree.pattern) list) (* inserted matching *)
 
 let compile auto_loc cls =
   let name_args = collect cls
   and cls =
-    let trivial_clause (((_, jpats, _),_) as cl) =
+    let trivial_clause ((_, jpats, _) as cl) =
       cl, (jpats,[]), [] in
     List.map trivial_clause cls in
 
diff --git a/typing/joinmatching.mli b/typing/joinmatching.mli
index e9e6d73777..c1323d6e1f 100644
--- a/typing/joinmatching.mli
+++ b/typing/joinmatching.mli
@@ -27,13 +27,13 @@ type 'a reaction = Location.t * joinpattern list * 'a
 type dispatcher =
   Ident.t * (pattern * Ident.t) list * partial
 
-type ('a, 'b) guard =
-  ('a reaction * 'b) * (* old clause *)
+type 'a guard =
+  'a reaction  * (* old clause *)
   (joinpattern list list * (* new joinpattern *)
   (Ident.t * Typedtree.pattern) list) (* inserted matching *)
 
 val compile :
     Location.t (* location of automaton *)->
-    ('a reaction * 'b) list (* clauses *) ->
-      (dispatcher list * ('a, 'b) guard list) * (* compiled clauses *)
+    'a reaction  list (* clauses *) ->
+      (dispatcher list * 'a guard list) * (* compiled clauses *)
       (Ident.t * Ident.t list) list  (* new channels *)
diff --git a/typing/typecore.ml b/typing/typecore.ml
index c7c91ad7f6..ac816ecc2c 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -1035,7 +1035,7 @@ let reset_def scp =
   def_ids := []
 
 (* All channels defined by a join definition *)
-let auto_chans = ref ([] : (Ident.t * type_expr * Location.t * type_expr) list)
+let auto_chans = ref ([] : (Ident.t * type_expr * string loc * type_expr) list)
 let reset_auto () = auto_chans := []
 
 
@@ -1058,14 +1058,14 @@ let create_channel chan =
           raise (Error (chan.loc, Multiply_bound_variable name)) ;
         let id = Ident.create  name
         and ty =  newvar()
-	and loc = chan.loc
         and ty_arg = newvar() in
         def_ids := id :: !def_ids ;
-        auto_chans := (id, ty, loc, ty_arg) :: !auto_chans ;
+        auto_chans := (id, ty, chan, ty_arg) :: !auto_chans ;
 	begin
 	  match !def_scope with
 	  | None -> ()
-	  | Some s -> Stypes.record (Stypes.An_ident (loc, name, s));
+	  | Some s ->
+              Stypes.record (Stypes.An_ident (chan.loc, name, s));
 	end;
         (id, ty, ty_arg)
     | (id, ty, _,ty_arg)::rem ->
@@ -1084,10 +1084,10 @@ let enter_channel chan =
   reaction_chans := name :: !reaction_chans ;
   create_channel chan
 
-let mk_jident id loc ty env =
+let mk_jident id orig ty env =
   {
     jident_desc = id ;
-    jident_loc = loc;
+    jident_orig = orig;
     jident_type = ty;
     jident_env = env;
   }
@@ -1098,6 +1098,16 @@ let rec get_type id env = match env with
     if Ident.same id jd then ty,loc
     else get_type id env
 
+type auto_partly_typed =
+    { apt_loc : Location.t ;
+      apt_names : (Ident.t * Types.type_expr) list ;
+      apt_desc :
+        ((Location.t * Typedtree.joinpattern list * Parsetree.expression) *
+          ((Ident.t * Types.type_expr * string Asttypes.loc * Location.t *
+              bool)
+             list * (unit -> unit) list))
+        list ; }
+
 let type_auto_lhs tenv scope {pjauto_desc=sauto ; pjauto_loc=auto_loc}  =
 (* Type patterns *)
   reset_auto () ;
@@ -1111,7 +1121,7 @@ let type_auto_lhs tenv scope {pjauto_desc=sauto ; pjauto_loc=auto_loc}  =
             (fun sjpat ->
               let schan, sarg = sjpat.pjpat_desc in
               let (id, ty, ty_arg) =  enter_channel schan in
-              let chan = mk_jident id schan.loc ty tenv
+              let chan = mk_jident id schan ty tenv
               and arg =
                 let rtenv = ref tenv
                 and ty_pat = newvar () in
@@ -1126,65 +1136,10 @@ let type_auto_lhs tenv scope {pjauto_desc=sauto ; pjauto_loc=auto_loc}  =
         (get_ref pattern_variables, get_ref pattern_force))
       sauto in
 (* get orginal channel names now *)
-  let env =  get_ref auto_chans in (* get rid of [now useless] argument types *)
-  let original = List.map (fun (id,_,_,_) -> id) env in
-(* compile algebraic pattern in joinpatterns *)
-  let (disps, reacs), new_names = Joinmatching.compile auto_loc auto in
+  let env =  get_ref auto_chans in
 (* collect all names *)
-  let env = List.map (fun (id,ty,loc,_) -> id,ty,loc) env in
-  let env =
-    List.fold_right
-      (fun (id, ids) r ->
-        let ty,loc = get_type id env in
-        List.fold_right (fun id r -> (id,ty,loc)::r) ids r)
-      new_names env in
-(* allocate names for guarded processes *)
-  let disps =
-    List.map (fun disp -> Ident.create "#d#", disp) disps
-  and reacs, fwds = match reacs with
-  | [((_,[_],_),_),_ as reac] ->
-      [],[Ident.create "#f", reac]
-  | _ ->
-    List.map (fun reac -> Ident.create "#g#", reac) reacs, [] in
-
-(* collect forwarders *)
-  let alone_env =
-    List.map (fun (d_id,(id,_,_)) -> id, d_id) disps in
-  let alone_env =
-    List.fold_right
-      (fun fwd r -> match fwd with
-      | g_id,(_old,(patss,_gd)) ->
-          List.fold_right
-            (fun pats r ->
-              List.fold_right
-                (fun pat r ->
-                  let chan,_ = pat.jpat_desc in
-                  let id = chan.jident_desc in
-                  (id, g_id)::r)
-                pats r)
-            patss alone_env)
-      fwds alone_env in
-  
-(* automaton structure names *)
-  let name = Ident.create "#auto#"
-  and name_wrapped = Ident.create "#wrapped#" in
-(* Allocate channel slots *)
-  let auto_count = ref 0 in
-  let chan_names =
-    List.map
-      (fun (id, ty, _) ->
-        try
-          let g = List.assoc id alone_env in
-          id,(ty, Alone g)
-        with Not_found ->
-          let num = !auto_count in
-          incr auto_count ;
-          id, (ty, Chan (name,num)))
-      env in
-  auto_loc,
-  (name, name_wrapped),
-  (!auto_count, original, chan_names),
-  (disps, reacs, fwds)
+  let env = List.map (fun (id,ty,_,_) -> id,ty) env in
+  { apt_loc = auto_loc; apt_names = env; apt_desc = auto; }
 
 let rec do_type_autos_lhs env scope = function
   | [] -> []
@@ -3471,21 +3426,9 @@ and type_let ?(check = fun s -> Warnings.Unused_var s)
   (List.combine pat_list exp_list, new_env, unpacks)
 
 (*> JOCAML *)
-and type_dispatcher names disp =
-  let d_id,(chan_id, cls, par) = disp in
-
-  let find_channel id =
-    try List.assoc id names
-    with Not_found -> assert false in
-
-  let chan = find_channel chan_id
-  and cls =
-    List.map (fun (p,id) -> p, find_channel id) cls in
-  Disp (d_id, chan, cls, par)
     
-and type_clause env names reac =
-  let g_id,(old,(actual_pats, gd)) = reac in
-  let (loc_clause,jpats,sexp),(pat_vars,pat_force) = old in
+and type_clause env names cl =
+  let (loc_clause,jpats,sexp),(pat_vars,pat_force) = cl in
 
 (* First build environment for guarded process *)
   let conts = ref [] in
@@ -3498,7 +3441,8 @@ and type_clause env names reac =
     conts := kdesc :: !conts;
     Env.add_continuation kid kdesc env
 
-  and add_pat_var (id, ty, _name, loc, as_var) env = (* _name info forgotten *)
+  and add_pat_var (id, ty, _name, loc, as_var) env =
+    (* _name info forgotten *)
     let check =
       if as_var then  fun s -> Warnings.Unused_var s
       else fun s -> Warnings.Unused_var_strict s in
@@ -3526,7 +3470,7 @@ and type_clause env names reac =
       let chan, arg = jpat.jpat_desc in
       let tchan =
         try
-          let (ty,_) = List.assoc chan.jident_desc names in
+          let ty = List.assoc chan.jident_desc names in
           ty
         with Not_found -> assert false in
       let targ = arg.pat_type in
@@ -3552,48 +3496,34 @@ and type_clause env names reac =
           with Not_found -> assert false in
         jpat.jpat_kont := Some cont_id)
     jpats !conts ;
-  g_id, jpats, actual_pats, gd, exp
-
-and type_reac env names reac = Reac (type_clause env names reac)
-
-and type_fwd env names reac = Fwd (type_clause env names reac)
+  { jclause_loc = loc_clause ; jclause_desc = jpats, exp; }
 
-and type_auto env
-    (my_loc, my_names,
-     (nchans, original, def_names),
-     (disps,reacs,fwds)) =
+and type_auto env {apt_loc=my_loc; apt_names=def_names; apt_desc=cls; } =
   let env = Env.remove_continuations env in
-  let reacs = List.map (type_reac env def_names) reacs
-  and fwds =  List.map (type_fwd env def_names) fwds in
+  let cls = List.map (type_clause env def_names) cls in
   let def_names =
     List.map
-      (fun (chan, (ty, id)) ->
+      (fun (chan, ty) ->
         match (expand_head env ty).desc with
         | Tarrow (_, _, _, _) ->
             chan, {jchannel_sync=true; jchannel_env=env ;
                    jchannel_ident=chan ;
-                   jchannel_type=ty ; jchannel_id=id}
+                   jchannel_type=ty ; }
         | Tconstr (p, _, _) (* when Path.same p Predef.path_channel *) ->
             chan, {jchannel_sync=false; jchannel_env=env ;
                    jchannel_ident=chan ;
-                   jchannel_type=ty; jchannel_id=id}
+                   jchannel_type=ty;}
         | _ -> assert false)
       def_names in
-(* type dispacher second, it needs the new def_name *)
-  let disps = List.map (type_dispatcher def_names) disps in
-
-  {jauto_desc = (disps, reacs, fwds);
-   jauto_name = my_names ;
-   jauto_nchans = nchans ;
-   jauto_names =  def_names;
-   jauto_original = original ;
-   jauto_loc = my_loc }
+  { jauto_desc = cls;
+    jauto_loc = my_loc;
+    jauto_names = def_names; }
 
 and generalize_auto env auto =
-  let _,reacs,fwds = auto.jauto_desc in
+  let cls = auto.jauto_desc in
   List.iter
-    (fun reac ->
-      let _,jpats,_,_,_ = reac in
+    (fun cl ->
+      let jpats,_ = cl.jclause_desc in
       let tys = ref [] in
       List.iter
         (fun jpat ->
@@ -3608,31 +3538,17 @@ and generalize_auto env auto =
             end in
           iter_type_expr f chan.jident_type ;
           tys := !newtys @ !tys)
-        jpats)
-    (List.map (fun (Fwd r) -> r) fwds @
-     List.map (fun (Reac r) -> r) reacs) ;
+        jpats) cls ;
   List.iter
     (fun (id,chan) -> generalize chan.jchannel_type)
     auto.jauto_names
 
-and add_auto_names p env names =
+and add_auto_names loc p env names =
   List.fold_left
-    (fun env (id,(ty,nat)) ->
-      if p id then
-        let kind = match nat with
-        | Chan (name,num)-> Val_channel (name,num)
-        | Alone g  -> Val_alone g in
-        Env.add_value id
-          {val_type = ty; val_kind = kind; Types.val_loc = Location.none; } env
-      else env)         
-    env names
-
-and add_auto_names_as_regular p env names =
-  List.fold_left
-    (fun env (id,(ty,_)) ->
+    (fun env (id,ty) ->
       if p id then 
         Env.add_value id
-          {val_type = ty; val_kind = Val_reg; Types.val_loc = Location.none} env
+          {val_type = ty; val_kind = Val_reg; Types.val_loc = loc} env
       else env)
     env names
 
@@ -3643,8 +3559,10 @@ and type_def toplevel env sautos scope =
   let names_lhs_list = type_autos_lhs env sautos scope in
   let new_env =
     List.fold_left
-      (fun env (_, _ , (_,_,names), _) ->
-        add_auto_names (fun _ -> true) env names)
+      (fun env lhs ->
+        let names = lhs.apt_names
+        and loc = lhs.apt_loc in
+        add_auto_names loc (fun _ -> true) env names)
       env names_lhs_list in
   let autos =
     List.map (type_auto new_env) names_lhs_list in
@@ -3653,22 +3571,7 @@ and type_def toplevel env sautos scope =
 (* Generalization *)
   List.iter (generalize_auto env) autos ;
 
-(* For toplevel def, should change the bindings of channels,
-   so as to avoid internal automaton name escaping *)
-  let final_env = 
-    if toplevel then
-      List.fold_left
-        (fun env (_ , _, (_,original,names), _) ->
-          let p id = List.mem id original in
-          add_auto_names_as_regular p env names)
-        env names_lhs_list
-    else
-      List.fold_left
-        (fun env (_ , _, (_,original,names), _) ->
-          let p id = List.mem id original in
-          add_auto_names p env names)
-        env names_lhs_list in
-  autos, final_env
+  autos, new_env
 
 (* Got to export those *)
 let type_exp env e = do_type_exp E env e
diff --git a/typing/typedtree.ml b/typing/typedtree.ml
index cd6e6065e9..d2fac4cfd9 100644
--- a/typing/typedtree.ml
+++ b/typing/typedtree.ml
@@ -110,56 +110,32 @@ and expression_desc =
   | Texp_reply of expression * Ident.t
   | Texp_def of joinautomaton list * expression
 
-and 'a joinautomaton_gen =
-    {jauto_desc : 'a ;
-     jauto_name : Ident.t * Ident.t ;
-     jauto_names : (Ident.t * joinchannel) list ;
-     jauto_original : Ident.t list ;
-     jauto_nchans : int;
-     (* names defined, description *)
-     jauto_loc : Location.t}
-
 and joinautomaton =
- (joindispatcher list * joinreaction list * joinforwarder list)
-      joinautomaton_gen
-
-and joindispatcher =
-  Disp of
-    Ident.t * joinchannel * (pattern * joinchannel) list * partial
-
-and joinclause = 
-   Ident.t * joinpattern list * joinpattern list list * 
-  (Ident.t * pattern) list * expression
-
-and joinreaction = Reac of joinclause
-
-and joinforwarder = Fwd of joinclause
+    {jauto_desc : joinclause list ;
+     jauto_loc : Location.t ;
+     jauto_names : (Ident.t * joinchannel) list ; (* Channel defined *) }
 
 and joinchannel =
     {jchannel_sync : bool ;
-     jchannel_id   : jchannel_id ;
      jchannel_ident : Ident.t ;
      jchannel_type : type_expr;
      jchannel_env : Env.t;}
 
-and jchannel_id = Chan of Ident.t * int | Alone of Ident.t
+and joinclause = 
+    { jclause_desc : joinpattern list * expression;
+      jclause_loc : Location.t; }
 
 and joinpattern =
-    { jpat_desc: joinident * pattern ;
-      jpat_kont : Ident.t option ref ;
-      jpat_loc: Location.t}
+    { jpat_desc: joinident * pattern ; 
+      jpat_loc: Location.t ;
+      (* For synchronous channels, can be shared by several patterns *)
+      jpat_kont : Ident.t option ref ; }
 
 and joinident =
     { jident_desc : Ident.t ;
-      jident_loc  : Location.t;
+      jident_orig  : string loc ; (* Original ident as in source *)
       jident_type : type_expr;
       jident_env : Env.t;}
-
-and joinarg =
-    { jarg_desc : Ident.t option ;
-      jarg_loc  : Location.t;
-      jarg_type : type_expr;
-      jarg_env : Env.t;}
 (*< JOCAML *)
 
 and meth =
@@ -511,7 +487,8 @@ let let_bound_idents pat = List.map  fst (let_bound_idents_with_loc pat)
 (*> JOCAML *)
 let do_def_bound_idents autos r =
   List.fold_right
-    (fun {jauto_original=names} r -> names@r)
+    (fun {jauto_names=names} r ->
+      List.fold_right (fun (id,_) k -> id::k) names r)
     autos r
 
 let def_bound_idents d = do_def_bound_idents d []
@@ -538,3 +515,33 @@ let rec alpha_pat env p = match p.pat_desc with
 
 let mkloc = Location.mkloc
 let mknoloc = Location.mknoloc
+(*>JOCAML *)
+
+(* Compiled join automaton *)
+
+type joinchannelopt = Chan of Ident.t * int | Alone of Ident.t
+
+type joinchannelfull= joinchannel * joinchannelopt
+
+type dispatcher =
+   Ident.t * joinchannelfull  * (pattern * joinchannelfull) list * partial
+
+type reaction =  Ident.t * joinpattern list * joinpattern list list * 
+  (Ident.t * pattern) list * expression
+
+type channel_env =  (Ident.t * joinchannelfull) list 
+
+type compiledautomaton =
+  {
+   cauto_name : Ident.t * Ident.t; (* auto name, wrapped auto name *)
+   (* All names defined, with sort of  *)
+   cauto_channels : channel_env ;
+   cauto_nchans : int ; (* number of actual channels *)
+   (* Original names *)
+   cauto_original : channel_env ;
+   cauto_loc : Location.t ;
+   cauto_dispatchers : dispatcher list ;
+   cauto_forwarders : reaction list ;
+   cauto_reactions : reaction list ;
+ }  
+(*<JOCAML *)
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
index 40d0f90210..2fb7590dc6 100644
--- a/typing/typedtree.mli
+++ b/typing/typedtree.mli
@@ -109,49 +109,30 @@ and expression_desc =
   | Texp_reply of expression * Ident.t
   | Texp_def of joinautomaton list * expression
 
-
-and 'a joinautomaton_gen =
-    {jauto_desc : 'a ;
-      jauto_name : Ident.t * Ident.t; (* auto name, wrapped auto name *)
-      jauto_names : (Ident.t * joinchannel) list ;
-      jauto_original : Ident.t list ;
-      jauto_nchans : int;
-     (* names defined, description*)
-      jauto_loc : Location.t}
-      
 and joinautomaton =
- (joindispatcher list * joinreaction list * joinforwarder list)
-      joinautomaton_gen
-
-and joindispatcher =
-  Disp of
-    Ident.t * joinchannel  * (pattern * joinchannel) list * partial
-
-and joinclause = 
-   Ident.t * joinpattern list * joinpattern list list * 
-  (Ident.t * pattern) list * expression
-
-and joinreaction = Reac of joinclause
-
-and joinforwarder = Fwd of joinclause
+    {jauto_desc : joinclause list ;
+     jauto_loc : Location.t ;
+     jauto_names : (Ident.t * joinchannel) list ; (* Channel defined *) }
 
 and joinchannel =
     {jchannel_sync : bool ;
-     jchannel_id   : jchannel_id ;
      jchannel_ident : Ident.t ;
      jchannel_type : type_expr;
      jchannel_env : Env.t;}
 
-and jchannel_id = Chan of Ident.t * int | Alone of Ident.t
+and joinclause = 
+    { jclause_desc : joinpattern list * expression;
+      jclause_loc : Location.t; }
 
 and joinpattern =
-    { jpat_desc: joinident * pattern ;  (* as given in source *)
-      jpat_kont : Ident.t option ref ;  (* For synchronous channels, can be shared by several patterns *)
-      jpat_loc: Location.t}
+    { jpat_desc: joinident * pattern ; 
+      jpat_loc: Location.t ;
+      (* For synchronous channels, can be shared by several patterns *)
+      jpat_kont : Ident.t option ref ; }
 
 and joinident =
     { jident_desc : Ident.t ;
-      jident_loc  : Location.t;
+      jident_orig  : string loc ; (* Original ident as in source *)
       jident_type : type_expr;
       jident_env : Env.t;}
 (*< JOCAML *)
@@ -460,3 +441,38 @@ val mknoloc: 'a -> 'a Asttypes.loc
 val mkloc: 'a -> Location.t -> 'a Asttypes.loc
 
 val pat_bound_idents: pattern -> (Ident.t * string Asttypes.loc) list
+
+(*>JOCAML *)
+
+(* Compiled join automaton *)
+
+type joinchannelopt = Chan of Ident.t * int | Alone of Ident.t
+
+type joinchannelfull= joinchannel * joinchannelopt
+
+type dispatcher =
+   Ident.t * joinchannelfull  * (pattern * joinchannelfull) list * partial
+
+type reaction = 
+    Ident.t * (* Guarded process identifier *)
+      joinpattern list * (* Original join patterns *)
+      joinpattern list list *  (* Compiled joinpatterns *)
+      (Ident.t * pattern) list * (* Added matching *)
+      expression (* Guarded process *)
+
+type channel_env =  (Ident.t * joinchannelfull) list 
+
+type compiledautomaton =
+  {
+   cauto_name : Ident.t * Ident.t; (* auto name, wrapped auto name *)
+   (* All names defined, with sort of  *)
+   cauto_channels : channel_env ;
+   cauto_nchans : int ; (* number of actual channels *)
+   (* Original names *)
+   cauto_original : channel_env ;
+   cauto_loc : Location.t ;
+   cauto_dispatchers : dispatcher list ;
+   cauto_forwarders : reaction list ;
+   cauto_reactions : reaction list ;
+ }  
+(*<JOCAML *)
diff --git a/typing/types.ml b/typing/types.ml
index 00d8396f74..f53a60aed4 100644
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -110,12 +110,6 @@ and value_kind =
   | Val_anc of (string * Ident.t) list * string
                                         (* Ancestor *)
   | Val_unbound                         (* Unbound variable *)
-(*> JOCAML *)
-  | Val_channel of Ident.t * int
-     (* Channel: automaton, index *)
-  | Val_alone of Ident.t 
-     (* Channel: guard *)
-(*< JOCAML *)
 
 (* Constructor descriptions *)
 
diff --git a/typing/types.mli b/typing/types.mli
index 96b9710083..4441c91ebf 100644
--- a/typing/types.mli
+++ b/typing/types.mli
@@ -108,12 +108,6 @@ and value_kind =
   | Val_anc of (string * Ident.t) list * string
                                         (* Ancestor *)
   | Val_unbound                         (* Unbound variable *)
-(*> JOCAML *)
-  | Val_channel of Ident.t * int
-    (* Channel: automaton, index *)
-  | Val_alone of Ident.t 
-     (* Channel: guard *)
-(*< JOCAML *)
 
 (* Constructor descriptions *)