X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FCoreMonad.lhs;h=f8956b097e268eca5ab470d01056a41fdba74aad;hb=23bc35d6bbfefa7def797eb0868cc88e02633914;hp=a231103ec8a4edc85aeb292727fb922c17a1ca5d;hpb=703ca1542c8e0983cc9d8eebce6e9f3dd3fd71e2;p=ghc-hetmet.git diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs index a231103..f8956b0 100644 --- a/compiler/simplCore/CoreMonad.lhs +++ b/compiler/simplCore/CoreMonad.lhs @@ -11,7 +11,7 @@ module CoreMonad ( CoreM, runCoreM, -- ** Reading from the monad - getHscEnv, getAnnEnv, getRuleBase, getModule, + getHscEnv, getRuleBase, getModule, getDynFlags, getOrigNameCache, -- ** Writing to the monad @@ -22,8 +22,11 @@ module CoreMonad ( liftIO1, liftIO2, liftIO3, liftIO4, -- ** Dealing with annotations - findAnnotations, addAnnotation, + getAnnotations, getFirstAnnotations, + -- ** Debug output + endPass, endPassIf, endIteration, + -- ** Screen output putMsg, putMsgS, errorMsg, errorMsgS, fatalErrorMsg, fatalErrorMsgS, @@ -39,6 +42,10 @@ module CoreMonad ( #ifdef GHCI import Name( Name ) #endif +import CoreSyn +import PprCore +import CoreUtils +import CoreLint ( lintCoreBindings ) import PrelNames ( iNTERACTIVE ) import HscTypes import Module ( Module ) @@ -46,7 +53,6 @@ import DynFlags ( DynFlags, DynFlag ) import SimplMonad ( SimplCount, plusSimplCount, zeroSimplCount ) import Rules ( RuleBase ) import Annotations -import Serialized import IOEnv hiding ( liftIO, failM, failWithM ) import qualified IOEnv ( liftIO ) @@ -54,9 +60,11 @@ import TcEnv ( tcLookupGlobal ) import TcRnMonad ( TcM, initTc ) import Outputable +import FastString import qualified ErrUtils as Err import Maybes import UniqSupply +import LazyUniqFM ( UniqFM, mapUFM, filterUFM ) import Data.Dynamic import Data.IORef @@ -71,12 +79,58 @@ import qualified Language.Haskell.TH as TH #endif \end{code} -\subsection{Monad and carried data structure definitions} +%************************************************************************ +%* * + 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} +endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO () +endPass = dumpAndLint Err.dumpIfSet_core + +endPassIf :: Bool -> DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO () +endPassIf cond = dumpAndLint (Err.dumpIf_core cond) + +-- Same as endPass but doesn't dump Core even with -dverbose-core2core +endIteration :: DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO () +endIteration = dumpAndLint Err.dumpIfSet_dyn + +dumpAndLint :: (DynFlags -> DynFlag -> String -> SDoc -> IO ()) + -> DynFlags -> String -> DynFlag + -> [CoreBind] -> [CoreRule] -> IO () +dumpAndLint dump dflags pass_name dump_flag binds rules + = do { -- Report result size if required + -- This has the side effect of forcing the intermediate to be evaluated + ; Err.debugTraceMsg dflags 2 $ + (text " Result size =" <+> int (coreBindsSize binds)) + + -- Report verbosely, if required + ; dump dflags dump_flag pass_name + (pprCoreBindings binds $$ ppUnless (null rules) pp_rules) + + -- Type check + ; lintCoreBindings dflags pass_name binds } + where + pp_rules = vcat [ blankLine + , ptext (sLit "------ Local rules for imported ids --------") + , pprRules rules ] +\end{code} + + +%************************************************************************ +%* * + Monad and carried data structure definitions +%* * +%************************************************************************ \begin{code} -data CoreState = CoreState { - cs_uniq_supply :: UniqSupply, - cs_ann_env :: AnnEnv +newtype CoreState = CoreState { + cs_uniq_supply :: UniqSupply } data CoreReader = CoreReader { @@ -135,13 +189,12 @@ instance MonadUnique CoreM where return us1 runCoreM :: HscEnv - -> AnnEnv -> RuleBase -> UniqSupply -> Module -> CoreM a -> IO (a, SimplCount) -runCoreM hsc_env ann_env rule_base us mod m = +runCoreM hsc_env rule_base us mod m = liftM extract $ runIOEnv reader $ unCoreM m state where reader = CoreReader { @@ -150,8 +203,7 @@ runCoreM hsc_env ann_env rule_base us mod m = cr_module = mod } state = CoreState { - cs_uniq_supply = us, - cs_ann_env = ann_env + cs_uniq_supply = us } extract :: (a, CoreState, CoreWriter) -> (a, SimplCount) @@ -159,7 +211,12 @@ runCoreM hsc_env ann_env rule_base us mod m = \end{code} -\subsection{Core combinators, not exported} + +%************************************************************************ +%* * + Core combinators, not exported +%* * +%************************************************************************ \begin{code} @@ -199,16 +256,18 @@ liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> re \end{code} -\subsection{Reader, writer and state accessors} + +%************************************************************************ +%* * + Reader, writer and state accessors +%* * +%************************************************************************ \begin{code} getHscEnv :: CoreM HscEnv getHscEnv = read cr_hsc_env -getAnnEnv :: CoreM AnnEnv -getAnnEnv = getS cs_ann_env - getRuleBase :: CoreM RuleBase getRuleBase = read cr_rule_base @@ -232,34 +291,59 @@ getOrigNameCache = do \end{code} -\subsection{Dealing with annotations} -\begin{code} +%************************************************************************ +%* * + Dealing with annotations +%* * +%************************************************************************ --- | Find all the annotations we currently know about for the given target. Note that no --- annotations will be returned if we haven't loaded information about the particular target --- you are inquiring about: by default, only those modules that have been imported by the --- program being compiled will have been loaded in this way. +\begin{code} +-- | Get all annotations of a given type. This happens lazily, that is +-- no deserialization will take place until the [a] is actually demanded and +-- the [a] can also be empty (the UniqFM is not filtered). -- --- To load the information from additional modules, you can use the functions 'DynamicLoading.forceLoadModuleInterfaces' --- and 'DynamicLoading.forceLoadNameModuleInterface', but be aware that doing this indiscriminantly --- will impose a performance penalty. +-- This should be done once at the start of a Core-to-Core pass that uses +-- annotations. -- --- If no deserialization function is supplied, only transient annotations will be returned. -findAnnotations :: Typeable a => ([Word8] -> a) -> CoreAnnTarget -> CoreM [a] -findAnnotations deserialize target = do - ann_env <- getAnnEnv - return (findAnns deserialize ann_env target) - -addAnnotation :: Typeable a => (a -> [Word8]) -> CoreAnnTarget -> a -> CoreM () -addAnnotation serialize target what = addAnnotationToEnv $ Annotation { ann_target = target, ann_value = toSerialized serialize what } - -addAnnotationToEnv :: Annotation -> CoreM () -addAnnotationToEnv annotation = modifyS (\state -> state { cs_ann_env = extendAnnEnvList (cs_ann_env state) [annotation] }) - +-- See Note [Annotations] +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) + +-- | Get at most one annotation of a given type per Unique. +getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM a) +getFirstAnnotations deserialize guts + = liftM (mapUFM head . filterUFM (not . null)) + $ getAnnotations deserialize guts + \end{code} -\subsection{Direct screen output} +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} @@ -303,7 +387,6 @@ debugTraceMsg = msg (flip Err.debugTraceMsg 3) -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher dumpIfSet_dyn :: DynFlag -> String -> SDoc -> CoreM () dumpIfSet_dyn flag str = msg (\dflags -> Err.dumpIfSet_dyn dflags flag str) - \end{code} \begin{code} @@ -313,18 +396,25 @@ initTcForLookup hsc_env = liftM (expectJust "initTcInteractive" . snd) . initTc \end{code} -\subsection{Finding TyThings} -\begin{code} +%************************************************************************ +%* * + Finding TyThings +%* * +%************************************************************************ +\begin{code} instance MonadThings CoreM where lookupThing name = do hsc_env <- getHscEnv liftIO $ initTcForLookup hsc_env (tcLookupGlobal name) - \end{code} -\subsection{Template Haskell interoperability} +%************************************************************************ +%* * + Template Haskell interoperability +%* * +%************************************************************************ \begin{code} #ifdef GHCI