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