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