4 , DFTx, runDFTx, lastTxPass, txDecrement, txRemaining, txExhausted
9 , markFactsUnchanged, factsStatus, getFact, setFact, botFact
10 , forgetFact, allFacts, factsEnv, checkFactMatch
11 , addLastOutFact, lastOutFacts, forgetLastOutFacts
15 , DFM, runDFM, liftTx, liftAnal
29 import qualified ZipCfg as G
35 A dataflow monad maintains a mapping from BlockIds to dataflow facts,
36 where a dataflow fact is a value of type [[a]]. Values of type [[a]]
37 must form a lattice, as described by type [[Fact a]].
39 The dataflow engine uses the lattice structure to compute a least
40 solution to a set of dataflow equations. To compute a greatest
41 solution, flip the lattice over.
43 The engine works by starting at the bottom and iterating to a fixed
44 point, so in principle we require the bottom element, a join (least
45 upper bound) operation, and a comparison to find out if a value has
46 changed (grown). In practice, the comparison is only ever used in
47 conjunction with the join, so we have [[fact_add_to]]:
50 let j = join new old in
51 if j <= old then noTx old -- nothing changed
52 else aTx j -- the fact changed
56 data DataflowLattice a = DataflowLattice {
57 fact_name :: String, -- documentation
58 fact_bot :: a, -- lattice bottom element
59 fact_add_to :: a -> a -> TxRes a, -- lattice join and compare
60 -- ^ compute join of two args; something changed iff join is greater than 2nd arg
61 fact_do_logging :: Bool -- log changes
65 -- There are three monads here:
66 -- 1. DFTx, the monad of transactions, to be carried through all
67 -- graph-changing computations in the program
68 -- 2. DFA, the monad of analysis, which never changes anything
69 -- 3. DFM, the monad of combined analysis and transformation,
70 -- which needs a UniqSupply and may consume transactions
72 data DFAState f = DFAState { df_facts :: BlockEnv f
73 , df_facts_change :: ChangeFlag
76 data DFTxState = DFTxState { df_txlimit :: OptimizationFuel, df_lastpass :: String }
78 data DFState f = DFState { df_uniqs :: UniqSupply
79 , df_rewritten :: ChangeFlag
80 , df_astate :: DFAState f
81 , df_txstate :: DFTxState
82 , df_last_outs :: [(BlockId, f)]
85 newtype DFTx a = DFTx (DFTxState -> (a, DFTxState))
86 newtype DFA fact a = DFA (DataflowLattice fact -> DFAState fact -> (a, DFAState fact))
87 newtype DFM fact a = DFM (DataflowLattice fact -> DFState fact -> (a, DFState fact))
90 liftAnal :: DFA f a -> DFM f a
91 liftAnal (DFA f) = DFM f'
92 where f' l s = let (a, anal) = f l (df_astate s)
93 in (a, s {df_astate = anal})
95 liftTx :: DFTx a -> DFM f a
96 liftTx (DFTx f) = DFM f'
97 where f' _ s = let (a, txs) = f (df_txstate s)
98 in (a, s {df_txstate = txs})
100 newtype OptimizationFuel = OptimizationFuel Int
101 deriving (Ord, Eq, Num, Show, Bounded)
103 initDFAState :: DFAState f
104 initDFAState = DFAState emptyBlockEnv NoChange
106 runDFA :: DataflowLattice f -> DFA f a -> a
107 runDFA lattice (DFA f) = fst $ f lattice initDFAState
109 -- XXX DFTx really needs to be in IO, so we can dump programs in
110 -- intermediate states of optimization ---NR
112 functionalDFTx :: String -> (OptimizationFuel -> (a, OptimizationFuel)) -> DFTx a
113 functionalDFTx name pass = DFTx f
114 where f s = let (a, fuel) = pass (df_txlimit s)
115 in (a, DFTxState fuel name)
117 runDFTx :: OptimizationFuel -> DFTx a -> a --- should only be called once per program!
118 runDFTx lim (DFTx f) = fst $ f $ DFTxState lim "<none>"
120 lastTxPass :: DFTx String
122 where f s = (df_lastpass s, s)
124 runDFM :: UniqSupply -> DataflowLattice f -> DFM f a -> DFTx a
125 runDFM uniqs lattice (DFM f) = DFTx f'
127 let (a, s) = f lattice $ DFState uniqs NoChange initDFAState txs [] in
130 txExhausted :: DFTx Bool
132 where f s = (df_txlimit s <= 0, s)
134 txRemaining :: DFTx OptimizationFuel
136 where f s = (df_txlimit s, s)
138 txDecrement :: String -> OptimizationFuel -> OptimizationFuel -> DFTx ()
139 txDecrement optimizer old new = DFTx f
140 where f s = ((), s { df_txlimit = lim s, df_lastpass = optimizer })
141 lim s = if old == df_txlimit s then new
142 else panic $ concat ["lost track of ", optimizer, "'s transactions"]
145 class DataflowAnalysis m where
146 markFactsUnchanged :: m f () -- ^ Useful for starting a new iteration
147 factsStatus :: m f ChangeFlag
148 subAnalysis :: m f a -> m f a -- ^ Do a new analysis and then throw away
149 -- *all* the related state. Even the Uniques
152 getFact :: BlockId -> m f f
153 setFact :: Outputable f => BlockId -> f -> m f ()
154 checkFactMatch :: Outputable f =>
155 BlockId -> f -> m f () -- ^ assert fact already at this val
157 forgetFact :: BlockId -> m f ()
158 forgetLastOutFacts :: m f ()
159 allFacts :: m f (BlockEnv f)
160 factsEnv :: Monad (m f) => m f (BlockId -> f)
162 lattice :: m f (DataflowLattice f)
163 factsEnv = do { map <- allFacts
165 ; return $ \id -> lookupBlockEnv map id `orElse` bot }
167 instance DataflowAnalysis DFA where
168 markFactsUnchanged = DFA f
169 where f _ s = ((), s {df_facts_change = NoChange})
171 where f' _ s = (df_facts_change s, s)
172 subAnalysis (DFA f) = DFA f'
173 where f' l s = let (a, _) = f l (subAnalysisState s) in (a, s)
175 where get lattice s = (lookupBlockEnv (df_facts s) id `orElse` fact_bot lattice, s)
178 DataflowLattice { fact_add_to = add_fact
179 , fact_name = name, fact_do_logging = log } <- lattice
180 case add_fact a old of
181 TxRes NoChange _ -> return ()
182 TxRes SomeChange join -> DFA $ \_ s ->
183 let facts' = extendBlockEnv (df_facts s) id join
184 debug = if log then pprTrace else \_ _ a -> a
185 in debug name (pprSetFact id old a join) $
186 ((), s { df_facts = facts', df_facts_change = SomeChange })
188 where f lattice s = (fact_bot lattice, s)
189 forgetFact id = DFA f
190 where f _ s = ((), s { df_facts = delFromUFM (df_facts s) id })
191 forgetLastOutFacts = return ()
193 where f _ s = (df_facts s, s)
194 checkFactMatch id a =
196 ; old_a <- getFact id
197 ; case fact_add_to fact a old_a of
198 TxRes NoChange _ -> return ()
199 TxRes SomeChange new ->
200 do { facts <- allFacts
201 ; pprPanic "checkFactMatch"
202 (f4sep [text (fact_name fact), text "at id" <+> ppr id,
203 text "changed from", nest 4 (ppr old_a), text "to",
205 text "after supposedly reaching fixed point;",
206 text "env is", pprFacts facts])
209 where pprFacts env = vcat (map pprFact (ufmToList env))
210 pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
215 subAnalysisState :: DFAState f -> DFAState f
216 subAnalysisState s = s {df_facts_change = NoChange}
219 instance DataflowAnalysis DFM where
220 markFactsUnchanged = liftAnal $ markFactsUnchanged
221 factsStatus = liftAnal $ factsStatus
222 subAnalysis = dfmSubAnalysis
223 getFact id = liftAnal $ getFact id
224 setFact id new = liftAnal $ setFact id new
225 botFact = liftAnal $ botFact
226 forgetFact id = liftAnal $ forgetFact id
227 forgetLastOutFacts = dfmForgetLastOutFacts
228 allFacts = liftAnal $ allFacts
229 checkFactMatch id a = liftAnal $ checkFactMatch id a
231 lattice = liftAnal $ lattice
233 dfmSubAnalysis :: DFM f a -> DFM f a
234 dfmSubAnalysis (DFM f) = DFM f'
235 where f' l s = let s' = s { df_astate = subAnalysisState (df_astate s) }
239 dfmForgetLastOutFacts :: DFM f ()
240 dfmForgetLastOutFacts = DFM f
241 where f _ s = ((), s { df_last_outs = [] })
243 addLastOutFact :: (BlockId, f) -> DFM f ()
244 addLastOutFact pair = DFM f
245 where f _ s = ((), s { df_last_outs = pair : df_last_outs s })
247 lastOutFacts :: DFM f [(BlockId, f)]
249 where f _ s = (df_last_outs s, s)
251 markGraphRewritten :: DFM f ()
252 markGraphRewritten = DFM f
253 where f _ s = ((), s {df_rewritten = SomeChange})
255 freshBlockId :: String -> DFM f BlockId
256 freshBlockId _s = liftUSM $ getUniqueUs >>= return . BlockId
258 liftUSM :: UniqSM a -> DFM f a
260 where f _ s = let (a, us') = initUs (df_uniqs s) uc
261 in (a, s {df_uniqs = us'})
263 instance Monad (DFA f) where
264 DFA f >>= k = DFA (\l s -> let (a, s') = f l s
267 return a = DFA (\_ s -> (a, s))
269 instance Monad (DFM f) where
270 DFM f >>= k = DFM (\l s -> let (a, s') = f l s
273 return a = DFM (\_ s -> (a, s))
275 instance Monad (DFTx) where
276 DFTx f >>= k = DFTx (\s -> let (a, s') = f s
279 return a = DFTx (\s -> (a, s))
281 pprSetFact :: Outputable f => BlockId -> f -> f -> f -> SDoc
282 pprSetFact id old a join =
283 f4sep [text "at" <+> text (show id),
284 text "added" <+> ppr a, text "to" <+> ppr old,
285 text "yielding" <+> ppr join]
287 f4sep :: [SDoc] -> SDoc
289 f4sep (d:ds) = fsep (d : map (nest 4) ds)
292 _I_am_abstract :: Int -> OptimizationFuel
293 _I_am_abstract = OptimizationFuel -- prevents warning: OptimizationFuel unused