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 >>= cmmToRawCmm
 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 = noVectInfo
 698                                    -- VectInfo is added by the Core
 699                                    -- vectorisation pass
 700                           }
 701                     rnInfo = do decl <- tcg_rn_decls tc_result
 702                                 imports <- tcg_rn_imports tc_result
 703                                 let exports = tcg_rn_exports tc_result
 704                                 let doc = tcg_doc tc_result
 705                                     hmi = tcg_hmi tc_result
 706                                 return (decl,imports,exports,doc,hmi)
 707                 maybeModGuts <-
 708                  if compileToCore then
 709                    deSugar hsc_env (ms_location mod_summary) tc_result
 710                  else
 711                    return Nothing
 712                 return (Just (HscChecked rdr_module
 713                                    rnInfo
 714                                    (Just (tcg_binds tc_result,
 715                                           tcg_rdr_env tc_result,
 716                                           md))
 717                                    (fmap mg_binds maybeModGuts)))
 718         }}}}
 719
 720
 721 hscCmmFile :: DynFlags -> FilePath -> IO Bool
 722 hscCmmFile dflags filename = do
 723   maybe_cmm <- parseCmmFile dflags filename
 724   case maybe_cmm of
 725     Nothing -> return False
 726     Just cmm -> do
 727         --continuationC <- cmmCPS dflags [cmm] >>= cmmToRawCmm
 728         continuationC <- cmmToRawCmm [cmm]
 729         codeOutput dflags no_mod no_loc NoStubs [] continuationC
 730         return True
 731   where
 732         no_mod = panic "hscCmmFile: no_mod"
 733         no_loc = ModLocation{ ml_hs_file  = Just filename,
 734                               ml_hi_file  = panic "hscCmmFile: no hi file",
 735                               ml_obj_file = panic "hscCmmFile: no obj file" }
 736
 737
 738 myParseModule dflags src_filename maybe_src_buf
 739  =    --------------------------  Parser  ----------------
 740       showPass dflags "Parser" >>
 741       {-# SCC "Parser" #-} do
 742
 743         -- sometimes we already have the buffer in memory, perhaps
 744         -- because we needed to parse the imports out of it, or get the
 745         -- module name.
 746       buf <- case maybe_src_buf of
 747                 Just b  -> return b
 748                 Nothing -> hGetStringBuffer src_filename
 749
 750       let loc  = mkSrcLoc (mkFastString src_filename) 1 0
 751
 752       case unP parseModule (mkPState buf loc dflags) of {
 753
 754         PFailed span err -> return (Left (mkPlainErrMsg span err));
 755
 756         POk pst rdr_module -> do {
 757
 758       let {ms = getMessages pst};
 759       printErrorsAndWarnings dflags ms;
 760       when (errorsFound dflags ms) $ exitWith (ExitFailure 1);
 761
 762       dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
 763
 764       dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"
 765                            (ppSourceStats False rdr_module) ;
 766
 767       return (Right rdr_module)
 768         -- ToDo: free the string buffer later.
 769       }}
 770
 771
 772 myCoreToStg dflags this_mod prepd_binds
 773  = do
 774       stg_binds <- {-# SCC "Core2Stg" #-}
 775              coreToStg (thisPackage dflags) prepd_binds
 776
 777       (stg_binds2, cost_centre_info) <- {-# SCC "Stg2Stg" #-}
 778              stg2stg dflags this_mod stg_binds
 779
 780       return (stg_binds2, cost_centre_info)
 781 \end{code}
 782
 783
 784 %************************************************************************
 785 %*                                                                      *
 786 \subsection{Compiling a do-statement}
 787 %*                                                                      *
 788 %************************************************************************
 789
 790 When the UnlinkedBCOExpr is linked you get an HValue of type
 791         IO [HValue]
 792 When you run it you get a list of HValues that should be
 793 the same length as the list of names; add them to the ClosureEnv.
 794
 795 A naked expression returns a singleton Name [it].
 796
 797         What you type                   The IO [HValue] that hscStmt returns
 798         -------------                   ------------------------------------
 799         let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
 800                                         bindings: [x,y,...]
 801
 802         pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
 803                                         bindings: [x,y,...]
 804
 805         expr (of IO type)       ==>     expr >>= \ v -> return [v]
 806           [NB: result not printed]      bindings: [it]
 807
 808
 809         expr (of non-IO type,
 810           result showable)      ==>     let v = expr in print v >> return [v]
 811                                         bindings: [it]
 812
 813         expr (of non-IO type,
 814           result not showable)  ==>     error
 815
 816 \begin{code}
 817 #ifdef GHCI
 818 hscStmt         -- Compile a stmt all the way to an HValue, but don't run it
 819   :: HscEnv
 820   -> String                     -- The statement
 821   -> IO (Maybe ([Id], HValue))
 822
 823 hscStmt hsc_env stmt
 824   = do  { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt
 825         ; case maybe_stmt of {
 826              Nothing      -> return Nothing ;   -- Parse error
 827              Just Nothing -> return Nothing ;   -- Empty line
 828              Just (Just parsed_stmt) -> do {    -- The real stuff
 829
 830                 -- Rename and typecheck it
 831           let icontext = hsc_IC hsc_env
 832         ; maybe_tc_result <- tcRnStmt hsc_env icontext parsed_stmt
 833
 834         ; case maybe_tc_result of {
 835                 Nothing -> return Nothing ;
 836                 Just (ids, tc_expr) -> do {
 837
 838                 -- Desugar it
 839         ; let rdr_env  = ic_rn_gbl_env icontext
 840               type_env = mkTypeEnv (map AnId (ic_tmp_ids icontext))
 841         ; mb_ds_expr <- deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr
 842
 843         ; case mb_ds_expr of {
 844                 Nothing -> return Nothing ;
 845                 Just ds_expr -> do {
 846
 847                 -- Then desugar, code gen, and link it
 848         ; let src_span = srcLocSpan interactiveSrcLoc
 849         ; hval <- compileExpr hsc_env src_span ds_expr
 850
 851         ; return (Just (ids, hval))
 852         }}}}}}}
 853
 854 hscTcExpr       -- Typecheck an expression (but don't run it)
 855   :: HscEnv
 856   -> String                     -- The expression
 857   -> IO (Maybe Type)
 858
 859 hscTcExpr hsc_env expr
 860   = do  { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr
 861         ; let icontext = hsc_IC hsc_env
 862         ; case maybe_stmt of {
 863              Nothing      -> return Nothing ;   -- Parse error
 864              Just (Just (L _ (ExprStmt expr _ _)))
 865                         -> tcRnExpr hsc_env icontext expr ;
 866              Just other -> do { errorMsg (hsc_dflags hsc_env) (text "not an expression:" <+> quotes (text expr)) ;
 867                                 return Nothing } ;
 868              } }
 869
 870 hscKcType       -- Find the kind of a type
 871   :: HscEnv
 872   -> String                     -- The type
 873   -> IO (Maybe Kind)
 874
 875 hscKcType hsc_env str
 876   = do  { maybe_type <- hscParseType (hsc_dflags hsc_env) str
 877         ; let icontext = hsc_IC hsc_env
 878         ; case maybe_type of {
 879              Just ty -> tcRnType hsc_env icontext ty ;
 880              Nothing -> return Nothing } }
 881 #endif
 882 \end{code}
 883
 884 \begin{code}
 885 #ifdef GHCI
 886 hscParseStmt :: DynFlags -> String -> IO (Maybe (Maybe (LStmt RdrName)))
 887 hscParseStmt = hscParseThing parseStmt
 888
 889 hscParseType :: DynFlags -> String -> IO (Maybe (LHsType RdrName))
 890 hscParseType = hscParseThing parseType
 891 #endif
 892
 893 hscParseIdentifier :: DynFlags -> String -> IO (Maybe (Located RdrName))
 894 hscParseIdentifier = hscParseThing parseIdentifier
 895
 896 hscParseThing :: Outputable thing
 897               => Lexer.P thing
 898               -> DynFlags -> String
 899               -> IO (Maybe thing)
 900         -- Nothing => Parse error (message already printed)
 901         -- Just x  => success
 902 hscParseThing parser dflags str
 903  = showPass dflags "Parser" >>
 904       {-# SCC "Parser" #-} do
 905
 906       buf <- stringToStringBuffer str
 907
 908       let loc  = mkSrcLoc FSLIT("<interactive>") 1 0
 909
 910       case unP parser (mkPState buf loc dflags) of {
 911
 912         PFailed span err -> do { printError span err;
 913                                  return Nothing };
 914
 915         POk pst thing -> do {
 916
 917       let {ms = getMessages pst};
 918       printErrorsAndWarnings dflags ms;
 919       when (errorsFound dflags ms) $ exitWith (ExitFailure 1);
 920
 921       --ToDo: can't free the string buffer until we've finished this
 922       -- compilation sweep and all the identifiers have gone away.
 923       dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing);
 924       return (Just thing)
 925       }}
 926 \end{code}
 927
 928 %************************************************************************
 929 %*                                                                      *
 930         Desugar, simplify, convert to bytecode, and link an expression
 931 %*                                                                      *
 932 %************************************************************************
 933
 934 \begin{code}
 935 #ifdef GHCI
 936 compileExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
 937
 938 compileExpr hsc_env srcspan ds_expr
 939   = do  { let { dflags  = hsc_dflags hsc_env ;
 940                 lint_on = dopt Opt_DoCoreLinting dflags }
 941
 942                 -- Flatten it
 943         ; flat_expr <- flattenExpr hsc_env ds_expr
 944
 945                 -- Simplify it
 946         ; simpl_expr <- simplifyExpr dflags flat_expr
 947
 948                 -- Tidy it (temporary, until coreSat does cloning)
 949         ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
 950
 951                 -- Prepare for codegen
 952         ; prepd_expr <- corePrepExpr dflags tidy_expr
 953
 954                 -- Lint if necessary
 955                 -- ToDo: improve SrcLoc
 956         ; if lint_on then
 957                 let ictxt = hsc_IC hsc_env
 958                     tyvars = varSetElems (ic_tyvars ictxt)
 959                 in
 960                 case lintUnfolding noSrcLoc tyvars prepd_expr of
 961                    Just err -> pprPanic "compileExpr" err
 962                    Nothing  -> return ()
 963           else
 964                 return ()
 965
 966                 -- Convert to BCOs
 967         ; bcos <- coreExprToBCOs dflags prepd_expr
 968
 969                 -- link it
 970         ; hval <- linkExpr hsc_env srcspan bcos
 971
 972         ; return hval
 973      }
 974 #endif
 975 \end{code}
 976
 977
 978 %************************************************************************
 979 %*                                                                      *
 980         Statistics on reading interfaces
 981 %*                                                                      *
 982 %************************************************************************
 983
 984 \begin{code}
 985 dumpIfaceStats :: HscEnv -> IO ()
 986 dumpIfaceStats hsc_env
 987   = do  { eps <- readIORef (hsc_EPS hsc_env)
 988         ; dumpIfSet (dump_if_trace || dump_rn_stats)
 989                     "Interface statistics"
 990                     (ifaceStats eps) }
 991   where
 992     dflags = hsc_dflags hsc_env
 993     dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
 994     dump_if_trace = dopt Opt_D_dump_if_trace dflags
 995 \end{code}
 996
 997 %************************************************************************
 998 %*                                                                      *
 999         Progress Messages: Module i of n
1000 %*                                                                      *
1001 %************************************************************************
1002
1003 \begin{code}
1004 showModuleIndex Nothing = ""
1005 showModuleIndex (Just (i,n)) = "[" ++ padded ++ " of " ++ n_str ++ "] "
1006     where
1007         n_str = show n
1008         i_str = show i
1009         padded = replicate (length n_str - length i_str) ' ' ++ i_str
1010 \end{code}
1011