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