X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FDataflow.hs;h=6c54f73fc2689c55b8cb995d4ee19da52fb50f07;hp=7b5a391c44f519f58c4db7814acdffb256aeb517;hb=ad94d40948668032189ad22a0ad741ac1f645f50;hpb=4311d2d9de83b0af0695f957694cce0dcc566021 diff --git a/compiler/cmm/Dataflow.hs b/compiler/cmm/Dataflow.hs index 7b5a391..6c54f73 100644 --- a/compiler/cmm/Dataflow.hs +++ b/compiler/cmm/Dataflow.hs @@ -1,214 +1,58 @@ -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) - --------------------------------------------------------------------------------- - --- Solve a fixed-point of a dataflow problem. --- O(N+H*E) calls to update where +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings +-- for details + +module Dataflow ( + fixedpoint + ) where + +----------------------------------------------------------------------------- +-- | Solve the fixed-point of a dataflow problem. +-- +-- Complexity: O(N+H*E) calls to 'update' where -- N = number of nodes, -- E = number of edges, -- H = maximum height of the lattice for any particular node. --- dependants: map from nodes to those who's value depend on the argument node --- update: --- Given the node which needs to be updated, and --- which node caused that node to need to be updated, --- update the state. --- (The causing node will be 'Nothing' if this is the initial update.) --- Must return 'Nothing' if no change, --- otherwise returrn 'Just' of the new state --- nodes: a set of nodes that initially need updating --- state: some sort of state (usually a map) --- containing the initial value for each node -- -- Sketch for proof of complexity: -- Note that the state is threaded through the entire execution. -- Also note that the height of the latice at any particular node --- is the number of times 'update' can return non-Nothing for a particular node. --- Every call (except for the top level one) must be caused by a non-Nothing --- result and each non-Nothing result causes as many calls as it has --- out-going edges. Thus any particular node, n, may cause in total --- at most H*out(n) further calls. When summed over all nodes, +-- is the number of times 'update' can return non-Nothing for a +-- particular node. Every call (except for the top level one) +-- must be caused by a non-Nothing result and each non-Nothing +-- result causes as many calls as it has out-going edges. +-- Thus any particular node, n, may cause in total at +-- most H*out(n) further calls. When summed over all nodes, -- that is H*E. The N term of the complexity is from the initial call -- when 'update' will be passed 'Nothing'. fixedpoint :: - (node -> [node]) + (node -> [node]) -- ^ map from nodes to those who's + -- value depend on the argument node -> (node -> Maybe node -> s -> Maybe s) - -> [node] -> s -> s + -- ^ Given the node which needs to be + -- updated, and which node caused that node + -- to need to be updated, update the state. + -- + -- The causing node will be 'Nothing' if + -- this is the initial/bootstrapping update. + -- + -- Must return 'Nothing' if no change, + -- otherwise returrn 'Just' of the new state. + + -> [node] -- ^ Nodes that should initially be updated + + -> s -- ^ Initial state + -- (usually a map from node to + -- the value for that node) + + -> s -- ^ Final state fixedpoint dependants update nodes state = foldr (fixedpoint' Nothing) state nodes where + -- Use a depth first traversal of nodes based on the update graph. + -- Terminate the traversal when the update doesn't change anything. fixedpoint' cause node state = case update node cause state of Nothing -> state