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