CoreM, runCoreM,
-- ** Reading from the monad
- getHscEnv, getAnnEnv, getRuleBase, getModule,
+ getHscEnv, getRuleBase, getModule,
getDynFlags, getOrigNameCache,
-- ** Writing to the monad
liftIO1, liftIO2, liftIO3, liftIO4,
-- ** Dealing with annotations
- findAnnotations, addAnnotation,
+ getAnnotations, getFirstAnnotations,
+ -- ** Debug output
+ endPass, endPassIf, endIteration,
+
-- ** Screen output
putMsg, putMsgS, errorMsg, errorMsgS,
fatalErrorMsg, fatalErrorMsgS,
#ifdef GHCI
import Name( Name )
#endif
+import CoreSyn
+import PprCore
+import CoreUtils
+import CoreLint ( lintCoreBindings )
import PrelNames ( iNTERACTIVE )
import HscTypes
import Module ( Module )
import SimplMonad ( SimplCount, plusSimplCount, zeroSimplCount )
import Rules ( RuleBase )
import Annotations
-import Serialized
import IOEnv hiding ( liftIO, failM, failWithM )
import qualified IOEnv ( liftIO )
import TcRnMonad ( TcM, initTc )
import Outputable
+import FastString
import qualified ErrUtils as Err
-import MonadUtils
import Maybes
import UniqSupply
+import LazyUniqFM ( UniqFM, mapUFM, filterUFM )
import Data.Dynamic
import Data.IORef
import Data.Word
import Control.Monad
-import Control.Applicative
import Prelude hiding ( read )
#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 {
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 {
cr_module = mod
}
state = CoreState {
- cs_uniq_supply = us,
- cs_ann_env = ann_env
+ cs_uniq_supply = us
}
extract :: (a, CoreState, CoreWriter) -> (a, SimplCount)
\end{code}
-\subsection{Core combinators, not exported}
+
+%************************************************************************
+%* *
+ Core combinators, not exported
+%* *
+%************************************************************************
\begin{code}
\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
\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}
-- | 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}
\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
projects / ghc-hetmet.git / blobdiff