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 = calculateProcPoints' init_proc_points blocks
44 init_proc_points = mkUniqSet $
46 filter always_proc_point blocks
47 always_proc_point BrokenBlock {
48 brokenBlockEntry = FunctionEntry _ _ } = True
49 always_proc_point BrokenBlock {
50 brokenBlockEntry = ContinuationEntry _ _ } = True
51 always_proc_point _ = False
53 calculateProcPoints' :: UniqSet BlockId -> [BrokenBlock] -> UniqSet BlockId
54 calculateProcPoints' old_proc_points blocks =
55 if sizeUniqSet old_proc_points == sizeUniqSet new_proc_points
57 else calculateProcPoints' new_proc_points blocks
59 blocks_ufm :: BlockEnv BrokenBlock
60 blocks_ufm = blocksToBlockEnv blocks
62 owners = calculateOwnership blocks_ufm old_proc_points blocks
63 new_proc_points = unionManyUniqSets (old_proc_points:(map (calculateProcPoints'' owners) blocks))
65 calculateProcPoints'' :: BlockEnv (UniqSet BlockId) -> BrokenBlock -> UniqSet BlockId
66 calculateProcPoints'' owners block =
67 unionManyUniqSets (map (f parent_id) child_ids)
69 parent_id = brokenBlockId block
70 child_ids = brokenBlockTargets block
72 f parent_id child_id =
74 then unitUniqSet child_id
77 parent_owners = lookupWithDefaultUFM owners emptyUniqSet parent_id
78 child_owners = lookupWithDefaultUFM owners emptyUniqSet child_id
79 needs_proc_point = not $ isEmptyUniqSet $ child_owners `minusUniqSet` parent_owners