---------------------------------------------------------------------------------
--- Takes a basic block and returns a list of basic blocks that
--- each have at most 1 CmmCall in them which must occur at the end.
--- Also returns with each basic block, the variables that will
--- be arguments to the continuation of the block once the call (if any) returns.
-
-cmmBlockifyCalls :: [CmmBasicBlock] -> CPS [(CPSBlockInfo, CmmBasicBlock)]
-cmmBlockifyCalls blocks = liftM concat $ mapM breakBlock blocks
-
--- [(CmmReg,MachHint)] is the results from the previous block that are expected as parameters
---breakBlock :: CmmBasicBlock -> CPS [(Maybe BlockId, CmmBasicBlock)]
-breakBlock :: CmmBasicBlock -> CPS [(CPSBlockInfo, CmmBasicBlock)]
-breakBlock (BasicBlock ident stmts) = breakBlock' ident ControlBlock [] stmts
-
-breakBlock' current_id block_info accum_stmts [] =
- return [(block_info, BasicBlock current_id accum_stmts)]
--- TODO: notice a call just before a branch, jump, call, etc.
-breakBlock' current_id block_info accum_stmts (stmt@(CmmCall _ results _ _):stmts) = do
- new_id <- newLabelCPS
- let new_block = (block_info, BasicBlock current_id (accum_stmts ++ [stmt, CmmBranch new_id]))
- rest <- breakBlock' new_id (ContinuationBlock results) [] stmts
- return $ (new_block:rest)
-breakBlock' current_id arguments accum_stmts (stmt:stmts) =
- breakBlock' current_id arguments (accum_stmts ++ [stmt]) stmts
-
-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