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