compiler/cmm/Dataflow.hs

   1 module Dataflow (mapCmmTop, onBasicBlock, cmmLivenessComment, cmmLiveness) where
   2
   3 import Cmm
   4 import PprCmm ()
   5
   6 import UniqSet
   7 import UniqFM
   8
   9 import FastString
  10 import Outputable
  11
  12 import Maybes
  13
  14 import Data.List
  15 import Data.Maybe
  16
  17 cmmBranchSources :: [(BlockId, [BlockId])] -> [(BlockId, [BlockId])]
  18 cmmBranchSources input =
  19     [(target, [s | (s, ts) <- input, target `elem` ts])
  20      | target <- targets] where
  21         targets = nub [t | (s, ts) <- input, t <- ts]
  22
  23 cmmBranchTargets :: CmmBasicBlock -> UniqSet BlockId
  24 cmmBranchTargets (BasicBlock _ stmts) =
  25     mkUniqSet $ concatMap target stmts where
  26         target (CmmBranch ident) = [ident]
  27         target (CmmCondBranch _ ident) = [ident]
  28         target (CmmSwitch _ blocks) = mapMaybe id blocks
  29         target _ = []
  30
  31 --------------------------------------------------------------------------------
  32
  33 -- This should really be a state monad, but that is not in the core libraries
  34 -- so we'll hack around it here.
  35 -- The monad we're using is: type State a = s -> s
  36
  37 -- The variables that were made live and killed respectively
  38 type CmmLive = UniqSet LocalReg
  39 addLive new_live live = live `unionUniqSets` new_live
  40 addKilled new_killed live = live `minusUniqSet` new_killed
  41
  42 -- Calculate the live and killed registers for a local block
  43 cmmBlockLive :: UniqFM {-BlockId-} CmmLive -> CmmBasicBlock -> CmmLive
  44 cmmBlockLive other_live (BasicBlock _ stmts) =
  45     foldr ((.) . (cmmStmtLive other_live)) id stmts emptyUniqSet
  46
  47 -- Helper for cmmLocalLiveness
  48 cmmStmtLive :: UniqFM {-BlockId-} CmmLive -> CmmStmt -> (CmmLive -> CmmLive)
  49 cmmStmtLive _ (CmmNop) = id
  50 cmmStmtLive _ (CmmComment _) = id
  51 cmmStmtLive _ (CmmAssign reg expr) =
  52     cmmExprLive expr . reg_liveness where
  53         reg_liveness =
  54             case reg of
  55               (CmmLocal reg') -> addKilled $ unitUniqSet reg'
  56               (CmmGlobal _) -> id
  57 cmmStmtLive _ (CmmStore expr1 expr2) =
  58     cmmExprLive expr2 . cmmExprLive expr1
  59 cmmStmtLive _ (CmmCall target results arguments _) =
  60     target_liveness .
  61     foldr ((.) . cmmExprLive) id (map fst arguments) .
  62     addKilled (mkUniqSet $ only_local_regs results) where
  63         only_local_regs [] = []
  64         only_local_regs ((CmmGlobal _,_):args) = only_local_regs args
  65         only_local_regs ((CmmLocal r,_):args) = r:only_local_regs args
  66         target_liveness =
  67             case target of
  68               (CmmForeignCall target _) -> cmmExprLive target
  69               (CmmPrim _) -> id
  70 cmmStmtLive other_live (CmmBranch target) = addLive (lookupWithDefaultUFM other_live emptyUniqSet target)
  71 cmmStmtLive other_live (CmmCondBranch expr target) = cmmExprLive expr . addLive (lookupWithDefaultUFM other_live emptyUniqSet target)
  72 cmmStmtLive other_live (CmmSwitch expr targets) =
  73     cmmExprLive expr .
  74     (foldr ((.) . (addLive . lookupWithDefaultUFM other_live emptyUniqSet)) id (mapCatMaybes id targets))
  75 cmmStmtLive _ (CmmJump expr params) =
  76     const (cmmExprLive expr $ foldr ((.) . cmmExprLive) id (map fst params) $ emptyUniqSet)
  77 cmmStmtLive _ (CmmReturn params) =
  78     const (foldr ((.) . cmmExprLive) id (map fst params) $ emptyUniqSet)
  79
  80 --------
  81
  82 -- Helper for cmmLocalLiveness
  83 cmmExprLive :: CmmExpr -> (CmmLive -> CmmLive)
  84 cmmExprLive expr = addLive (mkUniqSet $ expr_liveness expr) where
  85     expr_liveness (CmmLit _) = []
  86     expr_liveness (CmmLoad expr _) = expr_liveness expr
  87     expr_liveness (CmmReg reg) = reg_liveness reg
  88     expr_liveness (CmmMachOp _ exprs) = concatMap expr_liveness exprs
  89     expr_liveness (CmmRegOff reg _) = reg_liveness reg
  90     reg_liveness (CmmLocal reg) = [reg]
  91     reg_liveness (CmmGlobal _) = []
  92
  93 cmmBlockUpdate ::
  94     UniqFM {-BlockId-} CmmBasicBlock
  95     -> BlockId
  96     -> Maybe BlockId
  97     -> UniqFM {-BlockId-} CmmLive
  98     -> Maybe (UniqFM {-BlockId-} CmmLive)
  99 cmmBlockUpdate blocks node _ state =
 100     let old_live = lookupWithDefaultUFM state emptyUniqSet node
 101         block = lookupWithDefaultUFM blocks (panic "unknown block id during liveness analysis") node
 102         new_live = cmmBlockLive state block
 103     in if (sizeUniqSet old_live) == (sizeUniqSet new_live)
 104        then Nothing
 105        else Just $ addToUFM state node new_live
 106
 107 cmmBlockDependants :: UniqFM {-BlockId-} (UniqSet BlockId) -> BlockId -> [BlockId]
 108 cmmBlockDependants sources ident =
 109     uniqSetToList $ lookupWithDefaultUFM sources emptyUFM ident
 110
 111 cmmBlockSourcesAndTargets ::
 112     [CmmBasicBlock]
 113     -> (UniqFM {-BlockId-} (UniqSet BlockId), UniqFM (UniqSet BlockId))
 114 cmmBlockSourcesAndTargets blocks = foldr aux (emptyUFM, emptyUFM) blocks where
 115     aux block (sourcesUFM, targetsUFM)  =
 116         (foldUniqSet add_source_edges sourcesUFM targets,
 117          addToUFM_Acc unionUniqSets id targetsUFM ident targets) where
 118             add_source_edges t ufm =
 119                 addToUFM_Acc (flip addOneToUniqSet) unitUniqSet ufm t ident
 120             targets = cmmBranchTargets block
 121             ident = blockId block
 122
 123 cmmBlockNames :: [CmmBasicBlock] -> UniqFM {-BlockId-} CmmBasicBlock
 124 cmmBlockNames blocks = listToUFM $ map block_name blocks where
 125     block_name b = (blockId b, b)
 126
 127 cmmLiveness :: [CmmBasicBlock] -> UniqFM {-BlockId-} CmmLive
 128 cmmLiveness blocks =
 129     fixedpoint (cmmBlockDependants sources) (cmmBlockUpdate blocks')
 130                (map blockId blocks) emptyUFM where
 131                    (sources, targets) = cmmBlockSourcesAndTargets blocks
 132                    blocks' = cmmBlockNames blocks
 133
 134 cmmLivenessComment ::
 135     UniqFM {-BlockId-} (UniqSet LocalReg)
 136     -> CmmBasicBlock -> CmmBasicBlock
 137 cmmLivenessComment live (BasicBlock ident stmts) =
 138     BasicBlock ident stmts' where
 139         stmts' = (CmmComment $ mkFastString $ showSDoc $ ppr $ live'):stmts
 140         live' = map CmmLocal $ uniqSetToList $ lookupWithDefaultUFM live emptyUniqSet ident
 141
 142 onBasicBlock f (CmmProc ds ident args blocks) = CmmProc ds ident args (f blocks)
 143 onBasicBlock f x = x
 144
 145 mapCmmTop f (Cmm xs) = Cmm (map f xs)
 146
 147 --------------------------------------------------------------------------------
 148
 149 -- Solve a fixed-point of a dataflow problem.
 150 -- O(N+H*E) calls to update where
 151 --   N = number of nodes,
 152 --   E = number of edges,
 153 --   H = maximum height of the lattice for any particular node.
 154 -- dependants: map from nodes to those who's value depend on the argument node
 155 -- update:
 156 --   Given the node which needs to be updated, and
 157 --   which node caused that node to need to be updated,
 158 --   update the state.
 159 --   (The causing node will be 'Nothing' if this is the initial update.)
 160 --   Must return 'Nothing' if no change,
 161 --   otherwise returrn 'Just' of the new state
 162 -- nodes: a set of nodes that initially need updating
 163 -- state: some sort of state (usually a map)
 164 --        containing the initial value for each node
 165 --
 166 -- Sketch for proof of complexity:
 167 -- Note that the state is threaded through the entire execution.
 168 -- Also note that the height of the latice at any particular node
 169 -- is the number of times 'update' can return non-Nothing for a particular node.
 170 -- Every call (except for the top level one) must be caused by a non-Nothing
 171 -- result and each non-Nothing result causes as many calls as it has
 172 -- out-going edges.  Thus any particular node, n, may cause in total
 173 -- at most H*out(n) further calls.  When summed over all nodes,
 174 -- that is H*E.  The N term of the complexity is from the initial call
 175 -- when 'update' will be passed 'Nothing'.
 176 fixedpoint ::
 177     (node -> [node])
 178     -> (node -> Maybe node -> s -> Maybe s)
 179     -> [node] -> s -> s
 180 fixedpoint dependants update nodes state =
 181     foldr (fixedpoint' Nothing) state nodes where
 182         fixedpoint' cause node state =
 183             case update node cause state of
 184               Nothing -> state
 185               Just state' ->
 186                   foldr (fixedpoint' (Just node)) state' (dependants node)