+breakBlock2 (BasicBlock ident stmts) entry = breakBlock2' ident entry [] [] stmts
+
+breakBlock2' current_id block_info exits accum_stmts [] =
+ panic "block doesn't end in jump, goto or return"
+breakBlock2' current_id entry exits accum_stmts [CmmJump target arguments] =
+ return [BrokenBlock current_id entry accum_stmts (TailCallExit exits target arguments)]
+breakBlock2' current_id entry exits accum_stmts [CmmReturn arguments] =
+ return [BrokenBlock current_id entry accum_stmts (ReturnExit exits arguments)]
+breakBlock2' current_id entry exits accum_stmts [CmmBranch target] =
+ return [BrokenBlock current_id entry accum_stmts (ControlExit exits target)]
+breakBlock2' _ _ _ _ (CmmJump _ _:_) = panic "jump in middle of block"
+breakBlock2' _ _ _ _ (CmmReturn _:_) = panic "return in middle of block"
+breakBlock2' _ _ _ _ (CmmBranch _:_) = panic "branch in middle of block"
+breakBlock2' _ _ _ _ (CmmSwitch _ _:_) = panic "switch in block not implemented"
+breakBlock2' current_id entry exits accum_stmts (CmmCall target results arguments saves:stmts) = do
+ new_id <- newLabelCPS
+ rest <- breakBlock2' new_id (ContinuationEntry results) [] [] stmts
+ return $ BrokenBlock current_id entry accum_stmts (CallExit exits new_id target results arguments saves) : rest
+breakBlock2' current_id entry exits accum_stmts (s@(CmmCondBranch test target):stmts) =
+ breakBlock2' current_id entry (target:exits) (accum_stmts++[s]) stmts
+breakBlock2' current_id entry exits accum_stmts (s:stmts) =
+ breakBlock2' current_id entry exits (accum_stmts++[s]) stmts
+
+brokenBlockTargets (BrokenBlock _ _ _ (TailCallExit exits _ _)) = exits
+brokenBlockTargets (BrokenBlock _ _ _ (ReturnExit exits _)) = exits
+brokenBlockTargets (BrokenBlock _ _ _ (ControlExit exits target)) = target:exits
+brokenBlockTargets (BrokenBlock _ _ _ (CallExit exits next _ _ _ _)) = next:exits
+
+brokenBlockId (BrokenBlock ident _ _ _) = ident
+
+cmmBrokenBlockSources ::
+ [BrokenBlock] -> UniqFM {-BlockId-} (UniqSet BlockId)
+cmmBrokenBlockSources blocks = foldr aux emptyUFM blocks where
+ aux block sourcesUFM =
+ foldr add_source_edges sourcesUFM targets where
+ add_source_edges t ufm =
+ addToUFM_Acc (flip addOneToUniqSet) unitUniqSet ufm t ident
+ targets = brokenBlockTargets block
+ ident = brokenBlockId block
+
+cmmBrokenBlockNames :: [BrokenBlock] -> UniqFM {-BlockId-} BrokenBlock
+cmmBrokenBlockNames blocks = listToUFM $ map block_name blocks where
+ block_name b = (brokenBlockId b, b)
+
+cmmBrokenBlockDependants :: UniqFM {-BlockId-} (UniqSet BlockId) -> BlockId -> [BlockId]
+cmmBrokenBlockDependants sources ident =
+ uniqSetToList $ lookupWithDefaultUFM sources emptyUniqSet ident
+
+cmmBrokenBlockLive :: UniqFM {-BlockId-} CmmLive -> BrokenBlock -> CmmLive
+cmmBrokenBlockLive other_live (BrokenBlock _ _ stmts exit) =
+ foldr ((.) . (cmmStmtLive other_live)) id stmts live_at_end
+ where
+ live_at_end =
+ case exit of
+ ControlExit _ _ -> emptyUniqSet
+ ReturnExit _ actuals -> foldr ((.) . cmmExprLive) id (map fst actuals) emptyUniqSet
+ TailCallExit _ target actuals ->
+ cmmExprLive target $ foldr ((.) . cmmExprLive) id (map fst actuals) $ emptyUniqSet
+ CallExit _ _ target _ actuals live ->
+ target_liveness $
+ foldr ((.) . cmmExprLive) id (map fst actuals) $
+ emptyUniqSet
+ where
+ only_local_regs [] = []
+ only_local_regs ((CmmGlobal _,_):args) = only_local_regs args
+ only_local_regs ((CmmLocal r,_):args) = r:only_local_regs args
+ target_liveness =
+ case target of
+ (CmmForeignCall target _) -> cmmExprLive target
+ (CmmPrim _) -> id
+
+
+cmmBrokenBlockUpdate ::
+ UniqFM {-BlockId-} BrokenBlock
+ -> BlockId
+ -> Maybe BlockId
+ -> UniqFM {-BlockId-} CmmLive
+ -> Maybe (UniqFM {-BlockId-} CmmLive)
+cmmBrokenBlockUpdate blocks node _ state =
+ let old_live = lookupWithDefaultUFM state (panic "unknown block id during liveness analysis") node
+ block = lookupWithDefaultUFM blocks (panic "unknown block id during liveness analysis") node
+ new_live = cmmBrokenBlockLive state block
+ in if (sizeUniqSet old_live) == (sizeUniqSet new_live)
+ then Nothing
+ else Just $ addToUFM state node new_live
+
+
+cmmLiveness2 :: [BrokenBlock] -> UniqFM {-BlockId-} CmmLive
+cmmLiveness2 blocks =
+ fixedpoint (cmmBrokenBlockDependants sources) (cmmBrokenBlockUpdate blocks')
+ (map brokenBlockId blocks) (listToUFM [(brokenBlockId b, emptyUniqSet) | b <- blocks]) where
+ sources = cmmBrokenBlockSources blocks
+ blocks' = cmmBrokenBlockNames blocks
+