Source file dominators.ml

(*
 *
 * Copyright (c) 2001-2002,
 *  George C. Necula    <necula@cs.berkeley.edu>
 *  Scott McPeak        <smcpeak@cs.berkeley.edu>
 *  Wes Weimer          <weimer@cs.berkeley.edu>
 * All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are
 * met:
 *
 * 1. Redistributions of source code must retain the above copyright
 * notice, this list of conditions and the following disclaimer.
 *
 * 2. Redistributions in binary form must reproduce the above copyright
 * notice, this list of conditions and the following disclaimer in the
 * documentation and/or other materials provided with the distribution.
 *
 * 3. The names of the contributors may not be used to endorse or promote
 * products derived from this software without specific prior written
 * permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
 * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
 * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
 * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
 * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
 * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
 * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
 * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
 * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
 * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
 * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 *
 *)

(** Compute dominator information for the statements in a function *)
open Cil
open Pretty
module E = Errormsg
module H = Hashtbl
module U = Util
module IH = Inthash

module DF = Dataflow

let debug = false

(* For each statement we maintain a set of statements that dominate it *)
module BS = Set.Make(struct
                        type t = Cil.stmt
                        let compare v1 v2 = Stdlib.compare v1.sid v2.sid
                     end)




(** Customization module for dominators *)
module DT = struct
  let name = "dom"

  let debug = ref debug

  type t = BS.t

   (** For each statement in a function we keep the set of dominator blocks.
    * Indexed by statement id *)
  let stmtStartData: t IH.t = IH.create 17

  let copy (d: t) = d

  let pretty () (d: t) =
    dprintf "{%a}"
      (docList (fun s -> dprintf "%d" s.sid))
      (BS.elements d)

  let computeFirstPredecessor (s: stmt) (d: BS.t) : BS.t =
    (* Make sure we add this block to the set *)
    BS.add s d

  let combinePredecessors (s: stmt) ~(old: BS.t) (d: BS.t) : BS.t option =
    (* First, add this block to the data from the predecessor *)
    let d' = BS.add s d in
    if BS.subset old d' then
      None
    else
      Some (BS.inter old d')

  let doInstr (i: instr) (d: t) = DF.Default

  let doStmt (s: stmt) (d: t) = DF.SDefault

  let doGuard condition _ = DF.GDefault


  let filterStmt _ = true
end



module Dom = DF.ForwardsDataFlow(DT)

let getStmtDominators (data: BS.t IH.t) (s: stmt) : BS.t =
  try IH.find data s.sid
  with Not_found -> BS.empty (* Not reachable *)


let getIdom (idomInfo: stmt option IH.t) (s: stmt) =
  try IH.find idomInfo s.sid
  with Not_found ->
    E.s (E.bug "Immediate dominator information not set for statement %d"
           s.sid)

(** Check whether one block dominates another. This assumes that the "idom"
 * field has been computed. *)
let rec dominates (idomInfo: stmt option IH.t) (s1: stmt) (s2: stmt) =
  s1 == s2 ||
  (let s2idom = getIdom idomInfo s2 in
  match s2idom with
    None -> false
  | Some s2idom -> dominates idomInfo s1 s2idom)




let computeIDom ?(doCFG:bool=true) (f: fundec) : stmt option IH.t =
  (* We must prepare the CFG info first *)
  if doCFG then begin
    prepareCFG f;
    computeCFGInfo f false
  end;
  IH.clear DT.stmtStartData;
  let idomData: stmt option IH.t = IH.create 13 in

  let _ =
    match f.sbody.bstmts with
      [] -> () (* function has no body *)
    | start :: _ -> begin
        (* We start with only the start block *)
        IH.add DT.stmtStartData start.sid (BS.singleton start);

        Dom.compute [start];

        (* Dump the dominators information *)
         if debug then
           List.iter
             (fun s ->
               let sdoms = getStmtDominators DT.stmtStartData s in
               if not (BS.mem s sdoms) then begin
                 (* It can be that the block is not reachable *)
                 if s.preds <> [] then
                   E.s (E.bug "Statement %d is not in its list of dominators"
                          s.sid);
               end;
               ignore (E.log "Dominators for %d: %a\n" s.sid
                         DT.pretty (BS.remove s sdoms)))
             f.sallstmts;

        (* Now fill the immediate dominators for all nodes *)
        let rec fillOneIdom (s: stmt) =
          try
            ignore (IH.find idomData s.sid)
              (* Already set *)
          with Not_found -> begin
            (* Get the dominators *)
            let sdoms = getStmtDominators DT.stmtStartData s in
            (* Fill the idom for the dominators first *)
            let idom =
              BS.fold
                (fun d (sofar: stmt option) ->
                  if d.sid = s.sid then
                    sofar (* Ignore the block itself *)
                  else begin
                    (* fill the idom information recursively *)
                    fillOneIdom d;
                    match sofar with
                      None -> Some d
                    | Some sofar' ->
                        (* See if d is dominated by sofar. We know that the
                         * idom information has been computed for both sofar
                         * and for d*)
                        if dominates idomData sofar' d then
                          Some d
                        else
                          sofar
                  end)
                sdoms
                None
            in
            IH.replace idomData s.sid idom
          end
        in
        (* Scan all blocks and compute the idom *)
        List.iter fillOneIdom f.sallstmts
    end
  in
  idomData

type tree = stmt option * BS.t IH.t

(* returns the IDoms and a map from statement ids to
   the set of statements that are dominated *)
let computeDomTree ?(doCFG:bool=true) (f: fundec)
    : stmt option IH.t * tree =
  (* We must prepare the CFG info first *)
  if doCFG then begin
    prepareCFG f;
    computeCFGInfo f false
  end;
  IH.clear DT.stmtStartData;
  let treeData: BS.t IH.t = IH.create 64 in
  let idomData: stmt option IH.t = IH.create 64 in

  let _ =
    match f.sbody.bstmts with
      [] -> () (* function has no body *)
    | start :: _ -> begin
        (* We start with only the start block *)
        IH.add DT.stmtStartData start.sid (BS.singleton start);

        Dom.compute [start];

        (* Dump the dominators information *)
         if debug then
           List.iter
             (fun s ->
               let sdoms = getStmtDominators DT.stmtStartData s in
               if not (BS.mem s sdoms) then begin
                 (* It can be that the block is not reachable *)
                 if s.preds <> [] then
                   E.s (E.bug "Statement %d is not in its list of dominators"
                          s.sid);
               end;
               ignore (E.log "Dominators for %d: %a\n" s.sid
                         DT.pretty (BS.remove s sdoms)))
             f.sallstmts;

        (* Now fill the immediate dominators for all nodes *)
        let rec fillOneIdom (s: stmt) =
          try
            ignore (IH.find idomData s.sid)
              (* Already set *)
          with Not_found -> begin
            (* Get the dominators *)
            let sdoms = getStmtDominators DT.stmtStartData s in
            (* Fill the idom for the dominators first *)
            let idom =
              BS.fold
                (fun d (sofar: stmt option) ->
                  if d.sid = s.sid then
                    sofar (* Ignore the block itself *)
                  else begin
                    (* fill the idom information recursively *)
                    fillOneIdom d;
                    match sofar with
                      None -> Some d
                    | Some sofar' ->
                        (* See if d is dominated by sofar. We know that the
                         * idom information has been computed for both sofar
                         * and for d*)
                        if dominates idomData sofar' d then
                          Some d
                        else
                          sofar
                  end)
                sdoms
                None
            in
            IH.replace idomData s.sid idom;
	    match idom with
	    | None -> ()
	    | Some d -> begin
		match IH.tryfind treeData d.sid with
		| None -> IH.add treeData d.sid (BS.singleton s)
		| Some bs -> IH.replace treeData d.sid (BS.add s bs)
	    end
          end
        in
        (* Scan all blocks and compute the idom *)
        List.iter fillOneIdom f.sallstmts
    end
  in
  try idomData, (Some(List.hd f.sbody.bstmts), treeData)
  with Failure _ -> idomData, (None, treeData)

type order = PreOrder | PostOrder

let rec domTreeIter (f: stmt -> unit)
                    (o : order)
                    (t: tree)
    : unit
    =
  let doChildren s =
    match IH.tryfind (snd t) s.sid with
    | None -> () (* No children *)
    | Some bs -> begin
	BS.iter (fun s -> domTreeIter f o (Some s, snd t)) bs
    end
  in
  match fst t with
  | None -> ()
  | Some s -> begin (* s is the current root *)
      match o with
      | PreOrder -> begin (* do s first *)
	  f s;
	  doChildren s
      end
      | PostOrder -> begin (* do s's children first *)
	  doChildren s;
	  f s
      end
  end

let children (t: tree) (s: stmt) : stmt list =
  match IH.tryfind (snd t) s.sid with
  | None -> []
  | Some bs -> BS.elements bs

(** Compute the start of the natural loops. For each start, keep a list of
 * origin of a back edge. The loop consists of the loop start and all
 * predecessors of the origins of back edges, up to and including the loop
 * start *)
let findNaturalLoops (f: fundec)
                     (idomData: stmt option IH.t) : (stmt * stmt list) list =
  let loops =
    List.fold_left
      (fun acc b ->
        (* Iterate over all successors, and see if they are among the
         * dominators for this block *)
        List.fold_left
          (fun acc s ->
            if dominates idomData s b then
              (* s is the start of a natural loop *)
              let rec addNaturalLoop = function
                  [] -> [(s, [b])]
                | (s', backs) :: rest when s'.sid = s.sid ->
                    (s', b :: backs) :: rest
                | l :: rest -> l :: addNaturalLoop rest
              in
              addNaturalLoop acc
            else
              acc)
          acc
          b.succs)
      []
      f.sallstmts
  in

  if debug then
    ignore (E.log "Natural loops:\n%a\n"
              (docList ~sep:line
                 (fun (s, backs) ->
                   dprintf "    Start: %d, backs:%a"
                     s.sid
                     (docList (fun b -> num b.sid))
                     backs))
              loops);

  loops