{-
(c) The AQUA Project, Glasgow University, 1993-1998

-}


{-# LANGUAGE DeriveFunctor #-}

module GHC.Core.Opt.Monad (
    -- * Types used in core-to-core passes
    FloatOutSwitches(..),

    -- * The monad
    CoreM, runCoreM,

    mapDynFlagsCoreM, dropSimplCount,

    -- ** Reading from the monad
    getHscEnv, getModule,
    initRuleEnv, getExternalRuleBase,
    getDynFlags, getPackageFamInstEnv,
    getInteractiveContext,
    getUniqMask,
    getNamePprCtx, getSrcSpanM,

    -- ** Writing to the monad
    addSimplCount,

    -- ** Lifting into the monad
    liftIO, liftIOWithCount,

    -- ** Dealing with annotations
    getAnnotations, getFirstAnnotations,

    -- ** Screen output
    putMsg, putMsgS, errorMsg, msg,
    fatalErrorMsg, fatalErrorMsgS,
    debugTraceMsg, debugTraceMsgS,
  ) where

import GHC.Prelude hiding ( read )

import GHC.Driver.Session
import GHC.Driver.Env

import GHC.Core.Rules     ( RuleBase, RuleEnv, mkRuleEnv )
import GHC.Core.Opt.Stats ( SimplCount, zeroSimplCount, plusSimplCount )

import GHC.Types.Annotations
import GHC.Types.Unique.Supply
import GHC.Types.Name.Env
import GHC.Types.SrcLoc
import GHC.Types.Error

import GHC.Utils.Error ( errorDiagnostic )
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Logger
import GHC.Utils.Monad

import GHC.Data.IOEnv hiding     ( liftIO, failM, failWithM )
import qualified GHC.Data.IOEnv  as IOEnv

import GHC.Runtime.Context ( InteractiveContext )

import GHC.Unit.Module
import GHC.Unit.Module.ModGuts
import GHC.Unit.External

import Data.Bifunctor ( bimap )
import Data.Dynamic
import Data.Maybe (listToMaybe)
import Data.Word
import Control.Monad
import Control.Applicative ( Alternative(..) )

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

  FloatOutSwitches -> Bool
floatOutConstants :: Bool,       -- ^ True <=> float constants to top level,
                                   --            even if they do not escape a lambda
  FloatOutSwitches -> Bool
floatOutOverSatApps :: Bool,
                             -- ^ True <=> float out over-saturated applications
                             --            based on arity information.
                             -- See Note [Floating over-saturated applications]
                             -- in GHC.Core.Opt.SetLevels
  FloatOutSwitches -> Bool
floatToTopLevelOnly :: Bool      -- ^ Allow floating to the top level only.
  }
instance Outputable FloatOutSwitches where
    ppr :: FloatOutSwitches -> SDoc
ppr = FloatOutSwitches -> SDoc
pprFloatOutSwitches

pprFloatOutSwitches :: FloatOutSwitches -> SDoc
pprFloatOutSwitches :: FloatOutSwitches -> SDoc
pprFloatOutSwitches FloatOutSwitches
sw
  = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"FOS" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> (SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
     [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
comma ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> a -> b
$
     [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Lam ="    SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Maybe Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr (FloatOutSwitches -> Maybe Int
floatOutLambdas FloatOutSwitches
sw)
     , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Consts =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr (FloatOutSwitches -> Bool
floatOutConstants FloatOutSwitches
sw)
     , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"OverSatApps ="   SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr (FloatOutSwitches -> Bool
floatOutOverSatApps FloatOutSwitches
sw) ])

{-
************************************************************************
*                                                                      *
             Monad and carried data structure definitions
*                                                                      *
************************************************************************
-}

data CoreReader = CoreReader {
        CoreReader -> HscEnv
cr_hsc_env             :: HscEnv,
        CoreReader -> RuleBase
cr_rule_base           :: RuleBase,  -- Home package table rules
        CoreReader -> Module
cr_module              :: Module,
        CoreReader -> NamePprCtx
cr_name_ppr_ctx        :: NamePprCtx,
        CoreReader -> SrcSpan
cr_loc                 :: SrcSpan,   -- Use this for log/error messages so they
                                             -- are at least tagged with the right source file
        CoreReader -> Char
cr_uniq_mask           :: !Char      -- Mask for creating unique values
}

