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 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 -- 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 False)
 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 True)
 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 :: Bool -> Maybe (Int,Int) -> Bool -> Comp ()
 381 batchMsg toInterp 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 (not toInterp) 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 hsc_env <- gets compHscEnv
 533          mod_summary <- gets compModSummary
 534          let writeIface = dopt Opt_WriteIface (hsc_dflags hsc_env)
 535          liftIO $ do
 536          unless (no_change || not writeIface)
 537            $ writeIfaceFile (ms_location mod_summary) iface
 538          return (iface, details, a)
 539
 540 hscIgnoreIface :: (ModIface, Bool, ModDetails, a) -> Comp (ModIface, ModDetails, a)
 541 hscIgnoreIface (iface, no_change, details, a)
 542     = return (iface, details, a)
 543
 544 -- Don't output any code.
 545 hscNothing :: (ModIface, ModDetails, a) -> Comp (HscStatus, ModIface, ModDetails)
 546 hscNothing (iface, details, a)
 547     = return (HscRecomp False, iface, details)
 548
 549 -- Generate code and return both the new ModIface and the ModDetails.
 550 hscBatch :: (ModIface, ModDetails, CgGuts) -> Comp (HscStatus, ModIface, ModDetails)
 551 hscBatch (iface, details, cgguts)
 552     = do hasStub <- hscCompile cgguts
 553          return (HscRecomp hasStub, iface, details)
 554
 555 -- Here we don't need the ModIface and ModDetails anymore.
 556 hscOneShot :: (ModIface, ModDetails, CgGuts) -> Comp HscStatus
 557 hscOneShot (_, _, cgguts)
 558     = do hasStub <- hscCompile cgguts
 559          return (HscRecomp hasStub)
 560
 561 -- Compile to hard-code.
 562 hscCompile :: CgGuts -> Comp Bool
 563 hscCompile cgguts
 564     = do hsc_env <- gets compHscEnv
 565          mod_summary <- gets compModSummary
 566          liftIO $ do
 567          let CgGuts{ -- This is the last use of the ModGuts in a compilation.
 568                      -- From now on, we just use the bits we need.
 569                      cg_module   = this_mod,
 570                      cg_binds    = core_binds,
 571                      cg_tycons   = tycons,
 572                      cg_dir_imps = dir_imps,
 573                      cg_foreign  = foreign_stubs,
 574                      cg_home_mods = home_mods,
 575                      cg_dep_pkgs = dependencies } = cgguts
 576              dflags = hsc_dflags hsc_env
 577              location = ms_location mod_summary
 578              data_tycons = filter isDataTyCon tycons
 579              -- cg_tycons includes newtypes, for the benefit of External Core,
 580              -- but we don't generate any code for newtypes
 581
 582          -------------------
 583          -- PREPARE FOR CODE GENERATION
 584          -- Do saturation and convert to A-normal form
 585          prepd_binds <- {-# SCC "CorePrep" #-}
 586                         corePrepPgm dflags core_binds data_tycons ;
 587          -----------------  Convert to STG ------------------
 588          (stg_binds, cost_centre_info)
 589              <- {-# SCC "CoreToStg" #-}
 590                 myCoreToStg dflags home_mods this_mod prepd_binds
 591          ------------------  Code generation ------------------
 592          abstractC <- {-# SCC "CodeGen" #-}
 593                       codeGen dflags home_mods this_mod data_tycons
 594                               foreign_stubs dir_imps cost_centre_info
 595                               stg_binds
 596          ------------------  Code output -----------------------
 597          (stub_h_exists,stub_c_exists)
 598              <- codeOutput dflags this_mod location foreign_stubs
 599                 dependencies abstractC
 600          return stub_c_exists
 601
 602 hscConst :: b -> a -> Comp b
 603 hscConst b a = return b
 604
 605 hscInteractive :: (ModIface, ModDetails, CgGuts)
 606                -> Comp (InteractiveStatus, ModIface, ModDetails)
 607 hscInteractive (iface, details, cgguts)
 608 #ifdef GHCI
 609     = do hsc_env <- gets compHscEnv
 610          mod_summary <- gets compModSummary
 611          liftIO $ do
 612          let CgGuts{ -- This is the last use of the ModGuts in a compilation.
 613                      -- From now on, we just use the bits we need.
 614                      cg_module   = this_mod,
 615                      cg_binds    = core_binds,
 616                      cg_tycons   = tycons,
 617                      cg_foreign  = foreign_stubs } = cgguts
 618              dflags = hsc_dflags hsc_env
 619              location = ms_location mod_summary
 620              data_tycons = filter isDataTyCon tycons
 621              -- cg_tycons includes newtypes, for the benefit of External Core,
 622              -- but we don't generate any code for newtypes
 623
 624          -------------------
 625          -- PREPARE FOR CODE GENERATION
 626          -- Do saturation and convert to A-normal form
 627          prepd_binds <- {-# SCC "CorePrep" #-}
 628                         corePrepPgm dflags core_binds data_tycons ;
 629          -----------------  Generate byte code ------------------
 630          comp_bc <- byteCodeGen dflags prepd_binds data_tycons
 631          ------------------ Create f-x-dynamic C-side stuff ---
 632          (istub_h_exists, istub_c_exists)
 633              <- outputForeignStubs dflags this_mod location foreign_stubs
 634          return (InteractiveRecomp istub_c_exists comp_bc, iface, details)
 635 #else
 636     = panic "GHC not compiled with interpreter"
 637 #endif
 638
 639 ------------------------------
 640
 641 hscFileCheck :: HscEnv -> ModSummary -> IO (Maybe HscChecked)
 642 hscFileCheck hsc_env mod_summary = do {
 643             -------------------
 644             -- PARSE
 645             -------------------
 646         ; let dflags    = hsc_dflags hsc_env
 647               hspp_file = ms_hspp_file mod_summary
 648               hspp_buf  = ms_hspp_buf  mod_summary
 649
 650         ; maybe_parsed <- myParseModule dflags hspp_file hspp_buf
 651
 652         ; case maybe_parsed of {
 653              Left err -> do { printBagOfErrors dflags (unitBag err)
 654                             ; return Nothing } ;
 655              Right rdr_module -> do {
 656
 657             -------------------
 658             -- RENAME and TYPECHECK
 659             -------------------
 660           (tc_msgs, maybe_tc_result)
 661                 <- _scc_ "Typecheck-Rename"
 662                    tcRnModule hsc_env (ms_hsc_src mod_summary)
 663                         True{-save renamed syntax-}
 664                         rdr_module
 665
 666         ; printErrorsAndWarnings dflags tc_msgs
 667         ; case maybe_tc_result of {
 668              Nothing -> return (Just (HscChecked rdr_module Nothing Nothing));
 669              Just tc_result -> do
 670                 let md = ModDetails {
 671                                 md_types   = tcg_type_env tc_result,
 672                                 md_exports = tcg_exports  tc_result,
 673                                 md_insts   = tcg_insts    tc_result,
 674                                 md_rules   = [panic "no rules"] }
 675                                    -- Rules are CoreRules, not the
 676                                    -- RuleDecls we get out of the typechecker
 677                     rnInfo = do decl <- tcg_rn_decls tc_result
 678                                 imports <- tcg_rn_imports tc_result
 679                                 let exports = tcg_rn_exports tc_result
 680                                 return (decl,imports,exports)
 681                 return (Just (HscChecked rdr_module
 682                                    rnInfo
 683                                    (Just (tcg_binds tc_result,
 684                                           tcg_rdr_env tc_result,
 685                                           md))))
 686         }}}}
 687
 688
 689 hscCmmFile :: DynFlags -> FilePath -> IO Bool
 690 hscCmmFile dflags filename = do
 691   maybe_cmm <- parseCmmFile dflags (mkHomeModules []) filename
 692   case maybe_cmm of
 693     Nothing -> return False
 694     Just cmm -> do
 695         codeOutput dflags no_mod no_loc NoStubs [] [cmm]
 696         return True
 697   where
 698         no_mod = panic "hscCmmFile: no_mod"
 699         no_loc = ModLocation{ ml_hs_file  = Just filename,
 700                               ml_hi_file  = panic "hscCmmFile: no hi file",
 701                               ml_obj_file = panic "hscCmmFile: no obj file" }
 702
 703
 704 myParseModule dflags src_filename maybe_src_buf
 705  =    --------------------------  Parser  ----------------
 706       showPass dflags "Parser" >>
 707       {-# SCC "Parser" #-} do
 708
 709         -- sometimes we already have the buffer in memory, perhaps
 710         -- because we needed to parse the imports out of it, or get the
 711         -- module name.
 712       buf <- case maybe_src_buf of
 713                 Just b  -> return b
 714                 Nothing -> hGetStringBuffer src_filename
 715
 716       let loc  = mkSrcLoc (mkFastString src_filename) 1 0
 717
 718       case unP parseModule (mkPState buf loc dflags) of {
 719
 720         PFailed span err -> return (Left (mkPlainErrMsg span err));
 721
 722         POk _ rdr_module -> do {
 723
 724       dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
 725
 726       dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"
 727                            (ppSourceStats False rdr_module) ;
 728
 729       return (Right rdr_module)
 730         -- ToDo: free the string buffer later.
 731       }}
 732
 733
 734 myCoreToStg dflags home_mods this_mod prepd_binds
 735  = do
 736       stg_binds <- {-# SCC "Core2Stg" #-}
 737              coreToStg home_mods prepd_binds
 738
 739       (stg_binds2, cost_centre_info) <- {-# SCC "Stg2Stg" #-}
 740              stg2stg dflags home_mods this_mod stg_binds
 741
 742       return (stg_binds2, cost_centre_info)
 743 \end{code}
 744
 745
 746 %************************************************************************
 747 %*                                                                      *
 748 \subsection{Compiling a do-statement}
 749 %*                                                                      *
 750 %************************************************************************
 751
 752 When the UnlinkedBCOExpr is linked you get an HValue of type
 753         IO [HValue]
 754 When you run it you get a list of HValues that should be
 755 the same length as the list of names; add them to the ClosureEnv.
 756
 757 A naked expression returns a singleton Name [it].
 758
 759         What you type                   The IO [HValue] that hscStmt returns
 760         -------------                   ------------------------------------
 761         let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
 762                                         bindings: [x,y,...]
 763
 764         pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
 765                                         bindings: [x,y,...]
 766
 767         expr (of IO type)       ==>     expr >>= \ v -> return [v]
 768           [NB: result not printed]      bindings: [it]
 769
 770
 771         expr (of non-IO type,
 772           result showable)      ==>     let v = expr in print v >> return [v]
 773                                         bindings: [it]
 774
 775         expr (of non-IO type,
 776           result not showable)  ==>     error
 777
 778 \begin{code}
 779 #ifdef GHCI
 780 hscStmt         -- Compile a stmt all the way to an HValue, but don't run it
 781   :: HscEnv
 782   -> String                     -- The statement
 783   -> IO (Maybe (HscEnv, [Name], HValue))
 784
 785 hscStmt hsc_env stmt
 786   = do  { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt
 787         ; case maybe_stmt of {
 788              Nothing      -> return Nothing ;   -- Parse error
 789              Just Nothing -> return Nothing ;   -- Empty line
 790              Just (Just parsed_stmt) -> do {    -- The real stuff
 791
 792                 -- Rename and typecheck it
 793           let icontext = hsc_IC hsc_env
 794         ; maybe_tc_result <- tcRnStmt hsc_env icontext parsed_stmt
 795
 796         ; case maybe_tc_result of {
 797                 Nothing -> return Nothing ;
 798                 Just (new_ic, bound_names, tc_expr) -> do {
 799
 800                 -- Then desugar, code gen, and link it
 801         ; hval <- compileExpr hsc_env iNTERACTIVE
 802                               (ic_rn_gbl_env new_ic)
 803                               (ic_type_env new_ic)
 804                               tc_expr
 805
 806         ; return (Just (hsc_env{ hsc_IC=new_ic }, bound_names, hval))
 807         }}}}}
 808
 809 hscTcExpr       -- Typecheck an expression (but don't run it)
 810   :: HscEnv
 811   -> String                     -- The expression
 812   -> IO (Maybe Type)
 813
 814 hscTcExpr hsc_env expr
 815   = do  { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr
 816         ; let icontext = hsc_IC hsc_env
 817         ; case maybe_stmt of {
 818              Nothing      -> return Nothing ;   -- Parse error
 819              Just (Just (L _ (ExprStmt expr _ _)))
 820                         -> tcRnExpr hsc_env icontext expr ;
 821              Just other -> do { errorMsg (hsc_dflags hsc_env) (text "not an expression:" <+> quotes (text expr)) ;
 822                                 return Nothing } ;
 823              } }
 824
 825 hscKcType       -- Find the kind of a type
 826   :: HscEnv
 827   -> String                     -- The type
 828   -> IO (Maybe Kind)
 829
 830 hscKcType hsc_env str
 831   = do  { maybe_type <- hscParseType (hsc_dflags hsc_env) str
 832         ; let icontext = hsc_IC hsc_env
 833         ; case maybe_type of {
 834              Just ty    -> tcRnType hsc_env icontext ty ;
 835              Just other -> do { errorMsg (hsc_dflags hsc_env) (text "not an type:" <+> quotes (text str)) ;
 836                                 return Nothing } ;
 837              Nothing    -> return Nothing } }
 838 #endif
 839 \end{code}
 840
 841 \begin{code}
 842 #ifdef GHCI
 843 hscParseStmt :: DynFlags -> String -> IO (Maybe (Maybe (LStmt RdrName)))
 844 hscParseStmt = hscParseThing parseStmt
 845
 846 hscParseType :: DynFlags -> String -> IO (Maybe (LHsType RdrName))
 847 hscParseType = hscParseThing parseType
 848 #endif
 849
 850 hscParseIdentifier :: DynFlags -> String -> IO (Maybe (Located RdrName))
 851 hscParseIdentifier = hscParseThing parseIdentifier
 852
 853 hscParseThing :: Outputable thing
 854               => Lexer.P thing
 855               -> DynFlags -> String
 856               -> IO (Maybe thing)
 857         -- Nothing => Parse error (message already printed)
 858         -- Just x  => success
 859 hscParseThing parser dflags str
 860  = showPass dflags "Parser" >>
 861       {-# SCC "Parser" #-} do
 862
 863       buf <- stringToStringBuffer str
 864
 865       let loc  = mkSrcLoc FSLIT("<interactive>") 1 0
 866
 867       case unP parser (mkPState buf loc dflags) of {
 868
 869         PFailed span err -> do { printError span err;
 870                                  return Nothing };
 871
 872         POk _ thing -> do {
 873
 874       --ToDo: can't free the string buffer until we've finished this
 875       -- compilation sweep and all the identifiers have gone away.
 876       dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing);
 877       return (Just thing)
 878       }}
 879 \end{code}
 880
 881 %************************************************************************
 882 %*                                                                      *
 883         Desugar, simplify, convert to bytecode, and link an expression
 884 %*                                                                      *
 885 %************************************************************************
 886
 887 \begin{code}
 888 #ifdef GHCI
 889 compileExpr :: HscEnv
 890             -> Module -> GlobalRdrEnv -> TypeEnv
 891             -> LHsExpr Id
 892             -> IO HValue
 893
 894 compileExpr hsc_env this_mod rdr_env type_env tc_expr
 895   = do  { let { dflags  = hsc_dflags hsc_env ;
 896                 lint_on = dopt Opt_DoCoreLinting dflags }
 897
 898                 -- Desugar it
 899         ; ds_expr <- deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
 900
 901                 -- Flatten it
 902         ; flat_expr <- flattenExpr hsc_env ds_expr
 903
 904                 -- Simplify it
 905         ; simpl_expr <- simplifyExpr dflags flat_expr
 906
 907                 -- Tidy it (temporary, until coreSat does cloning)
 908         ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
 909
 910                 -- Prepare for codegen
 911         ; prepd_expr <- corePrepExpr dflags tidy_expr
 912
 913                 -- Lint if necessary
 914                 -- ToDo: improve SrcLoc
 915         ; if lint_on then
 916                 case lintUnfolding noSrcLoc [] prepd_expr of
 917                    Just err -> pprPanic "compileExpr" err
 918                    Nothing  -> return ()
 919           else
 920                 return ()
 921
 922                 -- Convert to BCOs
 923         ; bcos <- coreExprToBCOs dflags prepd_expr
 924
 925                 -- link it
 926         ; hval <- linkExpr hsc_env bcos
 927
 928         ; return hval
 929      }
 930 #endif
 931 \end{code}
 932
 933
 934 %************************************************************************
 935 %*                                                                      *
 936         Statistics on reading interfaces
 937 %*                                                                      *
 938 %************************************************************************
 939
 940 \begin{code}
 941 dumpIfaceStats :: HscEnv -> IO ()
 942 dumpIfaceStats hsc_env
 943   = do  { eps <- readIORef (hsc_EPS hsc_env)
 944         ; dumpIfSet (dump_if_trace || dump_rn_stats)
 945                     "Interface statistics"
 946                     (ifaceStats eps) }
 947   where
 948     dflags = hsc_dflags hsc_env
 949     dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
 950     dump_if_trace = dopt Opt_D_dump_if_trace dflags
 951 \end{code}
 952
 953 %************************************************************************
 954 %*                                                                      *
 955         Progress Messages: Module i of n
 956 %*                                                                      *
 957 %************************************************************************
 958
 959 \begin{code}
 960 showModuleIndex Nothing = ""
 961 showModuleIndex (Just (i,n)) = "[" ++ padded ++ " of " ++ n_str ++ "] "
 962     where
 963         n_str = show n
 964         i_str = show i
 965         padded = replicate (length n_str - length i_str) ' ' ++ i_str
 966 \end{code}
 967