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, 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     getAnnotations, getFirstAnnotations,
  26
  27     -- ** Debug output
  28     endPass, endPassIf, endIteration,
  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
  57 import IOEnv hiding     ( liftIO, failM, failWithM )
  58 import qualified IOEnv  ( liftIO )
  59 import TcEnv            ( tcLookupGlobal )
  60 import TcRnMonad        ( TcM, initTc )
  61
  62 import Outputable
  63 import FastString
  64 import qualified ErrUtils as Err
  65 import Maybes
  66 import UniqSupply
  67 import LazyUniqFM       ( UniqFM, mapUFM, filterUFM )
  68
  69 import Data.Dynamic
  70 import Data.IORef
  71 import Data.Word
  72 import Control.Monad
  73
  74 import Prelude hiding   ( read )
  75
  76 #ifdef GHCI
  77 import {-# SOURCE #-} TcSplice ( lookupThName_maybe )
  78 import qualified Language.Haskell.TH as TH
  79 #endif
  80 \end{code}
  81
  82 %************************************************************************
  83 %*                                                                      *
  84                        Debug output
  85 %*                                                                      *
  86 %************************************************************************
  87
  88 These functions are not CoreM monad stuff, but they probably ought to
  89 be, and it makes a conveneint place.  place for them.  They print out
  90 stuff before and after core passes, and do Core Lint when necessary.
  91
  92 \begin{code}
  93 endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO ()
  94 endPass = dumpAndLint Err.dumpIfSet_core
  95
  96 endPassIf :: Bool -> DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO ()
  97 endPassIf cond = dumpAndLint (Err.dumpIf_core cond)
  98
  99 -- Same as endPass but doesn't dump Core even with -dverbose-core2core
 100 endIteration :: DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO ()
 101 endIteration = dumpAndLint Err.dumpIfSet_dyn
 102
 103 dumpAndLint :: (DynFlags -> DynFlag -> String -> SDoc -> IO ())
 104             -> DynFlags -> String -> DynFlag
 105             -> [CoreBind] -> [CoreRule] -> IO ()
 106 dumpAndLint dump dflags pass_name dump_flag binds rules
 107   = do {  -- Report result size if required
 108           -- This has the side effect of forcing the intermediate to be evaluated
 109        ; Err.debugTraceMsg dflags 2 $
 110                 (text "    Result size =" <+> int (coreBindsSize binds))
 111
 112         -- Report verbosely, if required
 113        ; dump dflags dump_flag pass_name
 114               (pprCoreBindings binds $$ ppUnless (null rules) pp_rules)
 115
 116         -- Type check
 117        ; lintCoreBindings dflags pass_name binds }
 118   where
 119     pp_rules = vcat [ blankLine
 120                     , ptext (sLit "------ Local rules for imported ids --------")
 121                     , pprRules rules ]
 122 \end{code}
 123
 124
 125 %************************************************************************
 126 %*                                                                      *
 127              Monad and carried data structure definitions
 128 %*                                                                      *
 129 %************************************************************************
 130
 131 \begin{code}
 132 newtype CoreState = CoreState {
 133         cs_uniq_supply :: UniqSupply
 134 }
 135
 136 data CoreReader = CoreReader {
 137         cr_hsc_env :: HscEnv,
 138         cr_rule_base :: RuleBase,
 139         cr_module :: Module
 140 }
 141
 142 data CoreWriter = CoreWriter {
 143         cw_simpl_count :: SimplCount
 144 }
 145
 146 emptyWriter :: DynFlags -> CoreWriter
 147 emptyWriter dflags = CoreWriter {
 148         cw_simpl_count = zeroSimplCount dflags
 149     }
 150
 151 plusWriter :: CoreWriter -> CoreWriter -> CoreWriter
 152 plusWriter w1 w2 = CoreWriter {
 153         cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2)
 154     }
 155
 156 type CoreIOEnv = IOEnv CoreReader
 157
 158 -- | The monad used by Core-to-Core passes to access common state, register simplification
 159 -- statistics and so on
 160 newtype CoreM a = CoreM { unCoreM :: CoreState -> CoreIOEnv (a, CoreState, CoreWriter) }
 161
 162 instance Functor CoreM where
 163     fmap f ma = do
 164         a <- ma
 165         return (f a)
 166
 167 instance Monad CoreM where
 168     return x = CoreM (\s -> nop s x)
 169     mx >>= f = CoreM $ \s -> do
 170             (x, s', w1) <- unCoreM mx s
 171             (y, s'', w2) <- unCoreM (f x) s'
 172             return (y, s'', w1 `plusWriter` w2)
 173
 174 instance Applicative CoreM where
 175     pure = return
 176     (<*>) = ap
 177
 178 -- For use if the user has imported Control.Monad.Error from MTL
 179 -- Requires UndecidableInstances
 180 instance MonadPlus IO => MonadPlus CoreM where
 181     mzero = CoreM (const mzero)
 182     m `mplus` n = CoreM (\rs -> unCoreM m rs `mplus` unCoreM n rs)
 183
 184 instance MonadUnique CoreM where
 185     getUniqueSupplyM = do
 186         us <- getS cs_uniq_supply
 187         let (us1, us2) = splitUniqSupply us
 188         modifyS (\s -> s { cs_uniq_supply = us2 })
 189         return us1
 190
 191 runCoreM :: HscEnv
 192          -> RuleBase
 193          -> UniqSupply
 194          -> Module
 195          -> CoreM a
 196          -> IO (a, SimplCount)
 197 runCoreM hsc_env rule_base us mod m =
 198         liftM extract $ runIOEnv reader $ unCoreM m state
 199   where
 200     reader = CoreReader {
 201             cr_hsc_env = hsc_env,
 202             cr_rule_base = rule_base,
 203             cr_module = mod
 204         }
 205     state = CoreState {
 206             cs_uniq_supply = us
 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 getRuleBase :: CoreM RuleBase
 272 getRuleBase = read cr_rule_base
 273
 274 getModule :: CoreM Module
 275 getModule = read cr_module
 276
 277 addSimplCount :: SimplCount -> CoreM ()
 278 addSimplCount count = write (CoreWriter { cw_simpl_count = count })
 279
 280 -- Convenience accessors for useful fields of HscEnv
 281
 282 getDynFlags :: CoreM DynFlags
 283 getDynFlags = fmap hsc_dflags getHscEnv
 284
 285 -- | The original name cache is the current mapping from 'Module' and
 286 -- 'OccName' to a compiler-wide unique 'Name'
 287 getOrigNameCache :: CoreM OrigNameCache
 288 getOrigNameCache = do
 289     nameCacheRef <- fmap hsc_NC getHscEnv
 290     liftIO $ fmap nsNames $ readIORef nameCacheRef
 291
 292 \end{code}
 293
 294
 295 %************************************************************************
 296 %*                                                                      *
 297              Dealing with annotations
 298 %*                                                                      *
 299 %************************************************************************
 300
 301 \begin{code}
 302 -- | Get all annotations of a given type. This happens lazily, that is
 303 -- no deserialization will take place until the [a] is actually demanded and
 304 -- the [a] can also be empty (the UniqFM is not filtered).
 305 --
 306 -- This should be done once at the start of a Core-to-Core pass that uses
 307 -- annotations.
 308 --
 309 -- See Note [Annotations]
 310 getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM [a])
 311 getAnnotations deserialize guts = do
 312      hsc_env <- getHscEnv
 313      ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts)
 314      return (deserializeAnns deserialize ann_env)
 315
 316 -- | Get at most one annotation of a given type per Unique.
 317 getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM a)
 318 getFirstAnnotations deserialize guts
 319   = liftM (mapUFM head . filterUFM (not . null))
 320   $ getAnnotations deserialize guts
 321
 322 \end{code}
 323
 324 Note [Annotations]
 325 ~~~~~~~~~~~~~~~~~~
 326 A Core-to-Core pass that wants to make use of annotations calls
 327 getAnnotations or getFirstAnnotations at the beginning to obtain a UniqFM with
 328 annotations of a specific type. This produces all annotations from interface
 329 files read so far. However, annotations from interface files read during the
 330 pass will not be visible until getAnnotations is called again. This is similar
 331 to how rules work and probably isn't too bad.
 332
 333 The current implementation could be optimised a bit: when looking up
 334 annotations for a thing from the HomePackageTable, we could search directly in
 335 the module where the thing is defined rather than building one UniqFM which
 336 contains all annotations we know of. This would work because annotations can
 337 only be given to things defined in the same module. However, since we would
 338 only want to deserialise every annotation once, we would have to build a cache
 339 for every module in the HTP. In the end, it's probably not worth it as long as
 340 we aren't using annotations heavily.
 341
 342 %************************************************************************
 343 %*                                                                      *
 344                 Direct screen output
 345 %*                                                                      *
 346 %************************************************************************
 347
 348 \begin{code}
 349
 350 msg :: (DynFlags -> SDoc -> IO ()) -> SDoc -> CoreM ()
 351 msg how doc = do
 352         dflags <- getDynFlags
 353         liftIO $ how dflags doc
 354
 355 -- | Output a String message to the screen
 356 putMsgS :: String -> CoreM ()
 357 putMsgS = putMsg . text
 358
 359 -- | Output a message to the screen
 360 putMsg :: SDoc -> CoreM ()
 361 putMsg = msg Err.putMsg
 362
 363 -- | Output a string error to the screen
 364 errorMsgS :: String -> CoreM ()
 365 errorMsgS = errorMsg . text
 366
 367 -- | Output an error to the screen
 368 errorMsg :: SDoc -> CoreM ()
 369 errorMsg = msg Err.errorMsg
 370
 371 -- | Output a fatal string error to the screen. Note this does not by itself cause the compiler to die
 372 fatalErrorMsgS :: String -> CoreM ()
 373 fatalErrorMsgS = fatalErrorMsg . text
 374
 375 -- | Output a fatal error to the screen. Note this does not by itself cause the compiler to die
 376 fatalErrorMsg :: SDoc -> CoreM ()
 377 fatalErrorMsg = msg Err.fatalErrorMsg
 378
 379 -- | Output a string debugging message at verbosity level of @-v@ or higher
 380 debugTraceMsgS :: String -> CoreM ()
 381 debugTraceMsgS = debugTraceMsg . text
 382
 383 -- | Outputs a debugging message at verbosity level of @-v@ or higher
 384 debugTraceMsg :: SDoc -> CoreM ()
 385 debugTraceMsg = msg (flip Err.debugTraceMsg 3)
 386
 387 -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
 388 dumpIfSet_dyn :: DynFlag -> String -> SDoc -> CoreM ()
 389 dumpIfSet_dyn flag str = msg (\dflags -> Err.dumpIfSet_dyn dflags flag str)
 390 \end{code}
 391
 392 \begin{code}
 393
 394 initTcForLookup :: HscEnv -> TcM a -> IO a
 395 initTcForLookup hsc_env = liftM (expectJust "initTcInteractive" . snd) . initTc hsc_env HsSrcFile False iNTERACTIVE
 396
 397 \end{code}
 398
 399
 400 %************************************************************************
 401 %*                                                                      *
 402                Finding TyThings
 403 %*                                                                      *
 404 %************************************************************************
 405
 406 \begin{code}
 407 instance MonadThings CoreM where
 408     lookupThing name = do
 409         hsc_env <- getHscEnv
 410         liftIO $ initTcForLookup hsc_env (tcLookupGlobal name)
 411 \end{code}
 412
 413 %************************************************************************
 414 %*                                                                      *
 415                Template Haskell interoperability
 416 %*                                                                      *
 417 %************************************************************************
 418
 419 \begin{code}
 420 #ifdef GHCI
 421 -- | Attempt to convert a Template Haskell name to one that GHC can
 422 -- understand. Original TH names such as those you get when you use
 423 -- the @'foo@ syntax will be translated to their equivalent GHC name
 424 -- exactly. Qualified or unqualifed TH names will be dynamically bound
 425 -- to names in the module being compiled, if possible. Exact TH names
 426 -- will be bound to the name they represent, exactly.
 427 thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
 428 thNameToGhcName th_name = do
 429     hsc_env <- getHscEnv
 430     liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)
 431 #endif
 432 \end{code}