The Big INLINE Patch: totally reorganise way that INLINE pragmas work
[ghc.git] / compiler / simplCore / CoreMonad.lhs
1 %
2 % (c) The AQUA Project, Glasgow University, 1993-1998
3 %
4 \section[CoreMonad]{The core pipeline monad}
5
6 \begin{code}
7 {-# LANGUAGE UndecidableInstances #-}
8
9 module CoreMonad (
10     -- * The monad
11     CoreM, runCoreM,
12     
13     -- ** Reading from the monad
14     getHscEnv, getAnnEnv, getRuleBase, getModule,
15     getDynFlags, getOrigNameCache,
16     
17     -- ** Writing to the monad
18     addSimplCount,
19     
20     -- ** Lifting into the monad
21     liftIO, liftIOWithCount,
22     liftIO1, liftIO2, liftIO3, liftIO4,
23     
24     -- ** Dealing with annotations
25     findAnnotations, deserializeAnnotations, addAnnotation,
26     
27     -- ** Debug output
28     endPass, endPassIf, 
29
30     -- ** Screen output
31     putMsg, putMsgS, errorMsg, errorMsgS, 
32     fatalErrorMsg, fatalErrorMsgS, 
33     debugTraceMsg, debugTraceMsgS,
34     dumpIfSet_dyn,
35
36 #ifdef GHCI
37     -- * Getting 'Name's
38     thNameToGhcName
39 #endif
40   ) where
41
42 #ifdef GHCI
43 import Name( Name )
44 #endif
45 import CoreSyn
46 import PprCore
47 import CoreUtils
48 import CoreLint         ( lintCoreBindings )
49 import PrelNames        ( iNTERACTIVE )
50 import HscTypes
51 import Module           ( Module )
52 import DynFlags         ( DynFlags, DynFlag )
53 import SimplMonad       ( SimplCount, plusSimplCount, zeroSimplCount )
54 import Rules            ( RuleBase )
55 import Annotations
56 import Serialized
57
58 import IOEnv hiding     ( liftIO, failM, failWithM )
59 import qualified IOEnv  ( liftIO )
60 import TcEnv            ( tcLookupGlobal )
61 import TcRnMonad        ( TcM, initTc )
62
63 import Outputable
64 import FastString
65 import qualified ErrUtils as Err
66 import Maybes
67 import UniqSupply
68 import LazyUniqFM       ( UniqFM )
69
70 import Data.Dynamic
71 import Data.IORef
72 import Data.Word
73 import Control.Monad
74
75 import Prelude hiding   ( read )
76
77 #ifdef GHCI
78 import {-# SOURCE #-} TcSplice ( lookupThName_maybe )
79 import qualified Language.Haskell.TH as TH
80 #endif
81 \end{code}
82
83 %************************************************************************
84 %*                                                                      *
85                        Debug output
86 %*                                                                      *
87 %************************************************************************
88
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.
92
93 \begin{code}
94 endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO ()
95 endPass = dumpAndLint Err.dumpIfSet_core
96
97 endPassIf :: Bool -> DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO ()
98 endPassIf cond = dumpAndLint (Err.dumpIf_core cond)
99
100 dumpAndLint :: (DynFlags -> DynFlag -> String -> SDoc -> IO ())
101             -> DynFlags -> String -> DynFlag 
102             -> [CoreBind] -> [CoreRule] -> IO ()
103 dumpAndLint dump dflags pass_name dump_flag binds rules
104   = do {  -- Report result size if required
105           -- This has the side effect of forcing the intermediate to be evaluated
106        ; Err.debugTraceMsg dflags 2 $
107                 (text "    Result size =" <+> int (coreBindsSize binds))
108
109         -- Report verbosely, if required
110        ; dump dflags dump_flag pass_name
111               (pprCoreBindings binds $$ ppUnless (null rules) pp_rules)
112
113         -- Type check
114        ; lintCoreBindings dflags pass_name binds }
115   where
116     pp_rules = vcat [ blankLine
117                     , ptext (sLit "------ Local rules for imported ids --------")
118                     , pprRules rules ]
119 \end{code}
120
121
122 %************************************************************************
123 %*                                                                      *
124              Monad and carried data structure definitions
125 %*                                                                      *
126 %************************************************************************
127
128 \begin{code}
129 data CoreState = CoreState {
130         cs_uniq_supply :: UniqSupply,
131         cs_ann_env :: AnnEnv
132 }
133
134 data CoreReader = CoreReader {
135         cr_hsc_env :: HscEnv,
136         cr_rule_base :: RuleBase,
137         cr_module :: Module
138 }
139
140 data CoreWriter = CoreWriter {
141         cw_simpl_count :: SimplCount
142 }
143
144 emptyWriter :: DynFlags -> CoreWriter
145 emptyWriter dflags = CoreWriter {
146         cw_simpl_count = zeroSimplCount dflags
147     }
148
149 plusWriter :: CoreWriter -> CoreWriter -> CoreWriter
150 plusWriter w1 w2 = CoreWriter {
151         cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2)
152     }
153
154 type CoreIOEnv = IOEnv CoreReader
155
156 -- | The monad used by Core-to-Core passes to access common state, register simplification
157 -- statistics and so on
158 newtype CoreM a = CoreM { unCoreM :: CoreState -> CoreIOEnv (a, CoreState, CoreWriter) }
159
160 instance Functor CoreM where
161     fmap f ma = do
162         a <- ma
163         return (f a)
164
165 instance Monad CoreM where
166     return x = CoreM (\s -> nop s x)
167     mx >>= f = CoreM $ \s -> do
168             (x, s', w1) <- unCoreM mx s
169             (y, s'', w2) <- unCoreM (f x) s'
170             return (y, s'', w1 `plusWriter` w2)
171
172 instance Applicative CoreM where
173     pure = return
174     (<*>) = ap
175
176 -- For use if the user has imported Control.Monad.Error from MTL
177 -- Requires UndecidableInstances
178 instance MonadPlus IO => MonadPlus CoreM where
179     mzero = CoreM (const mzero)
180     m `mplus` n = CoreM (\rs -> unCoreM m rs `mplus` unCoreM n rs)
181
182 instance MonadUnique CoreM where
183     getUniqueSupplyM = do
184         us <- getS cs_uniq_supply
185         let (us1, us2) = splitUniqSupply us
186         modifyS (\s -> s { cs_uniq_supply = us2 })
187         return us1
188
189 runCoreM :: HscEnv
190          -> AnnEnv
191          -> RuleBase
192          -> UniqSupply
193          -> Module
194          -> CoreM a
195          -> IO (a, SimplCount)
196 runCoreM hsc_env ann_env rule_base us mod m =
197         liftM extract $ runIOEnv reader $ unCoreM m state
198   where
199     reader = CoreReader {
200             cr_hsc_env = hsc_env,
201             cr_rule_base = rule_base,
202             cr_module = mod
203         }
204     state = CoreState { 
205             cs_uniq_supply = us,
206             cs_ann_env = ann_env
207         }
208
209     extract :: (a, CoreState, CoreWriter) -> (a, SimplCount)
210     extract (value, _, writer) = (value, cw_simpl_count writer)
211
212 \end{code}
213
214
215 %************************************************************************
216 %*                                                                      *
217              Core combinators, not exported
218 %*                                                                      *
219 %************************************************************************
220
221 \begin{code}
222
223 nop :: CoreState -> a -> CoreIOEnv (a, CoreState, CoreWriter)
224 nop s x = do
225     r <- getEnv
226     return (x, s, emptyWriter $ (hsc_dflags . cr_hsc_env) r)
227
228 read :: (CoreReader -> a) -> CoreM a
229 read f = CoreM (\s -> getEnv >>= (\r -> nop s (f r)))
230
231 getS :: (CoreState -> a) -> CoreM a
232 getS f = CoreM (\s -> nop s (f s))
233
234 modifyS :: (CoreState -> CoreState) -> CoreM ()
235 modifyS f = CoreM (\s -> nop (f s) ())
236
237 write :: CoreWriter -> CoreM ()
238 write w = CoreM (\s -> return ((), s, w))
239
240 \end{code}
241
242 \subsection{Lifting IO into the monad}
243
244 \begin{code}
245
246 -- | Lift an 'IOEnv' operation into 'CoreM'
247 liftIOEnv :: CoreIOEnv a -> CoreM a
248 liftIOEnv mx = CoreM (\s -> mx >>= (\x -> nop s x))
249
250 instance MonadIO CoreM where
251     liftIO = liftIOEnv . IOEnv.liftIO
252
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)
256
257 \end{code}
258
259
260 %************************************************************************
261 %*                                                                      *
262              Reader, writer and state accessors
263 %*                                                                      *
264 %************************************************************************
265
266 \begin{code}
267
268 getHscEnv :: CoreM HscEnv
269 getHscEnv = read cr_hsc_env
270
271 getAnnEnv :: CoreM AnnEnv
272 getAnnEnv = getS cs_ann_env
273
274 getRuleBase :: CoreM RuleBase
275 getRuleBase = read cr_rule_base
276
277 getModule :: CoreM Module
278 getModule = read cr_module
279
280 addSimplCount :: SimplCount -> CoreM ()
281 addSimplCount count = write (CoreWriter { cw_simpl_count = count })
282
283 -- Convenience accessors for useful fields of HscEnv
284
285 getDynFlags :: CoreM DynFlags
286 getDynFlags = fmap hsc_dflags getHscEnv
287
288 -- | The original name cache is the current mapping from 'Module' and
289 -- 'OccName' to a compiler-wide unique 'Name'
290 getOrigNameCache :: CoreM OrigNameCache
291 getOrigNameCache = do
292     nameCacheRef <- fmap hsc_NC getHscEnv
293     liftIO $ fmap nsNames $ readIORef nameCacheRef
294
295 \end{code}
296
297
298 %************************************************************************
299 %*                                                                      *
300              Dealing with annotations
301 %*                                                                      *
302 %************************************************************************
303
304 \begin{code}
305
306 -- | Find all the annotations we currently know about for the given target. Note that no
307 -- annotations will be returned if we haven't loaded information about the particular target
308 -- you are inquiring about: by default, only those modules that have been imported by the
309 -- program being compiled will have been loaded in this way.
310 --
311 -- To load the information from additional modules, you can use the functions 'DynamicLoading.forceLoadModuleInterfaces'
312 -- and 'DynamicLoading.forceLoadNameModuleInterface', but be aware that doing this indiscriminantly
313 -- will impose a performance penalty.
314 --
315 -- If no deserialization function is supplied, only transient annotations will be returned.
316 findAnnotations :: Typeable a => ([Word8] -> a) -> CoreAnnTarget -> CoreM [a]
317 findAnnotations deserialize target = do
318      ann_env <- getAnnEnv
319      return (findAnns deserialize ann_env target)
320
321 -- | Deserialize all annotations of a given type. This happens lazily, that is
322 --   no deserialization will take place until the [a] is actually demanded and
323 --   the [a] can also be empty (the UniqFM is not filtered).
324 deserializeAnnotations :: Typeable a => ([Word8] -> a) -> CoreM (UniqFM [a])
325 deserializeAnnotations deserialize = do
326      ann_env <- getAnnEnv
327      return (deserializeAnns deserialize ann_env)
328
329 addAnnotation :: Typeable a => (a -> [Word8]) -> CoreAnnTarget -> a -> CoreM ()
330 addAnnotation serialize target what = addAnnotationToEnv $ Annotation { ann_target = target, ann_value = toSerialized serialize what }
331
332 addAnnotationToEnv :: Annotation -> CoreM ()
333 addAnnotationToEnv annotation = modifyS (\state -> state { cs_ann_env = extendAnnEnvList (cs_ann_env state) [annotation] })
334
335 \end{code}
336
337
338 %************************************************************************
339 %*                                                                      *
340                 Direct screen output
341 %*                                                                      *
342 %************************************************************************
343
344 \begin{code}
345
346 msg :: (DynFlags -> SDoc -> IO ()) -> SDoc -> CoreM ()
347 msg how doc = do
348         dflags <- getDynFlags
349         liftIO $ how dflags doc
350
351 -- | Output a String message to the screen
352 putMsgS :: String -> CoreM ()
353 putMsgS = putMsg . text
354
355 -- | Output a message to the screen
356 putMsg :: SDoc -> CoreM ()
357 putMsg = msg Err.putMsg
358
359 -- | Output a string error to the screen
360 errorMsgS :: String -> CoreM ()
361 errorMsgS = errorMsg . text
362
363 -- | Output an error to the screen
364 errorMsg :: SDoc -> CoreM ()
365 errorMsg = msg Err.errorMsg
366
367 -- | Output a fatal string error to the screen. Note this does not by itself cause the compiler to die
368 fatalErrorMsgS :: String -> CoreM ()
369 fatalErrorMsgS = fatalErrorMsg . text
370
371 -- | Output a fatal error to the screen. Note this does not by itself cause the compiler to die
372 fatalErrorMsg :: SDoc -> CoreM ()
373 fatalErrorMsg = msg Err.fatalErrorMsg
374
375 -- | Output a string debugging message at verbosity level of @-v@ or higher
376 debugTraceMsgS :: String -> CoreM ()
377 debugTraceMsgS = debugTraceMsg . text
378
379 -- | Outputs a debugging message at verbosity level of @-v@ or higher
380 debugTraceMsg :: SDoc -> CoreM ()
381 debugTraceMsg = msg (flip Err.debugTraceMsg 3)
382
383 -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
384 dumpIfSet_dyn :: DynFlag -> String -> SDoc -> CoreM ()
385 dumpIfSet_dyn flag str = msg (\dflags -> Err.dumpIfSet_dyn dflags flag str)
386 \end{code}
387
388 \begin{code}
389
390 initTcForLookup :: HscEnv -> TcM a -> IO a
391 initTcForLookup hsc_env = liftM (expectJust "initTcInteractive" . snd) . initTc hsc_env HsSrcFile False iNTERACTIVE
392
393 \end{code}
394
395
396 %************************************************************************
397 %*                                                                      *
398                Finding TyThings
399 %*                                                                      *
400 %************************************************************************
401
402 \begin{code}
403 instance MonadThings CoreM where
404     lookupThing name = do
405         hsc_env <- getHscEnv
406         liftIO $ initTcForLookup hsc_env (tcLookupGlobal name)
407 \end{code}
408
409 %************************************************************************
410 %*                                                                      *
411                Template Haskell interoperability
412 %*                                                                      *
413 %************************************************************************
414
415 \begin{code}
416 #ifdef GHCI
417 -- | Attempt to convert a Template Haskell name to one that GHC can
418 -- understand. Original TH names such as those you get when you use
419 -- the @'foo@ syntax will be translated to their equivalent GHC name
420 -- exactly. Qualified or unqualifed TH names will be dynamically bound
421 -- to names in the module being compiled, if possible. Exact TH names
422 -- will be bound to the name they represent, exactly.
423 thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
424 thNameToGhcName th_name = do
425     hsc_env <- getHscEnv
426     liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)
427 #endif
428 \end{code}