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