--- TODO: TBD when to adjust the stack
-
-cpsProc :: CmmTop -> CPS [CmmTop]
-cpsProc x@(CmmData _ _) = return [x]
-cpsProc x@(CmmProc info_table ident params blocks) = do
-
- broken_blocks <- liftM concat $ mapM breakBlock blocks
- broken_blocks2 <- liftM concat (zipWithM breakBlock2 blocks (FunctionEntry:repeat ControlEntry))
- -- broken_blocks :: [BrokenBlock]
-
- let live = cmmLiveness (map snd broken_blocks)
- let live2 :: BlockEntryLiveness
- live2 = cmmLiveness2 broken_blocks2
-
- let blocks_with_live = map (cmmLivenessComment live . snd) broken_blocks
-
- let formats = selectStackFormat (panic "params to selectStackFormat" {-TODO-}) live (undefined)
- let formats2 :: BlockEnv StackFormat -- Stack format on entry
- formats2 = selectStackFormat2 live2 broken_blocks2
-
- let block_infos = listToUFM $ map (\(info, block) -> (blockId block, info)) broken_blocks
- --let blocks_with_live' = map (constructContinuation block_infos formats) blocks_with_live
- --let blocks_with_live'' = map (destructContinuation block_infos formats) blocks_with_live'
- --let blocks_with_live''' = map (transformReturn block_infos formats) blocks_with_live''
-
- return $ [CmmProc info_table ident params $ map (constructContinuation2 formats2) broken_blocks2]
-{-
- return $ [CmmProc info_table ident params $
- map (constructContinuation block_infos formats .
- destructContinuation block_infos formats .
- transformReturn block_infos formats)
- blocks_with_live]
--}
-
---------------------------------------------------------------------------------
--- 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
-
---------------------------------------------------------------------------------
-cmmCPS :: DynFlags
- -> [Cmm] -- C-- with Proceedures
- -> IO [Cmm] -- Output: CPS transformed C--
-
-cmmCPS dflags abstractC = do
- when (dopt Opt_DoCmmLinting dflags) $
- do showPass dflags "CmmLint"
- case firstJust $ map cmmLint abstractC of
- Just err -> do printDump err
- ghcExit dflags 1
- Nothing -> return ()
- showPass dflags "CPS"
- -- TODO: check for use of branches to non-existant blocks
- -- TODO: check for use of Sp, SpLim, R1, R2, etc.
- -- continuationC <- return abstractC
- -- TODO: find out if it is valid to create a new unique source like this
- uniqSupply <- mkSplitUniqSupply 'p'
- let (_, continuationC) = runCPS (mapM (mapMCmmTop cpsProc) abstractC) (CPSState uniqSupply)
-
- dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (pprCmms continuationC)
- -- TODO: add option to dump Cmm to file
- return continuationC