-- 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 (#7702).
newtype CoreWriter = CoreWriter {
        CoreWriter -> SimplCount
cw_simpl_count :: SimplCount
}

emptyWriter :: Bool -- ^ -ddump-simpl-stats
            -> CoreWriter
emptyWriter :: Bool -> CoreWriter
emptyWriter Bool
dump_simpl_stats = CoreWriter {
        cw_simpl_count :: SimplCount
cw_simpl_count = Bool -> SimplCount
zeroSimplCount Bool
dump_simpl_stats
    }

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

type CoreIOEnv = IOEnv CoreReader

-- | 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 { forall a. CoreM a -> CoreIOEnv (a, CoreWriter)
unCoreM :: CoreIOEnv (a, CoreWriter) }
    deriving ((forall a b. (a -> b) -> CoreM a -> CoreM b)
-> (forall a b. a -> CoreM b -> CoreM a) -> Functor CoreM
forall a b. a -> CoreM b -> CoreM a
forall a b. (a -> b) -> CoreM a -> CoreM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> CoreM a -> CoreM b
fmap :: forall a b. (a -> b) -> CoreM a -> CoreM b
$c<$ :: forall a b. a -> CoreM b -> CoreM a
<$ :: forall a b. a -> CoreM b -> CoreM a
Functor)

instance Monad CoreM where
    CoreM a
mx >>= :: forall a b. CoreM a -> (a -> CoreM b) -> CoreM b
>>= a -> CoreM b
f = CoreIOEnv (b, CoreWriter) -> CoreM b
forall a. CoreIOEnv (a, CoreWriter) -> CoreM a
CoreM (CoreIOEnv (b, CoreWriter) -> CoreM b)
-> CoreIOEnv (b, CoreWriter) -> CoreM b
forall a b. (a -> b) -> a -> b
$ do
            (a
x, CoreWriter
w1) <- CoreM a -> CoreIOEnv (a, CoreWriter)
forall a. CoreM a -> CoreIOEnv (a, CoreWriter)
unCoreM CoreM a
mx
            (b
y, CoreWriter
w2) <- CoreM b -> CoreIOEnv (b, CoreWriter)
forall a. CoreM a -> CoreIOEnv (a, CoreWriter)
unCoreM (a -> CoreM b
f a
x)
            let w :: CoreWriter
w = CoreWriter
w1 CoreWriter -> CoreWriter -> CoreWriter
`plusWriter` CoreWriter
w2
            (b, CoreWriter) -> CoreIOEnv (b, CoreWriter)
forall a. a -> IOEnv CoreReader a
forall (m :: * -> *) a. Monad m => a -> m a
return ((b, CoreWriter) -> CoreIOEnv (b, CoreWriter))
-> (b, CoreWriter) -> CoreIOEnv (b, CoreWriter)
forall a b. (a -> b) -> a -> b
$ CoreWriter -> (b, CoreWriter) -> (b, CoreWriter)
forall a b. a -> b -> b
seq CoreWriter
w (b
y, CoreWriter
w)
            -- forcing w before building the tuple avoids a space leak
            -- (#7702)

instance Applicative CoreM where
    pure :: forall a. a -> CoreM a
pure a
x = CoreIOEnv (a, CoreWriter) -> CoreM a
forall a. CoreIOEnv (a, CoreWriter) -> CoreM a
CoreM (CoreIOEnv (a, CoreWriter) -> CoreM a)
-> CoreIOEnv (a, CoreWriter) -> CoreM a
forall a b. (a -> b) -> a -> b
$ a -> CoreIOEnv (a, CoreWriter)
forall a. a -> CoreIOEnv (a, CoreWriter)
nop a
x
    <*> :: forall a b. CoreM (a -> b) -> CoreM a -> CoreM b
(<*>) = CoreM (a -> b) -> CoreM a -> CoreM b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
    CoreM a
m *> :: forall a b. CoreM a -> CoreM b -> CoreM b
*> CoreM b
k = CoreM a
m CoreM a -> (a -> CoreM b) -> CoreM b
forall a b. CoreM a -> (a -> CoreM b) -> CoreM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
_ -> CoreM b
k

instance Alternative CoreM where
    empty :: forall a. CoreM a
empty   = CoreIOEnv (a, CoreWriter) -> CoreM a
forall a. CoreIOEnv (a, CoreWriter) -> CoreM a
CoreM CoreIOEnv (a, CoreWriter)
forall a. IOEnv CoreReader a
forall (f :: * -> *) a. Alternative f => f a
Control.Applicative.empty
    CoreM a
m <|> :: forall a. CoreM a -> CoreM a -> CoreM a
<|> CoreM a
n = CoreIOEnv (a, CoreWriter) -> CoreM a
forall a. CoreIOEnv (a, CoreWriter) -> CoreM a
CoreM (CoreM a -> CoreIOEnv (a, CoreWriter)
forall a. CoreM a -> CoreIOEnv (a, CoreWriter)
unCoreM CoreM a
m CoreIOEnv (a, CoreWriter)
-> CoreIOEnv (a, CoreWriter) -> CoreIOEnv (a, CoreWriter)
forall a.
IOEnv CoreReader a -> IOEnv CoreReader a -> IOEnv CoreReader a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> CoreM a -> CoreIOEnv (a, CoreWriter)
forall a. CoreM a -> CoreIOEnv (a, CoreWriter)
unCoreM CoreM a
n)

instance MonadPlus CoreM

instance MonadUnique CoreM where
    getUniqueSupplyM :: CoreM UniqSupply
getUniqueSupplyM = do
        Char
mask <- (CoreReader -> Char) -> CoreM Char
forall a. (CoreReader -> a) -> CoreM a
read CoreReader -> Char
cr_uniq_mask
        IO UniqSupply -> CoreM UniqSupply
forall a. IO a -> CoreM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UniqSupply -> CoreM UniqSupply)
-> IO UniqSupply -> CoreM UniqSupply
forall a b. (a -> b) -> a -> b
$! Char -> IO UniqSupply
mkSplitUniqSupply Char
mask

    getUniqueM :: CoreM Unique
getUniqueM = do
        Char
mask <- (CoreReader -> Char) -> CoreM Char
forall a. (CoreReader -> a) -> CoreM a
read CoreReader -> Char
cr_uniq_mask
        IO Unique -> CoreM Unique
forall a. IO a -> CoreM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Unique -> CoreM Unique) -> IO Unique -> CoreM Unique
forall a b. (a -> b) -> a -> b
$! Char -> IO Unique
uniqFromMask Char
mask

