Re-implement the binder-swap stuff in OccurAnal
[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 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 = VerySimplZero         -- These two are used when 
181                 | VerySimplNonZero      -- we are only interested in 
182                                         -- termination info
183
184                 | SimplCount    {
185                         ticks   :: !Int,                -- Total ticks
186                         details :: !TickCounts,         -- How many of each type
187                         n_log   :: !Int,                -- N
188                         log1    :: [Tick],              -- Last N events; <= opt_HistorySize
189                         log2    :: [Tick]               -- Last opt_HistorySize events before that
190                   }
191
192 type TickCounts = FiniteMap Tick Int
193
194 zeroSimplCount dflags
195                 -- This is where we decide whether to do
196                 -- the VerySimpl version or the full-stats version
197   | dopt Opt_D_dump_simpl_stats dflags
198   = SimplCount {ticks = 0, details = emptyFM,
199                 n_log = 0, log1 = [], log2 = []}
200   | otherwise
201   = VerySimplZero
202
203 isZeroSimplCount VerySimplZero              = True
204 isZeroSimplCount (SimplCount { ticks = 0 }) = True
205 isZeroSimplCount _                          = False
206
207 doFreeTick tick sc@SimplCount { details = dts } 
208   = sc { details = dts `addTick` tick }
209 doFreeTick _ sc = sc 
210
211 doTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 }
212   | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
213   | otherwise             = sc1 { n_log = nl+1, log1 = tick : l1 }
214   where
215     sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
216
217 doTick _ _ = VerySimplNonZero -- The very simple case
218
219
220 -- Don't use plusFM_C because that's lazy, and we want to 
221 -- be pretty strict here!
222 addTick :: TickCounts -> Tick -> TickCounts
223 addTick fm tick = case lookupFM fm tick of
224                         Nothing -> addToFM fm tick 1
225                         Just n  -> n1 `seq` addToFM fm tick n1
226                                 where
227                                    n1 = n+1
228
229
230 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
231                sc2@(SimplCount { ticks = tks2, details = dts2 })
232   = log_base { ticks = tks1 + tks2, details = plusFM_C (+) dts1 dts2 }
233   where
234         -- A hackish way of getting recent log info
235     log_base | null (log1 sc2) = sc1    -- Nothing at all in sc2
236              | null (log2 sc2) = sc2 { log2 = log1 sc1 }
237              | otherwise       = sc2
238
239 plusSimplCount VerySimplZero VerySimplZero = VerySimplZero
240 plusSimplCount _             _             = VerySimplNonZero
241
242 pprSimplCount VerySimplZero    = ptext (sLit "Total ticks: ZERO!")
243 pprSimplCount VerySimplNonZero = ptext (sLit "Total ticks: NON-ZERO!")
244 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
245   = vcat [ptext (sLit "Total ticks:    ") <+> int tks,
246           blankLine,
247           pprTickCounts (fmToList dts),
248           if verboseSimplStats then
249                 vcat [blankLine,
250                       ptext (sLit "Log (most recent first)"),
251                       nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
252           else empty
253     ]
254
255 pprTickCounts :: [(Tick,Int)] -> SDoc
256 pprTickCounts [] = empty
257 pprTickCounts ((tick1,n1):ticks)
258   = vcat [int tot_n <+> text (tickString tick1),
259           pprTCDetails real_these,
260           pprTickCounts others
261     ]
262   where
263     tick1_tag           = tickToTag tick1
264     (these, others)     = span same_tick ticks
265     real_these          = (tick1,n1):these
266     same_tick (tick2,_) = tickToTag tick2 == tick1_tag
267     tot_n               = sum [n | (_,n) <- real_these]
268
269 pprTCDetails :: [(Tick, Int)] -> SDoc
270 pprTCDetails ticks@((tick,_):_)
271   | verboseSimplStats || isRuleFired tick
272   = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
273   | otherwise
274   = empty
275 pprTCDetails [] = panic "pprTCDetails []"
276 \end{code}
277
278 %************************************************************************
279 %*                                                                      *
280 \subsection{Ticks}
281 %*                                                                      *
282 %************************************************************************
283
284 \begin{code}
285 data Tick
286   = PreInlineUnconditionally    Id
287   | PostInlineUnconditionally   Id
288
289   | UnfoldingDone               Id
290   | RuleFired                   FastString      -- Rule name
291
292   | LetFloatFromLet
293   | EtaExpansion                Id      -- LHS binder
294   | EtaReduction                Id      -- Binder on outer lambda
295   | BetaReduction               Id      -- Lambda binder
296
297
298   | CaseOfCase                  Id      -- Bndr on *inner* case
299   | KnownBranch                 Id      -- Case binder
300   | CaseMerge                   Id      -- Binder on outer case
301   | AltMerge                    Id      -- Case binder
302   | CaseElim                    Id      -- Case binder
303   | CaseIdentity                Id      -- Case binder
304   | FillInCaseDefault           Id      -- Case binder
305
306   | BottomFound         
307   | SimplifierDone              -- Ticked at each iteration of the simplifier
308
309 isRuleFired :: Tick -> Bool
310 isRuleFired (RuleFired _) = True
311 isRuleFired _             = False
312
313 instance Outputable Tick where
314   ppr tick = text (tickString tick) <+> pprTickCts tick
315
316 instance Eq Tick where
317   a == b = case a `cmpTick` b of
318            EQ -> True
319            _ -> False
320
321 instance Ord Tick where
322   compare = cmpTick
323
324 tickToTag :: Tick -> Int
325 tickToTag (PreInlineUnconditionally _)  = 0
326 tickToTag (PostInlineUnconditionally _) = 1
327 tickToTag (UnfoldingDone _)             = 2
328 tickToTag (RuleFired _)                 = 3
329 tickToTag LetFloatFromLet               = 4
330 tickToTag (EtaExpansion _)              = 5
331 tickToTag (EtaReduction _)              = 6
332 tickToTag (BetaReduction _)             = 7
333 tickToTag (CaseOfCase _)                = 8
334 tickToTag (KnownBranch _)               = 9
335 tickToTag (CaseMerge _)                 = 10
336 tickToTag (CaseElim _)                  = 11
337 tickToTag (CaseIdentity _)              = 12
338 tickToTag (FillInCaseDefault _)         = 13
339 tickToTag BottomFound                   = 14
340 tickToTag SimplifierDone                = 16
341 tickToTag (AltMerge _)                  = 17
342
343 tickString :: Tick -> String
344 tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
345 tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
346 tickString (UnfoldingDone _)            = "UnfoldingDone"
347 tickString (RuleFired _)                = "RuleFired"
348 tickString LetFloatFromLet              = "LetFloatFromLet"
349 tickString (EtaExpansion _)             = "EtaExpansion"
350 tickString (EtaReduction _)             = "EtaReduction"
351 tickString (BetaReduction _)            = "BetaReduction"
352 tickString (CaseOfCase _)               = "CaseOfCase"
353 tickString (KnownBranch _)              = "KnownBranch"
354 tickString (CaseMerge _)                = "CaseMerge"
355 tickString (AltMerge _)                 = "AltMerge"
356 tickString (CaseElim _)                 = "CaseElim"
357 tickString (CaseIdentity _)             = "CaseIdentity"
358 tickString (FillInCaseDefault _)        = "FillInCaseDefault"
359 tickString BottomFound                  = "BottomFound"
360 tickString SimplifierDone               = "SimplifierDone"
361
362 pprTickCts :: Tick -> SDoc
363 pprTickCts (PreInlineUnconditionally v) = ppr v
364 pprTickCts (PostInlineUnconditionally v)= ppr v
365 pprTickCts (UnfoldingDone v)            = ppr v
366 pprTickCts (RuleFired v)                = ppr v
367 pprTickCts LetFloatFromLet              = empty
368 pprTickCts (EtaExpansion v)             = ppr v
369 pprTickCts (EtaReduction v)             = ppr v
370 pprTickCts (BetaReduction v)            = ppr v
371 pprTickCts (CaseOfCase v)               = ppr v
372 pprTickCts (KnownBranch v)              = ppr v
373 pprTickCts (CaseMerge v)                = ppr v
374 pprTickCts (AltMerge v)                 = ppr v
375 pprTickCts (CaseElim v)                 = ppr v
376 pprTickCts (CaseIdentity v)             = ppr v
377 pprTickCts (FillInCaseDefault v)        = ppr v
378 pprTickCts _                            = empty
379
380 cmpTick :: Tick -> Tick -> Ordering
381 cmpTick a b = case (tickToTag a `compare` tickToTag b) of
382                 GT -> GT
383                 EQ | isRuleFired a || verboseSimplStats -> cmpEqTick a b
384                    | otherwise                          -> EQ
385                 LT -> LT
386         -- Always distinguish RuleFired, so that the stats
387         -- can report them even in non-verbose mode
388
389 cmpEqTick :: Tick -> Tick -> Ordering
390 cmpEqTick (PreInlineUnconditionally a)  (PreInlineUnconditionally b)    = a `compare` b
391 cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b)   = a `compare` b
392 cmpEqTick (UnfoldingDone a)             (UnfoldingDone b)               = a `compare` b
393 cmpEqTick (RuleFired a)                 (RuleFired b)                   = a `compare` b
394 cmpEqTick (EtaExpansion a)              (EtaExpansion b)                = a `compare` b
395 cmpEqTick (EtaReduction a)              (EtaReduction b)                = a `compare` b
396 cmpEqTick (BetaReduction a)             (BetaReduction b)               = a `compare` b
397 cmpEqTick (CaseOfCase a)                (CaseOfCase b)                  = a `compare` b
398 cmpEqTick (KnownBranch a)               (KnownBranch b)                 = a `compare` b
399 cmpEqTick (CaseMerge a)                 (CaseMerge b)                   = a `compare` b
400 cmpEqTick (AltMerge a)                  (AltMerge b)                    = a `compare` b
401 cmpEqTick (CaseElim a)                  (CaseElim b)                    = a `compare` b
402 cmpEqTick (CaseIdentity a)              (CaseIdentity b)                = a `compare` b
403 cmpEqTick (FillInCaseDefault a)         (FillInCaseDefault b)           = a `compare` b
404 cmpEqTick _                             _                               = EQ
405 \end{code}
406
407
408 %************************************************************************
409 %*                                                                      *
410 \subsubsection{Command-line switches}
411 %*                                                                      *
412 %************************************************************************
413
414 \begin{code}
415 type SwitchChecker = SimplifierSwitch -> SwitchResult
416
417 data SwitchResult
418   = SwBool      Bool            -- on/off
419   | SwString    FastString      -- nothing or a String
420   | SwInt       Int             -- nothing or an Int
421
422 allOffSwitchChecker :: SwitchChecker
423 allOffSwitchChecker _ = SwBool False
424
425 isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult
426 isAmongSimpl on_switches                -- Switches mentioned later occur *earlier*
427                                         -- in the list; defaults right at the end.
428   = let
429         tidied_on_switches = foldl rm_dups [] on_switches
430                 -- The fold*l* ensures that we keep the latest switches;
431                 -- ie the ones that occur earliest in the list.
432
433         sw_tbl :: Array Int SwitchResult
434         sw_tbl = (array (0, lAST_SIMPL_SWITCH_TAG) -- bounds...
435                         all_undefined)
436                  // defined_elems
437
438         all_undefined = [ (i, SwBool False) | i <- [0 .. lAST_SIMPL_SWITCH_TAG ] ]
439
440         defined_elems = map mk_assoc_elem tidied_on_switches
441     in
442     -- (avoid some unboxing, bounds checking, and other horrible things:)
443     \ switch -> unsafeAt sw_tbl $ iBox (tagOf_SimplSwitch switch)
444   where
445     mk_assoc_elem k@(MaxSimplifierIterations lvl)
446         = (iBox (tagOf_SimplSwitch k), SwInt lvl)
447     mk_assoc_elem k
448         = (iBox (tagOf_SimplSwitch k), SwBool True) -- I'm here, Mom!
449
450     -- cannot have duplicates if we are going to use the array thing
451     rm_dups switches_so_far switch
452       = if switch `is_elem` switches_so_far
453         then switches_so_far
454         else switch : switches_so_far
455       where
456         _  `is_elem` []     = False
457         sw `is_elem` (s:ss) = (tagOf_SimplSwitch sw) ==# (tagOf_SimplSwitch s)
458                             || sw `is_elem` ss
459 \end{code}
460
461 \begin{code}
462 getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
463 getSimplIntSwitch chkr switch
464   = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
465
466 switchIsOn :: (switch -> SwitchResult) -> switch -> Bool
467
468 switchIsOn lookup_fn switch
469   = case (lookup_fn switch) of
470       SwBool False -> False
471       _            -> True
472
473 intSwitchSet :: (switch -> SwitchResult)
474              -> (Int -> switch)
475              -> Maybe Int
476
477 intSwitchSet lookup_fn switch
478   = case (lookup_fn (switch (panic "intSwitchSet"))) of
479       SwInt int -> Just int
480       _         -> Nothing
481 \end{code}
482
483
484 These things behave just like enumeration types.
485
486 \begin{code}
487 instance Eq SimplifierSwitch where
488     a == b = tagOf_SimplSwitch a ==# tagOf_SimplSwitch b
489
490 instance Ord SimplifierSwitch where
491     a <  b  = tagOf_SimplSwitch a <# tagOf_SimplSwitch b
492     a <= b  = tagOf_SimplSwitch a <=# tagOf_SimplSwitch b
493
494
495 tagOf_SimplSwitch :: SimplifierSwitch -> FastInt
496 tagOf_SimplSwitch (MaxSimplifierIterations _)   = _ILIT(1)
497 tagOf_SimplSwitch NoCaseOfCase                  = _ILIT(2)
498
499 -- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
500
501 lAST_SIMPL_SWITCH_TAG :: Int
502 lAST_SIMPL_SWITCH_TAG = 2
503 \end{code}
504