Don't import FastString in HsVersions.h
[ghc-hetmet.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 {-# OPTIONS -w #-}
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
12 -- for details
13
14 module SimplMonad (
15         -- The monad
16         SimplM,
17         initSmpl,
18         getDOptsSmpl, getRules, getFamEnvs,
19
20         -- Unique supply
21         MonadUnique(..), newId,
22
23         -- Counting
24         SimplCount, Tick(..),
25         tick, freeTick,
26         getSimplCount, zeroSimplCount, pprSimplCount, 
27         plusSimplCount, isZeroSimplCount,
28
29         -- Switch checker
30         SwitchChecker, SwitchResult(..), getSimplIntSwitch,
31         isAmongSimpl, intSwitchSet, switchIsOn
32     ) where
33
34 #include "HsVersions.h"
35
36 import Id               ( Id, mkSysLocal )
37 import Type             ( Type )
38 import FamInstEnv       ( FamInstEnv )
39 import Rules            ( RuleBase )
40 import UniqSupply
41 import DynFlags         ( SimplifierSwitch(..), DynFlags, DynFlag(..), dopt )
42 import StaticFlags      ( opt_PprStyle_Debug, opt_HistorySize )
43 import Unique           ( Unique )
44 import Maybes           ( expectJust )
45 import FiniteMap        ( FiniteMap, emptyFM, isEmptyFM, lookupFM, addToFM, plusFM_C, fmToList )
46 import FastString
47 import Outputable
48 import FastTypes
49
50 import Data.Array
51 import Data.Array.Base (unsafeAt)
52 \end{code}
53
54 %************************************************************************
55 %*                                                                      *
56 \subsection{Monad plumbing}
57 %*                                                                      *
58 %************************************************************************
59
60 For the simplifier monad, we want to {\em thread} a unique supply and a counter.
61 (Command-line switches move around through the explicitly-passed SimplEnv.)
62
63 \begin{code}
64 newtype SimplM result
65   =  SM  { unSM :: SimplTopEnv  -- Envt that does not change much
66                 -> UniqSupply   -- We thread the unique supply because
67                                 -- constantly splitting it is rather expensive
68                 -> SimplCount 
69                 -> (result, UniqSupply, SimplCount)}
70
71 data SimplTopEnv = STE  { st_flags :: DynFlags 
72                         , st_rules :: RuleBase
73                         , st_fams  :: (FamInstEnv, FamInstEnv) }
74 \end{code}
75
76 \begin{code}
77 initSmpl :: DynFlags -> RuleBase -> (FamInstEnv, FamInstEnv) 
78          -> UniqSupply          -- No init count; set to 0
79          -> SimplM a
80          -> (a, SimplCount)
81
82 initSmpl dflags rules fam_envs us m
83   = case unSM m env us (zeroSimplCount dflags) of 
84         (result, _, count) -> (result, count)
85   where
86     env = STE { st_flags = dflags, st_rules = rules, st_fams = fam_envs }
87
88 {-# INLINE thenSmpl #-}
89 {-# INLINE thenSmpl_ #-}
90 {-# INLINE returnSmpl #-}
91
92 instance Monad SimplM where
93    (>>)   = thenSmpl_
94    (>>=)  = thenSmpl
95    return = returnSmpl
96
97 returnSmpl :: a -> SimplM a
98 returnSmpl e = SM (\ st_env us sc -> (e, us, sc))
99
100 thenSmpl  :: SimplM a -> (a -> SimplM b) -> SimplM b
101 thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
102
103 thenSmpl m k 
104   = SM (\ st_env us0 sc0 ->
105           case (unSM m st_env us0 sc0) of 
106                 (m_result, us1, sc1) -> unSM (k m_result) st_env us1 sc1 )
107
108 thenSmpl_ m k 
109   = SM (\st_env us0 sc0 ->
110          case (unSM m st_env us0 sc0) of 
111                 (_, us1, sc1) -> unSM k st_env us1 sc1)
112
113 -- TODO: this specializing is not allowed
114 {-# -- SPECIALIZE mapM         :: (a -> SimplM b) -> [a] -> SimplM [b] #-}
115 {-# -- SPECIALIZE mapAndUnzipM :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c]) #-}
116 {-# -- SPECIALIZE mapAccumLM   :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c]) #-}
117 \end{code}
118
119
120 %************************************************************************
121 %*                                                                      *
122 \subsection{The unique supply}
123 %*                                                                      *
124 %************************************************************************
125
126 \begin{code}
127 instance MonadUnique SimplM where
128     getUniqueSupplyM
129        = SM (\st_env us sc -> case splitUniqSupply us of
130                                 (us1, us2) -> (us1, us2, sc))
131
132     getUniqueM
133        = SM (\st_env us sc -> case splitUniqSupply us of
134                                 (us1, us2) -> (uniqFromSupply us1, us2, sc))
135
136     getUniquesM
137         = SM (\st_env us sc -> case splitUniqSupply us of
138                                 (us1, us2) -> (uniqsFromSupply us1, us2, sc))
139
140 getDOptsSmpl :: SimplM DynFlags
141 getDOptsSmpl = SM (\st_env us sc -> (st_flags st_env, us, sc))
142
143 getRules :: SimplM RuleBase
144 getRules = SM (\st_env us sc -> (st_rules st_env, us, sc))
145
146 getFamEnvs :: SimplM (FamInstEnv, FamInstEnv)
147 getFamEnvs = SM (\st_env us sc -> (st_fams st_env, us, sc))
148
149 newId :: FastString -> Type -> SimplM Id
150 newId fs ty = do uniq <- getUniqueM
151                  return (mkSysLocal fs uniq ty)
152 \end{code}
153
154
155 %************************************************************************
156 %*                                                                      *
157 \subsection{Counting up what we've done}
158 %*                                                                      *
159 %************************************************************************
160
161 \begin{code}
162 getSimplCount :: SimplM SimplCount
163 getSimplCount = SM (\st_env us sc -> (sc, us, sc))
164
165 tick :: Tick -> SimplM ()
166 tick t 
167    = SM (\st_env us sc -> let sc' = doTick t sc 
168                           in sc' `seq` ((), us, sc'))
169
170 freeTick :: Tick -> SimplM ()
171 -- Record a tick, but don't add to the total tick count, which is
172 -- used to decide when nothing further has happened
173 freeTick t 
174    = SM (\st_env us sc -> let sc' = doFreeTick t sc
175                           in sc' `seq` ((), us, sc'))
176 \end{code}
177
178 \begin{code}
179 verboseSimplStats = opt_PprStyle_Debug          -- For now, anyway
180
181 zeroSimplCount     :: DynFlags -> SimplCount
182 isZeroSimplCount   :: SimplCount -> Bool
183 pprSimplCount      :: SimplCount -> SDoc
184 doTick, doFreeTick :: Tick -> SimplCount -> SimplCount
185 plusSimplCount     :: SimplCount -> SimplCount -> SimplCount
186 \end{code}
187
188 \begin{code}
189 data SimplCount = VerySimplZero         -- These two are used when 
190                 | VerySimplNonZero      -- we are only interested in 
191                                         -- termination info
192
193                 | SimplCount    {
194                         ticks   :: !Int,                -- Total ticks
195                         details :: !TickCounts,         -- How many of each type
196                         n_log   :: !Int,                -- N
197                         log1    :: [Tick],              -- Last N events; <= opt_HistorySize
198                         log2    :: [Tick]               -- Last opt_HistorySize events before that
199                   }
200
201 type TickCounts = FiniteMap Tick Int
202
203 zeroSimplCount dflags
204                 -- This is where we decide whether to do
205                 -- the VerySimpl version or the full-stats version
206   | dopt Opt_D_dump_simpl_stats dflags
207   = SimplCount {ticks = 0, details = emptyFM,
208                 n_log = 0, log1 = [], log2 = []}
209   | otherwise
210   = VerySimplZero
211
212 isZeroSimplCount VerySimplZero              = True
213 isZeroSimplCount (SimplCount { ticks = 0 }) = True
214 isZeroSimplCount other                      = False
215
216 doFreeTick tick sc@SimplCount { details = dts } 
217   = dts' `seqFM` sc { details = dts' }
218   where
219     dts' = dts `addTick` tick 
220 doFreeTick tick sc = sc 
221
222 -- Gross hack to persuade GHC 3.03 to do this important seq
223 seqFM fm x | isEmptyFM fm = x
224            | otherwise    = x
225
226 doTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1, log2 = l2 }
227   | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
228   | otherwise             = sc1 { n_log = nl+1, log1 = tick : l1 }
229   where
230     sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
231
232 doTick tick sc = VerySimplNonZero       -- The very simple case
233
234
235 -- Don't use plusFM_C because that's lazy, and we want to 
236 -- be pretty strict here!
237 addTick :: TickCounts -> Tick -> TickCounts
238 addTick fm tick = case lookupFM fm tick of
239                         Nothing -> addToFM fm tick 1
240                         Just n  -> n1 `seq` addToFM fm tick n1
241                                 where
242                                    n1 = n+1
243
244
245 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
246                sc2@(SimplCount { ticks = tks2, details = dts2 })
247   = log_base { ticks = tks1 + tks2, details = plusFM_C (+) dts1 dts2 }
248   where
249         -- A hackish way of getting recent log info
250     log_base | null (log1 sc2) = sc1    -- Nothing at all in sc2
251              | null (log2 sc2) = sc2 { log2 = log1 sc1 }
252              | otherwise       = sc2
253
254 plusSimplCount VerySimplZero VerySimplZero = VerySimplZero
255 plusSimplCount sc1           sc2           = VerySimplNonZero
256
257 pprSimplCount VerySimplZero    = ptext SLIT("Total ticks: ZERO!")
258 pprSimplCount VerySimplNonZero = ptext SLIT("Total ticks: NON-ZERO!")
259 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
260   = vcat [ptext SLIT("Total ticks:    ") <+> int tks,
261           text "",
262           pprTickCounts (fmToList dts),
263           if verboseSimplStats then
264                 vcat [text "",
265                       ptext SLIT("Log (most recent first)"),
266                       nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
267           else empty
268     ]
269
270 pprTickCounts :: [(Tick,Int)] -> SDoc
271 pprTickCounts [] = empty
272 pprTickCounts ((tick1,n1):ticks)
273   = vcat [int tot_n <+> text (tickString tick1),
274           pprTCDetails real_these,
275           pprTickCounts others
276     ]
277   where
278     tick1_tag           = tickToTag tick1
279     (these, others)     = span same_tick ticks
280     real_these          = (tick1,n1):these
281     same_tick (tick2,_) = tickToTag tick2 == tick1_tag
282     tot_n               = sum [n | (_,n) <- real_these]
283
284 pprTCDetails ticks@((tick,_):_)
285   | verboseSimplStats || isRuleFired tick
286   = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
287   | otherwise
288   = empty
289 \end{code}
290
291 %************************************************************************
292 %*                                                                      *
293 \subsection{Ticks}
294 %*                                                                      *
295 %************************************************************************
296
297 \begin{code}
298 data Tick
299   = PreInlineUnconditionally    Id
300   | PostInlineUnconditionally   Id
301
302   | UnfoldingDone               Id
303   | RuleFired                   FastString      -- Rule name
304
305   | LetFloatFromLet
306   | EtaExpansion                Id      -- LHS binder
307   | EtaReduction                Id      -- Binder on outer lambda
308   | BetaReduction               Id      -- Lambda binder
309
310
311   | CaseOfCase                  Id      -- Bndr on *inner* case
312   | KnownBranch                 Id      -- Case binder
313   | CaseMerge                   Id      -- Binder on outer case
314   | AltMerge                    Id      -- Case binder
315   | CaseElim                    Id      -- Case binder
316   | CaseIdentity                Id      -- Case binder
317   | FillInCaseDefault           Id      -- Case binder
318
319   | BottomFound         
320   | SimplifierDone              -- Ticked at each iteration of the simplifier
321
322 isRuleFired (RuleFired _) = True
323 isRuleFired other         = False
324
325 instance Outputable Tick where
326   ppr tick = text (tickString tick) <+> pprTickCts tick
327
328 instance Eq Tick where
329   a == b = case a `cmpTick` b of { EQ -> True; other -> False }
330
331 instance Ord Tick where
332   compare = cmpTick
333
334 tickToTag :: Tick -> Int
335 tickToTag (PreInlineUnconditionally _)  = 0
336 tickToTag (PostInlineUnconditionally _) = 1
337 tickToTag (UnfoldingDone _)             = 2
338 tickToTag (RuleFired _)                 = 3
339 tickToTag LetFloatFromLet               = 4
340 tickToTag (EtaExpansion _)              = 5
341 tickToTag (EtaReduction _)              = 6
342 tickToTag (BetaReduction _)             = 7
343 tickToTag (CaseOfCase _)                = 8
344 tickToTag (KnownBranch _)               = 9
345 tickToTag (CaseMerge _)                 = 10
346 tickToTag (CaseElim _)                  = 11
347 tickToTag (CaseIdentity _)              = 12
348 tickToTag (FillInCaseDefault _)         = 13
349 tickToTag BottomFound                   = 14
350 tickToTag SimplifierDone                = 16
351 tickToTag (AltMerge _)                  = 17
352
353 tickString :: Tick -> String
354 tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
355 tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
356 tickString (UnfoldingDone _)            = "UnfoldingDone"
357 tickString (RuleFired _)                = "RuleFired"
358 tickString LetFloatFromLet              = "LetFloatFromLet"
359 tickString (EtaExpansion _)             = "EtaExpansion"
360 tickString (EtaReduction _)             = "EtaReduction"
361 tickString (BetaReduction _)            = "BetaReduction"
362 tickString (CaseOfCase _)               = "CaseOfCase"
363 tickString (KnownBranch _)              = "KnownBranch"
364 tickString (CaseMerge _)                = "CaseMerge"
365 tickString (AltMerge _)                 = "AltMerge"
366 tickString (CaseElim _)                 = "CaseElim"
367 tickString (CaseIdentity _)             = "CaseIdentity"
368 tickString (FillInCaseDefault _)        = "FillInCaseDefault"
369 tickString BottomFound                  = "BottomFound"
370 tickString SimplifierDone               = "SimplifierDone"
371
372 pprTickCts :: Tick -> SDoc
373 pprTickCts (PreInlineUnconditionally v) = ppr v
374 pprTickCts (PostInlineUnconditionally v)= ppr v
375 pprTickCts (UnfoldingDone v)            = ppr v
376 pprTickCts (RuleFired v)                = ppr v
377 pprTickCts LetFloatFromLet              = empty
378 pprTickCts (EtaExpansion v)             = ppr v
379 pprTickCts (EtaReduction v)             = ppr v
380 pprTickCts (BetaReduction v)            = ppr v
381 pprTickCts (CaseOfCase v)               = ppr v
382 pprTickCts (KnownBranch v)              = ppr v
383 pprTickCts (CaseMerge v)                = ppr v
384 pprTickCts (AltMerge v)                 = ppr v
385 pprTickCts (CaseElim v)                 = ppr v
386 pprTickCts (CaseIdentity v)             = ppr v
387 pprTickCts (FillInCaseDefault v)        = ppr v
388 pprTickCts other                        = empty
389
390 cmpTick :: Tick -> Tick -> Ordering
391 cmpTick a b = case (tickToTag a `compare` tickToTag b) of
392                 GT -> GT
393                 EQ | isRuleFired a || verboseSimplStats -> cmpEqTick a b
394                    | otherwise                          -> EQ
395                 LT -> LT
396         -- Always distinguish RuleFired, so that the stats
397         -- can report them even in non-verbose mode
398
399 cmpEqTick :: Tick -> Tick -> Ordering
400 cmpEqTick (PreInlineUnconditionally a)  (PreInlineUnconditionally b)    = a `compare` b
401 cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b)   = a `compare` b
402 cmpEqTick (UnfoldingDone a)             (UnfoldingDone b)               = a `compare` b
403 cmpEqTick (RuleFired a)                 (RuleFired b)                   = a `compare` b
404 cmpEqTick (EtaExpansion a)              (EtaExpansion b)                = a `compare` b
405 cmpEqTick (EtaReduction a)              (EtaReduction b)                = a `compare` b
406 cmpEqTick (BetaReduction a)             (BetaReduction b)               = a `compare` b
407 cmpEqTick (CaseOfCase a)                (CaseOfCase b)                  = a `compare` b
408 cmpEqTick (KnownBranch a)               (KnownBranch b)                 = a `compare` b
409 cmpEqTick (CaseMerge a)                 (CaseMerge b)                   = a `compare` b
410 cmpEqTick (AltMerge a)                  (AltMerge b)                    = a `compare` b
411 cmpEqTick (CaseElim a)                  (CaseElim b)                    = a `compare` b
412 cmpEqTick (CaseIdentity a)              (CaseIdentity b)                = a `compare` b
413 cmpEqTick (FillInCaseDefault a)         (FillInCaseDefault b)           = a `compare` b
414 cmpEqTick other1                        other2                          = EQ
415 \end{code}
416
417
418 %************************************************************************
419 %*                                                                      *
420 \subsubsection{Command-line switches}
421 %*                                                                      *
422 %************************************************************************
423
424 \begin{code}
425 type SwitchChecker = SimplifierSwitch -> SwitchResult
426
427 data SwitchResult
428   = SwBool      Bool            -- on/off
429   | SwString    FastString      -- nothing or a String
430   | SwInt       Int             -- nothing or an Int
431
432 isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult
433 isAmongSimpl on_switches                -- Switches mentioned later occur *earlier*
434                                         -- in the list; defaults right at the end.
435   = let
436         tidied_on_switches = foldl rm_dups [] on_switches
437                 -- The fold*l* ensures that we keep the latest switches;
438                 -- ie the ones that occur earliest in the list.
439
440         sw_tbl :: Array Int SwitchResult
441         sw_tbl = (array (0, lAST_SIMPL_SWITCH_TAG) -- bounds...
442                         all_undefined)
443                  // defined_elems
444
445         all_undefined = [ (i, SwBool False) | i <- [0 .. lAST_SIMPL_SWITCH_TAG ] ]
446
447         defined_elems = map mk_assoc_elem tidied_on_switches
448     in
449     -- (avoid some unboxing, bounds checking, and other horrible things:)
450     \ switch -> unsafeAt sw_tbl $ iBox (tagOf_SimplSwitch switch)
451   where
452     mk_assoc_elem k@(MaxSimplifierIterations lvl)
453         = (iBox (tagOf_SimplSwitch k), SwInt lvl)
454     mk_assoc_elem k
455         = (iBox (tagOf_SimplSwitch k), SwBool True) -- I'm here, Mom!
456
457     -- cannot have duplicates if we are going to use the array thing
458     rm_dups switches_so_far switch
459       = if switch `is_elem` switches_so_far
460         then switches_so_far
461         else switch : switches_so_far
462       where
463         sw `is_elem` []     = False
464         sw `is_elem` (s:ss) = (tagOf_SimplSwitch sw) ==# (tagOf_SimplSwitch s)
465                             || sw `is_elem` ss
466 \end{code}
467
468 \begin{code}
469 getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
470 getSimplIntSwitch chkr switch
471   = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
472
473 switchIsOn :: (switch -> SwitchResult) -> switch -> Bool
474
475 switchIsOn lookup_fn switch
476   = case (lookup_fn switch) of
477       SwBool False -> False
478       _            -> True
479
480 intSwitchSet :: (switch -> SwitchResult)
481              -> (Int -> switch)
482              -> Maybe Int
483
484 intSwitchSet lookup_fn switch
485   = case (lookup_fn (switch (panic "intSwitchSet"))) of
486       SwInt int -> Just int
487       _         -> Nothing
488 \end{code}
489
490
491 These things behave just like enumeration types.
492
493 \begin{code}
494 instance Eq SimplifierSwitch where
495     a == b = tagOf_SimplSwitch a ==# tagOf_SimplSwitch b
496
497 instance Ord SimplifierSwitch where
498     a <  b  = tagOf_SimplSwitch a <# tagOf_SimplSwitch b
499     a <= b  = tagOf_SimplSwitch a <=# tagOf_SimplSwitch b
500
501
502 tagOf_SimplSwitch (MaxSimplifierIterations _)   = _ILIT(1)
503 tagOf_SimplSwitch NoCaseOfCase                  = _ILIT(2)
504
505 -- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
506
507 lAST_SIMPL_SWITCH_TAG = 2
508 \end{code}
509