Move all the CoreToDo stuff into CoreMonad
[ghc.git] / compiler / simplCore / SimplMonad.lhs
1 %
2 % (c) The AQUA Project, Glasgow University, 1993-1998
3 %
4 \section[SimplMonad]{The simplifier Monad}
5
6 \begin{code}
7 module SimplMonad (
8         -- The monad
9         SimplM,
10         initSmpl,
11         getDOptsSmpl, getSimplRules, getFamEnvs,
12
13         -- Unique supply
14         MonadUnique(..), newId,
15
16         -- Counting
17         SimplCount, tick, freeTick,
18         getSimplCount, zeroSimplCount, pprSimplCount, 
19         plusSimplCount, isZeroSimplCount,
20
21         -- Switch checker
22         SwitchChecker, SwitchResult(..), getSimplIntSwitch,
23         isAmongSimpl, intSwitchSet, switchIsOn, allOffSwitchChecker
24     ) where
25
26 import Id               ( Id, mkSysLocal )
27 import Type             ( Type )
28 import FamInstEnv       ( FamInstEnv )
29 import Rules            ( RuleBase )
30 import UniqSupply
31 import DynFlags         ( DynFlags )
32 import Maybes           ( expectJust )
33 import CoreMonad
34 import FastString
35 import Outputable
36 import FastTypes
37
38 import Data.Array
39 import Data.Array.Base (unsafeAt)
40 \end{code}
41
42 %************************************************************************
43 %*                                                                      *
44 \subsection{Monad plumbing}
45 %*                                                                      *
46 %************************************************************************
47
48 For the simplifier monad, we want to {\em thread} a unique supply and a counter.
49 (Command-line switches move around through the explicitly-passed SimplEnv.)
50
51 \begin{code}
52 newtype SimplM result
53   =  SM  { unSM :: SimplTopEnv  -- Envt that does not change much
54                 -> UniqSupply   -- We thread the unique supply because
55                                 -- constantly splitting it is rather expensive
56                 -> SimplCount 
57                 -> (result, UniqSupply, SimplCount)}
58
59 data SimplTopEnv = STE  { st_flags :: DynFlags 
60                         , st_rules :: RuleBase
61                         , st_fams  :: (FamInstEnv, FamInstEnv) }
62 \end{code}
63
64 \begin{code}
65 initSmpl :: DynFlags -> RuleBase -> (FamInstEnv, FamInstEnv) 
66          -> UniqSupply          -- No init count; set to 0
67          -> SimplM a
68          -> (a, SimplCount)
69
70 initSmpl dflags rules fam_envs us m
71   = case unSM m env us (zeroSimplCount dflags) of 
72         (result, _, count) -> (result, count)
73   where
74     env = STE { st_flags = dflags, st_rules = rules, st_fams = fam_envs }
75
76 {-# INLINE thenSmpl #-}
77 {-# INLINE thenSmpl_ #-}
78 {-# INLINE returnSmpl #-}
79
80 instance Monad SimplM where
81    (>>)   = thenSmpl_
82    (>>=)  = thenSmpl
83    return = returnSmpl
84
85 returnSmpl :: a -> SimplM a
86 returnSmpl e = SM (\_st_env us sc -> (e, us, sc))
87
88 thenSmpl  :: SimplM a -> (a -> SimplM b) -> SimplM b
89 thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
90
91 thenSmpl m k 
92   = SM (\ st_env us0 sc0 ->
93           case (unSM m st_env us0 sc0) of 
94                 (m_result, us1, sc1) -> unSM (k m_result) st_env us1 sc1 )
95
96 thenSmpl_ m k 
97   = SM (\st_env us0 sc0 ->
98          case (unSM m st_env us0 sc0) of 
99                 (_, us1, sc1) -> unSM k st_env us1 sc1)
100
101 -- TODO: this specializing is not allowed
102 -- {-# SPECIALIZE mapM         :: (a -> SimplM b) -> [a] -> SimplM [b] #-}
103 -- {-# SPECIALIZE mapAndUnzipM :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c]) #-}
104 -- {-# SPECIALIZE mapAccumLM   :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c]) #-}
105 \end{code}
106
107
108 %************************************************************************
109 %*                                                                      *
110 \subsection{The unique supply}
111 %*                                                                      *
112 %************************************************************************
113
114 \begin{code}
115 instance MonadUnique SimplM where
116     getUniqueSupplyM
117        = SM (\_st_env us sc -> case splitUniqSupply us of
118                                 (us1, us2) -> (us1, us2, sc))
119
120     getUniqueM
121        = SM (\_st_env us sc -> case splitUniqSupply us of
122                                 (us1, us2) -> (uniqFromSupply us1, us2, sc))
123
124     getUniquesM
125         = SM (\_st_env us sc -> case splitUniqSupply us of
126                                 (us1, us2) -> (uniqsFromSupply us1, us2, sc))
127
128 getDOptsSmpl :: SimplM DynFlags
129 getDOptsSmpl = SM (\st_env us sc -> (st_flags st_env, us, sc))
130
131 getSimplRules :: SimplM RuleBase
132 getSimplRules = SM (\st_env us sc -> (st_rules st_env, us, sc))
133
134 getFamEnvs :: SimplM (FamInstEnv, FamInstEnv)
135 getFamEnvs = SM (\st_env us sc -> (st_fams st_env, us, sc))
136
137 newId :: FastString -> Type -> SimplM Id
138 newId fs ty = do uniq <- getUniqueM
139                  return (mkSysLocal fs uniq ty)
140 \end{code}
141
142
143 %************************************************************************
144 %*                                                                      *
145 \subsection{Counting up what we've done}
146 %*                                                                      *
147 %************************************************************************
148
149 \begin{code}
150 getSimplCount :: SimplM SimplCount
151 getSimplCount = SM (\_st_env us sc -> (sc, us, sc))
152
153 tick :: Tick -> SimplM ()
154 tick t 
155    = SM (\_st_env us sc -> let sc' = doSimplTick t sc 
156                            in sc' `seq` ((), us, sc'))
157
158 freeTick :: Tick -> SimplM ()
159 -- Record a tick, but don't add to the total tick count, which is
160 -- used to decide when nothing further has happened
161 freeTick t 
162    = SM (\_st_env us sc -> let sc' = doFreeSimplTick t sc
163                            in sc' `seq` ((), us, sc'))
164 \end{code}
165
166
167 %************************************************************************
168 %*                                                                      *
169 \subsubsection{Command-line switches}
170 %*                                                                      *
171 %************************************************************************
172
173 \begin{code}
174 type SwitchChecker = SimplifierSwitch -> SwitchResult
175
176 data SwitchResult
177   = SwBool      Bool            -- on/off
178   | SwString    FastString      -- nothing or a String
179   | SwInt       Int             -- nothing or an Int
180
181 allOffSwitchChecker :: SwitchChecker
182 allOffSwitchChecker _ = SwBool False
183
184 isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult
185 isAmongSimpl on_switches                -- Switches mentioned later occur *earlier*
186                                         -- in the list; defaults right at the end.
187   = let
188         tidied_on_switches = foldl rm_dups [] on_switches
189                 -- The fold*l* ensures that we keep the latest switches;
190                 -- ie the ones that occur earliest in the list.
191
192         sw_tbl :: Array Int SwitchResult
193         sw_tbl = (array (0, lAST_SIMPL_SWITCH_TAG) -- bounds...
194                         all_undefined)
195                  // defined_elems
196
197         all_undefined = [ (i, SwBool False) | i <- [0 .. lAST_SIMPL_SWITCH_TAG ] ]
198
199         defined_elems = map mk_assoc_elem tidied_on_switches
200     in
201     -- (avoid some unboxing, bounds checking, and other horrible things:)
202     \ switch -> unsafeAt sw_tbl $ iBox (tagOf_SimplSwitch switch)
203   where
204     mk_assoc_elem k@(MaxSimplifierIterations lvl)
205         = (iBox (tagOf_SimplSwitch k), SwInt lvl)
206     mk_assoc_elem k
207         = (iBox (tagOf_SimplSwitch k), SwBool True) -- I'm here, Mom!
208
209     -- cannot have duplicates if we are going to use the array thing
210     rm_dups switches_so_far switch
211       = if switch `is_elem` switches_so_far
212         then switches_so_far
213         else switch : switches_so_far
214       where
215         _  `is_elem` []     = False
216         sw `is_elem` (s:ss) = (tagOf_SimplSwitch sw) ==# (tagOf_SimplSwitch s)
217                             || sw `is_elem` ss
218 \end{code}
219
220 \begin{code}
221 getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
222 getSimplIntSwitch chkr switch
223   = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
224
225 switchIsOn :: (switch -> SwitchResult) -> switch -> Bool
226
227 switchIsOn lookup_fn switch
228   = case (lookup_fn switch) of
229       SwBool False -> False
230       _            -> True
231
232 intSwitchSet :: (switch -> SwitchResult)
233              -> (Int -> switch)
234              -> Maybe Int
235
236 intSwitchSet lookup_fn switch
237   = case (lookup_fn (switch (panic "intSwitchSet"))) of
238       SwInt int -> Just int
239       _         -> Nothing
240 \end{code}
241
242
243 These things behave just like enumeration types.
244
245 \begin{code}
246 instance Eq SimplifierSwitch where
247     a == b = tagOf_SimplSwitch a ==# tagOf_SimplSwitch b
248
249 instance Ord SimplifierSwitch where
250     a <  b  = tagOf_SimplSwitch a <# tagOf_SimplSwitch b
251     a <= b  = tagOf_SimplSwitch a <=# tagOf_SimplSwitch b
252
253
254 tagOf_SimplSwitch :: SimplifierSwitch -> FastInt
255 tagOf_SimplSwitch (MaxSimplifierIterations _)   = _ILIT(1)
256 tagOf_SimplSwitch NoCaseOfCase                  = _ILIT(2)
257
258 -- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
259
260 lAST_SIMPL_SWITCH_TAG :: Int
261 lAST_SIMPL_SWITCH_TAG = 2
262 \end{code}
263