Commit 4311d2d9 authored by Michael D. Adams's avatar Michael D. Adams
Browse files

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.
parent a7c788e5
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)
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment