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) (availsToNameSet (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          hsc_env <- gets compHscEnv
 545          let dflags = hsc_dflags hsc_env
 546          liftIO $ do
 547          unless no_change
 548            $ writeIfaceFile dflags (ms_location mod_summary) iface
 549          return (iface, details, a)
 550
 551 hscIgnoreIface :: (ModIface, Bool, ModDetails, a) -> Comp (ModIface, ModDetails, a)
 552 hscIgnoreIface (iface, no_change, details, a)
 553     = return (iface, details, a)
 554
 555 -- Don't output any code.
 556 hscNothing :: (ModIface, ModDetails, a) -> Comp (HscStatus, ModIface, ModDetails)
 557 hscNothing (iface, details, a)
 558     = return (HscRecomp False, iface, details)
 559
 560 -- Generate code and return both the new ModIface and the ModDetails.
 561 hscBatch :: (ModIface, ModDetails, CgGuts) -> Comp (HscStatus, ModIface, ModDetails)
 562 hscBatch (iface, details, cgguts)
 563     = do hasStub <- hscCompile cgguts
 564          return (HscRecomp hasStub, iface, details)
 565
 566 -- Here we don't need the ModIface and ModDetails anymore.
 567 hscOneShot :: (ModIface, ModDetails, CgGuts) -> Comp HscStatus
 568 hscOneShot (_, _, cgguts)
 569     = do hasStub <- hscCompile cgguts
 570          return (HscRecomp hasStub)
 571
 572 -- Compile to hard-code.
 573 hscCompile :: CgGuts -> Comp Bool
 574 hscCompile cgguts
 575     = do hsc_env <- gets compHscEnv
 576          mod_summary <- gets compModSummary
 577          liftIO $ do
 578          let CgGuts{ -- This is the last use of the ModGuts in a compilation.
 579                      -- From now on, we just use the bits we need.
 580                      cg_module   = this_mod,
 581                      cg_binds    = core_binds,
 582                      cg_tycons   = tycons,
 583                      cg_dir_imps = dir_imps,
 584                      cg_foreign  = foreign_stubs,
 585                      cg_dep_pkgs = dependencies } = cgguts
 586              dflags = hsc_dflags hsc_env
 587              location = ms_location mod_summary
 588              data_tycons = filter isDataTyCon tycons
 589              -- cg_tycons includes newtypes, for the benefit of External Core,
 590              -- but we don't generate any code for newtypes
 591
 592          -------------------
 593          -- PREPARE FOR CODE GENERATION
 594          -- Do saturation and convert to A-normal form
 595          prepd_binds <- {-# SCC "CorePrep" #-}
 596                         corePrepPgm dflags core_binds data_tycons ;
 597          -----------------  Convert to STG ------------------
 598          (stg_binds, cost_centre_info)
 599              <- {-# SCC "CoreToStg" #-}
 600                 myCoreToStg dflags this_mod prepd_binds
 601          ------------------  Code generation ------------------
 602          abstractC <- {-# SCC "CodeGen" #-}
 603                       codeGen dflags this_mod data_tycons
 604                               foreign_stubs dir_imps cost_centre_info
 605                               stg_binds
 606          ------------------  Code output -----------------------
 607          (stub_h_exists,stub_c_exists)
 608              <- codeOutput dflags this_mod location foreign_stubs
 609                 dependencies abstractC
 610          return stub_c_exists
 611
 612 hscConst :: b -> a -> Comp b
 613 hscConst b a = return b
 614
 615 hscInteractive :: (ModIface, ModDetails, CgGuts)
 616                -> Comp (InteractiveStatus, ModIface, ModDetails)
 617 hscInteractive (iface, details, cgguts)
 618 #ifdef GHCI
 619     = do hsc_env <- gets compHscEnv
 620          mod_summary <- gets compModSummary
 621          liftIO $ do
 622          let CgGuts{ -- This is the last use of the ModGuts in a compilation.
 623                      -- From now on, we just use the bits we need.
 624                      cg_module   = this_mod,
 625                      cg_binds    = core_binds,
 626                      cg_tycons   = tycons,
 627                      cg_foreign  = foreign_stubs } = cgguts
 628              dflags = hsc_dflags hsc_env
 629              location = ms_location mod_summary
 630              data_tycons = filter isDataTyCon tycons
 631              -- cg_tycons includes newtypes, for the benefit of External Core,
 632              -- but we don't generate any code for newtypes
 633
 634          -------------------
 635          -- PREPARE FOR CODE GENERATION
 636          -- Do saturation and convert to A-normal form
 637          prepd_binds <- {-# SCC "CorePrep" #-}
 638                         corePrepPgm dflags core_binds data_tycons ;
 639          -----------------  Generate byte code ------------------
 640          comp_bc <- byteCodeGen dflags prepd_binds data_tycons
 641          ------------------ Create f-x-dynamic C-side stuff ---
 642          (istub_h_exists, istub_c_exists)
 643              <- outputForeignStubs dflags this_mod location foreign_stubs
 644          return (InteractiveRecomp istub_c_exists comp_bc, iface, details)
 645 #else
 646     = panic "GHC not compiled with interpreter"
 647 #endif
 648
 649 ------------------------------
 650
 651 hscFileCheck :: HscEnv -> ModSummary -> IO (Maybe HscChecked)
 652 hscFileCheck hsc_env mod_summary = do {
 653             -------------------
 654             -- PARSE
 655             -------------------
 656         ; let dflags    = hsc_dflags hsc_env
 657               hspp_file = ms_hspp_file mod_summary
 658               hspp_buf  = ms_hspp_buf  mod_summary
 659
 660         ; maybe_parsed <- myParseModule dflags hspp_file hspp_buf
 661
 662         ; case maybe_parsed of {
 663              Left err -> do { printBagOfErrors dflags (unitBag err)
 664                             ; return Nothing } ;
 665              Right rdr_module -> do {
 666
 667             -------------------
 668             -- RENAME and TYPECHECK
 669             -------------------
 670           (tc_msgs, maybe_tc_result)
 671                 <- _scc_ "Typecheck-Rename"
 672                    tcRnModule hsc_env (ms_hsc_src mod_summary)
 673                         True{-save renamed syntax-}
 674                         rdr_module
 675
 676         ; printErrorsAndWarnings dflags tc_msgs
 677         ; case maybe_tc_result of {
 678              Nothing -> return (Just (HscChecked rdr_module Nothing Nothing));
 679              Just tc_result -> do
 680                 let type_env = tcg_type_env tc_result
 681                     md = ModDetails {
 682                                 md_types     = type_env,
 683                                 md_exports   = tcg_exports   tc_result,
 684                                 md_insts     = tcg_insts     tc_result,
 685                                 md_fam_insts = tcg_fam_insts tc_result,
 686                                 md_rules     = [panic "no rules"] }
 687                                    -- Rules are CoreRules, not the
 688                                    -- RuleDecls we get out of the typechecker
 689                     rnInfo = do decl <- tcg_rn_decls tc_result
 690                                 imports <- tcg_rn_imports tc_result
 691                                 let exports = tcg_rn_exports tc_result
 692                                 let doc = tcg_doc tc_result
 693                                     hmi = tcg_hmi tc_result
 694                                 return (decl,imports,exports,doc,hmi)
 695                 return (Just (HscChecked rdr_module
 696                                    rnInfo
 697                                    (Just (tcg_binds tc_result,
 698                                           tcg_rdr_env tc_result,
 699                                           md))))
 700         }}}}
 701
 702
 703 hscCmmFile :: DynFlags -> FilePath -> IO Bool
 704 hscCmmFile dflags filename = do
 705   maybe_cmm <- parseCmmFile dflags filename
 706   case maybe_cmm of
 707     Nothing -> return False
 708     Just cmm -> do
 709         codeOutput dflags no_mod no_loc NoStubs [] [cmm]
 710         return True
 711   where
 712         no_mod = panic "hscCmmFile: no_mod"
 713         no_loc = ModLocation{ ml_hs_file  = Just filename,
 714                               ml_hi_file  = panic "hscCmmFile: no hi file",
 715                               ml_obj_file = panic "hscCmmFile: no obj file" }
 716
 717
 718 myParseModule dflags src_filename maybe_src_buf
 719  =    --------------------------  Parser  ----------------
 720       showPass dflags "Parser" >>
 721       {-# SCC "Parser" #-} do
 722
 723         -- sometimes we already have the buffer in memory, perhaps
 724         -- because we needed to parse the imports out of it, or get the
 725         -- module name.
 726       buf <- case maybe_src_buf of
 727                 Just b  -> return b
 728                 Nothing -> hGetStringBuffer src_filename
 729
 730       let loc  = mkSrcLoc (mkFastString src_filename) 1 0
 731
 732       case unP parseModule (mkPState buf loc dflags) of {
 733
 734         PFailed span err -> return (Left (mkPlainErrMsg span err));
 735
 736         POk _ rdr_module -> do {
 737
 738       dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
 739
 740       dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"
 741                            (ppSourceStats False rdr_module) ;
 742
 743       return (Right rdr_module)
 744         -- ToDo: free the string buffer later.
 745       }}
 746
 747
 748 myCoreToStg dflags this_mod prepd_binds
 749  = do
 750       stg_binds <- {-# SCC "Core2Stg" #-}
 751              coreToStg (thisPackage dflags) prepd_binds
 752
 753       (stg_binds2, cost_centre_info) <- {-# SCC "Stg2Stg" #-}
 754              stg2stg dflags this_mod stg_binds
 755
 756       return (stg_binds2, cost_centre_info)
 757 \end{code}
 758
 759
 760 %************************************************************************
 761 %*                                                                      *
 762 \subsection{Compiling a do-statement}
 763 %*                                                                      *
 764 %************************************************************************
 765
 766 When the UnlinkedBCOExpr is linked you get an HValue of type
 767         IO [HValue]
 768 When you run it you get a list of HValues that should be
 769 the same length as the list of names; add them to the ClosureEnv.
 770
 771 A naked expression returns a singleton Name [it].
 772
 773         What you type                   The IO [HValue] that hscStmt returns
 774         -------------                   ------------------------------------
 775         let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
 776                                         bindings: [x,y,...]
 777
 778         pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
 779                                         bindings: [x,y,...]
 780
 781         expr (of IO type)       ==>     expr >>= \ v -> return [v]
 782           [NB: result not printed]      bindings: [it]
 783
 784
 785         expr (of non-IO type,
 786           result showable)      ==>     let v = expr in print v >> return [v]
 787                                         bindings: [it]
 788
 789         expr (of non-IO type,
 790           result not showable)  ==>     error
 791
 792 \begin{code}
 793 #ifdef GHCI
 794 hscStmt         -- Compile a stmt all the way to an HValue, but don't run it
 795   :: HscEnv
 796   -> String                     -- The statement
 797   -> IO (Maybe (HscEnv, [Name], HValue))
 798
 799 hscStmt hsc_env stmt
 800   = do  { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt
 801         ; case maybe_stmt of {
 802              Nothing      -> return Nothing ;   -- Parse error
 803              Just Nothing -> return Nothing ;   -- Empty line
 804              Just (Just parsed_stmt) -> do {    -- The real stuff
 805
 806                 -- Rename and typecheck it
 807           let icontext = hsc_IC hsc_env
 808         ; maybe_tc_result <- tcRnStmt hsc_env icontext parsed_stmt
 809
 810         ; case maybe_tc_result of {
 811                 Nothing -> return Nothing ;
 812                 Just (new_ic, bound_names, tc_expr) -> do {
 813
 814
 815                 -- Desugar it
 816         ; let rdr_env  = ic_rn_gbl_env new_ic
 817               type_env = ic_type_env new_ic
 818         ; mb_ds_expr <- deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr
 819
 820         ; case mb_ds_expr of {
 821                 Nothing -> return Nothing ;
 822                 Just ds_expr -> do {
 823
 824                 -- Then desugar, code gen, and link it
 825         ; let src_span = srcLocSpan interactiveSrcLoc
 826         ; hval <- compileExpr hsc_env src_span ds_expr
 827
 828         ; return (Just (hsc_env{ hsc_IC=new_ic }, bound_names, hval))
 829         }}}}}}}
 830
 831 hscTcExpr       -- Typecheck an expression (but don't run it)
 832   :: HscEnv
 833   -> String                     -- The expression
 834   -> IO (Maybe Type)
 835
 836 hscTcExpr hsc_env expr
 837   = do  { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr
 838         ; let icontext = hsc_IC hsc_env
 839         ; case maybe_stmt of {
 840              Nothing      -> return Nothing ;   -- Parse error
 841              Just (Just (L _ (ExprStmt expr _ _)))
 842                         -> tcRnExpr hsc_env icontext expr ;
 843              Just other -> do { errorMsg (hsc_dflags hsc_env) (text "not an expression:" <+> quotes (text expr)) ;
 844                                 return Nothing } ;
 845              } }
 846
 847 hscKcType       -- Find the kind of a type
 848   :: HscEnv
 849   -> String                     -- The type
 850   -> IO (Maybe Kind)
 851
 852 hscKcType hsc_env str
 853   = do  { maybe_type <- hscParseType (hsc_dflags hsc_env) str
 854         ; let icontext = hsc_IC hsc_env
 855         ; case maybe_type of {
 856              Just ty -> tcRnType hsc_env icontext ty ;
 857              Nothing -> return Nothing } }
 858 #endif
 859 \end{code}
 860
 861 \begin{code}
 862 #ifdef GHCI
 863 hscParseStmt :: DynFlags -> String -> IO (Maybe (Maybe (LStmt RdrName)))
 864 hscParseStmt = hscParseThing parseStmt
 865
 866 hscParseType :: DynFlags -> String -> IO (Maybe (LHsType RdrName))
 867 hscParseType = hscParseThing parseType
 868 #endif
 869
 870 hscParseIdentifier :: DynFlags -> String -> IO (Maybe (Located RdrName))
 871 hscParseIdentifier = hscParseThing parseIdentifier
 872
 873 hscParseThing :: Outputable thing
 874               => Lexer.P thing
 875               -> DynFlags -> String
 876               -> IO (Maybe thing)
 877         -- Nothing => Parse error (message already printed)
 878         -- Just x  => success
 879 hscParseThing parser dflags str
 880  = showPass dflags "Parser" >>
 881       {-# SCC "Parser" #-} do
 882
 883       buf <- stringToStringBuffer str
 884
 885       let loc  = mkSrcLoc FSLIT("<interactive>") 1 0
 886
 887       case unP parser (mkPState buf loc dflags) of {
 888
 889         PFailed span err -> do { printError span err;
 890                                  return Nothing };
 891
 892         POk _ thing -> do {
 893
 894       --ToDo: can't free the string buffer until we've finished this
 895       -- compilation sweep and all the identifiers have gone away.
 896       dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing);
 897       return (Just thing)
 898       }}
 899 \end{code}
 900
 901 %************************************************************************
 902 %*                                                                      *
 903         Desugar, simplify, convert to bytecode, and link an expression
 904 %*                                                                      *
 905 %************************************************************************
 906
 907 \begin{code}
 908 #ifdef GHCI
 909 compileExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
 910
 911 compileExpr hsc_env srcspan ds_expr
 912   = do  { let { dflags  = hsc_dflags hsc_env ;
 913                 lint_on = dopt Opt_DoCoreLinting dflags }
 914
 915                 -- Flatten it
 916         ; flat_expr <- flattenExpr hsc_env ds_expr
 917
 918                 -- Simplify it
 919         ; simpl_expr <- simplifyExpr dflags flat_expr
 920
 921                 -- Tidy it (temporary, until coreSat does cloning)
 922         ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
 923
 924                 -- Prepare for codegen
 925         ; prepd_expr <- corePrepExpr dflags tidy_expr
 926
 927                 -- Lint if necessary
 928                 -- ToDo: improve SrcLoc
 929         ; if lint_on then
 930                 case lintUnfolding noSrcLoc [] prepd_expr of
 931                    Just err -> pprPanic "compileExpr" err
 932                    Nothing  -> return ()
 933           else
 934                 return ()
 935
 936                 -- Convert to BCOs
 937         ; bcos <- coreExprToBCOs dflags prepd_expr
 938
 939                 -- link it
 940         ; hval <- linkExpr hsc_env srcspan bcos
 941
 942         ; return hval
 943      }
 944 #endif
 945 \end{code}
 946
 947
 948 %************************************************************************
 949 %*                                                                      *
 950         Statistics on reading interfaces
 951 %*                                                                      *
 952 %************************************************************************
 953
 954 \begin{code}
 955 dumpIfaceStats :: HscEnv -> IO ()
 956 dumpIfaceStats hsc_env
 957   = do  { eps <- readIORef (hsc_EPS hsc_env)
 958         ; dumpIfSet (dump_if_trace || dump_rn_stats)
 959                     "Interface statistics"
 960                     (ifaceStats eps) }
 961   where
 962     dflags = hsc_dflags hsc_env
 963     dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
 964     dump_if_trace = dopt Opt_D_dump_if_trace dflags
 965 \end{code}
 966
 967 %************************************************************************
 968 %*                                                                      *
 969         Progress Messages: Module i of n
 970 %*                                                                      *
 971 %************************************************************************
 972
 973 \begin{code}
 974 showModuleIndex Nothing = ""
 975 showModuleIndex (Just (i,n)) = "[" ++ padded ++ " of " ++ n_str ++ "] "
 976     where
 977         n_str = show n
 978         i_str = show i
 979         padded = replicate (length n_str - length i_str) ' ' ++ i_str
 980 \end{code}
 981