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 calculateOwnership :: BlockEnv BrokenBlock -> UniqSet BlockId -> [BrokenBlock] -> BlockEnv (UniqSet BlockId)
  16 calculateOwnership blocks_ufm proc_points blocks =
  17     fixedpoint dependants update (map brokenBlockId blocks) emptyUFM
  18     where
  19       dependants :: BlockId -> [BlockId]
  20       dependants ident =
  21           brokenBlockTargets $ lookupWithDefaultUFM
  22                                  blocks_ufm unknown_block ident
  23
  24       update :: BlockId -> Maybe BlockId
  25              -> BlockEnv (UniqSet BlockId) -> Maybe (BlockEnv (UniqSet BlockId))
  26       update ident cause owners =
  27           case (cause, ident `elementOfUniqSet` proc_points) of
  28             (Nothing, True) -> Just $ addToUFM owners ident (unitUniqSet ident)
  29             (Nothing, False) -> Nothing
  30             (Just cause', True) -> Nothing
  31             (Just cause', False) ->
  32                 if (sizeUniqSet old) == (sizeUniqSet new)
  33                    then Nothing
  34                    else Just $ addToUFM owners ident new
  35                 where
  36                   old = lookupWithDefaultUFM owners emptyUniqSet ident
  37                   new = old `unionUniqSets` lookupWithDefaultUFM owners emptyUniqSet cause'
  38
  39       unknown_block = panic "unknown BlockId in selectStackFormat"
  40
  41 calculateProcPoints :: [BrokenBlock] -> UniqSet BlockId
  42 calculateProcPoints blocks =
  43     calculateProcPoints' init_proc_points blocks
  44     where
  45       init_proc_points = mkUniqSet $
  46                          map brokenBlockId $
  47                          filter always_proc_point blocks
  48       always_proc_point BrokenBlock {
  49                               brokenBlockEntry = FunctionEntry _ _ _ } = True
  50       always_proc_point BrokenBlock {
  51                               brokenBlockEntry = ContinuationEntry _ _ } = True
  52       always_proc_point _ = False
  53
  54 calculateProcPoints' :: UniqSet BlockId -> [BrokenBlock] -> UniqSet BlockId
  55 calculateProcPoints' old_proc_points blocks =
  56     if sizeUniqSet old_proc_points == sizeUniqSet new_proc_points
  57       then old_proc_points
  58       else calculateProcPoints' new_proc_points blocks
  59     where
  60       blocks_ufm :: BlockEnv BrokenBlock
  61       blocks_ufm = blocksToBlockEnv blocks
  62
  63       owners = calculateOwnership blocks_ufm old_proc_points blocks
  64       new_proc_points = unionManyUniqSets (old_proc_points:(map (calculateProcPoints'' owners) blocks))
  65
  66 calculateProcPoints'' :: BlockEnv (UniqSet BlockId) -> BrokenBlock -> UniqSet BlockId
  67 calculateProcPoints''  owners block =
  68     unionManyUniqSets (map (f parent_id) child_ids)
  69     where
  70       parent_id = brokenBlockId block
  71       child_ids = brokenBlockTargets block
  72       -- TODO: name for f
  73       f parent_id child_id =
  74           if needs_proc_point
  75             then unitUniqSet child_id
  76             else emptyUniqSet
  77           where
  78             parent_owners = lookupWithDefaultUFM owners emptyUniqSet parent_id
  79             child_owners = lookupWithDefaultUFM owners emptyUniqSet child_id
  80             needs_proc_point = not $ isEmptyUniqSet $ child_owners `minusUniqSet` parent_owners