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 Machine_code_types

  begin

    IMap.iter (fun v expr -> Format.fprintf fmt "%s |-> %a@ " v pp_val expr) elim;

    Format.fprintf fmt "}@ @]";

  let e_expr = eliminate_expr elim in

  | MStateAssign (i,v) -> update_instr_desc instr (MStateAssign (i, e_expr v))

       MBranch

	 (e_expr g, 

	  (List.map 

	     (fun (l, il) -> l, List.map (eliminate elim) il) 

	     hl

	  )

	 )

     )

and eliminate_expr elim expr =

  | Array(vl) -> {expr with value_desc = Array(List.map (eliminate_expr elim) vl)}

  | Access(v1, v2) -> { expr with value_desc = Access(eliminate_expr elim v1, eliminate_expr elim v2)}

  | Power(v1, v2) -> { expr with value_desc = Power(eliminate_expr elim v1, eliminate_expr elim v2)}

  | Cst _ | StateVar _ -> expr

    (fun v -> try

		dimension_of_value (IMap.find v elim) 

      with Not_found -> mkdim_ident dim.dim_loc v) 

    dim

(* 8th Jan 2016: issues when merging salsa with horn_encoding: The following

   functions seem unsused. They have to be adapted to the new type for expr

    (fun res -> (function | Index i -> mk_val (Access (res, value_of_dimension m i))

					      (Types.array_element_type res.value_type)

                          | Field f -> Format.eprintf "internal error: not yet implemented !"; assert false))

    expr offset

    | []          , _

         simplify_cst_expr m q elt_typ (List.nth cl (Dimension.size_const_dimension i))

         unfold_expr_offset m [Index i] (mk_val (Array (List.map (simplify_cst_expr m q elt_typ) cl)) typ)

         simplify_cst_expr m q fld_typ (List.assoc f fl)

let simplify_expr_offset m expr =

  let rec simplify offset expr =

                                     -> mk_val (Fun (id, List.map (simplify offset) vl)) expr.value_type

    | _           , StateVar _

    | _           , LocalVar _       -> unfold_expr_offset m offset expr

    | []          , _                -> expr

    | Index _ :: q, Power (expr, _)  -> simplify q expr

    | Index i :: q, Array vl when Dimension.is_dimension_const i

                                     -> simplify q (List.nth vl (Dimension.size_const_dimension i))

     with e -> (Format.eprintf "simplify_expr %a %a = <FAIL>@." pp_val expr (Utils.fprintf_list ~sep:"" Printers.pp_offset) offset; raise e*)

  in simplify [] expr

let rec simplify_instr_offset m instr =

  | MLocalAssign (v, expr) -> update_instr_desc instr (MLocalAssign (v, simplify_expr_offset m expr))

  | MStateAssign (v, expr) -> update_instr_desc instr (MStateAssign (v, simplify_expr_offset m expr))

      MBranch(simplify_expr_offset m cond, List.map (fun (l, il) -> l, simplify_instrs_offset m il) brl)

    )

and simplify_instrs_offset m instrs =

  List.map (simplify_instr_offset m) instrs

  match c with

  | Const_real _

  | _             -> false

   - either expr is atomic

     (no complex expressions, only const, vars and array/struct accesses)

   - or v has a fanin <= 1 (used at most once)

*)

let is_unfoldable_expr fanin expr =

  let rec unfold_const offset cst =

    match offset, cst with

    | _           , Const_int _

    | _           , Const_real _

    | _           , Const_tag _     -> true

    | Field f :: q, Const_struct fl -> unfold_const q (List.assoc f fl)

    | []          , Const_struct _  -> false

    | Index i :: q, Const_array cl when Dimension.is_dimension_const i

                                    -> unfold_const q (List.nth cl (Dimension.size_const_dimension i))

    | _           , Const_array _   -> false

    | _                             -> assert false in

  let rec unfold offset expr =

    | _           , LocalVar _

    | _           , StateVar _                   -> true

    | []          , Power _

    | []          , Array _                      -> false

    | Index i :: q, Power (v, _)                 -> unfold q v

    | Index i :: q, Array vl when Dimension.is_dimension_const i

                                                 -> unfold q (List.nth vl (Dimension.size_const_dimension i))

    | _           , Array _                      -> false

    | _           , Access (v, i)                -> unfold (Index (dimension_of_value i) :: offset) v

    | _           , Fun _                        -> false

    | _                                          -> assert false

  in unfold [] expr

    let d = Hashtbl.find fanin v.var_id

  with Not_found -> false

