CristalCaveGem » LustreC

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

(*                                                                  *)

(*  The LustreC compiler toolset   /  The LustreC Development Team  *)

(*  Copyright 2012 -    --   ONERA - CNRS - INPT                    *)

(*                                                                  *)

(*  LustreC is free software, distributed WITHOUT ANY WARRANTY      *)

(*  under the terms of the GNU Lesser General Public License        *)

(*  version 2.1.                                                    *)

(*                                                                  *)

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

open Utils

open Graph

open Causality

(* Topological sort with a priority for variables belonging in the same equation lhs.

   For variables still unrelated, standard compare is used to choose the minimal element.

   This priority is used since it helps a lot in factorizing generated code.

   to improve the behavior of optimization algorithms applied in forthcoming compilation steps. 

   - [eq_equiv] is the equivalence relation between vars of the same equation lhs

   - [g] the (imperative) graph to be topologically sorted

   - [pending] is the set of unsorted root variables so far, equivalent to the last sorted var

   - [frontier] is the set of unsorted root variables so far, not belonging in [pending]

   - [sort] is the resulting topological order

*)

(* Checks whether the currently scheduled variable [choice]

   is an output of a call, possibly among others *)

let is_call_output choice g =

   then removes [v] from [g] 

*)

let add_successors eq_equiv g v pending frontier =

  let succs_v = IdentDepGraph.succ g v in

  begin

    IdentDepGraph.remove_vertex g v;

      (fun v' -> 

	if is_graph_root v' g then 

	  (if eq_equiv v v' then 

	      pending := ISet.add v' !pending 

	   else

	      frontier := ISet.add v' !frontier)

      ) succs_v;

(* Chooses the next var to be sorted, taking priority into account.

   Modifies [pending] and [frontier] accordingly.

*)

    if ISet.is_empty !pending

    then

      begin

	let choice = ISet.min_elt !frontier in

	let (p, f) = ISet.partition (eq_equiv choice) !frontier in

	pending := p;

	frontier := f;

	then sort := [choice] :: !sort

    else

      begin

	let choice = ISet.min_elt !pending in

	add_successors eq_equiv g choice pending frontier;

	then sort := (if !call

		      then (choice :: List.hd !sort) :: List.tl !sort

		      else [choice] :: !sort)

  end

(* Topological sort of dependency graph [g], with priority.

 *)

let topological_sort eq_equiv g =

  let roots = graph_roots g in

  assert (roots <> []);

  let pending = ref ISet.empty in

  let sorted = ref [] in

  begin

    while not (ISet.is_empty !frontier && ISet.is_empty !pending)

    do

      (*Format.eprintf "frontier = {%a}, pending = {%a}@."

	(fun fmt -> ISet.iter (fun e -> Format.pp_print_string fmt e)) !frontier

	(fun fmt -> ISet.iter (fun e -> Format.pp_print_string fmt e)) !pending;*)

  end

   in a case of a dependency error *)

