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