compiler/cmm/Dataflow.hs

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