sortActions.ml

(** Time-stamp: <modified the 07/10/2014 (at 16:21) by Erwan Jahier> *)

(** topological sort of actions (that may optimize test openning) *)

open ActionsDeps

(*********************************************************************************)
module OrderedAction = struct
  type t = ActionsDeps.action
  let compare = compare
end
module MapAction = Map.Make(OrderedAction)


type color = Grey | Black (* in process | done *)
type color_table = color MapAction.t

exception DependencyCycle of action * action list
(* exception DependencyCycle of Soc.var_expr list *)

let (grey_actions : color_table -> ActionsDeps.action list) =
  fun ct -> 
    MapAction.fold
      (fun action color acc -> if color=Grey then action::acc else acc) ct []

let rec (visit : ActionsDeps.t -> color_table -> ActionsDeps.action -> color_table) =
  fun succ_t color_t n ->
    if not (ActionsDeps.have_deps succ_t n) then MapAction.add n Black color_t else
      let color_t =
	     List.fold_left
	       (fun color_t nt -> 
	         try
	           match MapAction.find nt color_t with
		          | Grey -> raise (DependencyCycle (n, grey_actions color_t))
		          | Black -> color_t
	         with 
		          (* The node [nt] is white *)
		          Not_found -> visit succ_t color_t nt
	       ) 
	       (MapAction.add n Grey color_t)
	       (ActionsDeps.find_deps succ_t n)
      in
	   MapAction.add n Black color_t

(* TEDLT *)
let (check_there_is_no_cycle : ActionsDeps.action list -> ActionsDeps.t -> unit) =
  fun actions t -> 
    List.iter (fun action -> ignore(visit t MapAction.empty action)) actions


let (topo_sort : ActionsDeps.action list -> ActionsDeps.t -> ActionsDeps.action list) =
  fun actions stbl -> 
    let visited_init = 
      List.fold_left (fun acc x -> MapAction.add x false acc) MapAction.empty actions 
    in
    let rec f (acc:action list) (l:action list) (stbl:t) (visited:bool MapAction.t) = 
      (* The graph contains no cycle! *)
      match l with
	     | [] -> List.rev acc
	     | x::tail -> 
	       if (try MapAction.find x visited with Not_found -> assert false)
	       then 
	         f acc tail stbl visited 
          else 
              let x_succ = ActionsDeps.find_deps stbl x in
              if x_succ = [] then
	             f (x::acc) tail stbl (MapAction.add x true visited)
              else
	             f acc (x_succ @ l) (ActionsDeps.remove_dep stbl x) visited
    in
    check_there_is_no_cycle actions stbl;
    f [] actions stbl visited_init

(*********************************************************************************)
(* From actions to gaos, optimizing test openning *)

let rec (gao_of_action: action -> Soc.gao) = 
  fun (ck, il, ol, op, lxm) ->
    let rec unpack_clock = function
      | Lic.BaseLic -> Soc.Call (ol, op, il)
      | Lic.ClockVar i -> (* should not occur ?*)
        Soc.Call (ol, op, il)
      | Lic.On((value, cvar, _ctyp), inner_clock) ->
(*         let inner_clock = match inner_clock_opt with *)
(*           | Some x -> x *)
(*           | None ->  *)
(*                 (* TODO? Retreive the clock of c *) *)
(*             Lv6errors.internal lxm; *)
(*             assert false  *)
(*         in *)
        Soc.Case (cvar, [Ident.string_of_long2 value, [unpack_clock inner_clock]] )
    in
    unpack_clock ck

(*********************************************************************************)
(* [my_assoc x l] returns the elt associated to x in l plus l without (x,elt) *)
let my_assoc x l = 
  let rec aux acc = function
  | [] -> None
  | (a,b)::l -> if compare a x = 0 then Some(b,List.rev_append acc l) else aux ((a,b)::acc) l
  in 
  aux [] l

(* Simple optimisation : when 2 consecutive gao holds on the same clock, we
   try to factorize them out.
*)
let (optimize_test_openning: Soc.gao list -> ActionsDeps.t -> Soc.gao list) =
  fun gaol deps ->
    let rec aux acc gaol = match gaol with 
      | []  -> List.rev acc
      | [a] -> List.rev (a::acc)
      | Soc.Call(o,op,i)::tail -> aux (Soc.Call(o,op,i)::acc) tail 
      | a1::Soc.Call(o,op,i)::tail ->  aux (Soc.Call(o,op,i)::a1::acc) tail 
      | Case(v1,l1)::Case(v2,l2)::tail -> 
        if v1 <> v2 then aux (Soc.Case(v1,l1)::acc) (Case(v2,l2)::tail) else
          let l = merge_gaol l1 l2 [] in
          aux acc (Soc.Case(v1,l)::tail) 
            
    and (merge_gaol : (string * Soc.gao list) list -> (string * Soc.gao list) list -> 
         (string * Soc.gao list) list -> (string * Soc.gao list) list) =
      fun l1 l2 acc -> 
        match l1 with
          | [] -> if l2 = [] then List.rev acc else List.rev_append acc l2
          | (x1,gaol1)::l1 -> 
            (match my_assoc x1 l2 with
              | None -> merge_gaol l1 l2 ((x1,gaol1)::acc)
              | Some(gaol2,l2) -> 
                let gaol = aux [] (gaol1@gaol2) in
                merge_gaol l1 l2 ((x1,gaol)::acc)
            )
    in
    aux [] gaol

(*********************************************************************************)

let (f : action list -> ActionsDeps.t -> Lxm.t -> Soc.gao list) = 
  fun actions deps lxm -> 
    let actions = 
      try topo_sort actions deps
      with DependencyCycle(x,l) ->
        let l = List.map ActionsDeps.string_of_action_simple l in
        let msg = "A combinational cycle been detected "^
          (Lxm.details lxm)^" on \n  "^(ActionsDeps.string_of_action_simple x)^
          "\n  "^(String.concat "\n  " l) ^ "\n\nHint: try to use --expand-nodes.\n"
        in
        raise (Lv6errors.Global_error msg)
    in
    let gaol = List.map gao_of_action actions in
     optimize_test_openning gaol deps 
(*     gaol *)