2 ( DataflowLattice(..) , DataflowAnalysis
3 , markFactsUnchanged, factsStatus, getFact, setFact, getExitFact, setExitFact
4 , forgetFact, botFact, setAllFacts, getAllFacts, factsEnv
5 , addLastOutFact, bareLastOutFacts, forgetLastOutFacts, checkFactMatch
8 , DFM, runDFM, liftToDFM
9 , markGraphRewritten, graphWasRewritten
11 , module OptimizationFuel
18 import OptimizationFuel
28 A dataflow monad maintains a mapping from BlockIds to dataflow facts,
29 where a dataflow fact is a value of type [[a]]. Values of type [[a]]
30 must form a lattice, as described by type [[Fact a]].
32 The dataflow engine uses the lattice structure to compute a least
33 solution to a set of dataflow equations. To compute a greatest
34 solution, flip the lattice over.
36 The engine works by starting at the bottom and iterating to a fixed
37 point, so in principle we require the bottom element, a join (least
38 upper bound) operation, and a comparison to find out if a value has
39 changed (grown). In practice, the comparison is only ever used in
40 conjunction with the join, so we have [[fact_add_to]]:
43 let j = join new old in
44 if j <= old then noTx old -- nothing changed
45 else aTx j -- the fact changed
49 data DataflowLattice a = DataflowLattice {
50 fact_name :: String, -- documentation
51 fact_bot :: a, -- lattice bottom element
52 fact_add_to :: a -> a -> TxRes a, -- lattice join and compare
53 -- ^ compute join of two args; something changed iff join is greater than 2nd arg
54 fact_do_logging :: Bool -- log changes
58 -- DFM is the monad of combined analysis and transformation,
59 -- which needs a UniqSupply and may consume optimization fuel
60 -- DFM is defined using a monad transformer, DFM', which is the general
61 -- case of DFM, parameterized over any monad.
62 -- In practice, we apply DFM' to the FuelMonad, which provides optimization fuel and
64 data DFState f = DFState { df_rewritten :: ChangeFlag
65 , df_facts :: BlockEnv f
67 , df_last_outs :: [(BlockId, f)]
68 , df_facts_change :: ChangeFlag
71 newtype DFM' m fact a = DFM' (DataflowLattice fact -> DFState fact
72 -> m (a, DFState fact))
73 type DFM fact a = DFM' FuelMonad fact a
76 runDFM :: Monad m => DataflowLattice f -> DFM' m f a -> m a
77 runDFM lattice (DFM' f) =
78 (f lattice $ DFState NoChange emptyBlockEnv (fact_bot lattice)[] NoChange)
81 class DataflowAnalysis m where
82 markFactsUnchanged :: m f () -- ^ Useful for starting a new iteration
83 factsStatus :: m f ChangeFlag
84 subAnalysis :: m f a -> m f a -- ^ Do a new analysis and then throw away
85 -- *all* the related state.
87 getFact :: BlockId -> m f f
88 setFact :: Outputable f => BlockId -> f -> m f ()
90 setExitFact :: Outputable f => f -> m f ()
91 checkFactMatch :: Outputable f =>
92 BlockId -> f -> m f () -- ^ assert fact already at this val
94 forgetFact :: BlockId -> m f ()
95 -- | It might be surprising these next two are needed in a pure analysis,
96 -- but for some problems we do a 'shallow' rewriting in which a rewritten
97 -- graph is not itself considered for further rewriting but merely undergoes
98 -- an analysis. In this case the results of a forward analysis might produce
99 -- new facts that go on BlockId's that reside outside the graph being analyzed.
100 -- Thus these 'lastOutFacts' need to be available even in a pure analysis.
101 addLastOutFact :: (BlockId, f) -> m f ()
102 bareLastOutFacts :: m f [(BlockId, f)]
103 forgetLastOutFacts :: m f ()
104 getAllFacts :: m f (BlockEnv f)
105 setAllFacts :: BlockEnv f -> m f ()
106 factsEnv :: Monad (m f) => m f (BlockId -> f)
108 lattice :: m f (DataflowLattice f)
109 factsEnv = do { map <- getAllFacts
111 ; return $ \id -> lookupBlockEnv map id `orElse` bot }
113 instance Monad m => DataflowAnalysis (DFM' m) where
114 markFactsUnchanged = DFM' f
115 where f _ s = return ((), s {df_facts_change = NoChange})
116 factsStatus = DFM' f'
117 where f' _ s = return (df_facts_change s, s)
118 subAnalysis (DFM' f) = DFM' f'
119 where f' l s = do (a, _) <- f l (subAnalysisState s)
121 getFact id = DFM' get
122 where get lattice s =
123 return (lookupBlockEnv (df_facts s) id `orElse` fact_bot lattice, s)
124 setFact id a = DFM' set
125 where set (DataflowLattice name bot add_fact log) s =
126 case add_fact a old of
127 TxRes NoChange _ -> if initialized then return ((), s) else update old old
128 TxRes SomeChange join -> update join old
129 where (old, initialized) =
130 case lookupBlockEnv (df_facts s) id of
132 Nothing -> (bot, False)
134 let facts' = extendBlockEnv (df_facts s) id join
135 debug = if log then pprTrace else \_ _ a -> a
136 in debug name (pprSetFact id old a join) $
137 return ((), s { df_facts = facts', df_facts_change = SomeChange })
138 getExitFact = DFM' get
139 where get _ s = return (df_exit_fact s, s)
141 do old <- getExitFact
142 DataflowLattice { fact_add_to = add_fact
143 , fact_name = name, fact_do_logging = log } <- lattice
144 case add_fact a old of
145 TxRes NoChange _ -> return ()
146 TxRes SomeChange join -> DFM' $ \_ s ->
147 let debug = if log then pprTrace else \_ _ a -> a
148 in debug name (pprSetFact "exit" old a join) $
149 return ((), s { df_exit_fact = join, df_facts_change = SomeChange })
151 where f _ s = return (df_facts s, s)
152 setAllFacts env = DFM' f
153 where f _ s = return ((), s { df_facts = env})
155 where f lattice s = return (fact_bot lattice, s)
156 forgetFact id = DFM' f
157 where f _ s = return ((), s { df_facts = delFromUFM (df_facts s) id })
158 addLastOutFact pair = DFM' f
159 where f _ s = return ((), s { df_last_outs = pair : df_last_outs s })
160 bareLastOutFacts = DFM' f
161 where f _ s = return (df_last_outs s, s)
162 forgetLastOutFacts = DFM' f
163 where f _ s = return ((), s { df_last_outs = [] })
164 checkFactMatch id a =
166 ; old_a <- getFact id
167 ; case fact_add_to fact a old_a of
168 TxRes NoChange _ -> return ()
169 TxRes SomeChange new ->
170 do { facts <- getAllFacts
171 ; pprPanic "checkFactMatch"
172 (f4sep [text (fact_name fact), text "at id" <+> ppr id,
173 text "changed from", nest 4 (ppr old_a), text "to",
175 text "after supposedly reaching fixed point;",
176 text "env is", pprFacts facts])
179 where pprFacts env = vcat (map pprFact (ufmToList env))
180 pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
183 where f l s = return (l, s)
185 subAnalysisState :: DFState f -> DFState f
186 subAnalysisState s = s {df_facts_change = NoChange}
189 markGraphRewritten :: Monad m => DFM' m f ()
190 markGraphRewritten = DFM' f
191 where f _ s = return ((), s {df_rewritten = SomeChange})
193 graphWasRewritten :: DFM f ChangeFlag
194 graphWasRewritten = DFM' f
195 where f _ s = return (df_rewritten s, s)
197 freshBlockId :: String -> DFM f BlockId
198 freshBlockId _s = getUniqueM >>= return . BlockId
200 instance Monad m => Monad (DFM' m f) where
201 DFM' f >>= k = DFM' (\l s -> do (a, s') <- f l s
202 let DFM' f' = k a in f' l s')
203 return a = DFM' (\_ s -> return (a, s))
205 instance FuelUsingMonad (DFM' FuelMonad f) where
206 fuelRemaining = liftToDFM' fuelRemaining
207 lastFuelPass = liftToDFM' lastFuelPass
208 fuelExhausted = liftToDFM' fuelExhausted
209 fuelDecrement p f f' = liftToDFM' (fuelDecrement p f f')
210 fuelDec1 = liftToDFM' fuelDec1
211 instance MonadUnique (DFM' FuelMonad f) where
212 getUniqueSupplyM = liftToDFM' getUniqueSupplyM
213 getUniqueM = liftToDFM' getUniqueM
214 getUniquesM = liftToDFM' getUniquesM
216 liftToDFM' :: Monad m => m x -> DFM' m f x
217 liftToDFM' m = DFM' (\ _ s -> m >>= (\a -> return (a, s)))
218 liftToDFM :: FuelMonad x -> DFM f x
219 liftToDFM m = DFM' (\ _ s -> m >>= (\a -> return (a, s)))
222 pprSetFact :: (Show a, Outputable f) => a -> f -> f -> f -> SDoc
223 pprSetFact id old a join =
224 f4sep [text "at" <+> text (show id),
225 text "added" <+> ppr a, text "to" <+> ppr old,
226 text "yielding" <+> ppr join]
228 f4sep :: [SDoc] -> SDoc
230 f4sep (d:ds) = fsep (d : map (nest 4) ds)