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