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