+blocksToBlockEnv :: [BrokenBlock] -> BlockEnv BrokenBlock
+blocksToBlockEnv blocks = listToUFM $ map (\b -> (brokenBlockId b, b)) blocks
+
+-----------------------------------------------------------------------------
+calculateOwnership :: UniqSet BlockId -> [BrokenBlock] -> BlockEnv (UniqSet BlockId)
+calculateOwnership proc_points blocks =
+ fixedpoint dependants update (map brokenBlockId blocks) emptyUFM
+ where
+ blocks_ufm :: BlockEnv BrokenBlock
+ blocks_ufm = blocksToBlockEnv blocks
+
+ 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 selectStackFormat"
+
+calculateProcPoints :: [BrokenBlock] -> UniqSet BlockId
+calculateProcPoints blocks = calculateProcPoints' init_proc_points blocks
+ where
+ init_proc_points = mkUniqSet $
+ map brokenBlockId $
+ filter always_proc_point blocks
+ always_proc_point BrokenBlock {
+ brokenBlockEntry = FunctionEntry _ } = True
+ always_proc_point BrokenBlock {
+ brokenBlockEntry = ContinuationEntry _ } = True
+ always_proc_point _ = False
+
+calculateProcPoints' :: UniqSet BlockId -> [BrokenBlock] -> UniqSet BlockId
+calculateProcPoints' old_proc_points blocks =
+ if sizeUniqSet old_proc_points == sizeUniqSet new_proc_points
+ then old_proc_points
+ else calculateProcPoints' new_proc_points blocks
+ where
+ owners = calculateOwnership old_proc_points blocks
+ new_proc_points = unionManyUniqSets (old_proc_points:(map (calculateProcPoints'' owners) blocks))
+
+calculateProcPoints'' :: BlockEnv (UniqSet BlockId) -> BrokenBlock -> UniqSet BlockId
+calculateProcPoints'' owners block =
+ unionManyUniqSets (map (f parent_id) child_ids)
+ where
+ parent_id = brokenBlockId block
+ child_ids = brokenBlockTargets block
+ f parent_id child_id =
+ if needs_proc_point
+ then unitUniqSet child_id
+ else emptyUniqSet
+ where
+ parent_owners = lookupWithDefaultUFM owners emptyUniqSet parent_id
+ child_owners = lookupWithDefaultUFM owners emptyUniqSet child_id
+ needs_proc_point = not $ isEmptyUniqSet $ child_owners `minusUniqSet` parent_owners
+ --needs_proc_point = sizeUniqSet (parent_owners `unionUniqSets` child_owners) /= sizeUniqSet parent_owners
+
+cmmCondBranchTargets (CmmCondBranch _ target) = [target]
+cmmCondBranchTargets _ = []
+
+finalBranchOrSwitchTargets (FinalBranch target) = [target]
+finalBranchOrSwitchTargets (FinalSwitch _ targets) = mapCatMaybes id targets
+finalBranchOrSwitchTargets _ = []
+
+collectNonProcPointTargets ::
+ UniqSet BlockId -> BlockEnv BrokenBlock
+ -> UniqSet BlockId -> BlockId -> UniqSet BlockId
+collectNonProcPointTargets proc_points blocks current_targets block =
+ if sizeUniqSet current_targets == sizeUniqSet new_targets
+ then current_targets
+ else foldl (collectNonProcPointTargets proc_points blocks) new_targets targets
+ where
+ block' = lookupWithDefaultUFM blocks (panic "TODO") block
+ targets = -- We can't use the brokenBlockTargets b/c we don't want to follow the final goto after a call -- brokenBlockTargets block'
+ --finalBranchOrSwitchTargets (brokenBlockExit block') ++ concatMap cmmCondBranchTargets (brokenBlockStmts block')
+ uniqSetToList $ (mkUniqSet $ brokenBlockTargets block') `minusUniqSet` proc_points
+ -- TODO: remove redundant uniqSetToList
+ new_targets = current_targets `unionUniqSets` (mkUniqSet targets)
+
+buildContinuation ::
+ UniqSet BlockId -> BlockEnv BrokenBlock
+ -> BlockId -> Continuation
+buildContinuation proc_points blocks start =
+ Continuation is_entry info_table clabel params body
+ where
+ children = (collectNonProcPointTargets proc_points blocks (unitUniqSet start) start) `delOneFromUniqSet` start
+ start_block = lookupWithDefaultUFM blocks (panic "TODO") start
+ children_blocks = map (lookupWithDefaultUFM blocks (panic "TODO")) (uniqSetToList children)
+ body = start_block : children_blocks
+ info_table = [] -- TODO
+ is_entry = case start_block of
+ BrokenBlock { brokenBlockEntry = FunctionEntry _ } -> True
+ _ -> False
+ clabel = mkReturnPtLabel $ getUnique start
+ params = case start_block of
+ BrokenBlock { brokenBlockEntry = FunctionEntry args } -> args
+ BrokenBlock { brokenBlockEntry = ContinuationEntry args } -> args
+ BrokenBlock { brokenBlockEntry = ControlEntry } -> [] -- TODO: it's a proc-point, we could pass lives in parameter registers
+