compiler/main/HscMain.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-2000
   3 %
   4
   5 \section[GHC_Main]{Main driver for Glasgow Haskell compiler}
   6
   7 \begin{code}
   8 module HscMain
   9     ( newHscEnv, hscCmmFile
  10     , hscParseIdentifier
  11     , hscSimplify
  12     , evalComp
  13     , hscNormalIface, hscWriteIface, hscOneShot
  14     , CompState (..)
  15 #ifdef GHCI
  16     , hscStmt, hscTcExpr, hscKcType
  17     , compileExpr
  18 #endif
  19     , hscCompileOneShot     -- :: Compiler HscStatus
  20     , hscCompileBatch       -- :: Compiler (HscStatus, ModIface, ModDetails)
  21     , hscCompileNothing     -- :: Compiler (HscStatus, ModIface, ModDetails)
  22     , hscCompileInteractive -- :: Compiler (InteractiveStatus, ModIface, ModDetails)
  23     , HscStatus (..)
  24     , InteractiveStatus (..)
  25
  26     -- The new interface
  27     , parseFile
  28     , typecheckModule'
  29     , typecheckRenameModule
  30     , deSugarModule
  31     , makeSimpleIface
  32     , makeSimpleDetails
  33     ) where
  34
  35 #ifdef GHCI
  36 import CodeOutput       ( outputForeignStubs )
  37 import ByteCodeGen      ( byteCodeGen, coreExprToBCOs )
  38 import Linker           ( HValue, linkExpr )
  39 import CoreTidy         ( tidyExpr )
  40 import CorePrep         ( corePrepExpr )
  41 import Desugar          ( deSugarExpr )
  42 import SimplCore        ( simplifyExpr )
  43 import TcRnDriver       ( tcRnStmt, tcRnExpr, tcRnType )
  44 import Type             ( Type )
  45 import PrelNames        ( iNTERACTIVE )
  46 import {- Kind parts of -} Type         ( Kind )
  47 import CoreLint         ( lintUnfolding )
  48 import DsMeta           ( templateHaskellNames )
  49 import SrcLoc           ( SrcSpan, noSrcLoc, interactiveSrcLoc, srcLocSpan, noSrcSpan )
  50 import VarSet
  51 import VarEnv           ( emptyTidyEnv )
  52 #endif
  53
  54 import Id               ( Id )
  55 import Module           ( emptyModuleEnv, ModLocation(..), Module )
  56 import RdrName
  57 import HsSyn
  58 import CoreSyn
  59 import SrcLoc           ( Located(..) )
  60 import StringBuffer
  61 import Parser
  62 import Lexer
  63 import SrcLoc           ( mkSrcLoc )
  64 import TcRnDriver       ( tcRnModule )
  65 import TcIface          ( typecheckIface )
  66 import TcRnMonad        ( initIfaceCheck, TcGblEnv(..) )
  67 import IfaceEnv         ( initNameCache )
  68 import LoadIface        ( ifaceStats, initExternalPackageState )
  69 import PrelInfo         ( wiredInThings, basicKnownKeyNames )
  70 import MkIface
  71 import Desugar          ( deSugar )
  72 import SimplCore        ( core2core )
  73 import TidyPgm
  74 import CorePrep         ( corePrepPgm )
  75 import CoreToStg        ( coreToStg )
  76 import StgSyn
  77 import CostCentre
  78 import TyCon            ( isDataTyCon )
  79 import Name             ( Name, NamedThing(..) )
  80 import SimplStg         ( stg2stg )
  81 import CodeGen          ( codeGen )
  82 import Cmm              ( Cmm )
  83 import CmmParse         ( parseCmmFile )
  84 import CmmCPS
  85 import CmmCPSZ
  86 import CmmInfo
  87 import OptimizationFuel ( initOptFuelState )
  88 import CmmCvt
  89 import CmmTx
  90 import CmmContFlowOpt
  91 import CodeOutput       ( codeOutput )
  92 import NameEnv          ( emptyNameEnv )
  93
  94 import DynFlags
  95 import ErrUtils
  96 import UniqSupply       ( mkSplitUniqSupply )
  97
  98 import Outputable
  99 import HscStats         ( ppSourceStats )
 100 import HscTypes
 101 import MkExternalCore   ( emitExternalCore )
 102 import FastString
 103 import LazyUniqFM               ( emptyUFM )
 104 import UniqSupply       ( initUs_ )
 105 import Bag              ( unitBag, emptyBag, unionBags )
 106 import Exception
 107 import MonadUtils
 108
 109 import Control.Monad
 110 import System.IO
 111 import Data.IORef
 112 \end{code}
 113 #include "HsVersions.h"
 114
 115
 116 %************************************************************************
 117 %*                                                                      *
 118                 Initialisation
 119 %*                                                                      *
 120 %************************************************************************
 121
 122 \begin{code}
 123 newHscEnv :: DynFlags -> IO HscEnv
 124 newHscEnv dflags
 125   = do  { eps_var <- newIORef initExternalPackageState
 126         ; us      <- mkSplitUniqSupply 'r'
 127         ; nc_var  <- newIORef (initNameCache us knownKeyNames)
 128         ; fc_var  <- newIORef emptyUFM
 129         ; mlc_var <- newIORef emptyModuleEnv
 130         ; optFuel <- initOptFuelState
 131         ; return (HscEnv { hsc_dflags = dflags,
 132                            hsc_targets = [],
 133                            hsc_mod_graph = [],
 134                            hsc_IC      = emptyInteractiveContext,
 135                            hsc_HPT     = emptyHomePackageTable,
 136                            hsc_EPS     = eps_var,
 137                            hsc_NC      = nc_var,
 138                            hsc_FC      = fc_var,
 139                            hsc_MLC     = mlc_var,
 140                            hsc_OptFuel = optFuel,
 141                            hsc_type_env_var = Nothing,
 142                            hsc_global_rdr_env = emptyGlobalRdrEnv,
 143                            hsc_global_type_env = emptyNameEnv } ) }
 144
 145
 146 knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta,
 147                         -- where templateHaskellNames are defined
 148 knownKeyNames = map getName wiredInThings
 149               ++ basicKnownKeyNames
 150 #ifdef GHCI
 151               ++ templateHaskellNames
 152 #endif
 153 \end{code}
 154
 155
 156 \begin{code}
 157 -- | parse a file, returning the abstract syntax
 158 parseFile :: GhcMonad m => HscEnv -> ModSummary -> m (Located (HsModule RdrName))
 159 parseFile hsc_env mod_summary = do
 160     ((warns,errs), maybe_parsed) <- liftIO $ myParseModule dflags hspp_file hspp_buf
 161     logWarnings warns
 162     case maybe_parsed of
 163       Nothing -> liftIO $ throwIO (mkSrcErr errs)
 164       Just rdr_module
 165               -> return rdr_module
 166   where
 167            dflags    = hsc_dflags hsc_env
 168            hspp_file = ms_hspp_file mod_summary
 169            hspp_buf  = ms_hspp_buf  mod_summary
 170
 171 -- | Rename and typecheck a module
 172 typecheckModule' :: GhcMonad m =>
 173                    HscEnv -> ModSummary -> Located (HsModule RdrName)
 174                 -> m TcGblEnv
 175 typecheckModule' hsc_env mod_summary rdr_module = do
 176       r <- {-# SCC "Typecheck-Rename" #-}
 177            ioMsgMaybe $ tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module
 178       return r
 179
 180 -- XXX: should this really be a Maybe X?  Check under which circumstances this
 181 -- can become a Nothing and decide whether this should instead throw an
 182 -- exception/signal an error.
 183 type RenamedStuff =
 184         (Maybe (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
 185                 Maybe (HsDoc Name), HaddockModInfo Name))
 186
 187 -- | Rename and typecheck a module, additionally returning the renamed syntax
 188 typecheckRenameModule
 189     :: GhcMonad m =>
 190        HscEnv -> ModSummary -> Located (HsModule RdrName)
 191     -> m (TcGblEnv, RenamedStuff)
 192 typecheckRenameModule hsc_env mod_summary rdr_module = do
 193     tc_result
 194           <- {-# SCC "Typecheck-Rename" #-}
 195              ioMsgMaybe $ tcRnModule hsc_env (ms_hsc_src mod_summary) True rdr_module
 196
 197     let rn_info = do decl <- tcg_rn_decls tc_result
 198                      imports <- tcg_rn_imports tc_result
 199                      let exports = tcg_rn_exports tc_result
 200                      let doc = tcg_doc tc_result
 201                      let hmi = tcg_hmi tc_result
 202                      return (decl,imports,exports,doc,hmi)
 203
 204     return (tc_result, rn_info)
 205
 206 -- | Convert a typechecked module to Core
 207 deSugarModule :: GhcMonad m => HscEnv -> ModSummary -> TcGblEnv -> m ModGuts
 208 deSugarModule hsc_env mod_summary tc_result = do
 209     ioMsgMaybe $ deSugar hsc_env (ms_location mod_summary) tc_result
 210
 211 -- | Make a 'ModIface' from the results of typechecking.  Used when
 212 -- not optimising, and the interface doesn't need to contain any
 213 -- unfoldings or other cross-module optimisation info.
 214 -- ToDo: the old interface is only needed to get the version numbers,
 215 -- we should use fingerprint versions instead.
 216 makeSimpleIface :: HscEnv -> Maybe ModIface -> TcGblEnv -> ModDetails
 217                 -> IO (ModIface,Bool)
 218 makeSimpleIface hsc_env maybe_old_iface tc_result details = do
 219   mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) details tc_result
 220
 221 -- | Make a 'ModDetails' from the results of typechecking.  Used when
 222 -- typechecking only, as opposed to full compilation.
 223 makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails
 224 makeSimpleDetails hsc_env tc_result = mkBootModDetailsTc hsc_env tc_result
 225
 226 -- deSugarModule :: HscEnv -> TcGblEnv -> IO Core
 227 \end{code}
 228
 229 %************************************************************************
 230 %*                                                                      *
 231                 The main compiler pipeline
 232 %*                                                                      *
 233 %************************************************************************
 234
 235                    --------------------------------
 236                         The compilation proper
 237                    --------------------------------
 238
 239
 240 It's the task of the compilation proper to compile Haskell, hs-boot and
 241 core files to either byte-code, hard-code (C, asm, Java, ect) or to
 242 nothing at all (the module is still parsed and type-checked. This
 243 feature is mostly used by IDE's and the likes).
 244 Compilation can happen in either 'one-shot', 'batch', 'nothing',
 245 or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch' mode
 246 targets hard-code, 'nothing' mode targets nothing and 'interactive' mode
 247 targets byte-code.
 248 The modes are kept separate because of their different types and meanings.
 249 In 'one-shot' mode, we're only compiling a single file and can therefore
 250 discard the new ModIface and ModDetails. This is also the reason it only
 251 targets hard-code; compiling to byte-code or nothing doesn't make sense
 252 when we discard the result.
 253 'Batch' mode is like 'one-shot' except that we keep the resulting ModIface
 254 and ModDetails. 'Batch' mode doesn't target byte-code since that require
 255 us to return the newly compiled byte-code.
 256 'Nothing' mode has exactly the same type as 'batch' mode but they're still
 257 kept separate. This is because compiling to nothing is fairly special: We
 258 don't output any interface files, we don't run the simplifier and we don't
 259 generate any code.
 260 'Interactive' mode is similar to 'batch' mode except that we return the
 261 compiled byte-code together with the ModIface and ModDetails.
 262
 263 Trying to compile a hs-boot file to byte-code will result in a run-time
 264 error. This is the only thing that isn't caught by the type-system.
 265
 266 \begin{code}
 267
 268 -- Status of a compilation to hard-code or nothing.
 269 data HscStatus
 270     = HscNoRecomp
 271     | HscRecomp  Bool -- Has stub files.
 272                       -- This is a hack. We can't compile C files here
 273                       -- since it's done in DriverPipeline. For now we
 274                       -- just return True if we want the caller to compile
 275                       -- them for us.
 276
 277 -- Status of a compilation to byte-code.
 278 data InteractiveStatus
 279     = InteractiveNoRecomp
 280     | InteractiveRecomp Bool     -- Same as HscStatus
 281                         CompiledByteCode
 282                         ModBreaks
 283
 284
 285 -- I want Control.Monad.State! --Lemmih 03/07/2006
 286 newtype Comp a = Comp {runComp :: CompState -> IORef Messages -> IO (a, CompState)}
 287
 288 instance Monad Comp where
 289     g >>= fn = Comp $ \s r -> runComp g s r >>= \(a,s') -> runComp (fn a) s' r
 290     return a = Comp $ \s _ -> return (a,s)
 291     fail = error
 292
 293 evalComp :: Comp a -> CompState -> IO (Messages, a)
 294 evalComp comp st = do r <- newIORef emptyMessages
 295                       (val,_st') <- runComp comp st r
 296                       msgs <- readIORef r
 297                       return (msgs, val)
 298
 299 logMsgs :: Messages -> Comp ()
 300 logMsgs (warns', errs') = Comp $ \s r -> do
 301                            (warns, errs) <- readIORef r
 302                            writeIORef r $! ( warns' `unionBags` warns
 303                                            , errs' `unionBags` errs )
 304                            return ((), s)
 305
 306 data CompState
 307     = CompState
 308     { compHscEnv     :: HscEnv
 309     , compModSummary :: ModSummary
 310     , compOldIface   :: Maybe ModIface
 311     }
 312
 313 get :: Comp CompState
 314 get = Comp $ \s _ -> return (s,s)
 315
 316 modify :: (CompState -> CompState) -> Comp ()
 317 modify f = Comp $ \s _ -> return ((), f s)
 318
 319 gets :: (CompState -> a) -> Comp a
 320 gets getter = do st <- get
 321                  return (getter st)
 322
 323 instance MonadIO Comp where
 324   liftIO ioA = Comp $ \s _ -> do a <- ioA; return (a,s)
 325
 326 type NoRecomp result = ModIface -> Comp result
 327
 328 -- FIXME: The old interface and module index are only using in 'batch' and
 329 --        'interactive' mode. They should be removed from 'oneshot' mode.
 330 type Compiler result =  GhcMonad m =>
 331                         HscEnv
 332                      -> ModSummary
 333                      -> Bool                -- True <=> source unchanged
 334                      -> Maybe ModIface      -- Old interface, if available
 335                      -> Maybe (Int,Int)     -- Just (i,n) <=> module i of n (for msgs)
 336                      -> m result
 337
 338 --------------------------------------------------------------
 339 -- Compilers
 340 --------------------------------------------------------------
 341
 342 -- Compile Haskell, boot and extCore in OneShot mode.
 343 hscCompileOneShot :: Compiler HscStatus
 344 hscCompileOneShot hsc_env mod_summary src_changed mb_old_iface mb_i_of_n
 345   = do
 346      -- One-shot mode needs a knot-tying mutable variable for interface files.
 347      -- See TcRnTypes.TcGblEnv.tcg_type_env_var.
 348     type_env_var <- liftIO $ newIORef emptyNameEnv
 349     let
 350        mod = ms_mod mod_summary
 351        hsc_env' = hsc_env{ hsc_type_env_var = Just (mod, type_env_var) }
 352     ---
 353     hscCompilerOneShot' hsc_env' mod_summary src_changed mb_old_iface mb_i_of_n
 354
 355 hscCompilerOneShot' :: Compiler HscStatus
 356 hscCompilerOneShot'
 357    = hscCompiler norecompOneShot oneShotMsg (genComp backend boot_backend)
 358    where
 359      backend inp  = hscSimplify inp >>= hscNormalIface >>= hscWriteIface >>= hscOneShot
 360      boot_backend inp = hscSimpleIface inp >>= hscWriteIface >> return (Just (HscRecomp False))
 361
 362 -- Compile Haskell, boot and extCore in batch mode.
 363 hscCompileBatch :: Compiler (HscStatus, ModIface, ModDetails)
 364 hscCompileBatch
 365    = hscCompiler norecompBatch batchMsg (genComp backend boot_backend)
 366    where
 367      backend inp  = hscSimplify inp >>= hscNormalIface >>= hscWriteIface >>= hscBatch
 368      boot_backend inp = hscSimpleIface inp >>= hscWriteIface >>= hscNothing
 369
 370 -- Compile Haskell, extCore to bytecode.
 371 hscCompileInteractive :: Compiler (InteractiveStatus, ModIface, ModDetails)
 372 hscCompileInteractive
 373    = hscCompiler norecompInteractive batchMsg (genComp backend boot_backend)
 374    where
 375      backend inp = hscSimplify inp >>= hscNormalIface >>= hscIgnoreIface >>= hscInteractive
 376      boot_backend _ = panic "hscCompileInteractive: HsBootFile"
 377
 378 -- Type-check Haskell and .hs-boot only (no external core)
 379 hscCompileNothing :: Compiler (HscStatus, ModIface, ModDetails)
 380 hscCompileNothing
 381    = hscCompiler norecompBatch batchMsg comp
 382    where
 383      backend tc = hscSimpleIface tc >>= hscIgnoreIface >>= hscNothing
 384
 385      comp = do   -- genComp doesn't fit here, because we want to omit
 386                  -- desugaring and for the backend to take a TcGblEnv
 387         mod_summary <- gets compModSummary
 388         case ms_hsc_src mod_summary of
 389            ExtCoreFile -> panic "hscCompileNothing: cannot do external core"
 390            _other -> do
 391                 mb_tc <- hscFileFrontEnd
 392                 case mb_tc of
 393                   Nothing -> return Nothing
 394                   Just tc_result -> backend tc_result
 395
 396 hscCompiler
 397         :: NoRecomp result                       -- No recomp necessary
 398         -> (Maybe (Int,Int) -> Bool -> Comp ())  -- Message callback
 399         -> Comp (Maybe result)
 400         -> Compiler result
 401 hscCompiler norecomp messenger recomp hsc_env mod_summary
 402             source_unchanged mbOldIface mbModIndex
 403    = ioMsgMaybe $
 404       flip evalComp (CompState hsc_env mod_summary mbOldIface) $
 405       do (recomp_reqd, mbCheckedIface)
 406              <- {-# SCC "checkOldIface" #-}
 407                 liftIO $ checkOldIface hsc_env mod_summary
 408                               source_unchanged mbOldIface
 409          -- save the interface that comes back from checkOldIface.
 410          -- In one-shot mode we don't have the old iface until this
 411          -- point, when checkOldIface reads it from the disk.
 412          modify (\s -> s{ compOldIface = mbCheckedIface })
 413          case mbCheckedIface of
 414            Just iface | not recomp_reqd
 415                -> do messenger mbModIndex False
 416                      result <- norecomp iface
 417                      return (Just result)
 418            _otherwise
 419                -> do messenger mbModIndex True
 420                      recomp
 421
 422 -- the usual way to build the Comp (Maybe result) to pass to hscCompiler
 423 genComp :: (ModGuts  -> Comp (Maybe a))
 424         -> (TcGblEnv -> Comp (Maybe a))
 425         -> Comp (Maybe a)
 426 genComp backend boot_backend = do
 427     mod_summary <- gets compModSummary
 428     case ms_hsc_src mod_summary of
 429        ExtCoreFile -> do
 430           panic "GHC does not currently support reading External Core files"
 431        _not_core -> do
 432           mb_tc <- hscFileFrontEnd
 433           case mb_tc of
 434             Nothing -> return Nothing
 435             Just tc_result ->
 436               case ms_hsc_src mod_summary of
 437                 HsBootFile -> boot_backend tc_result
 438                 _other     -> do
 439                   mb_guts <- hscDesugar tc_result
 440                   case mb_guts of
 441                     Nothing -> return Nothing
 442                     Just guts -> backend guts
 443
 444 --------------------------------------------------------------
 445 -- NoRecomp handlers
 446 --------------------------------------------------------------
 447
 448 norecompOneShot :: NoRecomp HscStatus
 449 norecompOneShot _old_iface
 450     = do hsc_env <- gets compHscEnv
 451          liftIO $ do
 452          dumpIfaceStats hsc_env
 453          return HscNoRecomp
 454
 455 norecompBatch :: NoRecomp (HscStatus, ModIface, ModDetails)
 456 norecompBatch = norecompWorker HscNoRecomp False
 457
 458 norecompInteractive :: NoRecomp (InteractiveStatus, ModIface, ModDetails)
 459 norecompInteractive = norecompWorker InteractiveNoRecomp True
 460
 461 norecompWorker :: a -> Bool -> NoRecomp (a, ModIface, ModDetails)
 462 norecompWorker a _isInterp old_iface
 463     = do hsc_env <- gets compHscEnv
 464          liftIO $ do
 465          new_details <- {-# SCC "tcRnIface" #-}
 466                         initIfaceCheck hsc_env $
 467                         typecheckIface old_iface
 468          dumpIfaceStats hsc_env
 469          return (a, old_iface, new_details)
 470
 471 --------------------------------------------------------------
 472 -- Progress displayers.
 473 --------------------------------------------------------------
 474
 475 oneShotMsg :: Maybe (Int,Int) -> Bool -> Comp ()
 476 oneShotMsg _mb_mod_index recomp
 477     = do hsc_env <- gets compHscEnv
 478          liftIO $ do
 479          if recomp
 480             then return ()
 481             else compilationProgressMsg (hsc_dflags hsc_env) $
 482                      "compilation IS NOT required"
 483
 484 batchMsg :: Maybe (Int,Int) -> Bool -> Comp ()
 485 batchMsg mb_mod_index recomp
 486     = do hsc_env <- gets compHscEnv
 487          mod_summary <- gets compModSummary
 488          let showMsg msg = compilationProgressMsg (hsc_dflags hsc_env) $
 489                            (showModuleIndex mb_mod_index ++
 490                             msg ++ showModMsg (hscTarget (hsc_dflags hsc_env)) recomp mod_summary)
 491          liftIO $ do
 492          if recomp
 493             then showMsg "Compiling "
 494             else if verbosity (hsc_dflags hsc_env) >= 2
 495                     then showMsg "Skipping  "
 496                     else return ()
 497
 498 --------------------------------------------------------------
 499 -- FrontEnds
 500 --------------------------------------------------------------
 501 hscFileFrontEnd :: Comp (Maybe TcGblEnv)
 502 hscFileFrontEnd =
 503     do hsc_env <- gets compHscEnv
 504        mod_summary <- gets compModSummary
 505
 506              -------------------
 507              -- PARSE
 508              -------------------
 509        let dflags = hsc_dflags hsc_env
 510            hspp_file = ms_hspp_file mod_summary
 511            hspp_buf  = ms_hspp_buf  mod_summary
 512        (ms@(warns,_), maybe_parsed)
 513            <- liftIO $ myParseModule dflags hspp_file hspp_buf
 514        case maybe_parsed of
 515          Nothing
 516              -> do logMsgs ms
 517                    return Nothing
 518          Just rdr_module
 519              -------------------
 520              -- RENAME and TYPECHECK
 521              -------------------
 522              -> do logMsgs (warns, emptyBag)
 523                    (tc_msgs, maybe_tc_result)
 524                        <- {-# SCC "Typecheck-Rename" #-}
 525                           liftIO $ tcRnModule hsc_env (ms_hsc_src mod_summary)
 526                                               False rdr_module
 527                    logMsgs tc_msgs
 528                    return maybe_tc_result
 529
 530 --------------------------------------------------------------
 531 -- Desugaring
 532 --------------------------------------------------------------
 533
 534 hscDesugar :: TcGblEnv -> Comp (Maybe ModGuts)
 535 hscDesugar tc_result
 536   = do mod_summary <- gets compModSummary
 537        hsc_env <- gets compHscEnv
 538
 539           -------------------
 540           -- DESUGAR
 541           -------------------
 542        (msgs, ds_result)
 543            <- {-# SCC "DeSugar" #-}
 544               liftIO $ deSugar hsc_env (ms_location mod_summary) tc_result
 545        logMsgs msgs
 546        return ds_result
 547
 548 --------------------------------------------------------------
 549 -- Simplifiers
 550 --------------------------------------------------------------
 551
 552 hscSimplify :: ModGuts -> Comp ModGuts
 553 hscSimplify ds_result
 554   = do hsc_env <- gets compHscEnv
 555        liftIO $ do
 556            -------------------
 557            -- SIMPLIFY
 558            -------------------
 559        simpl_result <- {-# SCC "Core2Core" #-}
 560                        core2core hsc_env ds_result
 561        return simpl_result
 562
 563 --------------------------------------------------------------
 564 -- Interface generators
 565 --------------------------------------------------------------
 566
 567 -- HACK: we return ModGuts even though we know it's not gonna be used.
 568 --       We do this because the type signature needs to be identical
 569 --       in structure to the type of 'hscNormalIface'.
 570 hscSimpleIface :: TcGblEnv -> Comp (ModIface, Bool, ModDetails, TcGblEnv)
 571 hscSimpleIface tc_result
 572   = do hsc_env <- gets compHscEnv
 573        maybe_old_iface <- gets compOldIface
 574        liftIO $ do
 575        details <- mkBootModDetailsTc hsc_env tc_result
 576        (new_iface, no_change)
 577            <- {-# SCC "MkFinalIface" #-}
 578               mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) details tc_result
 579        -- And the answer is ...
 580        dumpIfaceStats hsc_env
 581        return (new_iface, no_change, details, tc_result)
 582
 583 hscNormalIface :: ModGuts -> Comp (ModIface, Bool, ModDetails, CgGuts)
 584 hscNormalIface simpl_result
 585   = do hsc_env <- gets compHscEnv
 586        _mod_summary <- gets compModSummary
 587        maybe_old_iface <- gets compOldIface
 588        liftIO $ do
 589             -------------------
 590             -- TIDY
 591             -------------------
 592        (cg_guts, details) <- {-# SCC "CoreTidy" #-}
 593                              tidyProgram hsc_env simpl_result
 594
 595             -------------------
 596             -- BUILD THE NEW ModIface and ModDetails
 597             --  and emit external core if necessary
 598             -- This has to happen *after* code gen so that the back-end
 599             -- info has been set.  Not yet clear if it matters waiting
 600             -- until after code output
 601        (new_iface, no_change)
 602                 <- {-# SCC "MkFinalIface" #-}
 603                    mkIface hsc_env (fmap mi_iface_hash maybe_old_iface)
 604                          details simpl_result
 605         -- Emit external core
 606        -- This should definitely be here and not after CorePrep,
 607        -- because CorePrep produces unqualified constructor wrapper declarations,
 608        -- so its output isn't valid External Core (without some preprocessing).
 609        emitExternalCore (hsc_dflags hsc_env) cg_guts
 610        dumpIfaceStats hsc_env
 611
 612             -------------------
 613             -- Return the prepared code.
 614        return (new_iface, no_change, details, cg_guts)
 615
 616 --------------------------------------------------------------
 617 -- BackEnd combinators
 618 --------------------------------------------------------------
 619
 620 hscWriteIface :: (ModIface, Bool, ModDetails, a) -> Comp (ModIface, ModDetails, a)
 621 hscWriteIface (iface, no_change, details, a)
 622     = do mod_summary <- gets compModSummary
 623          hsc_env <- gets compHscEnv
 624          let dflags = hsc_dflags hsc_env
 625          liftIO $ do
 626          unless no_change
 627            $ writeIfaceFile dflags (ms_location mod_summary) iface
 628          return (iface, details, a)
 629
 630 hscIgnoreIface :: (ModIface, Bool, ModDetails, a) -> Comp (ModIface, ModDetails, a)
 631 hscIgnoreIface (iface, _no_change, details, a)
 632     = return (iface, details, a)
 633
 634 -- Don't output any code.
 635 hscNothing :: (ModIface, ModDetails, a) -> Comp (Maybe (HscStatus, ModIface, ModDetails))
 636 hscNothing (iface, details, _)
 637     = return (Just (HscRecomp False, iface, details))
 638
 639 -- Generate code and return both the new ModIface and the ModDetails.
 640 hscBatch :: (ModIface, ModDetails, CgGuts) -> Comp (Maybe (HscStatus, ModIface, ModDetails))
 641 hscBatch (iface, details, cgguts)
 642     = do hasStub <- hscCompile cgguts
 643          return (Just (HscRecomp hasStub, iface, details))
 644
 645 -- Here we don't need the ModIface and ModDetails anymore.
 646 hscOneShot :: (ModIface, ModDetails, CgGuts) -> Comp (Maybe HscStatus)
 647 hscOneShot (_, _, cgguts)
 648     = do hasStub <- hscCompile cgguts
 649          return (Just (HscRecomp hasStub))
 650
 651 -- Compile to hard-code.
 652 hscCompile :: CgGuts -> Comp Bool
 653 hscCompile cgguts
 654     = do hsc_env <- gets compHscEnv
 655          mod_summary <- gets compModSummary
 656          liftIO $ do
 657          let CgGuts{ -- This is the last use of the ModGuts in a compilation.
 658                      -- From now on, we just use the bits we need.
 659                      cg_module   = this_mod,
 660                      cg_binds    = core_binds,
 661                      cg_tycons   = tycons,
 662                      cg_dir_imps = dir_imps,
 663                      cg_foreign  = foreign_stubs,
 664                      cg_dep_pkgs = dependencies,
 665                      cg_hpc_info = hpc_info } = cgguts
 666              dflags = hsc_dflags hsc_env
 667              location = ms_location mod_summary
 668              data_tycons = filter isDataTyCon tycons
 669              -- cg_tycons includes newtypes, for the benefit of External Core,
 670              -- but we don't generate any code for newtypes
 671
 672          -------------------
 673          -- PREPARE FOR CODE GENERATION
 674          -- Do saturation and convert to A-normal form
 675          prepd_binds <- {-# SCC "CorePrep" #-}
 676                         corePrepPgm dflags core_binds data_tycons ;
 677          -----------------  Convert to STG ------------------
 678          (stg_binds, cost_centre_info)
 679              <- {-# SCC "CoreToStg" #-}
 680                 myCoreToStg dflags this_mod prepd_binds
 681          ------------------  Code generation ------------------
 682          cmms <- {-# SCC "CodeGen" #-}
 683                       codeGen dflags this_mod data_tycons
 684                               dir_imps cost_centre_info
 685                               stg_binds hpc_info
 686          --- Optionally run experimental Cmm transformations ---
 687          cmms <- optionallyConvertAndOrCPS hsc_env cmms
 688                  -- unless certain dflags are on, the identity function
 689          ------------------  Code output -----------------------
 690          rawcmms <- cmmToRawCmm cmms
 691          (_stub_h_exists, stub_c_exists)
 692              <- codeOutput dflags this_mod location foreign_stubs
 693                 dependencies rawcmms
 694          return stub_c_exists
 695
 696 hscInteractive :: (ModIface, ModDetails, CgGuts)
 697                -> Comp (Maybe (InteractiveStatus, ModIface, ModDetails))
 698 #ifdef GHCI
 699 hscInteractive (iface, details, cgguts)
 700     = do hsc_env <- gets compHscEnv
 701          mod_summary <- gets compModSummary
 702          liftIO $ do
 703          let CgGuts{ -- This is the last use of the ModGuts in a compilation.
 704                      -- From now on, we just use the bits we need.
 705                      cg_module   = this_mod,
 706                      cg_binds    = core_binds,
 707                      cg_tycons   = tycons,
 708                      cg_foreign  = foreign_stubs,
 709                      cg_modBreaks = mod_breaks } = cgguts
 710              dflags = hsc_dflags hsc_env
 711              location = ms_location mod_summary
 712              data_tycons = filter isDataTyCon tycons
 713              -- cg_tycons includes newtypes, for the benefit of External Core,
 714              -- but we don't generate any code for newtypes
 715
 716          -------------------
 717          -- PREPARE FOR CODE GENERATION
 718          -- Do saturation and convert to A-normal form
 719          prepd_binds <- {-# SCC "CorePrep" #-}
 720                         corePrepPgm dflags core_binds data_tycons ;
 721          -----------------  Generate byte code ------------------
 722          comp_bc <- byteCodeGen dflags prepd_binds data_tycons mod_breaks
 723          ------------------ Create f-x-dynamic C-side stuff ---
 724          (_istub_h_exists, istub_c_exists)
 725              <- outputForeignStubs dflags this_mod location foreign_stubs
 726          return (Just (InteractiveRecomp istub_c_exists comp_bc mod_breaks, iface, details))
 727 #else
 728 hscInteractive _ = panic "GHC not compiled with interpreter"
 729 #endif
 730
 731 ------------------------------
 732
 733 hscCmmFile :: GhcMonad m => HscEnv -> FilePath -> m ()
 734 hscCmmFile hsc_env filename = do
 735     dflags <- return $ hsc_dflags hsc_env
 736     cmm <- ioMsgMaybe $
 737              parseCmmFile dflags filename
 738     cmms <- liftIO $ optionallyConvertAndOrCPS hsc_env [cmm]
 739     rawCmms <- liftIO $ cmmToRawCmm cmms
 740     liftIO $ codeOutput dflags no_mod no_loc NoStubs [] rawCmms
 741     return ()
 742   where
 743         no_mod = panic "hscCmmFile: no_mod"
 744         no_loc = ModLocation{ ml_hs_file  = Just filename,
 745                               ml_hi_file  = panic "hscCmmFile: no hi file",
 746                               ml_obj_file = panic "hscCmmFile: no obj file" }
 747
 748 optionallyConvertAndOrCPS :: HscEnv -> [Cmm] -> IO [Cmm]
 749 optionallyConvertAndOrCPS hsc_env cmms =
 750     do let dflags = hsc_dflags hsc_env
 751         --------  Optionally convert to and from zipper ------
 752        cmms <- if dopt Opt_ConvertToZipCfgAndBack dflags
 753                then mapM (testCmmConversion hsc_env) cmms
 754                else return cmms
 755          ---------  Optionally convert to CPS (MDA) -----------
 756        cmms <- if not (dopt Opt_ConvertToZipCfgAndBack dflags) &&
 757                   dopt Opt_RunCPSZ dflags
 758                then cmmCPS dflags cmms
 759                else return cmms
 760        return cmms
 761
 762
 763 testCmmConversion :: HscEnv -> Cmm -> IO Cmm
 764 testCmmConversion hsc_env cmm =
 765     do let dflags = hsc_dflags hsc_env
 766        showPass dflags "CmmToCmm"
 767        dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (ppr cmm)
 768        --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm
 769        us <- mkSplitUniqSupply 'C'
 770        let cfopts = runTx $ runCmmOpts cmmCfgOptsZ
 771        let cvtm = do g <- cmmToZgraph cmm
 772                      return $ cfopts g
 773        let zgraph = initUs_ us cvtm
 774        cps_zgraph <- protoCmmCPSZ hsc_env zgraph
 775        let chosen_graph = if dopt Opt_RunCPSZ dflags then cps_zgraph else zgraph
 776        dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (ppr chosen_graph)
 777        showPass dflags "Convert from Z back to Cmm"
 778        let cvt = cmmOfZgraph $ cfopts $ chosen_graph
 779        dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (ppr cvt)
 780        return cvt
 781        -- return cmm -- don't use the conversion
 782
 783 myParseModule :: DynFlags -> FilePath -> Maybe StringBuffer
 784               -> IO (Messages, Maybe (Located (HsModule RdrName)))
 785 myParseModule dflags src_filename maybe_src_buf =
 786    --------------------------  Parser  ----------------
 787    showPass dflags "Parser" >>
 788    {-# SCC "Parser" #-} do
 789
 790         -- sometimes we already have the buffer in memory, perhaps
 791         -- because we needed to parse the imports out of it, or get the
 792         -- module name.
 793      buf <- case maybe_src_buf of
 794               Just b  -> return b
 795               Nothing -> hGetStringBuffer src_filename
 796
 797      let loc  = mkSrcLoc (mkFastString src_filename) 1 0
 798
 799      case unP parseModule (mkPState buf loc dflags) of
 800        PFailed span err ->
 801            return ((emptyBag, unitBag (mkPlainErrMsg span err)), Nothing);
 802
 803        POk pst rdr_module -> do
 804           let ms = getMessages pst
 805           if errorsFound dflags ms then
 806             return (ms, Nothing)
 807            else do
 808             dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
 809             dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"
 810                                  (ppSourceStats False rdr_module) ;
 811             return (ms, Just rdr_module)
 812             -- ToDo: free the string buffer later.
 813
 814 myCoreToStg :: DynFlags -> Module -> [CoreBind]
 815             -> IO ( [(StgBinding,[(Id,[Id])])]  -- output program
 816                   , CollectedCCs) -- cost centre info (declared and used)
 817
 818 myCoreToStg dflags this_mod prepd_binds
 819  = do
 820       stg_binds <- {-# SCC "Core2Stg" #-}
 821              coreToStg (thisPackage dflags) prepd_binds
 822
 823       (stg_binds2, cost_centre_info) <- {-# SCC "Stg2Stg" #-}
 824              stg2stg dflags this_mod stg_binds
 825
 826       return (stg_binds2, cost_centre_info)
 827 \end{code}
 828
 829
 830 %************************************************************************
 831 %*                                                                      *
 832 \subsection{Compiling a do-statement}
 833 %*                                                                      *
 834 %************************************************************************
 835
 836 When the UnlinkedBCOExpr is linked you get an HValue of type
 837         IO [HValue]
 838 When you run it you get a list of HValues that should be
 839 the same length as the list of names; add them to the ClosureEnv.
 840
 841 A naked expression returns a singleton Name [it].
 842
 843         What you type                   The IO [HValue] that hscStmt returns
 844         -------------                   ------------------------------------
 845         let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
 846                                         bindings: [x,y,...]
 847
 848         pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
 849                                         bindings: [x,y,...]
 850
 851         expr (of IO type)       ==>     expr >>= \ v -> return [v]
 852           [NB: result not printed]      bindings: [it]
 853
 854
 855         expr (of non-IO type,
 856           result showable)      ==>     let v = expr in print v >> return [v]
 857                                         bindings: [it]
 858
 859         expr (of non-IO type,
 860           result not showable)  ==>     error
 861
 862 \begin{code}
 863 #ifdef GHCI
 864 hscStmt         -- Compile a stmt all the way to an HValue, but don't run it
 865   :: GhcMonad m =>
 866      HscEnv
 867   -> String                     -- The statement
 868   -> m (Maybe ([Id], HValue))
 869      -- ^ 'Nothing' <==> empty statement (or comment only), but no parse error
 870 hscStmt hsc_env stmt = do
 871     maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt
 872     case maybe_stmt of
 873       Nothing -> return Nothing
 874       Just parsed_stmt -> do  -- The real stuff
 875
 876              -- Rename and typecheck it
 877         let icontext = hsc_IC hsc_env
 878         (ids, tc_expr) <- ioMsgMaybe $ tcRnStmt hsc_env icontext parsed_stmt
 879             -- Desugar it
 880         let rdr_env  = ic_rn_gbl_env icontext
 881             type_env = mkTypeEnv (map AnId (ic_tmp_ids icontext))
 882         ds_expr <- ioMsgMaybe $
 883                      deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr
 884
 885         -- Then desugar, code gen, and link it
 886         let src_span = srcLocSpan interactiveSrcLoc
 887         hval <- liftIO $ compileExpr hsc_env src_span ds_expr
 888
 889         return $ Just (ids, hval)
 890
 891
 892 hscTcExpr       -- Typecheck an expression (but don't run it)
 893   :: GhcMonad m =>
 894      HscEnv
 895   -> String                     -- The expression
 896   -> m Type
 897
 898 hscTcExpr hsc_env expr = do
 899     maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr
 900     let icontext = hsc_IC hsc_env
 901     case maybe_stmt of
 902       Just (L _ (ExprStmt expr _ _)) -> do
 903           ty <- ioMsgMaybe $ tcRnExpr hsc_env icontext expr
 904           return ty
 905       _ -> do throw $ mkSrcErr $ unitBag $ mkPlainErrMsg
 906                         noSrcSpan
 907                         (text "not an expression:" <+> quotes (text expr))
 908
 909 -- | Find the kind of a type
 910 hscKcType
 911   :: GhcMonad m =>
 912      HscEnv
 913   -> String                     -- ^ The type
 914   -> m Kind
 915
 916 hscKcType hsc_env str = do
 917     ty <- hscParseType (hsc_dflags hsc_env) str
 918     let icontext = hsc_IC hsc_env
 919     ioMsgMaybe $ tcRnType hsc_env icontext ty
 920
 921 #endif
 922 \end{code}
 923
 924 \begin{code}
 925 #ifdef GHCI
 926 hscParseStmt :: GhcMonad m => DynFlags -> String -> m (Maybe (LStmt RdrName))
 927 hscParseStmt = hscParseThing parseStmt
 928
 929 hscParseType :: GhcMonad m => DynFlags -> String -> m (LHsType RdrName)
 930 hscParseType = hscParseThing parseType
 931 #endif
 932
 933 hscParseIdentifier :: GhcMonad m => DynFlags -> String -> m (Located RdrName)
 934 hscParseIdentifier = hscParseThing parseIdentifier
 935
 936 hscParseThing :: (Outputable thing, GhcMonad m)
 937               => Lexer.P thing
 938               -> DynFlags -> String
 939               -> m thing
 940         -- Nothing => Parse error (message already printed)
 941         -- Just x  => success
 942 hscParseThing parser dflags str
 943  = (liftIO $ showPass dflags "Parser") >>
 944       {-# SCC "Parser" #-} do
 945
 946       buf <- liftIO $ stringToStringBuffer str
 947
 948       let loc  = mkSrcLoc (fsLit "<interactive>") 1 0
 949
 950       case unP parser (mkPState buf loc dflags) of
 951
 952         PFailed span err -> do
 953           let msg = mkPlainErrMsg span err
 954           throw (mkSrcErr (unitBag msg))
 955
 956         POk pst thing -> do
 957
 958           let ms@(warns, errs) = getMessages pst
 959           logWarnings warns
 960           when (errorsFound dflags ms) $ -- handle -Werror
 961             throw (mkSrcErr errs)
 962
 963           --ToDo: can't free the string buffer until we've finished this
 964           -- compilation sweep and all the identifiers have gone away.
 965           liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing)
 966           return thing
 967 \end{code}
 968
 969 %************************************************************************
 970 %*                                                                      *
 971         Desugar, simplify, convert to bytecode, and link an expression
 972 %*                                                                      *
 973 %************************************************************************
 974
 975 \begin{code}
 976 #ifdef GHCI
 977 compileExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
 978
 979 compileExpr hsc_env srcspan ds_expr
 980   = do  { let { dflags  = hsc_dflags hsc_env ;
 981                 lint_on = dopt Opt_DoCoreLinting dflags }
 982
 983                 -- Simplify it
 984         ; simpl_expr <- simplifyExpr dflags ds_expr
 985
 986                 -- Tidy it (temporary, until coreSat does cloning)
 987         ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
 988
 989                 -- Prepare for codegen
 990         ; prepd_expr <- corePrepExpr dflags tidy_expr
 991
 992                 -- Lint if necessary
 993                 -- ToDo: improve SrcLoc
 994         ; if lint_on then
 995                 let ictxt = hsc_IC hsc_env
 996                     tyvars = varSetElems (ic_tyvars ictxt)
 997                 in
 998                 case lintUnfolding noSrcLoc tyvars prepd_expr of
 999                    Just err -> pprPanic "compileExpr" err
1000                    Nothing  -> return ()
1001           else
1002                 return ()
1003
1004                 -- Convert to BCOs
1005         ; bcos <- coreExprToBCOs dflags prepd_expr
1006
1007                 -- link it
1008         ; hval <- linkExpr hsc_env srcspan bcos
1009
1010         ; return hval
1011      }
1012 #endif
1013 \end{code}
1014
1015
1016 %************************************************************************
1017 %*                                                                      *
1018         Statistics on reading interfaces
1019 %*                                                                      *
1020 %************************************************************************
1021
1022 \begin{code}
1023 dumpIfaceStats :: HscEnv -> IO ()
1024 dumpIfaceStats hsc_env
1025   = do  { eps <- readIORef (hsc_EPS hsc_env)
1026         ; dumpIfSet (dump_if_trace || dump_rn_stats)
1027                     "Interface statistics"
1028                     (ifaceStats eps) }
1029   where
1030     dflags = hsc_dflags hsc_env
1031     dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
1032     dump_if_trace = dopt Opt_D_dump_if_trace dflags
1033 \end{code}
1034
1035 %************************************************************************
1036 %*                                                                      *
1037         Progress Messages: Module i of n
1038 %*                                                                      *
1039 %************************************************************************
1040
1041 \begin{code}
1042 showModuleIndex :: Maybe (Int, Int) -> String
1043 showModuleIndex Nothing = ""
1044 showModuleIndex (Just (i,n)) = "[" ++ padded ++ " of " ++ n_str ++ "] "
1045     where
1046         n_str = show n
1047         i_str = show i
1048         padded = replicate (length n_str - length i_str) ' ' ++ i_str
1049 \end{code}