Deduplicate `HaskellMachRegs.h` and `RtsMachRegs.h` headers
[ghc.git] / compiler / simplCore / CoreMonad.hs
index ce5286d..d2918a2 100644 (file)
@@ -4,17 +4,18 @@
 \section[CoreMonad]{The core pipeline monad}
 -}
 
-{-# LANGUAGE CPP, UndecidableInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFunctor #-}
 
 module CoreMonad (
     -- * Configuration of the core-to-core passes
     CoreToDo(..), runWhen, runMaybe,
-    SimplifierMode(..),
+    SimplMode(..),
     FloatOutSwitches(..),
     pprPassDetails,
 
     -- * Plugins
-    PluginPass, bindsOnlyPass,
+    CorePluginPass, bindsOnlyPass,
 
     -- * Counting
     SimplCount, doSimplTick, doFreeSimplTick, simplCountN,
@@ -35,10 +36,6 @@ module CoreMonad (
 
     -- ** Lifting into the monad
     liftIO, liftIOWithCount,
-    liftIO1, liftIO2, liftIO3, liftIO4,
-
-    -- ** Global initialization
-    reinitializeGlobals,
 
     -- ** Dealing with annotations
     getAnnotations, getFirstAnnotations,
@@ -47,65 +44,41 @@ module CoreMonad (
     putMsg, putMsgS, errorMsg, errorMsgS, warnMsg,
     fatalErrorMsg, fatalErrorMsgS,
     debugTraceMsg, debugTraceMsgS,
-    dumpIfSet_dyn,
-
-#ifdef GHCI
-    -- * Getting 'Name's
-    thNameToGhcName
-#endif
+    dumpIfSet_dyn
   ) where
 
-#ifdef GHCI
-import Name( Name )
-import TcRnMonad        ( initTcForLookup )
-#endif
+import GhcPrelude hiding ( read )
+
 import CoreSyn
 import HscTypes
 import Module
 import DynFlags
-import StaticFlags
 import BasicTypes       ( CompilerPhase(..) )
 import Annotations
 
 import IOEnv hiding     ( liftIO, failM, failWithM )
 import qualified IOEnv  ( liftIO )
-import TcEnv            ( lookupGlobal )
 import Var
 import Outputable
 import FastString
 import qualified ErrUtils as Err
 import ErrUtils( Severity(..) )
-import Maybes
 import UniqSupply
 import UniqFM       ( UniqFM, mapUFM, filterUFM )
 import MonadUtils
+import NameCache
 import SrcLoc
-import ListSetOps       ( runs )
 import Data.List
 import Data.Ord
 import Data.Dynamic
 import Data.IORef
 import Data.Map (Map)
 import qualified Data.Map as Map
+import qualified Data.Map.Strict as MapStrict
 import Data.Word
-import qualified Control.Applicative as A
 import Control.Monad
-
-import Prelude hiding   ( read )
-
-#ifdef GHCI
-import Control.Concurrent.MVar (MVar)
-import Linker ( PersistentLinkerState, saveLinkerGlobals, restoreLinkerGlobals )
-import {-# SOURCE #-} TcSplice ( lookupThName_maybe )
-import qualified Language.Haskell.TH as TH
-#else
-saveLinkerGlobals :: IO ()
-saveLinkerGlobals = return ()
-
-restoreLinkerGlobals :: () -> IO ()
-restoreLinkerGlobals () = return ()
-#endif
-
+import Control.Applicative ( Alternative(..) )
+import Panic (throwGhcException, GhcException(..))
 
 {-
 ************************************************************************
@@ -122,14 +95,15 @@ data CoreToDo           -- These are diff core-to-core passes,
 
   = CoreDoSimplify      -- The core-to-core simplifier.
         Int                    -- Max iterations
-        SimplifierMode
-  | CoreDoPluginPass String PluginPass
+        SimplMode
+  | CoreDoPluginPass String CorePluginPass
   | CoreDoFloatInwards
   | CoreDoFloatOutwards FloatOutSwitches
   | CoreLiberateCase
   | CoreDoPrintCore
   | CoreDoStaticArgs
   | CoreDoCallArity
+  | CoreDoExitify
   | CoreDoStrictness
   | CoreDoWorkerWrapper
   | CoreDoSpecialising
@@ -137,7 +111,6 @@ data CoreToDo           -- These are diff core-to-core passes,
   | CoreCSE
   | CoreDoRuleCheck CompilerPhase String   -- Check for non-application of rules
                                            -- matching this string
-  | CoreDoVectorisation
   | CoreDoNothing                -- Useful when building up
   | CoreDoPasses [CoreToDo]      -- lists of these things
 
@@ -147,58 +120,62 @@ data CoreToDo           -- These are diff core-to-core passes,
 
   | CoreTidy
   | CorePrep
+  | CoreOccurAnal
 
 instance Outputable CoreToDo where
-  ppr (CoreDoSimplify _ _)     = ptext (sLit "Simplifier")
-  ppr (CoreDoPluginPass s _)   = ptext (sLit "Core plugin: ") <+> text s
-  ppr CoreDoFloatInwards       = ptext (sLit "Float inwards")
-  ppr (CoreDoFloatOutwards f)  = ptext (sLit "Float out") <> parens (ppr f)
-  ppr CoreLiberateCase         = ptext (sLit "Liberate case")
-  ppr CoreDoStaticArgs         = ptext (sLit "Static argument")
-  ppr CoreDoCallArity          = ptext (sLit "Called arity analysis")
-  ppr CoreDoStrictness         = ptext (sLit "Demand analysis")
-  ppr CoreDoWorkerWrapper      = ptext (sLit "Worker Wrapper binds")
-  ppr CoreDoSpecialising       = ptext (sLit "Specialise")
-  ppr CoreDoSpecConstr         = ptext (sLit "SpecConstr")
-  ppr CoreCSE                  = ptext (sLit "Common sub-expression")
-  ppr CoreDoVectorisation      = ptext (sLit "Vectorisation")
-  ppr CoreDesugar              = ptext (sLit "Desugar (before optimization)")
-  ppr CoreDesugarOpt           = ptext (sLit "Desugar (after optimization)")
-  ppr CoreTidy                 = ptext (sLit "Tidy Core")
-  ppr CorePrep                 = ptext (sLit "CorePrep")
-  ppr CoreDoPrintCore          = ptext (sLit "Print core")
-  ppr (CoreDoRuleCheck {})     = ptext (sLit "Rule check")
-  ppr CoreDoNothing            = ptext (sLit "CoreDoNothing")
-  ppr (CoreDoPasses {})        = ptext (sLit "CoreDoPasses")
+  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"
+  ppr CoreDoExitify            = text "Exitification transformation"
+  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"
+  ppr CoreOccurAnal            = text "Occurrence analysis"
+  ppr CoreDoPrintCore          = text "Print core"
+  ppr (CoreDoRuleCheck {})     = text "Rule check"
+  ppr CoreDoNothing            = text "CoreDoNothing"
+  ppr (CoreDoPasses passes)    = text "CoreDoPasses" <+> ppr passes
 
 pprPassDetails :: CoreToDo -> SDoc
-pprPassDetails (CoreDoSimplify n md) = vcat [ ptext (sLit "Max iterations =") <+> int n
+pprPassDetails (CoreDoSimplify n md) = vcat [ text "Max iterations =" <+> int n
                                             , ppr md ]
 pprPassDetails _ = Outputable.empty
 
-data SimplifierMode             -- See comments in SimplMonad
+data SimplMode             -- See comments in SimplMonad
   = SimplMode
         { sm_names      :: [String] -- Name(s) of the phase
         , sm_phase      :: CompilerPhase
+        , sm_dflags     :: DynFlags -- Just for convenient non-monadic
+                                    -- access; we don't override these
         , 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
         }
 
-instance Outputable SimplifierMode where
+instance Outputable SimplMode where
     ppr (SimplMode { sm_phase = p, sm_names = ss
                    , sm_rules = r, sm_inline = i
                    , sm_eta_expand = eta, sm_case_case = cc })
-       = ptext (sLit "SimplMode") <+> braces (
-         sep [ ptext (sLit "Phase =") <+> ppr p <+>
+       = text "SimplMode" <+> braces (
+         sep [ text "Phase =" <+> ppr p <+>
                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") ])
          where
-           pp_flag f s = ppUnless f (ptext (sLit "no")) <+> ptext s
+           pp_flag f s = ppUnless f (text "no") <+> ptext s
 
 data FloatOutSwitches = FloatOutSwitches {
   floatOutLambdas   :: Maybe Int,  -- ^ Just n <=> float lambdas to top level, if
@@ -211,21 +188,23 @@ data FloatOutSwitches = FloatOutSwitches {
 
   floatOutConstants :: Bool,       -- ^ True <=> float constants to top level,
                                    --            even if they do not escape a lambda
-  floatOutOverSatApps :: Bool      -- ^ True <=> float out over-saturated applications
-                                   --            based on arity information.
-                                   -- See Note [Floating over-saturated applications]
-                                   -- in SetLevels
+  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.
   }
 instance Outputable FloatOutSwitches where
     ppr = pprFloatOutSwitches
 
 pprFloatOutSwitches :: FloatOutSwitches -> SDoc
 pprFloatOutSwitches sw
-  = ptext (sLit "FOS") <+> (braces $
+  = text "FOS" <+> (braces $
      sep $ punctuate comma $
-     [ ptext (sLit "Lam =")    <+> ppr (floatOutLambdas sw)
-     , ptext (sLit "Consts =") <+> ppr (floatOutConstants sw)
-     , ptext (sLit "OverSatApps =")   <+> ppr (floatOutOverSatApps sw) ])
+     [ text "Lam ="    <+> ppr (floatOutLambdas sw)
+     , text "Consts =" <+> ppr (floatOutConstants sw)
+     , text "OverSatApps ="   <+> ppr (floatOutOverSatApps sw) ])
 
 -- The core-to-core pass ordering is derived from the DynFlags:
 runWhen :: Bool -> CoreToDo -> CoreToDo
@@ -237,22 +216,6 @@ runMaybe (Just x) f = f x
 runMaybe Nothing  _ = CoreDoNothing
 
 {-
-Note [RULEs enabled in SimplGently]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-RULES are enabled when doing "gentle" simplification.  Two reasons:
-
-  * We really want the class-op cancellation to happen:
-        op (df d1 d2) --> $cop3 d1 d2
-    because this breaks the mutual recursion between 'op' and 'df'
-
-  * I wanted the RULE
-        lift String ===> ...
-    to work in Template Haskell when simplifying
-    splices, so we get simpler code for literal strings
-
-But watch out: list fusion can prevent floating.  So use phase control
-to switch off those rules until after floating.
-
 
 ************************************************************************
 *                                                                      *
@@ -262,7 +225,7 @@ to switch off those rules until after floating.
 -}
 
 -- | A description of the plugin pass itself
-type PluginPass = ModGuts -> CoreM ModGuts
+type CorePluginPass = ModGuts -> CoreM ModGuts
 
 bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts
 bindsOnlyPass pass guts
@@ -277,8 +240,8 @@ bindsOnlyPass pass guts
 ************************************************************************
 -}
 
-verboseSimplStats :: Bool
-verboseSimplStats = opt_PprStyle_Debug          -- For now, anyway
+getVerboseSimplStats :: (Bool -> SDoc) -> SDoc
+getVerboseSimplStats = getPprDebug          -- For now, anyway
 
 zeroSimplCount     :: DynFlags -> SimplCount
 isZeroSimplCount   :: SimplCount -> Bool
@@ -338,19 +301,13 @@ doSimplTick dflags tick
 doSimplTick _ _ (VerySimplCount n) = VerySimplCount (n+1)
 
 
--- Don't use Map.unionWith because that's lazy, and we want to
--- be pretty strict here!
 addTick :: TickCounts -> Tick -> TickCounts
-addTick fm tick = case Map.lookup tick fm of
-                        Nothing -> Map.insert tick 1 fm
-                        Just n  -> n1 `seq` Map.insert tick n1 fm
-                                where
-                                   n1 = n+1
-
+addTick fm tick = MapStrict.insertWith (+) tick 1 fm
 
 plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
                sc2@(SimplCount { ticks = tks2, details = dts2 })
-  = log_base { ticks = tks1 + tks2, details = Map.unionWith (+) dts1 dts2 }
+  = log_base { ticks = tks1 + tks2
+             , details = MapStrict.unionWith (+) dts1 dts2 }
   where
         -- A hackish way of getting recent log info
     log_base | null (log1 sc2) = sc1    -- Nothing at all in sc2
@@ -358,28 +315,108 @@ plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
              | otherwise       = sc2
 
 plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m)
-plusSimplCount _                  _                  = panic "plusSimplCount"
+plusSimplCount lhs                rhs                =
+  throwGhcException . PprProgramError "plusSimplCount" $ vcat
+    [ text "lhs"
+    , pprSimplCount lhs
+    , text "rhs"
+    , pprSimplCount rhs
+    ]
        -- We use one or the other consistently
 
-pprSimplCount (VerySimplCount n) = ptext (sLit "Total ticks:") <+> int n
+pprSimplCount (VerySimplCount n) = text "Total ticks:" <+> int n
 pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
-  = vcat [ptext (sLit "Total ticks:    ") <+> int tks,
+  = vcat [text "Total ticks:    " <+> int tks,
           blankLine,
           pprTickCounts dts,
-          if verboseSimplStats then
+          getVerboseSimplStats $ \dbg -> if dbg
+          then
                 vcat [blankLine,
-                      ptext (sLit "Log (most recent first)"),
+                      text "Log (most recent first)",
                       nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
           else Outputable.empty
     ]
 
+{- 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
+-}
+
 pprTickCounts :: Map Tick Int -> SDoc
 pprTickCounts counts
   = vcat (map pprTickGroup groups)
   where
     groups :: [[(Tick,Int)]]    -- Each group shares a comon tag
                                 -- toList returns common tags adjacent
-    groups = runs same_tag (Map.toList counts)
+    groups = groupBy same_tag (Map.toList counts)
     same_tag (tick1,_) (tick2,_) = tickToTag tick1 == tickToTag tick2
 
 pprTickGroup :: [(Tick, Int)] -> SDoc
@@ -390,7 +427,7 @@ pprTickGroup group@((tick1,_):_)
                | (tick,n) <- sortBy (flip (comparing snd)) group])
 pprTickGroup [] = panic "pprTickGroup"
 
-data Tick
+data Tick  -- See Note [Which transformations are innocuous]
   = PreInlineUnconditionally    Id
   | PostInlineUnconditionally   Id
 
@@ -411,7 +448,6 @@ data Tick
   | CaseIdentity                Id      -- Case binder
   | FillInCaseDefault           Id      -- Case binder
 
-  | BottomFound
   | SimplifierDone              -- Ticked at each iteration of the simplifier
 
 instance Outputable Tick where
@@ -440,7 +476,6 @@ tickToTag (CaseMerge _)                 = 10
 tickToTag (CaseElim _)                  = 11
 tickToTag (CaseIdentity _)              = 12
 tickToTag (FillInCaseDefault _)         = 13
-tickToTag BottomFound                   = 14
 tickToTag SimplifierDone                = 16
 tickToTag (AltMerge _)                  = 17
 
@@ -460,7 +495,6 @@ tickString (AltMerge _)                 = "AltMerge"
 tickString (CaseElim _)                 = "CaseElim"
 tickString (CaseIdentity _)             = "CaseIdentity"
 tickString (FillInCaseDefault _)        = "FillInCaseDefault"
-tickString BottomFound                  = "BottomFound"
 tickString SimplifierDone               = "SimplifierDone"
 
 pprTickCts :: Tick -> SDoc
@@ -523,17 +557,12 @@ data CoreReader = CoreReader {
         cr_print_unqual        :: PrintUnqualified,
         cr_loc                 :: SrcSpan,   -- Use this for log/error messages so they
                                              -- are at least tagged with the right source file
-        cr_visible_orphan_mods :: !ModuleSet,
-#ifdef GHCI
-        cr_globals :: (MVar PersistentLinkerState, Bool)
-#else
-        cr_globals :: ()
-#endif
+        cr_visible_orphan_mods :: !ModuleSet
 }
 
 -- 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
--- strict to avoid a space leak (Trac #7702).
+-- strict to avoid a space leak (#7702).
 newtype CoreWriter = CoreWriter {
         cw_simpl_count :: SimplCount
 }
@@ -553,34 +582,27 @@ type CoreIOEnv = IOEnv CoreReader
 -- | The monad used by Core-to-Core passes to access common state, register simplification
 -- statistics and so on
 newtype CoreM a = CoreM { unCoreM :: CoreState -> CoreIOEnv (a, CoreState, CoreWriter) }
-
-instance Functor CoreM where
-    fmap = liftM
+    deriving (Functor)
 
 instance Monad CoreM where
-    return = pure
     mx >>= f = CoreM $ \s -> do
             (x, s', w1) <- unCoreM mx s
             (y, s'', w2) <- unCoreM (f x) s'
             let w = w1 `plusWriter` w2
             return $ seq w (y, s'', w)
             -- forcing w before building the tuple avoids a space leak
-            -- (Trac #7702)
+            -- (#7702)
 
-instance A.Applicative CoreM where
+instance Applicative CoreM where
     pure x = CoreM $ \s -> nop s x
     (<*>) = ap
     m *> k = m >>= \_ -> k
 
-instance MonadPlus IO => A.Alternative CoreM where
-    empty = mzero
-    (<|>) = mplus
+instance Alternative CoreM where
+    empty   = CoreM (const Control.Applicative.empty)
+    m <|> n = CoreM (\rs -> unCoreM m rs <|> unCoreM n rs)
 
--- For use if the user has imported Control.Monad.Error from MTL
--- Requires UndecidableInstances
-instance MonadPlus IO => MonadPlus CoreM where
-    mzero = CoreM (const mzero)
-    m `mplus` n = CoreM (\rs -> unCoreM m rs `mplus` unCoreM n rs)
+instance MonadPlus CoreM
 
 instance MonadUnique CoreM where
     getUniqueSupplyM = do
@@ -605,15 +627,13 @@ runCoreM :: HscEnv
          -> CoreM a
          -> IO (a, SimplCount)
 runCoreM hsc_env rule_base us mod orph_imps print_unqual loc m
-  = do { glbls <- saveLinkerGlobals
-       ; liftM extract $ runIOEnv (reader glbls) $ unCoreM m state }
+  = liftM extract $ runIOEnv reader $ unCoreM m state
   where
-    reader glbls = CoreReader {
+    reader = CoreReader {
             cr_hsc_env = hsc_env,
             cr_rule_base = rule_base,
             cr_module = mod,
             cr_visible_orphan_mods = orph_imps,
-            cr_globals = glbls,
             cr_print_unqual = print_unqual,
             cr_loc = loc
         }
@@ -712,60 +732,6 @@ getPackageFamInstEnv = do
 {-
 ************************************************************************
 *                                                                      *
-             Initializing globals
-*                                                                      *
-************************************************************************
-
-This is a rather annoying function. When a plugin is loaded, it currently
-gets linked against a *newly loaded* copy of the GHC package. This would
-not be a problem, except that the new copy has its own mutable state
-that is not shared with that state that has already been initialized by
-the original GHC package.
-
-(NB This mechanism is sufficient for granting plugins read-only access to
-globals that are guaranteed to be initialized before the plugin is loaded.  If
-any further synchronization is necessary, I would suggest using the more
-sophisticated mechanism involving GHC.Conc.Sync.sharedCAF and rts/Globals.c to
-share a single instance of the global variable among the compiler and the
-plugins.  Perhaps we should migrate all global variables to use that mechanism,
-for robustness... -- NSF July 2013)
-
-This leads to loaded plugins calling GHC code which pokes the static flags,
-and then dying with a panic because the static flags *it* sees are uninitialized.
-
-There are two possible solutions:
-  1. Export the symbols from the GHC executable from the GHC library and link
-     against this existing copy rather than a new copy of the GHC library
-  2. Carefully ensure that the global state in the two copies of the GHC
-     library matches
-
-I tried 1. and it *almost* works (and speeds up plugin load times!) except
-on Windows. On Windows the GHC library tends to export more than 65536 symbols
-(see #5292) which overflows the limit of what we can export from the EXE and
-causes breakage.
-
-(Note that if the GHC executable was dynamically linked this wouldn't be a
-problem, because we could share the GHC library it links to.)
-
-We are going to try 2. instead. Unfortunately, this means that every plugin
-will have to say `reinitializeGlobals` before it does anything, but never mind.
-
-I've threaded the cr_globals through CoreM rather than giving them as an
-argument to the plugin function so that we can turn this function into
-(return ()) without breaking any plugins when we eventually get 1. working.
--}
-
-reinitializeGlobals :: CoreM ()
-reinitializeGlobals = do
-    linker_globals <- read cr_globals
-    hsc_env <- getHscEnv
-    let dflags = hsc_dflags hsc_env
-    liftIO $ restoreLinkerGlobals linker_globals
-    liftIO $ setUnsafeGlobalDynFlags dflags
-
-{-
-************************************************************************
-*                                                                      *
              Dealing with annotations
 *                                                                      *
 ************************************************************************
@@ -817,8 +783,8 @@ we aren't using annotations heavily.
 ************************************************************************
 -}
 
-msg :: Severity -> SDoc -> CoreM ()
-msg sev doc
+msg :: Severity -> WarnReason -> SDoc -> CoreM ()
+msg sev reason doc
   = do { dflags <- getDynFlags
        ; loc    <- getSrcSpanM
        ; unqual <- getPrintUnqualified
@@ -828,10 +794,9 @@ msg sev doc
                      SevDump    -> dump_sty
                      _          -> user_sty
              err_sty  = mkErrStyle dflags unqual
-             user_sty = mkUserStyle unqual AllTheWay
-             dump_sty = mkDumpStyle unqual
-       ; liftIO $
-         (log_action dflags) dflags sev loc sty doc }
+             user_sty = mkUserStyle dflags unqual AllTheWay
+             dump_sty = mkDumpStyle dflags unqual
+       ; liftIO $ putLogMsg dflags reason sev loc sty doc }
 
 -- | Output a String message to the screen
 putMsgS :: String -> CoreM ()
@@ -839,26 +804,26 @@ putMsgS = putMsg . text
 
 -- | Output a message to the screen
 putMsg :: SDoc -> CoreM ()
-putMsg = msg SevInfo
+putMsg = msg SevInfo NoReason
 
--- | Output a string error to the screen
+-- | Output an error to the screen. Does not cause the compiler to die.
 errorMsgS :: String -> CoreM ()
 errorMsgS = errorMsg . text
 
--- | Output an error to the screen
+-- | Output an error to the screen. Does not cause the compiler to die.
 errorMsg :: SDoc -> CoreM ()
-errorMsg = msg SevError
+errorMsg = msg SevError NoReason
 
-warnMsg :: SDoc -> CoreM ()
+warnMsg :: WarnReason -> SDoc -> CoreM ()
 warnMsg = msg SevWarning
 
--- | Output a fatal string error to the screen. Note this does not by itself cause the compiler to die
+-- | Output a fatal error to the screen. Does not cause the compiler to die.
 fatalErrorMsgS :: String -> CoreM ()
 fatalErrorMsgS = fatalErrorMsg . text
 
--- | Output a fatal error to the screen. Note this does not by itself cause the compiler to die
+-- | Output a fatal error to the screen. Does not cause the compiler to die.
 fatalErrorMsg :: SDoc -> CoreM ()
-fatalErrorMsg = msg SevFatal
+fatalErrorMsg = msg SevFatal NoReason
 
 -- | Output a string debugging message at verbosity level of @-v@ or higher
 debugTraceMsgS :: String -> CoreM ()
@@ -866,7 +831,7 @@ debugTraceMsgS = debugTraceMsg . text
 
 -- | Outputs a debugging message at verbosity level of @-v@ or higher
 debugTraceMsg :: SDoc -> CoreM ()
-debugTraceMsg = msg SevDump
+debugTraceMsg = msg SevDump NoReason
 
 -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
 dumpIfSet_dyn :: DumpFlag -> String -> SDoc -> CoreM ()
@@ -875,36 +840,3 @@ dumpIfSet_dyn flag str doc
        ; unqual <- getPrintUnqualified
        ; when (dopt flag dflags) $ liftIO $
          Err.dumpSDoc dflags unqual flag str doc }
-
-{-
-************************************************************************
-*                                                                      *
-               Finding TyThings
-*                                                                      *
-************************************************************************
--}
-
-instance MonadThings CoreM where
-    lookupThing name = do { hsc_env <- getHscEnv
-                          ; liftIO $ lookupGlobal hsc_env name }
-
-{-
-************************************************************************
-*                                                                      *
-               Template Haskell interoperability
-*                                                                      *
-************************************************************************
--}
-
-#ifdef GHCI
--- | Attempt to convert a Template Haskell name to one that GHC can
--- understand. Original TH names such as those you get when you use
--- the @'foo@ syntax will be translated to their equivalent GHC name
--- exactly. Qualified or unqualifed TH names will be dynamically bound
--- to names in the module being compiled, if possible. Exact TH names
--- will be bound to the name they represent, exactly.
-thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
-thNameToGhcName th_name = do
-    hsc_env <- getHscEnv
-    liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)
-#endif