2 % (c) The AQUA Project, Glasgow University, 1993-1998
4 \section[CoreMonad]{The core pipeline monad}
7 {-# LANGUAGE UndecidableInstances #-}
13 -- ** Reading from the monad
14 getHscEnv, getAnnEnv, getRuleBase, getModule,
15 getDynFlags, getOrigNameCache,
17 -- ** Writing to the monad
20 -- ** Lifting into the monad
21 liftIO, liftIOWithCount,
22 liftIO1, liftIO2, liftIO3, liftIO4,
24 -- ** Dealing with annotations
25 findAnnotations, deserializeAnnotations, addAnnotation,
28 putMsg, putMsgS, errorMsg, errorMsgS,
29 fatalErrorMsg, fatalErrorMsgS,
30 debugTraceMsg, debugTraceMsgS,
42 import PrelNames ( iNTERACTIVE )
44 import Module ( Module )
45 import DynFlags ( DynFlags, DynFlag )
46 import SimplMonad ( SimplCount, plusSimplCount, zeroSimplCount )
47 import Rules ( RuleBase )
51 import IOEnv hiding ( liftIO, failM, failWithM )
52 import qualified IOEnv ( liftIO )
53 import TcEnv ( tcLookupGlobal )
54 import TcRnMonad ( TcM, initTc )
57 import qualified ErrUtils as Err
60 import LazyUniqFM ( UniqFM )
67 import Prelude hiding ( read )
70 import {-# SOURCE #-} TcSplice ( lookupThName_maybe )
71 import qualified Language.Haskell.TH as TH
75 \subsection{Monad and carried data structure definitions}
78 data CoreState = CoreState {
79 cs_uniq_supply :: UniqSupply,
83 data CoreReader = CoreReader {
85 cr_rule_base :: RuleBase,
89 data CoreWriter = CoreWriter {
90 cw_simpl_count :: SimplCount
93 emptyWriter :: DynFlags -> CoreWriter
94 emptyWriter dflags = CoreWriter {
95 cw_simpl_count = zeroSimplCount dflags
98 plusWriter :: CoreWriter -> CoreWriter -> CoreWriter
99 plusWriter w1 w2 = CoreWriter {
100 cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2)
103 type CoreIOEnv = IOEnv CoreReader
105 -- | The monad used by Core-to-Core passes to access common state, register simplification
106 -- statistics and so on
107 newtype CoreM a = CoreM { unCoreM :: CoreState -> CoreIOEnv (a, CoreState, CoreWriter) }
109 instance Functor CoreM where
114 instance Monad CoreM where
115 return x = CoreM (\s -> nop s x)
116 mx >>= f = CoreM $ \s -> do
117 (x, s', w1) <- unCoreM mx s
118 (y, s'', w2) <- unCoreM (f x) s'
119 return (y, s'', w1 `plusWriter` w2)
121 instance Applicative CoreM where
125 -- For use if the user has imported Control.Monad.Error from MTL
126 -- Requires UndecidableInstances
127 instance MonadPlus IO => MonadPlus CoreM where
128 mzero = CoreM (const mzero)
129 m `mplus` n = CoreM (\rs -> unCoreM m rs `mplus` unCoreM n rs)
131 instance MonadUnique CoreM where
132 getUniqueSupplyM = do
133 us <- getS cs_uniq_supply
134 let (us1, us2) = splitUniqSupply us
135 modifyS (\s -> s { cs_uniq_supply = us2 })
144 -> IO (a, SimplCount)
145 runCoreM hsc_env ann_env rule_base us mod m =
146 liftM extract $ runIOEnv reader $ unCoreM m state
148 reader = CoreReader {
149 cr_hsc_env = hsc_env,
150 cr_rule_base = rule_base,
158 extract :: (a, CoreState, CoreWriter) -> (a, SimplCount)
159 extract (value, _, writer) = (value, cw_simpl_count writer)
163 \subsection{Core combinators, not exported}
167 nop :: CoreState -> a -> CoreIOEnv (a, CoreState, CoreWriter)
170 return (x, s, emptyWriter $ (hsc_dflags . cr_hsc_env) r)
172 read :: (CoreReader -> a) -> CoreM a
173 read f = CoreM (\s -> getEnv >>= (\r -> nop s (f r)))
175 getS :: (CoreState -> a) -> CoreM a
176 getS f = CoreM (\s -> nop s (f s))
178 modifyS :: (CoreState -> CoreState) -> CoreM ()
179 modifyS f = CoreM (\s -> nop (f s) ())
181 write :: CoreWriter -> CoreM ()
182 write w = CoreM (\s -> return ((), s, w))
186 \subsection{Lifting IO into the monad}
190 -- | Lift an 'IOEnv' operation into 'CoreM'
191 liftIOEnv :: CoreIOEnv a -> CoreM a
192 liftIOEnv mx = CoreM (\s -> mx >>= (\x -> nop s x))
194 instance MonadIO CoreM where
195 liftIO = liftIOEnv . IOEnv.liftIO
197 -- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount'
198 liftIOWithCount :: IO (SimplCount, a) -> CoreM a
199 liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x)
203 \subsection{Reader, writer and state accessors}
207 getHscEnv :: CoreM HscEnv
208 getHscEnv = read cr_hsc_env
210 getAnnEnv :: CoreM AnnEnv
211 getAnnEnv = getS cs_ann_env
213 getRuleBase :: CoreM RuleBase
214 getRuleBase = read cr_rule_base
216 getModule :: CoreM Module
217 getModule = read cr_module
219 addSimplCount :: SimplCount -> CoreM ()
220 addSimplCount count = write (CoreWriter { cw_simpl_count = count })
222 -- Convenience accessors for useful fields of HscEnv
224 getDynFlags :: CoreM DynFlags
225 getDynFlags = fmap hsc_dflags getHscEnv
227 -- | The original name cache is the current mapping from 'Module' and
228 -- 'OccName' to a compiler-wide unique 'Name'
229 getOrigNameCache :: CoreM OrigNameCache
230 getOrigNameCache = do
231 nameCacheRef <- fmap hsc_NC getHscEnv
232 liftIO $ fmap nsNames $ readIORef nameCacheRef
236 \subsection{Dealing with annotations}
240 -- | Find all the annotations we currently know about for the given target. Note that no
241 -- annotations will be returned if we haven't loaded information about the particular target
242 -- you are inquiring about: by default, only those modules that have been imported by the
243 -- program being compiled will have been loaded in this way.
245 -- To load the information from additional modules, you can use the functions 'DynamicLoading.forceLoadModuleInterfaces'
246 -- and 'DynamicLoading.forceLoadNameModuleInterface', but be aware that doing this indiscriminantly
247 -- will impose a performance penalty.
249 -- If no deserialization function is supplied, only transient annotations will be returned.
250 findAnnotations :: Typeable a => ([Word8] -> a) -> CoreAnnTarget -> CoreM [a]
251 findAnnotations deserialize target = do
253 return (findAnns deserialize ann_env target)
255 -- | Deserialize all annotations of a given type. This happens lazily, that is
256 -- no deserialization will take place until the [a] is actually demanded and
257 -- the [a] can also be empty (the UniqFM is not filtered).
258 deserializeAnnotations :: Typeable a => ([Word8] -> a) -> CoreM (UniqFM [a])
259 deserializeAnnotations deserialize = do
261 return (deserializeAnns deserialize ann_env)
263 addAnnotation :: Typeable a => (a -> [Word8]) -> CoreAnnTarget -> a -> CoreM ()
264 addAnnotation serialize target what = addAnnotationToEnv $ Annotation { ann_target = target, ann_value = toSerialized serialize what }
266 addAnnotationToEnv :: Annotation -> CoreM ()
267 addAnnotationToEnv annotation = modifyS (\state -> state { cs_ann_env = extendAnnEnvList (cs_ann_env state) [annotation] })
271 \subsection{Direct screen output}
275 msg :: (DynFlags -> SDoc -> IO ()) -> SDoc -> CoreM ()
277 dflags <- getDynFlags
278 liftIO $ how dflags doc
280 -- | Output a String message to the screen
281 putMsgS :: String -> CoreM ()
282 putMsgS = putMsg . text
284 -- | Output a message to the screen
285 putMsg :: SDoc -> CoreM ()
286 putMsg = msg Err.putMsg
288 -- | Output a string error to the screen
289 errorMsgS :: String -> CoreM ()
290 errorMsgS = errorMsg . text
292 -- | Output an error to the screen
293 errorMsg :: SDoc -> CoreM ()
294 errorMsg = msg Err.errorMsg
296 -- | Output a fatal string error to the screen. Note this does not by itself cause the compiler to die
297 fatalErrorMsgS :: String -> CoreM ()
298 fatalErrorMsgS = fatalErrorMsg . text
300 -- | Output a fatal error to the screen. Note this does not by itself cause the compiler to die
301 fatalErrorMsg :: SDoc -> CoreM ()
302 fatalErrorMsg = msg Err.fatalErrorMsg
304 -- | Output a string debugging message at verbosity level of @-v@ or higher
305 debugTraceMsgS :: String -> CoreM ()
306 debugTraceMsgS = debugTraceMsg . text
308 -- | Outputs a debugging message at verbosity level of @-v@ or higher
309 debugTraceMsg :: SDoc -> CoreM ()
310 debugTraceMsg = msg (flip Err.debugTraceMsg 3)
312 -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
313 dumpIfSet_dyn :: DynFlag -> String -> SDoc -> CoreM ()
314 dumpIfSet_dyn flag str = msg (\dflags -> Err.dumpIfSet_dyn dflags flag str)
320 initTcForLookup :: HscEnv -> TcM a -> IO a
321 initTcForLookup hsc_env = liftM (expectJust "initTcInteractive" . snd) . initTc hsc_env HsSrcFile False iNTERACTIVE
325 \subsection{Finding TyThings}
329 instance MonadThings CoreM where
330 lookupThing name = do
332 liftIO $ initTcForLookup hsc_env (tcLookupGlobal name)
336 \subsection{Template Haskell interoperability}
340 -- | Attempt to convert a Template Haskell name to one that GHC can
341 -- understand. Original TH names such as those you get when you use
342 -- the @'foo@ syntax will be translated to their equivalent GHC name
343 -- exactly. Qualified or unqualifed TH names will be dynamically bound
344 -- to names in the module being compiled, if possible. Exact TH names
345 -- will be bound to the name they represent, exactly.
346 thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
347 thNameToGhcName th_name = do
349 liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)