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

#include "HsVersions.h"

7
import BlockId
8
import CmmBrokenBlock
9 10 11 12 13
import Dataflow

import UniqSet
import Panic

14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36
-- 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.
37 38

calculateProcPoints :: [BrokenBlock] -> UniqSet BlockId
39 40
calculateProcPoints blocks =
    calculateProcPoints' init_proc_points blocks
41 42 43 44 45
    where
      init_proc_points = mkUniqSet $
                         map brokenBlockId $
                         filter always_proc_point blocks
      always_proc_point BrokenBlock {
46
                              brokenBlockEntry = FunctionEntry _ _ _ } = True
47
      always_proc_point BrokenBlock {
48
                              brokenBlockEntry = ContinuationEntry _ _ _ } = True
49 50 51 52 53 54 55 56 57 58 59 60
      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
61 62 63 64
      new_proc_points =
          unionManyUniqSets
            (old_proc_points:
             map (calculateNewProcPoints owners) blocks)
65

66 67 68 69 70
calculateNewProcPoints :: BlockEnv (UniqSet BlockId)
                       -> BrokenBlock
                       -> UniqSet BlockId
calculateNewProcPoints  owners block =
    unionManyUniqSets (map (maybe_proc_point parent_id) child_ids)
71 72 73
    where
      parent_id = brokenBlockId block
      child_ids = brokenBlockTargets block
74
      maybe_proc_point parent_id child_id =
75 76 77 78
          if needs_proc_point
            then unitUniqSet child_id
            else emptyUniqSet
          where
79 80
            parent_owners = lookupWithDefaultBEnv owners emptyUniqSet parent_id
            child_owners = lookupWithDefaultBEnv owners emptyUniqSet child_id
81 82 83 84 85 86
            needs_proc_point =
                -- only if parent isn't dead
                (not $ isEmptyUniqSet parent_owners) &&
                -- and only if child has more owners than parent
                (not $ isEmptyUniqSet $
                     child_owners `minusUniqSet` parent_owners)
87 88 89 90 91 92

calculateOwnership :: BlockEnv BrokenBlock
                   -> UniqSet BlockId
                   -> [BrokenBlock]
                   -> BlockEnv (UniqSet BlockId)
calculateOwnership blocks_ufm proc_points blocks =
93
    fixedpoint dependants update (map brokenBlockId blocks) emptyBlockEnv
94 95 96
    where
      dependants :: BlockId -> [BlockId]
      dependants ident =
97
          brokenBlockTargets $ lookupWithDefaultBEnv
98 99 100 101 102 103 104 105 106
                                 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) ->
107
                Just $ extendBlockEnv owners ident (unitUniqSet ident)
108
            (Nothing, False) -> Nothing
Ian Lynagh's avatar
Ian Lynagh committed
109
            (Just _,      True) -> Nothing
110 111 112
            (Just cause', False) ->
                if (sizeUniqSet old) == (sizeUniqSet new)
                   then Nothing
113
                   else Just $ extendBlockEnv owners ident new
114
                where
115
                  old = lookupWithDefaultBEnv owners emptyUniqSet ident
116
                  new = old `unionUniqSets`
117
                        lookupWithDefaultBEnv owners emptyUniqSet cause'
118

119
      unknown_block = panic "unknown BlockId in calculateOwnership"