runCoreM :: HscEnv
         -> RuleBase
         -> Char -- ^ Mask
         -> Module
         -> NamePprCtx
         -> SrcSpan
         -> CoreM a
         -> IO (a, SimplCount)
runCoreM :: forall a.
HscEnv
-> RuleBase
-> Char
-> Module
-> NamePprCtx
-> SrcSpan
-> CoreM a
-> IO (a, SimplCount)
runCoreM HscEnv
hsc_env RuleBase
rule_base Char
mask Module
mod NamePprCtx
name_ppr_ctx SrcSpan
loc CoreM a
m
  = ((a, CoreWriter) -> (a, SimplCount))
-> IO (a, CoreWriter) -> IO (a, SimplCount)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (a, CoreWriter) -> (a, SimplCount)
forall a. (a, CoreWriter) -> (a, SimplCount)
extract (IO (a, CoreWriter) -> IO (a, SimplCount))
-> IO (a, CoreWriter) -> IO (a, SimplCount)
forall a b. (a -> b) -> a -> b
$ CoreReader
-> IOEnv CoreReader (a, CoreWriter) -> IO (a, CoreWriter)
forall env a. env -> IOEnv env a -> IO a
runIOEnv CoreReader
reader (IOEnv CoreReader (a, CoreWriter) -> IO (a, CoreWriter))
-> IOEnv CoreReader (a, CoreWriter) -> IO (a, CoreWriter)
forall a b. (a -> b) -> a -> b
$ CoreM a -> IOEnv CoreReader (a, CoreWriter)
forall a. CoreM a -> CoreIOEnv (a, CoreWriter)
unCoreM CoreM a
m
  where
    reader :: CoreReader
