8a02b174e85631ff8b76f49c5a9804a5de0f98f7
[ghc.git] / compiler / simplCore / SimplMonad.lhs
1 %
2 % (c) The AQUA Project, Glasgow University, 1993-1998
3 %
4 \section[SimplMonad]{The simplifier Monad}
5
6 \begin{code}
7 module SimplMonad (
8         -- The monad
9         SimplM,
10         initSmpl,
11         getDOptsSmpl, getSimplRules, getFamEnvs,
12
13         -- Unique supply
14         MonadUnique(..), newId,
15
16         -- Counting
17         SimplCount, Tick(..),
18         tick, freeTick,
19         getSimplCount, zeroSimplCount, pprSimplCount, 
20         plusSimplCount, isZeroSimplCount,
21
22         -- Switch checker
23         SwitchChecker, SwitchResult(..), getSimplIntSwitch,
24         isAmongSimpl, intSwitchSet, switchIsOn, allOffSwitchChecker
25     ) where
26
27 import Id               ( Id, mkSysLocal )
28 import Type             ( Type )
29 import FamInstEnv       ( FamInstEnv )
30 import Rules            ( RuleBase )
31 import UniqSupply
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 )
36 import FastString
37 import Outputable
38 import FastTypes
39
40 import Data.Array
41 import Data.Array.Base (unsafeAt)
42 \end{code}
43
44 %************************************************************************
45 %*                                                                      *
46 \subsection{Monad plumbing}
47 %*                                                                      *
48 %************************************************************************
49
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.)
52
53 \begin{code}
54 newtype SimplM result
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
58                 -> SimplCount 
59                 -> (result, UniqSupply, SimplCount)}
60
61 data SimplTopEnv = STE  { st_flags :: DynFlags 
62                         , st_rules :: RuleBase
63                         , st_fams  :: (FamInstEnv, FamInstEnv) }
64 \end{code}
65
66 \begin{code}
67 initSmpl :: DynFlags -> RuleBase -> (FamInstEnv, FamInstEnv) 
68          -> UniqSupply          -- No init count; set to 0
69          -> SimplM a
70          -> (a, SimplCount)
71
72 initSmpl dflags rules fam_envs us m
73   = case unSM m env us (zeroSimplCount dflags) of 
74         (result, _, count) -> (result, count)
75   where
76     env = STE { st_flags = dflags, st_rules = rules, st_fams = fam_envs }
77
78 {-# INLINE thenSmpl #-}
79 {-# INLINE thenSmpl_ #-}
80 {-# INLINE returnSmpl #-}
81
82 instance Monad SimplM where
83    (>>)   = thenSmpl_
84    (>>=)  = thenSmpl
85    return = returnSmpl
86
87 returnSmpl :: a -> SimplM a
88 returnSmpl e = SM (\_st_env us sc -> (e, us, sc))
89
90 thenSmpl  :: SimplM a -> (a -> SimplM b) -> SimplM b
91 thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
92
93 thenSmpl m k 
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 )
97
98 thenSmpl_ m k 
99   = SM (\st_env us0 sc0 ->
100          case (unSM m st_env us0 sc0) of 
101                 (_, us1, sc1) -> unSM k st_env us1 sc1)
102
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]) #-}
107 \end{code}
108
109
110 %************************************************************************
111 %*                                                                      *
112 \subsection{The unique supply}
113 %*                                                                      *
114 %************************************************************************
115
116 \begin{code}
117 instance MonadUnique SimplM where
118     getUniqueSupplyM
119        = SM (\_st_env us sc -> case splitUniqSupply us of
120                                 (us1, us2) -> (us1, us2, sc))
121
122     getUniqueM
123        = SM (\_st_env us sc -> case splitUniqSupply us of
124                                 (us1, us2) -> (uniqFromSupply us1, us2, sc))
125
126     getUniquesM
127         = SM (\_st_env us sc -> case splitUniqSupply us of
128                                 (us1, us2) -> (uniqsFromSupply us1, us2, sc))
129
130 getDOptsSmpl :: SimplM DynFlags
131 getDOptsSmpl = SM (\st_env us sc -> (st_flags st_env, us, sc))
132
133 getSimplRules :: SimplM RuleBase
134 getSimplRules = SM (\st_env us sc -> (st_rules st_env, us, sc))
135
136 getFamEnvs :: SimplM (FamInstEnv, FamInstEnv)
137 getFamEnvs = SM (\st_env us sc -> (st_fams st_env, us, sc))
138
139 newId :: FastString -> Type -> SimplM Id
140 newId fs ty = do uniq <- getUniqueM
141                  return (mkSysLocal fs uniq ty)
142 \end{code}
143
144
145 %************************************************************************
146 %*                                                                      *
147 \subsection{Counting up what we've done}
148 %*                                                                      *
149 %************************************************************************
150
151 \begin{code}
152 getSimplCount :: SimplM SimplCount
153 getSimplCount = SM (\_st_env us sc -> (sc, us, sc))
154
155 tick :: Tick -> SimplM ()
156 tick t 
157    = SM (\_st_env us sc -> let sc' = doTick t sc 
158                            in sc' `seq` ((), us, sc'))
159
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
163 freeTick t 
164    = SM (\_st_env us sc -> let sc' = doFreeTick t sc
165                            in sc' `seq` ((), us, sc'))
166 \end{code}
167
168 \begin{code}
169 verboseSimplStats :: Bool
170 verboseSimplStats = opt_PprStyle_Debug          -- For now, anyway
171
172 zeroSimplCount     :: DynFlags -> SimplCount
173 isZeroSimplCount   :: SimplCount -> Bool
174 pprSimplCount      :: SimplCount -> SDoc
175 doTick, doFreeTick :: Tick -> SimplCount -> SimplCount
176 plusSimplCount     :: SimplCount -> SimplCount -> SimplCount
177 \end{code}
178
179 \begin{code}
180 data SimplCount 
181    = VerySimplZero              -- These two are used when 
182    | VerySimplNonZero   -- we are only interested in 
183                                 -- termination info
184
185    | SimplCount {
186         ticks   :: !Int,        -- Total ticks
187         details :: !TickCounts, -- How many of each type
188
189         n_log   :: !Int,        -- N
190         log1    :: [Tick],      -- Last N events; <= opt_HistorySize, 
191                                 --   most recent first
192         log2    :: [Tick]       -- Last opt_HistorySize events before that
193                                 -- Having log1, log2 lets us accumulate the
194                                 -- recent history reasonably efficiently
195      }
196
197 type TickCounts = FiniteMap Tick Int
198
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 = []}
205   | otherwise
206   = VerySimplZero
207
208 isZeroSimplCount VerySimplZero              = True
209 isZeroSimplCount (SimplCount { ticks = 0 }) = True
210 isZeroSimplCount _                          = False
211
212 doFreeTick tick sc@SimplCount { details = dts } 
213   = sc { details = dts `addTick` tick }
214 doFreeTick _ sc = sc 
215
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 }
219   where
220     sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
221
222 doTick _ _ = VerySimplNonZero -- The very simple case
223
224
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
231                                 where
232                                    n1 = n+1
233
234
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 }
238   where
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 }
242              | otherwise       = sc2
243
244 plusSimplCount VerySimplZero VerySimplZero = VerySimplZero
245 plusSimplCount _             _             = VerySimplNonZero
246
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,
251           blankLine,
252           pprTickCounts (fmToList dts),
253           if verboseSimplStats then
254                 vcat [blankLine,
255                       ptext (sLit "Log (most recent first)"),
256                       nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
257           else empty
258     ]
259
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,
265           pprTickCounts others
266     ]
267   where
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]
273
274 pprTCDetails :: [(Tick, Int)] -> SDoc
275 pprTCDetails ticks
276   = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
277 \end{code}
278
279 %************************************************************************
280 %*                                                                      *
281 \subsection{Ticks}
282 %*                                                                      *
283 %************************************************************************
284
285 \begin{code}
286 data Tick
287   = PreInlineUnconditionally    Id
288   | PostInlineUnconditionally   Id
289
290   | UnfoldingDone               Id
291   | RuleFired                   FastString      -- Rule name
292
293   | LetFloatFromLet
294   | EtaExpansion                Id      -- LHS binder
295   | EtaReduction                Id      -- Binder on outer lambda
296   | BetaReduction               Id      -- Lambda binder
297
298
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
306
307   | BottomFound         
308   | SimplifierDone              -- Ticked at each iteration of the simplifier
309
310 instance Outputable Tick where
311   ppr tick = text (tickString tick) <+> pprTickCts tick
312
313 instance Eq Tick where
314   a == b = case a `cmpTick` b of
315            EQ -> True
316            _ -> False
317
318 instance Ord Tick where
319   compare = cmpTick
320
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
339
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"
358
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
375 pprTickCts _                            = empty
376
377 cmpTick :: Tick -> Tick -> Ordering
378 cmpTick a b = case (tickToTag a `compare` tickToTag b) of
379                 GT -> GT
380                 EQ -> cmpEqTick a b
381                 LT -> LT
382
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
398 cmpEqTick _                             _                               = EQ
399 \end{code}
400
401
402 %************************************************************************
403 %*                                                                      *
404 \subsubsection{Command-line switches}
405 %*                                                                      *
406 %************************************************************************
407
408 \begin{code}
409 type SwitchChecker = SimplifierSwitch -> SwitchResult
410
411 data SwitchResult
412   = SwBool      Bool            -- on/off
413   | SwString    FastString      -- nothing or a String
414   | SwInt       Int             -- nothing or an Int
415
416 allOffSwitchChecker :: SwitchChecker
417 allOffSwitchChecker _ = SwBool False
418
419 isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult
420 isAmongSimpl on_switches                -- Switches mentioned later occur *earlier*
421                                         -- in the list; defaults right at the end.
422   = let
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.
426
427         sw_tbl :: Array Int SwitchResult
428         sw_tbl = (array (0, lAST_SIMPL_SWITCH_TAG) -- bounds...
429                         all_undefined)
430                  // defined_elems
431
432         all_undefined = [ (i, SwBool False) | i <- [0 .. lAST_SIMPL_SWITCH_TAG ] ]
433
434         defined_elems = map mk_assoc_elem tidied_on_switches
435     in
436     -- (avoid some unboxing, bounds checking, and other horrible things:)
437     \ switch -> unsafeAt sw_tbl $ iBox (tagOf_SimplSwitch switch)
438   where
439     mk_assoc_elem k@(MaxSimplifierIterations lvl)
440         = (iBox (tagOf_SimplSwitch k), SwInt lvl)
441     mk_assoc_elem k
442         = (iBox (tagOf_SimplSwitch k), SwBool True) -- I'm here, Mom!
443
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
447         then switches_so_far
448         else switch : switches_so_far
449       where
450         _  `is_elem` []     = False
451         sw `is_elem` (s:ss) = (tagOf_SimplSwitch sw) ==# (tagOf_SimplSwitch s)
452                             || sw `is_elem` ss
453 \end{code}
454
455 \begin{code}
456 getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
457 getSimplIntSwitch chkr switch
458   = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
459
460 switchIsOn :: (switch -> SwitchResult) -> switch -> Bool
461
462 switchIsOn lookup_fn switch
463   = case (lookup_fn switch) of
464       SwBool False -> False
465       _            -> True
466
467 intSwitchSet :: (switch -> SwitchResult)
468              -> (Int -> switch)
469              -> Maybe Int
470
471 intSwitchSet lookup_fn switch
472   = case (lookup_fn (switch (panic "intSwitchSet"))) of
473       SwInt int -> Just int
474       _         -> Nothing
475 \end{code}
476
477
478 These things behave just like enumeration types.
479
480 \begin{code}
481 instance Eq SimplifierSwitch where
482     a == b = tagOf_SimplSwitch a ==# tagOf_SimplSwitch b
483
484 instance Ord SimplifierSwitch where
485     a <  b  = tagOf_SimplSwitch a <# tagOf_SimplSwitch b
486     a <= b  = tagOf_SimplSwitch a <=# tagOf_SimplSwitch b
487
488
489 tagOf_SimplSwitch :: SimplifierSwitch -> FastInt
490 tagOf_SimplSwitch (MaxSimplifierIterations _)   = _ILIT(1)
491 tagOf_SimplSwitch NoCaseOfCase                  = _ILIT(2)
492
493 -- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
494
495 lAST_SIMPL_SWITCH_TAG :: Int
496 lAST_SIMPL_SWITCH_TAG = 2
497 \end{code}
498