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"
23 -- Determine the proc points for a set of basic blocks.
25 -- A proc point is any basic block that must start a new function.
26 -- The entry block of the original function is a proc point.
27 -- The continuation of a function call is also a proc point.
28 -- The third kind of proc point arises when there is a joint point
29 -- in the control flow. Suppose we have code like the following:
31 -- if (...) { ...; call foo(); ...}
32 -- else { ...; call bar(); ...}
35 -- That last statement "x = y" must be a proc point because
36 -- it can be reached by blocks owned by different proc points
37 -- (the two branches of the conditional).
39 -- We calculate these proc points by starting with the minimal set
40 -- and finding blocks that are reachable from more proc points than
41 -- one of their parents. (This ensures we don't choose a block
42 -- simply beause it is reachable from another block that is reachable
43 -- from multiple proc points.) These new blocks are added to the
44 -- set of proc points and the process is repeated until there
45 -- are no more proc points to be found.
47 calculateProcPoints :: [BrokenBlock] -> UniqSet BlockId
48 calculateProcPoints blocks =
49 calculateProcPoints' init_proc_points blocks
51 init_proc_points = mkUniqSet $
53 filter always_proc_point blocks
54 always_proc_point BrokenBlock {
55 brokenBlockEntry = FunctionEntry _ _ _ } = True
56 always_proc_point BrokenBlock {
57 brokenBlockEntry = ContinuationEntry _ _ _ } = True
58 always_proc_point _ = False
60 calculateProcPoints' :: UniqSet BlockId -> [BrokenBlock] -> UniqSet BlockId
61 calculateProcPoints' old_proc_points blocks =
62 if sizeUniqSet old_proc_points == sizeUniqSet new_proc_points
64 else calculateProcPoints' new_proc_points blocks
66 blocks_ufm :: BlockEnv BrokenBlock
67 blocks_ufm = blocksToBlockEnv blocks
69 owners = calculateOwnership blocks_ufm old_proc_points blocks
73 map (calculateNewProcPoints owners) blocks)
75 calculateNewProcPoints :: BlockEnv (UniqSet BlockId)
78 calculateNewProcPoints owners block =
79 unionManyUniqSets (map (maybe_proc_point parent_id) child_ids)
81 parent_id = brokenBlockId block
82 child_ids = brokenBlockTargets block
83 maybe_proc_point parent_id child_id =
85 then unitUniqSet child_id
88 parent_owners = lookupWithDefaultUFM owners emptyUniqSet parent_id
89 child_owners = lookupWithDefaultUFM owners emptyUniqSet child_id
91 -- only if parent isn't dead
92 (not $ isEmptyUniqSet parent_owners) &&
93 -- and only if child has more owners than parent
94 (not $ isEmptyUniqSet $
95 child_owners `minusUniqSet` parent_owners)
97 calculateOwnership :: BlockEnv BrokenBlock
100 -> BlockEnv (UniqSet BlockId)
101 calculateOwnership blocks_ufm proc_points blocks =
102 fixedpoint dependants update (map brokenBlockId blocks) emptyUFM
104 dependants :: BlockId -> [BlockId]
106 brokenBlockTargets $ lookupWithDefaultUFM
107 blocks_ufm unknown_block ident
111 -> BlockEnv (UniqSet BlockId)
112 -> Maybe (BlockEnv (UniqSet BlockId))
113 update ident cause owners =
114 case (cause, ident `elementOfUniqSet` proc_points) of
116 Just $ addToUFM owners ident (unitUniqSet ident)
117 (Nothing, False) -> Nothing
118 (Just cause', True) -> Nothing
119 (Just cause', False) ->
120 if (sizeUniqSet old) == (sizeUniqSet new)
122 else Just $ addToUFM owners ident new
124 old = lookupWithDefaultUFM owners emptyUniqSet ident
125 new = old `unionUniqSets`
126 lookupWithDefaultUFM owners emptyUniqSet cause'
128 unknown_block = panic "unknown BlockId in calculateOwnership"