&& basic_unfoldable_assign fanin v expr

  let merge k e1 e2 =

    match e1, e2 with

    | Some e1, Some e2 -> if e1 = e2 then Some e1 else None

    | _      , Some e2 -> Some e2

    | Some e1, _       -> Some e1

    | _                -> None

  in IMap.merge merge elim1 elim2

  let elim, rev_instrs = 

    List.fold_left (fun (elim, instrs) instr ->

      (* each subexpression in instr that could be rewritten by the elim set is

	 rewritten *)

      let instr = eliminate elim instr in

      (* if instr is a simple local assign, then (a) elim is simplified with it (b) it

	 is stored as the elim set *)

      instr_unfold fanin instrs elim instr

    ) (elim, []) instrs

  in elim, List.rev rev_instrs

and instr_unfold fanin instrs elim instr =

    -> (IMap.add v.var_id expr elim, instrs)

  | MBranch(g, hl) when false

    -> let elim_branches = List.map (fun (h, l) -> (h, instrs_unfold fanin elim l)) hl in

       let (elim, branches) =

	 List.fold_right

	   (fun (h, (e, l)) (elim, branches) -> (merge_elim elim e, (h, l)::branches))

	   elim_branches (elim, [])

    -> (elim, instr :: instrs)

(** We iterate in the order, recording simple local assigns in an accumulator

    1. each expression is rewritten according to the accumulator

    2. local assigns then rewrite occurrences of the lhs in the computed accumulator

*)

  let replace v =

    try

      Machine_code.dimension_of_value (IMap.find v elim)

    with Not_found -> Dimension.mkdim_ident Location.dummy_loc v

  in (inst, (n, List.map (Dimension.expr_replace_expr replace) args))

    - iterate through step instructions and remove simple local assigns

*)

  (*Log.report ~level:1 (fun fmt -> Format.fprintf fmt "machine_unfold %a@." pp_elim elim);*)

  let elim_vars, instrs = instrs_unfold fanin elim_consts machine.mstep.step_instrs in

  let checks = List.map (fun (loc, check) -> loc, eliminate_expr elim_vars check) machine.mstep.step_checks in

  let minstances = List.map (static_call_unfold elim_consts) machine.minstances in

  let mcalls = List.map (static_call_unfold elim_consts) machine.mcalls

  {

    machine with

      mstep = { 

	machine.mstep with 

	  step_checks = checks

      mconst = mconst;

      minstances = minstances;

      mcalls = mcalls;

  elim_vars

  let const = const_of_top top_const in

    let fanin = (IMap.find m.mname.node_id node_schs).Scheduling.fanin_table in

    let elim_consts, _ = instrs_unfold fanin IMap.empty (List.map instr_of_const consts) in

    let (m, removed_m) =  machine_unfold fanin elim_consts m in

    (m::machines, IMap.add m.mname.node_id removed_m removed)

    )

  | MStateAssign(v, e) -> mk_val (StateVar v) e.value_type

let get_assign_rhs instr =

  | MStateAssign(_, e) -> e

  | _                  -> assert false

let is_assign instr =

  | MStateAssign _ -> true

  | _              -> false

let mk_assign v e =

 | StateVar v -> MStateAssign(v, e)

 | _          -> assert false

let rec assigns_instr instr assign =

  | MStep (ol, _, _)   -> List.fold_right VSet.add ol assign

  | _                  -> assign

and assigns_instrs instrs assign =

  List.fold_left (fun assign instr -> assigns_instr instr assign) assign instrs

(*    

and substitute_expr subst expr =

  match expr with

  | StateVar v

  | LocalVar v -> (try IMap.find expr subst with Not_found -> expr)

  | Fun (id, vl) -> Fun (id, List.map (substitute_expr subst) vl)

  | Array(vl) -> Array(List.map (substitute_expr subst) vl)

  | Access(v1, v2) -> Access(substitute_expr subst v1, substitute_expr subst v2)

  | Power(v1, v2) -> Power(substitute_expr subst v1, substitute_expr subst v2)

  | Cst _  -> expr

*)

(** Finds a substitute for [instr] in [instrs], 

   i.e. another instr' with the same rhs expression.

   Then substitute this expression with the first assigned var

*)

let subst_instr subst instrs instr =

  (*Format.eprintf "subst instr: %a@." Machine_code.pp_instr instr;*)

  let instr = eliminate subst instr in

  let v = get_assign_lhs instr in

  let e = get_assign_rhs instr in

try

      IMap.add v.var_id (get_assign_lhs instr') subst, instrs

    | StateVar v ->

      let typ' = lhs'.value_type in

      (match lhs'.value_desc with

      | StateVar v' ->

let instrs' = snd (List.fold_right (fun instr (ok, instrs) -> (ok || instr = instr', if ok then instr :: instrs else if instr = instr' then instrs else eliminate subst_v' instr :: instrs)) instrs (false, [])) in

	IMap.add v'.var_id (mk_val (StateVar v) typ') subst, instr :: instrs'

    | _          -> assert false

  with Not_found -> subst, instr :: instrs

