module CmmProcPoint (
calculateProcPoints
) where
#include "HsVersions.h"
import BlockId
import CmmBrokenBlock
import Dataflow
import UniqSet
import Panic
calculateProcPoints :: [BrokenBlock] -> UniqSet BlockId
calculateProcPoints blocks =
calculateProcPoints' init_proc_points blocks
where
init_proc_points = mkUniqSet $
map brokenBlockId $
filter always_proc_point blocks
always_proc_point BrokenBlock {
brokenBlockEntry = FunctionEntry _ _ _ } = True
always_proc_point BrokenBlock {
brokenBlockEntry = ContinuationEntry _ _ _ } = True
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
new_proc_points =
unionManyUniqSets
(old_proc_points:
map (calculateNewProcPoints owners) blocks)
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
maybe_proc_point parent_id child_id =
if needs_proc_point
then unitUniqSet child_id
else emptyUniqSet
where
parent_owners = lookupWithDefaultBEnv owners emptyUniqSet parent_id
child_owners = lookupWithDefaultBEnv owners emptyUniqSet child_id
needs_proc_point =
(not $ isEmptyUniqSet parent_owners) &&
(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) emptyBlockEnv
where
dependants :: BlockId -> [BlockId]
dependants ident =
brokenBlockTargets $ lookupWithDefaultBEnv
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 $ extendBlockEnv owners ident (unitUniqSet ident)
(Nothing, False) -> Nothing
(Just _, True) -> Nothing
(Just cause', False) ->
if (sizeUniqSet old) == (sizeUniqSet new)
then Nothing
else Just $ extendBlockEnv owners ident new
where
old = lookupWithDefaultBEnv owners emptyUniqSet ident
new = old `unionUniqSets`
lookupWithDefaultBEnv owners emptyUniqSet cause'
unknown_block = panic "unknown BlockId in calculateOwnership"