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 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
 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 -- Does it make sense to compile extCore to nothing?
 311 hscCompileNothing :: Compiler (HscStatus, ModIface, ModDetails)
 312 hscCompileNothing hsc_env mod_summary
 313     = compiler hsc_env mod_summary
 314     where mkComp = hscMkCompiler norecompBatch batchMsg
 315           pipeline inp = hscSimpleIface inp >>= hscIgnoreIface >>= hscNothing
 316           compiler
 317               = case ms_hsc_src mod_summary of
 318                 ExtCoreFile
 319                     -> mkComp hscCoreFrontEnd pipeline
 320                 HsSrcFile
 321                     -> mkComp hscFileFrontEnd pipeline
 322                 HsBootFile
 323                     -> mkComp hscFileFrontEnd pipeline
 324
 325 -- Compile Haskell, extCore to bytecode.
 326 hscCompileInteractive :: Compiler (InteractiveStatus, ModIface, ModDetails)
 327 hscCompileInteractive hsc_env mod_summary =
 328     hscMkCompiler norecompInteractive batchMsg
 329                   frontend backend
 330                   hsc_env mod_summary
 331     where backend inp = hscSimplify inp >>= hscNormalIface >>= hscIgnoreIface >>= hscInteractive
 332           frontend = case ms_hsc_src mod_summary of
 333                        ExtCoreFile -> hscCoreFrontEnd
 334                        HsSrcFile   -> hscFileFrontEnd
 335                        HsBootFile  -> panic bootErrorMsg
 336           bootErrorMsg = "Compiling a HsBootFile to bytecode doesn't make sense. " ++
 337                          "Use 'hscCompileBatch' instead."
 338
 339 --------------------------------------------------------------
 340 -- NoRecomp handlers
 341 --------------------------------------------------------------
 342
 343 norecompOneShot :: NoRecomp HscStatus
 344 norecompOneShot old_iface
 345     = do hsc_env <- gets compHscEnv
 346          liftIO $ do
 347          dumpIfaceStats hsc_env
 348          return HscNoRecomp
 349
 350 norecompBatch :: NoRecomp (HscStatus, ModIface, ModDetails)
 351 norecompBatch = norecompWorker HscNoRecomp False
 352
 353 norecompInteractive :: NoRecomp (InteractiveStatus, ModIface, ModDetails)
 354 norecompInteractive = norecompWorker InteractiveNoRecomp True
 355
 356 norecompWorker :: a -> Bool -> NoRecomp (a, ModIface, ModDetails)
 357 norecompWorker a isInterp old_iface
 358     = do hsc_env <- gets compHscEnv
 359          mod_summary <- gets compModSummary
 360          liftIO $ do
 361          new_details <- {-# SCC "tcRnIface" #-}
 362                         initIfaceCheck hsc_env $
 363                         typecheckIface old_iface
 364          dumpIfaceStats hsc_env
 365          return (a, old_iface, new_details)
 366
 367 --------------------------------------------------------------
 368 -- Progress displayers.
 369 --------------------------------------------------------------
 370
 371 oneShotMsg :: Maybe (Int,Int) -> Bool -> Comp ()
 372 oneShotMsg _mb_mod_index recomp
 373     = do hsc_env <- gets compHscEnv
 374          liftIO $ do
 375          if recomp
 376             then return ()
 377             else compilationProgressMsg (hsc_dflags hsc_env) $
 378                      "compilation IS NOT required"
 379
 380 batchMsg :: Maybe (Int,Int) -> Bool -> Comp ()
 381 batchMsg mb_mod_index recomp
 382     = do hsc_env <- gets compHscEnv
 383          mod_summary <- gets compModSummary
 384          let showMsg msg = compilationProgressMsg (hsc_dflags hsc_env) $
 385                            (showModuleIndex mb_mod_index ++
 386                             msg ++ showModMsg (hscTarget (hsc_dflags hsc_env)) recomp mod_summary)
 387          liftIO $ do
 388          if recomp
 389             then showMsg "Compiling "
 390             else showMsg "Skipping  "
 391
 392
 393
 394 --------------------------------------------------------------
 395 -- FrontEnds
 396 --------------------------------------------------------------
 397
 398 hscCoreFrontEnd :: FrontEnd ModGuts
 399 hscCoreFrontEnd =
 400     do hsc_env <- gets compHscEnv
 401        mod_summary <- gets compModSummary
 402        liftIO $ do
 403             -------------------
 404             -- PARSE
 405             -------------------
 406        inp <- readFile (ms_hspp_file mod_summary)
 407        case parseCore inp 1 of
 408          FailP s
 409              -> do errorMsg (hsc_dflags hsc_env) (text s{-ToDo: wrong-})
 410                    return Nothing
 411          OkP rdr_module
 412              -------------------
 413              -- RENAME and TYPECHECK
 414              -------------------
 415              -> do (tc_msgs, maybe_tc_result) <- {-# SCC "TypeCheck" #-}
 416                                                  tcRnExtCore hsc_env rdr_module
 417                    printErrorsAndWarnings (hsc_dflags hsc_env) tc_msgs
 418                    case maybe_tc_result of
 419                      Nothing       -> return Nothing
 420                      Just mod_guts -> return (Just mod_guts)         -- No desugaring to do!
 421
 422
 423 hscFileFrontEnd :: FrontEnd ModGuts
 424 hscFileFrontEnd =
 425     do hsc_env <- gets compHscEnv
 426        mod_summary <- gets compModSummary
 427        liftIO $ do
 428              -------------------
 429              -- PARSE
 430              -------------------
 431        let dflags = hsc_dflags hsc_env
 432            hspp_file = ms_hspp_file mod_summary
 433            hspp_buf  = ms_hspp_buf  mod_summary
 434        maybe_parsed <- myParseModule dflags hspp_file hspp_buf
 435        case maybe_parsed of
 436          Left err
 437              -> do printBagOfErrors dflags (unitBag err)
 438                    return Nothing
 439          Right rdr_module
 440              -------------------
 441              -- RENAME and TYPECHECK
 442              -------------------
 443              -> do (tc_msgs, maybe_tc_result)
 444                        <- {-# SCC "Typecheck-Rename" #-}
 445                           tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module
 446                    printErrorsAndWarnings dflags tc_msgs
 447                    case maybe_tc_result of
 448                      Nothing
 449                          -> return Nothing
 450                      Just tc_result
 451                          -------------------
 452                          -- DESUGAR
 453                          -------------------
 454                          -> do (warns, maybe_ds_result) <- {-# SCC "DeSugar" #-}
 455                                                            deSugar hsc_env tc_result
 456                                printBagOfWarnings dflags warns
 457                                return maybe_ds_result
 458
 459 --------------------------------------------------------------
 460 -- Simplifiers
 461 --------------------------------------------------------------
 462
 463 hscSimplify :: ModGuts -> Comp ModGuts
 464 hscSimplify ds_result
 465   = do hsc_env <- gets compHscEnv
 466        liftIO $ do
 467        flat_result <- {-# SCC "Flattening" #-}
 468                       flatten hsc_env ds_result
 469            -------------------
 470            -- SIMPLIFY
 471            -------------------
 472        simpl_result <- {-# SCC "Core2Core" #-}
 473                        core2core hsc_env flat_result
 474        return simpl_result
 475
 476 --------------------------------------------------------------
 477 -- Interface generators
 478 --------------------------------------------------------------
 479
 480 -- HACK: we return ModGuts even though we know it's not gonna be used.
 481 --       We do this because the type signature needs to be identical
 482 --       in structure to the type of 'hscNormalIface'.
 483 hscSimpleIface :: ModGuts -> Comp (ModIface, Bool, ModDetails, ModGuts)
 484 hscSimpleIface ds_result
 485   = do hsc_env <- gets compHscEnv
 486        mod_summary <- gets compModSummary
 487        maybe_old_iface <- gets compOldIface
 488        liftIO $ do
 489        details <- mkBootModDetails hsc_env ds_result
 490        (new_iface, no_change)
 491            <- {-# SCC "MkFinalIface" #-}
 492               mkIface hsc_env maybe_old_iface ds_result details
 493        -- And the answer is ...
 494        dumpIfaceStats hsc_env
 495        return (new_iface, no_change, details, ds_result)
 496
 497 hscNormalIface :: ModGuts -> Comp (ModIface, Bool, ModDetails, CgGuts)
 498 hscNormalIface simpl_result
 499   = do hsc_env <- gets compHscEnv
 500        mod_summary <- gets compModSummary
 501        maybe_old_iface <- gets compOldIface
 502        liftIO $ do
 503             -------------------
 504             -- TIDY
 505             -------------------
 506        (cg_guts, details) <- {-# SCC "CoreTidy" #-}
 507                              tidyProgram hsc_env simpl_result
 508
 509             -------------------
 510             -- BUILD THE NEW ModIface and ModDetails
 511             --  and emit external core if necessary
 512             -- This has to happen *after* code gen so that the back-end
 513             -- info has been set.  Not yet clear if it matters waiting
 514             -- until after code output
 515        (new_iface, no_change)
 516                 <- {-# SCC "MkFinalIface" #-}
 517                    mkIface hsc_env maybe_old_iface simpl_result details
 518         -- Emit external core
 519        emitExternalCore (hsc_dflags hsc_env) cg_guts -- Move this? --Lemmih 03/07/2006
 520        dumpIfaceStats hsc_env
 521
 522             -------------------
 523             -- Return the prepared code.
 524        return (new_iface, no_change, details, cg_guts)
 525
 526 --------------------------------------------------------------
 527 -- BackEnd combinators
 528 --------------------------------------------------------------
 529
 530 hscWriteIface :: (ModIface, Bool, ModDetails, a) -> Comp (ModIface, ModDetails, a)
 531 hscWriteIface (iface, no_change, details, a)
 532     = do mod_summary <- gets compModSummary
 533          liftIO $ do
 534          unless no_change
 535            $ writeIfaceFile (ms_location mod_summary) iface
 536          return (iface, details, a)
 537
 538 hscIgnoreIface :: (ModIface, Bool, ModDetails, a) -> Comp (ModIface, ModDetails, a)
 539 hscIgnoreIface (iface, no_change, details, a)
 540     = return (iface, details, a)
 541
 542 -- Don't output any code.
 543 hscNothing :: (ModIface, ModDetails, a) -> Comp (HscStatus, ModIface, ModDetails)
 544 hscNothing (iface, details, a)
 545     = return (HscRecomp False, iface, details)
 546
 547 -- Generate code and return both the new ModIface and the ModDetails.
 548 hscBatch :: (ModIface, ModDetails, CgGuts) -> Comp (HscStatus, ModIface, ModDetails)
 549 hscBatch (iface, details, cgguts)
 550     = do hasStub <- hscCompile cgguts
 551          return (HscRecomp hasStub, iface, details)
 552
 553 -- Here we don't need the ModIface and ModDetails anymore.
 554 hscOneShot :: (ModIface, ModDetails, CgGuts) -> Comp HscStatus
 555 hscOneShot (_, _, cgguts)
 556     = do hasStub <- hscCompile cgguts
 557          return (HscRecomp hasStub)
 558
 559 -- Compile to hard-code.
 560 hscCompile :: CgGuts -> Comp Bool
 561 hscCompile cgguts
 562     = do hsc_env <- gets compHscEnv
 563          mod_summary <- gets compModSummary
 564          liftIO $ do
 565          let CgGuts{ -- This is the last use of the ModGuts in a compilation.
 566                      -- From now on, we just use the bits we need.
 567                      cg_module   = this_mod,
 568                      cg_binds    = core_binds,
 569                      cg_tycons   = tycons,
 570                      cg_dir_imps = dir_imps,
 571                      cg_foreign  = foreign_stubs,
 572                      cg_home_mods = home_mods,
 573                      cg_dep_pkgs = dependencies } = cgguts
 574              dflags = hsc_dflags hsc_env
 575              location = ms_location mod_summary
 576              data_tycons = filter isDataTyCon tycons
 577              -- cg_tycons includes newtypes, for the benefit of External Core,
 578              -- but we don't generate any code for newtypes
 579
 580          -------------------
 581          -- PREPARE FOR CODE GENERATION
 582          -- Do saturation and convert to A-normal form
 583          prepd_binds <- {-# SCC "CorePrep" #-}
 584                         corePrepPgm dflags core_binds data_tycons ;
 585          -----------------  Convert to STG ------------------
 586          (stg_binds, cost_centre_info)
 587              <- {-# SCC "CoreToStg" #-}
 588                 myCoreToStg dflags home_mods this_mod prepd_binds
 589          ------------------  Code generation ------------------
 590          abstractC <- {-# SCC "CodeGen" #-}
 591                       codeGen dflags home_mods this_mod data_tycons
 592                               foreign_stubs dir_imps cost_centre_info
 593                               stg_binds
 594          ------------------  Code output -----------------------
 595          (stub_h_exists,stub_c_exists)
 596              <- codeOutput dflags this_mod location foreign_stubs
 597                 dependencies abstractC
 598          return stub_c_exists
 599
 600 hscConst :: b -> a -> Comp b
 601 hscConst b a = return b
 602
 603 hscInteractive :: (ModIface, ModDetails, CgGuts)
 604                -> Comp (InteractiveStatus, ModIface, ModDetails)
 605 hscInteractive (iface, details, cgguts)
 606 #ifdef GHCI
 607     = do hsc_env <- gets compHscEnv
 608          mod_summary <- gets compModSummary
 609          liftIO $ do
 610          let CgGuts{ -- This is the last use of the ModGuts in a compilation.
 611                      -- From now on, we just use the bits we need.
 612                      cg_module   = this_mod,
 613                      cg_binds    = core_binds,
 614                      cg_tycons   = tycons,
 615                      cg_foreign  = foreign_stubs } = cgguts
 616              dflags = hsc_dflags hsc_env
 617              location = ms_location mod_summary
 618              data_tycons = filter isDataTyCon tycons
 619              -- cg_tycons includes newtypes, for the benefit of External Core,
 620              -- but we don't generate any code for newtypes
 621
 622          -------------------
 623          -- PREPARE FOR CODE GENERATION
 624          -- Do saturation and convert to A-normal form
 625          prepd_binds <- {-# SCC "CorePrep" #-}
 626                         corePrepPgm dflags core_binds data_tycons ;
 627          -----------------  Generate byte code ------------------
 628          comp_bc <- byteCodeGen dflags prepd_binds data_tycons
 629          ------------------ Create f-x-dynamic C-side stuff ---
 630          (istub_h_exists, istub_c_exists)
 631              <- outputForeignStubs dflags this_mod location foreign_stubs
 632          return (InteractiveRecomp istub_c_exists comp_bc, iface, details)
 633 #else
 634     = panic "GHC not compiled with interpreter"
 635 #endif
 636
 637 ------------------------------
 638
 639 hscFileCheck :: HscEnv -> ModSummary -> IO (Maybe HscChecked)
 640 hscFileCheck hsc_env mod_summary = do {
 641             -------------------
 642             -- PARSE
 643             -------------------
 644         ; let dflags    = hsc_dflags hsc_env
 645               hspp_file = ms_hspp_file mod_summary
 646               hspp_buf  = ms_hspp_buf  mod_summary
 647
 648         ; maybe_parsed <- myParseModule dflags hspp_file hspp_buf
 649
 650         ; case maybe_parsed of {
 651              Left err -> do { printBagOfErrors dflags (unitBag err)
 652                             ; return Nothing } ;
 653              Right rdr_module -> do {
 654
 655             -------------------
 656             -- RENAME and TYPECHECK
 657             -------------------
 658           (tc_msgs, maybe_tc_result)
 659                 <- _scc_ "Typecheck-Rename"
 660                    tcRnModule hsc_env (ms_hsc_src mod_summary)
 661                         True{-save renamed syntax-}
 662                         rdr_module
 663
 664         ; printErrorsAndWarnings dflags tc_msgs
 665         ; case maybe_tc_result of {
 666              Nothing -> return (Just (HscChecked rdr_module Nothing Nothing));
 667              Just tc_result -> do
 668                 let md = ModDetails {
 669                                 md_types   = tcg_type_env tc_result,
 670                                 md_exports = tcg_exports  tc_result,
 671                                 md_insts   = tcg_insts    tc_result,
 672                                 md_rules   = [panic "no rules"] }
 673                                    -- Rules are CoreRules, not the
 674                                    -- RuleDecls we get out of the typechecker
 675                     rnInfo = do decl <- tcg_rn_decls tc_result
 676                                 imports <- tcg_rn_imports tc_result
 677                                 let exports = tcg_rn_exports tc_result
 678                                 return (decl,imports,exports)
 679                 return (Just (HscChecked rdr_module
 680                                    rnInfo
 681                                    (Just (tcg_binds tc_result,
 682                                           tcg_rdr_env tc_result,
 683                                           md))))
 684         }}}}
 685
 686
 687 hscCmmFile :: DynFlags -> FilePath -> IO Bool
 688 hscCmmFile dflags filename = do
 689   maybe_cmm <- parseCmmFile dflags (mkHomeModules []) filename
 690   case maybe_cmm of
 691     Nothing -> return False
 692     Just cmm -> do
 693         codeOutput dflags no_mod no_loc NoStubs [] [cmm]
 694         return True
 695   where
 696         no_mod = panic "hscCmmFile: no_mod"
 697         no_loc = ModLocation{ ml_hs_file  = Just filename,
 698                               ml_hi_file  = panic "hscCmmFile: no hi file",
 699                               ml_obj_file = panic "hscCmmFile: no obj file" }
 700
 701
 702 myParseModule dflags src_filename maybe_src_buf
 703  =    --------------------------  Parser  ----------------
 704       showPass dflags "Parser" >>
 705       {-# SCC "Parser" #-} do
 706
 707         -- sometimes we already have the buffer in memory, perhaps
 708         -- because we needed to parse the imports out of it, or get the
 709         -- module name.
 710       buf <- case maybe_src_buf of
 711                 Just b  -> return b
 712                 Nothing -> hGetStringBuffer src_filename
 713
 714       let loc  = mkSrcLoc (mkFastString src_filename) 1 0
 715
 716       case unP parseModule (mkPState buf loc dflags) of {
 717
 718         PFailed span err -> return (Left (mkPlainErrMsg span err));
 719
 720         POk _ rdr_module -> do {
 721
 722       dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
 723
 724       dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"
 725                            (ppSourceStats False rdr_module) ;
 726
 727       return (Right rdr_module)
 728         -- ToDo: free the string buffer later.
 729       }}
 730
 731
 732 myCoreToStg dflags home_mods this_mod prepd_binds
 733  = do
 734       stg_binds <- {-# SCC "Core2Stg" #-}
 735              coreToStg home_mods prepd_binds
 736
 737       (stg_binds2, cost_centre_info) <- {-# SCC "Stg2Stg" #-}
 738              stg2stg dflags home_mods this_mod stg_binds
 739
 740       return (stg_binds2, cost_centre_info)
 741 \end{code}
 742
 743
 744 %************************************************************************
 745 %*                                                                      *
 746 \subsection{Compiling a do-statement}
 747 %*                                                                      *
 748 %************************************************************************
 749
 750 When the UnlinkedBCOExpr is linked you get an HValue of type
 751         IO [HValue]
 752 When you run it you get a list of HValues that should be
 753 the same length as the list of names; add them to the ClosureEnv.
 754
 755 A naked expression returns a singleton Name [it].
 756
 757         What you type                   The IO [HValue] that hscStmt returns
 758         -------------                   ------------------------------------
 759         let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
 760                                         bindings: [x,y,...]
 761
 762         pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
 763                                         bindings: [x,y,...]
 764
 765         expr (of IO type)       ==>     expr >>= \ v -> return [v]
 766           [NB: result not printed]      bindings: [it]
 767
 768
 769         expr (of non-IO type,
 770           result showable)      ==>     let v = expr in print v >> return [v]
 771                                         bindings: [it]
 772
 773         expr (of non-IO type,
 774           result not showable)  ==>     error
 775
 776 \begin{code}
 777 #ifdef GHCI
 778 hscStmt         -- Compile a stmt all the way to an HValue, but don't run it
 779   :: HscEnv
 780   -> String                     -- The statement
 781   -> IO (Maybe (HscEnv, [Name], HValue))
 782
 783 hscStmt hsc_env stmt
 784   = do  { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt
 785         ; case maybe_stmt of {
 786              Nothing      -> return Nothing ;   -- Parse error
 787              Just Nothing -> return Nothing ;   -- Empty line
 788              Just (Just parsed_stmt) -> do {    -- The real stuff
 789
 790                 -- Rename and typecheck it
 791           let icontext = hsc_IC hsc_env
 792         ; maybe_tc_result <- tcRnStmt hsc_env icontext parsed_stmt
 793
 794         ; case maybe_tc_result of {
 795                 Nothing -> return Nothing ;
 796                 Just (new_ic, bound_names, tc_expr) -> do {
 797
 798                 -- Then desugar, code gen, and link it
 799         ; hval <- compileExpr hsc_env iNTERACTIVE
 800                               (ic_rn_gbl_env new_ic)
 801                               (ic_type_env new_ic)
 802                               tc_expr
 803
 804         ; return (Just (hsc_env{ hsc_IC=new_ic }, bound_names, hval))
 805         }}}}}
 806
 807 hscTcExpr       -- Typecheck an expression (but don't run it)
 808   :: HscEnv
 809   -> String                     -- The expression
 810   -> IO (Maybe Type)
 811
 812 hscTcExpr hsc_env expr
 813   = do  { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr
 814         ; let icontext = hsc_IC hsc_env
 815         ; case maybe_stmt of {
 816              Nothing      -> return Nothing ;   -- Parse error
 817              Just (Just (L _ (ExprStmt expr _ _)))
 818                         -> tcRnExpr hsc_env icontext expr ;
 819              Just other -> do { errorMsg (hsc_dflags hsc_env) (text "not an expression:" <+> quotes (text expr)) ;
 820                                 return Nothing } ;
 821              } }
 822
 823 hscKcType       -- Find the kind of a type
 824   :: HscEnv
 825   -> String                     -- The type
 826   -> IO (Maybe Kind)
 827
 828 hscKcType hsc_env str
 829   = do  { maybe_type <- hscParseType (hsc_dflags hsc_env) str
 830         ; let icontext = hsc_IC hsc_env
 831         ; case maybe_type of {
 832              Just ty    -> tcRnType hsc_env icontext ty ;
 833              Just other -> do { errorMsg (hsc_dflags hsc_env) (text "not an type:" <+> quotes (text str)) ;
 834                                 return Nothing } ;
 835              Nothing    -> return Nothing } }
 836 #endif
 837 \end{code}
 838
 839 \begin{code}
 840 #ifdef GHCI
 841 hscParseStmt :: DynFlags -> String -> IO (Maybe (Maybe (LStmt RdrName)))
 842 hscParseStmt = hscParseThing parseStmt
 843
 844 hscParseType :: DynFlags -> String -> IO (Maybe (LHsType RdrName))
 845 hscParseType = hscParseThing parseType
 846 #endif
 847
 848 hscParseIdentifier :: DynFlags -> String -> IO (Maybe (Located RdrName))
 849 hscParseIdentifier = hscParseThing parseIdentifier
 850
 851 hscParseThing :: Outputable thing
 852               => Lexer.P thing
 853               -> DynFlags -> String
 854               -> IO (Maybe thing)
 855         -- Nothing => Parse error (message already printed)
 856         -- Just x  => success
 857 hscParseThing parser dflags str
 858  = showPass dflags "Parser" >>
 859       {-# SCC "Parser" #-} do
 860
 861       buf <- stringToStringBuffer str
 862
 863       let loc  = mkSrcLoc FSLIT("<interactive>") 1 0
 864
 865       case unP parser (mkPState buf loc dflags) of {
 866
 867         PFailed span err -> do { printError span err;
 868                                  return Nothing };
 869
 870         POk _ thing -> do {
 871
 872       --ToDo: can't free the string buffer until we've finished this
 873       -- compilation sweep and all the identifiers have gone away.
 874       dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing);
 875       return (Just thing)
 876       }}
 877 \end{code}
 878
 879 %************************************************************************
 880 %*                                                                      *
 881         Desugar, simplify, convert to bytecode, and link an expression
 882 %*                                                                      *
 883 %************************************************************************
 884
 885 \begin{code}
 886 #ifdef GHCI
 887 compileExpr :: HscEnv
 888             -> Module -> GlobalRdrEnv -> TypeEnv
 889             -> LHsExpr Id
 890             -> IO HValue
 891
 892 compileExpr hsc_env this_mod rdr_env type_env tc_expr
 893   = do  { let { dflags  = hsc_dflags hsc_env ;
 894                 lint_on = dopt Opt_DoCoreLinting dflags }
 895
 896                 -- Desugar it
 897         ; ds_expr <- deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
 898
 899                 -- Flatten it
 900         ; flat_expr <- flattenExpr hsc_env ds_expr
 901
 902                 -- Simplify it
 903         ; simpl_expr <- simplifyExpr dflags flat_expr
 904
 905                 -- Tidy it (temporary, until coreSat does cloning)
 906         ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
 907
 908                 -- Prepare for codegen
 909         ; prepd_expr <- corePrepExpr dflags tidy_expr
 910
 911                 -- Lint if necessary
 912                 -- ToDo: improve SrcLoc
 913         ; if lint_on then
 914                 case lintUnfolding noSrcLoc [] prepd_expr of
 915                    Just err -> pprPanic "compileExpr" err
 916                    Nothing  -> return ()
 917           else
 918                 return ()
 919
 920                 -- Convert to BCOs
 921         ; bcos <- coreExprToBCOs dflags prepd_expr
 922
 923                 -- link it
 924         ; hval <- linkExpr hsc_env bcos
 925
 926         ; return hval
 927      }
 928 #endif
 929 \end{code}
 930
 931
 932 %************************************************************************
 933 %*                                                                      *
 934         Statistics on reading interfaces
 935 %*                                                                      *
 936 %************************************************************************
 937
 938 \begin{code}
 939 dumpIfaceStats :: HscEnv -> IO ()
 940 dumpIfaceStats hsc_env
 941   = do  { eps <- readIORef (hsc_EPS hsc_env)
 942         ; dumpIfSet (dump_if_trace || dump_rn_stats)
 943                     "Interface statistics"
 944                     (ifaceStats eps) }
 945   where
 946     dflags = hsc_dflags hsc_env
 947     dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
 948     dump_if_trace = dopt Opt_D_dump_if_trace dflags
 949 \end{code}
 950
 951 %************************************************************************
 952 %*                                                                      *
 953         Progress Messages: Module i of n
 954 %*                                                                      *
 955 %************************************************************************
 956
 957 \begin{code}
 958 showModuleIndex Nothing = ""
 959 showModuleIndex (Just (i,n)) = "[" ++ padded ++ " of " ++ n_str ++ "] "
 960     where
 961         n_str = show n
 962         i_str = show i
 963         padded = replicate (length n_str - length i_str) ' ' ++ i_str
 964 \end{code}
 965