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