(* TML5 -- generated on vendredi 24 juillet 2009, 19:25:00 (UTC+0200) from /home/deleuzec/Rech/TML/Doc/tml_impl.tex *)


(* insert bfoncteur *)


module type SVAL_TYPE = sig type t end

module Gen_TML = functor(SV:SVAL_TYPE) ->
  struct
    type sval_t = SV.t
(* end  bfoncteur *)

type process = unit -> coop
and coop = 
  | Done 
  | Next
  | Pause   of process
  | Wait    of signal_t * awproc
  | Wait_im of signal_t * awproc
  | Present of signal_t * process * process
        
and awproc = 
  | No  of (unit -> coop)
  | One of (sval_t -> coop)
  | All of (sval_t list -> coop)
        
and signal_t = {
    mutable last_emit : int;
    mutable prev_emit : int;
    mutable value : sval_t list;
    mutable prev_value : sval_t list;
    mutable used : bool;
    gather : (sval_t list -> sval_t list);
    
    mutable await : (ctxt * awproc) list;
    mutable await_im : (ctxt * awproc) list;
    mutable present : (ctxt * process * process) list
  }
      
and ctxt =
    Free
  | Until of signal_t * process
  | Untilv of signal_t * (sval_t list -> coop) * process
  | Control of signal_t * process
  | When of signal_t * awproc

(* insert def2 *)


let instant = ref 1

let runq   = ref []
and pauseq = ref []

let run f = f ()
let term () = Done
let pause p = Pause p

let put_in_runq p = runq := p :: !runq
(* end  def2 *)

  let put_in_await_im s p =
    s.await_im <- p :: s.await_im

(* insert signal *)


let signal () =
  { last_emit = -1; prev_emit = -1; value = []; prev_value = [];
    used = false; gather = (fun x -> x); await = []; await_im = [];
    present = [] 
  }

let signalc g =
  { last_emit = -1; prev_emit = -1; value = []; prev_value = [];
    used = false; gather = g; await = []; await_im = [];
    present = [] 
  }
(* end  signal *)

(* insert used *)


let used_signals = ref ([]:signal_t list)

let signal_is_used s =
  if not s.used then begin
    s.used <- true;
    used_signals := s :: !used_signals
  end
(* end  used *)

(* insert await4 *)


let ispst = fun s -> s.last_emit = !instant

let await s p = Wait(s, All p)

let await_one s p = Wait(s, One p)

let await_immediate s p =
  if ispst s then p () else Wait_im(s, No p)
          
let await_immediate_one s p =
  if ispst s then p (List.hd s.value) else Wait_im(s, One p)

let present s p1 p2 =
  if ispst s then p1 () else Present(s,p1,p2)

let pre s = s.prev_emit = !instant - 1 || s.last_emit = !instant - 1

let prev s = if s.last_emit = !instant then s.prev_value else s.value
(* end  await4 *)

let emit s v =
  if s.last_emit <> !instant then begin
    s.prev_emit <- s.last_emit;
    s.last_emit <- !instant;
    s.prev_value <- s.value;
    s.value <- [];
    signal_is_used s
  end;
  s.value <- v :: s.value;
  List.iter 
    (fun (c,awp) -> match awp with
    | No p -> put_in_runq (c, p)
    | One p -> put_in_runq (c, fun () -> p v))
    s.await_im;
  s.await_im <- [];
  List.iter (fun (c,p1,p2) -> put_in_runq (c,p1)) s.present;
  s.present <- []

let dountil s e k =
  put_in_runq (Until(s,k), e); Next

let dountilv s e e2 k =
  put_in_runq (Untilv(s,e2,k), e); Next

let controlwith s e k =
  put_in_runq (Control(s,k), e); Next

let dowhen s e k =
  if s.last_emit = !instant then put_in_runq (When(s,No k), e)
  else put_in_await_im s (When(s,No k), No e);
  Next

let pause2   = ref []  (* pour les proc. suspensibles et désactivables *)
let unactive = ref []  (* pour les proc. désactivés *)
        
let current_context = ref Free

let put_in_unact p = unactive := p :: !unactive

let ispst = fun s -> s.last_emit = !instant

