2 -- The above warning supression flag is a temporary kludge.
3 -- While working on this module you are encouraged to remove it and fix
4 -- any warnings in the module. See
5 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
12 #include "HsVersions.h"
22 -- Determine the proc points for a set of basic blocks.
24 -- A proc point is any basic block that must start a new function.
25 -- The entry block of the original function is a proc point.
26 -- The continuation of a function call is also a proc point.
27 -- The third kind of proc point arises when there is a joint point
28 -- in the control flow. Suppose we have code like the following:
30 -- if (...) { ...; call foo(); ...}
31 -- else { ...; call bar(); ...}
34 -- That last statement "x = y" must be a proc point because
35 -- it can be reached by blocks owned by different proc points
36 -- (the two branches of the conditional).
38 -- We calculate these proc points by starting with the minimal set
39 -- and finding blocks that are reachable from more proc points than
40 -- one of their parents. (This ensures we don't choose a block
41 -- simply beause it is reachable from another block that is reachable
42 -- from multiple proc points.) These new blocks are added to the
43 -- set of proc points and the process is repeated until there
44 -- are no more proc points to be found.
46 calculateProcPoints :: [BrokenBlock] -> UniqSet BlockId
47 calculateProcPoints blocks =
48 calculateProcPoints' init_proc_points blocks
50 init_proc_points = mkUniqSet $
52 filter always_proc_point blocks
53 always_proc_point BrokenBlock {
54 brokenBlockEntry = FunctionEntry _ _ _ } = True
55 always_proc_point BrokenBlock {
56 brokenBlockEntry = ContinuationEntry _ _ _ } = True
57 always_proc_point _ = False
59 calculateProcPoints' :: UniqSet BlockId -> [BrokenBlock] -> UniqSet BlockId
60 calculateProcPoints' old_proc_points blocks =
61 if sizeUniqSet old_proc_points == sizeUniqSet new_proc_points
63 else calculateProcPoints' new_proc_points blocks
65 blocks_ufm :: BlockEnv BrokenBlock
66 blocks_ufm = blocksToBlockEnv blocks
68 owners = calculateOwnership blocks_ufm old_proc_points blocks
72 map (calculateNewProcPoints owners) blocks)
74 calculateNewProcPoints :: BlockEnv (UniqSet BlockId)
77 calculateNewProcPoints owners block =
78 unionManyUniqSets (map (maybe_proc_point parent_id) child_ids)
80 parent_id = brokenBlockId block
81 child_ids = brokenBlockTargets block
82 maybe_proc_point parent_id child_id =
84 then unitUniqSet child_id
87 parent_owners = lookupWithDefaultUFM owners emptyUniqSet parent_id
88 child_owners = lookupWithDefaultUFM owners emptyUniqSet child_id
90 -- only if parent isn't dead
91 (not $ isEmptyUniqSet parent_owners) &&
92 -- and only if child has more owners than parent
93 (not $ isEmptyUniqSet $
94 child_owners `minusUniqSet` parent_owners)
96 calculateOwnership :: BlockEnv BrokenBlock
99 -> BlockEnv (UniqSet BlockId)
100 calculateOwnership blocks_ufm proc_points blocks =
101 fixedpoint dependants update (map brokenBlockId blocks) emptyUFM
103 dependants :: BlockId -> [BlockId]
105 brokenBlockTargets $ lookupWithDefaultUFM
106 blocks_ufm unknown_block ident
110 -> BlockEnv (UniqSet BlockId)
111 -> Maybe (BlockEnv (UniqSet BlockId))
112 update ident cause owners =
113 case (cause, ident `elementOfUniqSet` proc_points) of
115 Just $ addToUFM owners ident (unitUniqSet ident)
116 (Nothing, False) -> Nothing
117 (Just cause', True) -> Nothing
118 (Just cause', False) ->
119 if (sizeUniqSet old) == (sizeUniqSet new)
121 else Just $ addToUFM owners ident new
123 old = lookupWithDefaultUFM owners emptyUniqSet ident
124 new = old `unionUniqSets`
125 lookupWithDefaultUFM owners emptyUniqSet cause'
127 unknown_block = panic "unknown BlockId in calculateOwnership"