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