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