Source file liveness.ml

open Utils
open Prog

(* Updates [s_o] to hold which variables are live before a write_lval. *)
let dep_lv s_o x =
  match x with
  | Lvar x -> Sv.remove (L.unloc x) s_o
  | _      -> vars_lv s_o x

let dep_lvs s_o xs =
  List.fold_left dep_lv s_o xs

(** Adds to [s] variables that are used as destination or to compute a
destination (array index, memory offset) *)
let weak_dep_lv s = function
  | Lnone _     -> s
  | Lvar x      -> Sv.add (L.unloc x) s
  | Lmem(_, _, _, e) -> Sv.union (vars_e e) s
  | Laset(_, _, _, x, e)
  | Lasub(_, _, _, x, e) -> Sv.add (L.unloc x) (Sv.union (vars_e e) s)

let weak_dep_lvs s lvs = List.fold_left weak_dep_lv s lvs

(* When [weak] is true, the out live-set contains also the written variables and
the variables that are used for evaluating LHS expressions. *)
let rec live_i weak i s_o =
  let s_i, s_o, d = live_d weak i.i_desc s_o in
  s_i, { i with i_desc = d; i_info = (s_i, s_o); }

and live_d weak d (s_o: Sv.t) =
  match d with
  | Cassgn(x, tg, ty, e) ->

    let s_i = Sv.union (vars_e e) (dep_lv s_o x) in
    let s_o =
      if weak then weak_dep_lv s_o x
      else s_o in
    s_i, s_o, Cassgn(x, tg, ty, e)

  | Copn(xs,t,o,es) ->
    let s_i = Sv.union (vars_es es) (dep_lvs s_o xs) in
    let s_o =
     if weak
     then weak_dep_lvs s_o xs
     else s_o in
    s_i, s_o, Copn(xs,t,o,es)

  | Cif(e,c1,c2) ->
    let s1, c1 = live_c weak c1 s_o in
    let s2, c2 = live_c weak c2 s_o in
    Sv.union (vars_e e) (Sv.union s1 s2), s_o, Cif(e, c1, c2)

  | Cfor (x, (_dir, e1, e2 as r), c) ->
    let rec loop s_o =
      let s_i, c = live_c weak c s_o in
      let s_i = Sv.remove (L.unloc x) s_i in
      if Sv.subset s_i s_o then s_o, c
      else loop (Sv.union s_i s_o) in
    let s_i, c = loop s_o in
    Sv.union (vars_es [ e1; e2 ]) s_i, s_o, Cfor (x, r, c)

  | Cwhile(a, c, e, (info, _), c') ->
    let ve = (vars_e e) in
    let rec loop s_o =
      (* loop (c; if e then c' else exit) *)
      let s_o' = Sv.union ve s_o in
      let s_i, c = live_c weak c s_o' in
      let s_i', c' = live_c weak c' s_i in
      if Sv.subset s_i' s_o then s_i, (s_o', s_i'), (c, c')
      else loop (Sv.union s_i' s_o) in
    let s_i, se, (c,c') = loop s_o in
    s_i, s_o, Cwhile(a, c, e, (info, se), c')

  | Ccall(xs,f,es) ->
    let s_i = Sv.union (vars_es es) (dep_lvs s_o xs) in
    s_i, (if weak then weak_dep_lvs s_o xs else s_o), Ccall(xs,f,es)

  | Csyscall(xs,o,es) ->
    let s_i = Sv.union (vars_es es) (dep_lvs s_o xs) in
    s_i, (if weak then weak_dep_lvs s_o xs else s_o), Csyscall(xs,o,es)

and live_c weak c s_o =
  List.fold_right
    (fun i (s_o, c) ->
      let s_i, i = live_i weak i s_o in
      (s_i, i :: c))
    c
    (s_o, [])

let live_fd weak fd =
  let s_o = vars_ret fd in
  let s_i, c = live_c weak fd.f_body s_o in
  { fd with f_body = c; f_info = (s_i, s_o) }

let liveness weak prog =
  let fds = List.map (live_fd weak) (snd prog) in
  fst prog, fds

let iter_call_sites (cbf: L.i_loc -> funname -> lvals -> Sv.t * Sv.t -> unit)
                    (cbs: L.i_loc -> BinNums.positive Syscall_t.syscall_t -> lvals -> Sv.t * Sv.t -> unit)
                    (f: (Sv.t * Sv.t, 'asm) func) : unit =
  iter_instr (fun i ->
      match i.i_desc with
      | Ccall (xs, fn, _) -> cbf i.i_loc fn xs i.i_info
      | Csyscall (xs, op, _) -> cbs i.i_loc op xs i.i_info
      | (Cassgn _ | Copn _ | Cif _ | Cfor _ | Cwhile _) -> ()
    ) f.f_body

let pp_info fmt (s1, s2) =
  Format.fprintf fmt "before: %a; after %a@ "
    (pp_list " " (Printer.pp_var ~debug:true)) (Sv.elements s1)
    (pp_list " " (Printer.pp_var ~debug:true)) (Sv.elements s2)

let merge_class cf s =
  let add_conflict x cf =
    Mv.modify_def Sv.empty x (Sv.union (Sv.remove x s)) cf
  in
  Sv.fold add_conflict s cf

let rec conflicts_i cf i =
  let (s1, s2) = i.i_info in
  let cf = merge_class cf s1 in

  match i.i_desc with
  | Cassgn _ | Copn _ | Csyscall _ | Ccall _ ->
    merge_class cf s2
  | Cfor( _, _, c) ->
    conflicts_c (merge_class cf s2) c
  | Cif(_, c1, c2) | Cwhile(_, c1, _, _, c2) ->
    conflicts_c (conflicts_c (merge_class cf s2) c1) c2
and conflicts_c cf c =
  List.fold_left conflicts_i cf c


type conflicts = Sv.t Mv.t

let conflicts f =
  let ca = Sv.of_list f.f_args in
  let cr = Sv.of_list (List.map L.unloc f.f_ret) in
  let cf = merge_class Mv.empty ca in
  let cf = merge_class cf cr in
  conflicts_c cf f.f_body

type var_classes = conflicts * var Mv.t

let init_classes cf = cf, Mv.empty

let get_conflict (cf,_) x =
  Mv.find_default Sv.empty x cf

let rec get_repr m x =
  if Mv.mem x m then get_repr m (Mv.find x m)
  else x

let normalize_repr (_c,m) =
  Mv.mapi (fun x _ -> get_repr m x) m

exception SetSameConflict

let merge_class1 cf rx xc ry yc =
  (* ajoute x dans les conflits de y *)
  let add_conflict x y cf =
    Mv.modify_def Sv.empty y (Sv.add x) cf
  in
  let cf = Sv.fold (add_conflict rx) yc cf in
  let cf = Sv.fold (add_conflict ry) xc cf in
  let c = Sv.union xc yc in
  let cf = Mv.add rx c cf in
  let cf = Mv.add ry c cf in
  cf

(*
let pp_map fmt m =
  Mv.iter (fun v1 v2 ->
      Format.fprintf fmt "%a ----> %a@."
         (Printer.pp_var ~debug:true) v1 (Printer.pp_var ~debug:true) v2)
      m
 *)

let set_same (cf, m as cfm) x y =
  let rx = get_repr m x in
  let ry = get_repr m y in
  if V.equal rx ry then cfm
  else
    let xc = Mv.find_default Sv.empty rx cf in
    let yc = Mv.find_default Sv.empty ry cf in
    if Sv.mem rx yc then
      begin
(*        let pp_v = Printer.pp_var ~debug:true in
        Format.eprintf "map:@.%a@.@."
          pp_map m;
        Format.eprintf "x = %a --> %a; y = %a --> %a@."
           pp_v x pp_v rx pp_v y pp_v ry;
        Format.eprintf "rx = %a@."
           (pp_list " " pp_v) (Sv.elements xc);
        Format.eprintf "ry = %a@."
           (pp_list " " pp_v) (Sv.elements yc); *)
        raise SetSameConflict
      end;
    merge_class1 cf rx xc ry yc, Mv.add rx ry m

let var_classes_merge cfm1 (_cf2, m2) =
  Mv.fold (fun x _ cfm ->
      let r = get_repr m2 x in
      set_same cfm x r
    ) m2 cfm1

let var_classes_incl (_cf1, m1) (_cf2, m2) =
  Mv.for_all (fun x y ->
      V.equal (get_repr m2 x) (get_repr m2 y)
    ) m1