5 #include "HsVersions.h"
15 calculateOwnership :: BlockEnv BrokenBlock -> UniqSet BlockId -> [BrokenBlock] -> BlockEnv (UniqSet BlockId)
16 calculateOwnership blocks_ufm proc_points blocks =
17 fixedpoint dependants update (map brokenBlockId blocks) emptyUFM
19 dependants :: BlockId -> [BlockId]
21 brokenBlockTargets $ lookupWithDefaultUFM
22 blocks_ufm unknown_block ident
24 update :: BlockId -> Maybe BlockId
25 -> BlockEnv (UniqSet BlockId) -> Maybe (BlockEnv (UniqSet BlockId))
26 update ident cause owners =
27 case (cause, ident `elementOfUniqSet` proc_points) of
28 (Nothing, True) -> Just $ addToUFM owners ident (unitUniqSet ident)
29 (Nothing, False) -> Nothing
30 (Just cause', True) -> Nothing
31 (Just cause', False) ->
32 if (sizeUniqSet old) == (sizeUniqSet new)
34 else Just $ addToUFM owners ident new
36 old = lookupWithDefaultUFM owners emptyUniqSet ident
37 new = old `unionUniqSets` lookupWithDefaultUFM owners emptyUniqSet cause'
39 unknown_block = panic "unknown BlockId in selectStackFormat"
41 calculateProcPoints :: [BrokenBlock] -> UniqSet BlockId
42 calculateProcPoints blocks =
43 calculateProcPoints' init_proc_points blocks
45 init_proc_points = mkUniqSet $
47 filter always_proc_point blocks
48 always_proc_point BrokenBlock {
49 brokenBlockEntry = FunctionEntry _ _ _ } = True
50 always_proc_point BrokenBlock {
51 brokenBlockEntry = ContinuationEntry _ _ } = True
52 always_proc_point _ = False
54 calculateProcPoints' :: UniqSet BlockId -> [BrokenBlock] -> UniqSet BlockId
55 calculateProcPoints' old_proc_points blocks =
56 if sizeUniqSet old_proc_points == sizeUniqSet new_proc_points
58 else calculateProcPoints' new_proc_points blocks
60 blocks_ufm :: BlockEnv BrokenBlock
61 blocks_ufm = blocksToBlockEnv blocks
63 owners = calculateOwnership blocks_ufm old_proc_points blocks
64 new_proc_points = unionManyUniqSets (old_proc_points:(map (calculateProcPoints'' owners) blocks))
66 calculateProcPoints'' :: BlockEnv (UniqSet BlockId) -> BrokenBlock -> UniqSet BlockId
67 calculateProcPoints'' owners block =
68 unionManyUniqSets (map (f parent_id) child_ids)
70 parent_id = brokenBlockId block
71 child_ids = brokenBlockTargets block
73 f parent_id child_id =
75 then unitUniqSet child_id
78 parent_owners = lookupWithDefaultUFM owners emptyUniqSet parent_id
79 child_owners = lookupWithDefaultUFM owners emptyUniqSet child_id
80 needs_proc_point = not $ isEmptyUniqSet $ child_owners `minusUniqSet` parent_owners