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