(***********************************************************************)
(*                                                                     *)
(*                          OCamlP3l                                   *)
(*                                                                     *)
(* (C) 2004-2007                                                       *)
(*             Roberto Di Cosmo (dicosmo@dicosmo.org)                  *)
(*             Zheng Li (zli@lip6.fr)                                  *)
(*             Pierre Weis (Pierre.Weis@inria.fr)                      *)
(*             Francois Clement (Francois.Clement@inria.fr)            *)
(*                                                                     *)
(* Based on original Ocaml P3L System                                  *)
(* (C) 1997 by                                                         *)
(*             Roberto Di Cosmo (dicosmo@ens.fr)                       *)
(*             Marco Danelutto (marcod@di.unipi.it)                    *)
(*             Xavier Leroy  (Xavier.Leroy@inria.fr)                   *)
(*             Susanna Pelagatti (susanna@di.unipi.it)                 *)
(*                                                                     *)
(* This program is free software; you can redistribute it and/or       *)
(* modify it under the terms of the GNU Library General Public License *)
(* as published by the Free Software Foundation; either version 2      *)
(* of the License, or (at your option) any later version.              *)
(*                                                                     *)
(* This program is distributed in the hope that it will be useful,     *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of      *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the       *)
(* GNU Library General Public License for more details.                *)
(*                                                                     *)
(***********************************************************************)

(* $Id: parp3l.ml,v 1.24 2008-11-24 19:44:05 dicosmo Exp $ *)

(* the type of the p3l cap *)

type ('a, 'b) io = unit;;
(* place holder for future stream io functions *)

