From 4311d2d9de83b0af0695f957694cce0dcc566021 Mon Sep 17 00:00:00 2001 From: "Michael D. Adams" Date: Thu, 10 May 2007 10:36:50 +0000 Subject: [PATCH] Added compiler/cmm/Dataflow.hs Dataflow.hs contains an early draft of the live variable analysis. This draft contains known bugs and is being recorded only to provide a point to be revert back to if necessary. --- compiler/cmm/Dataflow.hs | 216 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 216 insertions(+) create mode 100644 compiler/cmm/Dataflow.hs diff --git a/compiler/cmm/Dataflow.hs b/compiler/cmm/Dataflow.hs new file mode 100644 index 0000000..7b5a391 --- /dev/null +++ b/compiler/cmm/Dataflow.hs @@ -0,0 +1,216 @@ +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 +-- 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, +-- 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 -> Maybe node -> s -> Maybe s) + -> [node] -> s -> s +fixedpoint dependants update nodes state = + foldr (fixedpoint' Nothing) state nodes where + fixedpoint' cause node state = + case update node cause state of + Nothing -> state + Just state' -> + foldr (fixedpoint' (Just node)) state' (dependants node) -- 1.7.10.4