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