Don't dump Core after every simplifier iteration with -dverbose-core2core
[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, 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 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 -- 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
103
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))
112
113         -- Report verbosely, if required
114        ; dump dflags dump_flag pass_name
115               (pprCoreBindings binds $$ ppUnless (null rules) pp_rules)
116
117         -- Type check
118        ; lintCoreBindings dflags pass_name binds }
119   where
120     pp_rules = vcat [ blankLine
121                     , ptext (sLit "------ Local rules for imported ids --------")
122                     , pprRules rules ]
123 \end{code}
124
125
126 %************************************************************************
127 %*                                                                      *
128              Monad and carried data structure definitions
129 %*                                                                      *
130 %************************************************************************
131
132 \begin{code}
133 data CoreState = CoreState {
134         cs_uniq_supply :: UniqSupply,
135         cs_ann_env :: AnnEnv
136 }
137
138 data CoreReader = CoreReader {
139         cr_hsc_env :: HscEnv,
140         cr_rule_base :: RuleBase,
141         cr_module :: Module
142 }
143
144 data CoreWriter = CoreWriter {
145         cw_simpl_count :: SimplCount
146 }
147
148 emptyWriter :: DynFlags -> CoreWriter
149 emptyWriter dflags = CoreWriter {
150         cw_simpl_count = zeroSimplCount dflags
151     }
152
153 plusWriter :: CoreWriter -> CoreWriter -> CoreWriter
154 plusWriter w1 w2 = CoreWriter {
155         cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2)
156     }
157
158 type CoreIOEnv = IOEnv CoreReader
159
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) }
163
164 instance Functor CoreM where
165     fmap f ma = do
166         a <- ma
167         return (f a)
168
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)
175
176 instance Applicative CoreM where
177     pure = return
178     (<*>) = ap
179
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)
185
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 })
191         return us1
192
193 runCoreM :: HscEnv
194          -> AnnEnv
195          -> RuleBase
196          -> UniqSupply
197          -> Module
198          -> CoreM a
199          -> IO (a, SimplCount)
200 runCoreM hsc_env ann_env rule_base us mod m =
201         liftM extract $ runIOEnv reader $ unCoreM m state
202   where
203     reader = CoreReader {
204             cr_hsc_env = hsc_env,
205             cr_rule_base = rule_base,
206             cr_module = mod
207         }
208     state = CoreState { 
209             cs_uniq_supply = us,
210             cs_ann_env = ann_env
211         }
212
213     extract :: (a, CoreState, CoreWriter) -> (a, SimplCount)
214     extract (value, _, writer) = (value, cw_simpl_count writer)
215
216 \end{code}
217
218
219 %************************************************************************
220 %*                                                                      *
221              Core combinators, not exported
222 %*                                                                      *
223 %************************************************************************
224
225 \begin{code}
226
227 nop :: CoreState -> a -> CoreIOEnv (a, CoreState, CoreWriter)
228 nop s x = do
229     r <- getEnv
230     return (x, s, emptyWriter $ (hsc_dflags . cr_hsc_env) r)
231
232 read :: (CoreReader -> a) -> CoreM a
233 read f = CoreM (\s -> getEnv >>= (\r -> nop s (f r)))
234
235 getS :: (CoreState -> a) -> CoreM a
236 getS f = CoreM (\s -> nop s (f s))
237
238 modifyS :: (CoreState -> CoreState) -> CoreM ()
239 modifyS f = CoreM (\s -> nop (f s) ())
240
241 write :: CoreWriter -> CoreM ()
242 write w = CoreM (\s -> return ((), s, w))
243
244 \end{code}
245
246 \subsection{Lifting IO into the monad}
247
248 \begin{code}
249
250 -- | Lift an 'IOEnv' operation into 'CoreM'
251 liftIOEnv :: CoreIOEnv a -> CoreM a
252 liftIOEnv mx = CoreM (\s -> mx >>= (\x -> nop s x))
253
254 instance MonadIO CoreM where
255     liftIO = liftIOEnv . IOEnv.liftIO
256
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)
260
261 \end{code}
262
263
264 %************************************************************************
265 %*                                                                      *
266              Reader, writer and state accessors
267 %*                                                                      *
268 %************************************************************************
269
270 \begin{code}
271
272 getHscEnv :: CoreM HscEnv
273 getHscEnv = read cr_hsc_env
274
275 getAnnEnv :: CoreM AnnEnv
276 getAnnEnv = getS cs_ann_env
277
278 getRuleBase :: CoreM RuleBase
279 getRuleBase = read cr_rule_base
280
281 getModule :: CoreM Module
282 getModule = read cr_module
283
284 addSimplCount :: SimplCount -> CoreM ()
285 addSimplCount count = write (CoreWriter { cw_simpl_count = count })
286
287 -- Convenience accessors for useful fields of HscEnv
288
289 getDynFlags :: CoreM DynFlags
290 getDynFlags = fmap hsc_dflags getHscEnv
291
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
298
299 \end{code}
300
301
302 %************************************************************************
303 %*                                                                      *
304              Dealing with annotations
305 %*                                                                      *
306 %************************************************************************
307
308 \begin{code}
309
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.
314 --
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.
318 --
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
322      ann_env <- getAnnEnv
323      return (findAnns deserialize ann_env target)
324
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
330      ann_env <- getAnnEnv
331      return (deserializeAnns deserialize ann_env)
332
333 addAnnotation :: Typeable a => (a -> [Word8]) -> CoreAnnTarget -> a -> CoreM ()
334 addAnnotation serialize target what = addAnnotationToEnv $ Annotation { ann_target = target, ann_value = toSerialized serialize what }
335
336 addAnnotationToEnv :: Annotation -> CoreM ()
337 addAnnotationToEnv annotation = modifyS (\state -> state { cs_ann_env = extendAnnEnvList (cs_ann_env state) [annotation] })
338
339 \end{code}
340
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}