compiler/main/HscMain.lhs

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