f8956b097e268eca5ab470d01056a41fdba74aad
[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, 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     getAnnotations, getFirstAnnotations,
26     
27     -- ** Debug output
28     endPass, endPassIf, endIteration,
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
57 import IOEnv hiding     ( liftIO, failM, failWithM )
58 import qualified IOEnv  ( liftIO )
59 import TcEnv            ( tcLookupGlobal )
60 import TcRnMonad        ( TcM, initTc )
61
62 import Outputable
63 import FastString
64 import qualified ErrUtils as Err
65 import Maybes
66 import UniqSupply
67 import LazyUniqFM       ( UniqFM, mapUFM, filterUFM )
68
69 import Data.Dynamic
70 import Data.IORef
71 import Data.Word
72 import Control.Monad
73
74 import Prelude hiding   ( read )
75
76 #ifdef GHCI
77 import {-# SOURCE #-} TcSplice ( lookupThName_maybe )
78 import qualified Language.Haskell.TH as TH
79 #endif
80 \end{code}
81
82 %************************************************************************
83 %*                                                                      *
84                        Debug output
85 %*                                                                      *
86 %************************************************************************
87
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.
91
92 \begin{code}
93 endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO ()
94 endPass = dumpAndLint Err.dumpIfSet_core
95
96 endPassIf :: Bool -> DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO ()
97 endPassIf cond = dumpAndLint (Err.dumpIf_core cond)
98
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
102
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))
111
112         -- Report verbosely, if required
113        ; dump dflags dump_flag pass_name
114               (pprCoreBindings binds $$ ppUnless (null rules) pp_rules)
115
116         -- Type check
117        ; lintCoreBindings dflags pass_name binds }
118   where
119     pp_rules = vcat [ blankLine
120                     , ptext (sLit "------ Local rules for imported ids --------")
121                     , pprRules rules ]
122 \end{code}
123
124
125 %************************************************************************
126 %*                                                                      *
127              Monad and carried data structure definitions
128 %*                                                                      *
129 %************************************************************************
130
131 \begin{code}
132 newtype CoreState = CoreState {
133         cs_uniq_supply :: UniqSupply
134 }
135
136 data CoreReader = CoreReader {
137         cr_hsc_env :: HscEnv,
138         cr_rule_base :: RuleBase,
139         cr_module :: Module
140 }
141
142 data CoreWriter = CoreWriter {
143         cw_simpl_count :: SimplCount
144 }
145
146 emptyWriter :: DynFlags -> CoreWriter
147 emptyWriter dflags = CoreWriter {
148         cw_simpl_count = zeroSimplCount dflags
149     }
150
151 plusWriter :: CoreWriter -> CoreWriter -> CoreWriter
152 plusWriter w1 w2 = CoreWriter {
153         cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2)
154     }
155
156 type CoreIOEnv = IOEnv CoreReader
157
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) }
161
162 instance Functor CoreM where
163     fmap f ma = do
164         a <- ma
165         return (f a)
166
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)
173
174 instance Applicative CoreM where
175     pure = return
176     (<*>) = ap
177
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)
183
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 })
189         return us1
190
191 runCoreM :: HscEnv
192          -> RuleBase
193          -> UniqSupply
194          -> Module
195          -> CoreM a
196          -> IO (a, SimplCount)
197 runCoreM hsc_env rule_base us mod m =
198         liftM extract $ runIOEnv reader $ unCoreM m state
199   where
200     reader = CoreReader {
201             cr_hsc_env = hsc_env,
202             cr_rule_base = rule_base,
203             cr_module = mod
204         }
205     state = CoreState { 
206             cs_uniq_supply = us
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 getRuleBase :: CoreM RuleBase
272 getRuleBase = read cr_rule_base
273
274 getModule :: CoreM Module
275 getModule = read cr_module
276
277 addSimplCount :: SimplCount -> CoreM ()
278 addSimplCount count = write (CoreWriter { cw_simpl_count = count })
279
280 -- Convenience accessors for useful fields of HscEnv
281
282 getDynFlags :: CoreM DynFlags
283 getDynFlags = fmap hsc_dflags getHscEnv
284
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
291
292 \end{code}
293
294
295 %************************************************************************
296 %*                                                                      *
297              Dealing with annotations
298 %*                                                                      *
299 %************************************************************************
300
301 \begin{code}
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).
305 --
306 -- This should be done once at the start of a Core-to-Core pass that uses
307 -- annotations.
308 --
309 -- See Note [Annotations]
310 getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM [a])
311 getAnnotations deserialize guts = do
312      hsc_env <- getHscEnv
313      ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts)
314      return (deserializeAnns deserialize ann_env)
315
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
321   
322 \end{code}
323
324 Note [Annotations]
325 ~~~~~~~~~~~~~~~~~~
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.
332
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.
341
342 %************************************************************************
343 %*                                                                      *
344                 Direct screen output
345 %*                                                                      *
346 %************************************************************************
347
348 \begin{code}
349
350 msg :: (DynFlags -> SDoc -> IO ()) -> SDoc -> CoreM ()
351 msg how doc = do
352         dflags <- getDynFlags
353         liftIO $ how dflags doc
354
355 -- | Output a String message to the screen
356 putMsgS :: String -> CoreM ()
357 putMsgS = putMsg . text
358
359 -- | Output a message to the screen
360 putMsg :: SDoc -> CoreM ()
361 putMsg = msg Err.putMsg
362
363 -- | Output a string error to the screen
364 errorMsgS :: String -> CoreM ()
365 errorMsgS = errorMsg . text
366
367 -- | Output an error to the screen
368 errorMsg :: SDoc -> CoreM ()
369 errorMsg = msg Err.errorMsg
370
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
374
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
378
379 -- | Output a string debugging message at verbosity level of @-v@ or higher
380 debugTraceMsgS :: String -> CoreM ()
381 debugTraceMsgS = debugTraceMsg . text
382
383 -- | Outputs a debugging message at verbosity level of @-v@ or higher
384 debugTraceMsg :: SDoc -> CoreM ()
385 debugTraceMsg = msg (flip Err.debugTraceMsg 3)
386
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)
390 \end{code}
391
392 \begin{code}
393
394 initTcForLookup :: HscEnv -> TcM a -> IO a
395 initTcForLookup hsc_env = liftM (expectJust "initTcInteractive" . snd) . initTc hsc_env HsSrcFile False iNTERACTIVE
396
397 \end{code}
398
399
400 %************************************************************************
401 %*                                                                      *
402                Finding TyThings
403 %*                                                                      *
404 %************************************************************************
405
406 \begin{code}
407 instance MonadThings CoreM where
408     lookupThing name = do
409         hsc_env <- getHscEnv
410         liftIO $ initTcForLookup hsc_env (tcLookupGlobal name)
411 \end{code}
412
413 %************************************************************************
414 %*                                                                      *
415                Template Haskell interoperability
416 %*                                                                      *
417 %************************************************************************
418
419 \begin{code}
420 #ifdef GHCI
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
429     hsc_env <- getHscEnv
430     liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)
431 #endif
432 \end{code}