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 endPass, endPassIf, endIteration,
31 putMsg, putMsgS, errorMsg, errorMsgS,
32 fatalErrorMsg, fatalErrorMsgS,
33 debugTraceMsg, debugTraceMsgS,
48 import CoreLint ( lintCoreBindings )
49 import PrelNames ( iNTERACTIVE )
51 import Module ( Module )
52 import DynFlags ( DynFlags, DynFlag )
53 import SimplMonad ( SimplCount, plusSimplCount, zeroSimplCount )
54 import Rules ( RuleBase )
58 import IOEnv hiding ( liftIO, failM, failWithM )
59 import qualified IOEnv ( liftIO )
60 import TcEnv ( tcLookupGlobal )
61 import TcRnMonad ( TcM, initTc )
65 import qualified ErrUtils as Err
68 import LazyUniqFM ( UniqFM )
75 import Prelude hiding ( read )
78 import {-# SOURCE #-} TcSplice ( lookupThName_maybe )
79 import qualified Language.Haskell.TH as TH
83 %************************************************************************
87 %************************************************************************
89 These functions are not CoreM monad stuff, but they probably ought to
90 be, and it makes a conveneint place. place for them. They print out
91 stuff before and after core passes, and do Core Lint when necessary.
94 endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO ()
95 endPass = dumpAndLint Err.dumpIfSet_core
97 endPassIf :: Bool -> DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO ()
98 endPassIf cond = dumpAndLint (Err.dumpIf_core cond)
100 -- Same as endPass but doesn't dump Core even with -dverbose-core2core
101 endIteration :: DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO ()
102 endIteration = dumpAndLint Err.dumpIfSet_dyn
104 dumpAndLint :: (DynFlags -> DynFlag -> String -> SDoc -> IO ())
105 -> DynFlags -> String -> DynFlag
106 -> [CoreBind] -> [CoreRule] -> IO ()
107 dumpAndLint dump dflags pass_name dump_flag binds rules
108 = do { -- Report result size if required
109 -- This has the side effect of forcing the intermediate to be evaluated
110 ; Err.debugTraceMsg dflags 2 $
111 (text " Result size =" <+> int (coreBindsSize binds))
113 -- Report verbosely, if required
114 ; dump dflags dump_flag pass_name
115 (pprCoreBindings binds $$ ppUnless (null rules) pp_rules)
118 ; lintCoreBindings dflags pass_name binds }
120 pp_rules = vcat [ blankLine
121 , ptext (sLit "------ Local rules for imported ids --------")
126 %************************************************************************
128 Monad and carried data structure definitions
130 %************************************************************************
133 data CoreState = CoreState {
134 cs_uniq_supply :: UniqSupply,
138 data CoreReader = CoreReader {
139 cr_hsc_env :: HscEnv,
140 cr_rule_base :: RuleBase,
144 data CoreWriter = CoreWriter {
145 cw_simpl_count :: SimplCount
148 emptyWriter :: DynFlags -> CoreWriter
149 emptyWriter dflags = CoreWriter {
150 cw_simpl_count = zeroSimplCount dflags
153 plusWriter :: CoreWriter -> CoreWriter -> CoreWriter
154 plusWriter w1 w2 = CoreWriter {
155 cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2)
158 type CoreIOEnv = IOEnv CoreReader
160 -- | The monad used by Core-to-Core passes to access common state, register simplification
161 -- statistics and so on
162 newtype CoreM a = CoreM { unCoreM :: CoreState -> CoreIOEnv (a, CoreState, CoreWriter) }
164 instance Functor CoreM where
169 instance Monad CoreM where
170 return x = CoreM (\s -> nop s x)
171 mx >>= f = CoreM $ \s -> do
172 (x, s', w1) <- unCoreM mx s
173 (y, s'', w2) <- unCoreM (f x) s'
174 return (y, s'', w1 `plusWriter` w2)
176 instance Applicative CoreM where
180 -- For use if the user has imported Control.Monad.Error from MTL
181 -- Requires UndecidableInstances
182 instance MonadPlus IO => MonadPlus CoreM where
183 mzero = CoreM (const mzero)
184 m `mplus` n = CoreM (\rs -> unCoreM m rs `mplus` unCoreM n rs)
186 instance MonadUnique CoreM where
187 getUniqueSupplyM = do
188 us <- getS cs_uniq_supply
189 let (us1, us2) = splitUniqSupply us
190 modifyS (\s -> s { cs_uniq_supply = us2 })
199 -> IO (a, SimplCount)
200 runCoreM hsc_env ann_env rule_base us mod m =
201 liftM extract $ runIOEnv reader $ unCoreM m state
203 reader = CoreReader {
204 cr_hsc_env = hsc_env,
205 cr_rule_base = rule_base,
213 extract :: (a, CoreState, CoreWriter) -> (a, SimplCount)
214 extract (value, _, writer) = (value, cw_simpl_count writer)
219 %************************************************************************
221 Core combinators, not exported
223 %************************************************************************
227 nop :: CoreState -> a -> CoreIOEnv (a, CoreState, CoreWriter)
230 return (x, s, emptyWriter $ (hsc_dflags . cr_hsc_env) r)
232 read :: (CoreReader -> a) -> CoreM a
233 read f = CoreM (\s -> getEnv >>= (\r -> nop s (f r)))
235 getS :: (CoreState -> a) -> CoreM a
236 getS f = CoreM (\s -> nop s (f s))
238 modifyS :: (CoreState -> CoreState) -> CoreM ()
239 modifyS f = CoreM (\s -> nop (f s) ())
241 write :: CoreWriter -> CoreM ()
242 write w = CoreM (\s -> return ((), s, w))
246 \subsection{Lifting IO into the monad}
250 -- | Lift an 'IOEnv' operation into 'CoreM'
251 liftIOEnv :: CoreIOEnv a -> CoreM a
252 liftIOEnv mx = CoreM (\s -> mx >>= (\x -> nop s x))
254 instance MonadIO CoreM where
255 liftIO = liftIOEnv . IOEnv.liftIO
257 -- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount'
258 liftIOWithCount :: IO (SimplCount, a) -> CoreM a
259 liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x)
264 %************************************************************************
266 Reader, writer and state accessors
268 %************************************************************************
272 getHscEnv :: CoreM HscEnv
273 getHscEnv = read cr_hsc_env
275 getAnnEnv :: CoreM AnnEnv
276 getAnnEnv = getS cs_ann_env
278 getRuleBase :: CoreM RuleBase
279 getRuleBase = read cr_rule_base
281 getModule :: CoreM Module
282 getModule = read cr_module
284 addSimplCount :: SimplCount -> CoreM ()
285 addSimplCount count = write (CoreWriter { cw_simpl_count = count })
287 -- Convenience accessors for useful fields of HscEnv
289 getDynFlags :: CoreM DynFlags
290 getDynFlags = fmap hsc_dflags getHscEnv
292 -- | The original name cache is the current mapping from 'Module' and
293 -- 'OccName' to a compiler-wide unique 'Name'
294 getOrigNameCache :: CoreM OrigNameCache
295 getOrigNameCache = do
296 nameCacheRef <- fmap hsc_NC getHscEnv
297 liftIO $ fmap nsNames $ readIORef nameCacheRef
302 %************************************************************************
304 Dealing with annotations
306 %************************************************************************
310 -- | Find all the annotations we currently know about for the given target. Note that no
311 -- annotations will be returned if we haven't loaded information about the particular target
312 -- you are inquiring about: by default, only those modules that have been imported by the
313 -- program being compiled will have been loaded in this way.
315 -- To load the information from additional modules, you can use the functions 'DynamicLoading.forceLoadModuleInterfaces'
316 -- and 'DynamicLoading.forceLoadNameModuleInterface', but be aware that doing this indiscriminantly
317 -- will impose a performance penalty.
319 -- If no deserialization function is supplied, only transient annotations will be returned.
320 findAnnotations :: Typeable a => ([Word8] -> a) -> CoreAnnTarget -> CoreM [a]
321 findAnnotations deserialize target = do
323 return (findAnns deserialize ann_env target)
325 -- | Deserialize all annotations of a given type. This happens lazily, that is
326 -- no deserialization will take place until the [a] is actually demanded and
327 -- the [a] can also be empty (the UniqFM is not filtered).
328 deserializeAnnotations :: Typeable a => ([Word8] -> a) -> CoreM (UniqFM [a])
329 deserializeAnnotations deserialize = do
331 return (deserializeAnns deserialize ann_env)
333 addAnnotation :: Typeable a => (a -> [Word8]) -> CoreAnnTarget -> a -> CoreM ()
334 addAnnotation serialize target what = addAnnotationToEnv $ Annotation { ann_target = target, ann_value = toSerialized serialize what }
336 addAnnotationToEnv :: Annotation -> CoreM ()
337 addAnnotationToEnv annotation = modifyS (\state -> state { cs_ann_env = extendAnnEnvList (cs_ann_env state) [annotation] })
342 %************************************************************************
346 %************************************************************************
350 msg :: (DynFlags -> SDoc -> IO ()) -> SDoc -> CoreM ()
352 dflags <- getDynFlags
353 liftIO $ how dflags doc
355 -- | Output a String message to the screen
356 putMsgS :: String -> CoreM ()
357 putMsgS = putMsg . text
359 -- | Output a message to the screen
360 putMsg :: SDoc -> CoreM ()
361 putMsg = msg Err.putMsg
363 -- | Output a string error to the screen
364 errorMsgS :: String -> CoreM ()
365 errorMsgS = errorMsg . text
367 -- | Output an error to the screen
368 errorMsg :: SDoc -> CoreM ()
369 errorMsg = msg Err.errorMsg
371 -- | Output a fatal string error to the screen. Note this does not by itself cause the compiler to die
372 fatalErrorMsgS :: String -> CoreM ()
373 fatalErrorMsgS = fatalErrorMsg . text
375 -- | Output a fatal error to the screen. Note this does not by itself cause the compiler to die
376 fatalErrorMsg :: SDoc -> CoreM ()
377 fatalErrorMsg = msg Err.fatalErrorMsg
379 -- | Output a string debugging message at verbosity level of @-v@ or higher
380 debugTraceMsgS :: String -> CoreM ()
381 debugTraceMsgS = debugTraceMsg . text
383 -- | Outputs a debugging message at verbosity level of @-v@ or higher
384 debugTraceMsg :: SDoc -> CoreM ()
385 debugTraceMsg = msg (flip Err.debugTraceMsg 3)
387 -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
388 dumpIfSet_dyn :: DynFlag -> String -> SDoc -> CoreM ()
389 dumpIfSet_dyn flag str = msg (\dflags -> Err.dumpIfSet_dyn dflags flag str)
394 initTcForLookup :: HscEnv -> TcM a -> IO a
395 initTcForLookup hsc_env = liftM (expectJust "initTcInteractive" . snd) . initTc hsc_env HsSrcFile False iNTERACTIVE
400 %************************************************************************
404 %************************************************************************
407 instance MonadThings CoreM where
408 lookupThing name = do
410 liftIO $ initTcForLookup hsc_env (tcLookupGlobal name)
413 %************************************************************************
415 Template Haskell interoperability
417 %************************************************************************
421 -- | Attempt to convert a Template Haskell name to one that GHC can
422 -- understand. Original TH names such as those you get when you use
423 -- the @'foo@ syntax will be translated to their equivalent GHC name
424 -- exactly. Qualified or unqualifed TH names will be dynamically bound
425 -- to names in the module being compiled, if possible. Exact TH names
426 -- will be bound to the name they represent, exactly.
427 thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
428 thNameToGhcName th_name = do
430 liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)