-instance DataflowAnalysis DFA where
- markFactsUnchanged = DFA f
- where f _ s = ((), s {df_facts_change = NoChange})
- factsStatus = DFA f'
- where f' _ s = (df_facts_change s, s)
- subAnalysis (DFA f) = DFA f'
- where f' l s = let (a, _) = f l (subAnalysisState s) in (a, s)
- getFact id = DFA get
- where get lattice s = (lookupBlockEnv (df_facts s) id `orElse` fact_bot lattice, s)
- setFact id a =
- do old <- getFact id
- DataflowLattice { fact_add_to = add_fact
- , fact_name = name, fact_do_logging = log } <- lattice
- case add_fact a old of
- TxRes NoChange _ -> return ()
- TxRes SomeChange join -> DFA $ \_ s ->
- let facts' = extendBlockEnv (df_facts s) id join
- debug = if log then pprTrace else \_ _ a -> a
- in debug name (pprSetFact id old a join) $
- ((), s { df_facts = facts', df_facts_change = SomeChange })
- getExitFact = DFA get
- where get _ s = (df_exit_fact s, s)
+instance Monad m => DataflowAnalysis (DFM' m) where
+ markFactsUnchanged = DFM' f
+ where f _ s = return ((), s {df_facts_change = NoChange})
+ factsStatus = DFM' f'
+ where f' _ s = return (df_facts_change s, s)
+ subAnalysis (DFM' f) = DFM' f'
+ where f' l s = do (a, _) <- f l (subAnalysisState s)
+ return (a, s)
+ getFact id = DFM' get
+ where get lattice s =
+ return (lookupBlockEnv (df_facts s) id `orElse` fact_bot lattice, s)
+ setFact id a = DFM' set
+ where set (DataflowLattice name bot add_fact log) s =
+ case add_fact a old of
+ TxRes NoChange _ -> if initialized then return ((), s) else update old old
+ TxRes SomeChange join -> update join old
+ where (old, initialized) =
+ case lookupBlockEnv (df_facts s) id of
+ Just f -> (f, True)
+ Nothing -> (bot, False)
+ update join old =
+ let facts' = extendBlockEnv (df_facts s) id join
+ debug = if log then pprTrace else \_ _ a -> a
+ in debug name (pprSetFact id old a join) $
+ return ((), s { df_facts = facts', df_facts_change = SomeChange })
+ getExitFact = DFM' get
+ where get _ s = return (df_exit_fact s, s)