+{-# 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
+
module CmmProcPoint (
calculateProcPoints
) where
import UniqFM
import Panic
-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'
-
- unknown_block = panic "unknown BlockId in selectStackFormat"
+-- 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.
calculateProcPoints :: [BrokenBlock] -> UniqSet BlockId
calculateProcPoints blocks =
always_proc_point BrokenBlock {
brokenBlockEntry = FunctionEntry _ _ _ } = True
always_proc_point BrokenBlock {
- brokenBlockEntry = ContinuationEntry _ _ } = True
+ brokenBlockEntry = ContinuationEntry _ _ _ } = True
always_proc_point _ = False
calculateProcPoints' :: UniqSet BlockId -> [BrokenBlock] -> UniqSet BlockId
blocks_ufm = blocksToBlockEnv blocks
owners = calculateOwnership blocks_ufm old_proc_points blocks
- new_proc_points = unionManyUniqSets (old_proc_points:(map (calculateProcPoints'' owners) blocks))
+ new_proc_points =
+ unionManyUniqSets
+ (old_proc_points:
+ map (calculateNewProcPoints owners) blocks)
-calculateProcPoints'' :: BlockEnv (UniqSet BlockId) -> BrokenBlock -> UniqSet BlockId
-calculateProcPoints'' owners block =
- unionManyUniqSets (map (f parent_id) child_ids)
+calculateNewProcPoints :: BlockEnv (UniqSet BlockId)
+ -> BrokenBlock
+ -> UniqSet BlockId
+calculateNewProcPoints owners block =
+ unionManyUniqSets (map (maybe_proc_point parent_id) child_ids)
where
parent_id = brokenBlockId block
child_ids = brokenBlockTargets block
- -- TODO: name for f
- f parent_id child_id =
+ maybe_proc_point parent_id child_id =
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
- needs_proc_point = not $ isEmptyUniqSet $ child_owners `minusUniqSet` parent_owners
+ 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)
+
+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'
+
+ unknown_block = panic "unknown BlockId in calculateOwnership"
projects / ghc-hetmet.git / blobdiff