CristalCaveGem » LustreC

(* 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