let filter_original n vl =

 List.fold_right (fun v res ->

   if ExprDep.is_instance_var v then Format.sprintf "node %s" (ExprDep.undo_instance_var v) :: res else

   let vdecl = get_node_var v n in

   if vdecl.var_orig then v :: res else res) vl []

  fun v1 v2 ->

  try

    Hashtbl.find eq_equiv_hash v1 = Hashtbl.find eq_equiv_hash v2

  with Not_found -> false

  (* TODO X: extend the graph with inputs (adapt the causality analysis to deal with inputs

     warning (no modification) when memories are non used (do not impact output) or when inputs are not used (do not impact output)

  *)

  let sort = topological_sort eq_equiv g in

  let unused = Liveness.compute_unused_variables n gg in

  let fanin = Liveness.compute_fanin n gg in

  { node = n'; schedule = sort; unused_vars = unused; fanin_table = fanin; dep_graph = gg; }

 *   let eq_equiv = eq_equiv (ExprDep.eqs_eq_equiv eqs) in

 *   assert false (\* TODO: continue to implement scheduling of eqs for spec *\) *)

  let disjoint = Disjunction.clock_disjoint_map (get_node_vars report.node) in

  let reuse = Liveness.compute_reuse_policy report.node report.schedule disjoint report.dep_graph in

(*

    then

      begin

	  (fun fmt -> 

	    Format.fprintf fmt

	      "OPT:%B@." (try (Hashtbl.iter (fun s1 v2 -> if s1 = v2.var_id then raise Not_found) reuse; false) with Not_found -> true)

	  );

	  (fun fmt -> 

	    Format.fprintf fmt

	      "OPT:clock disjoint map for node %s: %a" 

	      n'.node_id

	      Disjunction.pp_disjoint_map disjoint

	  );

	Log.report ~level:0 

	  (fun fmt -> 

	    Format.fprintf fmt

	      "OPT:reuse policy for node %s: %a" 

	      n'.node_id

	      Liveness.pp_reuse_policy reuse

	  );

      end;

    reuse

  List.fold_right (

	let report = schedule_node nd in

	{top_decl with top_decl_desc = Node report.node}::accu_prog, 

	IMap.add nd.node_id report sch_map

    prog

let compute_prog_reuse_table report =

  IMap.map compute_node_reuse_table report

(* removes inlined local variables from schedule report, 

   which are now useless *)

let remove_node_inlined_locals locals report =

  let is_inlined v = IMap.exists (fun l _ -> v = l) locals in

  let schedule' =

    List.fold_right (fun heads q -> let heads' = List.filter (fun v -> not (is_inlined v)) heads

				    in if heads' = [] then q else heads'::q)

      report.schedule [] in

  begin

    IMap.iter (fun v _ -> Hashtbl.remove report.fanin_table v) locals;

    IMap.iter (fun v _ -> let iv = ExprDep.mk_instance_var v

			  in Liveness.replace_in_dep_graph v iv report.dep_graph) locals;

    { report with schedule = schedule' }

  end

let remove_prog_inlined_locals removed reuse =

  IMap.mapi (fun id -> remove_node_inlined_locals (IMap.find id removed)) reuse

  match vl with

  | []  -> assert false

  | [v] -> Format.fprintf fmt "%s" v

  | _   -> Format.fprintf fmt "(%a)" (fprintf_list ~sep:" , " (fun fmt v -> Format.fprintf fmt "%s" v)) vl

 IMap.iter

   (fun nd report ->

     Format.fprintf fmt "%s schedule: %a@."

       nd

let pp_fanin_table fmt node_schs =

  IMap.iter

    (fun nd report ->

    node_schs

let pp_dep_graph fmt node_schs =

  IMap.iter

    (fun nd report ->

      Format.fprintf fmt "%s dependency graph: %a" nd pp_dep_graph report.dep_graph)

 IMap.iter

   (fun nd report ->

     let unused = report.unused_vars in

     if not (ISet.is_empty unused)

     then

       let nd = match (Corelang.node_from_name nd).top_decl_desc with Node nd -> nd | _ -> assert false in

       ISet.iter

	   let vu = get_node_var u nd in

	   if vu.var_orig

   )

   node_schs

   to the computed schedule [sch]

*)

      Format.fprintf fmt "schedule: %a@."

  	(Utils.fprintf_list ~sep:" ; " pp_eq_schedule) sch);

    List.fold_left

      (fun (accu, node_eqs_remainder) vl ->

       if List.for_all (fun v -> List.exists (fun eq -> List.mem v eq.eq_lhs) accu) vl

	 (accu, node_eqs_remainder)

       else

	 let eq_v, remainder = find_eq vl node_eqs_remainder in

	 eq_v::accu, remainder

      )

      ([], split_eqs)

      sch

  in

  begin

    let unused =

      if List.length remainder > 0 then (

        Log.report ~level:3 (fun fmt -> Format.fprintf fmt

                                       "[Warning] Equations not used are@ %a@ Full equation set is:@ %a@ "

		                       Printers.pp_node_eqs remainder

      		                     Printers.pp_node_eqs eqs

          );

        let vars = List.fold_left (fun accu eq -> eq.eq_lhs @ accu) [] remainder in

        Log.report ~level:1 (fun fmt -> Format.fprintf fmt

                                      "[Warning] Unused variables: %a@ "

                                      (fprintf_list ~sep:", " Format.pp_print_string)

                                  vars

          );

        vars

      )

      else

        []

    in

    eqs, unused

(* compile-command:"make -C .." *)

(* End: *)