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, 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 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 -- Same as endPass but doesn't dump Core even with -dverbose-core2core
 101 endIteration :: DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO ()
 102 endIteration = dumpAndLint Err.dumpIfSet_dyn
 103
 104 dumpAndLint :: (DynFlags -> DynFlag -> String -> SDoc -> IO ())
 105             -> DynFlags -> String -> DynFlag
 106             -> [CoreBind] -> [CoreRule] -> IO ()
 107 dumpAndLint dump dflags pass_name dump_flag binds rules
 108   = do {  -- Report result size if required
 109           -- This has the side effect of forcing the intermediate to be evaluated
 110        ; Err.debugTraceMsg dflags 2 $
 111                 (text "    Result size =" <+> int (coreBindsSize binds))
 112
 113         -- Report verbosely, if required
 114        ; dump dflags dump_flag pass_name
 115               (pprCoreBindings binds $$ ppUnless (null rules) pp_rules)
 116
 117         -- Type check
 118        ; lintCoreBindings dflags pass_name binds }
 119   where
 120     pp_rules = vcat [ blankLine
 121                     , ptext (sLit "------ Local rules for imported ids --------")
 122                     , pprRules rules ]
 123 \end{code}
 124
 125
 126 %************************************************************************
 127 %*                                                                      *
 128              Monad and carried data structure definitions
 129 %*                                                                      *
 130 %************************************************************************
 131
 132 \begin{code}
 133 data CoreState = CoreState {
 134         cs_uniq_supply :: UniqSupply,
 135         cs_ann_env :: AnnEnv
 136 }
 137
 138 data CoreReader = CoreReader {
 139         cr_hsc_env :: HscEnv,
 140         cr_rule_base :: RuleBase,
 141         cr_module :: Module
 142 }
 143
 144 data CoreWriter = CoreWriter {
 145         cw_simpl_count :: SimplCount
 146 }
 147
 148 emptyWriter :: DynFlags -> CoreWriter
 149 emptyWriter dflags = CoreWriter {
 150         cw_simpl_count = zeroSimplCount dflags
 151     }
 152
 153 plusWriter :: CoreWriter -> CoreWriter -> CoreWriter
 154 plusWriter w1 w2 = CoreWriter {
 155         cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2)
 156     }
 157
 158 type CoreIOEnv = IOEnv CoreReader
 159
 160 -- | The monad used by Core-to-Core passes to access common state, register simplification
 161 -- statistics and so on
 162 newtype CoreM a = CoreM { unCoreM :: CoreState -> CoreIOEnv (a, CoreState, CoreWriter) }
 163
 164 instance Functor CoreM where
 165     fmap f ma = do
 166         a <- ma
 167         return (f a)
 168
 169 instance Monad CoreM where
 170     return x = CoreM (\s -> nop s x)
 171     mx >>= f = CoreM $ \s -> do
 172             (x, s', w1) <- unCoreM mx s
 173             (y, s'', w2) <- unCoreM (f x) s'
 174             return (y, s'', w1 `plusWriter` w2)
 175
 176 instance Applicative CoreM where
 177     pure = return
 178     (<*>) = ap
 179
 180 -- For use if the user has imported Control.Monad.Error from MTL
 181 -- Requires UndecidableInstances
 182 instance MonadPlus IO => MonadPlus CoreM where
 183     mzero = CoreM (const mzero)
 184     m `mplus` n = CoreM (\rs -> unCoreM m rs `mplus` unCoreM n rs)
 185
 186 instance MonadUnique CoreM where
 187     getUniqueSupplyM = do
 188         us <- getS cs_uniq_supply
 189         let (us1, us2) = splitUniqSupply us
 190         modifyS (\s -> s { cs_uniq_supply = us2 })
 191         return us1
 192
 193 runCoreM :: HscEnv
 194          -> AnnEnv
 195          -> RuleBase
 196          -> UniqSupply
 197          -> Module
 198          -> CoreM a
 199          -> IO (a, SimplCount)
 200 runCoreM hsc_env ann_env rule_base us mod m =
 201         liftM extract $ runIOEnv reader $ unCoreM m state
 202   where
 203     reader = CoreReader {
 204             cr_hsc_env = hsc_env,
 205             cr_rule_base = rule_base,
 206             cr_module = mod
 207         }
 208     state = CoreState {
 209             cs_uniq_supply = us,
 210             cs_ann_env = ann_env
 211         }
 212
 213     extract :: (a, CoreState, CoreWriter) -> (a, SimplCount)
 214     extract (value, _, writer) = (value, cw_simpl_count writer)
 215
 216 \end{code}
 217
 218
 219 %************************************************************************
 220 %*                                                                      *
 221              Core combinators, not exported
 222 %*                                                                      *
 223 %************************************************************************
 224
 225 \begin{code}
 226
 227 nop :: CoreState -> a -> CoreIOEnv (a, CoreState, CoreWriter)
 228 nop s x = do
 229     r <- getEnv
 230     return (x, s, emptyWriter $ (hsc_dflags . cr_hsc_env) r)
 231
 232 read :: (CoreReader -> a) -> CoreM a
 233 read f = CoreM (\s -> getEnv >>= (\r -> nop s (f r)))
 234
 235 getS :: (CoreState -> a) -> CoreM a
 236 getS f = CoreM (\s -> nop s (f s))
 237
 238 modifyS :: (CoreState -> CoreState) -> CoreM ()
 239 modifyS f = CoreM (\s -> nop (f s) ())
 240
 241 write :: CoreWriter -> CoreM ()
 242 write w = CoreM (\s -> return ((), s, w))
 243
 244 \end{code}
 245
 246 \subsection{Lifting IO into the monad}
 247
 248 \begin{code}
 249
 250 -- | Lift an 'IOEnv' operation into 'CoreM'
 251 liftIOEnv :: CoreIOEnv a -> CoreM a
 252 liftIOEnv mx = CoreM (\s -> mx >>= (\x -> nop s x))
 253
 254 instance MonadIO CoreM where
 255     liftIO = liftIOEnv . IOEnv.liftIO
 256
 257 -- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount'
 258 liftIOWithCount :: IO (SimplCount, a) -> CoreM a
 259 liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x)
 260
 261 \end{code}
 262
 263
 264 %************************************************************************
 265 %*                                                                      *
 266              Reader, writer and state accessors
 267 %*                                                                      *
 268 %************************************************************************
 269
 270 \begin{code}
 271
 272 getHscEnv :: CoreM HscEnv
 273 getHscEnv = read cr_hsc_env
 274
 275 getAnnEnv :: CoreM AnnEnv
 276 getAnnEnv = getS cs_ann_env
 277
 278 getRuleBase :: CoreM RuleBase
 279 getRuleBase = read cr_rule_base
 280
 281 getModule :: CoreM Module
 282 getModule = read cr_module
 283
 284 addSimplCount :: SimplCount -> CoreM ()
 285 addSimplCount count = write (CoreWriter { cw_simpl_count = count })
 286
 287 -- Convenience accessors for useful fields of HscEnv
 288
 289 getDynFlags :: CoreM DynFlags
 290 getDynFlags = fmap hsc_dflags getHscEnv
 291
 292 -- | The original name cache is the current mapping from 'Module' and
 293 -- 'OccName' to a compiler-wide unique 'Name'
 294 getOrigNameCache :: CoreM OrigNameCache
 295 getOrigNameCache = do
 296     nameCacheRef <- fmap hsc_NC getHscEnv
 297     liftIO $ fmap nsNames $ readIORef nameCacheRef
 298
 299 \end{code}
 300
 301
 302 %************************************************************************
 303 %*                                                                      *
 304              Dealing with annotations
 305 %*                                                                      *
 306 %************************************************************************
 307
 308 \begin{code}
 309
 310 -- | Find all the annotations we currently know about for the given target. Note that no
 311 -- annotations will be returned if we haven't loaded information about the particular target
 312 -- you are inquiring about: by default, only those modules that have been imported by the
 313 -- program being compiled will have been loaded in this way.
 314 --
 315 -- To load the information from additional modules, you can use the functions 'DynamicLoading.forceLoadModuleInterfaces'
 316 -- and 'DynamicLoading.forceLoadNameModuleInterface', but be aware that doing this indiscriminantly
 317 -- will impose a performance penalty.
 318 --
 319 -- If no deserialization function is supplied, only transient annotations will be returned.
 320 findAnnotations :: Typeable a => ([Word8] -> a) -> CoreAnnTarget -> CoreM [a]
 321 findAnnotations deserialize target = do
 322      ann_env <- getAnnEnv
 323      return (findAnns deserialize ann_env target)
 324
 325 -- | Deserialize all annotations of a given type. This happens lazily, that is
 326 --   no deserialization will take place until the [a] is actually demanded and
 327 --   the [a] can also be empty (the UniqFM is not filtered).
 328 deserializeAnnotations :: Typeable a => ([Word8] -> a) -> CoreM (UniqFM [a])
 329 deserializeAnnotations deserialize = do
 330      ann_env <- getAnnEnv
 331      return (deserializeAnns deserialize ann_env)
 332
 333 addAnnotation :: Typeable a => (a -> [Word8]) -> CoreAnnTarget -> a -> CoreM ()
 334 addAnnotation serialize target what = addAnnotationToEnv $ Annotation { ann_target = target, ann_value = toSerialized serialize what }
 335
 336 addAnnotationToEnv :: Annotation -> CoreM ()
 337 addAnnotationToEnv annotation = modifyS (\state -> state { cs_ann_env = extendAnnEnvList (cs_ann_env state) [annotation] })
 338
 339 \end{code}
 340
 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}