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, 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 getAnnotations, getFirstAnnotations,
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 )
57 import IOEnv hiding ( liftIO, failM, failWithM )
58 import qualified IOEnv ( liftIO )
59 import TcEnv ( tcLookupGlobal )
60 import TcRnMonad ( TcM, initTc )
64 import qualified ErrUtils as Err
67 import LazyUniqFM ( UniqFM, mapUFM, filterUFM )
74 import Prelude hiding ( read )
77 import {-# SOURCE #-} TcSplice ( lookupThName_maybe )
78 import qualified Language.Haskell.TH as TH
82 %************************************************************************
86 %************************************************************************
88 These functions are not CoreM monad stuff, but they probably ought to
89 be, and it makes a conveneint place. place for them. They print out
90 stuff before and after core passes, and do Core Lint when necessary.
93 endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO ()
94 endPass = dumpAndLint Err.dumpIfSet_core
96 endPassIf :: Bool -> DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO ()
97 endPassIf cond = dumpAndLint (Err.dumpIf_core cond)
99 -- Same as endPass but doesn't dump Core even with -dverbose-core2core
100 endIteration :: DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO ()
101 endIteration = dumpAndLint Err.dumpIfSet_dyn
103 dumpAndLint :: (DynFlags -> DynFlag -> String -> SDoc -> IO ())
104 -> DynFlags -> String -> DynFlag
105 -> [CoreBind] -> [CoreRule] -> IO ()
106 dumpAndLint dump dflags pass_name dump_flag binds rules
107 = do { -- Report result size if required
108 -- This has the side effect of forcing the intermediate to be evaluated
109 ; Err.debugTraceMsg dflags 2 $
110 (text " Result size =" <+> int (coreBindsSize binds))
112 -- Report verbosely, if required
113 ; dump dflags dump_flag pass_name
114 (pprCoreBindings binds $$ ppUnless (null rules) pp_rules)
117 ; lintCoreBindings dflags pass_name binds }
119 pp_rules = vcat [ blankLine
120 , ptext (sLit "------ Local rules for imported ids --------")
125 %************************************************************************
127 Monad and carried data structure definitions
129 %************************************************************************
132 newtype CoreState = CoreState {
133 cs_uniq_supply :: UniqSupply
136 data CoreReader = CoreReader {
137 cr_hsc_env :: HscEnv,
138 cr_rule_base :: RuleBase,
142 data CoreWriter = CoreWriter {
143 cw_simpl_count :: SimplCount
146 emptyWriter :: DynFlags -> CoreWriter
147 emptyWriter dflags = CoreWriter {
148 cw_simpl_count = zeroSimplCount dflags
151 plusWriter :: CoreWriter -> CoreWriter -> CoreWriter
152 plusWriter w1 w2 = CoreWriter {
153 cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2)
156 type CoreIOEnv = IOEnv CoreReader
158 -- | The monad used by Core-to-Core passes to access common state, register simplification
159 -- statistics and so on
160 newtype CoreM a = CoreM { unCoreM :: CoreState -> CoreIOEnv (a, CoreState, CoreWriter) }
162 instance Functor CoreM where
167 instance Monad CoreM where
168 return x = CoreM (\s -> nop s x)
169 mx >>= f = CoreM $ \s -> do
170 (x, s', w1) <- unCoreM mx s
171 (y, s'', w2) <- unCoreM (f x) s'
172 return (y, s'', w1 `plusWriter` w2)
174 instance Applicative CoreM where
178 -- For use if the user has imported Control.Monad.Error from MTL
179 -- Requires UndecidableInstances
180 instance MonadPlus IO => MonadPlus CoreM where
181 mzero = CoreM (const mzero)
182 m `mplus` n = CoreM (\rs -> unCoreM m rs `mplus` unCoreM n rs)
184 instance MonadUnique CoreM where
185 getUniqueSupplyM = do
186 us <- getS cs_uniq_supply
187 let (us1, us2) = splitUniqSupply us
188 modifyS (\s -> s { cs_uniq_supply = us2 })
196 -> IO (a, SimplCount)
197 runCoreM hsc_env rule_base us mod m =
198 liftM extract $ runIOEnv reader $ unCoreM m state
200 reader = CoreReader {
201 cr_hsc_env = hsc_env,
202 cr_rule_base = rule_base,
209 extract :: (a, CoreState, CoreWriter) -> (a, SimplCount)
210 extract (value, _, writer) = (value, cw_simpl_count writer)
215 %************************************************************************
217 Core combinators, not exported
219 %************************************************************************
223 nop :: CoreState -> a -> CoreIOEnv (a, CoreState, CoreWriter)
226 return (x, s, emptyWriter $ (hsc_dflags . cr_hsc_env) r)
228 read :: (CoreReader -> a) -> CoreM a
229 read f = CoreM (\s -> getEnv >>= (\r -> nop s (f r)))
231 getS :: (CoreState -> a) -> CoreM a
232 getS f = CoreM (\s -> nop s (f s))
234 modifyS :: (CoreState -> CoreState) -> CoreM ()
235 modifyS f = CoreM (\s -> nop (f s) ())
237 write :: CoreWriter -> CoreM ()
238 write w = CoreM (\s -> return ((), s, w))
242 \subsection{Lifting IO into the monad}
246 -- | Lift an 'IOEnv' operation into 'CoreM'
247 liftIOEnv :: CoreIOEnv a -> CoreM a
248 liftIOEnv mx = CoreM (\s -> mx >>= (\x -> nop s x))
250 instance MonadIO CoreM where
251 liftIO = liftIOEnv . IOEnv.liftIO
253 -- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount'
254 liftIOWithCount :: IO (SimplCount, a) -> CoreM a
255 liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x)
260 %************************************************************************
262 Reader, writer and state accessors
264 %************************************************************************
268 getHscEnv :: CoreM HscEnv
269 getHscEnv = read cr_hsc_env
271 getRuleBase :: CoreM RuleBase
272 getRuleBase = read cr_rule_base
274 getModule :: CoreM Module
275 getModule = read cr_module
277 addSimplCount :: SimplCount -> CoreM ()
278 addSimplCount count = write (CoreWriter { cw_simpl_count = count })
280 -- Convenience accessors for useful fields of HscEnv
282 getDynFlags :: CoreM DynFlags
283 getDynFlags = fmap hsc_dflags getHscEnv
285 -- | The original name cache is the current mapping from 'Module' and
286 -- 'OccName' to a compiler-wide unique 'Name'
287 getOrigNameCache :: CoreM OrigNameCache
288 getOrigNameCache = do
289 nameCacheRef <- fmap hsc_NC getHscEnv
290 liftIO $ fmap nsNames $ readIORef nameCacheRef
295 %************************************************************************
297 Dealing with annotations
299 %************************************************************************
302 -- | Get all annotations of a given type. This happens lazily, that is
303 -- no deserialization will take place until the [a] is actually demanded and
304 -- the [a] can also be empty (the UniqFM is not filtered).
306 -- This should be done once at the start of a Core-to-Core pass that uses
309 -- See Note [Annotations]
310 getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM [a])
311 getAnnotations deserialize guts = do
313 ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts)
314 return (deserializeAnns deserialize ann_env)
316 -- | Get at most one annotation of a given type per Unique.
317 getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM a)
318 getFirstAnnotations deserialize guts
319 = liftM (mapUFM head . filterUFM (not . null))
320 $ getAnnotations deserialize guts
326 A Core-to-Core pass that wants to make use of annotations calls
327 getAnnotations or getFirstAnnotations at the beginning to obtain a UniqFM with
328 annotations of a specific type. This produces all annotations from interface
329 files read so far. However, annotations from interface files read during the
330 pass will not be visible until getAnnotations is called again. This is similar
331 to how rules work and probably isn't too bad.
333 The current implementation could be optimised a bit: when looking up
334 annotations for a thing from the HomePackageTable, we could search directly in
335 the module where the thing is defined rather than building one UniqFM which
336 contains all annotations we know of. This would work because annotations can
337 only be given to things defined in the same module. However, since we would
338 only want to deserialise every annotation once, we would have to build a cache
339 for every module in the HTP. In the end, it's probably not worth it as long as
340 we aren't using annotations heavily.
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)