Remove unused imports
[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, addAnnotation,
26     
27     -- ** Screen output
28     putMsg, putMsgS, errorMsg, errorMsgS, 
29     fatalErrorMsg, fatalErrorMsgS, 
30     debugTraceMsg, debugTraceMsgS,
31     dumpIfSet_dyn,
32
33 #ifdef GHCI
34     -- * Getting 'Name's
35     thNameToGhcName
36 #endif
37   ) where
38
39 #ifdef GHCI
40 import Name( Name )
41 #endif
42 import PrelNames        ( iNTERACTIVE )
43 import HscTypes
44 import Module           ( Module )
45 import DynFlags         ( DynFlags, DynFlag )
46 import SimplMonad       ( SimplCount, plusSimplCount, zeroSimplCount )
47 import Rules            ( RuleBase )
48 import Annotations
49 import Serialized
50
51 import IOEnv hiding     ( liftIO, failM, failWithM )
52 import qualified IOEnv  ( liftIO )
53 import TcEnv            ( tcLookupGlobal )
54 import TcRnMonad        ( TcM, initTc )
55
56 import Outputable
57 import qualified ErrUtils as Err
58 import Maybes
59 import UniqSupply
60
61 import Data.Dynamic
62 import Data.IORef
63 import Data.Word
64 import Control.Monad
65
66 import Prelude hiding   ( read )
67
68 #ifdef GHCI
69 import {-# SOURCE #-} TcSplice ( lookupThName_maybe )
70 import qualified Language.Haskell.TH as TH
71 #endif
72 \end{code}
73
74 \subsection{Monad and carried data structure definitions}
75
76 \begin{code}
77 data CoreState = CoreState {
78         cs_uniq_supply :: UniqSupply,
79         cs_ann_env :: AnnEnv
80 }
81
82 data CoreReader = CoreReader {
83         cr_hsc_env :: HscEnv,
84         cr_rule_base :: RuleBase,
85         cr_module :: Module
86 }
87
88 data CoreWriter = CoreWriter {
89         cw_simpl_count :: SimplCount
90 }
91
92 emptyWriter :: DynFlags -> CoreWriter
93 emptyWriter dflags = CoreWriter {
94         cw_simpl_count = zeroSimplCount dflags
95     }
96
97 plusWriter :: CoreWriter -> CoreWriter -> CoreWriter
98 plusWriter w1 w2 = CoreWriter {
99         cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2)
100     }
101
102 type CoreIOEnv = IOEnv CoreReader
103
104 -- | The monad used by Core-to-Core passes to access common state, register simplification
105 -- statistics and so on
106 newtype CoreM a = CoreM { unCoreM :: CoreState -> CoreIOEnv (a, CoreState, CoreWriter) }
107
108 instance Functor CoreM where
109     fmap f ma = do
110         a <- ma
111         return (f a)
112
113 instance Monad CoreM where
114     return x = CoreM (\s -> nop s x)
115     mx >>= f = CoreM $ \s -> do
116             (x, s', w1) <- unCoreM mx s
117             (y, s'', w2) <- unCoreM (f x) s'
118             return (y, s'', w1 `plusWriter` w2)
119
120 instance Applicative CoreM where
121     pure = return
122     (<*>) = ap
123
124 -- For use if the user has imported Control.Monad.Error from MTL
125 -- Requires UndecidableInstances
126 instance MonadPlus IO => MonadPlus CoreM where
127     mzero = CoreM (const mzero)
128     m `mplus` n = CoreM (\rs -> unCoreM m rs `mplus` unCoreM n rs)
129
130 instance MonadUnique CoreM where
131     getUniqueSupplyM = do
132         us <- getS cs_uniq_supply
133         let (us1, us2) = splitUniqSupply us
134         modifyS (\s -> s { cs_uniq_supply = us2 })
135         return us1
136
137 runCoreM :: HscEnv
138          -> AnnEnv
139          -> RuleBase
140          -> UniqSupply
141          -> Module
142          -> CoreM a
143          -> IO (a, SimplCount)
144 runCoreM hsc_env ann_env rule_base us mod m =
145         liftM extract $ runIOEnv reader $ unCoreM m state
146   where
147     reader = CoreReader {
148             cr_hsc_env = hsc_env,
149             cr_rule_base = rule_base,
150             cr_module = mod
151         }
152     state = CoreState { 
153             cs_uniq_supply = us,
154             cs_ann_env = ann_env
155         }
156
157     extract :: (a, CoreState, CoreWriter) -> (a, SimplCount)
158     extract (value, _, writer) = (value, cw_simpl_count writer)
159
160 \end{code}
161
162 \subsection{Core combinators, not exported}
163
164 \begin{code}
165
166 nop :: CoreState -> a -> CoreIOEnv (a, CoreState, CoreWriter)
167 nop s x = do
168     r <- getEnv
169     return (x, s, emptyWriter $ (hsc_dflags . cr_hsc_env) r)
170
171 read :: (CoreReader -> a) -> CoreM a
172 read f = CoreM (\s -> getEnv >>= (\r -> nop s (f r)))
173
174 getS :: (CoreState -> a) -> CoreM a
175 getS f = CoreM (\s -> nop s (f s))
176
177 modifyS :: (CoreState -> CoreState) -> CoreM ()
178 modifyS f = CoreM (\s -> nop (f s) ())
179
180 write :: CoreWriter -> CoreM ()
181 write w = CoreM (\s -> return ((), s, w))
182
183 \end{code}
184
185 \subsection{Lifting IO into the monad}
186
187 \begin{code}
188
189 -- | Lift an 'IOEnv' operation into 'CoreM'
190 liftIOEnv :: CoreIOEnv a -> CoreM a
191 liftIOEnv mx = CoreM (\s -> mx >>= (\x -> nop s x))
192
193 instance MonadIO CoreM where
194     liftIO = liftIOEnv . IOEnv.liftIO
195
196 -- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount'
197 liftIOWithCount :: IO (SimplCount, a) -> CoreM a
198 liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x)
199
200 \end{code}
201
202 \subsection{Reader, writer and state accessors}
203
204 \begin{code}
205
206 getHscEnv :: CoreM HscEnv
207 getHscEnv = read cr_hsc_env
208
209 getAnnEnv :: CoreM AnnEnv
210 getAnnEnv = getS cs_ann_env
211
212 getRuleBase :: CoreM RuleBase
213 getRuleBase = read cr_rule_base
214
215 getModule :: CoreM Module
216 getModule = read cr_module
217
218 addSimplCount :: SimplCount -> CoreM ()
219 addSimplCount count = write (CoreWriter { cw_simpl_count = count })
220
221 -- Convenience accessors for useful fields of HscEnv
222
223 getDynFlags :: CoreM DynFlags
224 getDynFlags = fmap hsc_dflags getHscEnv
225
226 -- | The original name cache is the current mapping from 'Module' and
227 -- 'OccName' to a compiler-wide unique 'Name'
228 getOrigNameCache :: CoreM OrigNameCache
229 getOrigNameCache = do
230     nameCacheRef <- fmap hsc_NC getHscEnv
231     liftIO $ fmap nsNames $ readIORef nameCacheRef
232
233 \end{code}
234
235 \subsection{Dealing with annotations}
236
237 \begin{code}
238
239 -- | Find all the annotations we currently know about for the given target. Note that no
240 -- annotations will be returned if we haven't loaded information about the particular target
241 -- you are inquiring about: by default, only those modules that have been imported by the
242 -- program being compiled will have been loaded in this way.
243 --
244 -- To load the information from additional modules, you can use the functions 'DynamicLoading.forceLoadModuleInterfaces'
245 -- and 'DynamicLoading.forceLoadNameModuleInterface', but be aware that doing this indiscriminantly
246 -- will impose a performance penalty.
247 --
248 -- If no deserialization function is supplied, only transient annotations will be returned.
249 findAnnotations :: Typeable a => ([Word8] -> a) -> CoreAnnTarget -> CoreM [a]
250 findAnnotations deserialize target = do
251      ann_env <- getAnnEnv
252      return (findAnns deserialize ann_env target)
253
254 addAnnotation :: Typeable a => (a -> [Word8]) -> CoreAnnTarget -> a -> CoreM ()
255 addAnnotation serialize target what = addAnnotationToEnv $ Annotation { ann_target = target, ann_value = toSerialized serialize what }
256
257 addAnnotationToEnv :: Annotation -> CoreM ()
258 addAnnotationToEnv annotation = modifyS (\state -> state { cs_ann_env = extendAnnEnvList (cs_ann_env state) [annotation] })
259
260 \end{code}
261
262 \subsection{Direct screen output}
263
264 \begin{code}
265
266 msg :: (DynFlags -> SDoc -> IO ()) -> SDoc -> CoreM ()
267 msg how doc = do
268         dflags <- getDynFlags
269         liftIO $ how dflags doc
270
271 -- | Output a String message to the screen
272 putMsgS :: String -> CoreM ()
273 putMsgS = putMsg . text
274
275 -- | Output a message to the screen
276 putMsg :: SDoc -> CoreM ()
277 putMsg = msg Err.putMsg
278
279 -- | Output a string error to the screen
280 errorMsgS :: String -> CoreM ()
281 errorMsgS = errorMsg . text
282
283 -- | Output an error to the screen
284 errorMsg :: SDoc -> CoreM ()
285 errorMsg = msg Err.errorMsg
286
287 -- | Output a fatal string error to the screen. Note this does not by itself cause the compiler to die
288 fatalErrorMsgS :: String -> CoreM ()
289 fatalErrorMsgS = fatalErrorMsg . text
290
291 -- | Output a fatal error to the screen. Note this does not by itself cause the compiler to die
292 fatalErrorMsg :: SDoc -> CoreM ()
293 fatalErrorMsg = msg Err.fatalErrorMsg
294
295 -- | Output a string debugging message at verbosity level of @-v@ or higher
296 debugTraceMsgS :: String -> CoreM ()
297 debugTraceMsgS = debugTraceMsg . text
298
299 -- | Outputs a debugging message at verbosity level of @-v@ or higher
300 debugTraceMsg :: SDoc -> CoreM ()
301 debugTraceMsg = msg (flip Err.debugTraceMsg 3)
302
303 -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
304 dumpIfSet_dyn :: DynFlag -> String -> SDoc -> CoreM ()
305 dumpIfSet_dyn flag str = msg (\dflags -> Err.dumpIfSet_dyn dflags flag str)
306
307 \end{code}
308
309 \begin{code}
310
311 initTcForLookup :: HscEnv -> TcM a -> IO a
312 initTcForLookup hsc_env = liftM (expectJust "initTcInteractive" . snd) . initTc hsc_env HsSrcFile False iNTERACTIVE
313
314 \end{code}
315
316 \subsection{Finding TyThings}
317
318 \begin{code}
319
320 instance MonadThings CoreM where
321     lookupThing name = do
322         hsc_env <- getHscEnv
323         liftIO $ initTcForLookup hsc_env (tcLookupGlobal name)
324
325 \end{code}
326
327 \subsection{Template Haskell interoperability}
328
329 \begin{code}
330 #ifdef GHCI
331 -- | Attempt to convert a Template Haskell name to one that GHC can
332 -- understand. Original TH names such as those you get when you use
333 -- the @'foo@ syntax will be translated to their equivalent GHC name
334 -- exactly. Qualified or unqualifed TH names will be dynamically bound
335 -- to names in the module being compiled, if possible. Exact TH names
336 -- will be bound to the name they represent, exactly.
337 thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
338 thNameToGhcName th_name = do
339     hsc_env <- getHscEnv
340     liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)
341 #endif
342 \end{code}