reader = CoreReader {
            cr_hsc_env :: HscEnv
cr_hsc_env = HscEnv
hsc_env,
            cr_rule_base :: RuleBase
cr_rule_base = RuleBase
rule_base,
            cr_module :: Module
cr_module = Module
mod,
            cr_name_ppr_ctx :: NamePprCtx
cr_name_ppr_ctx = NamePprCtx
name_ppr_ctx,
            cr_loc :: SrcSpan
cr_loc = SrcSpan
loc,
            cr_uniq_mask :: Char
cr_uniq_mask = Char
mask
        }

    extract :: (a, CoreWriter) -> (a, SimplCount)
    extract :: forall a. (a, CoreWriter) -> (a, SimplCount)
extract (a
value, CoreWriter
writer) = (a
value, CoreWriter -> SimplCount
cw_simpl_count CoreWriter
writer)

{-
************************************************************************
*                                                                      *
             Core combinators, not exported
*                                                                      *
************************************************************************
-}

nop :: a -> CoreIOEnv (a, CoreWriter)
nop :: forall a. a -> CoreIOEnv (a, CoreWriter)
nop a
x = do
    Logger
logger <- HscEnv -> Logger
hsc_logger (HscEnv -> Logger)
-> (CoreReader -> HscEnv) -> CoreReader -> Logger
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreReader -> HscEnv
cr_hsc_env (CoreReader -> Logger)
-> IOEnv CoreReader CoreReader -> IOEnv CoreReader Logger
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv CoreReader CoreReader
forall env. IOEnv env env
getEnv
    (a, CoreWriter) -> CoreIOEnv (a, CoreWriter)
forall a. a -> IOEnv CoreReader a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x, Bool -> CoreWriter
emptyWriter (Bool -> CoreWriter) -> Bool -> CoreWriter
forall a b. (a -> b) -> a -> b
$ Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_dump_simpl_stats)

read :: (CoreReader -> a) -> CoreM a
read :: forall a. (CoreReader -> a) -> CoreM a
read CoreReader -> a
f = CoreIOEnv (a, CoreWriter) -> CoreM a
forall a. CoreIOEnv (a, CoreWriter) -> CoreM a
CoreM (CoreIOEnv (a, CoreWriter) -> CoreM a)
-> CoreIOEnv (a, CoreWriter) -> CoreM a
forall a b. (a -> b) -> a -> b
$ IOEnv CoreReader CoreReader
forall env. IOEnv env env
getEnv IOEnv CoreReader CoreReader
-> (CoreReader -> CoreIOEnv (a, CoreWriter))
-> CoreIOEnv (a, CoreWriter)
forall a b.
IOEnv CoreReader a
-> (a -> IOEnv CoreReader b) -> IOEnv CoreReader b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\CoreReader
r -> a -> CoreIOEnv (a, CoreWriter)
forall a. a -> CoreIOEnv (a, CoreWriter)
nop (CoreReader -> a
f CoreReader
r))

write :: CoreWriter -> CoreM ()
write :: CoreWriter -> CoreM ()
write CoreWriter
w = CoreIOEnv ((), CoreWriter) -> CoreM ()
forall a. CoreIOEnv (a, CoreWriter) -> CoreM a
CoreM (CoreIOEnv ((), CoreWriter) -> CoreM ())
-> CoreIOEnv ((), CoreWriter) -> CoreM ()
forall a b. (a -> b) -> a -> b
$ ((), CoreWriter) -> CoreIOEnv ((), CoreWriter)
forall a. a -> IOEnv CoreReader a
forall (m :: * -> *) a. Monad m => a -> m a
return ((), CoreWriter
w)

-- \subsection{Lifting IO into the monad}

