5 , markFactsUnchanged, factsStatus, getFact, setFact, getExitFact, setExitFact
6 , forgetFact, botFact, setAllFacts, getAllFacts, factsEnv, checkFactMatch
7 , addLastOutFact, bareLastOutFacts, forgetLastOutFacts
11 , DFM, runDFM, liftAnal
12 , markGraphRewritten, graphWasRewritten
15 , module OptimizationFuel
21 import OptimizationFuel
33 A dataflow monad maintains a mapping from BlockIds to dataflow facts,
34 where a dataflow fact is a value of type [[a]]. Values of type [[a]]
35 must form a lattice, as described by type [[Fact a]].
37 The dataflow engine uses the lattice structure to compute a least
38 solution to a set of dataflow equations. To compute a greatest
39 solution, flip the lattice over.
41 The engine works by starting at the bottom and iterating to a fixed
42 point, so in principle we require the bottom element, a join (least
43 upper bound) operation, and a comparison to find out if a value has
44 changed (grown). In practice, the comparison is only ever used in
45 conjunction with the join, so we have [[fact_add_to]]:
48 let j = join new old in
49 if j <= old then noTx old -- nothing changed
50 else aTx j -- the fact changed
54 data DataflowLattice a = DataflowLattice {
55 fact_name :: String, -- documentation
56 fact_bot :: a, -- lattice bottom element
57 fact_add_to :: a -> a -> TxRes a, -- lattice join and compare
58 -- ^ compute join of two args; something changed iff join is greater than 2nd arg
59 fact_do_logging :: Bool -- log changes
63 -- There are two monads here:
64 -- 1. DFA, the monad of analysis, which never changes anything
65 -- 2. DFM, the monad of combined analysis and transformation,
66 -- which needs a UniqSupply and may consume transactions
68 data DFAState f = DFAState { df_facts :: BlockEnv f
70 , df_last_outs :: [(BlockId, f)]
71 , df_facts_change :: ChangeFlag
75 data DFState f = DFState { df_uniqs :: UniqSupply
76 , df_rewritten :: ChangeFlag
77 , df_astate :: DFAState f
78 , df_fstate :: FuelState
81 newtype DFA fact a = DFA (DataflowLattice fact -> DFAState fact -> (a, DFAState fact))
82 newtype DFM fact a = DFM (DataflowLattice fact -> DFState fact -> (a, DFState fact))
85 liftAnal :: DFA f a -> DFM f a
86 liftAnal (DFA f) = DFM f'
87 where f' l s = let (a, anal) = f l (df_astate s)
88 in (a, s {df_astate = anal})
90 initDFAState :: f -> DFAState f
91 initDFAState bot = DFAState emptyBlockEnv bot [] NoChange
93 runDFA :: DataflowLattice f -> DFA f a -> a
94 runDFA lattice (DFA f) = fst $ f lattice (initDFAState $ fact_bot lattice)
96 runDFM :: UniqSupply -> DataflowLattice f -> DFM f a -> FuelMonad a
97 runDFM uniqs lattice (DFM f) = FuelMonad (\s ->
98 let (a, s') = f lattice $ DFState uniqs NoChange dfa_state s
100 where dfa_state = initDFAState (fact_bot lattice)
102 class DataflowAnalysis m where
103 markFactsUnchanged :: m f () -- ^ Useful for starting a new iteration
104 factsStatus :: m f ChangeFlag
105 subAnalysis :: m f a -> m f a -- ^ Do a new analysis and then throw away
106 -- *all* the related state. Even the Uniques
109 getFact :: BlockId -> m f f
110 setFact :: Outputable f => BlockId -> f -> m f ()
112 setExitFact :: Outputable f => f -> m f ()
113 checkFactMatch :: Outputable f =>
114 BlockId -> f -> m f () -- ^ assert fact already at this val
116 forgetFact :: BlockId -> m f ()
117 -- | It might be surprising these next two are needed in a pure analysis,
118 -- but for some problems we do a 'shallow' rewriting in which a rewritten
119 -- graph is not itself considered for further rewriting but merely undergoes
120 -- an analysis. In this case the results of a forward analysis might produce
121 -- new facts that go on BlockId's that reside outside the graph being analyzed.
122 -- Thus these 'lastOutFacts' need to be available even in a pure analysis.
123 addLastOutFact :: (BlockId, f) -> m f ()
124 bareLastOutFacts :: m f [(BlockId, f)]
125 forgetLastOutFacts :: m f ()
126 getAllFacts :: m f (BlockEnv f)
127 setAllFacts :: BlockEnv f -> m f ()
128 factsEnv :: Monad (m f) => m f (BlockId -> f)
130 lattice :: m f (DataflowLattice f)
131 factsEnv = do { map <- getAllFacts
133 ; return $ \id -> lookupBlockEnv map id `orElse` bot }
135 instance DataflowAnalysis DFA where
136 markFactsUnchanged = DFA f
137 where f _ s = ((), s {df_facts_change = NoChange})
139 where f' _ s = (df_facts_change s, s)
140 subAnalysis (DFA f) = DFA f'
141 where f' l s = let (a, _) = f l (subAnalysisState s) in (a, s)
143 where get lattice s = (lookupBlockEnv (df_facts s) id `orElse` fact_bot lattice, s)
146 DataflowLattice { fact_add_to = add_fact
147 , fact_name = name, fact_do_logging = log } <- lattice
148 case add_fact a old of
149 TxRes NoChange _ -> return ()
150 TxRes SomeChange join -> DFA $ \_ s ->
151 let facts' = extendBlockEnv (df_facts s) id join
152 debug = if log then pprTrace else \_ _ a -> a
153 in debug name (pprSetFact id old a join) $
154 ((), s { df_facts = facts', df_facts_change = SomeChange })
155 getExitFact = DFA get
156 where get _ s = (df_exit_fact s, s)
158 do old <- getExitFact
159 DataflowLattice { fact_add_to = add_fact
160 , fact_name = name, fact_do_logging = log } <- lattice
161 case add_fact a old of
162 TxRes NoChange _ -> return ()
163 TxRes SomeChange join -> DFA $ \_ s ->
164 let debug = if log then pprTrace else \_ _ a -> a
165 in debug name (pprSetFact "exit" old a join) $
166 ((), s { df_exit_fact = join, df_facts_change = SomeChange })
168 where f _ s = (df_facts s, s)
169 setAllFacts env = DFA f
170 where f _ s = ((), s { df_facts = env})
172 where f lattice s = (fact_bot lattice, s)
173 forgetFact id = DFA f
174 where f _ s = ((), s { df_facts = delFromUFM (df_facts s) id })
175 addLastOutFact pair = DFA f
176 where f _ s = ((), s { df_last_outs = pair : df_last_outs s })
177 bareLastOutFacts = DFA f
178 where f _ s = (df_last_outs s, s)
179 forgetLastOutFacts = DFA f
180 where f _ s = ((), s { df_last_outs = [] })
181 checkFactMatch id a =
183 ; old_a <- getFact id
184 ; case fact_add_to fact a old_a of
185 TxRes NoChange _ -> return ()
186 TxRes SomeChange new ->
187 do { facts <- getAllFacts
188 ; pprPanic "checkFactMatch"
189 (f4sep [text (fact_name fact), text "at id" <+> ppr id,
190 text "changed from", nest 4 (ppr old_a), text "to",
192 text "after supposedly reaching fixed point;",
193 text "env is", pprFacts facts])
196 where pprFacts env = vcat (map pprFact (ufmToList env))
197 pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
202 subAnalysisState :: DFAState f -> DFAState f
203 subAnalysisState s = s {df_facts_change = NoChange}
206 instance DataflowAnalysis DFM where
207 markFactsUnchanged = liftAnal $ markFactsUnchanged
208 factsStatus = liftAnal $ factsStatus
209 subAnalysis = dfmSubAnalysis
210 getFact id = liftAnal $ getFact id
211 setFact id new = liftAnal $ setFact id new
212 getExitFact = liftAnal $ getExitFact
213 setExitFact new = liftAnal $ setExitFact new
214 botFact = liftAnal $ botFact
215 forgetFact id = liftAnal $ forgetFact id
216 addLastOutFact p = liftAnal $ addLastOutFact p
217 bareLastOutFacts = liftAnal $ bareLastOutFacts
218 forgetLastOutFacts = liftAnal $ forgetLastOutFacts
219 getAllFacts = liftAnal $ getAllFacts
220 setAllFacts env = liftAnal $ setAllFacts env
221 checkFactMatch id a = liftAnal $ checkFactMatch id a
223 lattice = liftAnal $ lattice
225 dfmSubAnalysis :: DFM f a -> DFM f a
226 dfmSubAnalysis (DFM f) = DFM f'
227 where f' l s = let s' = s { df_astate = subAnalysisState (df_astate s) }
232 markGraphRewritten :: DFM f ()
233 markGraphRewritten = DFM f
234 where f _ s = ((), s {df_rewritten = SomeChange})
236 graphWasRewritten :: DFM f ChangeFlag
237 graphWasRewritten = DFM f
238 where f _ s = (df_rewritten s, s)
240 freshBlockId :: String -> DFM f BlockId
241 freshBlockId _s = liftUSM $ getUniqueUs >>= return . BlockId
243 liftUSM :: UniqSM a -> DFM f a
245 where f _ s = let (a, us') = initUs (df_uniqs s) uc
246 in (a, s {df_uniqs = us'})
248 instance Monad (DFA f) where
249 DFA f >>= k = DFA (\l s -> let (a, s') = f l s
252 return a = DFA (\_ s -> (a, s))
254 instance Monad (DFM f) where
255 DFM f >>= k = DFM (\l s -> let (a, s') = f l s
258 return a = DFM (\_ s -> (a, s))
260 instance FuelUsingMonad (DFM f) where
261 fuelRemaining = extract fuelRemainingInState
262 lastFuelPass = extract lastFuelPassInState
263 fuelExhausted = extract fuelExhaustedInState
264 fuelDecrement p f f' = DFM (\_ s -> ((), s { df_fstate = fs' s }))
265 where fs' s = fuelDecrementState p f f' $ df_fstate s
267 extract :: (FuelState -> a) -> DFM f a
268 extract f = DFM (\_ s -> (f $ df_fstate s, s))
271 pprSetFact :: (Show a, Outputable f) => a -> f -> f -> f -> SDoc
272 pprSetFact id old a join =
273 f4sep [text "at" <+> text (show id),
274 text "added" <+> ppr a, text "to" <+> ppr old,
275 text "yielding" <+> ppr join]
277 f4sep :: [SDoc] -> SDoc
279 f4sep (d:ds) = fsep (d : map (nest 4) ds)