{-# LANGUAGE DeriveFunctor #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module GHC.Core.Opt.Monad (
CoreToDo(..), runWhen, runMaybe,
SimplMode(..),
FloatOutSwitches(..),
pprPassDetails,
CorePluginPass, bindsOnlyPass,
SimplCount, doSimplTick, doFreeSimplTick, simplCountN,
pprSimplCount, plusSimplCount, zeroSimplCount,
isZeroSimplCount, hasDetailedCounts, Tick(..),
CoreM, runCoreM,
getHscEnv, getRuleBase, getModule,
getDynFlags, getPackageFamInstEnv,
getVisibleOrphanMods, getUniqMask,
getPrintUnqualified, getSrcSpanM,
addSimplCount,
liftIO, liftIOWithCount,
getAnnotations, getFirstAnnotations,
putMsg, putMsgS, errorMsg, errorMsgS, msg,
fatalErrorMsg, fatalErrorMsgS,
debugTraceMsg, debugTraceMsgS,
) where
import GHC.Prelude hiding ( read )
import GHC.Driver.Session
import GHC.Driver.Env
import GHC.Core
import GHC.Core.Unfold
import GHC.Types.Basic ( CompilerPhase(..) )
import GHC.Types.Annotations
import GHC.Types.Var
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.FastString
import GHC.Data.IOEnv hiding ( liftIO, failM, failWithM )
import qualified GHC.Data.IOEnv as IOEnv
import GHC.Unit.Module
import GHC.Unit.Module.ModGuts
import GHC.Unit.External
import Data.Bifunctor ( bimap )
import Data.List (intersperse, groupBy, sortBy)
import Data.Ord
import Data.Dynamic
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Map.Strict as MapStrict
import Data.Word
import Control.Monad
import Control.Applicative ( Alternative(..) )
import GHC.Utils.Panic (throwGhcException, GhcException(..), panic)
data CoreToDo
= CoreDoSimplify
Int
SimplMode
| CoreDoPluginPass String CorePluginPass
| CoreDoFloatInwards
| CoreDoFloatOutwards FloatOutSwitches
| CoreLiberateCase
| CoreDoPrintCore
| CoreDoStaticArgs
| CoreDoCallArity
| CoreDoExitify
| CoreDoDemand
| CoreDoCpr
| CoreDoWorkerWrapper
| CoreDoSpecialising
| CoreDoSpecConstr
| CoreCSE
| CoreDoRuleCheck CompilerPhase String
| CoreDoNothing
| CoreDoPasses [CoreToDo]
| CoreDesugar
| CoreDesugarOpt
| CoreTidy
| CorePrep
| CoreAddCallerCcs
| CoreAddLateCcs
| CoreOccurAnal
instance Outputable CoreToDo where
ppr :: CoreToDo -> SDoc
ppr (CoreDoSimplify Int
_ SimplMode
_) = String -> SDoc
text String
"Simplifier"
ppr (CoreDoPluginPass String
s CorePluginPass
_) = String -> SDoc
text String
"Core plugin: " SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
s
ppr CoreToDo
CoreDoFloatInwards = String -> SDoc
text String
"Float inwards"
ppr (CoreDoFloatOutwards FloatOutSwitches
f) = String -> SDoc
text String
"Float out" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens (FloatOutSwitches -> SDoc
forall a. Outputable a => a -> SDoc
ppr FloatOutSwitches
f)
ppr CoreToDo
CoreLiberateCase = String -> SDoc
text String
"Liberate case"
ppr CoreToDo
CoreDoStaticArgs = String -> SDoc
text String
"Static argument"
ppr CoreToDo
CoreDoCallArity = String -> SDoc
text String
"Called arity analysis"
ppr CoreToDo
CoreDoExitify = String -> SDoc
text String
"Exitification transformation"
ppr CoreToDo
CoreDoDemand = String -> SDoc
text String
"Demand analysis"
ppr CoreToDo
CoreDoCpr = String -> SDoc
text String
"Constructed Product Result analysis"
ppr CoreToDo
CoreDoWorkerWrapper = String -> SDoc
text String
"Worker Wrapper binds"
ppr CoreToDo
CoreDoSpecialising = String -> SDoc
text String
"Specialise"
ppr CoreToDo
CoreDoSpecConstr = String -> SDoc
text String
"SpecConstr"
ppr CoreToDo
CoreCSE = String -> SDoc
text String
"Common sub-expression"
ppr CoreToDo
CoreDesugar = String -> SDoc
text String
"Desugar (before optimization)"
ppr CoreToDo
CoreDesugarOpt = String -> SDoc
text String
"Desugar (after optimization)"
ppr CoreToDo
CoreTidy = String -> SDoc
text String
"Tidy Core"
ppr CoreToDo
CoreAddCallerCcs = String -> SDoc
text String
"Add caller cost-centres"
ppr CoreToDo
CoreAddLateCcs = String -> SDoc
text String
"Add late core cost-centres"
ppr CoreToDo
CorePrep = String -> SDoc
text String
"CorePrep"
ppr CoreToDo
CoreOccurAnal = String -> SDoc
text String
"Occurrence analysis"
ppr CoreToDo
CoreDoPrintCore = String -> SDoc
text String
"Print core"
ppr (CoreDoRuleCheck {}) = String -> SDoc
text String
"Rule check"
ppr CoreToDo
CoreDoNothing = String -> SDoc
text String
"CoreDoNothing"
ppr (CoreDoPasses [CoreToDo]
passes) = String -> SDoc
text String
"CoreDoPasses" SDoc -> SDoc -> SDoc
<+> [CoreToDo] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CoreToDo]
passes
pprPassDetails :: CoreToDo -> SDoc
pprPassDetails :: CoreToDo -> SDoc
pprPassDetails (CoreDoSimplify Int
n SimplMode
md) = [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Max iterations =" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
n
, SimplMode -> SDoc
forall a. Outputable a => a -> SDoc
ppr SimplMode
md ]
pprPassDetails CoreToDo
_ = SDoc
Outputable.empty
data SimplMode
= SimplMode
{ SimplMode -> [String]
sm_names :: [String]
, SimplMode -> CompilerPhase
sm_phase :: CompilerPhase
, SimplMode -> UnfoldingOpts
sm_uf_opts :: !UnfoldingOpts
, SimplMode -> Bool
sm_rules :: !Bool
, SimplMode -> Bool
sm_inline :: !Bool
, SimplMode -> Bool
sm_case_case :: !Bool
, SimplMode -> Bool
sm_eta_expand :: !Bool
, SimplMode -> Bool
sm_cast_swizzle :: !Bool
, SimplMode -> Bool
sm_pre_inline :: !Bool
, SimplMode -> Logger
sm_logger :: !Logger
, SimplMode -> DynFlags
sm_dflags :: DynFlags
}
instance Outputable SimplMode where
ppr :: SimplMode -> SDoc
ppr (SimplMode { sm_phase :: SimplMode -> CompilerPhase
sm_phase = CompilerPhase
p, sm_names :: SimplMode -> [String]
sm_names = [String]
ss
, sm_rules :: SimplMode -> Bool
sm_rules = Bool
r, sm_inline :: SimplMode -> Bool
sm_inline = Bool
i
, sm_cast_swizzle :: SimplMode -> Bool
sm_cast_swizzle = Bool
cs
, sm_eta_expand :: SimplMode -> Bool
sm_eta_expand = Bool
eta, sm_case_case :: SimplMode -> Bool
sm_case_case = Bool
cc })
= String -> SDoc
text String
"SimplMode" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
braces (
[SDoc] -> SDoc
sep [ String -> SDoc
text String
"Phase =" SDoc -> SDoc -> SDoc
<+> CompilerPhase -> SDoc
forall a. Outputable a => a -> SDoc
ppr CompilerPhase
p SDoc -> SDoc -> SDoc
<+>
SDoc -> SDoc
brackets (String -> SDoc
text ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
"," [String]
ss)) SDoc -> SDoc -> SDoc
<> SDoc
comma
, Bool -> SDoc -> SDoc
pp_flag Bool
i (String -> SDoc
text String
"inline") SDoc -> SDoc -> SDoc
<> SDoc
comma
, Bool -> SDoc -> SDoc
pp_flag Bool
r (String -> SDoc
text String
"rules") SDoc -> SDoc -> SDoc
<> SDoc
comma
, Bool -> SDoc -> SDoc
pp_flag Bool
eta (String -> SDoc
text String
"eta-expand") SDoc -> SDoc -> SDoc
<> SDoc
comma
, Bool -> SDoc -> SDoc
pp_flag Bool
cs (String -> SDoc
text String
"cast-swizzle") SDoc -> SDoc -> SDoc
<> SDoc
comma
, Bool -> SDoc -> SDoc
pp_flag Bool
cc (String -> SDoc
text String
"case-of-case") ])
where
pp_flag :: Bool -> SDoc -> SDoc
pp_flag Bool
f SDoc
s = Bool -> SDoc -> SDoc
ppUnless Bool
f (String -> SDoc
text String
"no") SDoc -> SDoc -> SDoc
<+> SDoc
s
data FloatOutSwitches = FloatOutSwitches {
FloatOutSwitches -> Maybe Int
floatOutLambdas :: Maybe Int,
FloatOutSwitches -> Bool
floatOutConstants :: Bool,
FloatOutSwitches -> Bool
floatOutOverSatApps :: Bool,
FloatOutSwitches -> Bool
floatToTopLevelOnly :: Bool
}
instance Outputable FloatOutSwitches where
ppr :: FloatOutSwitches -> SDoc
ppr = FloatOutSwitches -> SDoc
pprFloatOutSwitches
pprFloatOutSwitches :: FloatOutSwitches -> SDoc
pprFloatOutSwitches :: FloatOutSwitches -> SDoc
pprFloatOutSwitches FloatOutSwitches
sw
= String -> SDoc
text String
"FOS" SDoc -> SDoc -> SDoc
<+> (SDoc -> SDoc
braces (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
sep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> a -> b
$
[ String -> SDoc
text String
"Lam =" SDoc -> SDoc -> SDoc
<+> Maybe Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr (FloatOutSwitches -> Maybe Int
floatOutLambdas FloatOutSwitches
sw)
, String -> SDoc
text String
"Consts =" SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr (FloatOutSwitches -> Bool
floatOutConstants FloatOutSwitches
sw)
, String -> SDoc
text String
"OverSatApps =" SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr (FloatOutSwitches -> Bool
floatOutOverSatApps FloatOutSwitches
sw) ])
runWhen :: Bool -> CoreToDo -> CoreToDo
runWhen :: Bool -> CoreToDo -> CoreToDo
runWhen Bool
True CoreToDo
do_this = CoreToDo
do_this
runWhen Bool
False CoreToDo
_ = CoreToDo
CoreDoNothing
runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo
runMaybe :: forall a. Maybe a -> (a -> CoreToDo) -> CoreToDo
runMaybe (Just a
x) a -> CoreToDo
f = a -> CoreToDo
f a
x
runMaybe Maybe a
Nothing a -> CoreToDo
_ = CoreToDo
CoreDoNothing
type CorePluginPass = ModGuts -> CoreM ModGuts
bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts
bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> CorePluginPass
bindsOnlyPass CoreProgram -> CoreM CoreProgram
pass ModGuts
guts
= do { CoreProgram
binds' <- CoreProgram -> CoreM CoreProgram
pass (ModGuts -> CoreProgram
mg_binds ModGuts
guts)
; CorePluginPass
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModGuts
guts { mg_binds :: CoreProgram
mg_binds = CoreProgram
binds' }) }
getVerboseSimplStats :: (Bool -> SDoc) -> SDoc
getVerboseSimplStats :: (Bool -> SDoc) -> SDoc
getVerboseSimplStats = (Bool -> SDoc) -> SDoc
getPprDebug
zeroSimplCount :: DynFlags -> SimplCount
isZeroSimplCount :: SimplCount -> Bool
hasDetailedCounts :: SimplCount -> Bool
pprSimplCount :: SimplCount -> SDoc
doSimplTick :: DynFlags -> Tick -> SimplCount -> SimplCount
doFreeSimplTick :: Tick -> SimplCount -> SimplCount
plusSimplCount :: SimplCount -> SimplCount -> SimplCount
data SimplCount
= VerySimplCount !Int
| SimplCount {
SimplCount -> Int
ticks :: !Int,
SimplCount -> TickCounts
details :: !TickCounts,
SimplCount -> Int
n_log :: !Int,
SimplCount -> [Tick]
log1 :: [Tick],
SimplCount -> [Tick]
log2 :: [Tick]
}
type TickCounts = Map Tick Int
simplCountN :: SimplCount -> Int
simplCountN :: SimplCount -> Int
simplCountN (VerySimplCount Int
n) = Int
n
simplCountN (SimplCount { ticks :: SimplCount -> Int
ticks = Int
n }) = Int
n
zeroSimplCount :: DynFlags -> SimplCount
zeroSimplCount DynFlags
dflags
| DumpFlag -> DynFlags -> Bool
dopt DumpFlag
Opt_D_dump_simpl_stats DynFlags
dflags
= SimplCount {ticks :: Int
ticks = Int
0, details :: TickCounts
details = TickCounts
forall k a. Map k a
Map.empty,
n_log :: Int
n_log = Int
0, log1 :: [Tick]
log1 = [], log2 :: [Tick]
log2 = []}
| Bool
otherwise
= Int -> SimplCount
VerySimplCount Int
0
isZeroSimplCount :: SimplCount -> Bool
isZeroSimplCount (VerySimplCount Int
n) = Int
nInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0
isZeroSimplCount (SimplCount { ticks :: SimplCount -> Int
ticks = Int
n }) = Int
nInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0
hasDetailedCounts :: SimplCount -> Bool
hasDetailedCounts (VerySimplCount {}) = Bool
False
hasDetailedCounts (SimplCount {}) = Bool
True
doFreeSimplTick :: Tick -> SimplCount -> SimplCount
doFreeSimplTick Tick
tick sc :: SimplCount
sc@SimplCount { details :: SimplCount -> TickCounts
details = TickCounts
dts }
= SimplCount
sc { details :: TickCounts
details = TickCounts
dts TickCounts -> Tick -> TickCounts
`addTick` Tick
tick }
doFreeSimplTick Tick
_ SimplCount
sc = SimplCount
sc
doSimplTick :: DynFlags -> Tick -> SimplCount -> SimplCount
doSimplTick DynFlags
dflags Tick
tick
sc :: SimplCount
sc@(SimplCount { ticks :: SimplCount -> Int
ticks = Int
tks, details :: SimplCount -> TickCounts
details = TickCounts
dts, n_log :: SimplCount -> Int
n_log = Int
nl, log1 :: SimplCount -> [Tick]
log1 = [Tick]
l1 })
| Int
nl Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= DynFlags -> Int
historySize DynFlags
dflags = SimplCount
sc1 { n_log :: Int
n_log = Int
1, log1 :: [Tick]
log1 = [Tick
tick], log2 :: [Tick]
log2 = [Tick]
l1 }
| Bool
otherwise = SimplCount
sc1 { n_log :: Int
n_log = Int
nlInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, log1 :: [Tick]
log1 = Tick
tick Tick -> [Tick] -> [Tick]
forall a. a -> [a] -> [a]
: [Tick]
l1 }
where
sc1 :: SimplCount
sc1 = SimplCount
sc { ticks :: Int
ticks = Int
tksInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, details :: TickCounts
details = TickCounts
dts TickCounts -> Tick -> TickCounts
`addTick` Tick
tick }
doSimplTick DynFlags
_ Tick
_ (VerySimplCount Int
n) = Int -> SimplCount
VerySimplCount (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
addTick :: TickCounts -> Tick -> TickCounts
addTick :: TickCounts -> Tick -> TickCounts
addTick TickCounts
fm Tick
tick = (Int -> Int -> Int) -> Tick -> Int -> TickCounts -> TickCounts
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
MapStrict.insertWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Tick
tick Int
1 TickCounts
fm
plusSimplCount :: SimplCount -> SimplCount -> SimplCount
plusSimplCount sc1 :: SimplCount
sc1@(SimplCount { ticks :: SimplCount -> Int
ticks = Int
tks1, details :: SimplCount -> TickCounts
details = TickCounts
dts1 })
sc2 :: SimplCount
sc2@(SimplCount { ticks :: SimplCount -> Int
ticks = Int
tks2, details :: SimplCount -> TickCounts
details = TickCounts
dts2 })
= SimplCount
log_base { ticks :: Int
ticks = Int
tks1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
tks2
, details :: TickCounts
details = (Int -> Int -> Int) -> TickCounts -> TickCounts -> TickCounts
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
MapStrict.unionWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) TickCounts
dts1 TickCounts
dts2 }
where
log_base :: SimplCount
log_base | [Tick] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (SimplCount -> [Tick]
log1 SimplCount
sc2) = SimplCount
sc1
| [Tick] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (SimplCount -> [Tick]
log2 SimplCount
sc2) = SimplCount
sc2 { log2 :: [Tick]
log2 = SimplCount -> [Tick]
log1 SimplCount
sc1 }
| Bool
otherwise = SimplCount
sc2
plusSimplCount (VerySimplCount Int
n) (VerySimplCount Int
m) = Int -> SimplCount
VerySimplCount (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
m)
plusSimplCount SimplCount
lhs SimplCount
rhs =
GhcException -> SimplCount
forall a. GhcException -> a
throwGhcException (GhcException -> SimplCount)
-> (SDoc -> GhcException) -> SDoc -> SimplCount
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> SDoc -> GhcException
PprProgramError String
"plusSimplCount" (SDoc -> SimplCount) -> SDoc -> SimplCount
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"lhs"
, SimplCount -> SDoc
pprSimplCount SimplCount
lhs
, String -> SDoc
text String
"rhs"
, SimplCount -> SDoc
pprSimplCount SimplCount
rhs
]
pprSimplCount :: SimplCount -> SDoc
pprSimplCount (VerySimplCount Int
n) = String -> SDoc
text String
"Total ticks:" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
n
pprSimplCount (SimplCount { ticks :: SimplCount -> Int
ticks = Int
tks, details :: SimplCount -> TickCounts
details = TickCounts
dts, log1 :: SimplCount -> [Tick]
log1 = [Tick]
l1, log2 :: SimplCount -> [Tick]
log2 = [Tick]
l2 })
= [SDoc] -> SDoc
vcat [String -> SDoc
text String
"Total ticks: " SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
tks,
SDoc
blankLine,
TickCounts -> SDoc
pprTickCounts TickCounts
dts,
(Bool -> SDoc) -> SDoc
getVerboseSimplStats ((Bool -> SDoc) -> SDoc) -> (Bool -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \Bool
dbg -> if Bool
dbg
then
[SDoc] -> SDoc
vcat [SDoc
blankLine,
String -> SDoc
text String
"Log (most recent first)",
Int -> SDoc -> SDoc
nest Int
4 ([SDoc] -> SDoc
vcat ((Tick -> SDoc) -> [Tick] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Tick -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Tick]
l1) SDoc -> SDoc -> SDoc
$$ [SDoc] -> SDoc
vcat ((Tick -> SDoc) -> [Tick] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Tick -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Tick]
l2))]
else SDoc
Outputable.empty
]
pprTickCounts :: Map Tick Int -> SDoc
pprTickCounts :: TickCounts -> SDoc
pprTickCounts TickCounts
counts
= [SDoc] -> SDoc
vcat (([(Tick, Int)] -> SDoc) -> [[(Tick, Int)]] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map [(Tick, Int)] -> SDoc
pprTickGroup [[(Tick, Int)]]
groups)
where
groups :: [[(Tick,Int)]]
groups :: [[(Tick, Int)]]
groups = ((Tick, Int) -> (Tick, Int) -> Bool)
-> [(Tick, Int)] -> [[(Tick, Int)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (Tick, Int) -> (Tick, Int) -> Bool
forall {b} {b}. (Tick, b) -> (Tick, b) -> Bool
same_tag (TickCounts -> [(Tick, Int)]
forall k a. Map k a -> [(k, a)]
Map.toList TickCounts
counts)
same_tag :: (Tick, b) -> (Tick, b) -> Bool
same_tag (Tick
tick1,b
_) (Tick
tick2,b
_) = Tick -> Int
tickToTag Tick
tick1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Tick -> Int
tickToTag Tick
tick2
pprTickGroup :: [(Tick, Int)] -> SDoc
pprTickGroup :: [(Tick, Int)] -> SDoc
pprTickGroup group :: [(Tick, Int)]
group@((Tick
tick1,Int
_):[(Tick, Int)]
_)
= SDoc -> Int -> SDoc -> SDoc
hang (Int -> SDoc
int ([Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int
n | (Tick
_,Int
n) <- [(Tick, Int)]
group]) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text (Tick -> String
tickString Tick
tick1))
Int
2 ([SDoc] -> SDoc
vcat [ Int -> SDoc
int Int
n SDoc -> SDoc -> SDoc
<+> Tick -> SDoc
pprTickCts Tick
tick
| (Tick
tick,Int
n) <- ((Tick, Int) -> (Tick, Int) -> Ordering)
-> [(Tick, Int)] -> [(Tick, Int)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Tick, Int) -> (Tick, Int) -> Ordering)
-> (Tick, Int) -> (Tick, Int) -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip (((Tick, Int) -> Int) -> (Tick, Int) -> (Tick, Int) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Tick, Int) -> Int
forall a b. (a, b) -> b
snd)) [(Tick, Int)]
group])
pprTickGroup [] = String -> SDoc
forall a. String -> a
panic String
"pprTickGroup"
data Tick
= PreInlineUnconditionally Id
| PostInlineUnconditionally Id
| UnfoldingDone Id
| RuleFired FastString
| LetFloatFromLet
| EtaExpansion Id
| EtaReduction Id
| BetaReduction Id
| CaseOfCase Id
| KnownBranch Id
| CaseMerge Id
| AltMerge Id
| CaseElim Id
| CaseIdentity Id
| FillInCaseDefault Id
| SimplifierDone
instance Outputable Tick where
ppr :: Tick -> SDoc
ppr Tick
tick = String -> SDoc
text (Tick -> String
tickString Tick
tick) SDoc -> SDoc -> SDoc
<+> Tick -> SDoc
pprTickCts Tick
tick
instance Eq Tick where
Tick
a == :: Tick -> Tick -> Bool
== Tick
b = case Tick
a Tick -> Tick -> Ordering
`cmpTick` Tick
b of
Ordering
EQ -> Bool
True
Ordering
_ -> Bool
False
instance Ord Tick where
compare :: Tick -> Tick -> Ordering
compare = Tick -> Tick -> Ordering
cmpTick
tickToTag :: Tick -> Int
tickToTag :: Tick -> Int
tickToTag (PreInlineUnconditionally Id
_) = Int
0
tickToTag (PostInlineUnconditionally Id
_) = Int
1
tickToTag (UnfoldingDone Id
_) = Int
2
tickToTag (RuleFired FastString
_) = Int
3
tickToTag Tick
LetFloatFromLet = Int
4
tickToTag (EtaExpansion Id
_) = Int
5
tickToTag (EtaReduction Id
_) = Int
6
tickToTag (BetaReduction Id
_) = Int
7
tickToTag (CaseOfCase Id
_) = Int
8
tickToTag (KnownBranch Id
_) = Int
9
tickToTag (CaseMerge Id
_) = Int
10
tickToTag (CaseElim Id
_) = Int
11
tickToTag (CaseIdentity Id
_) = Int
12
tickToTag (FillInCaseDefault Id
_) = Int
13
tickToTag Tick
SimplifierDone = Int
16
tickToTag (AltMerge Id
_) = Int
17
tickString :: Tick -> String
tickString :: Tick -> String
tickString (PreInlineUnconditionally Id
_) = String
"PreInlineUnconditionally"
tickString (PostInlineUnconditionally Id
_)= String
"PostInlineUnconditionally"
tickString (UnfoldingDone Id
_) = String
"UnfoldingDone"
tickString (RuleFired FastString
_) = String
"RuleFired"
tickString Tick
LetFloatFromLet = String
"LetFloatFromLet"
tickString (EtaExpansion Id
_) = String
"EtaExpansion"
tickString (EtaReduction Id
_) = String
"EtaReduction"
tickString (BetaReduction Id
_) = String
"BetaReduction"
tickString (CaseOfCase Id
_) = String
"CaseOfCase"
tickString (KnownBranch Id
_) = String
"KnownBranch"
tickString (CaseMerge Id
_) = String
"CaseMerge"
tickString (AltMerge Id
_) = String
"AltMerge"
tickString (CaseElim Id
_) = String
"CaseElim"
tickString (CaseIdentity Id
_) = String
"CaseIdentity"
tickString (FillInCaseDefault Id
_) = String
"FillInCaseDefault"
tickString Tick
SimplifierDone = String
"SimplifierDone"
pprTickCts :: Tick -> SDoc
pprTickCts :: Tick -> SDoc
pprTickCts (PreInlineUnconditionally Id
v) = Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
v
pprTickCts (PostInlineUnconditionally Id
v)= Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
v
pprTickCts (UnfoldingDone Id
v) = Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
v
pprTickCts (RuleFired FastString
v) = FastString -> SDoc
forall a. Outputable a => a -> SDoc
ppr FastString
v
pprTickCts Tick
LetFloatFromLet = SDoc
Outputable.empty
pprTickCts (EtaExpansion Id
v) = Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
v
pprTickCts (EtaReduction Id
v) = Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
v
pprTickCts (BetaReduction Id
v) = Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
v
pprTickCts (CaseOfCase Id
v) = Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
v
pprTickCts (KnownBranch Id
v) = Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
v
pprTickCts (CaseMerge Id
v) = Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
v
pprTickCts (AltMerge Id
v) = Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
v
pprTickCts (CaseElim Id
v) = Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
v
pprTickCts (CaseIdentity Id
v) = Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
v
pprTickCts (FillInCaseDefault Id
v) = Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
v
pprTickCts Tick
_ = SDoc
Outputable.empty
cmpTick :: Tick -> Tick -> Ordering
cmpTick :: Tick -> Tick -> Ordering
cmpTick Tick
a Tick
b = case (Tick -> Int
tickToTag Tick
a Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Tick -> Int
tickToTag Tick
b) of
Ordering
GT -> Ordering
GT
Ordering
EQ -> Tick -> Tick -> Ordering
cmpEqTick Tick
a Tick
b
Ordering
LT -> Ordering
LT
cmpEqTick :: Tick -> Tick -> Ordering
cmpEqTick :: Tick -> Tick -> Ordering
cmpEqTick (PreInlineUnconditionally Id
a) (PreInlineUnconditionally Id
b) = Id
a Id -> Id -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Id
b
cmpEqTick (PostInlineUnconditionally Id
a) (PostInlineUnconditionally Id
b) = Id
a Id -> Id -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Id
b
cmpEqTick (UnfoldingDone Id
a) (UnfoldingDone Id
b) = Id
a Id -> Id -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Id
b
cmpEqTick (RuleFired FastString
a) (RuleFired FastString
b) = FastString
a FastString -> FastString -> Ordering
`uniqCompareFS` FastString
b
cmpEqTick (EtaExpansion Id
a) (EtaExpansion Id
b) = Id
a Id -> Id -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Id
b
cmpEqTick (EtaReduction Id
a) (EtaReduction Id
b) = Id
a Id -> Id -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Id
b
cmpEqTick (BetaReduction Id
a) (BetaReduction Id
b) = Id
a Id -> Id -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Id
b
cmpEqTick (CaseOfCase Id
a) (CaseOfCase Id
b) = Id
a Id -> Id -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Id
b
cmpEqTick (KnownBranch Id
a) (KnownBranch Id
b) = Id
a Id -> Id -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Id
b
cmpEqTick (CaseMerge Id
a) (CaseMerge Id
b) = Id
a Id -> Id -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Id
b
cmpEqTick (AltMerge Id
a) (AltMerge Id
b) = Id
a Id -> Id -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Id
b
cmpEqTick (CaseElim Id
a) (CaseElim Id
b) = Id
a Id -> Id -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Id
b
cmpEqTick (CaseIdentity Id
a) (CaseIdentity Id
b) = Id
a Id -> Id -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Id
b
cmpEqTick (FillInCaseDefault Id
a) (FillInCaseDefault Id
b) = Id
a Id -> Id -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Id
b
cmpEqTick Tick
_ Tick
_ = Ordering
EQ
data CoreReader = CoreReader {
CoreReader -> HscEnv
cr_hsc_env :: HscEnv,
CoreReader -> RuleBase
cr_rule_base :: RuleBase,
CoreReader -> Module
cr_module :: Module,
CoreReader -> PrintUnqualified
cr_print_unqual :: PrintUnqualified,
CoreReader -> SrcSpan
cr_loc :: SrcSpan,
CoreReader -> ModuleSet
cr_visible_orphan_mods :: !ModuleSet,
CoreReader -> Char
cr_uniq_mask :: !Char
}
newtype CoreWriter = CoreWriter {
CoreWriter -> SimplCount
cw_simpl_count :: SimplCount
}
emptyWriter :: DynFlags -> CoreWriter
emptyWriter :: DynFlags -> CoreWriter
emptyWriter DynFlags
dflags = CoreWriter {
cw_simpl_count :: SimplCount
cw_simpl_count = DynFlags -> SimplCount
zeroSimplCount DynFlags
dflags
}
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
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)
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
-> Module
-> ModuleSet
-> PrintUnqualified
-> SrcSpan
-> CoreM a
-> IO (a, SimplCount)
runCoreM :: forall a.
HscEnv
-> RuleBase
-> Char
-> Module
-> ModuleSet
-> PrintUnqualified
-> SrcSpan
-> CoreM a
-> IO (a, SimplCount)
runCoreM HscEnv
hsc_env RuleBase
rule_base Char
mask Module
mod ModuleSet
orph_imps PrintUnqualified
print_unqual 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_visible_orphan_mods :: ModuleSet
cr_visible_orphan_mods = ModuleSet
orph_imps,
cr_print_unqual :: PrintUnqualified
cr_print_unqual = PrintUnqualified
print_unqual,
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)
nop :: a -> CoreIOEnv (a, CoreWriter)
nop :: forall a. a -> CoreIOEnv (a, CoreWriter)
nop a
x = do
CoreReader
r <- 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, DynFlags -> CoreWriter
emptyWriter (DynFlags -> CoreWriter) -> DynFlags -> CoreWriter
forall a b. (a -> b) -> a -> b
$ (HscEnv -> DynFlags
hsc_dflags (HscEnv -> DynFlags)
-> (CoreReader -> HscEnv) -> CoreReader -> DynFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreReader -> HscEnv
cr_hsc_env) CoreReader
r)
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)
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
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)
getHscEnv :: CoreM HscEnv
getHscEnv :: CoreM HscEnv
getHscEnv = (CoreReader -> HscEnv) -> CoreM HscEnv
forall a. (CoreReader -> a) -> CoreM a
read CoreReader -> HscEnv
cr_hsc_env
getRuleBase :: CoreM RuleBase
getRuleBase :: CoreM RuleBase
getRuleBase = (CoreReader -> RuleBase) -> CoreM RuleBase
forall a. (CoreReader -> a) -> CoreM a
read CoreReader -> RuleBase
cr_rule_base
getVisibleOrphanMods :: CoreM ModuleSet
getVisibleOrphanMods :: CoreM ModuleSet
getVisibleOrphanMods = (CoreReader -> ModuleSet) -> CoreM ModuleSet
forall a. (CoreReader -> a) -> CoreM a
read CoreReader -> ModuleSet
cr_visible_orphan_mods
getPrintUnqualified :: CoreM PrintUnqualified
getPrintUnqualified :: CoreM PrintUnqualified
getPrintUnqualified = (CoreReader -> PrintUnqualified) -> CoreM PrintUnqualified
forall a. (CoreReader -> a) -> CoreM a
read CoreReader -> PrintUnqualified
cr_print_unqual
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
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
getPackageFamInstEnv :: CoreM PackageFamInstEnv
getPackageFamInstEnv :: CoreM PackageFamInstEnv
getPackageFamInstEnv = do
HscEnv
hsc_env <- CoreM HscEnv
getHscEnv
ExternalPackageState
eps <- 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
PackageFamInstEnv -> CoreM PackageFamInstEnv
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageFamInstEnv -> CoreM PackageFamInstEnv)
-> PackageFamInstEnv -> CoreM PackageFamInstEnv
forall a b. (a -> b) -> a -> b
$ ExternalPackageState -> PackageFamInstEnv
eps_fam_inst_env ExternalPackageState
eps
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)
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 {elt2}. NameEnv [elt2] -> NameEnv elt2
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 = ([b] -> b) -> ModuleEnv [b] -> ModuleEnv b
forall a b. (a -> b) -> ModuleEnv a -> ModuleEnv b
mapModuleEnv [b] -> b
forall a. HasCallStack => [a] -> a
head (ModuleEnv [b] -> ModuleEnv b)
-> (ModuleEnv [b] -> ModuleEnv [b]) -> ModuleEnv [b] -> ModuleEnv b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Module -> [b] -> Bool) -> ModuleEnv [b] -> ModuleEnv [b]
forall a. (Module -> a -> Bool) -> ModuleEnv a -> ModuleEnv a
filterModuleEnv (([b] -> Bool) -> Module -> [b] -> Bool
forall a b. a -> b -> a
const (([b] -> Bool) -> Module -> [b] -> Bool)
-> ([b] -> Bool) -> Module -> [b] -> Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> ([b] -> Bool) -> [b] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [b] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null)
name :: NameEnv [elt2] -> NameEnv elt2
name = ([elt2] -> elt2) -> NameEnv [elt2] -> NameEnv elt2
forall elt1 elt2. (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2
mapNameEnv [elt2] -> elt2
forall a. HasCallStack => [a] -> a
head (NameEnv [elt2] -> NameEnv elt2)
-> (NameEnv [elt2] -> NameEnv [elt2])
-> NameEnv [elt2]
-> NameEnv elt2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([elt2] -> Bool) -> NameEnv [elt2] -> NameEnv [elt2]
forall elt. (elt -> Bool) -> NameEnv elt -> NameEnv elt
filterNameEnv (Bool -> Bool
not (Bool -> Bool) -> ([elt2] -> Bool) -> [elt2] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [elt2] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null)
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
PrintUnqualified
unqual <- CoreM PrintUnqualified
getPrintUnqualified
let sty :: PprStyle
sty = case MessageClass
msg_class of
MCDiagnostic Severity
_ DiagnosticReason
_ -> PprStyle
err_sty
MessageClass
MCDump -> PprStyle
dump_sty
MessageClass
_ -> PprStyle
user_sty
err_sty :: PprStyle
err_sty = PrintUnqualified -> PprStyle
mkErrStyle PrintUnqualified
unqual
user_sty :: PprStyle
user_sty = PrintUnqualified -> Depth -> PprStyle
mkUserStyle PrintUnqualified
unqual Depth
AllTheWay
dump_sty :: PprStyle
dump_sty = PrintUnqualified -> PprStyle
mkDumpStyle PrintUnqualified
unqual
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)
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
text
putMsg :: SDoc -> CoreM ()
putMsg :: SDoc -> CoreM ()
putMsg = MessageClass -> SDoc -> CoreM ()
msg MessageClass
MCInfo
errorMsgS :: String -> CoreM ()
errorMsgS :: String -> CoreM ()
errorMsgS = SDoc -> CoreM ()
errorMsg (SDoc -> CoreM ()) -> (String -> SDoc) -> String -> CoreM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> SDoc
text
errorMsg :: SDoc -> CoreM ()
errorMsg :: SDoc -> CoreM ()
errorMsg SDoc
doc = MessageClass -> SDoc -> CoreM ()
msg MessageClass
errorDiagnostic SDoc
doc
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
text
fatalErrorMsg :: SDoc -> CoreM ()
fatalErrorMsg :: SDoc -> CoreM ()
fatalErrorMsg = MessageClass -> SDoc -> CoreM ()
msg MessageClass
MCFatal
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
text
debugTraceMsg :: SDoc -> CoreM ()
debugTraceMsg :: SDoc -> CoreM ()
debugTraceMsg = MessageClass -> SDoc -> CoreM ()
msg MessageClass
MCDump