try

      IMap.add v.var_id (get_assign_lhs instr') subst, instrs

       let lhs = get_assign_lhs instr' in

      (match lhs.value_desc with

	let subst_v' = IMap.add stv'.var_id v IMap.empty in

    | _          -> assert false

  with Not_found -> subst, instr :: instrs

(** Common sub-expression elimination for machine instructions *)

(* - [subst] : hashtable from ident to (simple) definition

               it is an equivalence table

   - [elim]   : set of eliminated variables

   - [instrs] : previous instructions, which [instr] is compared against

   - [instr] : current instruction, normalized by [subst]

*)

let rec instr_cse (subst, instrs) instr =

  | _ when is_assign instr

      -> subst_instr subst instrs instr

  | _ -> (subst, instr :: instrs)

(** Apply common sub-expression elimination to a sequence of instrs

*)

let rec instrs_cse subst instrs =

  let subst, rev_instrs = 

    List.fold_left instr_cse (subst, []) instrs

  in subst, List.rev rev_instrs

(** Apply common sub-expression elimination to a machine

    - iterate through step instructions and remove simple local assigns

*)

let machine_cse subst machine =

  (*Log.report ~level:1 (fun fmt -> Format.fprintf fmt "machine_cse %a@." pp_elim subst);*)

  let subst, instrs = instrs_cse subst machine.mstep.step_instrs in

  {

    machine with

	machine.mstep with 

      }

  }

let machines_cse machines =

  List.map

    (machine_cse IMap.empty)

    machines

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

let rec instr_is_skip instr =

  | MStateAssign (i, { value_desc = StateVar v; _}) when i = v -> true

  | _               -> 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 =

  | MStateAssign (i, { value_desc = StateVar v; _ }) when i = v -> cont

and instrs_remove_skip instrs cont =

  List.fold_right instr_remove_skip instrs cont

let rec value_replace_var fvar value =

  | Array vl -> { value with value_desc = Array (List.map (value_replace_var fvar) vl)}

  | Access (t, i) -> { value with value_desc = Access(value_replace_var fvar t, i)}

  | Power (v, n) -> { value with value_desc = Power(value_replace_var fvar v, n)}

let rec instr_replace_var fvar instr cont =

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

  | MBranch (g, hl)     -> instr_cons (update_instr_desc instr (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

    (fun m -> 

  | MStateAssign (i, _) -> Disjunction.CISet.add i res

  | MBranch (g, hl)     -> List.fold_left (fun res (h, b) -> instrs_assign res b) res hl

  | MStep (il, _, _)    -> List.fold_right Disjunction.CISet.add il res

  | _                   -> res

and instrs_assign res instrs =

  List.fold_left instr_assign res instrs

let rec instr_constant_assign var instr =

  | MStateAssign (i, { value_desc = Cst (Const_tag _); _ }) -> i = var

  | _                                   -> false

and instrs_constant_assign var instrs =

  List.fold_left (fun res i -> if Disjunction.CISet.mem var (instr_assign Disjunction.CISet.empty i) then instr_constant_assign var i else res) false instrs

let rec instr_reduce branches instr1 cont =

  | MStateAssign (_, { value_desc = Cst (Const_tag c); _}) -> instr1 :: (List.assoc c branches @ cont)

and instrs_reduce branches instrs cont =

 match instrs with

 | []        -> cont

 | [i]       -> instr_reduce branches i cont

 | i1::i2::q -> i1 :: instrs_reduce branches (i2::q) cont

let rec instrs_fusion instrs =

  | [], []

  | [_], [_]                                                               ->