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 = not $ isEmptyUniqSet $
  83                                child_owners `minusUniqSet` parent_owners
  84
  85 calculateOwnership :: BlockEnv BrokenBlock
  86                    -> UniqSet BlockId
  87                    -> [BrokenBlock]
  88                    -> BlockEnv (UniqSet BlockId)
  89 calculateOwnership blocks_ufm proc_points blocks =
  90     fixedpoint dependants update (map brokenBlockId blocks) emptyUFM
  91     where
  92       dependants :: BlockId -> [BlockId]
  93       dependants ident =
  94           brokenBlockTargets $ lookupWithDefaultUFM
  95                                  blocks_ufm unknown_block ident
  96
  97       update :: BlockId
  98              -> Maybe BlockId
  99              -> BlockEnv (UniqSet BlockId)
 100              -> Maybe (BlockEnv (UniqSet BlockId))
 101       update ident cause owners =
 102           case (cause, ident `elementOfUniqSet` proc_points) of
 103             (Nothing, True) ->
 104                 Just $ addToUFM owners ident (unitUniqSet ident)
 105             (Nothing, False) -> Nothing
 106             (Just cause', True) -> Nothing
 107             (Just cause', False) ->
 108                 if (sizeUniqSet old) == (sizeUniqSet new)
 109                    then Nothing
 110                    else Just $ addToUFM owners ident new
 111                 where
 112                   old = lookupWithDefaultUFM owners emptyUniqSet ident
 113                   new = old `unionUniqSets`
 114                         lookupWithDefaultUFM owners emptyUniqSet cause'
 115
 116       unknown_block = panic "unknown BlockId in calculateOwnership"