Dataflow.hs 7.5 KB
Newer Older
1
module Dataflow (cmmLivenessComment, cmmLiveness, CmmLive) where
2 3

import Cmm
4
import PprCmm ()
5 6 7 8 9 10 11

import UniqSet
import UniqFM

import FastString
import Outputable

12 13
import Maybes

14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37
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
38 39 40
type CmmLive = UniqSet LocalReg
addLive new_live live = live `unionUniqSets` new_live
addKilled new_killed live = live `minusUniqSet` new_killed
41 42

-- Calculate the live and killed registers for a local block
43 44 45
cmmBlockLive :: UniqFM {-BlockId-} CmmLive -> CmmBasicBlock -> CmmLive
cmmBlockLive other_live (BasicBlock _ stmts) =
    foldr ((.) . (cmmStmtLive other_live)) id stmts emptyUniqSet
46 47

-- Helper for cmmLocalLiveness
48 49 50 51 52
cmmStmtLive :: UniqFM {-BlockId-} CmmLive -> CmmStmt -> (CmmLive -> CmmLive)
cmmStmtLive _ (CmmNop) = id
cmmStmtLive _ (CmmComment _) = id
cmmStmtLive _ (CmmAssign reg expr) =
    cmmExprLive expr . reg_liveness where
53 54
        reg_liveness =
            case reg of
55
              (CmmLocal reg') -> addKilled $ unitUniqSet reg'
56
              (CmmGlobal _) -> id
57 58 59
cmmStmtLive _ (CmmStore expr1 expr2) =
    cmmExprLive expr2 . cmmExprLive expr1
cmmStmtLive _ (CmmCall target results arguments _) =
60
    target_liveness .
61 62
    foldr ((.) . cmmExprLive) id (map fst arguments) .
    addKilled (mkUniqSet $ only_local_regs results) where
63 64 65 66 67
        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
68
              (CmmForeignCall target _) -> cmmExprLive target
69
              (CmmPrim _) -> id
70 71 72 73 74 75
cmmStmtLive other_live (CmmBranch target) = addLive (lookupWithDefaultUFM other_live emptyUniqSet target)
cmmStmtLive other_live (CmmCondBranch expr target) = cmmExprLive expr . addLive (lookupWithDefaultUFM other_live emptyUniqSet target)
cmmStmtLive other_live (CmmSwitch expr targets) =
    cmmExprLive expr .
    (foldr ((.) . (addLive . lookupWithDefaultUFM other_live emptyUniqSet)) id (mapCatMaybes id targets))
cmmStmtLive _ (CmmJump expr params) =
76 77 78
    const (cmmExprLive expr $ foldr ((.) . cmmExprLive) id (map fst params) $ emptyUniqSet)
cmmStmtLive _ (CmmReturn params) =
    const (foldr ((.) . cmmExprLive) id (map fst params) $ emptyUniqSet)
79 80

--------
81 82

-- Helper for cmmLocalLiveness
83 84
cmmExprLive :: CmmExpr -> (CmmLive -> CmmLive)
cmmExprLive expr = addLive (mkUniqSet $ expr_liveness expr) where
85 86 87 88 89 90 91 92 93
    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 _) = []

cmmBlockUpdate ::
94
    UniqFM {-BlockId-} CmmBasicBlock
95 96
    -> BlockId
    -> Maybe BlockId
97 98 99
    -> UniqFM {-BlockId-} CmmLive
    -> Maybe (UniqFM {-BlockId-} CmmLive)
cmmBlockUpdate blocks node _ state =
100
    let old_live = lookupWithDefaultUFM state (panic "unknown block id during liveness analysis") node
101 102 103 104 105
        block = lookupWithDefaultUFM blocks (panic "unknown block id during liveness analysis") node
        new_live = cmmBlockLive state block
    in if (sizeUniqSet old_live) == (sizeUniqSet new_live)
       then Nothing
       else Just $ addToUFM state node new_live
106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122

cmmBlockDependants :: UniqFM {-BlockId-} (UniqSet BlockId) -> BlockId -> [BlockId]
cmmBlockDependants sources ident =
    uniqSetToList $ lookupWithDefaultUFM sources emptyUFM ident

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

123 124 125 126 127
cmmBlockNames :: [CmmBasicBlock] -> UniqFM {-BlockId-} CmmBasicBlock
cmmBlockNames blocks = listToUFM $ map block_name blocks where
    block_name b = (blockId b, b)

cmmLiveness :: [CmmBasicBlock] -> UniqFM {-BlockId-} CmmLive
128
cmmLiveness blocks =
129
    fixedpoint (cmmBlockDependants sources) (cmmBlockUpdate blocks')
130
               (map blockId blocks) (listToUFM [(blockId b, emptyUniqSet) | b <- blocks]) where
131
                   (sources, targets) = cmmBlockSourcesAndTargets blocks
132
                   blocks' = cmmBlockNames blocks
133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181

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

--------------------------------------------------------------------------------

-- 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)