CoreMonad.hs 30.7 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3
{-
(c) The AQUA Project, Glasgow University, 1993-1998

4
\section[CoreMonad]{The core pipeline monad}
Austin Seipp's avatar
Austin Seipp committed
5
-}
6

7
{-# LANGUAGE CPP #-}
8
{-# LANGUAGE DeriveFunctor #-}
Ian Lynagh's avatar
Ian Lynagh committed
9

10
module CoreMonad (
11
    -- * Configuration of the core-to-core passes
12
    CoreToDo(..), runWhen, runMaybe,
13
    SimplMode(..),
14
    FloatOutSwitches(..),
15
    pprPassDetails,
16 17

    -- * Plugins
18
    CorePluginPass, bindsOnlyPass,
19 20

    -- * Counting
21
    SimplCount, doSimplTick, doFreeSimplTick, simplCountN,
22
    pprSimplCount, plusSimplCount, zeroSimplCount,
23
    isZeroSimplCount, hasDetailedCounts, Tick(..),
24

25 26
    -- * The monad
    CoreM, runCoreM,
27

28
    -- ** Reading from the monad
29
    getHscEnv, getRuleBase, getModule,
30
    getDynFlags, getOrigNameCache, getPackageFamInstEnv,
31
    getVisibleOrphanMods, getUniqMask,
32
    getPrintUnqualified, getSrcSpanM,
33

34 35
    -- ** Writing to the monad
    addSimplCount,
36

37 38
    -- ** Lifting into the monad
    liftIO, liftIOWithCount,
39

40
    -- ** Dealing with annotations
41
    getAnnotations, getFirstAnnotations,
42

43
    -- ** Screen output
44
    putMsg, putMsgS, errorMsg, errorMsgS, warnMsg,
45
    fatalErrorMsg, fatalErrorMsgS,
46
    debugTraceMsg, debugTraceMsgS,
47
    dumpIfSet_dyn
48 49
  ) where

50 51
import GhcPrelude hiding ( read )

52
import CoreSyn
53
import HscTypes
54
import Module
55
import DynFlags
56
import BasicTypes       ( CompilerPhase(..) )
57 58 59 60
import Annotations

import IOEnv hiding     ( liftIO, failM, failWithM )
import qualified IOEnv  ( liftIO )
61
import Var
62
import Outputable
63
import FastString
64
import qualified ErrUtils as Err
65
import ErrUtils( Severity(..) )
66
import UniqSupply
67
import UniqFM       ( UniqFM, mapUFM, filterUFM )
68
import MonadUtils
69
import NameCache
70
import SrcLoc
Ian Lynagh's avatar
Ian Lynagh committed
71 72
import Data.List
import Data.Ord
73 74
import Data.Dynamic
import Data.IORef
75 76
import Data.Map (Map)
import qualified Data.Map as Map
77
import qualified Data.Map.Strict as MapStrict
78 79
import Data.Word
import Control.Monad
80
import Control.Applicative ( Alternative(..) )
81
import Panic (throwGhcException, GhcException(..))
82

Austin Seipp's avatar
Austin Seipp committed
83 84 85
{-
************************************************************************
*                                                                      *
86
              The CoreToDo type and related types
87
          Abstraction of core-to-core passes to run.
Austin Seipp's avatar
Austin Seipp committed
88 89 90
*                                                                      *
************************************************************************
-}
91

92 93 94 95 96
data CoreToDo           -- These are diff core-to-core passes,
                        -- which may be invoked in any order,
                        -- as many times as you like.

  = CoreDoSimplify      -- The core-to-core simplifier.
97
        Int                    -- Max iterations
98
        SimplMode
99
  | CoreDoPluginPass String CorePluginPass
100 101 102 103 104
  | CoreDoFloatInwards
  | CoreDoFloatOutwards FloatOutSwitches
  | CoreLiberateCase
  | CoreDoPrintCore
  | CoreDoStaticArgs
105
  | CoreDoCallArity
106
  | CoreDoExitify
107 108 109 110 111 112 113 114 115 116
  | CoreDoStrictness
  | CoreDoWorkerWrapper
  | CoreDoSpecialising
  | CoreDoSpecConstr
  | CoreCSE
  | CoreDoRuleCheck CompilerPhase String   -- Check for non-application of rules
                                           -- matching this string
  | CoreDoNothing                -- Useful when building up
  | CoreDoPasses [CoreToDo]      -- lists of these things

117 118 119
  | CoreDesugar    -- Right after desugaring, no simple optimisation yet!
  | CoreDesugarOpt -- CoreDesugarXXX: Not strictly a core-to-core pass, but produces
                       --                 Core output, and hence useful to pass to endPass
120 121 122

  | CoreTidy
  | CorePrep
lukemaurer's avatar
lukemaurer committed
123
  | CoreOccurAnal
124 125

instance Outputable CoreToDo where
126 127 128 129 130 131 132
  ppr (CoreDoSimplify _ _)     = text "Simplifier"
  ppr (CoreDoPluginPass s _)   = text "Core plugin: " <+> text s
  ppr CoreDoFloatInwards       = text "Float inwards"
  ppr (CoreDoFloatOutwards f)  = text "Float out" <> parens (ppr f)
  ppr CoreLiberateCase         = text "Liberate case"
  ppr CoreDoStaticArgs         = text "Static argument"
  ppr CoreDoCallArity          = text "Called arity analysis"
133
  ppr CoreDoExitify            = text "Exitification transformation"
134 135 136 137 138 139 140 141 142
  ppr CoreDoStrictness         = text "Demand analysis"
  ppr CoreDoWorkerWrapper      = text "Worker Wrapper binds"
  ppr CoreDoSpecialising       = text "Specialise"
  ppr CoreDoSpecConstr         = text "SpecConstr"
  ppr CoreCSE                  = text "Common sub-expression"
  ppr CoreDesugar              = text "Desugar (before optimization)"
  ppr CoreDesugarOpt           = text "Desugar (after optimization)"
  ppr CoreTidy                 = text "Tidy Core"
  ppr CorePrep                 = text "CorePrep"
lukemaurer's avatar
lukemaurer committed
143
  ppr CoreOccurAnal            = text "Occurrence analysis"
144 145 146 147
  ppr CoreDoPrintCore          = text "Print core"
  ppr (CoreDoRuleCheck {})     = text "Rule check"
  ppr CoreDoNothing            = text "CoreDoNothing"
  ppr (CoreDoPasses passes)    = text "CoreDoPasses" <+> ppr passes
148 149

pprPassDetails :: CoreToDo -> SDoc
150
pprPassDetails (CoreDoSimplify n md) = vcat [ text "Max iterations =" <+> int n
151
                                            , ppr md ]
152
pprPassDetails _ = Outputable.empty
153

154
data SimplMode             -- See comments in SimplMonad
155 156 157
  = SimplMode
        { sm_names      :: [String] -- Name(s) of the phase
        , sm_phase      :: CompilerPhase
158 159
        , sm_dflags     :: DynFlags -- Just for convenient non-monadic
                                    -- access; we don't override these
160 161 162 163 164
        , sm_rules      :: Bool     -- Whether RULES are enabled
        , sm_inline     :: Bool     -- Whether inlining is enabled
        , sm_case_case  :: Bool     -- Whether case-of-case is enabled
        , sm_eta_expand :: Bool     -- Whether eta-expansion is enabled
        }
165

166
instance Outputable SimplMode where
167 168 169
    ppr (SimplMode { sm_phase = p, sm_names = ss
                   , sm_rules = r, sm_inline = i
                   , sm_eta_expand = eta, sm_case_case = cc })
170 171
       = text "SimplMode" <+> braces (
         sep [ text "Phase =" <+> ppr p <+>
172 173 174 175 176
               brackets (text (concat $ intersperse "," ss)) <> comma
             , pp_flag i   (sLit "inline") <> comma
             , pp_flag r   (sLit "rules") <> comma
             , pp_flag eta (sLit "eta-expand") <> comma
             , pp_flag cc  (sLit "case-of-case") ])
177
         where
178
           pp_flag f s = ppUnless f (text "no") <+> ptext s
179 180

data FloatOutSwitches = FloatOutSwitches {
181
  floatOutLambdas   :: Maybe Int,  -- ^ Just n <=> float lambdas to top level, if
182
                                   -- doing so will abstract over n or fewer
183
                                   -- value variables
184
                                   -- Nothing <=> float all lambdas to top level,
185 186 187 188 189 190
                                   --             regardless of how many free variables
                                   -- Just 0 is the vanilla case: float a lambda
                                   --    iff it has no free vars

  floatOutConstants :: Bool,       -- ^ True <=> float constants to top level,
                                   --            even if they do not escape a lambda
191 192 193 194 195 196
  floatOutOverSatApps :: Bool,
                             -- ^ True <=> float out over-saturated applications
                             --            based on arity information.
                             -- See Note [Floating over-saturated applications]
                             -- in SetLevels
  floatToTopLevelOnly :: Bool      -- ^ Allow floating to the top level only.
197
  }
198 199 200 201
instance Outputable FloatOutSwitches where
    ppr = pprFloatOutSwitches

pprFloatOutSwitches :: FloatOutSwitches -> SDoc
202
pprFloatOutSwitches sw
203
  = text "FOS" <+> (braces $
204
     sep $ punctuate comma $
205 206 207
     [ text "Lam ="    <+> ppr (floatOutLambdas sw)
     , text "Consts =" <+> ppr (floatOutConstants sw)
     , text "OverSatApps ="   <+> ppr (floatOutOverSatApps sw) ])
208 209 210 211 212 213 214 215 216 217

-- The core-to-core pass ordering is derived from the DynFlags:
runWhen :: Bool -> CoreToDo -> CoreToDo
runWhen True  do_this = do_this
runWhen False _       = CoreDoNothing

runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo
runMaybe (Just x) f = f x
runMaybe Nothing  _ = CoreDoNothing

Austin Seipp's avatar
Austin Seipp committed
218
{-
219

Austin Seipp's avatar
Austin Seipp committed
220 221
************************************************************************
*                                                                      *
222
             Types for Plugins
Austin Seipp's avatar
Austin Seipp committed
223 224 225
*                                                                      *
************************************************************************
-}
226 227

-- | A description of the plugin pass itself
228
type CorePluginPass = ModGuts -> CoreM ModGuts
229

230
bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts
231 232 233 234
bindsOnlyPass pass guts
  = do { binds' <- pass (mg_binds guts)
       ; return (guts { mg_binds = binds' }) }

Austin Seipp's avatar
Austin Seipp committed
235 236 237
{-
************************************************************************
*                                                                      *
238
             Counting and logging
Austin Seipp's avatar
Austin Seipp committed
239 240 241
*                                                                      *
************************************************************************
-}
242

Sylvain Henry's avatar
Sylvain Henry committed
243
getVerboseSimplStats :: (Bool -> SDoc) -> SDoc
Simon Peyton Jones's avatar
Simon Peyton Jones committed
244
getVerboseSimplStats = getPprDebug          -- For now, anyway
245

246
zeroSimplCount     :: DynFlags -> SimplCount
247
isZeroSimplCount   :: SimplCount -> Bool
248
hasDetailedCounts  :: SimplCount -> Bool
249
pprSimplCount      :: SimplCount -> SDoc
250 251
doSimplTick        :: DynFlags -> Tick -> SimplCount -> SimplCount
doFreeSimplTick    ::             Tick -> SimplCount -> SimplCount
252 253
plusSimplCount     :: SimplCount -> SimplCount -> SimplCount

254 255 256 257 258 259 260 261 262 263 264 265 266
data SimplCount
   = VerySimplCount !Int        -- Used when don't want detailed stats

   | SimplCount {
        ticks   :: !Int,        -- Total ticks
        details :: !TickCounts, -- How many of each type

        n_log   :: !Int,        -- N
        log1    :: [Tick],      -- Last N events; <= opt_HistorySize,
                                --   most recent first
        log2    :: [Tick]       -- Last opt_HistorySize events before that
                                -- Having log1, log2 lets us accumulate the
                                -- recent history reasonably efficiently
267 268
     }

269
type TickCounts = Map Tick Int
270

271 272 273 274
simplCountN :: SimplCount -> Int
simplCountN (VerySimplCount n)         = n
simplCountN (SimplCount { ticks = n }) = n

275
zeroSimplCount dflags
276 277
                -- This is where we decide whether to do
                -- the VerySimpl version or the full-stats version
278
  | dopt Opt_D_dump_simpl_stats dflags
279
  = SimplCount {ticks = 0, details = Map.empty,
280 281
                n_log = 0, log1 = [], log2 = []}
  | otherwise
282
  = VerySimplCount 0
283

284
isZeroSimplCount (VerySimplCount n)         = n==0
285
isZeroSimplCount (SimplCount { ticks = n }) = n==0
286

287 288 289
hasDetailedCounts (VerySimplCount {}) = False
hasDetailedCounts (SimplCount {})     = True

290
doFreeSimplTick tick sc@SimplCount { details = dts }
291
  = sc { details = dts `addTick` tick }
292
doFreeSimplTick _ sc = sc
293

294 295 296 297
doSimplTick dflags tick
    sc@(SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 })
  | nl >= historySize dflags = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
  | otherwise                = sc1 { n_log = nl+1, log1 = tick : l1 }
298 299 300
  where
    sc1 = sc { ticks = tks+1, details = dts `addTick` tick }

301
doSimplTick _ _ (VerySimplCount n) = VerySimplCount (n+1)
302 303 304


addTick :: TickCounts -> Tick -> TickCounts
305
addTick fm tick = MapStrict.insertWith (+) tick 1 fm
306 307

plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
308
               sc2@(SimplCount { ticks = tks2, details = dts2 })
309 310
  = log_base { ticks = tks1 + tks2
             , details = MapStrict.unionWith (+) dts1 dts2 }
311
  where
312 313 314 315
        -- A hackish way of getting recent log info
    log_base | null (log1 sc2) = sc1    -- Nothing at all in sc2
             | null (log2 sc2) = sc2 { log2 = log1 sc1 }
             | otherwise       = sc2
316

317
plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m)
318 319 320 321 322 323 324
plusSimplCount lhs                rhs                =
  throwGhcException . PprProgramError "plusSimplCount" $ vcat
    [ text "lhs"
    , pprSimplCount lhs
    , text "rhs"
    , pprSimplCount rhs
    ]
325
       -- We use one or the other consistently
326

327
pprSimplCount (VerySimplCount n) = text "Total ticks:" <+> int n
328
pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
329
  = vcat [text "Total ticks:    " <+> int tks,
330 331
          blankLine,
          pprTickCounts dts,
Sylvain Henry's avatar
Sylvain Henry committed
332 333
          getVerboseSimplStats $ \dbg -> if dbg
          then
334
                vcat [blankLine,
335
                      text "Log (most recent first)",
336 337
                      nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
          else Outputable.empty
338 339
    ]

340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412
{- Note [Which transformations are innocuous]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
At one point (Jun 18) I wondered if some transformations (ticks)
might be  "innocuous", in the sense that they do not unlock a later
transformation that does not occur in the same pass.  If so, we could
refrain from bumping the overall tick-count for such innocuous
transformations, and perhaps terminate the simplifier one pass
earlier.

BUt alas I found that virtually nothing was innocuous!  This Note
just records what I learned, in case anyone wants to try again.

These transformations are not innocuous:

*** NB: I think these ones could be made innocuous
          EtaExpansion
          LetFloatFromLet

LetFloatFromLet
    x = K (let z = e2 in Just z)
  prepareRhs transforms to
    x2 = let z=e2 in Just z
    x  = K xs
  And now more let-floating can happen in the
  next pass, on x2

PreInlineUnconditionally
  Example in spectral/cichelli/Auxil
     hinsert = ...let lo = e in
                  let j = ...lo... in
                  case x of
                    False -> ()
                    True -> case lo of I# lo' ->
                              ...j...
  When we PreInlineUnconditionally j, lo's occ-info changes to once,
  so it can be PreInlineUnconditionally in the next pass, and a
  cascade of further things can happen.

PostInlineUnconditionally
  let x = e in
  let y = ...x.. in
  case .. of { A -> ...x...y...
               B -> ...x...y... }
  Current postinlineUnconditinaly will inline y, and then x; sigh.

  But PostInlineUnconditionally might also unlock subsequent
  transformations for the same reason as PreInlineUnconditionally,
  so it's probably not innocuous anyway.

KnownBranch, BetaReduction:
  May drop chunks of code, and thereby enable PreInlineUnconditionally
  for some let-binding which now occurs once

EtaExpansion:
  Example in imaginary/digits-of-e1
    fail = \void. e          where e :: IO ()
  --> etaExpandRhs
    fail = \void. (\s. (e |> g) s) |> sym g      where g :: IO () ~ S -> (S,())
  --> Next iteration of simplify
    fail1 = \void. \s. (e |> g) s
    fail = fail1 |> Void#->sym g
  And now inline 'fail'

CaseMerge:
  case x of y {
    DEFAULT -> case y of z { pi -> ei }
    alts2 }
  ---> CaseMerge
    case x of { pi -> let z = y in ei
              ; alts2 }
  The "let z=y" case-binder-swap gets dealt with in the next pass
-}

413 414 415 416
pprTickCounts :: Map Tick Int -> SDoc
pprTickCounts counts
  = vcat (map pprTickGroup groups)
  where
417 418
    groups :: [[(Tick,Int)]]    -- Each group shares a comon tag
                                -- toList returns common tags adjacent
419
    groups = groupBy same_tag (Map.toList counts)
420 421 422 423 424
    same_tag (tick1,_) (tick2,_) = tickToTag tick1 == tickToTag tick2

pprTickGroup :: [(Tick, Int)] -> SDoc
pprTickGroup group@((tick1,_):_)
  = hang (int (sum [n | (_,n) <- group]) <+> text (tickString tick1))
425
       2 (vcat [ int n <+> pprTickCts tick
Ian Lynagh's avatar
Ian Lynagh committed
426 427
                                    -- flip as we want largest first
               | (tick,n) <- sortBy (flip (comparing snd)) group])
428
pprTickGroup [] = panic "pprTickGroup"
429

430
data Tick  -- See Note [Which transformations are innocuous]
431 432
  = PreInlineUnconditionally    Id
  | PostInlineUnconditionally   Id
433

434 435
  | UnfoldingDone               Id
  | RuleFired                   FastString      -- Rule name
436 437

  | LetFloatFromLet
438 439 440
  | EtaExpansion                Id      -- LHS binder
  | EtaReduction                Id      -- Binder on outer lambda
  | BetaReduction               Id      -- Lambda binder
441 442


443 444 445 446 447 448 449
  | CaseOfCase                  Id      -- Bndr on *inner* case
  | KnownBranch                 Id      -- Case binder
  | CaseMerge                   Id      -- Binder on outer case
  | AltMerge                    Id      -- Case binder
  | CaseElim                    Id      -- Case binder
  | CaseIdentity                Id      -- Case binder
  | FillInCaseDefault           Id      -- Case binder
450

451
  | SimplifierDone              -- Ticked at each iteration of the simplifier
452 453 454 455 456 457 458 459 460 461 462 463 464

instance Outputable Tick where
  ppr tick = text (tickString tick) <+> pprTickCts tick

instance Eq Tick where
  a == b = case a `cmpTick` b of
           EQ -> True
           _ -> False

instance Ord Tick where
  compare = cmpTick

tickToTag :: Tick -> Int
465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480
tickToTag (PreInlineUnconditionally _)  = 0
tickToTag (PostInlineUnconditionally _) = 1
tickToTag (UnfoldingDone _)             = 2
tickToTag (RuleFired _)                 = 3
tickToTag LetFloatFromLet               = 4
tickToTag (EtaExpansion _)              = 5
tickToTag (EtaReduction _)              = 6
tickToTag (BetaReduction _)             = 7
tickToTag (CaseOfCase _)                = 8
tickToTag (KnownBranch _)               = 9
tickToTag (CaseMerge _)                 = 10
tickToTag (CaseElim _)                  = 11
tickToTag (CaseIdentity _)              = 12
tickToTag (FillInCaseDefault _)         = 13
tickToTag SimplifierDone                = 16
tickToTag (AltMerge _)                  = 17
481 482

tickString :: Tick -> String
483
tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
484
tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
485 486 487 488 489 490 491 492 493 494 495 496 497 498
tickString (UnfoldingDone _)            = "UnfoldingDone"
tickString (RuleFired _)                = "RuleFired"
tickString LetFloatFromLet              = "LetFloatFromLet"
tickString (EtaExpansion _)             = "EtaExpansion"
tickString (EtaReduction _)             = "EtaReduction"
tickString (BetaReduction _)            = "BetaReduction"
tickString (CaseOfCase _)               = "CaseOfCase"
tickString (KnownBranch _)              = "KnownBranch"
tickString (CaseMerge _)                = "CaseMerge"
tickString (AltMerge _)                 = "AltMerge"
tickString (CaseElim _)                 = "CaseElim"
tickString (CaseIdentity _)             = "CaseIdentity"
tickString (FillInCaseDefault _)        = "FillInCaseDefault"
tickString SimplifierDone               = "SimplifierDone"
499 500

pprTickCts :: Tick -> SDoc
501
pprTickCts (PreInlineUnconditionally v) = ppr v
502
pprTickCts (PostInlineUnconditionally v)= ppr v
503 504 505 506 507 508 509 510 511 512 513 514 515 516
pprTickCts (UnfoldingDone v)            = ppr v
pprTickCts (RuleFired v)                = ppr v
pprTickCts LetFloatFromLet              = Outputable.empty
pprTickCts (EtaExpansion v)             = ppr v
pprTickCts (EtaReduction v)             = ppr v
pprTickCts (BetaReduction v)            = ppr v
pprTickCts (CaseOfCase v)               = ppr v
pprTickCts (KnownBranch v)              = ppr v
pprTickCts (CaseMerge v)                = ppr v
pprTickCts (AltMerge v)                 = ppr v
pprTickCts (CaseElim v)                 = ppr v
pprTickCts (CaseIdentity v)             = ppr v
pprTickCts (FillInCaseDefault v)        = ppr v
pprTickCts _                            = Outputable.empty
517 518 519

cmpTick :: Tick -> Tick -> Ordering
cmpTick a b = case (tickToTag a `compare` tickToTag b) of
520 521 522
                GT -> GT
                EQ -> cmpEqTick a b
                LT -> LT
523 524

cmpEqTick :: Tick -> Tick -> Ordering
525 526 527 528 529 530 531 532 533 534 535 536 537 538 539
cmpEqTick (PreInlineUnconditionally a)  (PreInlineUnconditionally b)    = a `compare` b
cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b)   = a `compare` b
cmpEqTick (UnfoldingDone a)             (UnfoldingDone b)               = a `compare` b
cmpEqTick (RuleFired a)                 (RuleFired b)                   = a `compare` b
cmpEqTick (EtaExpansion a)              (EtaExpansion b)                = a `compare` b
cmpEqTick (EtaReduction a)              (EtaReduction b)                = a `compare` b
cmpEqTick (BetaReduction a)             (BetaReduction b)               = a `compare` b
cmpEqTick (CaseOfCase a)                (CaseOfCase b)                  = a `compare` b
cmpEqTick (KnownBranch a)               (KnownBranch b)                 = a `compare` b
cmpEqTick (CaseMerge a)                 (CaseMerge b)                   = a `compare` b
cmpEqTick (AltMerge a)                  (AltMerge b)                    = a `compare` b
cmpEqTick (CaseElim a)                  (CaseElim b)                    = a `compare` b
cmpEqTick (CaseIdentity a)              (CaseIdentity b)                = a `compare` b
cmpEqTick (FillInCaseDefault a)         (FillInCaseDefault b)           = a `compare` b
cmpEqTick _                             _                               = EQ
540

Austin Seipp's avatar
Austin Seipp committed
541 542 543
{-
************************************************************************
*                                                                      *
544
             Monad and carried data structure definitions
Austin Seipp's avatar
Austin Seipp committed
545 546 547
*                                                                      *
************************************************************************
-}
548 549

data CoreReader = CoreReader {
550 551 552 553 554 555
        cr_hsc_env             :: HscEnv,
        cr_rule_base           :: RuleBase,
        cr_module              :: Module,
        cr_print_unqual        :: PrintUnqualified,
        cr_loc                 :: SrcSpan,   -- Use this for log/error messages so they
                                             -- are at least tagged with the right source file
556 557
        cr_visible_orphan_mods :: !ModuleSet,
        cr_uniq_mask           :: !Char      -- Mask for creating unique values
558 559
}

560 561
-- Note: CoreWriter used to be defined with data, rather than newtype.  If it
-- is defined that way again, the cw_simpl_count field, at least, must be
562
-- strict to avoid a space leak (#7702).
563 564
newtype CoreWriter = CoreWriter {
        cw_simpl_count :: SimplCount
565 566 567 568 569 570 571 572 573 574 575 576 577 578
}

emptyWriter :: DynFlags -> CoreWriter
emptyWriter dflags = CoreWriter {
        cw_simpl_count = zeroSimplCount dflags
    }

plusWriter :: CoreWriter -> CoreWriter -> CoreWriter
plusWriter w1 w2 = CoreWriter {
        cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2)
    }

type CoreIOEnv = IOEnv CoreReader

579 580 581
-- | The monad used by Core-to-Core passes to register simplification statistics.
--  Also used to have common state (in the form of UniqueSupply) for generating Uniques.
newtype CoreM a = CoreM { unCoreM :: CoreIOEnv (a, CoreWriter) }
582
    deriving (Functor)
583 584

instance Monad CoreM where
585 586 587
    mx >>= f = CoreM $ do
            (x, w1) <- unCoreM mx
            (y, w2) <- unCoreM (f x)
588
            let w = w1 `plusWriter` w2
589
            return $ seq w (y, w)
590
            -- forcing w before building the tuple avoids a space leak
591
            -- (#7702)
592

593
instance Applicative CoreM where
594
    pure x = CoreM $ nop x
595
    (<*>) = ap
596
    m *> k = m >>= \_ -> k
597

598
instance Alternative CoreM where
599 600
    empty   = CoreM Control.Applicative.empty
    m <|> n = CoreM (unCoreM m <|> unCoreM n)
Austin Seipp's avatar
Austin Seipp committed
601

602
instance MonadPlus CoreM
603 604 605

instance MonadUnique CoreM where
    getUniqueSupplyM = do
606 607
        mask <- read cr_uniq_mask
        liftIO $! mkSplitUniqSupply mask
608

609
    getUniqueM = do
610 611
        mask <- read cr_uniq_mask
        liftIO $! uniqFromMask mask
612

613 614
runCoreM :: HscEnv
         -> RuleBase
615
         -> Char -- ^ Mask
616
         -> Module
617
         -> ModuleSet
618
         -> PrintUnqualified
619
         -> SrcSpan
620 621
         -> CoreM a
         -> IO (a, SimplCount)
622 623
runCoreM hsc_env rule_base mask mod orph_imps print_unqual loc m
  = liftM extract $ runIOEnv reader $ unCoreM m
624
  where
625
    reader = CoreReader {
626 627
            cr_hsc_env = hsc_env,
            cr_rule_base = rule_base,
628
            cr_module = mod,
629
            cr_visible_orphan_mods = orph_imps,
630
            cr_print_unqual = print_unqual,
631 632
            cr_loc = loc,
            cr_uniq_mask = mask
633 634
        }

635 636
    extract :: (a, CoreWriter) -> (a, SimplCount)
    extract (value, writer) = (value, cw_simpl_count writer)
637

Austin Seipp's avatar
Austin Seipp committed
638 639 640
{-
************************************************************************
*                                                                      *
641
             Core combinators, not exported
Austin Seipp's avatar
Austin Seipp committed
642 643 644
*                                                                      *
************************************************************************
-}
645

646 647
nop :: a -> CoreIOEnv (a, CoreWriter)
nop x = do
648
    r <- getEnv
649
    return (x, emptyWriter $ (hsc_dflags . cr_hsc_env) r)
650 651

read :: (CoreReader -> a) -> CoreM a
652
read f = CoreM $ getEnv >>= (\r -> nop (f r))
653 654

write :: CoreWriter -> CoreM ()
655
write w = CoreM $ return ((), w)
656

Austin Seipp's avatar
Austin Seipp committed
657
-- \subsection{Lifting IO into the monad}
658 659 660

-- | Lift an 'IOEnv' operation into 'CoreM'
liftIOEnv :: CoreIOEnv a -> CoreM a
661
liftIOEnv mx = CoreM (mx >>= (\x -> nop x))
662 663 664 665 666 667 668 669

instance MonadIO CoreM where
    liftIO = liftIOEnv . IOEnv.liftIO

-- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount'
liftIOWithCount :: IO (SimplCount, a) -> CoreM a
liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x)

Austin Seipp's avatar
Austin Seipp committed
670 671 672
{-
************************************************************************
*                                                                      *
673
             Reader, writer and state accessors
Austin Seipp's avatar
Austin Seipp committed
674 675 676
*                                                                      *
************************************************************************
-}
677 678 679 680 681 682 683

getHscEnv :: CoreM HscEnv
getHscEnv = read cr_hsc_env

getRuleBase :: CoreM RuleBase
getRuleBase = read cr_rule_base

684 685 686
getVisibleOrphanMods :: CoreM ModuleSet
getVisibleOrphanMods = read cr_visible_orphan_mods

687 688 689
getPrintUnqualified :: CoreM PrintUnqualified
getPrintUnqualified = read cr_print_unqual

690 691 692
getSrcSpanM :: CoreM SrcSpan
getSrcSpanM = read cr_loc

693 694 695
addSimplCount :: SimplCount -> CoreM ()
addSimplCount count = write (CoreWriter { cw_simpl_count = count })

696 697 698
getUniqMask :: CoreM Char
getUniqMask = read cr_uniq_mask

699 700
-- Convenience accessors for useful fields of HscEnv

701 702
instance HasDynFlags CoreM where
    getDynFlags = fmap hsc_dflags getHscEnv
703

704 705 706
instance HasModule CoreM where
    getModule = read cr_module

707 708 709 710 711 712
-- | The original name cache is the current mapping from 'Module' and
-- 'OccName' to a compiler-wide unique 'Name'
getOrigNameCache :: CoreM OrigNameCache
getOrigNameCache = do
    nameCacheRef <- fmap hsc_NC getHscEnv
    liftIO $ fmap nsNames $ readIORef nameCacheRef
713 714 715 716 717 718

getPackageFamInstEnv :: CoreM PackageFamInstEnv
getPackageFamInstEnv = do
    hsc_env <- getHscEnv
    eps <- liftIO $ hscEPS hsc_env
    return $ eps_fam_inst_env eps
719

Austin Seipp's avatar
Austin Seipp committed
720 721 722
{-
************************************************************************
*                                                                      *
723
             Dealing with annotations
Austin Seipp's avatar
Austin Seipp committed
724 725 726
*                                                                      *
************************************************************************
-}
727

728 729 730
-- | Get all annotations of a given type. This happens lazily, that is
-- no deserialization will take place until the [a] is actually demanded and
-- the [a] can also be empty (the UniqFM is not filtered).
731
--
732 733
-- This should be done once at the start of a Core-to-Core pass that uses
-- annotations.
734
--
735 736 737 738 739
-- See Note [Annotations]
getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM [a])
getAnnotations deserialize guts = do
     hsc_env <- getHscEnv
     ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts)
740 741
     return (deserializeAnns deserialize ann_env)

742 743 744 745 746
-- | Get at most one annotation of a given type per Unique.
getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM a)
getFirstAnnotations deserialize guts
  = liftM (mapUFM head . filterUFM (not . null))
  $ getAnnotations deserialize guts