-- | Lift an 'IOEnv' operation into 'CoreM'
liftIOEnv :: CoreIOEnv a -> CoreM a
liftIOEnv :: forall a. CoreIOEnv a -> CoreM a
liftIOEnv CoreIOEnv a
mx = CoreIOEnv (a, CoreWriter) -> CoreM a
forall a. CoreIOEnv (a, CoreWriter) -> CoreM a
CoreM (CoreIOEnv a
mx CoreIOEnv a
-> (a -> CoreIOEnv (a, CoreWriter)) -> CoreIOEnv (a, CoreWriter)
forall a b.
IOEnv CoreReader a
-> (a -> IOEnv CoreReader b) -> IOEnv CoreReader b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\a
x -> a -> CoreIOEnv (a, CoreWriter)
forall a. a -> CoreIOEnv (a, CoreWriter)
nop a
x))

instance MonadIO CoreM where
    liftIO :: forall a. IO a -> CoreM a
liftIO = CoreIOEnv a -> CoreM a
forall a. CoreIOEnv a -> CoreM a
liftIOEnv (CoreIOEnv a -> CoreM a)
-> (IO a -> CoreIOEnv a) -> IO a -> CoreM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> CoreIOEnv a
forall a. IO a -> IOEnv CoreReader a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IOEnv.liftIO

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

{-
************************************************************************
*                                                                      *
             Reader, writer and state accessors
*                                                                      *
************************************************************************
-}

getHscEnv :: CoreM HscEnv
getHscEnv :: CoreM HscEnv
getHscEnv = (CoreReader -> HscEnv) -> CoreM HscEnv
forall a. (CoreReader -> a) -> CoreM a
read CoreReader -> HscEnv
cr_hsc_env

getHomeRuleBase :: CoreM RuleBase
getHomeRuleBase :: CoreM RuleBase
getHomeRuleBase = (CoreReader -> RuleBase) -> CoreM RuleBase
forall a. (CoreReader -> a) -> CoreM a
read CoreReader -> RuleBase
cr_rule_base

initRuleEnv :: ModGuts -> CoreM RuleEnv
initRuleEnv :: ModGuts -> CoreM RuleEnv
initRuleEnv ModGuts
guts
  = do { RuleBase
hpt_rules <- CoreM RuleBase
getHomeRuleBase
       ; RuleBase
eps_rules <- CoreM RuleBase
getExternalRuleBase
       ; RuleEnv -> CoreM RuleEnv
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModGuts -> RuleBase -> RuleBase -> RuleEnv
mkRuleEnv ModGuts
guts RuleBase
eps_rules RuleBase
hpt_rules) }

getExternalRuleBase :: CoreM RuleBase
getExternalRuleBase :: CoreM RuleBase
getExternalRuleBase = ExternalPackageState -> RuleBase
eps_rule_base (ExternalPackageState -> RuleBase)
-> CoreM ExternalPackageState -> CoreM RuleBase
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreM ExternalPackageState
get_eps

getNamePprCtx :: CoreM NamePprCtx
getNamePprCtx :: CoreM NamePprCtx
getNamePprCtx = (CoreReader -> NamePprCtx) -> CoreM NamePprCtx
forall a. (CoreReader -> a) -> CoreM a
read CoreReader -> NamePprCtx
cr_name_ppr_ctx

getSrcSpanM :: CoreM SrcSpan
getSrcSpanM :: CoreM SrcSpan
getSrcSpanM = (CoreReader -> SrcSpan) -> CoreM SrcSpan
forall a. (CoreReader -> a) -> CoreM a
read CoreReader -> SrcSpan
cr_loc

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

getUniqMask :: CoreM Char
getUniqMask :: CoreM Char
getUniqMask = (CoreReader -> Char) -> CoreM Char
forall a. (CoreReader -> a) -> CoreM a
read CoreReader -> Char
cr_uniq_mask

-- Convenience accessors for useful fields of HscEnv

