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     -- ** Debug output
  28     endPass, endPassIf,
  29
  30     -- ** Screen output
  31     putMsg, putMsgS, errorMsg, errorMsgS,
  32     fatalErrorMsg, fatalErrorMsgS,
  33     debugTraceMsg, debugTraceMsgS,
  34     dumpIfSet_dyn,
  35
  36 #ifdef GHCI
  37     -- * Getting 'Name's
  38     thNameToGhcName
  39 #endif
  40   ) where
  41
  42 #ifdef GHCI
  43 import Name( Name )
  44 #endif
  45 import CoreSyn
  46 import PprCore
  47 import CoreUtils
  48 import CoreLint         ( lintCoreBindings )
  49 import PrelNames        ( iNTERACTIVE )
  50 import HscTypes
  51 import Module           ( Module )
  52 import DynFlags         ( DynFlags, DynFlag )
  53 import SimplMonad       ( SimplCount, plusSimplCount, zeroSimplCount )
  54 import Rules            ( RuleBase )
  55 import Annotations
  56 import Serialized
  57
  58 import IOEnv hiding     ( liftIO, failM, failWithM )
  59 import qualified IOEnv  ( liftIO )
  60 import TcEnv            ( tcLookupGlobal )
  61 import TcRnMonad        ( TcM, initTc )
  62
  63 import Outputable
  64 import FastString
  65 import qualified ErrUtils as Err
  66 import Maybes
  67 import UniqSupply
  68 import LazyUniqFM       ( UniqFM )
  69
  70 import Data.Dynamic
  71 import Data.IORef
  72 import Data.Word
  73 import Control.Monad
  74
  75 import Prelude hiding   ( read )
  76
  77 #ifdef GHCI
  78 import {-# SOURCE #-} TcSplice ( lookupThName_maybe )
  79 import qualified Language.Haskell.TH as TH
  80 #endif
  81 \end{code}
  82
  83 %************************************************************************
  84 %*                                                                      *
  85                        Debug output
  86 %*                                                                      *
  87 %************************************************************************
  88
  89 These functions are not CoreM monad stuff, but they probably ought to
  90 be, and it makes a conveneint place.  place for them.  They print out
  91 stuff before and after core passes, and do Core Lint when necessary.
  92
  93 \begin{code}
  94 endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO ()
  95 endPass = dumpAndLint Err.dumpIfSet_core
  96
  97 endPassIf :: Bool -> DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO ()
  98 endPassIf cond = dumpAndLint (Err.dumpIf_core cond)
  99
 100 dumpAndLint :: (DynFlags -> DynFlag -> String -> SDoc -> IO ())
 101             -> DynFlags -> String -> DynFlag
 102             -> [CoreBind] -> [CoreRule] -> IO ()
 103 dumpAndLint dump dflags pass_name dump_flag binds rules
 104   = do {  -- Report result size if required
 105           -- This has the side effect of forcing the intermediate to be evaluated
 106        ; Err.debugTraceMsg dflags 2 $
 107                 (text "    Result size =" <+> int (coreBindsSize binds))
 108
 109         -- Report verbosely, if required
 110        ; dump dflags dump_flag pass_name
 111               (pprCoreBindings binds $$ ppUnless (null rules) pp_rules)
 112
 113         -- Type check
 114        ; lintCoreBindings dflags pass_name binds }
 115   where
 116     pp_rules = vcat [ blankLine
 117                     , ptext (sLit "------ Local rules for imported ids --------")
 118                     , pprRules rules ]
 119 \end{code}
 120
 121
 122 %************************************************************************
 123 %*                                                                      *
 124              Monad and carried data structure definitions
 125 %*                                                                      *
 126 %************************************************************************
 127
 128 \begin{code}
 129 data CoreState = CoreState {
 130         cs_uniq_supply :: UniqSupply,
 131         cs_ann_env :: AnnEnv
 132 }
 133
 134 data CoreReader = CoreReader {
 135         cr_hsc_env :: HscEnv,
 136         cr_rule_base :: RuleBase,
 137         cr_module :: Module
 138 }
 139
 140 data CoreWriter = CoreWriter {
 141         cw_simpl_count :: SimplCount
 142 }
 143
 144 emptyWriter :: DynFlags -> CoreWriter
 145 emptyWriter dflags = CoreWriter {
 146         cw_simpl_count = zeroSimplCount dflags
 147     }
 148
 149 plusWriter :: CoreWriter -> CoreWriter -> CoreWriter
 150 plusWriter w1 w2 = CoreWriter {
 151         cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2)
 152     }
 153
 154 type CoreIOEnv = IOEnv CoreReader
 155
 156 -- | The monad used by Core-to-Core passes to access common state, register simplification
 157 -- statistics and so on
 158 newtype CoreM a = CoreM { unCoreM :: CoreState -> CoreIOEnv (a, CoreState, CoreWriter) }
 159
 160 instance Functor CoreM where
 161     fmap f ma = do
 162         a <- ma
 163         return (f a)
 164
 165 instance Monad CoreM where
 166     return x = CoreM (\s -> nop s x)
 167     mx >>= f = CoreM $ \s -> do
 168             (x, s', w1) <- unCoreM mx s
 169             (y, s'', w2) <- unCoreM (f x) s'
 170             return (y, s'', w1 `plusWriter` w2)
 171
 172 instance Applicative CoreM where
 173     pure = return
 174     (<*>) = ap
 175
 176 -- For use if the user has imported Control.Monad.Error from MTL
 177 -- Requires UndecidableInstances
 178 instance MonadPlus IO => MonadPlus CoreM where
 179     mzero = CoreM (const mzero)
 180     m `mplus` n = CoreM (\rs -> unCoreM m rs `mplus` unCoreM n rs)
 181
 182 instance MonadUnique CoreM where
 183     getUniqueSupplyM = do
 184         us <- getS cs_uniq_supply
 185         let (us1, us2) = splitUniqSupply us
 186         modifyS (\s -> s { cs_uniq_supply = us2 })
 187         return us1
 188
 189 runCoreM :: HscEnv
 190          -> AnnEnv
 191          -> RuleBase
 192          -> UniqSupply
 193          -> Module
 194          -> CoreM a
 195          -> IO (a, SimplCount)
 196 runCoreM hsc_env ann_env rule_base us mod m =
 197         liftM extract $ runIOEnv reader $ unCoreM m state
 198   where
 199     reader = CoreReader {
 200             cr_hsc_env = hsc_env,
 201             cr_rule_base = rule_base,
 202             cr_module = mod
 203         }
 204     state = CoreState {
 205             cs_uniq_supply = us,
 206             cs_ann_env = ann_env
 207         }
 208
 209     extract :: (a, CoreState, CoreWriter) -> (a, SimplCount)
 210     extract (value, _, writer) = (value, cw_simpl_count writer)
 211
 212 \end{code}
 213
 214
 215 %************************************************************************
 216 %*                                                                      *
 217              Core combinators, not exported
 218 %*                                                                      *
 219 %************************************************************************
 220
 221 \begin{code}
 222
 223 nop :: CoreState -> a -> CoreIOEnv (a, CoreState, CoreWriter)
 224 nop s x = do
 225     r <- getEnv
 226     return (x, s, emptyWriter $ (hsc_dflags . cr_hsc_env) r)
 227
 228 read :: (CoreReader -> a) -> CoreM a
 229 read f = CoreM (\s -> getEnv >>= (\r -> nop s (f r)))
 230
 231 getS :: (CoreState -> a) -> CoreM a
 232 getS f = CoreM (\s -> nop s (f s))
 233
 234 modifyS :: (CoreState -> CoreState) -> CoreM ()
 235 modifyS f = CoreM (\s -> nop (f s) ())
 236
 237 write :: CoreWriter -> CoreM ()
 238 write w = CoreM (\s -> return ((), s, w))
 239
 240 \end{code}
 241
 242 \subsection{Lifting IO into the monad}
 243
 244 \begin{code}
 245
 246 -- | Lift an 'IOEnv' operation into 'CoreM'
 247 liftIOEnv :: CoreIOEnv a -> CoreM a
 248 liftIOEnv mx = CoreM (\s -> mx >>= (\x -> nop s x))
 249
 250 instance MonadIO CoreM where
 251     liftIO = liftIOEnv . IOEnv.liftIO
 252
 253 -- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount'
 254 liftIOWithCount :: IO (SimplCount, a) -> CoreM a
 255 liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x)
 256
 257 \end{code}
 258
 259
 260 %************************************************************************
 261 %*                                                                      *
 262              Reader, writer and state accessors
 263 %*                                                                      *
 264 %************************************************************************
 265
 266 \begin{code}
 267
 268 getHscEnv :: CoreM HscEnv
 269 getHscEnv = read cr_hsc_env
 270
 271 getAnnEnv :: CoreM AnnEnv
 272 getAnnEnv = getS cs_ann_env
 273
 274 getRuleBase :: CoreM RuleBase
 275 getRuleBase = read cr_rule_base
 276
 277 getModule :: CoreM Module
 278 getModule = read cr_module
 279
 280 addSimplCount :: SimplCount -> CoreM ()
 281 addSimplCount count = write (CoreWriter { cw_simpl_count = count })
 282
 283 -- Convenience accessors for useful fields of HscEnv
 284
 285 getDynFlags :: CoreM DynFlags
 286 getDynFlags = fmap hsc_dflags getHscEnv
 287
 288 -- | The original name cache is the current mapping from 'Module' and
 289 -- 'OccName' to a compiler-wide unique 'Name'
 290 getOrigNameCache :: CoreM OrigNameCache
 291 getOrigNameCache = do
 292     nameCacheRef <- fmap hsc_NC getHscEnv
 293     liftIO $ fmap nsNames $ readIORef nameCacheRef
 294
 295 \end{code}
 296
 297
 298 %************************************************************************
 299 %*                                                                      *
 300              Dealing with annotations
 301 %*                                                                      *
 302 %************************************************************************
 303
 304 \begin{code}
 305
 306 -- | Find all the annotations we currently know about for the given target. Note that no
 307 -- annotations will be returned if we haven't loaded information about the particular target
 308 -- you are inquiring about: by default, only those modules that have been imported by the
 309 -- program being compiled will have been loaded in this way.
 310 --
 311 -- To load the information from additional modules, you can use the functions 'DynamicLoading.forceLoadModuleInterfaces'
 312 -- and 'DynamicLoading.forceLoadNameModuleInterface', but be aware that doing this indiscriminantly
 313 -- will impose a performance penalty.
 314 --
 315 -- If no deserialization function is supplied, only transient annotations will be returned.
 316 findAnnotations :: Typeable a => ([Word8] -> a) -> CoreAnnTarget -> CoreM [a]
 317 findAnnotations deserialize target = do
 318      ann_env <- getAnnEnv
 319      return (findAnns deserialize ann_env target)
 320
 321 -- | Deserialize all annotations of a given type. This happens lazily, that is
 322 --   no deserialization will take place until the [a] is actually demanded and
 323 --   the [a] can also be empty (the UniqFM is not filtered).
 324 deserializeAnnotations :: Typeable a => ([Word8] -> a) -> CoreM (UniqFM [a])
 325 deserializeAnnotations deserialize = do
 326      ann_env <- getAnnEnv
 327      return (deserializeAnns deserialize ann_env)
 328
 329 addAnnotation :: Typeable a => (a -> [Word8]) -> CoreAnnTarget -> a -> CoreM ()
 330 addAnnotation serialize target what = addAnnotationToEnv $ Annotation { ann_target = target, ann_value = toSerialized serialize what }
 331
 332 addAnnotationToEnv :: Annotation -> CoreM ()
 333 addAnnotationToEnv annotation = modifyS (\state -> state { cs_ann_env = extendAnnEnvList (cs_ann_env state) [annotation] })
 334
 335 \end{code}
 336
 337
 338 %************************************************************************
 339 %*                                                                      *
 340                 Direct screen output
 341 %*                                                                      *
 342 %************************************************************************
 343
 344 \begin{code}
 345
 346 msg :: (DynFlags -> SDoc -> IO ()) -> SDoc -> CoreM ()
 347 msg how doc = do
 348         dflags <- getDynFlags
 349         liftIO $ how dflags doc
 350
 351 -- | Output a String message to the screen
 352 putMsgS :: String -> CoreM ()
 353 putMsgS = putMsg . text
 354
 355 -- | Output a message to the screen
 356 putMsg :: SDoc -> CoreM ()
 357 putMsg = msg Err.putMsg
 358
 359 -- | Output a string error to the screen
 360 errorMsgS :: String -> CoreM ()
 361 errorMsgS = errorMsg . text
 362
 363 -- | Output an error to the screen
 364 errorMsg :: SDoc -> CoreM ()
 365 errorMsg = msg Err.errorMsg
 366
 367 -- | Output a fatal string error to the screen. Note this does not by itself cause the compiler to die
 368 fatalErrorMsgS :: String -> CoreM ()
 369 fatalErrorMsgS = fatalErrorMsg . text
 370
 371 -- | Output a fatal error to the screen. Note this does not by itself cause the compiler to die
 372 fatalErrorMsg :: SDoc -> CoreM ()
 373 fatalErrorMsg = msg Err.fatalErrorMsg
 374
 375 -- | Output a string debugging message at verbosity level of @-v@ or higher
 376 debugTraceMsgS :: String -> CoreM ()
 377 debugTraceMsgS = debugTraceMsg . text
 378
 379 -- | Outputs a debugging message at verbosity level of @-v@ or higher
 380 debugTraceMsg :: SDoc -> CoreM ()
 381 debugTraceMsg = msg (flip Err.debugTraceMsg 3)
 382
 383 -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
 384 dumpIfSet_dyn :: DynFlag -> String -> SDoc -> CoreM ()
 385 dumpIfSet_dyn flag str = msg (\dflags -> Err.dumpIfSet_dyn dflags flag str)
 386 \end{code}
 387
 388 \begin{code}
 389
 390 initTcForLookup :: HscEnv -> TcM a -> IO a
 391 initTcForLookup hsc_env = liftM (expectJust "initTcInteractive" . snd) . initTc hsc_env HsSrcFile False iNTERACTIVE
 392
 393 \end{code}
 394
 395
 396 %************************************************************************
 397 %*                                                                      *
 398                Finding TyThings
 399 %*                                                                      *
 400 %************************************************************************
 401
 402 \begin{code}
 403 instance MonadThings CoreM where
 404     lookupThing name = do
 405         hsc_env <- getHscEnv
 406         liftIO $ initTcForLookup hsc_env (tcLookupGlobal name)
 407 \end{code}
 408
 409 %************************************************************************
 410 %*                                                                      *
 411                Template Haskell interoperability
 412 %*                                                                      *
 413 %************************************************************************
 414
 415 \begin{code}
 416 #ifdef GHCI
 417 -- | Attempt to convert a Template Haskell name to one that GHC can
 418 -- understand. Original TH names such as those you get when you use
 419 -- the @'foo@ syntax will be translated to their equivalent GHC name
 420 -- exactly. Qualified or unqualifed TH names will be dynamically bound
 421 -- to names in the module being compiled, if possible. Exact TH names
 422 -- will be bound to the name they represent, exactly.
 423 thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
 424 thNameToGhcName th_name = do
 425     hsc_env <- getHscEnv
 426     liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)
 427 #endif
 428 \end{code}