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