747

Austin Seipp's avatar
Austin Seipp committed
748
{-
749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765
Note [Annotations]
~~~~~~~~~~~~~~~~~~
A Core-to-Core pass that wants to make use of annotations calls
getAnnotations or getFirstAnnotations at the beginning to obtain a UniqFM with
annotations of a specific type. This produces all annotations from interface
files read so far. However, annotations from interface files read during the
pass will not be visible until getAnnotations is called again. This is similar
to how rules work and probably isn't too bad.

The current implementation could be optimised a bit: when looking up
annotations for a thing from the HomePackageTable, we could search directly in
the module where the thing is defined rather than building one UniqFM which
contains all annotations we know of. This would work because annotations can
only be given to things defined in the same module. However, since we would
only want to deserialise every annotation once, we would have to build a cache
for every module in the HTP. In the end, it's probably not worth it as long as
we aren't using annotations heavily.
766

Austin Seipp's avatar
Austin Seipp committed
767 768
************************************************************************
*                                                                      *
769
                Direct screen output
Austin Seipp's avatar
Austin Seipp committed
770 771 772
*                                                                      *
************************************************************************
-}
773

Eric Crockett's avatar
Eric Crockett committed
774 775
msg :: Severity -> WarnReason -> SDoc -> CoreM ()
msg sev reason doc
776 777 778 779 780 781 782 783 784
  = do { dflags <- getDynFlags
       ; loc    <- getSrcSpanM
       ; unqual <- getPrintUnqualified
       ; let sty = case sev of
                     SevError   -> err_sty
                     SevWarning -> err_sty
                     SevDump    -> dump_sty
                     _          -> user_sty
             err_sty  = mkErrStyle dflags unqual
Sylvain Henry's avatar
Sylvain Henry committed
785 786
             user_sty = mkUserStyle dflags unqual AllTheWay
             dump_sty = mkDumpStyle dflags unqual
Eric Crockett's avatar
Eric Crockett committed
787
       ; liftIO $ putLogMsg dflags reason sev loc sty doc }
