2 % (c) The AQUA Project, Glasgow University, 1993-1998
4 \section[SimplMonad]{The simplifier Monad}
8 -- The above warning supression flag is a temporary kludge.
9 -- While working on this module you are encouraged to remove it and fix
10 -- any warnings in the module. See
11 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
18 getDOptsSmpl, getRules, getFamEnvs,
21 MonadUnique(..), newId,
26 getSimplCount, zeroSimplCount, pprSimplCount,
27 plusSimplCount, isZeroSimplCount,
30 SwitchChecker, SwitchResult(..), getSimplIntSwitch,
31 isAmongSimpl, intSwitchSet, switchIsOn
34 import Id ( Id, mkSysLocal )
36 import FamInstEnv ( FamInstEnv )
37 import Rules ( RuleBase )
39 import DynFlags ( SimplifierSwitch(..), DynFlags, DynFlag(..), dopt )
40 import StaticFlags ( opt_PprStyle_Debug, opt_HistorySize )
41 import Unique ( Unique )
42 import Maybes ( expectJust )
43 import FiniteMap ( FiniteMap, emptyFM, isEmptyFM, lookupFM, addToFM, plusFM_C, fmToList )
49 import Data.Array.Base (unsafeAt)
52 %************************************************************************
54 \subsection{Monad plumbing}
56 %************************************************************************
58 For the simplifier monad, we want to {\em thread} a unique supply and a counter.
59 (Command-line switches move around through the explicitly-passed SimplEnv.)
63 = SM { unSM :: SimplTopEnv -- Envt that does not change much
64 -> UniqSupply -- We thread the unique supply because
65 -- constantly splitting it is rather expensive
67 -> (result, UniqSupply, SimplCount)}
69 data SimplTopEnv = STE { st_flags :: DynFlags
70 , st_rules :: RuleBase
71 , st_fams :: (FamInstEnv, FamInstEnv) }
75 initSmpl :: DynFlags -> RuleBase -> (FamInstEnv, FamInstEnv)
76 -> UniqSupply -- No init count; set to 0
80 initSmpl dflags rules fam_envs us m
81 = case unSM m env us (zeroSimplCount dflags) of
82 (result, _, count) -> (result, count)
84 env = STE { st_flags = dflags, st_rules = rules, st_fams = fam_envs }
86 {-# INLINE thenSmpl #-}
87 {-# INLINE thenSmpl_ #-}
88 {-# INLINE returnSmpl #-}
90 instance Monad SimplM where
95 returnSmpl :: a -> SimplM a
96 returnSmpl e = SM (\ st_env us sc -> (e, us, sc))
98 thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b
99 thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
102 = SM (\ st_env us0 sc0 ->
103 case (unSM m st_env us0 sc0) of
104 (m_result, us1, sc1) -> unSM (k m_result) st_env us1 sc1 )
107 = SM (\st_env us0 sc0 ->
108 case (unSM m st_env us0 sc0) of
109 (_, us1, sc1) -> unSM k st_env us1 sc1)
111 -- TODO: this specializing is not allowed
112 {-# -- SPECIALIZE mapM :: (a -> SimplM b) -> [a] -> SimplM [b] #-}
113 {-# -- SPECIALIZE mapAndUnzipM :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c]) #-}
114 {-# -- SPECIALIZE mapAccumLM :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c]) #-}
118 %************************************************************************
120 \subsection{The unique supply}
122 %************************************************************************
125 instance MonadUnique SimplM where
127 = SM (\st_env us sc -> case splitUniqSupply us of
128 (us1, us2) -> (us1, us2, sc))
131 = SM (\st_env us sc -> case splitUniqSupply us of
132 (us1, us2) -> (uniqFromSupply us1, us2, sc))
135 = SM (\st_env us sc -> case splitUniqSupply us of
136 (us1, us2) -> (uniqsFromSupply us1, us2, sc))
138 getDOptsSmpl :: SimplM DynFlags
139 getDOptsSmpl = SM (\st_env us sc -> (st_flags st_env, us, sc))
141 getRules :: SimplM RuleBase
142 getRules = SM (\st_env us sc -> (st_rules st_env, us, sc))
144 getFamEnvs :: SimplM (FamInstEnv, FamInstEnv)
145 getFamEnvs = SM (\st_env us sc -> (st_fams st_env, us, sc))
147 newId :: FastString -> Type -> SimplM Id
148 newId fs ty = do uniq <- getUniqueM
149 return (mkSysLocal fs uniq ty)
153 %************************************************************************
155 \subsection{Counting up what we've done}
157 %************************************************************************
160 getSimplCount :: SimplM SimplCount
161 getSimplCount = SM (\st_env us sc -> (sc, us, sc))
163 tick :: Tick -> SimplM ()
165 = SM (\st_env us sc -> let sc' = doTick t sc
166 in sc' `seq` ((), us, sc'))
168 freeTick :: Tick -> SimplM ()
169 -- Record a tick, but don't add to the total tick count, which is
170 -- used to decide when nothing further has happened
172 = SM (\st_env us sc -> let sc' = doFreeTick t sc
173 in sc' `seq` ((), us, sc'))
177 verboseSimplStats = opt_PprStyle_Debug -- For now, anyway
179 zeroSimplCount :: DynFlags -> SimplCount
180 isZeroSimplCount :: SimplCount -> Bool
181 pprSimplCount :: SimplCount -> SDoc
182 doTick, doFreeTick :: Tick -> SimplCount -> SimplCount
183 plusSimplCount :: SimplCount -> SimplCount -> SimplCount
187 data SimplCount = VerySimplZero -- These two are used when
188 | VerySimplNonZero -- we are only interested in
192 ticks :: !Int, -- Total ticks
193 details :: !TickCounts, -- How many of each type
195 log1 :: [Tick], -- Last N events; <= opt_HistorySize
196 log2 :: [Tick] -- Last opt_HistorySize events before that
199 type TickCounts = FiniteMap Tick Int
201 zeroSimplCount dflags
202 -- This is where we decide whether to do
203 -- the VerySimpl version or the full-stats version
204 | dopt Opt_D_dump_simpl_stats dflags
205 = SimplCount {ticks = 0, details = emptyFM,
206 n_log = 0, log1 = [], log2 = []}
210 isZeroSimplCount VerySimplZero = True
211 isZeroSimplCount (SimplCount { ticks = 0 }) = True
212 isZeroSimplCount other = False
214 doFreeTick tick sc@SimplCount { details = dts }
215 = dts' `seqFM` sc { details = dts' }
217 dts' = dts `addTick` tick
218 doFreeTick tick sc = sc
220 -- Gross hack to persuade GHC 3.03 to do this important seq
221 seqFM fm x | isEmptyFM fm = x
224 doTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1, log2 = l2 }
225 | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
226 | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 }
228 sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
230 doTick tick sc = VerySimplNonZero -- The very simple case
233 -- Don't use plusFM_C because that's lazy, and we want to
234 -- be pretty strict here!
235 addTick :: TickCounts -> Tick -> TickCounts
236 addTick fm tick = case lookupFM fm tick of
237 Nothing -> addToFM fm tick 1
238 Just n -> n1 `seq` addToFM fm tick n1
243 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
244 sc2@(SimplCount { ticks = tks2, details = dts2 })
245 = log_base { ticks = tks1 + tks2, details = plusFM_C (+) dts1 dts2 }
247 -- A hackish way of getting recent log info
248 log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2
249 | null (log2 sc2) = sc2 { log2 = log1 sc1 }
252 plusSimplCount VerySimplZero VerySimplZero = VerySimplZero
253 plusSimplCount sc1 sc2 = VerySimplNonZero
255 pprSimplCount VerySimplZero = ptext (sLit "Total ticks: ZERO!")
256 pprSimplCount VerySimplNonZero = ptext (sLit "Total ticks: NON-ZERO!")
257 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
258 = vcat [ptext (sLit "Total ticks: ") <+> int tks,
260 pprTickCounts (fmToList dts),
261 if verboseSimplStats then
263 ptext (sLit "Log (most recent first)"),
264 nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
268 pprTickCounts :: [(Tick,Int)] -> SDoc
269 pprTickCounts [] = empty
270 pprTickCounts ((tick1,n1):ticks)
271 = vcat [int tot_n <+> text (tickString tick1),
272 pprTCDetails real_these,
276 tick1_tag = tickToTag tick1
277 (these, others) = span same_tick ticks
278 real_these = (tick1,n1):these
279 same_tick (tick2,_) = tickToTag tick2 == tick1_tag
280 tot_n = sum [n | (_,n) <- real_these]
282 pprTCDetails ticks@((tick,_):_)
283 | verboseSimplStats || isRuleFired tick
284 = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
289 %************************************************************************
293 %************************************************************************
297 = PreInlineUnconditionally Id
298 | PostInlineUnconditionally Id
301 | RuleFired FastString -- Rule name
304 | EtaExpansion Id -- LHS binder
305 | EtaReduction Id -- Binder on outer lambda
306 | BetaReduction Id -- Lambda binder
309 | CaseOfCase Id -- Bndr on *inner* case
310 | KnownBranch Id -- Case binder
311 | CaseMerge Id -- Binder on outer case
312 | AltMerge Id -- Case binder
313 | CaseElim Id -- Case binder
314 | CaseIdentity Id -- Case binder
315 | FillInCaseDefault Id -- Case binder
318 | SimplifierDone -- Ticked at each iteration of the simplifier
320 isRuleFired (RuleFired _) = True
321 isRuleFired other = False
323 instance Outputable Tick where
324 ppr tick = text (tickString tick) <+> pprTickCts tick
326 instance Eq Tick where
327 a == b = case a `cmpTick` b of { EQ -> True; other -> False }
329 instance Ord Tick where
332 tickToTag :: Tick -> Int
333 tickToTag (PreInlineUnconditionally _) = 0
334 tickToTag (PostInlineUnconditionally _) = 1
335 tickToTag (UnfoldingDone _) = 2
336 tickToTag (RuleFired _) = 3
337 tickToTag LetFloatFromLet = 4
338 tickToTag (EtaExpansion _) = 5
339 tickToTag (EtaReduction _) = 6
340 tickToTag (BetaReduction _) = 7
341 tickToTag (CaseOfCase _) = 8
342 tickToTag (KnownBranch _) = 9
343 tickToTag (CaseMerge _) = 10
344 tickToTag (CaseElim _) = 11
345 tickToTag (CaseIdentity _) = 12
346 tickToTag (FillInCaseDefault _) = 13
347 tickToTag BottomFound = 14
348 tickToTag SimplifierDone = 16
349 tickToTag (AltMerge _) = 17
351 tickString :: Tick -> String
352 tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
353 tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
354 tickString (UnfoldingDone _) = "UnfoldingDone"
355 tickString (RuleFired _) = "RuleFired"
356 tickString LetFloatFromLet = "LetFloatFromLet"
357 tickString (EtaExpansion _) = "EtaExpansion"
358 tickString (EtaReduction _) = "EtaReduction"
359 tickString (BetaReduction _) = "BetaReduction"
360 tickString (CaseOfCase _) = "CaseOfCase"
361 tickString (KnownBranch _) = "KnownBranch"
362 tickString (CaseMerge _) = "CaseMerge"
363 tickString (AltMerge _) = "AltMerge"
364 tickString (CaseElim _) = "CaseElim"
365 tickString (CaseIdentity _) = "CaseIdentity"
366 tickString (FillInCaseDefault _) = "FillInCaseDefault"
367 tickString BottomFound = "BottomFound"
368 tickString SimplifierDone = "SimplifierDone"
370 pprTickCts :: Tick -> SDoc
371 pprTickCts (PreInlineUnconditionally v) = ppr v
372 pprTickCts (PostInlineUnconditionally v)= ppr v
373 pprTickCts (UnfoldingDone v) = ppr v
374 pprTickCts (RuleFired v) = ppr v
375 pprTickCts LetFloatFromLet = empty
376 pprTickCts (EtaExpansion v) = ppr v
377 pprTickCts (EtaReduction v) = ppr v
378 pprTickCts (BetaReduction v) = ppr v
379 pprTickCts (CaseOfCase v) = ppr v
380 pprTickCts (KnownBranch v) = ppr v
381 pprTickCts (CaseMerge v) = ppr v
382 pprTickCts (AltMerge v) = ppr v
383 pprTickCts (CaseElim v) = ppr v
384 pprTickCts (CaseIdentity v) = ppr v
385 pprTickCts (FillInCaseDefault v) = ppr v
386 pprTickCts other = empty
388 cmpTick :: Tick -> Tick -> Ordering
389 cmpTick a b = case (tickToTag a `compare` tickToTag b) of
391 EQ | isRuleFired a || verboseSimplStats -> cmpEqTick a b
394 -- Always distinguish RuleFired, so that the stats
395 -- can report them even in non-verbose mode
397 cmpEqTick :: Tick -> Tick -> Ordering
398 cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b
399 cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b
400 cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b
401 cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b
402 cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b
403 cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b
404 cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b
405 cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b
406 cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b
407 cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b
408 cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b
409 cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b
410 cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b
411 cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b
412 cmpEqTick other1 other2 = EQ
416 %************************************************************************
418 \subsubsection{Command-line switches}
420 %************************************************************************
423 type SwitchChecker = SimplifierSwitch -> SwitchResult
426 = SwBool Bool -- on/off
427 | SwString FastString -- nothing or a String
428 | SwInt Int -- nothing or an Int
430 isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult
431 isAmongSimpl on_switches -- Switches mentioned later occur *earlier*
432 -- in the list; defaults right at the end.
434 tidied_on_switches = foldl rm_dups [] on_switches
435 -- The fold*l* ensures that we keep the latest switches;
436 -- ie the ones that occur earliest in the list.
438 sw_tbl :: Array Int SwitchResult
439 sw_tbl = (array (0, lAST_SIMPL_SWITCH_TAG) -- bounds...
443 all_undefined = [ (i, SwBool False) | i <- [0 .. lAST_SIMPL_SWITCH_TAG ] ]
445 defined_elems = map mk_assoc_elem tidied_on_switches
447 -- (avoid some unboxing, bounds checking, and other horrible things:)
448 \ switch -> unsafeAt sw_tbl $ iBox (tagOf_SimplSwitch switch)
450 mk_assoc_elem k@(MaxSimplifierIterations lvl)
451 = (iBox (tagOf_SimplSwitch k), SwInt lvl)
453 = (iBox (tagOf_SimplSwitch k), SwBool True) -- I'm here, Mom!
455 -- cannot have duplicates if we are going to use the array thing
456 rm_dups switches_so_far switch
457 = if switch `is_elem` switches_so_far
459 else switch : switches_so_far
461 sw `is_elem` [] = False
462 sw `is_elem` (s:ss) = (tagOf_SimplSwitch sw) ==# (tagOf_SimplSwitch s)
467 getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
468 getSimplIntSwitch chkr switch
469 = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
471 switchIsOn :: (switch -> SwitchResult) -> switch -> Bool
473 switchIsOn lookup_fn switch
474 = case (lookup_fn switch) of
475 SwBool False -> False
478 intSwitchSet :: (switch -> SwitchResult)
482 intSwitchSet lookup_fn switch
483 = case (lookup_fn (switch (panic "intSwitchSet"))) of
484 SwInt int -> Just int
489 These things behave just like enumeration types.
492 instance Eq SimplifierSwitch where
493 a == b = tagOf_SimplSwitch a ==# tagOf_SimplSwitch b
495 instance Ord SimplifierSwitch where
496 a < b = tagOf_SimplSwitch a <# tagOf_SimplSwitch b
497 a <= b = tagOf_SimplSwitch a <=# tagOf_SimplSwitch b
500 tagOf_SimplSwitch (MaxSimplifierIterations _) = _ILIT(1)
501 tagOf_SimplSwitch NoCaseOfCase = _ILIT(2)
503 -- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
505 lAST_SIMPL_SWITCH_TAG = 2