compiler/main/HscMain.lhs

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