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