compiler/main/HscMain.lhs

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