compiler/cmm/CmmProcPoint.hs

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