-- | Adjust the dyn flags passed to the argument action
mapDynFlagsCoreM :: (DynFlags -> DynFlags) -> CoreM a -> CoreM a
mapDynFlagsCoreM :: forall a. (DynFlags -> DynFlags) -> CoreM a -> CoreM a
mapDynFlagsCoreM DynFlags -> DynFlags
f CoreM a
m = CoreIOEnv (a, CoreWriter) -> CoreM a
forall a. CoreIOEnv (a, CoreWriter) -> CoreM a
CoreM (CoreIOEnv (a, CoreWriter) -> CoreM a)
-> CoreIOEnv (a, CoreWriter) -> CoreM a
forall a b. (a -> b) -> a -> b
$ do
  !CoreReader
e <- IOEnv CoreReader CoreReader
forall env. IOEnv env env
getEnv
  let !e' :: CoreReader
e' = CoreReader
e { cr_hsc_env = hscUpdateFlags f $ cr_hsc_env e }
  IO (a, CoreWriter) -> CoreIOEnv (a, CoreWriter)
forall a. IO a -> IOEnv CoreReader a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (a, CoreWriter) -> CoreIOEnv (a, CoreWriter))
-> IO (a, CoreWriter) -> CoreIOEnv (a, CoreWriter)
forall a b. (a -> b) -> a -> b
$ CoreReader -> CoreIOEnv (a, CoreWriter) -> IO (a, CoreWriter)
forall env a. env -> IOEnv env a -> IO a
runIOEnv CoreReader
e' (CoreIOEnv (a, CoreWriter) -> IO (a, CoreWriter))
-> CoreIOEnv (a, CoreWriter) -> IO (a, CoreWriter)
forall a b. (a -> b) -> a -> b
$! CoreM a -> CoreIOEnv (a, CoreWriter)
forall a. CoreM a -> CoreIOEnv (a, CoreWriter)
unCoreM CoreM a
m

-- | Drop the single count of the argument action so it doesn't effect
-- the total.
dropSimplCount :: CoreM a -> CoreM a
dropSimplCount :: forall a. CoreM a -> CoreM a
dropSimplCount CoreM a
m = CoreIOEnv (a, CoreWriter) -> CoreM a
forall a. CoreIOEnv (a, CoreWriter) -> CoreM a
CoreM (CoreIOEnv (a, CoreWriter) -> CoreM a)
-> CoreIOEnv (a, CoreWriter) -> CoreM a
forall a b. (a -> b) -> a -> b
$ do
  (a
a, CoreWriter
_) <- CoreM a -> CoreIOEnv (a, CoreWriter)
forall a. CoreM a -> CoreIOEnv (a, CoreWriter)
unCoreM CoreM a
m
  CoreM a -> CoreIOEnv (a, CoreWriter)
forall a. CoreM a -> CoreIOEnv (a, CoreWriter)
unCoreM (CoreM a -> CoreIOEnv (a, CoreWriter))
-> CoreM a -> CoreIOEnv (a, CoreWriter)
forall a b. (a -> b) -> a -> b
$ a -> CoreM a
forall a. a -> CoreM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

instance HasDynFlags CoreM where
    getDynFlags :: CoreM DynFlags
getDynFlags = (HscEnv -> DynFlags) -> CoreM HscEnv -> CoreM DynFlags
forall a b. (a -> b) -> CoreM a -> CoreM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HscEnv -> DynFlags
hsc_dflags CoreM HscEnv
getHscEnv

instance HasLogger CoreM where
    getLogger :: CoreM Logger
getLogger = (HscEnv -> Logger) -> CoreM HscEnv -> CoreM Logger
forall a b. (a -> b) -> CoreM a -> CoreM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HscEnv -> Logger
hsc_logger CoreM HscEnv
getHscEnv

instance HasModule CoreM where
    getModule :: CoreM Module
getModule = (CoreReader -> Module) -> CoreM Module
forall a. (CoreReader -> a) -> CoreM a
read CoreReader -> Module
cr_module

getInteractiveContext :: CoreM InteractiveContext
getInteractiveContext :: CoreM InteractiveContext
getInteractiveContext = HscEnv -> InteractiveContext
hsc_IC (HscEnv -> InteractiveContext)
-> CoreM HscEnv -> CoreM InteractiveContext
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreM HscEnv
getHscEnv

