CmmProcPoint.hs 4.41 KB
Newer Older
1 2 3 4 5 6 7
module CmmProcPoint (
  calculateProcPoints
  ) where

#include "HsVersions.h"

import Cmm
8
import CmmBrokenBlock
9 10 11 12 13 14
import Dataflow

import UniqSet
import UniqFM
import Panic

15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37
-- Determine the proc points for a set of basic blocks.
--
-- A proc point is any basic block that must start a new function.
-- The entry block of the original function is a proc point.
-- The continuation of a function call is also a proc point.
-- The third kind of proc point arises when there is a joint point
-- in the control flow.  Suppose we have code like the following:
--
--   if (...) { ...; call foo(); ...}
--   else { ...; call bar(); ...}
--   x = y;
--
-- That last statement "x = y" must be a proc point because
-- it can be reached by blocks owned by different proc points
-- (the two branches of the conditional).
--
-- We calculate these proc points by starting with the minimal set
-- and finding blocks that are reachable from more proc points than
-- one of their parents.  (This ensures we don't choose a block
-- simply beause it is reachable from another block that is reachable
-- from multiple proc points.)  These new blocks are added to the
-- set of proc points and the process is repeated until there
-- are no more proc points to be found.
38 39

calculateProcPoints :: [BrokenBlock] -> UniqSet BlockId
40 41
calculateProcPoints blocks =
    calculateProcPoints' init_proc_points blocks
42 43 44 45 46
    where
      init_proc_points = mkUniqSet $
                         map brokenBlockId $
                         filter always_proc_point blocks
      always_proc_point BrokenBlock {
47
                              brokenBlockEntry = FunctionEntry _ _ _ } = True
48
      always_proc_point BrokenBlock {
49
                              brokenBlockEntry = ContinuationEntry _ _ _ } = True
50 51 52 53 54 55 56 57 58 59 60 61
      always_proc_point _ = False

calculateProcPoints' :: UniqSet BlockId -> [BrokenBlock] -> UniqSet BlockId
calculateProcPoints' old_proc_points blocks =
    if sizeUniqSet old_proc_points == sizeUniqSet new_proc_points
      then old_proc_points
      else calculateProcPoints' new_proc_points blocks
    where
      blocks_ufm :: BlockEnv BrokenBlock
      blocks_ufm = blocksToBlockEnv blocks

      owners = calculateOwnership blocks_ufm old_proc_points blocks
62 63 64 65
      new_proc_points =
          unionManyUniqSets
            (old_proc_points:
             map (calculateNewProcPoints owners) blocks)
66

67 68 69 70 71
calculateNewProcPoints :: BlockEnv (UniqSet BlockId)
                       -> BrokenBlock
                       -> UniqSet BlockId
calculateNewProcPoints  owners block =
    unionManyUniqSets (map (maybe_proc_point parent_id) child_ids)
72 73 74
    where
      parent_id = brokenBlockId block
      child_ids = brokenBlockTargets block
75
      maybe_proc_point parent_id child_id =
76 77 78 79 80 81
          if needs_proc_point
            then unitUniqSet child_id
            else emptyUniqSet
          where
            parent_owners = lookupWithDefaultUFM owners emptyUniqSet parent_id
            child_owners = lookupWithDefaultUFM owners emptyUniqSet child_id
82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115
            needs_proc_point = not $ isEmptyUniqSet $
                               child_owners `minusUniqSet` parent_owners

calculateOwnership :: BlockEnv BrokenBlock
                   -> UniqSet BlockId
                   -> [BrokenBlock]
                   -> BlockEnv (UniqSet BlockId)
calculateOwnership blocks_ufm proc_points blocks =
    fixedpoint dependants update (map brokenBlockId blocks) emptyUFM
    where
      dependants :: BlockId -> [BlockId]
      dependants ident =
          brokenBlockTargets $ lookupWithDefaultUFM
                                 blocks_ufm unknown_block ident

      update :: BlockId
             -> Maybe BlockId
             -> BlockEnv (UniqSet BlockId)
             -> Maybe (BlockEnv (UniqSet BlockId))
      update ident cause owners =
          case (cause, ident `elementOfUniqSet` proc_points) of
            (Nothing, True) ->
                Just $ addToUFM owners ident (unitUniqSet ident)
            (Nothing, False) -> Nothing
            (Just cause', True) -> Nothing
            (Just cause', False) ->
                if (sizeUniqSet old) == (sizeUniqSet new)
                   then Nothing
                   else Just $ addToUFM owners ident new
                where
                  old = lookupWithDefaultUFM owners emptyUniqSet ident
                  new = old `unionUniqSets`
                        lookupWithDefaultUFM owners emptyUniqSet cause'

116
      unknown_block = panic "unknown BlockId in calculateOwnership"