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}