getPackageFamInstEnv :: CoreM PackageFamInstEnv
getPackageFamInstEnv :: CoreM PackageFamInstEnv
getPackageFamInstEnv = ExternalPackageState -> PackageFamInstEnv
eps_fam_inst_env (ExternalPackageState -> PackageFamInstEnv)
-> CoreM ExternalPackageState -> CoreM PackageFamInstEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreM ExternalPackageState
get_eps

get_eps :: CoreM ExternalPackageState
get_eps :: CoreM ExternalPackageState
get_eps = do
    HscEnv
hsc_env <- CoreM HscEnv
getHscEnv
    IO ExternalPackageState -> CoreM ExternalPackageState
forall a. IO a -> CoreM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ExternalPackageState -> CoreM ExternalPackageState)
-> IO ExternalPackageState -> CoreM ExternalPackageState
forall a b. (a -> b) -> a -> b
$ HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env

{-
************************************************************************
*                                                                      *
             Dealing with annotations
*                                                                      *
************************************************************************
-}

-- | 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).
--
-- This should be done once at the start of a Core-to-Core pass that uses
-- annotations.
--
-- See Note [Annotations]
getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (ModuleEnv [a], NameEnv [a])
getAnnotations :: forall a.
Typeable a =>
([Word8] -> a) -> ModGuts -> CoreM (ModuleEnv [a], NameEnv [a])
getAnnotations [Word8] -> a
deserialize ModGuts
guts = do
     HscEnv
hsc_env <- CoreM HscEnv
getHscEnv
     AnnEnv
ann_env <- IO AnnEnv -> CoreM AnnEnv
forall a. IO a -> CoreM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO AnnEnv -> CoreM AnnEnv) -> IO AnnEnv -> CoreM AnnEnv
forall a b. (a -> b) -> a -> b
$ HscEnv -> Maybe ModGuts -> IO AnnEnv
prepareAnnotations HscEnv
hsc_env (ModGuts -> Maybe ModGuts
forall a. a -> Maybe a
Just ModGuts
guts)
     (ModuleEnv [a], NameEnv [a]) -> CoreM (ModuleEnv [a], NameEnv [a])
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return (([Word8] -> a) -> AnnEnv -> (ModuleEnv [a], NameEnv [a])
forall a.
Typeable a =>
([Word8] -> a) -> AnnEnv -> (ModuleEnv [a], NameEnv [a])
deserializeAnns [Word8] -> a
deserialize AnnEnv
ann_env)

-- | Get at most one annotation of a given type per annotatable item.
getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (ModuleEnv a, NameEnv a)
getFirstAnnotations :: forall a.
Typeable a =>
([Word8] -> a) -> ModGuts -> CoreM (ModuleEnv a, NameEnv a)
getFirstAnnotations [Word8] -> a
deserialize ModGuts
guts
  = (ModuleEnv [a] -> ModuleEnv a)
-> (NameEnv [a] -> NameEnv a)
-> (ModuleEnv [a], NameEnv [a])
-> (ModuleEnv a, NameEnv a)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ModuleEnv [a] -> ModuleEnv a
forall {b}. ModuleEnv [b] -> ModuleEnv b
mod NameEnv [a] -> NameEnv a
forall {b}. NameEnv [b] -> NameEnv b
name ((ModuleEnv [a], NameEnv [a]) -> (ModuleEnv a, NameEnv a))
-> CoreM (ModuleEnv [a], NameEnv [a])
-> CoreM (ModuleEnv a, NameEnv a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Word8] -> a) -> ModGuts -> CoreM (ModuleEnv [a], NameEnv [a])
forall a.
Typeable a =>
([Word8] -> a) -> ModGuts -> CoreM (ModuleEnv [a], NameEnv [a])
getAnnotations [Word8] -> a
deserialize ModGuts
guts
  where
    mod :: ModuleEnv [b] -> ModuleEnv b
