CristalCaveGem » LustreC

  (* merge variables [v] and [v'] in disjunction [map]. Then:

  let merge_in_disjoint_map map v v' =

  (* replace variable [v] by [v'] in disjunction [map].

    [v'] is a dead variable. Then:

      - the mapping v' becomes v' |-> (map v)

      - the mapping v |-> ... then disappears

      - all mappings become x |-> ((map x) \ { v}) union ({v'} if v in map x)

  *)

  let replace_in_disjoint_map map v v' =

    begin

      Hashtbl.replace map v'.var_id (Hashtbl.find map v.var_id);

      Hashtbl.remove  map v.var_id;

      Hashtbl.iter (fun x mapx -> Hashtbl.replace map x (if CISet.mem v mapx then CISet.add v' (CISet.remove v mapx) else CISet.remove v' mapx)) map;

    end

  (* remove variable [v] in disjunction [map]. Then:

      - the mapping v |-> ... then disappears

      - all mappings become x |-> (map x) \ { v}

  *)

  let remove_in_disjoint_map map v =

    begin

      Hashtbl.remove map v.var_id;

      Hashtbl.iter (fun x mapx -> Hashtbl.replace map x (CISet.remove v mapx)) map;

    end

  begin

  end

let add_external_dependency outputs mems g =

  let caller ="!_world" in

  begin

    IdentDepGraph.add_vertex g caller;

    ISet.iter (fun o -> IdentDepGraph.add_edge g caller o) outputs;

    ISet.iter (fun m -> IdentDepGraph.add_edge g caller m) mems;

  end

  let outputs = ExprDep.node_output_variables node in

  begin

    merge_with g_non_mems g_mems';

    add_external_dependency outputs mems g_non_mems;

    { node with node_eqs = eqs'; node_locals = vdecls'@node.node_locals }, 

    g_non_mems

  end

(* Unifies all the clock variables in the clock type of a tuple 

   expression, so that the clock type only uses at most one clock variable *)

let unify_tuple_clock ref_ck_opt ck loc =

  let ck_var = ref ref_ck_opt in

  let rec aux ck =

    match (repr ck).cdesc with

    | Con _

    | Cvar _ ->

        begin

          match !ck_var with

          | None ->

              ck_var:=Some ck

          | Some v ->

              (* may fail *)

              try_unify v ck loc

        end

    | Ctuple cl ->

        List.iter aux cl

    | Carrow _ -> assert false (* should not occur *)

    | Ccarrying (_, ck1) ->

        aux ck1

    | _ -> ()

  in

  aux ck

(* Unifies all the clock variables in the clock type of an imported

   node, so that the clock type only uses at most one base clock variable,

   that is, the activation clock of the node *)

let unify_imported_clock ref_ck_opt ck loc =

  let ck_var = ref ref_ck_opt in

  let rec aux ck =

    match (repr ck).cdesc with

    | Cvar _ ->

        begin

          match !ck_var with

          | None ->

              ck_var:=Some ck

          | Some v ->

              (* cannot fail *)

              try_unify v ck loc

        end

    | Ctuple cl ->

        List.iter aux cl

    | Carrow (ck1,ck2) ->

        aux ck1; aux ck2

    | Ccarrying (_, ck1) ->

        aux ck1

    | Con (ck1, _, _) -> aux ck1

    | _ -> ()

  in

  aux ck

  unify_imported_clock (Some clock_reset) cfun loc;

  ce, cr

    unify_tuple_clock (Some ck_c) ck expr.expr_loc;

    unify_tuple_clock None ck expr.expr_loc;

      let ck_c, cr = clock_carrier env c c_loc ce in

      unify_tuple_clock (Some ck_c) ce expr.expr_loc;

      let ck_c, cr = clock_carrier env c expr.expr_loc cvar in

      unify_tuple_clock (Some ck_c) cvar expr.expr_loc;

  unify_imported_clock None ck_node loc;

  unify_imported_clock None ck_node loc;

(* checks whether a variable is aliasable,

   depending on its (address) type *)

let is_aliasable var =

 Types.is_address_type var.var_type

   and returns [locals] and [evaluated] such roots

   - [locals] is the set of potentially reusable variables

   - [evaluated] is the set of already evaluated variables,

     wrt the scheduling

*)

  fun v -> is_aliasable v && List.mem v.var_id inputs_var

(* replace variable [v] by [v'] in graph [g].

   [v'] is a dead variable

let replace_in_dep_graph v v' g =

type context =

{

  mutable evaluated : Disjunction.CISet.t;

  mutable quasi : Disjunction.CISet.t;

  mutable reusable : Disjunction.CISet.t;

  disjoint : (ident, Disjunction.CISet.t) Hashtbl.t;

  policy : (ident, var_decl) Hashtbl.t;

}

let pp_reuse_policy fmt policy =

  begin

    Format.fprintf fmt "{ /* reuse policy */@.";

    Hashtbl.iter (fun s t -> Format.fprintf fmt "%s -> %s@." s t.var_id) policy;

    Format.fprintf fmt "}@."

  end

let pp_context fmt ctx =

  begin

    Format.fprintf fmt "{ /*BEGIN context */@.";

    Format.fprintf fmt "eval=%a;@." Disjunction.pp_ciset ctx.evaluated;

    Format.fprintf fmt "quasi=%a;@." Disjunction.pp_ciset ctx.quasi;

    Format.fprintf fmt "reusable=%a;@." Disjunction.pp_ciset ctx.reusable;

    Format.fprintf fmt "disjoint=%a;@." Disjunction.pp_disjoint_map ctx.disjoint;

    Format.fprintf fmt "policy=%a;@." pp_reuse_policy ctx.policy;

    Format.fprintf fmt "/* END context */ }@.";

  end

let is_reusable_quasi var ctx q =

  (*Log.report ~level:6 (fun fmt -> Format.fprintf fmt "is_reusable_quasi@ var=%s %a q=%s@." var.var_id pp_context ctx q.var_id);*)

  let disjoint = Hashtbl.find ctx.disjoint var.var_id in

  let q = Hashtbl.find ctx.policy q.var_id in

  Disjunction.CISet.for_all

    (fun v -> (Hashtbl.find ctx.policy v.var_id = q) <= (Disjunction.CISet.mem v disjoint || Disjunction.CISet.mem v ctx.quasi))

    ctx.evaluated

let compute_reusable heads var ctx =

  let (reusable', quasi') = Disjunction.CISet.partition (fun q -> (not (List.mem q heads)) && is_reusable_quasi var ctx q) ctx.quasi

  in

  begin

    ctx.quasi <- quasi';

    ctx.reusable <- Disjunction.CISet.fold (fun r' -> Disjunction.CISet.add (Hashtbl.find ctx.policy r'.var_id)) reusable' ctx.reusable;

    ctx.quasi <- Disjunction.CISet.diff ctx.quasi reusable';

    ctx.evaluated <- Disjunction.CISet.diff ctx.evaluated reusable';

  end

   - [locals] is the set of potentially reusable variables

   - [evaluated] is the set of evaluated variables

   - [quasi] is the set of quasi-reusable variables

   - [reusable] is the set of dead/reusable dependencies of [var] in graph [g]

   - [policy] is the reuse map (which domain is [evaluated])

let compute_dependencies locals heads ctx g =

  begin

    (*Log.report ~level:6 (fun fmt -> Format.fprintf fmt "compute_reusable_dependencies %a %a %a %a@." Disjunction.pp_ciset locals Printers.pp_var_name var pp_context ctx pp_dep_graph g);*)

    List.iter (fun head -> IdentDepGraph.iter_succ (IdentDepGraph.remove_edge g head.var_id) g head.var_id) heads;

    ctx.quasi <- Disjunction.CISet.union (remove_local_roots locals ctx.evaluated g) ctx.quasi;

    List.iter (fun head -> compute_reusable heads head ctx) heads;

  end

let compute_evaluated heads ctx =

    List.iter (fun head -> ctx.evaluated <- Disjunction.CISet.add head ctx.evaluated) heads;

let compute_reuse node var ctx g =

  let aliasable = is_aliasable_input node var.var_id in

  let eligible v = Typing.eq_ground var.var_type v.var_type && not (aliasable v) in

  try

    let disj = Hashtbl.find ctx.disjoint var.var_id in

    let reuse =

      Hashtbl.find ctx.policy

	(Disjunction.CISet.max_elt (Disjunction.CISet.filter (fun v -> (eligible v) && (Disjunction.CISet.mem v ctx.evaluated) && not (Disjunction.CISet.mem v ctx.reusable)) disj)).var_id in

    begin

      ctx.evaluated <- Disjunction.CISet.add var ctx.evaluated;

      Hashtbl.add ctx.policy var.var_id reuse;

    end

  with Not_found ->

  try

    let reuse = Hashtbl.find ctx.policy (Disjunction.CISet.choose (Disjunction.CISet.filter (fun v -> eligible v) ctx.reusable)).var_id in

    begin

      replace_in_dep_graph var.var_id reuse.var_id g;

      Disjunction.replace_in_disjoint_map ctx.disjoint var reuse;

      ctx.evaluated <- Disjunction.CISet.add reuse ctx.evaluated;

      ctx.reusable <- Disjunction.CISet.remove reuse ctx.reusable;

      Hashtbl.add ctx.policy var.var_id reuse;

    end

      with Not_found ->

    begin

      ctx.evaluated <- Disjunction.CISet.add var ctx.evaluated;

      Hashtbl.add ctx.policy var.var_id var;

    end

  let ctx = { evaluated = Disjunction.CISet.empty;

	      quasi     = Disjunction.CISet.empty;

	      reusable  = Disjunction.CISet.empty;

	      disjoint  = disjoint;

	      policy    = Hashtbl.create 23; } in

    Log.report ~level:6 (fun fmt -> Format.fprintf fmt "new context:%a@." pp_context ctx);

    Log.report ~level:6 

      (fun fmt -> Format.fprintf fmt "new dependency graph:%a@." pp_dep_graph g);

    let heads = List.map (fun v -> get_node_var v node) (List.hd !sort) in

    Log.report ~level:6 (fun fmt -> Format.fprintf fmt "NEW HEADS:");

    List.iter (fun head -> Log.report ~level:2 (fun fmt -> Format.fprintf fmt "%s " head.var_id)) heads;

    Log.report ~level:6 (fun fmt -> Format.fprintf fmt "@.");

    Log.report ~level:6 (fun fmt -> Format.fprintf fmt "COMPUTE_DEPENDENCIES@.");

    compute_dependencies locals heads ctx g;

    Log.report ~level:6 (fun fmt -> Format.fprintf fmt "new context:%a@." pp_context ctx);

    Log.report ~level:6 

    Log.report ~level:6 (fun fmt -> Format.fprintf fmt "COMPUTE_REUSE@.");

    List.iter (fun head -> compute_reuse node head ctx g) heads;

    List.iter (fun head -> Log.report ~level:6 (fun fmt -> Format.fprintf fmt "reuse %s instead of %s@." (Hashtbl.find ctx.policy head.var_id).var_id head.var_id)) heads;

  ctx.policy

    Clock_calculus.unify_imported_clock (Some call_ck) eq.eq_rhs.expr_clock eq.eq_rhs.expr_loc;

  Log.report ~level:3 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@," Scheduling.pp_warning_unused node_schs);

  Log.report ~level:3 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@," Scheduling.pp_schedule node_schs);

  Log.report ~level:3 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@," Scheduling.pp_fanin_table node_schs);

  Log.report ~level:3 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@," Printers.pp_prog prog);

    if !Options.optimization >= 3 then

      begin

	Log.report ~level:1 (fun fmt -> fprintf fmt ".. machines optimization@,");

	Optimize_machine.machines_reuse_variables machine_code node_schs

      end

 in

  Log.report ~level:3 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@,"

  (Utils.fprintf_list ~sep:"@ " Machine_code.pp_machine)

  machine_code);

  (* Compute traceability info: 

(* variable substitution for optimizing purposes *)

(* checks whether an [instr] is skip and can be removed from program *)

let rec instr_is_skip instr =

  match instr with

  | MLocalAssign (i, LocalVar v) when i = v -> true

  | MStateAssign (i, StateVar v) when i = v -> true

  | MBranch (g, hl) -> List.for_all (fun (_, il) -> instrs_are_skip il) hl

  | _               -> false

and instrs_are_skip instrs =

  List.for_all instr_is_skip instrs

let instr_cons instr cont =

 if instr_is_skip instr then cont else instr::cont

let rec instr_remove_skip instr cont =

  match instr with

  | MLocalAssign (i, LocalVar v) when i = v -> cont

  | MStateAssign (i, StateVar v) when i = v -> cont

  | MBranch (g, hl) -> MBranch (g, List.map (fun (h, il) -> (h, instrs_remove_skip il [])) hl) :: cont

  | _               -> instr::cont

and instrs_remove_skip instrs cont =

  List.fold_right instr_remove_skip instrs cont

let rec value_replace_var fvar value =

  match value with

  | Cst c -> value

  | LocalVar v -> LocalVar (fvar v)

  | StateVar v -> value

  | Fun (id, args) -> Fun (id, List.map (value_replace_var fvar) args) 

  | Array vl -> Array (List.map (value_replace_var fvar) vl)

  | Access (t, i) -> Access(value_replace_var fvar t, i)

  | Power (v, n) -> Power(value_replace_var fvar v, n)

let rec instr_replace_var fvar instr cont =

  match instr with

  | MLocalAssign (i, v) -> instr_cons (MLocalAssign (fvar i, value_replace_var fvar v)) cont

  | MStateAssign (i, v) -> instr_cons (MStateAssign (i, value_replace_var fvar v)) cont

  | MReset i            -> instr_cons instr cont

  | MStep (il, i, vl)   -> instr_cons (MStep (List.map fvar il, i, List.map (value_replace_var fvar) vl)) cont

  | MBranch (g, hl)     -> instr_cons (MBranch (value_replace_var fvar g, List.map (fun (h, il) -> (h, instrs_replace_var fvar il [])) hl)) cont

and instrs_replace_var fvar instrs cont =

  List.fold_right (instr_replace_var fvar) instrs cont

let step_replace_var fvar step =

  (* Some outputs may have been replaced by locals.

     We then need to rename those outputs

     without changing their clocks, etc *)

  let outputs' =

    List.map (fun o -> { o with var_id = (fvar o).var_id }) step.step_outputs in

  let locals'  =

    List.fold_left (fun res l ->

      let l' = fvar l in

      if List.exists (fun o -> o.var_id = l'.var_id) outputs'

      then res

      else Utils.add_cons l' res)

      [] step.step_locals in

  { step with

    step_checks = List.map (fun (l, v) -> (l, value_replace_var fvar v)) step.step_checks;

    step_outputs = outputs';

    step_locals = locals';

    step_instrs = instrs_replace_var fvar step.step_instrs [];

}

let rec machine_replace_variables fvar m =

  { m with

    mstep = step_replace_var fvar m.mstep

  }

let machine_reuse_variables m reuse =

  let fvar v =

    try

      Hashtbl.find reuse v.var_id

    with Not_found -> v in

  machine_replace_variables fvar m

let machines_reuse_variables prog node_schs =

  List.map 

    (fun m -> 

      machine_reuse_variables m (Utils.IMap.find m.mname.node_id node_schs).Scheduling.reuse_table

    ) prog

    let reuse = Liveness.compute_reuse_policy n sort disjoint gg in

let add_cons x l =

 if List.mem x l then l else x::l

 | t::q -> add_cons t (remove_duplicates q)