2 % (c) The AQUA Project, Glasgow University, 1993-1998
4 \section[SimplMonad]{The simplifier Monad}
11 getDOptsSmpl, getSimplRules, getFamEnvs,
14 MonadUnique(..), newId,
19 getSimplCount, zeroSimplCount, pprSimplCount,
20 plusSimplCount, isZeroSimplCount,
23 SwitchChecker, SwitchResult(..), getSimplIntSwitch,
24 isAmongSimpl, intSwitchSet, switchIsOn, allOffSwitchChecker
27 import Id ( Id, mkSysLocal )
29 import FamInstEnv ( FamInstEnv )
30 import Rules ( RuleBase )
32 import DynFlags ( SimplifierSwitch(..), DynFlags, DynFlag(..), dopt )
33 import StaticFlags ( opt_PprStyle_Debug, opt_HistorySize )
34 import Maybes ( expectJust )
35 import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM, plusFM_C, fmToList )
41 import Data.Array.Base (unsafeAt)
44 %************************************************************************
46 \subsection{Monad plumbing}
48 %************************************************************************
50 For the simplifier monad, we want to {\em thread} a unique supply and a counter.
51 (Command-line switches move around through the explicitly-passed SimplEnv.)
55 = SM { unSM :: SimplTopEnv -- Envt that does not change much
56 -> UniqSupply -- We thread the unique supply because
57 -- constantly splitting it is rather expensive
59 -> (result, UniqSupply, SimplCount)}
61 data SimplTopEnv = STE { st_flags :: DynFlags
62 , st_rules :: RuleBase
63 , st_fams :: (FamInstEnv, FamInstEnv) }
67 initSmpl :: DynFlags -> RuleBase -> (FamInstEnv, FamInstEnv)
68 -> UniqSupply -- No init count; set to 0
72 initSmpl dflags rules fam_envs us m
73 = case unSM m env us (zeroSimplCount dflags) of
74 (result, _, count) -> (result, count)
76 env = STE { st_flags = dflags, st_rules = rules, st_fams = fam_envs }
78 {-# INLINE thenSmpl #-}
79 {-# INLINE thenSmpl_ #-}
80 {-# INLINE returnSmpl #-}
82 instance Monad SimplM where
87 returnSmpl :: a -> SimplM a
88 returnSmpl e = SM (\_st_env us sc -> (e, us, sc))
90 thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b
91 thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
94 = SM (\ st_env us0 sc0 ->
95 case (unSM m st_env us0 sc0) of
96 (m_result, us1, sc1) -> unSM (k m_result) st_env us1 sc1 )
99 = SM (\st_env us0 sc0 ->
100 case (unSM m st_env us0 sc0) of
101 (_, us1, sc1) -> unSM k st_env us1 sc1)
103 -- TODO: this specializing is not allowed
104 -- {-# SPECIALIZE mapM :: (a -> SimplM b) -> [a] -> SimplM [b] #-}
105 -- {-# SPECIALIZE mapAndUnzipM :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c]) #-}
106 -- {-# SPECIALIZE mapAccumLM :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c]) #-}
110 %************************************************************************
112 \subsection{The unique supply}
114 %************************************************************************
117 instance MonadUnique SimplM where
119 = SM (\_st_env us sc -> case splitUniqSupply us of
120 (us1, us2) -> (us1, us2, sc))
123 = SM (\_st_env us sc -> case splitUniqSupply us of
124 (us1, us2) -> (uniqFromSupply us1, us2, sc))
127 = SM (\_st_env us sc -> case splitUniqSupply us of
128 (us1, us2) -> (uniqsFromSupply us1, us2, sc))
130 getDOptsSmpl :: SimplM DynFlags
131 getDOptsSmpl = SM (\st_env us sc -> (st_flags st_env, us, sc))
133 getSimplRules :: SimplM RuleBase
134 getSimplRules = SM (\st_env us sc -> (st_rules st_env, us, sc))
136 getFamEnvs :: SimplM (FamInstEnv, FamInstEnv)
137 getFamEnvs = SM (\st_env us sc -> (st_fams st_env, us, sc))
139 newId :: FastString -> Type -> SimplM Id
140 newId fs ty = do uniq <- getUniqueM
141 return (mkSysLocal fs uniq ty)
145 %************************************************************************
147 \subsection{Counting up what we've done}
149 %************************************************************************
152 getSimplCount :: SimplM SimplCount
153 getSimplCount = SM (\_st_env us sc -> (sc, us, sc))
155 tick :: Tick -> SimplM ()
157 = SM (\_st_env us sc -> let sc' = doTick t sc
158 in sc' `seq` ((), us, sc'))
160 freeTick :: Tick -> SimplM ()
161 -- Record a tick, but don't add to the total tick count, which is
162 -- used to decide when nothing further has happened
164 = SM (\_st_env us sc -> let sc' = doFreeTick t sc
165 in sc' `seq` ((), us, sc'))
169 verboseSimplStats :: Bool
170 verboseSimplStats = opt_PprStyle_Debug -- For now, anyway
172 zeroSimplCount :: DynFlags -> SimplCount
173 isZeroSimplCount :: SimplCount -> Bool
174 pprSimplCount :: SimplCount -> SDoc
175 doTick, doFreeTick :: Tick -> SimplCount -> SimplCount
176 plusSimplCount :: SimplCount -> SimplCount -> SimplCount
181 = VerySimplZero -- These two are used when
182 | VerySimplNonZero -- we are only interested in
186 ticks :: !Int, -- Total ticks
187 details :: !TickCounts, -- How many of each type
190 log1 :: [Tick], -- Last N events; <= opt_HistorySize,
192 log2 :: [Tick] -- Last opt_HistorySize events before that
193 -- Having log1, log2 lets us accumulate the
194 -- recent history reasonably efficiently
197 type TickCounts = FiniteMap Tick Int
199 zeroSimplCount dflags
200 -- This is where we decide whether to do
201 -- the VerySimpl version or the full-stats version
202 | dopt Opt_D_dump_simpl_stats dflags
203 = SimplCount {ticks = 0, details = emptyFM,
204 n_log = 0, log1 = [], log2 = []}
208 isZeroSimplCount VerySimplZero = True
209 isZeroSimplCount (SimplCount { ticks = 0 }) = True
210 isZeroSimplCount _ = False
212 doFreeTick tick sc@SimplCount { details = dts }
213 = sc { details = dts `addTick` tick }
216 doTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 }
217 | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
218 | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 }
220 sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
222 doTick _ _ = VerySimplNonZero -- The very simple case
225 -- Don't use plusFM_C because that's lazy, and we want to
226 -- be pretty strict here!
227 addTick :: TickCounts -> Tick -> TickCounts
228 addTick fm tick = case lookupFM fm tick of
229 Nothing -> addToFM fm tick 1
230 Just n -> n1 `seq` addToFM fm tick n1
235 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
236 sc2@(SimplCount { ticks = tks2, details = dts2 })
237 = log_base { ticks = tks1 + tks2, details = plusFM_C (+) dts1 dts2 }
239 -- A hackish way of getting recent log info
240 log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2
241 | null (log2 sc2) = sc2 { log2 = log1 sc1 }
244 plusSimplCount VerySimplZero VerySimplZero = VerySimplZero
245 plusSimplCount _ _ = VerySimplNonZero
247 pprSimplCount VerySimplZero = ptext (sLit "Total ticks: ZERO!")
248 pprSimplCount VerySimplNonZero = ptext (sLit "Total ticks: NON-ZERO!")
249 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
250 = vcat [ptext (sLit "Total ticks: ") <+> int tks,
252 pprTickCounts (fmToList dts),
253 if verboseSimplStats then
255 ptext (sLit "Log (most recent first)"),
256 nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
260 pprTickCounts :: [(Tick,Int)] -> SDoc
261 pprTickCounts [] = empty
262 pprTickCounts ((tick1,n1):ticks)
263 = vcat [int tot_n <+> text (tickString tick1),
264 pprTCDetails real_these,
268 tick1_tag = tickToTag tick1
269 (these, others) = span same_tick ticks
270 real_these = (tick1,n1):these
271 same_tick (tick2,_) = tickToTag tick2 == tick1_tag
272 tot_n = sum [n | (_,n) <- real_these]
274 pprTCDetails :: [(Tick, Int)] -> SDoc
276 = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
279 %************************************************************************
283 %************************************************************************
287 = PreInlineUnconditionally Id
288 | PostInlineUnconditionally Id
291 | RuleFired FastString -- Rule name
294 | EtaExpansion Id -- LHS binder
295 | EtaReduction Id -- Binder on outer lambda
296 | BetaReduction Id -- Lambda binder
299 | CaseOfCase Id -- Bndr on *inner* case
300 | KnownBranch Id -- Case binder
301 | CaseMerge Id -- Binder on outer case
302 | AltMerge Id -- Case binder
303 | CaseElim Id -- Case binder
304 | CaseIdentity Id -- Case binder
305 | FillInCaseDefault Id -- Case binder
308 | SimplifierDone -- Ticked at each iteration of the simplifier
310 instance Outputable Tick where
311 ppr tick = text (tickString tick) <+> pprTickCts tick
313 instance Eq Tick where
314 a == b = case a `cmpTick` b of
318 instance Ord Tick where
321 tickToTag :: Tick -> Int
322 tickToTag (PreInlineUnconditionally _) = 0
323 tickToTag (PostInlineUnconditionally _) = 1
324 tickToTag (UnfoldingDone _) = 2
325 tickToTag (RuleFired _) = 3
326 tickToTag LetFloatFromLet = 4
327 tickToTag (EtaExpansion _) = 5
328 tickToTag (EtaReduction _) = 6
329 tickToTag (BetaReduction _) = 7
330 tickToTag (CaseOfCase _) = 8
331 tickToTag (KnownBranch _) = 9
332 tickToTag (CaseMerge _) = 10
333 tickToTag (CaseElim _) = 11
334 tickToTag (CaseIdentity _) = 12
335 tickToTag (FillInCaseDefault _) = 13
336 tickToTag BottomFound = 14
337 tickToTag SimplifierDone = 16
338 tickToTag (AltMerge _) = 17
340 tickString :: Tick -> String
341 tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
342 tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
343 tickString (UnfoldingDone _) = "UnfoldingDone"
344 tickString (RuleFired _) = "RuleFired"
345 tickString LetFloatFromLet = "LetFloatFromLet"
346 tickString (EtaExpansion _) = "EtaExpansion"
347 tickString (EtaReduction _) = "EtaReduction"
348 tickString (BetaReduction _) = "BetaReduction"
349 tickString (CaseOfCase _) = "CaseOfCase"
350 tickString (KnownBranch _) = "KnownBranch"
351 tickString (CaseMerge _) = "CaseMerge"
352 tickString (AltMerge _) = "AltMerge"
353 tickString (CaseElim _) = "CaseElim"
354 tickString (CaseIdentity _) = "CaseIdentity"
355 tickString (FillInCaseDefault _) = "FillInCaseDefault"
356 tickString BottomFound = "BottomFound"
357 tickString SimplifierDone = "SimplifierDone"
359 pprTickCts :: Tick -> SDoc
360 pprTickCts (PreInlineUnconditionally v) = ppr v
361 pprTickCts (PostInlineUnconditionally v)= ppr v
362 pprTickCts (UnfoldingDone v) = ppr v
363 pprTickCts (RuleFired v) = ppr v
364 pprTickCts LetFloatFromLet = empty
365 pprTickCts (EtaExpansion v) = ppr v
366 pprTickCts (EtaReduction v) = ppr v
367 pprTickCts (BetaReduction v) = ppr v
368 pprTickCts (CaseOfCase v) = ppr v
369 pprTickCts (KnownBranch v) = ppr v
370 pprTickCts (CaseMerge v) = ppr v
371 pprTickCts (AltMerge v) = ppr v
372 pprTickCts (CaseElim v) = ppr v
373 pprTickCts (CaseIdentity v) = ppr v
374 pprTickCts (FillInCaseDefault v) = ppr v
377 cmpTick :: Tick -> Tick -> Ordering
378 cmpTick a b = case (tickToTag a `compare` tickToTag b) of
383 cmpEqTick :: Tick -> Tick -> Ordering
384 cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b
385 cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b
386 cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b
387 cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b
388 cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b
389 cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b
390 cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b
391 cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b
392 cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b
393 cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b
394 cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b
395 cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b
396 cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b
397 cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b
402 %************************************************************************
404 \subsubsection{Command-line switches}
406 %************************************************************************
409 type SwitchChecker = SimplifierSwitch -> SwitchResult
412 = SwBool Bool -- on/off
413 | SwString FastString -- nothing or a String
414 | SwInt Int -- nothing or an Int
416 allOffSwitchChecker :: SwitchChecker
417 allOffSwitchChecker _ = SwBool False
419 isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult
420 isAmongSimpl on_switches -- Switches mentioned later occur *earlier*
421 -- in the list; defaults right at the end.
423 tidied_on_switches = foldl rm_dups [] on_switches
424 -- The fold*l* ensures that we keep the latest switches;
425 -- ie the ones that occur earliest in the list.
427 sw_tbl :: Array Int SwitchResult
428 sw_tbl = (array (0, lAST_SIMPL_SWITCH_TAG) -- bounds...
432 all_undefined = [ (i, SwBool False) | i <- [0 .. lAST_SIMPL_SWITCH_TAG ] ]
434 defined_elems = map mk_assoc_elem tidied_on_switches
436 -- (avoid some unboxing, bounds checking, and other horrible things:)
437 \ switch -> unsafeAt sw_tbl $ iBox (tagOf_SimplSwitch switch)
439 mk_assoc_elem k@(MaxSimplifierIterations lvl)
440 = (iBox (tagOf_SimplSwitch k), SwInt lvl)
442 = (iBox (tagOf_SimplSwitch k), SwBool True) -- I'm here, Mom!
444 -- cannot have duplicates if we are going to use the array thing
445 rm_dups switches_so_far switch
446 = if switch `is_elem` switches_so_far
448 else switch : switches_so_far
450 _ `is_elem` [] = False
451 sw `is_elem` (s:ss) = (tagOf_SimplSwitch sw) ==# (tagOf_SimplSwitch s)
456 getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
457 getSimplIntSwitch chkr switch
458 = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
460 switchIsOn :: (switch -> SwitchResult) -> switch -> Bool
462 switchIsOn lookup_fn switch
463 = case (lookup_fn switch) of
464 SwBool False -> False
467 intSwitchSet :: (switch -> SwitchResult)
471 intSwitchSet lookup_fn switch
472 = case (lookup_fn (switch (panic "intSwitchSet"))) of
473 SwInt int -> Just int
478 These things behave just like enumeration types.
481 instance Eq SimplifierSwitch where
482 a == b = tagOf_SimplSwitch a ==# tagOf_SimplSwitch b
484 instance Ord SimplifierSwitch where
485 a < b = tagOf_SimplSwitch a <# tagOf_SimplSwitch b
486 a <= b = tagOf_SimplSwitch a <=# tagOf_SimplSwitch b
489 tagOf_SimplSwitch :: SimplifierSwitch -> FastInt
490 tagOf_SimplSwitch (MaxSimplifierIterations _) = _ILIT(1)
491 tagOf_SimplSwitch NoCaseOfCase = _ILIT(2)
493 -- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
495 lAST_SIMPL_SWITCH_TAG :: Int
496 lAST_SIMPL_SWITCH_TAG = 2