2 % (c) The AQUA Project, Glasgow University, 1993-1998
4 \section[SimplMonad]{The simplifier Monad}
10 initSmpl, returnSmpl, thenSmpl, thenSmpl_,
11 mapSmpl, mapAndUnzipSmpl, mapAccumLSmpl,
15 getUniqueSmpl, getUniquesSmpl, getUniqSupplySmpl, newId,
20 getSimplCount, zeroSimplCount, pprSimplCount,
21 plusSimplCount, isZeroSimplCount,
24 SwitchChecker, SwitchResult(..), getSimplIntSwitch,
25 isAmongSimpl, intSwitchSet, switchIsOn
28 #include "HsVersions.h"
30 import Id ( Id, mkSysLocal )
32 import UniqSupply ( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
35 import DynFlags ( SimplifierSwitch(..), DynFlags, DynFlag(..), dopt )
36 import StaticFlags ( opt_PprStyle_Debug, opt_HistorySize )
37 import OccName ( EncodedFS )
38 import Unique ( Unique )
39 import Maybes ( expectJust )
40 import FiniteMap ( FiniteMap, emptyFM, isEmptyFM, lookupFM, addToFM, plusFM_C, fmToList )
41 import FastString ( FastString )
45 import GLAEXTS ( indexArray# )
47 #if __GLASGOW_HASKELL__ < 503
48 import PrelArr ( Array(..) )
50 import GHC.Arr ( Array(..) )
53 import Array ( array, (//) )
55 infixr 0 `thenSmpl`, `thenSmpl_`
58 %************************************************************************
60 \subsection{Monad plumbing}
62 %************************************************************************
64 For the simplifier monad, we want to {\em thread} a unique supply and a counter.
65 (Command-line switches move around through the explicitly-passed SimplEnv.)
69 = SM { unSM :: DynFlags -- We thread the unique supply because
70 -> UniqSupply -- constantly splitting it is rather expensive
72 -> (result, UniqSupply, SimplCount)}
77 -> UniqSupply -- No init count; set to 0
82 = case unSM m dflags us (zeroSimplCount dflags) of
83 (result, _, count) -> (result, count)
86 {-# INLINE thenSmpl #-}
87 {-# INLINE thenSmpl_ #-}
88 {-# INLINE returnSmpl #-}
90 instance Monad SimplM where
95 returnSmpl :: a -> SimplM a
96 returnSmpl e = SM (\ dflags us sc -> (e, us, sc))
98 thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b
99 thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
102 = SM (\ dflags us0 sc0 ->
103 case (unSM m dflags us0 sc0) of
104 (m_result, us1, sc1) -> unSM (k m_result) dflags us1 sc1 )
107 = SM (\dflags us0 sc0 ->
108 case (unSM m dflags us0 sc0) of
109 (_, us1, sc1) -> unSM k dflags us1 sc1)
114 mapSmpl :: (a -> SimplM b) -> [a] -> SimplM [b]
115 mapAndUnzipSmpl :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c])
117 mapSmpl f [] = returnSmpl []
119 = f x `thenSmpl` \ x' ->
120 mapSmpl f xs `thenSmpl` \ xs' ->
123 mapAndUnzipSmpl f [] = returnSmpl ([],[])
124 mapAndUnzipSmpl f (x:xs)
125 = f x `thenSmpl` \ (r1, r2) ->
126 mapAndUnzipSmpl f xs `thenSmpl` \ (rs1, rs2) ->
127 returnSmpl (r1:rs1, r2:rs2)
129 mapAccumLSmpl :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c])
130 mapAccumLSmpl f acc [] = returnSmpl (acc, [])
131 mapAccumLSmpl f acc (x:xs) = f acc x `thenSmpl` \ (acc', x') ->
132 mapAccumLSmpl f acc' xs `thenSmpl` \ (acc'', xs') ->
133 returnSmpl (acc'', x':xs')
137 %************************************************************************
139 \subsection{The unique supply}
141 %************************************************************************
144 getUniqSupplySmpl :: SimplM UniqSupply
146 = SM (\dflags us sc -> case splitUniqSupply us of
147 (us1, us2) -> (us1, us2, sc))
149 getUniqueSmpl :: SimplM Unique
151 = SM (\dflags us sc -> case splitUniqSupply us of
152 (us1, us2) -> (uniqFromSupply us1, us2, sc))
154 getUniquesSmpl :: SimplM [Unique]
156 = SM (\dflags us sc -> case splitUniqSupply us of
157 (us1, us2) -> (uniqsFromSupply us1, us2, sc))
159 getDOptsSmpl :: SimplM DynFlags
161 = SM (\dflags us sc -> (dflags, us, sc))
163 newId :: EncodedFS -> Type -> SimplM Id
164 newId fs ty = getUniqueSmpl `thenSmpl` \ uniq ->
165 returnSmpl (mkSysLocal fs uniq ty)
169 %************************************************************************
171 \subsection{Counting up what we've done}
173 %************************************************************************
176 getSimplCount :: SimplM SimplCount
177 getSimplCount = SM (\dflags us sc -> (sc, us, sc))
179 tick :: Tick -> SimplM ()
181 = SM (\dflags us sc -> let sc' = doTick t sc
182 in sc' `seq` ((), us, sc'))
184 freeTick :: Tick -> SimplM ()
185 -- Record a tick, but don't add to the total tick count, which is
186 -- used to decide when nothing further has happened
188 = SM (\dflags us sc -> let sc' = doFreeTick t sc
189 in sc' `seq` ((), us, sc'))
193 verboseSimplStats = opt_PprStyle_Debug -- For now, anyway
195 zeroSimplCount :: DynFlags -> SimplCount
196 isZeroSimplCount :: SimplCount -> Bool
197 pprSimplCount :: SimplCount -> SDoc
198 doTick, doFreeTick :: Tick -> SimplCount -> SimplCount
199 plusSimplCount :: SimplCount -> SimplCount -> SimplCount
203 data SimplCount = VerySimplZero -- These two are used when
204 | VerySimplNonZero -- we are only interested in
208 ticks :: !Int, -- Total ticks
209 details :: !TickCounts, -- How many of each type
211 log1 :: [Tick], -- Last N events; <= opt_HistorySize
212 log2 :: [Tick] -- Last opt_HistorySize events before that
215 type TickCounts = FiniteMap Tick Int
217 zeroSimplCount dflags
218 -- This is where we decide whether to do
219 -- the VerySimpl version or the full-stats version
220 | dopt Opt_D_dump_simpl_stats dflags
221 = SimplCount {ticks = 0, details = emptyFM,
222 n_log = 0, log1 = [], log2 = []}
226 isZeroSimplCount VerySimplZero = True
227 isZeroSimplCount (SimplCount { ticks = 0 }) = True
228 isZeroSimplCount other = False
230 doFreeTick tick sc@SimplCount { details = dts }
231 = dts' `seqFM` sc { details = dts' }
233 dts' = dts `addTick` tick
234 doFreeTick tick sc = sc
236 -- Gross hack to persuade GHC 3.03 to do this important seq
237 seqFM fm x | isEmptyFM fm = x
240 doTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1, log2 = l2 }
241 | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
242 | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 }
244 sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
246 doTick tick sc = VerySimplNonZero -- The very simple case
249 -- Don't use plusFM_C because that's lazy, and we want to
250 -- be pretty strict here!
251 addTick :: TickCounts -> Tick -> TickCounts
252 addTick fm tick = case lookupFM fm tick of
253 Nothing -> addToFM fm tick 1
254 Just n -> n1 `seq` addToFM fm tick n1
259 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
260 sc2@(SimplCount { ticks = tks2, details = dts2 })
261 = log_base { ticks = tks1 + tks2, details = plusFM_C (+) dts1 dts2 }
263 -- A hackish way of getting recent log info
264 log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2
265 | null (log2 sc2) = sc2 { log2 = log1 sc1 }
268 plusSimplCount VerySimplZero VerySimplZero = VerySimplZero
269 plusSimplCount sc1 sc2 = VerySimplNonZero
271 pprSimplCount VerySimplZero = ptext SLIT("Total ticks: ZERO!")
272 pprSimplCount VerySimplNonZero = ptext SLIT("Total ticks: NON-ZERO!")
273 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
274 = vcat [ptext SLIT("Total ticks: ") <+> int tks,
276 pprTickCounts (fmToList dts),
277 if verboseSimplStats then
279 ptext SLIT("Log (most recent first)"),
280 nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
284 pprTickCounts :: [(Tick,Int)] -> SDoc
285 pprTickCounts [] = empty
286 pprTickCounts ((tick1,n1):ticks)
287 = vcat [int tot_n <+> text (tickString tick1),
288 pprTCDetails real_these,
292 tick1_tag = tickToTag tick1
293 (these, others) = span same_tick ticks
294 real_these = (tick1,n1):these
295 same_tick (tick2,_) = tickToTag tick2 == tick1_tag
296 tot_n = sum [n | (_,n) <- real_these]
298 pprTCDetails ticks@((tick,_):_)
299 | verboseSimplStats || isRuleFired tick
300 = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
305 %************************************************************************
309 %************************************************************************
313 = PreInlineUnconditionally Id
314 | PostInlineUnconditionally Id
317 | RuleFired FastString -- Rule name
320 | EtaExpansion Id -- LHS binder
321 | EtaReduction Id -- Binder on outer lambda
322 | BetaReduction Id -- Lambda binder
325 | CaseOfCase Id -- Bndr on *inner* case
326 | KnownBranch Id -- Case binder
327 | CaseMerge Id -- Binder on outer case
328 | AltMerge Id -- Case binder
329 | CaseElim Id -- Case binder
330 | CaseIdentity Id -- Case binder
331 | FillInCaseDefault Id -- Case binder
334 | SimplifierDone -- Ticked at each iteration of the simplifier
336 isRuleFired (RuleFired _) = True
337 isRuleFired other = False
339 instance Outputable Tick where
340 ppr tick = text (tickString tick) <+> pprTickCts tick
342 instance Eq Tick where
343 a == b = case a `cmpTick` b of { EQ -> True; other -> False }
345 instance Ord Tick where
348 tickToTag :: Tick -> Int
349 tickToTag (PreInlineUnconditionally _) = 0
350 tickToTag (PostInlineUnconditionally _) = 1
351 tickToTag (UnfoldingDone _) = 2
352 tickToTag (RuleFired _) = 3
353 tickToTag LetFloatFromLet = 4
354 tickToTag (EtaExpansion _) = 5
355 tickToTag (EtaReduction _) = 6
356 tickToTag (BetaReduction _) = 7
357 tickToTag (CaseOfCase _) = 8
358 tickToTag (KnownBranch _) = 9
359 tickToTag (CaseMerge _) = 10
360 tickToTag (CaseElim _) = 11
361 tickToTag (CaseIdentity _) = 12
362 tickToTag (FillInCaseDefault _) = 13
363 tickToTag BottomFound = 14
364 tickToTag SimplifierDone = 16
365 tickToTag (AltMerge _) = 17
367 tickString :: Tick -> String
368 tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
369 tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
370 tickString (UnfoldingDone _) = "UnfoldingDone"
371 tickString (RuleFired _) = "RuleFired"
372 tickString LetFloatFromLet = "LetFloatFromLet"
373 tickString (EtaExpansion _) = "EtaExpansion"
374 tickString (EtaReduction _) = "EtaReduction"
375 tickString (BetaReduction _) = "BetaReduction"
376 tickString (CaseOfCase _) = "CaseOfCase"
377 tickString (KnownBranch _) = "KnownBranch"
378 tickString (CaseMerge _) = "CaseMerge"
379 tickString (AltMerge _) = "AltMerge"
380 tickString (CaseElim _) = "CaseElim"
381 tickString (CaseIdentity _) = "CaseIdentity"
382 tickString (FillInCaseDefault _) = "FillInCaseDefault"
383 tickString BottomFound = "BottomFound"
384 tickString SimplifierDone = "SimplifierDone"
386 pprTickCts :: Tick -> SDoc
387 pprTickCts (PreInlineUnconditionally v) = ppr v
388 pprTickCts (PostInlineUnconditionally v)= ppr v
389 pprTickCts (UnfoldingDone v) = ppr v
390 pprTickCts (RuleFired v) = ppr v
391 pprTickCts LetFloatFromLet = empty
392 pprTickCts (EtaExpansion v) = ppr v
393 pprTickCts (EtaReduction v) = ppr v
394 pprTickCts (BetaReduction v) = ppr v
395 pprTickCts (CaseOfCase v) = ppr v
396 pprTickCts (KnownBranch v) = ppr v
397 pprTickCts (CaseMerge v) = ppr v
398 pprTickCts (AltMerge v) = ppr v
399 pprTickCts (CaseElim v) = ppr v
400 pprTickCts (CaseIdentity v) = ppr v
401 pprTickCts (FillInCaseDefault v) = ppr v
402 pprTickCts other = empty
404 cmpTick :: Tick -> Tick -> Ordering
405 cmpTick a b = case (tickToTag a `compare` tickToTag b) of
407 EQ | isRuleFired a || verboseSimplStats -> cmpEqTick a b
410 -- Always distinguish RuleFired, so that the stats
411 -- can report them even in non-verbose mode
413 cmpEqTick :: Tick -> Tick -> Ordering
414 cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b
415 cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b
416 cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b
417 cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b
418 cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b
419 cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b
420 cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b
421 cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b
422 cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b
423 cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b
424 cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b
425 cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b
426 cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b
427 cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b
428 cmpEqTick other1 other2 = EQ
432 %************************************************************************
434 \subsubsection{Command-line switches}
436 %************************************************************************
439 type SwitchChecker = SimplifierSwitch -> SwitchResult
442 = SwBool Bool -- on/off
443 | SwString FastString -- nothing or a String
444 | SwInt Int -- nothing or an Int
446 isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult
447 isAmongSimpl on_switches -- Switches mentioned later occur *earlier*
448 -- in the list; defaults right at the end.
450 tidied_on_switches = foldl rm_dups [] on_switches
451 -- The fold*l* ensures that we keep the latest switches;
452 -- ie the ones that occur earliest in the list.
454 sw_tbl :: Array Int SwitchResult
455 sw_tbl = (array (0, lAST_SIMPL_SWITCH_TAG) -- bounds...
459 all_undefined = [ (i, SwBool False) | i <- [0 .. lAST_SIMPL_SWITCH_TAG ] ]
461 defined_elems = map mk_assoc_elem tidied_on_switches
463 -- (avoid some unboxing, bounds checking, and other horrible things:)
464 case sw_tbl of { Array _ _ stuff ->
466 case (indexArray# stuff (tagOf_SimplSwitch switch)) of
470 mk_assoc_elem k@(MaxSimplifierIterations lvl)
471 = (iBox (tagOf_SimplSwitch k), SwInt lvl)
473 = (iBox (tagOf_SimplSwitch k), SwBool True) -- I'm here, Mom!
475 -- cannot have duplicates if we are going to use the array thing
476 rm_dups switches_so_far switch
477 = if switch `is_elem` switches_so_far
479 else switch : switches_so_far
481 sw `is_elem` [] = False
482 sw `is_elem` (s:ss) = (tagOf_SimplSwitch sw) ==# (tagOf_SimplSwitch s)
487 getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
488 getSimplIntSwitch chkr switch
489 = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
491 switchIsOn :: (switch -> SwitchResult) -> switch -> Bool
493 switchIsOn lookup_fn switch
494 = case (lookup_fn switch) of
495 SwBool False -> False
498 intSwitchSet :: (switch -> SwitchResult)
502 intSwitchSet lookup_fn switch
503 = case (lookup_fn (switch (panic "intSwitchSet"))) of
504 SwInt int -> Just int
509 These things behave just like enumeration types.
512 instance Eq SimplifierSwitch where
513 a == b = tagOf_SimplSwitch a ==# tagOf_SimplSwitch b
515 instance Ord SimplifierSwitch where
516 a < b = tagOf_SimplSwitch a <# tagOf_SimplSwitch b
517 a <= b = tagOf_SimplSwitch a <=# tagOf_SimplSwitch b
520 tagOf_SimplSwitch (MaxSimplifierIterations _) = _ILIT(1)
521 tagOf_SimplSwitch NoCaseOfCase = _ILIT(2)
523 -- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
525 lAST_SIMPL_SWITCH_TAG = 2