-module Dataflow (mapCmmTop, onBasicBlock, cmmLivenessComment, cmmLiveness) where
-
-import Cmm
-import PprCmm
-
-import Unique
-import UniqSet
-import UniqFM
-
-import FastString
-import Outputable
-
-import Data.List
-import Data.Maybe
-
-cmmBranchSources :: [(BlockId, [BlockId])] -> [(BlockId, [BlockId])]
-cmmBranchSources input =
- [(target, [s | (s, ts) <- input, target `elem` ts])
- | target <- targets] where
- targets = nub [t | (s, ts) <- input, t <- ts]
-
-cmmBranchTargets :: CmmBasicBlock -> UniqSet BlockId
-cmmBranchTargets (BasicBlock _ stmts) =
- mkUniqSet $ concatMap target stmts where
- target (CmmBranch ident) = [ident]
- target (CmmCondBranch _ ident) = [ident]
- target (CmmSwitch _ blocks) = mapMaybe id blocks
- target _ = []
-
---------------------------------------------------------------------------------
-
--- This should really be a state monad, but that is not in the core libraries
--- so we'll hack around it here.
--- The monad we're using is: type State a = s -> s
-
--- The variables that were made live and killed respectively
-type CmmLiveness = (UniqSet LocalReg, UniqSet LocalReg)
-addLocalLive new_live (live, killed) =
- (live `unionUniqSets` new_live, killed `minusUniqSet` new_live)
-addLocalKilled new_killed (live, killed) =
- (live `minusUniqSet` new_killed, killed `unionUniqSets` new_killed)
-
--- Calculate the live and killed registers for a local block
-cmmLocalLiveness :: CmmBasicBlock -> CmmLiveness
-cmmLocalLiveness (BasicBlock _ stmts) =
- foldr ((.) . cmmStmtLocalLiveness) id stmts (emptyUniqSet, emptyUniqSet)
-
--- Helper for cmmLocalLiveness
-cmmStmtLocalLiveness :: CmmStmt -> (CmmLiveness -> CmmLiveness)
-cmmStmtLocalLiveness (CmmNop) = id
-cmmStmtLocalLiveness (CmmComment _) = id
-cmmStmtLocalLiveness (CmmAssign reg expr) =
- cmmExprLocalLiveness expr . reg_liveness where
- reg_liveness =
- case reg of
- (CmmLocal reg') -> addLocalKilled $ unitUniqSet reg'
- (CmmGlobal _) -> id
-cmmStmtLocalLiveness (CmmStore expr1 expr2) =
- cmmExprLocalLiveness expr2 . cmmExprLocalLiveness expr1
-cmmStmtLocalLiveness (CmmCall target results arguments _) =
- target_liveness .
- foldr ((.) . cmmExprLocalLiveness) id (map fst arguments) .
- addLocalKilled (mkUniqSet $ only_local_regs results) 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 _) -> cmmExprLocalLiveness target
- (CmmPrim _) -> id
-cmmStmtLocalLiveness (CmmBranch _) = const (emptyUniqSet, emptyUniqSet)
-cmmStmtLocalLiveness (CmmCondBranch expr _) = cmmExprLocalLiveness expr
-cmmStmtLocalLiveness (CmmSwitch expr _) = cmmExprLocalLiveness expr
-cmmStmtLocalLiveness (CmmJump expr params) =
- const (cmmExprLocalLiveness expr (mkUniqSet params, emptyUniqSet))
-
--- Helper for cmmLocalLiveness
-cmmExprLocalLiveness :: CmmExpr -> (CmmLiveness -> CmmLiveness)
-cmmExprLocalLiveness expr = addLocalLive (mkUniqSet $ expr_liveness expr) where
- expr_liveness (CmmLit _) = []
- expr_liveness (CmmLoad expr _) = expr_liveness expr
- expr_liveness (CmmReg reg) = reg_liveness reg
- expr_liveness (CmmMachOp _ exprs) = concatMap expr_liveness exprs
- expr_liveness (CmmRegOff reg _) = reg_liveness reg
- reg_liveness (CmmLocal reg) = [reg]
- reg_liveness (CmmGlobal _) = []
-
-{-
-branch_update ::
- UniqFM {-BlockId-} (UniqSet BlockId)
- -> UniqFM {-BlockId-} CmmLiveness
- -> BlockId
- -> UniqFM {-BlockId-} (UniqSet LocalReg)
- -> Maybe (UniqFM {-BlockId-} (UniqSet LocalReg))
-branch_update targets local_liveness ident input_state =
- if (sizeUniqSet old_live) >= (sizeUniqSet new_live)
- then Nothing
- else Just $ addToUFM input_state ident new_live
- where
- old_live = lookupWithDefaultUFM input_state emptyUniqSet ident
- (born, killed) =
- lookupWithDefaultUFM
- local_liveness (emptyUniqSet, emptyUniqSet) ident
- target_live = unionManyUniqSets $
- map (lookupWithDefaultUFM input_state emptyUniqSet) target
- target = uniqSetToList $ lookupWithDefaultUFM targets emptyUniqSet ident
- new_live = (target_live `minusUniqSet` killed) `unionUniqSets` born
--}
-
-cmmBlockUpdate ::
- UniqFM {-BlockId-} CmmLiveness
- -> BlockId
- -> Maybe BlockId
- -> UniqFM {-BlockId-} (UniqSet LocalReg)
- -> Maybe (UniqFM {-BlockId-} (UniqSet LocalReg))
-cmmBlockUpdate local_liveness ident cause input_state =
- let (born, killed) = lookupWithDefaultUFM
- local_liveness (emptyUniqSet, emptyUniqSet) ident
- old_live = lookupWithDefaultUFM input_state emptyUniqSet ident
- cause_live =
- case cause of
- Just cause' -> lookupWithDefaultUFM input_state emptyUniqSet cause'
- Nothing -> emptyUniqSet
- new_live = old_live
- `unionUniqSets` (cause_live `minusUniqSet` killed)
- `unionUniqSets` born
- in {-trace (--(showSDoc $ ppr $ getUnique cause) ++ "-->" ++
- (showSDoc $ ppr $ getUnique ident) ++ ":" ++
- (showSDoc $ ppr $ map CmmLocal $ uniqSetToList $ cause_live) ++ ":" ++
- (showSDoc $ ppr $ map CmmLocal $ uniqSetToList $ old_live) ++ ":" ++
- (showSDoc $ ppr $ map CmmLocal $ uniqSetToList $ new_live) ++ "|" ++
- (show $ map (\(k,v) -> (k, showSDoc $ ppr $ map CmmLocal $ uniqSetToList v)) $ ufmToList input_state)) $-}
- if (sizeUniqSet old_live) == (sizeUniqSet new_live)
- then Nothing
- else Just $ addToUFM input_state ident new_live
-
-cmmBlockDependants :: UniqFM {-BlockId-} (UniqSet BlockId) -> BlockId -> [BlockId]
-cmmBlockDependants sources ident =
- uniqSetToList $ lookupWithDefaultUFM sources emptyUFM ident
-
-cmmBlockLiveness :: [CmmBasicBlock] -> UniqFM {-BlockId-} CmmLiveness
-cmmBlockLiveness blocks = listToUFM $ map block_info blocks where
- block_info block = (blockId block, cmmLocalLiveness block)
-
-cmmBlockSourcesAndTargets ::
- [CmmBasicBlock]
- -> (UniqFM {-BlockId-} (UniqSet BlockId), UniqFM (UniqSet BlockId))
-cmmBlockSourcesAndTargets blocks = foldr aux (emptyUFM, emptyUFM) blocks where
- aux block (sourcesUFM, targetsUFM) =
- (foldUniqSet add_source_edges sourcesUFM targets,
- addToUFM_Acc unionUniqSets id targetsUFM ident targets) where
- add_source_edges t ufm =
- addToUFM_Acc (flip addOneToUniqSet) unitUniqSet ufm t ident
- targets = cmmBranchTargets block
- ident = blockId block
-
-cmmLiveness :: [CmmBasicBlock] -> UniqFM {-BlockId-} (UniqSet LocalReg)
-cmmLiveness blocks =
- fixedpoint (cmmBlockDependants sources) (cmmBlockUpdate liveness)
- (map blockId blocks) emptyUFM where
- (sources, targets) = cmmBlockSourcesAndTargets blocks
- liveness = cmmBlockLiveness blocks
-
-cmmLivenessComment ::
- UniqFM {-BlockId-} (UniqSet LocalReg)
- -> CmmBasicBlock -> CmmBasicBlock
-cmmLivenessComment live (BasicBlock ident stmts) =
- BasicBlock ident stmts' where
- stmts' = (CmmComment $ mkFastString $ showSDoc $ ppr $ live'):stmts
- live' = map CmmLocal $ uniqSetToList $ lookupWithDefaultUFM live emptyUniqSet ident
-
-onBasicBlock f (CmmProc ds ident args blocks) = CmmProc ds ident args (f blocks)
-onBasicBlock f x = x
-
-mapCmmTop f (Cmm xs) = Cmm (map f xs)
+module Dataflow (
+ fixedpoint
+ ) where
--------------------------------------------------------------------------------
projects / ghc-hetmet.git / blobdiff