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