2 % (c) The AQUA Project, Glasgow University, 1993-1998
4 \section[SimplMonad]{The simplifier Monad}
11 getDOptsSmpl, getSimplRules, getFamEnvs,
14 MonadUnique(..), newId,
17 SimplCount, tick, freeTick,
18 getSimplCount, zeroSimplCount, pprSimplCount,
19 plusSimplCount, isZeroSimplCount,
22 SwitchChecker, SwitchResult(..), getSimplIntSwitch,
23 isAmongSimpl, intSwitchSet, switchIsOn, allOffSwitchChecker
26 import Id ( Id, mkSysLocal )
28 import FamInstEnv ( FamInstEnv )
29 import Rules ( RuleBase )
31 import DynFlags ( DynFlags )
32 import Maybes ( expectJust )
39 import Data.Array.Base (unsafeAt)
42 %************************************************************************
44 \subsection{Monad plumbing}
46 %************************************************************************
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.)
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
57 -> (result, UniqSupply, SimplCount)}
59 data SimplTopEnv = STE { st_flags :: DynFlags
60 , st_rules :: RuleBase
61 , st_fams :: (FamInstEnv, FamInstEnv) }
65 initSmpl :: DynFlags -> RuleBase -> (FamInstEnv, FamInstEnv)
66 -> UniqSupply -- No init count; set to 0
70 initSmpl dflags rules fam_envs us m
71 = case unSM m env us (zeroSimplCount dflags) of
72 (result, _, count) -> (result, count)
74 env = STE { st_flags = dflags, st_rules = rules, st_fams = fam_envs }
76 {-# INLINE thenSmpl #-}
77 {-# INLINE thenSmpl_ #-}
78 {-# INLINE returnSmpl #-}
80 instance Monad SimplM where
85 returnSmpl :: a -> SimplM a
86 returnSmpl e = SM (\_st_env us sc -> (e, us, sc))
88 thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b
89 thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
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 )
97 = SM (\st_env us0 sc0 ->
98 case (unSM m st_env us0 sc0) of
99 (_, us1, sc1) -> unSM k st_env us1 sc1)
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]) #-}
108 %************************************************************************
110 \subsection{The unique supply}
112 %************************************************************************
115 instance MonadUnique SimplM where
117 = SM (\_st_env us sc -> case splitUniqSupply us of
118 (us1, us2) -> (us1, us2, sc))
121 = SM (\_st_env us sc -> case splitUniqSupply us of
122 (us1, us2) -> (uniqFromSupply us1, us2, sc))
125 = SM (\_st_env us sc -> case splitUniqSupply us of
126 (us1, us2) -> (uniqsFromSupply us1, us2, sc))
128 getDOptsSmpl :: SimplM DynFlags
129 getDOptsSmpl = SM (\st_env us sc -> (st_flags st_env, us, sc))
131 getSimplRules :: SimplM RuleBase
132 getSimplRules = SM (\st_env us sc -> (st_rules st_env, us, sc))
134 getFamEnvs :: SimplM (FamInstEnv, FamInstEnv)
135 getFamEnvs = SM (\st_env us sc -> (st_fams st_env, us, sc))
137 newId :: FastString -> Type -> SimplM Id
138 newId fs ty = do uniq <- getUniqueM
139 return (mkSysLocal fs uniq ty)
143 %************************************************************************
145 \subsection{Counting up what we've done}
147 %************************************************************************
150 getSimplCount :: SimplM SimplCount
151 getSimplCount = SM (\_st_env us sc -> (sc, us, sc))
153 tick :: Tick -> SimplM ()
155 = SM (\_st_env us sc -> let sc' = doSimplTick t sc
156 in sc' `seq` ((), us, sc'))
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
162 = SM (\_st_env us sc -> let sc' = doFreeSimplTick t sc
163 in sc' `seq` ((), us, sc'))
167 %************************************************************************
169 \subsubsection{Command-line switches}
171 %************************************************************************
174 type SwitchChecker = SimplifierSwitch -> SwitchResult
177 = SwBool Bool -- on/off
178 | SwString FastString -- nothing or a String
179 | SwInt Int -- nothing or an Int
181 allOffSwitchChecker :: SwitchChecker
182 allOffSwitchChecker _ = SwBool False
184 isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult
185 isAmongSimpl on_switches -- Switches mentioned later occur *earlier*
186 -- in the list; defaults right at the end.
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.
192 sw_tbl :: Array Int SwitchResult
193 sw_tbl = (array (0, lAST_SIMPL_SWITCH_TAG) -- bounds...
197 all_undefined = [ (i, SwBool False) | i <- [0 .. lAST_SIMPL_SWITCH_TAG ] ]
199 defined_elems = map mk_assoc_elem tidied_on_switches
201 -- (avoid some unboxing, bounds checking, and other horrible things:)
202 \ switch -> unsafeAt sw_tbl $ iBox (tagOf_SimplSwitch switch)
205 = (iBox (tagOf_SimplSwitch k), SwBool True) -- I'm here, Mom!
207 -- cannot have duplicates if we are going to use the array thing
208 rm_dups switches_so_far switch
209 = if switch `is_elem` switches_so_far
211 else switch : switches_so_far
213 _ `is_elem` [] = False
214 sw `is_elem` (s:ss) = (tagOf_SimplSwitch sw) ==# (tagOf_SimplSwitch s)
219 getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
220 getSimplIntSwitch chkr switch
221 = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
223 switchIsOn :: (switch -> SwitchResult) -> switch -> Bool
225 switchIsOn lookup_fn switch
226 = case (lookup_fn switch) of
227 SwBool False -> False
230 intSwitchSet :: (switch -> SwitchResult)
234 intSwitchSet lookup_fn switch
235 = case (lookup_fn (switch (panic "intSwitchSet"))) of
236 SwInt int -> Just int
241 These things behave just like enumeration types.
244 instance Eq SimplifierSwitch where
245 a == b = tagOf_SimplSwitch a ==# tagOf_SimplSwitch b
247 instance Ord SimplifierSwitch where
248 a < b = tagOf_SimplSwitch a <# tagOf_SimplSwitch b
249 a <= b = tagOf_SimplSwitch a <=# tagOf_SimplSwitch b
252 tagOf_SimplSwitch :: SimplifierSwitch -> FastInt
253 tagOf_SimplSwitch NoCaseOfCase = _ILIT(1)
255 -- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
257 lAST_SIMPL_SWITCH_TAG :: Int
258 lAST_SIMPL_SWITCH_TAG = 2