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