ghc/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, returnSmpl, thenSmpl, thenSmpl_,
  11         mapSmpl, mapAndUnzipSmpl, mapAccumLSmpl,
  12         getDOptsSmpl,
  13
  14         -- Unique supply
  15         getUniqueSmpl, getUniquesSmpl, getUniqSupplySmpl, newId,
  16
  17         -- Counting
  18         SimplCount, Tick(..),
  19         tick, freeTick,
  20         getSimplCount, zeroSimplCount, pprSimplCount,
  21         plusSimplCount, isZeroSimplCount,
  22
  23         -- Switch checker
  24         SwitchChecker, SwitchResult(..), getSimplIntSwitch,
  25         isAmongSimpl, intSwitchSet, switchIsOn
  26     ) where
  27
  28 #include "HsVersions.h"
  29
  30 import Id               ( Id, mkSysLocal )
  31 import Type             ( Type )
  32 import UniqSupply       ( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
  33                           UniqSupply
  34                         )
  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 )
  42 import Outputable
  43 import FastTypes
  44
  45 import GLAEXTS          ( indexArray# )
  46
  47 #if __GLASGOW_HASKELL__ < 503
  48 import PrelArr  ( Array(..) )
  49 #else
  50 import GHC.Arr  ( Array(..) )
  51 #endif
  52
  53 import Array            ( array, (//) )
  54
  55 infixr 0  `thenSmpl`, `thenSmpl_`
  56 \end{code}
  57
  58 %************************************************************************
  59 %*                                                                      *
  60 \subsection{Monad plumbing}
  61 %*                                                                      *
  62 %************************************************************************
  63
  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.)
  66
  67 \begin{code}
  68 newtype SimplM result
  69   =  SM  { unSM :: DynFlags             -- We thread the unique supply because
  70                    -> UniqSupply        -- constantly splitting it is rather expensive
  71                    -> SimplCount
  72                    -> (result, UniqSupply, SimplCount)}
  73 \end{code}
  74
  75 \begin{code}
  76 initSmpl :: DynFlags
  77          -> UniqSupply          -- No init count; set to 0
  78          -> SimplM a
  79          -> (a, SimplCount)
  80
  81 initSmpl dflags us m
  82   = case unSM m dflags us (zeroSimplCount dflags) of
  83         (result, _, count) -> (result, count)
  84
  85
  86 {-# INLINE thenSmpl #-}
  87 {-# INLINE thenSmpl_ #-}
  88 {-# INLINE returnSmpl #-}
  89
  90 instance Monad SimplM where
  91    (>>)   = thenSmpl_
  92    (>>=)  = thenSmpl
  93    return = returnSmpl
  94
  95 returnSmpl :: a -> SimplM a
  96 returnSmpl e = SM (\ dflags us sc -> (e, us, sc))
  97
  98 thenSmpl  :: SimplM a -> (a -> SimplM b) -> SimplM b
  99 thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
 100
 101 thenSmpl m k
 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 )
 105
 106 thenSmpl_ m k
 107   = SM (\dflags us0 sc0 ->
 108          case (unSM m dflags us0 sc0) of
 109                 (_, us1, sc1) -> unSM k dflags us1 sc1)
 110 \end{code}
 111
 112
 113 \begin{code}
 114 mapSmpl         :: (a -> SimplM b) -> [a] -> SimplM [b]
 115 mapAndUnzipSmpl :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c])
 116
 117 mapSmpl f [] = returnSmpl []
 118 mapSmpl f (x:xs)
 119   = f x             `thenSmpl` \ x'  ->
 120     mapSmpl f xs    `thenSmpl` \ xs' ->
 121     returnSmpl (x':xs')
 122
 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)
 128
 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')
 134 \end{code}
 135
 136
 137 %************************************************************************
 138 %*                                                                      *
 139 \subsection{The unique supply}
 140 %*                                                                      *
 141 %************************************************************************
 142
 143 \begin{code}
 144 getUniqSupplySmpl :: SimplM UniqSupply
 145 getUniqSupplySmpl
 146    = SM (\dflags us sc -> case splitUniqSupply us of
 147                                 (us1, us2) -> (us1, us2, sc))
 148
 149 getUniqueSmpl :: SimplM Unique
 150 getUniqueSmpl
 151    = SM (\dflags us sc -> case splitUniqSupply us of
 152                                 (us1, us2) -> (uniqFromSupply us1, us2, sc))
 153
 154 getUniquesSmpl :: SimplM [Unique]
 155 getUniquesSmpl
 156    = SM (\dflags us sc -> case splitUniqSupply us of
 157                                 (us1, us2) -> (uniqsFromSupply us1, us2, sc))
 158
 159 getDOptsSmpl :: SimplM DynFlags
 160 getDOptsSmpl
 161    = SM (\dflags us sc -> (dflags, us, sc))
 162
 163 newId :: EncodedFS -> Type -> SimplM Id
 164 newId fs ty = getUniqueSmpl     `thenSmpl` \ uniq ->
 165               returnSmpl (mkSysLocal fs uniq ty)
 166 \end{code}
 167
 168
 169 %************************************************************************
 170 %*                                                                      *
 171 \subsection{Counting up what we've done}
 172 %*                                                                      *
 173 %************************************************************************
 174
 175 \begin{code}
 176 getSimplCount :: SimplM SimplCount
 177 getSimplCount = SM (\dflags us sc -> (sc, us, sc))
 178
 179 tick :: Tick -> SimplM ()
 180 tick t
 181    = SM (\dflags us sc -> let sc' = doTick t sc
 182                           in sc' `seq` ((), us, sc'))
 183
 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
 187 freeTick t
 188    = SM (\dflags us sc -> let sc' = doFreeTick t sc
 189                           in sc' `seq` ((), us, sc'))
 190 \end{code}
 191
 192 \begin{code}
 193 verboseSimplStats = opt_PprStyle_Debug          -- For now, anyway
 194
 195 zeroSimplCount     :: DynFlags -> SimplCount
 196 isZeroSimplCount   :: SimplCount -> Bool
 197 pprSimplCount      :: SimplCount -> SDoc
 198 doTick, doFreeTick :: Tick -> SimplCount -> SimplCount
 199 plusSimplCount     :: SimplCount -> SimplCount -> SimplCount
 200 \end{code}
 201
 202 \begin{code}
 203 data SimplCount = VerySimplZero         -- These two are used when
 204                 | VerySimplNonZero      -- we are only interested in
 205                                         -- termination info
 206
 207                 | SimplCount    {
 208                         ticks   :: !Int,                -- Total ticks
 209                         details :: !TickCounts,         -- How many of each type
 210                         n_log   :: !Int,                -- N
 211                         log1    :: [Tick],              -- Last N events; <= opt_HistorySize
 212                         log2    :: [Tick]               -- Last opt_HistorySize events before that
 213                   }
 214
 215 type TickCounts = FiniteMap Tick Int
 216
 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 = []}
 223   | otherwise
 224   = VerySimplZero
 225
 226 isZeroSimplCount VerySimplZero              = True
 227 isZeroSimplCount (SimplCount { ticks = 0 }) = True
 228 isZeroSimplCount other                      = False
 229
 230 doFreeTick tick sc@SimplCount { details = dts }
 231   = dts' `seqFM` sc { details = dts' }
 232   where
 233     dts' = dts `addTick` tick
 234 doFreeTick tick sc = sc
 235
 236 -- Gross hack to persuade GHC 3.03 to do this important seq
 237 seqFM fm x | isEmptyFM fm = x
 238            | otherwise    = x
 239
 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 }
 243   where
 244     sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
 245
 246 doTick tick sc = VerySimplNonZero       -- The very simple case
 247
 248
 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
 255                                 where
 256                                    n1 = n+1
 257
 258
 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 }
 262   where
 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 }
 266              | otherwise       = sc2
 267
 268 plusSimplCount VerySimplZero VerySimplZero = VerySimplZero
 269 plusSimplCount sc1           sc2           = VerySimplNonZero
 270
 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,
 275           text "",
 276           pprTickCounts (fmToList dts),
 277           if verboseSimplStats then
 278                 vcat [text "",
 279                       ptext SLIT("Log (most recent first)"),
 280                       nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
 281           else empty
 282     ]
 283
 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,
 289           pprTickCounts others
 290     ]
 291   where
 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]
 297
 298 pprTCDetails ticks@((tick,_):_)
 299   | verboseSimplStats || isRuleFired tick
 300   = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
 301   | otherwise
 302   = empty
 303 \end{code}
 304
 305 %************************************************************************
 306 %*                                                                      *
 307 \subsection{Ticks}
 308 %*                                                                      *
 309 %************************************************************************
 310
 311 \begin{code}
 312 data Tick
 313   = PreInlineUnconditionally    Id
 314   | PostInlineUnconditionally   Id
 315
 316   | UnfoldingDone               Id
 317   | RuleFired                   FastString      -- Rule name
 318
 319   | LetFloatFromLet
 320   | EtaExpansion                Id      -- LHS binder
 321   | EtaReduction                Id      -- Binder on outer lambda
 322   | BetaReduction               Id      -- Lambda binder
 323
 324
 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
 332
 333   | BottomFound
 334   | SimplifierDone              -- Ticked at each iteration of the simplifier
 335
 336 isRuleFired (RuleFired _) = True
 337 isRuleFired other         = False
 338
 339 instance Outputable Tick where
 340   ppr tick = text (tickString tick) <+> pprTickCts tick
 341
 342 instance Eq Tick where
 343   a == b = case a `cmpTick` b of { EQ -> True; other -> False }
 344
 345 instance Ord Tick where
 346   compare = cmpTick
 347
 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
 366
 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"
 385
 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
 403
 404 cmpTick :: Tick -> Tick -> Ordering
 405 cmpTick a b = case (tickToTag a `compare` tickToTag b) of
 406                 GT -> GT
 407                 EQ | isRuleFired a || verboseSimplStats -> cmpEqTick a b
 408                    | otherwise                          -> EQ
 409                 LT -> LT
 410         -- Always distinguish RuleFired, so that the stats
 411         -- can report them even in non-verbose mode
 412
 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
 429 \end{code}
 430
 431
 432 %************************************************************************
 433 %*                                                                      *
 434 \subsubsection{Command-line switches}
 435 %*                                                                      *
 436 %************************************************************************
 437
 438 \begin{code}
 439 type SwitchChecker = SimplifierSwitch -> SwitchResult
 440
 441 data SwitchResult
 442   = SwBool      Bool            -- on/off
 443   | SwString    FastString      -- nothing or a String
 444   | SwInt       Int             -- nothing or an Int
 445
 446 isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult
 447 isAmongSimpl on_switches                -- Switches mentioned later occur *earlier*
 448                                         -- in the list; defaults right at the end.
 449   = let
 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.
 453
 454         sw_tbl :: Array Int SwitchResult
 455         sw_tbl = (array (0, lAST_SIMPL_SWITCH_TAG) -- bounds...
 456                         all_undefined)
 457                  // defined_elems
 458
 459         all_undefined = [ (i, SwBool False) | i <- [0 .. lAST_SIMPL_SWITCH_TAG ] ]
 460
 461         defined_elems = map mk_assoc_elem tidied_on_switches
 462     in
 463     -- (avoid some unboxing, bounds checking, and other horrible things:)
 464     case sw_tbl of { Array _ _ stuff ->
 465     \ switch ->
 466         case (indexArray# stuff (tagOf_SimplSwitch switch)) of
 467           (# v #) -> v
 468     }
 469   where
 470     mk_assoc_elem k@(MaxSimplifierIterations lvl)
 471         = (iBox (tagOf_SimplSwitch k), SwInt lvl)
 472     mk_assoc_elem k
 473         = (iBox (tagOf_SimplSwitch k), SwBool True) -- I'm here, Mom!
 474
 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
 478         then switches_so_far
 479         else switch : switches_so_far
 480       where
 481         sw `is_elem` []     = False
 482         sw `is_elem` (s:ss) = (tagOf_SimplSwitch sw) ==# (tagOf_SimplSwitch s)
 483                             || sw `is_elem` ss
 484 \end{code}
 485
 486 \begin{code}
 487 getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
 488 getSimplIntSwitch chkr switch
 489   = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
 490
 491 switchIsOn :: (switch -> SwitchResult) -> switch -> Bool
 492
 493 switchIsOn lookup_fn switch
 494   = case (lookup_fn switch) of
 495       SwBool False -> False
 496       _            -> True
 497
 498 intSwitchSet :: (switch -> SwitchResult)
 499              -> (Int -> switch)
 500              -> Maybe Int
 501
 502 intSwitchSet lookup_fn switch
 503   = case (lookup_fn (switch (panic "intSwitchSet"))) of
 504       SwInt int -> Just int
 505       _         -> Nothing
 506 \end{code}
 507
 508
 509 These things behave just like enumeration types.
 510
 511 \begin{code}
 512 instance Eq SimplifierSwitch where
 513     a == b = tagOf_SimplSwitch a ==# tagOf_SimplSwitch b
 514
 515 instance Ord SimplifierSwitch where
 516     a <  b  = tagOf_SimplSwitch a <# tagOf_SimplSwitch b
 517     a <= b  = tagOf_SimplSwitch a <=# tagOf_SimplSwitch b
 518
 519
 520 tagOf_SimplSwitch (MaxSimplifierIterations _)   = _ILIT(1)
 521 tagOf_SimplSwitch NoCaseOfCase                  = _ILIT(2)
 522
 523 -- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
 524
 525 lAST_SIMPL_SWITCH_TAG = 2
 526 \end{code}
 527