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