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