%
% (c) The AQUA Project, Glasgow University, 1993-1998
%
\section[CoreMonad]{The core pipeline monad}
\begin{code}
module CoreMonad (
CoreToDo(..), runWhen, runMaybe,
SimplifierMode(..),
FloatOutSwitches(..),
dumpSimplPhase, pprPassDetails,
PluginPass, Plugin(..), CommandLineOption,
defaultPlugin, bindsOnlyPass,
SimplCount, doSimplTick, doFreeSimplTick, simplCountN,
pprSimplCount, plusSimplCount, zeroSimplCount,
isZeroSimplCount, hasDetailedCounts, Tick(..),
CoreM, runCoreM,
getHscEnv, getRuleBase, getModule,
getDynFlags, getOrigNameCache,
addSimplCount,
liftIO, liftIOWithCount,
liftIO1, liftIO2, liftIO3, liftIO4,
reinitializeGlobals,
getAnnotations, getFirstAnnotations,
showPass, endPass, dumpPassResult, lintPassResult, 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 HscTypes
import Module ( 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 ( initTcForLookup )
import Outputable
import FastString
import qualified ErrUtils as Err
import Bag
import Maybes
import SrcLoc
import UniqSupply
import UniqFM ( UniqFM, mapUFM, filterUFM )
import MonadUtils
import Util ( split )
import ListSetOps ( runs )
import Data.List
import Data.Ord
import Data.Dynamic
import Data.IORef
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Word
import Control.Monad
import Prelude hiding ( read )
#ifdef GHCI
import Control.Concurrent.MVar (MVar)
import Linker ( PersistentLinkerState, saveLinkerGlobals, restoreLinkerGlobals )
import TcSplice ( lookupThName_maybe )
import qualified Language.Haskell.TH as TH
#else
saveLinkerGlobals :: IO ()
saveLinkerGlobals = return ()
restoreLinkerGlobals :: () -> IO ()
restoreLinkerGlobals () = return ()
#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 (showPpr dflags pass)
endPass :: DynFlags -> CoreToDo -> CoreProgram -> [CoreRule] -> IO ()
endPass dflags pass binds rules
= do { dumpPassResult dflags mb_flag (ppr pass) (pprPassDetails pass) binds rules
; lintPassResult dflags pass binds }
where
mb_flag = case coreDumpFlag pass of
Just dflag | dopt dflag dflags -> Just dflag
| dopt Opt_D_verbose_core2core dflags -> Just dflag
_ -> Nothing
dumpIfSet :: DynFlags -> Bool -> CoreToDo -> SDoc -> SDoc -> IO ()
dumpIfSet dflags dump_me pass extra_info doc
= Err.dumpIfSet dflags dump_me (showSDoc dflags (ppr pass <+> extra_info)) doc
dumpPassResult :: DynFlags
-> Maybe DynFlag
-> SDoc
-> SDoc
-> CoreProgram -> [CoreRule]
-> IO ()
dumpPassResult dflags mb_flag hdr extra_info binds rules
| Just dflag <- mb_flag
= Err.dumpSDoc dflags dflag (showSDoc dflags hdr) dump_doc
| otherwise
= Err.debugTraceMsg dflags 2 size_doc
where
size_doc = sep [text "Result size of" <+> hdr, nest 2 (equals <+> ppr (coreBindsStats binds))]
dump_doc = vcat [ nest 2 extra_info
, size_doc
, blankLine
, pprCoreBindings binds
, ppUnless (null rules) pp_rules ]
pp_rules = vcat [ blankLine
, ptext (sLit "------ Local rules for imported ids --------")
, pprRules rules ]
lintPassResult :: DynFlags -> CoreToDo -> CoreProgram -> IO ()
lintPassResult dflags pass binds
= when (dopt Opt_DoCoreLinting dflags) $
do { let (warns, errs) = lintCoreBindings binds
; Err.showPass dflags ("Core Linted result of " ++ showPpr dflags pass)
; displayLintResults dflags pass warns errs binds }
displayLintResults :: DynFlags -> CoreToDo
-> Bag Err.MsgDoc -> Bag Err.MsgDoc -> CoreProgram
-> IO ()
displayLintResults dflags pass warns errs binds
| not (isEmptyBag errs)
= do { log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle
(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
= log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle
(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 _ (SimplMode { sm_phase = InitialPhase })) = False
showLintWarnings _ = True
\end{code}
%************************************************************************
%* *
The CoreToDo type and related types
Abstraction of core-to-core passes to run.
%* *
%************************************************************************
\begin{code}
data CoreToDo
= CoreDoSimplify
Int
SimplifierMode
| CoreDoPluginPass String PluginPass
| CoreDoFloatInwards
| CoreDoFloatOutwards FloatOutSwitches
| CoreLiberateCase
| CoreDoPrintCore
| CoreDoStaticArgs
| CoreDoStrictness
| CoreDoWorkerWrapper
| CoreDoSpecialising
| CoreDoSpecConstr
| CoreCSE
| CoreDoRuleCheck CompilerPhase String
| CoreDoVectorisation
| CoreDoNothing
| CoreDoPasses [CoreToDo]
| CoreDesugar
| CoreDesugarOpt
| CoreTidy
| CorePrep
\end{code}
\begin{code}
coreDumpFlag :: CoreToDo -> Maybe DynFlag
coreDumpFlag (CoreDoSimplify {}) = Just Opt_D_dump_simpl_phases
coreDumpFlag (CoreDoPluginPass {}) = Just Opt_D_dump_core_pipeline
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 CoreDesugarOpt = 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 (CoreDoPasses {}) = Nothing
instance Outputable CoreToDo where
ppr (CoreDoSimplify _ _) = ptext (sLit "Simplifier")
ppr (CoreDoPluginPass s _) = ptext (sLit "Core plugin: ") <+> text s
ppr CoreDoFloatInwards = ptext (sLit "Float inwards")
ppr (CoreDoFloatOutwards f) = ptext (sLit "Float out") <> parens (ppr f)
ppr CoreLiberateCase = ptext (sLit "Liberate case")
ppr CoreDoStaticArgs = ptext (sLit "Static argument")
ppr CoreDoStrictness = ptext (sLit "Demand analysis")
ppr CoreDoWorkerWrapper = ptext (sLit "Worker Wrapper binds")
ppr CoreDoSpecialising = ptext (sLit "Specialise")
ppr CoreDoSpecConstr = ptext (sLit "SpecConstr")
ppr CoreCSE = ptext (sLit "Common sub-expression")
ppr CoreDoVectorisation = ptext (sLit "Vectorisation")
ppr CoreDesugar = ptext (sLit "Desugar (before optimization)")
ppr CoreDesugarOpt = ptext (sLit "Desugar (after optimization)")
ppr CoreTidy = ptext (sLit "Tidy Core")
ppr CorePrep = ptext (sLit "CorePrep")
ppr CoreDoPrintCore = ptext (sLit "Print core")
ppr (CoreDoRuleCheck {}) = ptext (sLit "Rule check")
ppr CoreDoNothing = ptext (sLit "CoreDoNothing")
ppr (CoreDoPasses {}) = ptext (sLit "CoreDoPasses")
pprPassDetails :: CoreToDo -> SDoc
pprPassDetails (CoreDoSimplify n md) = vcat [ ptext (sLit "Max iterations =") <+> int n
, ppr md ]
pprPassDetails _ = empty
\end{code}
\begin{code}
data SimplifierMode
= SimplMode
{ sm_names :: [String]
, sm_phase :: CompilerPhase
, sm_rules :: Bool
, sm_inline :: Bool
, sm_case_case :: Bool
, sm_eta_expand :: Bool
}
instance Outputable SimplifierMode where
ppr (SimplMode { sm_phase = p, sm_names = ss
, sm_rules = r, sm_inline = i
, sm_eta_expand = eta, sm_case_case = cc })
= ptext (sLit "SimplMode") <+> braces (
sep [ ptext (sLit "Phase =") <+> ppr p <+>
brackets (text (concat $ intersperse "," ss)) <> comma
, pp_flag i (sLit "inline") <> comma
, pp_flag r (sLit "rules") <> comma
, pp_flag eta (sLit "eta-expand") <> comma
, pp_flag cc (sLit "case-of-case") ])
where
pp_flag f s = ppUnless f (ptext (sLit "no")) <+> ptext s
\end{code}
\begin{code}
data FloatOutSwitches = FloatOutSwitches {
floatOutLambdas :: Maybe Int,
floatOutConstants :: Bool,
floatOutPartialApplications :: Bool
}
instance Outputable FloatOutSwitches where
ppr = pprFloatOutSwitches
pprFloatOutSwitches :: FloatOutSwitches -> SDoc
pprFloatOutSwitches sw
= ptext (sLit "FOS") <+> (braces $
sep $ punctuate comma $
[ ptext (sLit "Lam =") <+> ppr (floatOutLambdas sw)
, ptext (sLit "Consts =") <+> ppr (floatOutConstants sw)
, ptext (sLit "PAPs =") <+> ppr (floatOutPartialApplications sw) ])
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 sm_phase mode of
Phase k -> n == k
_ -> False
phase_name :: String -> Bool
phase_name s = s `elem` sm_names mode
\end{code}
Note [RULEs enabled in SimplGently]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
RULES are enabled when doing "gentle" simplification. Two reasons:
* We really want the class-op cancellation to happen:
op (df d1 d2) --> $cop3 d1 d2
because this breaks the mutual recursion between 'op' and 'df'
* I wanted the RULE
lift String ===> ...
to work in Template Haskell when simplifying
splices, so we get simpler code for literal strings
But watch out: list fusion can prevent floating. So use phase control
to switch off those rules until after floating.
%************************************************************************
%* *
Types for Plugins
%* *
%************************************************************************
\begin{code}
type CommandLineOption = String
data Plugin = Plugin {
installCoreToDos :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
}
defaultPlugin :: Plugin
defaultPlugin = Plugin {
installCoreToDos = const return
}
type PluginPass = ModGuts -> CoreM ModGuts
bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts
bindsOnlyPass pass guts
= do { binds' <- pass (mg_binds guts)
; return (guts { mg_binds = binds' }) }
\end{code}
%************************************************************************
%* *
Counting and logging
%* *
%************************************************************************
\begin{code}
verboseSimplStats :: Bool
verboseSimplStats = opt_PprStyle_Debug
zeroSimplCount :: DynFlags -> SimplCount
isZeroSimplCount :: SimplCount -> Bool
hasDetailedCounts :: 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
hasDetailedCounts (VerySimplCount {}) = False
hasDetailedCounts (SimplCount {}) = True
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 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 :: Map Tick Int -> SDoc
pprTickCounts counts
= vcat (map pprTickGroup groups)
where
groups :: [[(Tick,Int)]]
groups = runs same_tag (Map.toList counts)
same_tag (tick1,_) (tick2,_) = tickToTag tick1 == tickToTag tick2
pprTickGroup :: [(Tick, Int)] -> SDoc
pprTickGroup group@((tick1,_):_)
= hang (int (sum [n | (_,n) <- group]) <+> text (tickString tick1))
2 (vcat [ int n <+> pprTickCts tick
| (tick,n) <- sortBy (flip (comparing snd)) group])
pprTickGroup [] = panic "pprTickGroup"
\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,
cr_globals :: ((Bool, [String], [Way]),
#ifdef GHCI
(MVar PersistentLinkerState, Bool))
#else
())
#endif
}
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 = do
glbls <- liftM2 (,) saveStaticFlagGlobals saveLinkerGlobals
liftM extract $ runIOEnv (reader glbls) $ unCoreM m state
where
reader glbls = CoreReader {
cr_hsc_env = hsc_env,
cr_rule_base = rule_base,
cr_module = mod,
cr_globals = glbls
}
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 })
instance HasDynFlags CoreM where
getDynFlags = fmap hsc_dflags getHscEnv
getOrigNameCache :: CoreM OrigNameCache
getOrigNameCache = do
nameCacheRef <- fmap hsc_NC getHscEnv
liftIO $ fmap nsNames $ readIORef nameCacheRef
\end{code}
%************************************************************************
%* *
Initializing globals
%* *
%************************************************************************
This is a rather annoying function. When a plugin is loaded, it currently
gets linked against a *newly loaded* copy of the GHC package. This would
not be a problem, except that the new copy has its own mutable state
that is not shared with that state that has already been initialized by
the original GHC package.
This leads to loaded plugins calling GHC code which pokes the static flags,
and then dying with a panic because the static flags *it* sees are uninitialized.
There are two possible solutions:
1. Export the symbols from the GHC executable from the GHC library and link
against this existing copy rather than a new copy of the GHC library
2. Carefully ensure that the global state in the two copies of the GHC
library matches
I tried 1. and it *almost* works (and speeds up plugin load times!) except
on Windows. On Windows the GHC library tends to export more than 65536 symbols
(see #5292) which overflows the limit of what we can export from the EXE and
causes breakage.
(Note that if the GHC exeecutable was dynamically linked this wouldn't be a problem,
because we could share the GHC library it links to.)
We are going to try 2. instead. Unfortunately, this means that every plugin
will have to say `reinitializeGlobals` before it does anything, but never mind.
I've threaded the cr_globals through CoreM rather than giving them as an
argument to the plugin function so that we can turn this function into
(return ()) without breaking any plugins when we eventually get 1. working.
\begin{code}
reinitializeGlobals :: CoreM ()
reinitializeGlobals = do
(sf_globals, linker_globals) <- read cr_globals
liftIO $ restoreStaticFlagGlobals sf_globals
liftIO $ restoreLinkerGlobals linker_globals
\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 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
%* *
%************************************************************************
\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}
%************************************************************************
%* *
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}