compiler/cmm/CmmProcPoint.hs

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