788 789 790 791 792 793 794

-- | Output a String message to the screen
putMsgS :: String -> CoreM ()
putMsgS = putMsg . text

-- | Output a message to the screen
putMsg :: SDoc -> CoreM ()
Eric Crockett's avatar
Eric Crockett committed
795
putMsg = msg SevInfo NoReason
796

797
-- | Output an error to the screen. Does not cause the compiler to die.
798 799 800
errorMsgS :: String -> CoreM ()
errorMsgS = errorMsg . text

801
-- | Output an error to the screen. Does not cause the compiler to die.
802
errorMsg :: SDoc -> CoreM ()
Eric Crockett's avatar
Eric Crockett committed
803
errorMsg = msg SevError NoReason
804

Eric Crockett's avatar
Eric Crockett committed
805
warnMsg :: WarnReason -> SDoc -> CoreM ()
806
warnMsg = msg SevWarning
807

808
-- | Output a fatal error to the screen. Does not cause the compiler to die.
809 810 811
fatalErrorMsgS :: String -> CoreM ()
fatalErrorMsgS = fatalErrorMsg . text

812
-- | Output a fatal error to the screen. Does not cause the compiler to die.
813
fatalErrorMsg :: SDoc -> CoreM ()
Eric Crockett's avatar
Eric Crockett committed
814
fatalErrorMsg = msg SevFatal NoReason
815 816 817 818 819 820 821

-- | Output a string debugging message at verbosity level of @-v@ or higher
debugTraceMsgS :: String -> CoreM ()
debugTraceMsgS = debugTraceMsg . text

-- | Outputs a debugging message at verbosity level of @-v@ or higher
debugTraceMsg :: SDoc -> CoreM ()
Eric Crockett's avatar
Eric Crockett committed
822
debugTraceMsg = msg SevDump NoReason
823 824

-- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
825
dumpIfSet_dyn :: DumpFlag -> String -> SDoc -> CoreM ()
826 827 828 829 830
dumpIfSet_dyn flag str doc
  = do { dflags <- getDynFlags
       ; unqual <- getPrintUnqualified
       ; when (dopt flag dflags) $ liftIO $
         Err.dumpSDoc dflags unqual flag str doc }