Dataflow.hs 7.57 KB
Newer Older
1
2
3
module Dataflow (mapCmmTop, onBasicBlock, cmmLivenessComment, cmmLiveness) where

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
100
101
102
103
104
105
    -> UniqFM {-BlockId-} CmmLive
    -> Maybe (UniqFM {-BlockId-} CmmLive)
cmmBlockUpdate blocks node _ state =
    let old_live = lookupWithDefaultUFM state emptyUniqSet node
        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
131
               (map blockId blocks) emptyUFM where
                   (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
182
183
184
185
186

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)