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