+ needs_proc_point =
+ -- only if parent isn't dead
+ (not $ isEmptyUniqSet parent_owners) &&
+ -- and only if child has more owners than parent
+ (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) emptyUFM
+ where
+ dependants :: BlockId -> [BlockId]
+ dependants ident =
+ brokenBlockTargets $ lookupWithDefaultUFM
+ 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 $ addToUFM owners ident (unitUniqSet ident)
+ (Nothing, False) -> Nothing
+ (Just cause', True) -> Nothing
+ (Just cause', False) ->
+ if (sizeUniqSet old) == (sizeUniqSet new)
+ then Nothing
+ else Just $ addToUFM owners ident new
+ where
+ old = lookupWithDefaultUFM owners emptyUniqSet ident
+ new = old `unionUniqSets`
+ lookupWithDefaultUFM owners emptyUniqSet cause'
+
+ unknown_block = panic "unknown BlockId in calculateOwnership"