let next_instant_unactive_pause2 () = 
  
  unactive := List.filter
      (fun (Control(s',k) as c,p) ->
        if ispst s' then (put_in_runq (c,p); false)
        else true)
      !unactive;
    
  List.iter
    (fun (c,p) -> match c with
    | Until(s',k) -> put_in_runq
          (if ispst s' then (Free, k) else (c, p))
          
    | Untilv(s',e2,k) ->
        put_in_runq
          (if ispst s' 
          then (Free, fun () -> e2 s'.value; k())
          else (c, p))
          
    | Control(s',k) ->
        (if ispst s' then put_in_unact else put_in_runq) (c,p)
    )
    !pause2;
  pause2 := []

let do_await_queue_absent s  =
  let new_list, used = List.fold_left
      (fun (acc,used) (c,qp) -> match c with
      | Free -> (Free, qp)::acc, used
                                  
      | When(s',k) -> 
          let next = match qp with
          | One p -> fun () -> await_one s p
          | All p -> fun () -> await s p
          in
          put_in_await_im s' (c, No next); acc, used
                
      | Until(s',k) -> 
          if ispst s' then (put_in_runq (Free, k); acc, used)
          else (c, qp)::acc, true
                              
      | Untilv(s',e2,k) -> 
          if ispst s' then 
            (put_in_runq (Free, fun () -> e2 s'.value; k()); acc, used)
          else 
            (c, qp)::acc, true
                           
      | Control(s',k) ->
          let next = match qp with
          | One p -> fun () -> await_one s p
          | All p -> fun () -> await s p
          in
          if ispst s' then (put_in_unact (c, next); acc, used)
          else (c, qp)::acc, true
      )
      
      ([], false)
      s.await
  in s.await <- new_list;
  used

let do_await_im_queue_absent s  =
  let new_list, used = List.fold_left
      (fun (acc,used) (c,qp) -> match c with
      | Free -> (Free, qp)::acc, used
                                  
      | When(s',k) -> 
          let next = match qp with
          | One p -> fun () -> await_immediate_one s p
          | No p -> fun () -> await_immediate s p
          in
          put_in_await_im s' (c, No next); acc, used
                
      | Until(s',k) -> 
          if ispst s' then (put_in_runq (Free, k); acc, used)
          else (c, qp)::acc, true
                              
      | Untilv(s',e2,k) -> 
          if ispst s' then 
            (put_in_runq (Free, fun () -> e2 s'.value; k()); acc, used)
          else 
            (c, qp)::acc, true
                           
      | Control(s',k) ->
          let next = match qp with
          | One p -> fun () -> await_immediate_one s p
          | No p -> fun () -> await_immediate s p
          in
          if ispst s' then (put_in_unact (c, next); acc, used)
          else (c, qp)::acc, true
      )
      ([], false)
      s.await_im
  in s.await_im <- new_list; used

  let do_await_queue_present s v ov = 
    List.iter 
      (fun (c, qp) -> 
        let next = match qp with
        | One p -> fun () -> p ov
        | All p -> fun () -> p v
        in 
        match c with
      | Free -> put_in_runq (Free, next)
            
      | When(s',k) -> put_in_await_im s' (c, No next)
            
      | Until(s',k) -> put_in_runq
            (if ispst s' then (Free, k) else (c, next))
            
      | Untilv(s',e2,k) ->
            put_in_runq
            (if ispst s' 
            then (Free, fun () -> e2 s'.value; k())
            else (c,    next))
            
      | Control(s',k) ->
          (if ispst s' then put_in_unact else put_in_runq)
            (c, next)
      )
      s.await;
      s.await <- []

  let do_present_queue_absent s =
    List.iter 
      (fun (c, p1, p2) -> match c with
      | Free -> put_in_runq (Free, p2)

      | When(s',k) -> put_in_runq (c, p2)
            
      | Until(s',k) -> put_in_runq (if ispst s' then (Free, k) else (c, p2))
            
      | Untilv(s',e2, k) ->
          put_in_runq
            (if ispst s'
              then (Free, fun () -> e2 s.value; k())
            else (c, p2))
            
      | Control(s',k) ->
          (if ispst s' then put_in_unact else put_in_runq) (c, p2)
      )
      s.present;
    s.present <- []

let next_instant () =
  runq:=!pauseq; pauseq:=[];
  next_instant_unactive_pause2 ();
  
  let new_used = List.filter
      (fun s -> 
        let keep = 
          if ispst s then                 (* s présent *)
            let v  = s.gather s.value in
            let ov = List.hd s.value
            in
            do_await_queue_present s v ov;
            false
          else begin                                (* s absent *)
            do_present_queue_absent s;
            let u1 = do_await_queue_absent s in
            let u2 = do_await_im_queue_absent s
            in u1 or u2
          end
        in
        if not keep then s.used <- false;
        keep)
      !used_signals
  in
  incr instant;
  used_signals := new_used

let until_or_ctrl c =
  match c with
  | Until _
  | Untilv _
  | Control _ -> true
  | _ -> false

let rec sched () =
  match !runq with
  | [] -> 
      next_instant();
      if !runq=[] then () else sched()
          
  | (c,p)::t -> begin runq := t; current_context := c; match p() with

    | Next -> sched ()

    | Done -> begin match c with
      | Free -> sched ()
      | Until(s,k)
      | Untilv(s,_,k)
      | When(s, No k)
      | Control(s,k)  -> put_in_runq (Free,k); sched ()
    end

    | Pause p -> begin match c with
      | Free      -> pauseq := (c,p) :: !pauseq; sched ()
      | When(s,_) -> s.await_im <- (c,No(fun _ -> p ()))::s.await_im; sched ()
      | Until _   
      | Untilv _  
      | Control _ -> pause2 := (c,p) :: !pause2; sched ()
    end
            
    | Wait(s,p) -> 
        s.await <- (c,p) :: s.await;
        if until_or_ctrl c then signal_is_used s;
        sched ()

    | Wait_im(s,p) ->
        s.await_im <- (c,p) :: s.await_im;
        if until_or_ctrl c then signal_is_used s;
        sched ()

    | Present(s, p1, p2) ->
        s.present <- (c,p1,p2) :: s.present;
        signal_is_used s;
        sched ()
  end

let spawn = fun p -> runq := (!current_context,p) :: !runq

let start pl =
  runq := List.map (fun p -> Free,p) pl;
  sched ()  

(* insert par *)


let par_help k1 k2 k3 =
  let you_re_last = ref false in
  let test _ = 
    if !you_re_last then k3 () else begin
        you_re_last := true;
        term()
      end
  in
  (fun () -> k1 test),
  (fun () -> k2 test)
    
let par p1 p2 k =
  let k1, k2 = par_help p1 p2 k
  in
  spawn k1;
  k2 ()
let tail_par p1 p2 =
  spawn p1;
  p2 ()
let tail_parn (p::ps) =
  List.iter spawn ps;
  p ()

let parn (p::ps) k =
  let cpt = ref (List.length ps) in
  let pk::pks = List.map
            (fun p -> 
              fun () -> p
                  (fun () -> if !cpt=0 then k () else 
                  begin decr cpt; term() end)
                  ())
            (p::ps)
  in
  List.iter spawn pks;
  pk ()
let fordopar e1 e2 pi k =
  let cpt = ref (e2-e1+1) in
  let finish () = decr cpt; if !cpt = 0 then k () else term()
  in
  for i=e1 to e2 do
    spawn (fun () -> pi i finish)
  done;
  term ()
  
let tail_fordopar e1 e2 pi =
  for i=e1 to e2 do
    spawn (fun () -> pi i)
  done;
  term ()
let letand_help p1 p2 k =
  let r1 = ref None
  and r2 = ref None
  in
  p1 
    (fun r -> match !r2 with
    | None -> r1 := Some r; term()
    | Some v2 -> k (r, v2)),
  p2
    (fun r -> match !r1 with
    | None -> r2 := Some r; term()
    | Some v1 -> k (v1, r))

let letand p1 p2 k =
  let k1, k2 = letand_help p1 p2 k
  in
  spawn k1;
  k2 ()
(* end  par *)

(* insert efoncteur *)


  end
(* end  efoncteur *)

This document was generated using caml2html