compiler/cmm/CmmProcPoint.hs

   1 module CmmProcPoint (
   2   calculateProcPoints
   3   ) where
   4
   5 #include "HsVersions.h"
   6
   7 import Cmm
   8 import CmmBrokenBlock
   9 import Dataflow
  10
  11 import UniqSet
  12 import UniqFM
  13 import Panic
  14
  15 -- Determine the proc points for a set of basic blocks.
  16 --
  17 -- A proc point is any basic block that must start a new function.
  18 -- The entry block of the original function is a proc point.
  19 -- The continuation of a function call is also a proc point.
  20 -- The third kind of proc point arises when there is a joint point
  21 -- in the control flow.  Suppose we have code like the following:
  22 --
  23 --   if (...) { ...; call foo(); ...}
  24 --   else { ...; call bar(); ...}
  25 --   x = y;
  26 --
  27 -- That last statement "x = y" must be a proc point because
  28 -- it can be reached by blocks owned by different proc points
  29 -- (the two branches of the conditional).
  30 --
  31 -- We calculate these proc points by starting with the minimal set
  32 -- and finding blocks that are reachable from more proc points than
  33 -- one of their parents.  (This ensures we don't choose a block
  34 -- simply beause it is reachable from another block that is reachable
  35 -- from multiple proc points.)  These new blocks are added to the
  36 -- set of proc points and the process is repeated until there
  37 -- are no more proc points to be found.
  38
  39 calculateProcPoints :: [BrokenBlock] -> UniqSet BlockId
  40 calculateProcPoints blocks =
  41     calculateProcPoints' init_proc_points blocks
  42     where
  43       init_proc_points = mkUniqSet $
  44                          map brokenBlockId $
  45                          filter always_proc_point blocks
  46       always_proc_point BrokenBlock {
  47                               brokenBlockEntry = FunctionEntry _ _ _ } = True
  48       always_proc_point BrokenBlock {
  49                               brokenBlockEntry = ContinuationEntry _ _ _ } = True
  50       always_proc_point _ = False
  51
  52 calculateProcPoints' :: UniqSet BlockId -> [BrokenBlock] -> UniqSet BlockId
  53 calculateProcPoints' old_proc_points blocks =
  54     if sizeUniqSet old_proc_points == sizeUniqSet new_proc_points
  55       then old_proc_points
  56       else calculateProcPoints' new_proc_points blocks
  57     where
  58       blocks_ufm :: BlockEnv BrokenBlock
  59       blocks_ufm = blocksToBlockEnv blocks
  60
  61       owners = calculateOwnership blocks_ufm old_proc_points blocks
  62       new_proc_points =
  63           unionManyUniqSets
  64             (old_proc_points:
  65              map (calculateNewProcPoints owners) blocks)
  66
  67 calculateNewProcPoints :: BlockEnv (UniqSet BlockId)
  68                        -> BrokenBlock
  69                        -> UniqSet BlockId
  70 calculateNewProcPoints  owners block =
  71     unionManyUniqSets (map (maybe_proc_point parent_id) child_ids)
  72     where
  73       parent_id = brokenBlockId block
  74       child_ids = brokenBlockTargets block
  75       maybe_proc_point parent_id child_id =
  76           if needs_proc_point
  77             then unitUniqSet child_id
  78             else emptyUniqSet
  79           where
  80             parent_owners = lookupWithDefaultUFM owners emptyUniqSet parent_id
  81             child_owners = lookupWithDefaultUFM owners emptyUniqSet child_id
  82             needs_proc_point =
  83                 -- only if parent isn't dead
  84                 (not $ isEmptyUniqSet parent_owners) &&
  85                 -- and only if child has more owners than parent
  86                 (not $ isEmptyUniqSet $
  87                      child_owners `minusUniqSet` parent_owners)
  88
  89 calculateOwnership :: BlockEnv BrokenBlock
  90                    -> UniqSet BlockId
  91                    -> [BrokenBlock]
  92                    -> BlockEnv (UniqSet BlockId)
  93 calculateOwnership blocks_ufm proc_points blocks =
  94     fixedpoint dependants update (map brokenBlockId blocks) emptyUFM
  95     where
  96       dependants :: BlockId -> [BlockId]
  97       dependants ident =
  98           brokenBlockTargets $ lookupWithDefaultUFM
  99                                  blocks_ufm unknown_block ident
 100
 101       update :: BlockId
 102              -> Maybe BlockId
 103              -> BlockEnv (UniqSet BlockId)
 104              -> Maybe (BlockEnv (UniqSet BlockId))
 105       update ident cause owners =
 106           case (cause, ident `elementOfUniqSet` proc_points) of
 107             (Nothing, True) ->
 108                 Just $ addToUFM owners ident (unitUniqSet ident)
 109             (Nothing, False) -> Nothing
 110             (Just cause', True) -> Nothing
 111             (Just cause', False) ->
 112                 if (sizeUniqSet old) == (sizeUniqSet new)
 113                    then Nothing
 114                    else Just $ addToUFM owners ident new
 115                 where
 116                   old = lookupWithDefaultUFM owners emptyUniqSet ident
 117                   new = old `unionUniqSets`
 118                         lookupWithDefaultUFM owners emptyUniqSet cause'
 119
 120       unknown_block = panic "unknown BlockId in calculateOwnership"