mod = (Module -> [b] -> Maybe b) -> ModuleEnv [b] -> ModuleEnv b
forall a b. (Module -> a -> Maybe b) -> ModuleEnv a -> ModuleEnv b
mapMaybeModuleEnv (([b] -> Maybe b) -> Module -> [b] -> Maybe b
forall a b. a -> b -> a
const [b] -> Maybe b
forall a. [a] -> Maybe a
listToMaybe)
    name :: NameEnv [b] -> NameEnv b
name = ([b] -> Maybe b) -> NameEnv [b] -> NameEnv b
forall a b. (a -> Maybe b) -> NameEnv a -> NameEnv b
mapMaybeNameEnv [b] -> Maybe b
forall a. [a] -> Maybe a
listToMaybe

{-
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.

************************************************************************
*                                                                      *
                Direct screen output
*                                                                      *
************************************************************************
-}

msg :: MessageClass -> SDoc -> CoreM ()
msg :: MessageClass -> SDoc -> CoreM ()
msg MessageClass
msg_class SDoc
doc = do
    Logger
logger <- CoreM Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
    SrcSpan
loc    <- CoreM SrcSpan
getSrcSpanM
    NamePprCtx
name_ppr_ctx <- CoreM NamePprCtx
getNamePprCtx
    let sty :: PprStyle
sty = case MessageClass
msg_class of
                MCDiagnostic Severity
_ DiagnosticReason
_ Maybe DiagnosticCode
_ -> PprStyle
err_sty
                MessageClass
MCDump             -> PprStyle
dump_sty
                MessageClass
_                  -> PprStyle
user_sty
        err_sty :: PprStyle
err_sty  = NamePprCtx -> PprStyle
mkErrStyle NamePprCtx
name_ppr_ctx
        user_sty :: PprStyle
user_sty = NamePprCtx -> Depth -> PprStyle
mkUserStyle NamePprCtx
name_ppr_ctx Depth
AllTheWay
        dump_sty :: PprStyle
dump_sty = NamePprCtx -> PprStyle
mkDumpStyle NamePprCtx
name_ppr_ctx
    IO () -> CoreM ()
forall a. IO a -> CoreM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CoreM ()) -> IO () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
logMsg Logger
logger MessageClass
msg_class SrcSpan
loc (PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
sty SDoc
doc)

-- | Output a String message to the screen
putMsgS :: String -> CoreM ()
putMsgS :: String -> CoreM ()
putMsgS = SDoc -> CoreM ()
putMsg (SDoc -> CoreM ()) -> (String -> SDoc) -> String -> CoreM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> SDoc
forall doc. IsLine doc => String -> doc
text

-- | Output a message to the screen
putMsg :: SDoc -> CoreM ()
putMsg :: SDoc -> CoreM ()
putMsg = MessageClass -> SDoc -> CoreM ()
msg MessageClass
MCInfo

-- | Output an error to the screen. Does not cause the compiler to die.
errorMsg :: SDoc -> CoreM ()
errorMsg :: SDoc -> CoreM ()
errorMsg SDoc
doc = MessageClass -> SDoc -> CoreM ()
msg MessageClass
errorDiagnostic SDoc
doc

-- | Output a fatal error to the screen. Does not cause the compiler to die.
fatalErrorMsgS :: String -> CoreM ()
fatalErrorMsgS :: String -> CoreM ()
fatalErrorMsgS = SDoc -> CoreM ()
fatalErrorMsg (SDoc -> CoreM ()) -> (String -> SDoc) -> String -> CoreM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> SDoc
forall doc. IsLine doc => String -> doc
text

-- | Output a fatal error to the screen. Does not cause the compiler to die.
fatalErrorMsg :: SDoc -> CoreM ()
fatalErrorMsg :: SDoc -> CoreM ()
fatalErrorMsg = MessageClass -> SDoc -> CoreM ()
msg MessageClass
MCFatal

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

-- | Outputs a debugging message at verbosity level of @-v@ or higher
debugTraceMsg :: SDoc -> CoreM ()
debugTraceMsg :: SDoc -> CoreM ()
debugTraceMsg = MessageClass -> SDoc -> CoreM ()
msg MessageClass
MCDump