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
  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           text "",
 247           pprTickCounts (fmToList dts),
 248           if verboseSimplStats then
 249                 vcat [text "",
 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 isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult
 423 isAmongSimpl on_switches                -- Switches mentioned later occur *earlier*
 424                                         -- in the list; defaults right at the end.
 425   = let
 426         tidied_on_switches = foldl rm_dups [] on_switches
 427                 -- The fold*l* ensures that we keep the latest switches;
 428                 -- ie the ones that occur earliest in the list.
 429
 430         sw_tbl :: Array Int SwitchResult
 431         sw_tbl = (array (0, lAST_SIMPL_SWITCH_TAG) -- bounds...
 432                         all_undefined)
 433                  // defined_elems
 434
 435         all_undefined = [ (i, SwBool False) | i <- [0 .. lAST_SIMPL_SWITCH_TAG ] ]
 436
 437         defined_elems = map mk_assoc_elem tidied_on_switches
 438     in
 439     -- (avoid some unboxing, bounds checking, and other horrible things:)
 440     \ switch -> unsafeAt sw_tbl $ iBox (tagOf_SimplSwitch switch)
 441   where
 442     mk_assoc_elem k@(MaxSimplifierIterations lvl)
 443         = (iBox (tagOf_SimplSwitch k), SwInt lvl)
 444     mk_assoc_elem k
 445         = (iBox (tagOf_SimplSwitch k), SwBool True) -- I'm here, Mom!
 446
 447     -- cannot have duplicates if we are going to use the array thing
 448     rm_dups switches_so_far switch
 449       = if switch `is_elem` switches_so_far
 450         then switches_so_far
 451         else switch : switches_so_far
 452       where
 453         _  `is_elem` []     = False
 454         sw `is_elem` (s:ss) = (tagOf_SimplSwitch sw) ==# (tagOf_SimplSwitch s)
 455                             || sw `is_elem` ss
 456 \end{code}
 457
 458 \begin{code}
 459 getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
 460 getSimplIntSwitch chkr switch
 461   = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
 462
 463 switchIsOn :: (switch -> SwitchResult) -> switch -> Bool
 464
 465 switchIsOn lookup_fn switch
 466   = case (lookup_fn switch) of
 467       SwBool False -> False
 468       _            -> True
 469
 470 intSwitchSet :: (switch -> SwitchResult)
 471              -> (Int -> switch)
 472              -> Maybe Int
 473
 474 intSwitchSet lookup_fn switch
 475   = case (lookup_fn (switch (panic "intSwitchSet"))) of
 476       SwInt int -> Just int
 477       _         -> Nothing
 478 \end{code}
 479
 480
 481 These things behave just like enumeration types.
 482
 483 \begin{code}
 484 instance Eq SimplifierSwitch where
 485     a == b = tagOf_SimplSwitch a ==# tagOf_SimplSwitch b
 486
 487 instance Ord SimplifierSwitch where
 488     a <  b  = tagOf_SimplSwitch a <# tagOf_SimplSwitch b
 489     a <= b  = tagOf_SimplSwitch a <=# tagOf_SimplSwitch b
 490
 491
 492 tagOf_SimplSwitch :: SimplifierSwitch -> FastInt
 493 tagOf_SimplSwitch (MaxSimplifierIterations _)   = _ILIT(1)
 494 tagOf_SimplSwitch NoCaseOfCase                  = _ILIT(2)
 495
 496 -- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
 497
 498 lAST_SIMPL_SWITCH_TAG :: Int
 499 lAST_SIMPL_SWITCH_TAG = 2
 500 \end{code}
 501