source: Deliverables/D2.2/8051/src/RTLabs/redundancyElimination.ml @ 1572

(** This module implements partial redundancy elimination, which subsumes
    common subexpression elimination and loop-invariant code motion.
    This is a reformulation of material found in Muchnick, Advanced compiler
    design and implementation.
    Along the way we also perform a first rough liveness analysis. *)


open RTLabs
open AST

(* Notes: To move loop-invariant computation, peeling is needed. It would *)
(* also profit from algebraic transformations that piece together *)
(* loop-constants: if x and y are loop-invariants, then x*y*i won't be *)
(* optimized unless it is transformed to (x*y)*i. Pretty important for *)
(* array addresses. *)

(* ----- PHASE 0 : critical edge elimination ------ *)

(* a critical edge is one between a node with several successors and a node*)
(* with several predecessors. In order for the optimization to work best   *)
(* these must be avoided, inserting an empty node in-between. *)
(* Note: maybe in our case we can avoid this, as branchings will have *)
(* emit cost nodes afterwards. To be checked. Empirically I haven't found *)
(* an example where this transformation really applies. *)

let count_predecessors
    (g : graph)
    : int Label.Map.t =
  let f lbl s m =
    let succs = RTLabsUtilities.statement_successors s in
    let f' m succ =
      try
        Label.Map.add succ (1 + Label.Map.find succ m) m
      with
        | Not_found -> Label.Map.add succ 1 m in
    let m = List.fold_left f' m succs in
    if Label.Map.mem lbl m then m else Label.Map.add lbl 0 m in
  Label.Map.fold f g Label.Map.empty

module LabelPairSet = Set.Make(struct
  type t = Label.t * Label.t
  let compare = compare
end)

let find_critical_edges (g : graph) : LabelPairSet.t =
  let pred_count = count_predecessors g in
  let add_if_2_preds l1 s l2 =
    if Label.Map.find l2 pred_count < 2 then s else
      LabelPairSet.add (l1, l2) s in
  let f l stmt s = match stmt with
    | St_cond(_, l1, l2) ->
      add_if_2_preds l (add_if_2_preds l s l1) l2
    | St_jumptable (_, ls) when List.length ls > 1 ->
      List.fold_left (add_if_2_preds l) s ls
    | _ -> s in
  Label.Map.fold f g LabelPairSet.empty

(* note to self: there is a degenrate case that is not eliminated by the *)
(* following, namely (top to bottom) *)
(*               src                *)
(*               / \                *)
(*              |   |               *)
(*               \ /                *)
(*               tgt                *)
(* In this case the result will be  *)
(*               src                *)
(*               / \                *)
(*               \ /                *)
(*               new                *)
(*                |                 *)
(*               tgt                *)
(* with two critical edges still in place. To be checked whether it *)
(* compromises the optimization, I think not *)

let critical_edge_elimination
    (f_def : internal_function)
    : internal_function =
  let g = f_def.f_graph in
  let fresh () = Label.Gen.fresh f_def.f_luniverse in
  let critical_edges = find_critical_edges g in
  let rem (src, tgt) g =
    snd (RTLabsUtilities.insert_in_between fresh g src tgt (St_skip tgt)) in
  { f_def with f_graph = LabelPairSet.fold rem critical_edges g }

(* Expressions, expression sets, and operations thereof *)

(* Load and store ops are not taken into account, maybe later *)
type expr =
  (*        | Cst of cst (* do we need to consider constants? maybe only big ones? *)*)
  | UnOp of op1 * Register.t
  | BinOp of op2 * argument * argument

let expr_of_stmt (s : statement) : expr option = match s with
        (*        | St_cst (_, c, _) -> Some (Cst c)*)
  | St_op1 (op, _, s, _) when op <> Op_id -> Some (UnOp (op, s))
  | St_op2 (op, _, s, t, _) -> Some (BinOp (op, s, t))
  | _ -> None

let expr_of (g : graph) (n : Label.t) : expr option =
  expr_of_stmt (Label.Map.find n g)

(* the register modified by a node *)
let modified_at_stmt = RTLabsUtilities.modified_at_stmt

let modified_at = RTLabsUtilities.modified_at

(* registers on which the value computed at the statement depends, which are*)
(* needed if the modified register is needed. Below used_at lists those*)
(* registers that may be needed regardless (i.e. in non-side-effect-free *)
(* statements).*)
let vars_of_stmt = function
  | St_op2 (_, _, Reg s, Reg t, _) ->
    Register.Set.add s (Register.Set.singleton t)
  | St_load (_, Reg s, _, _)
  | St_op1 (_, _, s, _)
  | St_op2 (_, _, Reg s, _, _)
  | St_op2 (_, _, _, Reg s, _) -> Register.Set.singleton s
  | _ -> Register.Set.empty

let vars_of (g : graph) (n : Label.t) : Register.Set.t =
  vars_of_stmt (Label.Map.find n g)

(* used in possibly non side-effect-free statements *)
let used_at_stmt stmt =
  let add_arg s = function
    | Reg r -> Register.Set.add r s
    | Imm _ -> s in
  match stmt with
    | St_call_id (_, rs, _, _, _)
    | St_call_ptr (_, rs, _, _, _)
    | St_tailcall_id (_, rs, _)
    | St_tailcall_ptr (_, rs, _) ->
      List.fold_left add_arg Register.Set.empty rs
    | St_store (_, a, b, _) ->
      add_arg (add_arg Register.Set.empty a) b
    | St_return (Some (Reg r))
    | St_cond (r, _, _) -> Register.Set.singleton r
    | _ -> Register.Set.empty

let used_at g n = used_at_stmt (Label.Map.find n g)

module ExprOrdered = struct
  type t = expr
  let compare = compare
end

module ExprSet = Set.Make(ExprOrdered)
module ExprMap = Map.Make(ExprOrdered)

type expr_set = ExprSet.t

let ( ^^ ) = ExprSet.inter

let ( ++ ) = ExprSet.union

let ( ++* ) s = function
  | None -> s
  | Some e -> ExprSet.add e s

let ( --* ) s = function
  | None -> s
  | Some e -> ExprSet.remove e s

let ( -- ) = ExprSet.diff

let big_inter (f : Label.t -> ExprSet.t) (ls : Label.t list) : ExprSet.t =
        (* generalized intersection, but in case of empty list it is empty *)
  match ls with
    | [] -> ExprSet.empty
    (* these two cases are singled out for speed, as they will be common *)
    | [l] -> f l
    | [l1 ; l2] -> f l1 ^^ f l2
    | l :: ls ->
      let inter s l' = s ^^ f l' in
      List.fold_left inter (f l) ls

let big_union (f : Label.t -> Register.Set.t) (ls : Label.t list)
    : Register.Set.t =
  (* generalized union *)
  let union s l' = Register.Set.union s (f l') in
  List.fold_left union Register.Set.empty ls

let filter_unchanged (r : Register.t option) (s : expr_set) : expr_set =
  match r with
    | None -> s
    | Some r ->
      let filter = function
        | UnOp (_, s) when r = s -> false
        | BinOp (_, s, t) when s = Reg r || t = Reg r -> false
        | _ -> true in
      ExprSet.filter filter s

module Lpair = struct

        (* A property is a pair of sets of expressions. *)
  type property = expr_set * expr_set

  let bottom = (ExprSet.empty, ExprSet.empty)

  let equal (ant1, nea1) (ant2, nea2) =
    ExprSet.equal ant1 ant2 && ExprSet.equal nea1 nea2

  let is_maximal _ = false

end

module Lsing = struct

  (* A property is a set of expressions. *)
  type property = expr_set

  let bottom = ExprSet.empty

  let equal = ExprSet.equal

  let is_maximal _ = false

end

module Lexprid = struct

  (* A property is a set of expressions and a set of registers. *)
  type property = expr_set * Register.Set.t

  let bottom = (ExprSet.empty, Register.Set.empty)

  let equal (a, b) (c, d) = ExprSet.equal a c && Register.Set.equal b d

  let is_maximal _ = false

end

module Fpair = Fix.Make (Label.ImpMap) (Lpair)

module Fsing = Fix.Make (Label.ImpMap) (Lsing)

module Fexprid = Fix.Make (Label.ImpMap) (Lexprid)

(* printing tools to debug *)

let print_expr = function
    (*    | Cst c ->
          (RTLabsPrinter.print_cst c)*)
  | UnOp (op, r) ->
    (RTLabsPrinter.print_op1 op r)
  | BinOp (op, r, s) ->
    (RTLabsPrinter.print_op2 op r s)

let print_prop_pair (p : Fpair.property) = let (ant, nea) = p in
                                           let f e = Printf.printf "%s, " (print_expr e) in
                                           Printf.printf "{ ";
                                           ExprSet.iter f ant;
                                           Printf.printf "}; { ";
                                           ExprSet.iter f nea;
                                           Printf.printf "}\n"

let print_valu_pair (valu : Fpair.valuation) (g : graph) (entry : Label.t) =
  let f lbl _ =
    Printf.printf "%s: " lbl;
    print_prop_pair (valu lbl) in
  RTLabsUtilities.dfs_iter f g entry

let print_prop_sing (p : Fsing.property) =
  let f e = Printf.printf "%s, " (print_expr e) in
  Printf.printf "{ ";
  ExprSet.iter f p;
  Printf.printf "}\n"

let print_valu_sing (valu : Fsing.valuation) (g : graph) (entry : Label.t) =
  let f lbl _ =
    Printf.printf "%s: " lbl;
    print_prop_sing (valu lbl) in
  RTLabsUtilities.dfs_iter f g entry


(* ----- PHASE 1 : Anticipatability and erliestness ------ *)
(* An expression e is anticipatable at point p if every path from p contains  *)
(* a computation of e and evaluating e at p holds the same result as all such *)
(* computations. *)
(* An expression e is earliest at point p if there is no computation of e *)
(* preceding p giving the same value. *)
(* We will compute anticipatable expressions and *non*-earliest ones for every*)
(* point with a single invocation to a fixpoint calculation. *)


let semantics_ant_nea
    (g : graph)
    (pred_table : Label.t list Label.Map.t)
    (lbl : Label.t)
    (valu : Fpair.valuation)
    : Fpair.property =
  let succs = RTLabsUtilities.statement_successors (Label.Map.find lbl g) in
  let preds = Label.Map.find lbl pred_table in

        (* anticipatable expressions at entry *)
        (* take anticipatable expressions of successors... *)
  let ant l = fst (valu l) in
  let nea l = snd (valu l) in
  let ant_in = big_inter ant succs in
        (* ... filter out those that contain the register being changed ...*)
  let ant_in = filter_unchanged (modified_at g lbl) ant_in in
        (* ... and add the expression being calculated ... *)
  let ant_in = ant_in ++* expr_of g lbl in

        (* non-earliest expressions at entry *)
        (* take non-earliest or anticipatable expressions of predecessors, *)
        (* filtered so that just unchanged expressions leak *)
  let ant_or_nea l =
    filter_unchanged (modified_at g l) (ant l ++ nea l) in
  let nea_in = big_inter ant_or_nea preds in

  (ant_in, nea_in)

let compute_anticipatable_and_non_earliest
    (f_def : internal_function)
    (pred_table : Label.t list Label.Map.t)
    : Fpair.valuation =

  Fpair.lfp (semantics_ant_nea f_def.f_graph pred_table)

(* ------------ PHASE 2 : delayedness and lateness ----------- *)
(* An expression e is delayable at position p there is a point p' preceding it*)
(* in the control flow where e could be safely placed, and between p'and p *)
(* excluded e is never used. *)


let semantics_delay
    (g : graph)
    (pred_table : Label.t list Label.Map.t)
    (ant_nea : Fpair.valuation)
    (lbl : Label.t)
    (valu : Fsing.valuation)
    : Fsing.property =
  let preds = Label.Map.find lbl pred_table in

                (* delayed expressions at entry *)
                (* take delayed expressions of predecessors which are not the expressions *)
                (* of such predecessors... *)
  let rem_pred lbl' = valu lbl' --* expr_of g lbl' in
  let delay_in = big_inter rem_pred preds in
                (* ... and add in anticipatable and earliest expressions *)
  let (ant, nea) = ant_nea lbl in
  delay_in ++ (ant -- nea)

let compute_delayed
    (f_def : internal_function)
    (pred_table : Label.t list Label.Map.t)
    (ant_nea : Fpair.valuation)
    : Fsing.valuation =

  Fsing.lfp (semantics_delay f_def.f_graph pred_table ant_nea)

(* An expression is latest at p if it cannot be delayed further *)
let late (g : graph) (delay : Fsing.valuation)
    : Fsing.valuation = fun lbl ->
      let stmt = Label.Map.find lbl g in
      let succs = RTLabsUtilities.statement_successors stmt in

      let eo = match expr_of g lbl with
        | Some e when ExprSet.mem e (delay lbl) -> Some e
        | _ -> None in

      (delay lbl -- big_inter delay succs) ++* eo


(* --------------- PHASE 3 : isolatedness, optimality and redudancy --------*)

(* An expression e is isolated at point p if on every path from p a use of *)
(* e is preceded by an optimal computation point for it. These are expressions*)
(* which will not be touched *)
(* A variable is used at entry if every use of it later in the execution path *)
(* is to compute variables which are in turn used. *)
let semantics_isolated_used
    (g : graph)
    (late : Fsing.valuation)
    (lbl : Label.t)
    (valu : Fexprid.valuation)
    : Fexprid.property =

  let stmt = Label.Map.find lbl g in
  let succs = RTLabsUtilities.statement_successors stmt in
  let f l = late l ++ (fst (valu l) --* expr_of g l) in
  let isol = big_inter f succs in

  let f l =
    let used_out = snd (valu l) in
    let used_out = match modified_at g l with
      | Some r when Register.Set.mem r used_out ->
        Register.Set.union (Register.Set.remove r used_out) (vars_of g l)
      | _ -> used_out in
    Register.Set.union used_out (used_at g l) in
  let used = big_union f succs in

  (isol, used)

let compute_isolated_used
    (f_def : internal_function)
    (delayed : Fsing.valuation)
    : Fexprid.valuation =

  let graph = f_def.f_graph in

  Fexprid.lfp (semantics_isolated_used graph (late graph delayed))

(* expressions that are optimally placed at point p, without being isolated *)
let optimal (late : Fsing.valuation) (isol : Fsing.valuation)
    : Fsing.valuation = fun lbl ->
      late lbl -- isol lbl

(* mark instructions that are redundant and can be removed *)
let redundant g late isol lbl =
  match expr_of g lbl with
    | Some e when ExprSet.mem e (isol lbl) ->
      false
    | Some _ -> true
    | _ -> false

(* mark instructions that modify an unused register *)
let unused g used lbl =
  match modified_at g lbl with
    | Some r when Register.Set.mem r (used lbl) ->
      false
    | Some r -> true
    | _ -> false

(*------ PHASE 4 : place expressions, remove reduntant ones -------------*)

let remove_redundant def is_redundant is_unused =
  let g = def.f_graph in
  let types = RTLabsUtilities.computes_type_map def in
  let f lbl stmt (g', s) =
    if is_unused lbl then
      let succ = List.hd (RTLabsUtilities.statement_successors stmt) in
      (Label.Map.add lbl (St_skip succ) g', s) else
      if is_redundant lbl then
        match modified_at_stmt stmt, expr_of_stmt stmt with
          | Some r, Some e ->
            let succ = List.hd (RTLabsUtilities.statement_successors stmt) in
            let (s, (tmp, _)) =
              try
                (s, ExprMap.find e s)
              with
                | Not_found ->
                  let tmp =        Register.fresh def.f_runiverse in
                  let typ = Register.Map.find r types in
                  let s = ExprMap.add e (tmp, typ) s in
                  (s, (tmp, typ)) in
            let new_stmt = St_op1 (Op_id, r, tmp, succ) in
            (Label.Map.add lbl new_stmt g', s)
          | _ -> assert false
      else (g', s) in
  let (g, s) = Label.Map.fold f g (g, ExprMap.empty) in
  ({ def with f_graph = g }, s)

let stmt_of_expr
    (r : Register.t)
    (e : expr)
    (l : Label.t)
    : statement =
  match e with
                (*                | Cst c -> St_cst (r, c, l)*)
    | UnOp (op, s) -> St_op1 (op, r, s, l)
    | BinOp (op, s, t) -> St_op2 (op, r, s, t, l)

let insert_after exprs redundants g freshl lbl next =
  let f e (next', g') =
    try
      let (tmp, _) = ExprMap.find e redundants in
      let opt_calc = stmt_of_expr tmp e next' in
      RTLabsUtilities.insert_in_between freshl g' lbl next' opt_calc
    with
      | Not_found -> (next', g') in
  snd (ExprSet.fold f exprs (next, g))

let insert_before exprs redundants g freshl lbl stmt =
  let f e (stmt', g') =
    try
      let (tmp, _) = ExprMap.find e redundants in
      let n_lbl = freshl () in
      let opt_calc = stmt_of_expr tmp e n_lbl in
      let g' = Label.Map.add n_lbl stmt' g' in
      let g' = Label.Map.add lbl opt_calc g' in
      (opt_calc, g')
    with
      | Not_found -> (stmt', g') in
  snd (ExprSet.fold f exprs (stmt, g))

let store_optimal_computation (def, redundants) optimal =
        (* first add the temporaries' declarations *)
  let f _ (r, typ) vars = (r, typ) :: vars in
  let f_locals = ExprMap.fold f redundants def.f_locals in

        (* now the actual replacement *)
  let g = def.f_graph in
  let freshl () = Label.Gen.fresh def.f_luniverse in
  let f lbl stmt g' =
    match stmt with
      (* in case of cost emittance the optimal calculations are inserted *)
      (* after, to preserve preciness *)
      | St_cost (_, next) ->
         insert_after (optimal lbl) redundants g' freshl lbl next
      | _ ->
        insert_before (optimal lbl) redundants g' freshl lbl stmt in
  { def with f_locals = f_locals; f_graph = Label.Map.fold f g g }


(* piecing it all together *)
let transform_internal f_def =
  let pred_table = RTLabsUtilities.compute_predecessor_lists f_def.f_graph in
  let ant_nea = compute_anticipatable_and_non_earliest f_def pred_table in
  let delay = compute_delayed f_def pred_table ant_nea in
  let late = late f_def.f_graph delay in
  let isol_used = compute_isolated_used f_def delay in
  let isol = fun lbl -> fst (isol_used lbl) in
  let used = fun lbl -> snd (isol_used lbl) in
  let opt = optimal late isol in
  let redn = redundant f_def.f_graph late isol in
  let unusd = unused f_def.f_graph used in
  let f lbl _ s = Register.Set.union (used lbl) s in
  let regs_used =
    RTLabsUtilities.dfs_fold f f_def.f_graph f_def.f_entry Register.Set.empty in
  let filter (r, _) = Register.Set.mem r regs_used in
  let f_def = { f_def with f_locals = List.filter filter f_def.f_locals } in
  store_optimal_computation (remove_redundant f_def redn unusd) opt


let transform_funct = function
  | (f, F_int f_def) -> (f, F_int (transform_internal f_def))
  | f -> f

let trans = Languages.RTLabs, function
  | Languages.AstRTLabs p ->
    Languages.AstRTLabs { p with functs = List.map transform_funct p.functs }
  | _ -> assert false (* wrong language *)