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
17 initSmpl, returnSmpl, thenSmpl, thenSmpl_,
18 mapSmpl, mapAndUnzipSmpl, mapAccumLSmpl,
19 getDOptsSmpl, getRules, getFamEnvs,
22 getUniqueSmpl, getUniquesSmpl, getUniqSupplySmpl, newId,
27 getSimplCount, zeroSimplCount, pprSimplCount,
28 plusSimplCount, isZeroSimplCount,
31 SwitchChecker, SwitchResult(..), getSimplIntSwitch,
32 isAmongSimpl, intSwitchSet, switchIsOn
35 #include "HsVersions.h"
37 import Id ( Id, mkSysLocal )
39 import FamInstEnv ( FamInstEnv )
40 import Rules ( RuleBase )
41 import UniqSupply ( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
44 import DynFlags ( SimplifierSwitch(..), DynFlags, DynFlag(..), dopt )
45 import StaticFlags ( opt_PprStyle_Debug, opt_HistorySize )
46 import Unique ( Unique )
47 import Maybes ( expectJust )
48 import FiniteMap ( FiniteMap, emptyFM, isEmptyFM, lookupFM, addToFM, plusFM_C, fmToList )
49 import FastString ( FastString )
53 import GHC.Exts ( indexArray# )
56 import Data.Array.Base (unsafeAt)
58 infixr 0 `thenSmpl`, `thenSmpl_`
61 %************************************************************************
63 \subsection{Monad plumbing}
65 %************************************************************************
67 For the simplifier monad, we want to {\em thread} a unique supply and a counter.
68 (Command-line switches move around through the explicitly-passed SimplEnv.)
72 = SM { unSM :: SimplTopEnv -- Envt that does not change much
73 -> UniqSupply -- We thread the unique supply because
74 -- constantly splitting it is rather expensive
76 -> (result, UniqSupply, SimplCount)}
78 data SimplTopEnv = STE { st_flags :: DynFlags
79 , st_rules :: RuleBase
80 , st_fams :: (FamInstEnv, FamInstEnv) }
84 initSmpl :: DynFlags -> RuleBase -> (FamInstEnv, FamInstEnv)
85 -> UniqSupply -- No init count; set to 0
89 initSmpl dflags rules fam_envs us m
90 = case unSM m env us (zeroSimplCount dflags) of
91 (result, _, count) -> (result, count)
93 env = STE { st_flags = dflags, st_rules = rules, st_fams = fam_envs }
95 {-# INLINE thenSmpl #-}
96 {-# INLINE thenSmpl_ #-}
97 {-# INLINE returnSmpl #-}
99 instance Monad SimplM where
104 returnSmpl :: a -> SimplM a
105 returnSmpl e = SM (\ st_env us sc -> (e, us, sc))
107 thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b
108 thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
111 = SM (\ st_env us0 sc0 ->
112 case (unSM m st_env us0 sc0) of
113 (m_result, us1, sc1) -> unSM (k m_result) st_env us1 sc1 )
116 = SM (\st_env us0 sc0 ->
117 case (unSM m st_env us0 sc0) of
118 (_, us1, sc1) -> unSM k st_env us1 sc1)
123 mapSmpl :: (a -> SimplM b) -> [a] -> SimplM [b]
124 mapAndUnzipSmpl :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c])
126 mapSmpl f [] = returnSmpl []
128 = f x `thenSmpl` \ x' ->
129 mapSmpl f xs `thenSmpl` \ xs' ->
132 mapAndUnzipSmpl f [] = returnSmpl ([],[])
133 mapAndUnzipSmpl f (x:xs)
134 = f x `thenSmpl` \ (r1, r2) ->
135 mapAndUnzipSmpl f xs `thenSmpl` \ (rs1, rs2) ->
136 returnSmpl (r1:rs1, r2:rs2)
138 mapAccumLSmpl :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c])
139 mapAccumLSmpl f acc [] = returnSmpl (acc, [])
140 mapAccumLSmpl f acc (x:xs) = f acc x `thenSmpl` \ (acc', x') ->
141 mapAccumLSmpl f acc' xs `thenSmpl` \ (acc'', xs') ->
142 returnSmpl (acc'', x':xs')
146 %************************************************************************
148 \subsection{The unique supply}
150 %************************************************************************
153 getUniqSupplySmpl :: SimplM UniqSupply
155 = SM (\st_env us sc -> case splitUniqSupply us of
156 (us1, us2) -> (us1, us2, sc))
158 getUniqueSmpl :: SimplM Unique
160 = SM (\st_env us sc -> case splitUniqSupply us of
161 (us1, us2) -> (uniqFromSupply us1, us2, sc))
163 getUniquesSmpl :: SimplM [Unique]
165 = SM (\st_env us sc -> case splitUniqSupply us of
166 (us1, us2) -> (uniqsFromSupply us1, us2, sc))
168 getDOptsSmpl :: SimplM DynFlags
169 getDOptsSmpl = SM (\st_env us sc -> (st_flags st_env, us, sc))
171 getRules :: SimplM RuleBase
172 getRules = SM (\st_env us sc -> (st_rules st_env, us, sc))
174 getFamEnvs :: SimplM (FamInstEnv, FamInstEnv)
175 getFamEnvs = SM (\st_env us sc -> (st_fams st_env, us, sc))
177 newId :: FastString -> Type -> SimplM Id
178 newId fs ty = getUniqueSmpl `thenSmpl` \ uniq ->
179 returnSmpl (mkSysLocal fs uniq ty)
183 %************************************************************************
185 \subsection{Counting up what we've done}
187 %************************************************************************
190 getSimplCount :: SimplM SimplCount
191 getSimplCount = SM (\st_env us sc -> (sc, us, sc))
193 tick :: Tick -> SimplM ()
195 = SM (\st_env us sc -> let sc' = doTick t sc
196 in sc' `seq` ((), us, sc'))
198 freeTick :: Tick -> SimplM ()
199 -- Record a tick, but don't add to the total tick count, which is
200 -- used to decide when nothing further has happened
202 = SM (\st_env us sc -> let sc' = doFreeTick t sc
203 in sc' `seq` ((), us, sc'))
207 verboseSimplStats = opt_PprStyle_Debug -- For now, anyway
209 zeroSimplCount :: DynFlags -> SimplCount
210 isZeroSimplCount :: SimplCount -> Bool
211 pprSimplCount :: SimplCount -> SDoc
212 doTick, doFreeTick :: Tick -> SimplCount -> SimplCount
213 plusSimplCount :: SimplCount -> SimplCount -> SimplCount
217 data SimplCount = VerySimplZero -- These two are used when
218 | VerySimplNonZero -- we are only interested in
222 ticks :: !Int, -- Total ticks
223 details :: !TickCounts, -- How many of each type
225 log1 :: [Tick], -- Last N events; <= opt_HistorySize
226 log2 :: [Tick] -- Last opt_HistorySize events before that
229 type TickCounts = FiniteMap Tick Int
231 zeroSimplCount dflags
232 -- This is where we decide whether to do
233 -- the VerySimpl version or the full-stats version
234 | dopt Opt_D_dump_simpl_stats dflags
235 = SimplCount {ticks = 0, details = emptyFM,
236 n_log = 0, log1 = [], log2 = []}
240 isZeroSimplCount VerySimplZero = True
241 isZeroSimplCount (SimplCount { ticks = 0 }) = True
242 isZeroSimplCount other = False
244 doFreeTick tick sc@SimplCount { details = dts }
245 = dts' `seqFM` sc { details = dts' }
247 dts' = dts `addTick` tick
248 doFreeTick tick sc = sc
250 -- Gross hack to persuade GHC 3.03 to do this important seq
251 seqFM fm x | isEmptyFM fm = x
254 doTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1, log2 = l2 }
255 | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
256 | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 }
258 sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
260 doTick tick sc = VerySimplNonZero -- The very simple case
263 -- Don't use plusFM_C because that's lazy, and we want to
264 -- be pretty strict here!
265 addTick :: TickCounts -> Tick -> TickCounts
266 addTick fm tick = case lookupFM fm tick of
267 Nothing -> addToFM fm tick 1
268 Just n -> n1 `seq` addToFM fm tick n1
273 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
274 sc2@(SimplCount { ticks = tks2, details = dts2 })
275 = log_base { ticks = tks1 + tks2, details = plusFM_C (+) dts1 dts2 }
277 -- A hackish way of getting recent log info
278 log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2
279 | null (log2 sc2) = sc2 { log2 = log1 sc1 }
282 plusSimplCount VerySimplZero VerySimplZero = VerySimplZero
283 plusSimplCount sc1 sc2 = VerySimplNonZero
285 pprSimplCount VerySimplZero = ptext SLIT("Total ticks: ZERO!")
286 pprSimplCount VerySimplNonZero = ptext SLIT("Total ticks: NON-ZERO!")
287 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
288 = vcat [ptext SLIT("Total ticks: ") <+> int tks,
290 pprTickCounts (fmToList dts),
291 if verboseSimplStats then
293 ptext SLIT("Log (most recent first)"),
294 nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
298 pprTickCounts :: [(Tick,Int)] -> SDoc
299 pprTickCounts [] = empty
300 pprTickCounts ((tick1,n1):ticks)
301 = vcat [int tot_n <+> text (tickString tick1),
302 pprTCDetails real_these,
306 tick1_tag = tickToTag tick1
307 (these, others) = span same_tick ticks
308 real_these = (tick1,n1):these
309 same_tick (tick2,_) = tickToTag tick2 == tick1_tag
310 tot_n = sum [n | (_,n) <- real_these]
312 pprTCDetails ticks@((tick,_):_)
313 | verboseSimplStats || isRuleFired tick
314 = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
319 %************************************************************************
323 %************************************************************************
327 = PreInlineUnconditionally Id
328 | PostInlineUnconditionally Id
331 | RuleFired FastString -- Rule name
334 | EtaExpansion Id -- LHS binder
335 | EtaReduction Id -- Binder on outer lambda
336 | BetaReduction Id -- Lambda binder
339 | CaseOfCase Id -- Bndr on *inner* case
340 | KnownBranch Id -- Case binder
341 | CaseMerge Id -- Binder on outer case
342 | AltMerge Id -- Case binder
343 | CaseElim Id -- Case binder
344 | CaseIdentity Id -- Case binder
345 | FillInCaseDefault Id -- Case binder
348 | SimplifierDone -- Ticked at each iteration of the simplifier
350 isRuleFired (RuleFired _) = True
351 isRuleFired other = False
353 instance Outputable Tick where
354 ppr tick = text (tickString tick) <+> pprTickCts tick
356 instance Eq Tick where
357 a == b = case a `cmpTick` b of { EQ -> True; other -> False }
359 instance Ord Tick where
362 tickToTag :: Tick -> Int
363 tickToTag (PreInlineUnconditionally _) = 0
364 tickToTag (PostInlineUnconditionally _) = 1
365 tickToTag (UnfoldingDone _) = 2
366 tickToTag (RuleFired _) = 3
367 tickToTag LetFloatFromLet = 4
368 tickToTag (EtaExpansion _) = 5
369 tickToTag (EtaReduction _) = 6
370 tickToTag (BetaReduction _) = 7
371 tickToTag (CaseOfCase _) = 8
372 tickToTag (KnownBranch _) = 9
373 tickToTag (CaseMerge _) = 10
374 tickToTag (CaseElim _) = 11
375 tickToTag (CaseIdentity _) = 12
376 tickToTag (FillInCaseDefault _) = 13
377 tickToTag BottomFound = 14
378 tickToTag SimplifierDone = 16
379 tickToTag (AltMerge _) = 17
381 tickString :: Tick -> String
382 tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
383 tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
384 tickString (UnfoldingDone _) = "UnfoldingDone"
385 tickString (RuleFired _) = "RuleFired"
386 tickString LetFloatFromLet = "LetFloatFromLet"
387 tickString (EtaExpansion _) = "EtaExpansion"
388 tickString (EtaReduction _) = "EtaReduction"
389 tickString (BetaReduction _) = "BetaReduction"
390 tickString (CaseOfCase _) = "CaseOfCase"
391 tickString (KnownBranch _) = "KnownBranch"
392 tickString (CaseMerge _) = "CaseMerge"
393 tickString (AltMerge _) = "AltMerge"
394 tickString (CaseElim _) = "CaseElim"
395 tickString (CaseIdentity _) = "CaseIdentity"
396 tickString (FillInCaseDefault _) = "FillInCaseDefault"
397 tickString BottomFound = "BottomFound"
398 tickString SimplifierDone = "SimplifierDone"
400 pprTickCts :: Tick -> SDoc
401 pprTickCts (PreInlineUnconditionally v) = ppr v
402 pprTickCts (PostInlineUnconditionally v)= ppr v
403 pprTickCts (UnfoldingDone v) = ppr v
404 pprTickCts (RuleFired v) = ppr v
405 pprTickCts LetFloatFromLet = empty
406 pprTickCts (EtaExpansion v) = ppr v
407 pprTickCts (EtaReduction v) = ppr v
408 pprTickCts (BetaReduction v) = ppr v
409 pprTickCts (CaseOfCase v) = ppr v
410 pprTickCts (KnownBranch v) = ppr v
411 pprTickCts (CaseMerge v) = ppr v
412 pprTickCts (AltMerge v) = ppr v
413 pprTickCts (CaseElim v) = ppr v
414 pprTickCts (CaseIdentity v) = ppr v
415 pprTickCts (FillInCaseDefault v) = ppr v
416 pprTickCts other = empty
418 cmpTick :: Tick -> Tick -> Ordering
419 cmpTick a b = case (tickToTag a `compare` tickToTag b) of
421 EQ | isRuleFired a || verboseSimplStats -> cmpEqTick a b
424 -- Always distinguish RuleFired, so that the stats
425 -- can report them even in non-verbose mode
427 cmpEqTick :: Tick -> Tick -> Ordering
428 cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b
429 cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b
430 cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b
431 cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b
432 cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b
433 cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b
434 cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b
435 cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b
436 cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b
437 cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b
438 cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b
439 cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b
440 cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b
441 cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b
442 cmpEqTick other1 other2 = EQ
446 %************************************************************************
448 \subsubsection{Command-line switches}
450 %************************************************************************
453 type SwitchChecker = SimplifierSwitch -> SwitchResult
456 = SwBool Bool -- on/off
457 | SwString FastString -- nothing or a String
458 | SwInt Int -- nothing or an Int
460 isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult
461 isAmongSimpl on_switches -- Switches mentioned later occur *earlier*
462 -- in the list; defaults right at the end.
464 tidied_on_switches = foldl rm_dups [] on_switches
465 -- The fold*l* ensures that we keep the latest switches;
466 -- ie the ones that occur earliest in the list.
468 sw_tbl :: Array Int SwitchResult
469 sw_tbl = (array (0, lAST_SIMPL_SWITCH_TAG) -- bounds...
473 all_undefined = [ (i, SwBool False) | i <- [0 .. lAST_SIMPL_SWITCH_TAG ] ]
475 defined_elems = map mk_assoc_elem tidied_on_switches
477 -- (avoid some unboxing, bounds checking, and other horrible things:)
478 \ switch -> unsafeAt sw_tbl $ iBox (tagOf_SimplSwitch switch)
480 mk_assoc_elem k@(MaxSimplifierIterations lvl)
481 = (iBox (tagOf_SimplSwitch k), SwInt lvl)
483 = (iBox (tagOf_SimplSwitch k), SwBool True) -- I'm here, Mom!
485 -- cannot have duplicates if we are going to use the array thing
486 rm_dups switches_so_far switch
487 = if switch `is_elem` switches_so_far
489 else switch : switches_so_far
491 sw `is_elem` [] = False
492 sw `is_elem` (s:ss) = (tagOf_SimplSwitch sw) ==# (tagOf_SimplSwitch s)
497 getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
498 getSimplIntSwitch chkr switch
499 = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
501 switchIsOn :: (switch -> SwitchResult) -> switch -> Bool
503 switchIsOn lookup_fn switch
504 = case (lookup_fn switch) of
505 SwBool False -> False
508 intSwitchSet :: (switch -> SwitchResult)
512 intSwitchSet lookup_fn switch
513 = case (lookup_fn (switch (panic "intSwitchSet"))) of
514 SwInt int -> Just int
519 These things behave just like enumeration types.
522 instance Eq SimplifierSwitch where
523 a == b = tagOf_SimplSwitch a ==# tagOf_SimplSwitch b
525 instance Ord SimplifierSwitch where
526 a < b = tagOf_SimplSwitch a <# tagOf_SimplSwitch b
527 a <= b = tagOf_SimplSwitch a <=# tagOf_SimplSwitch b
530 tagOf_SimplSwitch (MaxSimplifierIterations _) = _ILIT(1)
531 tagOf_SimplSwitch NoCaseOfCase = _ILIT(2)
533 -- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
535 lAST_SIMPL_SWITCH_TAG = 2