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