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}