%
% (c) The AQUA Project, Glasgow University, 19931998
%
\section[CoreMonad]{The core pipeline monad}
\begin{code}
module CoreMonad (
CoreToDo(..),
SimplifierMode(..),
SimplifierSwitch(..),
FloatOutSwitches(..),
getCoreToDo, dumpSimplPhase,
SimplCount, doSimplTick, doFreeSimplTick, simplCountN,
pprSimplCount, plusSimplCount, zeroSimplCount, isZeroSimplCount, Tick(..),
CoreM, runCoreM,
getHscEnv, getRuleBase, getModule,
getDynFlags, getOrigNameCache,
addSimplCount,
liftIO, liftIOWithCount,
liftIO1, liftIO2, liftIO3, liftIO4,
getAnnotations, getFirstAnnotations,
showPass, endPass, endIteration, dumpIfSet,
putMsg, putMsgS, errorMsg, errorMsgS,
fatalErrorMsg, fatalErrorMsgS,
debugTraceMsg, debugTraceMsgS,
dumpIfSet_dyn,
#ifdef GHCI
thNameToGhcName
#endif
) where
#ifdef GHCI
import Name( Name )
#endif
import CoreSyn
import PprCore
import CoreUtils
import CoreLint ( lintCoreBindings )
import PrelNames ( iNTERACTIVE )
import HscTypes
import Module ( PackageId, Module )
import DynFlags
import StaticFlags
import Rules ( RuleBase )
import BasicTypes ( CompilerPhase )
import Annotations
import Id ( Id )
import IOEnv hiding ( liftIO, failM, failWithM )
import qualified IOEnv ( liftIO )
import TcEnv ( tcLookupGlobal )
import TcRnMonad ( TcM, initTc )
import Outputable
import FastString
import qualified ErrUtils as Err
import Bag
import Maybes
import UniqSupply
import UniqFM ( UniqFM, mapUFM, filterUFM )
import Util ( split )
import Data.List ( intersperse )
import Data.Dynamic
import Data.IORef
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Word
import Control.Monad
import Prelude hiding ( read )
#ifdef GHCI
import TcSplice ( lookupThName_maybe )
import qualified Language.Haskell.TH as TH
#endif
\end{code}
%************************************************************************
%* *
Debug output
%* *
%************************************************************************
These functions are not CoreM monad stuff, but they probably ought to
be, and it makes a conveneint place. place for them. They print out
stuff before and after core passes, and do Core Lint when necessary.
\begin{code}
showPass :: DynFlags -> CoreToDo -> IO ()
showPass dflags pass = Err.showPass dflags (showSDoc (ppr pass))
endPass :: DynFlags -> CoreToDo -> [CoreBind] -> [CoreRule] -> IO ()
endPass dflags pass = dumpAndLint dflags True pass empty (coreDumpFlag pass)
endIteration :: DynFlags -> CoreToDo -> Int -> [CoreBind] -> [CoreRule] -> IO ()
endIteration dflags pass n
= dumpAndLint dflags False pass (ptext (sLit "iteration=") <> int n)
(Just Opt_D_dump_simpl_iterations)
dumpIfSet :: Bool -> CoreToDo -> SDoc -> SDoc -> IO ()
dumpIfSet dump_me pass extra_info doc
= Err.dumpIfSet dump_me (showSDoc (ppr pass <+> extra_info)) doc
dumpAndLint :: DynFlags -> Bool -> CoreToDo -> SDoc -> Maybe DynFlag
-> [CoreBind] -> [CoreRule] -> IO ()
dumpAndLint dflags show_all pass extra_info mb_dump_flag binds rules
= do {
; Err.debugTraceMsg dflags 2 $
(text " Result size =" <+> int (coreBindsSize binds))
; let pass_name = showSDoc (ppr pass <+> extra_info)
dump_doc = pprCoreBindings binds
$$ ppUnless (null rules) pp_rules
; case mb_dump_flag of
Nothing -> return ()
Just dump_flag -> Err.dumpIfSet_dyn_or dflags dump_flags pass_name dump_doc
where
dump_flags | show_all = [dump_flag, Opt_D_verbose_core2core]
| otherwise = [dump_flag]
; when (dopt Opt_DoCoreLinting dflags) $
do { let (warns, errs) = lintCoreBindings binds
; Err.showPass dflags ("Core Linted result of " ++ pass_name)
; displayLintResults dflags pass warns errs binds } }
where
pp_rules = vcat [ blankLine
, ptext (sLit "------ Local rules for imported ids --------")
, pprRules rules ]
displayLintResults :: DynFlags -> CoreToDo
-> Bag Err.Message -> Bag Err.Message -> [CoreBind]
-> IO ()
displayLintResults dflags pass warns errs binds
| not (isEmptyBag errs)
= do { printDump (vcat [ banner "errors", Err.pprMessageBag errs
, ptext (sLit "*** Offending Program ***")
, pprCoreBindings binds
, ptext (sLit "*** End of Offense ***") ])
; Err.ghcExit dflags 1 }
| not (isEmptyBag warns)
, not (case pass of { CoreDesugar -> True; _ -> False })
, not opt_NoDebugOutput
, showLintWarnings pass
= printDump (banner "warnings" $$ Err.pprMessageBag warns)
| otherwise = return ()
where
banner string = ptext (sLit "*** Core Lint") <+> text string
<+> ptext (sLit ": in result of") <+> ppr pass
<+> ptext (sLit "***")
showLintWarnings :: CoreToDo -> Bool
showLintWarnings (CoreDoSimplify (SimplGently {}) _ _) = False
showLintWarnings _ = True
\end{code}
%************************************************************************
%* *
The CoreToDo type and related types
Abstraction of coretocore passes to run.
%* *
%************************************************************************
\begin{code}
data CoreToDo
= CoreDoSimplify
SimplifierMode
Int
[SimplifierSwitch]
| CoreDoFloatInwards
| CoreDoFloatOutwards FloatOutSwitches
| CoreLiberateCase
| CoreDoPrintCore
| CoreDoStaticArgs
| CoreDoStrictness
| CoreDoWorkerWrapper
| CoreDoSpecialising
| CoreDoSpecConstr
| CoreDoGlomBinds
| CoreCSE
| CoreDoRuleCheck CompilerPhase String
| CoreDoVectorisation PackageId
| CoreDoNothing
| CoreDoPasses [CoreToDo]
| CoreDesugar
| CoreTidy
| CorePrep
coreDumpFlag :: CoreToDo -> Maybe DynFlag
coreDumpFlag (CoreDoSimplify {}) = Just Opt_D_dump_simpl_phases
coreDumpFlag CoreDoFloatInwards = Just Opt_D_verbose_core2core
coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core
coreDumpFlag CoreLiberateCase = Just Opt_D_verbose_core2core
coreDumpFlag CoreDoStaticArgs = Just Opt_D_verbose_core2core
coreDumpFlag CoreDoStrictness = Just Opt_D_dump_stranal
coreDumpFlag CoreDoWorkerWrapper = Just Opt_D_dump_worker_wrapper
coreDumpFlag CoreDoSpecialising = Just Opt_D_dump_spec
coreDumpFlag CoreDoSpecConstr = Just Opt_D_dump_spec
coreDumpFlag CoreCSE = Just Opt_D_dump_cse
coreDumpFlag (CoreDoVectorisation {}) = Just Opt_D_dump_vect
coreDumpFlag CoreDesugar = Just Opt_D_dump_ds
coreDumpFlag CoreTidy = Just Opt_D_dump_simpl
coreDumpFlag CorePrep = Just Opt_D_dump_prep
coreDumpFlag CoreDoPrintCore = Nothing
coreDumpFlag (CoreDoRuleCheck {}) = Nothing
coreDumpFlag CoreDoNothing = Nothing
coreDumpFlag CoreDoGlomBinds = Nothing
coreDumpFlag (CoreDoPasses {}) = Nothing
instance Outputable CoreToDo where
ppr (CoreDoSimplify md n _) = ptext (sLit "Simplifier")
<+> ppr md
<+> ptext (sLit "max-iterations=") <> int n
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 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")
ppr CoreTidy = ptext (sLit "Tidy Core")
ppr CorePrep = ptext (sLit "CorePrep")
ppr CoreDoPrintCore = ptext (sLit "Print core")
ppr (CoreDoRuleCheck {}) = ptext (sLit "Rule check")
ppr CoreDoGlomBinds = ptext (sLit "Glom binds")
ppr CoreDoNothing = ptext (sLit "CoreDoNothing")
ppr (CoreDoPasses {}) = ptext (sLit "CoreDoPasses")
\end{code}
\begin{code}
data SimplifierMode
= SimplGently
{ sm_rules :: Bool
, sm_inline :: Bool }
| SimplPhase
{ sm_num :: Int
, sm_names :: [String] }
instance Outputable SimplifierMode where
ppr (SimplPhase { sm_num = n, sm_names = ss })
= ptext (sLit "Phase") <+> int n <+> brackets (text (concat $ intersperse "," ss))
ppr (SimplGently { sm_rules = r, sm_inline = i })
= ptext (sLit "gentle") <>
brackets (pp_flag r (sLit "rules") <> comma <>
pp_flag i (sLit "inline"))
where
pp_flag f s = ppUnless f (ptext (sLit "no")) <+> ptext s
data SimplifierSwitch
= NoCaseOfCase
\end{code}
\begin{code}
data FloatOutSwitches = FloatOutSwitches {
floatOutLambdas :: Bool,
floatOutConstants :: Bool,
floatOutPartialApplications :: Bool
}
instance Outputable FloatOutSwitches where
ppr = pprFloatOutSwitches
pprFloatOutSwitches :: FloatOutSwitches -> SDoc
pprFloatOutSwitches sw = pp_not (floatOutLambdas sw) <+> text "lambdas" <> comma
<+> pp_not (floatOutConstants sw) <+> text "constants"
where
pp_not True = empty
pp_not False = text "not"
\end{code}
%************************************************************************
%* *
Generating the main optimisation pipeline
%* *
%************************************************************************
\begin{code}
getCoreToDo :: DynFlags -> [CoreToDo]
getCoreToDo dflags
= core_todo
where
opt_level = optLevel dflags
phases = simplPhases dflags
max_iter = maxSimplIterations dflags
strictness = dopt Opt_Strictness dflags
full_laziness = dopt Opt_FullLaziness dflags
do_specialise = dopt Opt_Specialise dflags
do_float_in = dopt Opt_FloatIn dflags
cse = dopt Opt_CSE dflags
spec_constr = dopt Opt_SpecConstr dflags
liberate_case = dopt Opt_LiberateCase dflags
rule_check = ruleCheck dflags
static_args = dopt Opt_StaticArgumentTransformation dflags
maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)
maybe_strictness_before phase
= runWhen (phase `elem` strictnessBefore dflags) CoreDoStrictness
simpl_phase phase names iter
= CoreDoPasses
[ maybe_strictness_before phase
, CoreDoSimplify (SimplPhase phase names)
iter []
, maybe_rule_check phase
]
vectorisation
= runWhen (dopt Opt_Vectorise dflags)
$ CoreDoPasses [ simpl_gently, CoreDoVectorisation (dphPackage dflags) ]
simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter
| phase <- [phases, phases1 .. 1] ]
simpl_gently = CoreDoSimplify
(SimplGently { sm_rules = True, sm_inline = False })
max_iter
[
NoCaseOfCase
]
core_todo =
if opt_level == 0 then
[vectorisation,
simpl_phase 0 ["final"] max_iter]
else [
runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]),
vectorisation,
simpl_gently,
runWhen do_specialise CoreDoSpecialising,
runWhen full_laziness $
CoreDoFloatOutwards FloatOutSwitches {
floatOutLambdas = False,
floatOutConstants = True,
floatOutPartialApplications = False },
runWhen do_float_in CoreDoFloatInwards,
simpl_phases,
simpl_phase 0 ["main"] (max max_iter 3),
runWhen strictness (CoreDoPasses [
CoreDoStrictness,
CoreDoWorkerWrapper,
CoreDoGlomBinds,
simpl_phase 0 ["post-worker-wrapper"] max_iter
]),
runWhen full_laziness $
CoreDoFloatOutwards FloatOutSwitches {
floatOutLambdas = False,
floatOutConstants = True,
floatOutPartialApplications = True },
runWhen cse CoreCSE,
runWhen do_float_in CoreDoFloatInwards,
maybe_rule_check 0,
runWhen liberate_case (CoreDoPasses [
CoreLiberateCase,
simpl_phase 0 ["post-liberate-case"] max_iter
]),
runWhen spec_constr CoreDoSpecConstr,
maybe_rule_check 0,
simpl_phase 0 ["final"] max_iter
]
runWhen :: Bool -> CoreToDo -> CoreToDo
runWhen True do_this = do_this
runWhen False _ = CoreDoNothing
runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo
runMaybe (Just x) f = f x
runMaybe Nothing _ = CoreDoNothing
dumpSimplPhase :: DynFlags -> SimplifierMode -> Bool
dumpSimplPhase dflags mode
| Just spec_string <- shouldDumpSimplPhase dflags
= match_spec spec_string
| otherwise
= dopt Opt_D_verbose_core2core dflags
where
match_spec :: String -> Bool
match_spec spec_string
= or $ map (and . map match . split ':')
$ split ',' spec_string
match :: String -> Bool
match "" = True
match s = case reads s of
[(n,"")] -> phase_num n
_ -> phase_name s
phase_num :: Int -> Bool
phase_num n = case mode of
SimplPhase k _ -> n == k
_ -> False
phase_name :: String -> Bool
phase_name s = case mode of
SimplGently {} -> s == "gentle"
SimplPhase { sm_names = ss } -> s `elem` ss
\end{code}
%************************************************************************
%* *
Counting and logging
%* *
%************************************************************************
\begin{code}
verboseSimplStats :: Bool
verboseSimplStats = opt_PprStyle_Debug
zeroSimplCount :: DynFlags -> SimplCount
isZeroSimplCount :: SimplCount -> Bool
pprSimplCount :: SimplCount -> SDoc
doSimplTick, doFreeSimplTick :: Tick -> SimplCount -> SimplCount
plusSimplCount :: SimplCount -> SimplCount -> SimplCount
\end{code}
\begin{code}
data SimplCount
= VerySimplCount !Int
| SimplCount {
ticks :: !Int,
details :: !TickCounts,
n_log :: !Int,
log1 :: [Tick],
log2 :: [Tick]
}
type TickCounts = Map Tick Int
simplCountN :: SimplCount -> Int
simplCountN (VerySimplCount n) = n
simplCountN (SimplCount { ticks = n }) = n
zeroSimplCount dflags
| dopt Opt_D_dump_simpl_stats dflags
= SimplCount {ticks = 0, details = Map.empty,
n_log = 0, log1 = [], log2 = []}
| otherwise
= VerySimplCount 0
isZeroSimplCount (VerySimplCount n) = n==0
isZeroSimplCount (SimplCount { ticks = n }) = n==0
doFreeSimplTick tick sc@SimplCount { details = dts }
= sc { details = dts `addTick` tick }
doFreeSimplTick _ sc = sc
doSimplTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 }
| nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
| otherwise = sc1 { n_log = nl+1, log1 = tick : l1 }
where
sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
doSimplTick _ (VerySimplCount n) = VerySimplCount (n+1)
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
plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
sc2@(SimplCount { ticks = tks2, details = dts2 })
= log_base { ticks = tks1 + tks2, details = Map.unionWith (+) dts1 dts2 }
where
log_base | null (log1 sc2) = sc1
| null (log2 sc2) = sc2 { log2 = log1 sc1 }
| otherwise = sc2
plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m)
plusSimplCount _ _ = panic "plusSimplCount"
pprSimplCount (VerySimplCount n) = ptext (sLit "Total ticks:") <+> int n
pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
= vcat [ptext (sLit "Total ticks: ") <+> int tks,
blankLine,
pprTickCounts (Map.toList dts),
if verboseSimplStats then
vcat [blankLine,
ptext (sLit "Log (most recent first)"),
nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
else empty
]
pprTickCounts :: [(Tick,Int)] -> SDoc
pprTickCounts [] = empty
pprTickCounts ((tick1,n1):ticks)
= vcat [int tot_n <+> text (tickString tick1),
pprTCDetails real_these,
pprTickCounts others
]
where
tick1_tag = tickToTag tick1
(these, others) = span same_tick ticks
real_these = (tick1,n1):these
same_tick (tick2,_) = tickToTag tick2 == tick1_tag
tot_n = sum [n | (_,n) <- real_these]
pprTCDetails :: [(Tick, Int)] -> SDoc
pprTCDetails ticks
= nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
\end{code}
\begin{code}
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
| BottomFound
| SimplifierDone
instance Outputable Tick where
ppr tick = text (tickString tick) <+> pprTickCts tick
instance Eq Tick where
a == b = case a `cmpTick` b of
EQ -> True
_ -> False
instance Ord Tick where
compare = cmpTick
tickToTag :: Tick -> Int
tickToTag (PreInlineUnconditionally _) = 0
tickToTag (PostInlineUnconditionally _) = 1
tickToTag (UnfoldingDone _) = 2
tickToTag (RuleFired _) = 3
tickToTag LetFloatFromLet = 4
tickToTag (EtaExpansion _) = 5
tickToTag (EtaReduction _) = 6
tickToTag (BetaReduction _) = 7
tickToTag (CaseOfCase _) = 8
tickToTag (KnownBranch _) = 9
tickToTag (CaseMerge _) = 10
tickToTag (CaseElim _) = 11
tickToTag (CaseIdentity _) = 12
tickToTag (FillInCaseDefault _) = 13
tickToTag BottomFound = 14
tickToTag SimplifierDone = 16
tickToTag (AltMerge _) = 17
tickString :: Tick -> String
tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
tickString (UnfoldingDone _) = "UnfoldingDone"
tickString (RuleFired _) = "RuleFired"
tickString LetFloatFromLet = "LetFloatFromLet"
tickString (EtaExpansion _) = "EtaExpansion"
tickString (EtaReduction _) = "EtaReduction"
tickString (BetaReduction _) = "BetaReduction"
tickString (CaseOfCase _) = "CaseOfCase"
tickString (KnownBranch _) = "KnownBranch"
tickString (CaseMerge _) = "CaseMerge"
tickString (AltMerge _) = "AltMerge"
tickString (CaseElim _) = "CaseElim"
tickString (CaseIdentity _) = "CaseIdentity"
tickString (FillInCaseDefault _) = "FillInCaseDefault"
tickString BottomFound = "BottomFound"
tickString SimplifierDone = "SimplifierDone"
pprTickCts :: Tick -> SDoc
pprTickCts (PreInlineUnconditionally v) = ppr v
pprTickCts (PostInlineUnconditionally v)= ppr v
pprTickCts (UnfoldingDone v) = ppr v
pprTickCts (RuleFired v) = ppr v
pprTickCts LetFloatFromLet = empty
pprTickCts (EtaExpansion v) = ppr v
pprTickCts (EtaReduction v) = ppr v
pprTickCts (BetaReduction v) = ppr v
pprTickCts (CaseOfCase v) = ppr v
pprTickCts (KnownBranch v) = ppr v
pprTickCts (CaseMerge v) = ppr v
pprTickCts (AltMerge v) = ppr v
pprTickCts (CaseElim v) = ppr v
pprTickCts (CaseIdentity v) = ppr v
pprTickCts (FillInCaseDefault v) = ppr v
pprTickCts _ = empty
cmpTick :: Tick -> Tick -> Ordering
cmpTick a b = case (tickToTag a `compare` tickToTag b) of
GT -> GT
EQ -> cmpEqTick a b
LT -> LT
cmpEqTick :: Tick -> Tick -> Ordering
cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b
cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b
cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b
cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b
cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b
cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b
cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b
cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b
cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b
cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b
cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b
cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b
cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b
cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b
cmpEqTick _ _ = EQ
\end{code}
%************************************************************************
%* *
Monad and carried data structure definitions
%* *
%************************************************************************
\begin{code}
newtype CoreState = CoreState {
cs_uniq_supply :: UniqSupply
}
data CoreReader = CoreReader {
cr_hsc_env :: HscEnv,
cr_rule_base :: RuleBase,
cr_module :: Module
}
data CoreWriter = CoreWriter {
cw_simpl_count :: SimplCount
}
emptyWriter :: DynFlags -> CoreWriter
emptyWriter dflags = CoreWriter {
cw_simpl_count = zeroSimplCount dflags
}
plusWriter :: CoreWriter -> CoreWriter -> CoreWriter
plusWriter w1 w2 = CoreWriter {
cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2)
}
type CoreIOEnv = IOEnv CoreReader
newtype CoreM a = CoreM { unCoreM :: CoreState -> CoreIOEnv (a, CoreState, CoreWriter) }
instance Functor CoreM where
fmap f ma = do
a <- ma
return (f a)
instance Monad CoreM where
return x = CoreM (\s -> nop s x)
mx >>= f = CoreM $ \s -> do
(x, s', w1) <- unCoreM mx s
(y, s'', w2) <- unCoreM (f x) s'
return (y, s'', w1 `plusWriter` w2)
instance Applicative CoreM where
pure = return
(<*>) = ap
instance MonadPlus IO => MonadPlus CoreM where
mzero = CoreM (const mzero)
m `mplus` n = CoreM (\rs -> unCoreM m rs `mplus` unCoreM n rs)
instance MonadUnique CoreM where
getUniqueSupplyM = do
us <- getS cs_uniq_supply
let (us1, us2) = splitUniqSupply us
modifyS (\s -> s { cs_uniq_supply = us2 })
return us1
runCoreM :: HscEnv
-> RuleBase
-> UniqSupply
-> Module
-> CoreM a
-> IO (a, SimplCount)
runCoreM hsc_env rule_base us mod m =
liftM extract $ runIOEnv reader $ unCoreM m state
where
reader = CoreReader {
cr_hsc_env = hsc_env,
cr_rule_base = rule_base,
cr_module = mod
}
state = CoreState {
cs_uniq_supply = us
}
extract :: (a, CoreState, CoreWriter) -> (a, SimplCount)
extract (value, _, writer) = (value, cw_simpl_count writer)
\end{code}
%************************************************************************
%* *
Core combinators, not exported
%* *
%************************************************************************
\begin{code}
nop :: CoreState -> a -> CoreIOEnv (a, CoreState, CoreWriter)
nop s x = do
r <- getEnv
return (x, s, emptyWriter $ (hsc_dflags . cr_hsc_env) r)
read :: (CoreReader -> a) -> CoreM a
read f = CoreM (\s -> getEnv >>= (\r -> nop s (f r)))
getS :: (CoreState -> a) -> CoreM a
getS f = CoreM (\s -> nop s (f s))
modifyS :: (CoreState -> CoreState) -> CoreM ()
modifyS f = CoreM (\s -> nop (f s) ())
write :: CoreWriter -> CoreM ()
write w = CoreM (\s -> return ((), s, w))
\end{code}
\subsection{Lifting IO into the monad}
\begin{code}
liftIOEnv :: CoreIOEnv a -> CoreM a
liftIOEnv mx = CoreM (\s -> mx >>= (\x -> nop s x))
instance MonadIO CoreM where
liftIO = liftIOEnv . IOEnv.liftIO
liftIOWithCount :: IO (SimplCount, a) -> CoreM a
liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x)
\end{code}
%************************************************************************
%* *
Reader, writer and state accessors
%* *
%************************************************************************
\begin{code}
getHscEnv :: CoreM HscEnv
getHscEnv = read cr_hsc_env
getRuleBase :: CoreM RuleBase
getRuleBase = read cr_rule_base
getModule :: CoreM Module
getModule = read cr_module
addSimplCount :: SimplCount -> CoreM ()
addSimplCount count = write (CoreWriter { cw_simpl_count = count })
getDynFlags :: CoreM DynFlags
getDynFlags = fmap hsc_dflags getHscEnv
getOrigNameCache :: CoreM OrigNameCache
getOrigNameCache = do
nameCacheRef <- fmap hsc_NC getHscEnv
liftIO $ fmap nsNames $ readIORef nameCacheRef
\end{code}
%************************************************************************
%* *
Dealing with annotations
%* *
%************************************************************************
\begin{code}
getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM [a])
getAnnotations deserialize guts = do
hsc_env <- getHscEnv
ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts)
return (deserializeAnns deserialize ann_env)
getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM a)
getFirstAnnotations deserialize guts
= liftM (mapUFM head . filterUFM (not . null))
$ getAnnotations deserialize guts
\end{code}
Note [Annotations]
~~~~~~~~~~~~~~~~~~
A CoretoCore 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
%* *
%************************************************************************
\begin{code}
msg :: (DynFlags -> SDoc -> IO ()) -> SDoc -> CoreM ()
msg how doc = do
dflags <- getDynFlags
liftIO $ how dflags doc
putMsgS :: String -> CoreM ()
putMsgS = putMsg . text
putMsg :: SDoc -> CoreM ()
putMsg = msg Err.putMsg
errorMsgS :: String -> CoreM ()
errorMsgS = errorMsg . text
errorMsg :: SDoc -> CoreM ()
errorMsg = msg Err.errorMsg
fatalErrorMsgS :: String -> CoreM ()
fatalErrorMsgS = fatalErrorMsg . text
fatalErrorMsg :: SDoc -> CoreM ()
fatalErrorMsg = msg Err.fatalErrorMsg
debugTraceMsgS :: String -> CoreM ()
debugTraceMsgS = debugTraceMsg . text
debugTraceMsg :: SDoc -> CoreM ()
debugTraceMsg = msg (flip Err.debugTraceMsg 3)
dumpIfSet_dyn :: DynFlag -> String -> SDoc -> CoreM ()
dumpIfSet_dyn flag str = msg (\dflags -> Err.dumpIfSet_dyn dflags flag str)
\end{code}
\begin{code}
initTcForLookup :: HscEnv -> TcM a -> IO a
initTcForLookup hsc_env = liftM (expectJust "initTcInteractive" . snd) . initTc hsc_env HsSrcFile False iNTERACTIVE
\end{code}
%************************************************************************
%* *
Finding TyThings
%* *
%************************************************************************
\begin{code}
instance MonadThings CoreM where
lookupThing name = do
hsc_env <- getHscEnv
liftIO $ initTcForLookup hsc_env (tcLookupGlobal name)
\end{code}
%************************************************************************
%* *
Template Haskell interoperability
%* *
%************************************************************************
\begin{code}
#ifdef GHCI
thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
thNameToGhcName th_name = do
hsc_env <- getHscEnv
liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)
#endif
\end{code}