CmmProcPoint.hs 4.85 KB
Newer Older
1 2 3 4 5 6 7
{-# OPTIONS_GHC -w #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
--     http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
-- for details

8 9 10 11 12 13 14
module CmmProcPoint (
  calculateProcPoints
  ) where

#include "HsVersions.h"

import Cmm
15
import CmmBrokenBlock
16 17 18 19 20 21
import Dataflow

import UniqSet
import UniqFM
import Panic

22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44
-- 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.
45 46

calculateProcPoints :: [BrokenBlock] -> UniqSet BlockId
47 48
calculateProcPoints blocks =
    calculateProcPoints' init_proc_points blocks
49 50 51 52 53
    where
      init_proc_points = mkUniqSet $
                         map brokenBlockId $
                         filter always_proc_point blocks
      always_proc_point BrokenBlock {
54
                              brokenBlockEntry = FunctionEntry _ _ _ } = True
55
      always_proc_point BrokenBlock {
56
                              brokenBlockEntry = ContinuationEntry _ _ _ } = True
57 58 59 60 61 62 63 64 65 66 67 68
      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
69 70 71 72
      new_proc_points =
          unionManyUniqSets
            (old_proc_points:
             map (calculateNewProcPoints owners) blocks)
73

74 75 76 77 78
calculateNewProcPoints :: BlockEnv (UniqSet BlockId)
                       -> BrokenBlock
                       -> UniqSet BlockId
calculateNewProcPoints  owners block =
    unionManyUniqSets (map (maybe_proc_point parent_id) child_ids)
79 80 81
    where
      parent_id = brokenBlockId block
      child_ids = brokenBlockTargets block
82
      maybe_proc_point parent_id child_id =
83 84 85 86 87 88
          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
89 90 91 92 93 94
            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)
95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126

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'

127
      unknown_block = panic "unknown BlockId in calculateOwnership"