type ('a, 'b) p3ltree =
   | Farm of int * int list * (('a, 'b) p3ltree * int)
   | Pipe of ('a,'b) p3ltree list
   | Map of (int * int list * (('a, 'b) p3ltree * int))
   | Reduce of (int * int list * (('a, 'b) p3ltree * int))
   | Reduceseqfun of (int * (('a, 'b) io -> ('a -> 'b)))
   | Seq of (int * (('a, 'b) io -> ('a -> 'b)))
   | Cond of (int * (('a, 'b) p3ltree * ('b -> bool)))
   | Start of ((unit -> 'b) * (unit -> unit))
   | Stop of (('a -> unit) * (unit -> unit) * (unit -> unit));;

(* here we encapsulate the data structure used to store the parfuns code *)
(* parfuns should be a
 (Commlib.vp_inch option ref *
  Commlib.vp_outch option ref *
  ('a, 'b) p3ltree) list *)
(* but then, Ocaml refuses to "generalize" the variables *)

type parfun =
  (Commlib.vp_chan option ref *
   Commlib.vp_chan option ref *
   (unit -> (unit, unit) p3ltree));;

let parfuns = (ref [] : parfun list ref);;

(* runtime check to avoid parfuns and pardos nested inside pardos *)
let insidepardo = ref false;;

let addskel icr ocr e =
  if !insidepardo then
    failwith "ERROR: parfun nested inside a pardo. \
              This is not allowed, read the manual better! Aborting.";
  parfuns :=
    (* cheat on the type system to use a list *)
    (icr, ocr, (Obj.magic e : unit -> (unit,unit) p3ltree)) :: !parfuns;;

type nproc = int;;
type cin = int;;
type cout = int;;
type color = int;;
type proctemplate =
   | Userfun
   | DemandUserfun
   | Farmemit
   | IntDemandFarmemit
   | ExtDemandFarmemit
   | Farmcoll of int
   | Mapemit
   | Mapcoll of int
   | Mapworker
   | Reduceemit of int
   | Reducecoll of int
   | Reduceworker
   | Reduceseqemit of int
   | Reduceseqcoll of int
   | Reduceseqworker
   | Starter
   | Stopper
   | Condtester
   | Loopdist
   | Farmworker
   | PipeStage;;

let string_of_template = function
  | Userfun -> "Userfun"
  | Farmemit -> "Farmemit"
  | Farmcoll n -> "Farmcoll " ^ string_of_int n
  | Mapemit -> "Mapemit"
  | Mapcoll n -> "Mapcoll " ^ string_of_int n
  | Mapworker -> "Mapworker"
  | Reduceemit n -> "Reduceemitter"
  | Reducecoll n -> "Reducecollector"
  | Reduceworker -> "Reduceworker"
  | Reduceseqemit n -> "Reduceseqemitter"
  | Reduceseqcoll n -> "Reduceseqcollector"
  | Reduceseqworker -> "Reduceseqworker"
  | Starter -> "Starter"
  | Stopper -> "Stopper"
  | Condtester -> "Condtester"
  | Loopdist -> "Loopdist"
  | Farmworker -> "Farmworke"
  | PipeStage -> "PipeStage"
  | DemandUserfun -> "DemandUserfun"
  | IntDemandFarmemit -> "IntDemandFarmemit"
  | ExtDemandFarmemit -> "ExtDemandFarmemit";;

type config =
  | Seqconf of nproc * cin list option * cout list option
  | Inconf of cin option * cout option;;

type ('a, 'b) p3ltreeexp =
  | Innode of ('a, 'b) innode
  | Leaf of ('a, 'b) node

and ('a, 'b) innode =
  | Farmexp of ('a, 'b) node * ('a, 'b) node *
        (('a, 'b) p3ltreeexp list) * config option
  | Mapexp of ('a, 'b) node * ('a, 'b) node *
        (('a, 'b) p3ltreeexp list) * config option
  | Reduceexp of ('a, 'b) node * ('a, 'b) node *
        (('a, 'b) p3ltreeexp list) * config option
  | Reduceseqexp of ('a, 'b) node * ('a, 'b) node *
        (('a, 'b) p3ltreeexp list) * config option
  | Pipexp of ('a, 'b) p3ltreeexp list * config option
  | Condexp of ('a, 'b) p3ltreeexp * ('a, 'b) node *
        ('a, 'b) node * config option

and ('a, 'b) node =
    proctemplate * config option * ('a, 'b) action option * color

and ('a, 'b) action =
  | Seqfun of (('a, 'b) io -> ('a -> 'b))
  | Startfun of ((unit -> 'b) * (unit -> unit))
  | Stopfun of (('a -> unit) * (unit -> unit) * (unit -> unit))
  | CondChanSel of ('b -> bool)
  | OutChanSel of (Commlib.vp_chan list -> Commlib.vp_chan)
  | InChanSel of (Commlib.vp_chan list -> 'a * Commlib.vp_chan)
  | InChanSelAndFun of
      (Commlib.vp_chan list -> 'a * Commlib.vp_chan) * ('a -> 'b);;

(* this can be used to avoid init-ing start and stop functions *)
let do_nothing _ = ();;

(* simple functions to build the syntactic tree data structure *)

let seq ?(col=0) f = Seq (col, f);;

let farm ?(col=0) ?(colv=[]) (tree, ncopy) = Farm (col, colv, (tree, ncopy));;
  (*match tree with*)
  (*  Farm(c, v, (t', m)) -> Farm (c, v, (t', m*ncopy))*)
  (*| _ -> Farm (col, (tree, ncopy));; *)
  (*hard to define so don't optimize*)

let mapvector
  ?(col=0) ?(colv=[]) ((tree : ('a, 'b) p3ltree), ncopy) =
  (Obj.magic (Map (col, colv, (tree, ncopy))) : ('a array, 'b array) p3ltree);;

let reducevector
    ?(col=0) ?(colv=[]) ((tree : (('a * 'a), 'a) p3ltree), ncopy) =
  match tree with
(* The special optimization for "seq" inside "reduce" is not
   implemented in template yet
  | Seq(0, f) -> (Obj.magic (Reduceseqfun (col, f)) : ('a array, 'a) p3ltree)
  | Seq(c, f) -> (Obj.magic (Reduceseqfun (c, f)) : ('a array, 'a) p3ltree)
*)
  | _ -> (Obj.magic (Reduce(col, colv, (tree, ncopy))) :
                      ('a array, 'a) p3ltree);;

let pipeline (t1 : ('a, 'b) p3ltree) (t2 : ('b, 'c) p3ltree) =
  match ((Obj.magic t1 : ('a, 'c) p3ltree),
         (Obj.magic t2 : ('a, 'c) p3ltree)) with
  | (Pipe l1, Pipe l2) -> Pipe (l1 @ l2)
  | (s1, Pipe l2) -> Pipe (s1 :: l2)
  | (Pipe l1, s2) -> Pipe (l1 @ [s2])
  | (s1, s2) -> Pipe [s1; s2];;

let ( ||| ) = pipeline;;

let loop ?(col=0)(cond, tree) = Cond (col, (tree, cond));;

(* this goes into nodecode now! *)
(* let startstop f1 f2 expr = (Start f1) ||| expr ||| (Stop f2);; *)

(* now we turn to building the expanded tree, making the copies we need *)

let (genconfig, resetconfig, curconfig) =
  let count = ref 0 in
  ((fun () ->
     let c = Some (Seqconf (!count, None, None)) in
     count := !count + 1;
     c),
   (fun () -> count := 0),
   (fun () -> !count));;

let get_color c = function
  | 0 -> c
  | color -> color;;

let rec nvlist n c cl = 
  match n,cl with
      (0,_) -> []
    | (_,[]) -> c::(nvlist (n-1) c [])
    | (_,hd::tl) -> (get_color c hd)::(nvlist (n-1) c tl);;

let rec expand col =
  let color = get_color col in
  function
  | Seq (c, f) -> Leaf (Userfun, None, Some (Seqfun f), color c)
  | Reduceseqfun (c, f) ->
      Leaf (Reduceseqworker, None, Some (Seqfun f), color c)
  | Start f ->
      Leaf (Starter, None, Some (Startfun f), col)
  | Stop  f ->
      Leaf (Stopper, None, Some (Stopfun f), col)
  | Cond (c, (t, f)) ->
      let tmpcol = color c in
      Innode
        (Condexp
          (expand tmpcol t, (Loopdist, None, None, tmpcol),
           (Condtester, None, Some (CondChanSel f), tmpcol), None))
  | Pipe tl ->
      let tlexp = List.map (expand col) tl in
      Innode (Pipexp (tlexp, None))
  | Farm (c, cv, (t, n)) ->
      let tmpcol = color c in
      let tmpcolist = nvlist n tmpcol cv in
      Innode
        (Farmexp
           ((Farmemit, None, None, tmpcol),
            (Farmcoll n, None, None, tmpcol),
	    List.map (fun x -> expand x t) tmpcolist ,
            None))
  | Reduce (c, cv, (t, n)) ->
      let tmpcol = color c in
      let tmpcolist = nvlist n tmpcol cv in
      Innode
        (Reduceexp
           ((Reduceemit n, None, None, tmpcol),
            (Reducecoll n, None, None, tmpcol),
	    List.map (fun x -> expand x t) tmpcolist,
            None))
  | Map (c, cv, (t, n)) ->
      let tmpcol = color c in
      let tmpcolist = nvlist n tmpcol cv in
      Innode
        (Mapexp
          ((Mapemit, None, None, tmpcol),
           (Mapcoll n, None, None, tmpcol),
	   List.map (fun x -> expand x t ) tmpcolist,
	   None));;

let allocnode (templ, _, a, b) = (templ, genconfig (), a, b);;

let rec leafalloc = function
  | Leaf n -> Leaf (allocnode n)
  | Innode (Condexp (t, n1, n2, c)) ->
      Innode (Condexp (leafalloc t, allocnode n1, allocnode n2, c))
  | Innode (Pipexp (tl, c)) ->
      Innode (Pipexp (List.map leafalloc tl, c))
  | Innode (Farmexp(n1, n2, tl, c)) ->
      Innode (Farmexp (allocnode n1, allocnode n2, List.map leafalloc tl, c))
  | Innode (Reduceexp (n1, n2, tl, c)) ->
      Innode (Reduceexp (allocnode n1, allocnode n2, List.map leafalloc tl, c))
  | Innode (Mapexp (n1, n2, tl, c)) ->
      Innode (Mapexp (allocnode n1, allocnode n2, List.map leafalloc tl, c))
  | _ -> failwith "Parp3l: unknown structure in leafalloc";;

(* the last visit of the tree: binding the channels together *)
let chconnect cinl coutl = function
  | templ, Some (Seqconf (nproc, _, _)), a, b ->
      (templ, Some (Seqconf (nproc, Some cinl, Some coutl)), a, b)
  | _ -> failwith "Parp3l: unknown structure in chconnect";;

let pe_of_node = function
  | _, Some (Seqconf (nproc, _, _)), _, _ -> nproc
  | _ -> failwith "Parp3l: unknown structure in pe_of_node";;

let rec getchans = function
  | Leaf n ->
      let nproc= pe_of_node n in (nproc, nproc)
  | Innode (Condexp (t, n1, n2, c)) ->
      (pe_of_node n1,  pe_of_node n2)
  | Innode (Pipexp (tl, c)) ->
      (fst (getchans (List.hd tl)), snd (getchans (List.hd (List.rev tl))))
  | Innode (Farmexp (n1, n2, _, _)) ->
      (pe_of_node n1, pe_of_node n2)
  | Innode (Reduceexp (n1, n2, _, _)) ->
      (pe_of_node n1, pe_of_node n2)
  | Innode (Mapexp (n1, n2, _, _))  ->
      (pe_of_node n1, pe_of_node n2)
  | _ -> failwith "Parp3l: unknown structure in getchans";;

let rec nodeconf = function
  | Innode (Pipexp (tl, c)) as n->
      let cin, cout = getchans n in
      Innode
        (Pipexp (List.map nodeconf tl, Some (Inconf (Some cin, Some cout))))
  | Innode (Farmexp (n1, n2, tl, c)) ->
      let cin, cout = pe_of_node n1, pe_of_node n2 in
      Innode
        (Farmexp (n1, n2, List.map nodeconf tl,
                  Some (Inconf (Some cin, Some cout))))
  | Innode (Reduceexp (n1, n2, tl, c)) ->
      let cin, cout = pe_of_node n1, pe_of_node n2 in
      Innode
        (Reduceexp (n1, n2, List.map nodeconf tl,
                    Some (Inconf (Some cin, Some cout))))
  | Innode (Mapexp (n1, n2, tl, c)) ->
      let (cin, cout) = pe_of_node n1, pe_of_node n2 in
      Innode
        (Mapexp (n1, n2, List.map nodeconf tl,
                 Some (Inconf (Some cin, Some cout))))
  | Innode (Condexp (t, n1, n2, c))  ->
      let cin, cout = pe_of_node n1, pe_of_node n2 in
      Innode
        (Condexp (nodeconf t, n1, n2, Some (Inconf (Some cin, Some cout))))
  | x -> x;;

let rec bindchan cinl coutl = function
  | Leaf n -> Leaf (chconnect cinl coutl n)
  | Innode (Pipexp (tl, c)) ->
      Innode (Pipexp (fst (spreadc (List.hd cinl) (List.hd coutl) tl), c))
  | Innode
      (Farmexp (n1, n2, tl, (Some (Inconf (Some fin, Some fout)) as c))) ->
      let winl, woutl = List.split (List.map getchans tl) in
      Innode
        (Farmexp (chconnect cinl winl n1,
                  chconnect woutl coutl n2,
                  List.map (bindchan [fin] [fout]) tl, c))
  | Innode
      (Reduceexp (n1, n2, tl, (Some (Inconf (Some fin, Some fout)) as c))) ->
      let winl, woutl = List.split (List.map getchans tl)
      and n1in = pe_of_node n1
      and n2in = pe_of_node n2 in
      Innode
        (Reduceexp (chconnect (n2in :: cinl) (n2in :: winl) n1,
                    chconnect (n1in :: woutl) (n1in :: coutl) n2,
                    List.map (bindchan [fin] [fout]) tl, c))
  | Innode
      (Mapexp (n1, n2, tl, (Some (Inconf (Some fin, Some fout)) as c))) ->
      let winl, woutl = List.split (List.map getchans tl) in
      Innode
        (Mapexp (chconnect cinl winl n1,
                 chconnect woutl coutl n2,
                 List.map (bindchan [fin] [fout]) tl, c))
  | Innode
      (Condexp (t, n1, n2, (Some (Inconf (Some fin, Some fout))as c))) ->
      let winl, woutl =
        let cin, cout = getchans t in ([cin], [cout]) in
      Innode
        (Condexp (bindchan [fin] [fout] t,
                  chconnect (fout :: cinl) winl n1,
                  chconnect woutl (fin :: coutl) n2, c))
  | _ -> failwith "Parp3l: unknown structure in bindchan"

and spreadc cin cout = function
  | [] -> [], (cin, cout)
  | [p] ->
      let xin, xout = getchans p in
      [bindchan [cin] [cout] p], (xin, xout)
  | p1 :: pl ->
      let p1in, p1out = getchans p1 in
      let rest, (rin, rout) = spreadc p1out cout pl in
      (bindchan [cin] [rin] p1 :: rest), (p1in, rout);;


(* the round robin selection of output channels for a farm emitter *)

let rr () =
  let count = ref 0 in
  function l ->
    let el = List.nth l !count in
    count := (if !count = List.length l - 1 then 0 else !count + 1);
    el;;

(* the selection of input channels *)

let confdist (pt, conf, _, col) =
  (pt, conf, Some (InChanSel Commlib.receive_any), col);;

let confemit (pt, conf, _, col) =
  (pt, conf, Some (OutChanSel (rr ())), col);;

let confcollect (pt, conf, _, col) =
  (pt, conf, Some (InChanSel Commlib.receive_any), col);;

let confreduceseqcollect = function
  | pt, conf, Some (Seqfun f), col ->
     (pt, conf, Some (InChanSelAndFun  (Commlib.receive_any, f)), col)
  | _ -> failwith "Parp3l: unknown structure in confreduceseqcollect";;

let rec leafs_of = function
  | Leaf n -> [Leaf n]
  | Innode (Condexp (t, n1, n2, _)) ->
      Leaf (confdist n1) :: Leaf n2 :: leafs_of t
  | Innode (Pipexp (tl, _)) ->
      List.flatten (List.map leafs_of tl)
  | Innode (Farmexp (n1, n2, tl, _)) ->
      Leaf (confemit n1) :: Leaf (confcollect n2) ::
      List.flatten  (List.map leafs_of tl)
  | Innode (Reduceexp (n1, n2, tl, _)) ->
      Leaf (confemit n1) :: Leaf (confcollect n2) ::
      List.flatten (List.map leafs_of tl)
  | Innode (Mapexp (n1, n2, tl, _))  ->
      Leaf (confemit n1) :: Leaf (confcollect n2) ::
      List.flatten (List.map leafs_of tl)
  | _ -> failwith "Parp3l: unknown structure in leafs_of";;

(* Iterator on p3ltreeexp *)

let rec p3ltreeexpr_it f = function
  | Innode (Condexp (t, n1, n2, c)) ->
      Innode (Condexp (p3ltreeexpr_it f t, n1, n2, c))
  | Innode (Pipexp (tl, c)) ->
      Innode (Pipexp (List.map (p3ltreeexpr_it f) tl, c))
  | Innode (Reduceexp (n1, n2, tl, c)) ->
      Innode (Reduceexp (n1, n2, List.map (p3ltreeexpr_it f) tl, c))
  | Innode (Mapexp (n1, n2, tl, c)) ->
      Innode (Mapexp (n1, n2, List.map (p3ltreeexpr_it f) tl, c))
  | node -> f node;;

(* DemandAdjust function: replace templates with proper demand templates
   in the AST *)

let demandadjust t =
  let inner= ref false in
  let rec aux = function
  | Innode (Farmexp ((_, c', a', col), c, wl, conf)) ->
      let templ =
        if !inner then IntDemandFarmemit else
          (inner := true; ExtDemandFarmemit) in
      Innode
        (Farmexp ((templ, c', a', col), c,
                  (let i = !inner in
                   List.map (fun w -> inner := i; aux w) wl), conf))
  | Leaf (Userfun, c', a', col) ->
      let templ =
        if !inner then (inner:=false; DemandUserfun) else Userfun in
      Leaf (templ, c', a', col)
  | Leaf (_, _, _, _) as node -> node
  | t -> p3ltreeexpr_it aux t in
  inner := false;
  aux t;;

(* the production chain : expand the cap, allocate the leafs, the
inner nodes, then bind the channels, and extract the configured
nodes *)

let p3ldo = fun
  cin cout f  ->
    let bound =
      demandadjust
       (bindchan [cin] [cout] (nodeconf (leafalloc (expand 0 f)))) in
    let fstnode, lastnode = getchans bound in
    (fstnode, (leafs_of bound), lastnode);;

(* build an association list of virtual processor/output nodes
   this is useful in dispatching, later, the channel numbers *)

let mkoutnodesassoc leafl =
  List.map
    (function
     | Leaf (_, Some (Seqconf (n, _, Some nl)), _, _) -> (n, nl)
     | _ -> failwith "Parp3l: unknown structure in mkoutnodeassoc")
    leafl;;

let mkinnodesassoc leafl =
  let ht = Hashtbl.create 32 in
  let addnodes n nl = List.iter (fun m -> Hashtbl.add ht m n) nl in
  List.iter
    (function
     | Leaf (_, Some (Seqconf (n, Some nl, _)), _, _) -> addnodes n nl
     | _ -> failwith "Parp3l: unknown structure in mkinnodeassoc")
    leafl;
  ht;;

let mknodecol leafl =
  List.map
   (function
    | Leaf (_, Some (Seqconf (n, _, _)), _, c) -> (n, c)
    | _ -> failwith "Parp3l: unknown structure in mkoutnodecol")
   leafl;;


(* the global function used by the root node: must return the leafs,
   first node, and the virtual processor mapping to the processr pool *)

(*
let busyplus (b, c, d) = d := !d + 1;;

let partition f a l =
  let switch (l1, l2) elem =
    if f elem > f a then (elem :: l1, l2) else (l1, elem :: l2) in
  List.fold_left switch ([], []) l;;

let rec order f  = function
  | [] -> []
  | [a] -> [a]
  | a :: l ->
      let l1, l2 = partition f a l
      in order f l1 @ a :: order f l2;;

let tuple_fst (a, _, _) = a;;
let tuple_snd (_, b, _) = b;;
let tuple_trd (_, _, c) = c;;

let pairfun vp pp =
  let pairone l v =
    let count = ref (List.hd pp) in
    let rec onepairone pl =
      if pl = [] || tuple_snd (List.hd pl) < snd v then begin
        busyplus !count;
        (fst v, tuple_fst !count)
      end else begin
        if !(tuple_trd (List.hd pl)) < !(tuple_trd !count)
        then count := List.hd pl;
        onepairone (List.tl pl)
      end in
    onepairone (List.tl pp) :: l in
  List.fold_left pairone [] vp;;
*)

(* in this code, we no longer make a distinctive usage of
   a start and stop node: this makes no sense with parfuns *)



let pair sflag vpool ppool =
  let ppoolext = List.map (fun ((a,b),c,d) -> ((a,b),c,ref d)) ppool 
  in let pp = List.fast_sort (fun ((a1,b1),c1,d1) ((a2,b2),c2,d2) -> (c2-c1)) ppoolext
  in let vp = List.fast_sort (fun (a1,b1) (a2,b2) -> (b2-b1)) vpool 
  in let () = Commlib.debug 
		(fun () -> 
		   Printf.printf "Ordered virtual processors\n" ;
		   List.iter (fun (a,b) -> Printf.printf "VP%i#%i\t" a b) vp;
		   print_newline ();print_newline ();
		   Printf.printf "Ordered physical processors\n" ;
		   List.iter (fun ((a,b),c,d) -> Printf.printf "%s:%i#%i%%%d\t" (Unix.string_of_inet_addr a) b c !d ) pp;
		   print_newline ();print_newline ();
		)

  in let pairfun (va,vb) =
      let count = ref (List.hd pp)
      in let rec onepairone pl = 
	  let ((ca,cb),cc,rcd) = !count 
	  in match pl with
	      [] -> if !rcd=0 then (failwith "Not enough physical processors in nonstrict mapping") else !count
	    | ((a,b),c,rd)::tl ->
		if (c<vb) && (!rcd!=0) then !count
		else 
		  begin 
		    if (!rcd=0)&&(!rd!=0)||(!rcd>0)&&(c=cc)&&(!rd>(!rcd))||(!rcd<0)&&(!rd>(!rcd))&&(!rd!=0) 
		    then count:=((a,b),c,rd) else (); 
		    onepairone tl
		  end
      in onepairone (List.tl pp) 

  in let pairone (va,vb) =
      if sflag (*not-so-strict solution: if sflag && (vb!=0)*)
      then
	try (List.find (fun ((_,_),c,rd) -> (c=vb)&&(!rd>0)) pp)
	with Not_found -> failwith "Not enough physical processors in strict mapping."
      else pairfun (va,vb) 

  in let fl = List.fold_left 
		(fun l (va,vb) -> 
		  let ((ca,cb),cc,rcd) = pairone (va,vb) 
		  in begin
		      Commlib.debug(fun () -> Printf.printf "VP%i#%i mapped to %s:%i#%i%%%i" va vb (Unix.string_of_inet_addr ca) cb cc !rcd); 
		      rcd:=!rcd-1;
		      (va,(ca,cb))::l
		    end
		) [] vp 
  in if sflag && (List.exists (fun ((_,_),_,rd) -> (!rd!=0)) pp) 
    then failwith "Not exact physical processors in strict mapping, more than expected"
    else fl;;

(*
   the entry point of this module:
   given an expression list and a processor pool, it gives back
   the virtual processors (leafs), the first node (fstnode),
   the mapping function associating a node to its actual processor,
   and the list of triples associating parfuns' i/o channels to
   the nodes
 *)

(* notice that we no longer treat separately the start and stop node *)

let p3ldoallparfuns sflag el pprocpool =
  resetconfig ();
  let _, fstnode, lastnode, leafs, io_al =
    List.fold_right
      (fun (inr, outr, e) (n, fn, ln, res, io_al) ->
        let fn', leafs, ln' = p3ldo n n e in
        (n - 1, min fn fn', max ln ln', leafs @ res, (n, inr, outr) :: io_al))
        (* this should be rethinked!
           we want the first first node and the last last node,
           and they are not necessarily obtained via max and min
           if the nets have more than 1000 nodes... *)
      el
      (-1, 1000, -1000, [], []) in
  let vprocpool = mknodecol leafs in
  let mapping = pair sflag vprocpool pprocpool in
    (fstnode, leafs), mapping, io_al;;

(* startstop is a simple streams function kept for backward compatibility,
   colors are not really used *)

(*let startstop ?(startcol = 0) ?(stopcol = 0) (f1, init1) (f2, init2, finalize) f =
  fun () ->
    init1();init2(); (* let us do the initialization steps first,  which are impure *)
    let _ = Streams.iter f2 (f (Streams.of_fun f1)) in finalize ();;
*)