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(..), LStmt, LHsType )
  29 import CodeOutput       ( outputForeignStubs )
  30 import ByteCodeGen      ( byteCodeGen, coreExprToBCOs )
  31 import Linker           ( HValue, linkExpr )
  32 import CoreSyn          ( CoreExpr )
  33 import CoreTidy         ( tidyExpr )
  34 import CorePrep         ( corePrepExpr )
  35 import Flattening       ( flattenExpr )
  36 import Desugar          ( deSugarExpr )
  37 import SimplCore        ( simplifyExpr )
  38 import TcRnDriver       ( tcRnStmt, tcRnExpr, tcRnType )
  39 import Type             ( Type )
  40 import PrelNames        ( iNTERACTIVE )
  41 import {- Kind parts of -} Type         ( Kind )
  42 import CoreLint         ( lintUnfolding )
  43 import DsMeta           ( templateHaskellNames )
  44 import SrcLoc           ( SrcSpan, noSrcLoc, interactiveSrcLoc, srcLocSpan )
  45 import VarSet
  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 CoreSyn
  55 import SrcLoc           ( Located(..) )
  56 import StringBuffer     ( hGetStringBuffer, stringToStringBuffer )
  57 import Parser
  58 import Lexer
  59 import SrcLoc           ( mkSrcLoc )
  60 import TcRnDriver       ( tcRnModule, tcRnExtCore )
  61 import TcIface          ( typecheckIface )
  62 import TcRnMonad        ( initIfaceCheck, TcGblEnv(..) )
  63 import IfaceEnv         ( initNameCache )
  64 import LoadIface        ( ifaceStats, initExternalPackageState )
  65 import PrelInfo         ( wiredInThings, basicKnownKeyNames )
  66 import MkIface          ( checkOldIface, mkIface, writeIfaceFile )
  67 import Desugar          ( deSugar )
  68 import Flattening       ( flatten )
  69 import SimplCore        ( core2core )
  70 import TidyPgm          ( tidyProgram, mkBootModDetails )
  71 import CorePrep         ( corePrepPgm )
  72 import CoreToStg        ( coreToStg )
  73 import TyCon            ( isDataTyCon )
  74 import Name             ( Name, NamedThing(..) )
  75 import SimplStg         ( stg2stg )
  76 import CodeGen          ( codeGen )
  77 import CmmParse         ( parseCmmFile )
  78 import CmmCPS
  79 import CmmInfo
  80 import CodeOutput       ( codeOutput )
  81 import NameEnv          ( emptyNameEnv )
  82
  83 import DynFlags
  84 import ErrUtils
  85 import UniqSupply       ( mkSplitUniqSupply )
  86
  87 import Outputable
  88 import HscStats         ( ppSourceStats )
  89 import HscTypes
  90 import MkExternalCore   ( emitExternalCore )
  91 import ParserCore
  92 import ParserCoreUtils
  93 import FastString
  94 import UniqFM           ( emptyUFM )
  95 import Bag              ( unitBag )
  96
  97 import Control.Monad
  98 import System.Exit
  99 import System.IO
 100 import Data.IORef
 101 \end{code}
 102
 103
 104 %************************************************************************
 105 %*                                                                      *
 106                 Initialisation
 107 %*                                                                      *
 108 %************************************************************************
 109
 110 \begin{code}
 111 newHscEnv :: DynFlags -> IO HscEnv
 112 newHscEnv dflags
 113   = do  { eps_var <- newIORef initExternalPackageState
 114         ; us      <- mkSplitUniqSupply 'r'
 115         ; nc_var  <- newIORef (initNameCache us knownKeyNames)
 116         ; fc_var  <- newIORef emptyUFM
 117         ; mlc_var  <- newIORef emptyModuleEnv
 118         ; return (HscEnv { hsc_dflags = dflags,
 119                            hsc_targets = [],
 120                            hsc_mod_graph = [],
 121                            hsc_IC     = emptyInteractiveContext,
 122                            hsc_HPT    = emptyHomePackageTable,
 123                            hsc_EPS    = eps_var,
 124                            hsc_NC     = nc_var,
 125                            hsc_FC     = fc_var,
 126                            hsc_MLC    = mlc_var,
 127                            hsc_global_rdr_env = emptyGlobalRdrEnv,
 128                            hsc_global_type_env = emptyNameEnv } ) }
 129
 130
 131 knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta,
 132                         -- where templateHaskellNames are defined
 133 knownKeyNames = map getName wiredInThings
 134               ++ basicKnownKeyNames
 135 #ifdef GHCI
 136               ++ templateHaskellNames
 137 #endif
 138 \end{code}
 139
 140
 141 %************************************************************************
 142 %*                                                                      *
 143                 The main compiler pipeline
 144 %*                                                                      *
 145 %************************************************************************
 146
 147                    --------------------------------
 148                         The compilation proper
 149                    --------------------------------
 150
 151
 152 It's the task of the compilation proper to compile Haskell, hs-boot and
 153 core files to either byte-code, hard-code (C, asm, Java, ect) or to
 154 nothing at all (the module is still parsed and type-checked. This
 155 feature is mostly used by IDE's and the likes).
 156 Compilation can happen in either 'one-shot', 'batch', 'nothing',
 157 or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch' mode
 158 targets hard-code, 'nothing' mode targets nothing and 'interactive' mode
 159 targets byte-code.
 160 The modes are kept separate because of their different types and meanings.
 161 In 'one-shot' mode, we're only compiling a single file and can therefore
 162 discard the new ModIface and ModDetails. This is also the reason it only
 163 targets hard-code; compiling to byte-code or nothing doesn't make sense
 164 when we discard the result.
 165 'Batch' mode is like 'one-shot' except that we keep the resulting ModIface
 166 and ModDetails. 'Batch' mode doesn't target byte-code since that require
 167 us to return the newly compiled byte-code.
 168 'Nothing' mode has exactly the same type as 'batch' mode but they're still
 169 kept separate. This is because compiling to nothing is fairly special: We
 170 don't output any interface files, we don't run the simplifier and we don't
 171 generate any code.
 172 'Interactive' mode is similar to 'batch' mode except that we return the
 173 compiled byte-code together with the ModIface and ModDetails.
 174
 175 Trying to compile a hs-boot file to byte-code will result in a run-time
 176 error. This is the only thing that isn't caught by the type-system.
 177
 178 \begin{code}
 179
 180 data HscChecked
 181     = HscChecked
 182         -- parsed
 183         (Located (HsModule RdrName))
 184         -- renamed
 185         (Maybe (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
 186                 Maybe (HsDoc Name), HaddockModInfo Name))
 187         -- typechecked
 188         (Maybe (LHsBinds Id, GlobalRdrEnv, ModDetails))
 189         -- desugared
 190         (Maybe [CoreBind])
 191
 192 -- Status of a compilation to hard-code or nothing.
 193 data HscStatus
 194     = HscNoRecomp
 195     | HscRecomp  Bool -- Has stub files.
 196                       -- This is a hack. We can't compile C files here
 197                       -- since it's done in DriverPipeline. For now we
 198                       -- just return True if we want the caller to compile
 199                       -- them for us.
 200
 201 -- Status of a compilation to byte-code.
 202 data InteractiveStatus
 203     = InteractiveNoRecomp
 204     | InteractiveRecomp Bool     -- Same as HscStatus
 205                         CompiledByteCode
 206
 207
 208 -- I want Control.Monad.State! --Lemmih 03/07/2006
 209 newtype Comp a = Comp {runComp :: CompState -> IO (a, CompState)}
 210
 211 instance Monad Comp where
 212     g >>= fn = Comp $ \s -> runComp g s >>= \(a,s') -> runComp (fn a) s'
 213     return a = Comp $ \s -> return (a,s)
 214     fail = error
 215
 216 evalComp :: Comp a -> CompState -> IO a
 217 evalComp comp st = do (val,_st') <- runComp comp st
 218                       return val
 219
 220 data CompState
 221     = CompState
 222     { compHscEnv     :: HscEnv
 223     , compModSummary :: ModSummary
 224     , compOldIface   :: Maybe ModIface
 225     }
 226
 227 get :: Comp CompState
 228 get = Comp $ \s -> return (s,s)
 229
 230 modify :: (CompState -> CompState) -> Comp ()
 231 modify f = Comp $ \s -> return ((), f s)
 232
 233 gets :: (CompState -> a) -> Comp a
 234 gets getter = do st <- get
 235                  return (getter st)
 236
 237 liftIO :: IO a -> Comp a
 238 liftIO ioA = Comp $ \s -> do a <- ioA
 239                              return (a,s)
 240
 241 type NoRecomp result = ModIface -> Comp result
 242 type FrontEnd core = Comp (Maybe core)
 243
 244 -- FIXME: The old interface and module index are only using in 'batch' and
 245 --        'interactive' mode. They should be removed from 'oneshot' mode.
 246 type Compiler result =  HscEnv
 247                      -> ModSummary
 248                      -> Bool                -- True <=> source unchanged
 249                      -> Maybe ModIface      -- Old interface, if available
 250                      -> Maybe (Int,Int)     -- Just (i,n) <=> module i of n (for msgs)
 251                      -> IO (Maybe result)
 252
 253
 254 -- This functions checks if recompilation is necessary and
 255 -- then combines the FrontEnd and BackEnd to a working compiler.
 256 hscMkCompiler :: NoRecomp result         -- What to do when recompilation isn't required.
 257               -> (Maybe (Int,Int) -> Bool -> Comp ())
 258               -> FrontEnd core
 259               -> (core -> Comp result)   -- Backend.
 260               -> Compiler result
 261 hscMkCompiler norecomp messenger frontend backend
 262               hsc_env mod_summary source_unchanged
 263               mbOldIface mbModIndex
 264     = flip evalComp (CompState hsc_env mod_summary mbOldIface) $
 265       do (recomp_reqd, mbCheckedIface)
 266              <- {-# SCC "checkOldIface" #-}
 267                 liftIO $ checkOldIface hsc_env mod_summary
 268                               source_unchanged mbOldIface
 269          -- save the interface that comes back from checkOldIface.
 270          -- In one-shot mode we don't have the old iface until this
 271          -- point, when checkOldIface reads it from the disk.
 272          modify (\s -> s{ compOldIface = mbCheckedIface })
 273          case mbCheckedIface of
 274            Just iface | not recomp_reqd
 275                -> do messenger mbModIndex False
 276                      result <- norecomp iface
 277                      return (Just result)
 278            _otherwise
 279                -> do messenger mbModIndex True
 280                      mbCore <- frontend
 281                      case mbCore of
 282                        Nothing
 283                            -> return Nothing
 284                        Just core
 285                            -> do result <- backend core
 286                                  return (Just result)
 287
 288 --------------------------------------------------------------
 289 -- Compilers
 290 --------------------------------------------------------------
 291
 292 --        1         2         3         4         5         6         7         8          9
 293 -- Compile Haskell, boot and extCore in OneShot mode.
 294 hscCompileOneShot :: Compiler HscStatus
 295 hscCompileOneShot = hscCompileHardCode norecompOneShot oneShotMsg hscOneShot (hscConst (HscRecomp False))
 296
 297 -- Compile Haskell, boot and extCore in batch mode.
 298 hscCompileBatch :: Compiler (HscStatus, ModIface, ModDetails)
 299 hscCompileBatch = hscCompileHardCode norecompBatch batchMsg hscBatch hscNothing
 300
 301 -- Compile to hardcode (C,asm,...). This general structure is shared by OneShot and Batch.
 302 hscCompileHardCode :: NoRecomp result                                  -- No recomp necessary
 303                    -> (Maybe (Int,Int) -> Bool -> Comp ())             -- Message callback
 304                    -> ((ModIface, ModDetails, CgGuts) -> Comp result)  -- Compile normal file
 305                    -> ((ModIface, ModDetails, ModGuts) -> Comp result) -- Compile boot file
 306                    -> Compiler result
 307 hscCompileHardCode norecomp msg compNormal compBoot hsc_env mod_summary =
 308     compiler hsc_env mod_summary
 309     where mkComp = hscMkCompiler norecomp msg
 310           -- How to compile nonBoot files.
 311           nonBootComp inp = hscSimplify inp >>= hscNormalIface >>=
 312                             hscWriteIface >>= compNormal
 313           -- How to compile boot files.
 314           bootComp inp = hscSimpleIface inp >>= hscWriteIface >>= compBoot
 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) >= 2
 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 (ms_location mod_summary) 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,
 587                      cg_hpc_info = hpc_info } = cgguts
 588              dflags = hsc_dflags hsc_env
 589              location = ms_location mod_summary
 590              data_tycons = filter isDataTyCon tycons
 591              -- cg_tycons includes newtypes, for the benefit of External Core,
 592              -- but we don't generate any code for newtypes
 593
 594          -------------------
 595          -- PREPARE FOR CODE GENERATION
 596          -- Do saturation and convert to A-normal form
 597          prepd_binds <- {-# SCC "CorePrep" #-}
 598                         corePrepPgm dflags core_binds data_tycons ;
 599          -----------------  Convert to STG ------------------
 600          (stg_binds, cost_centre_info)
 601              <- {-# SCC "CoreToStg" #-}
 602                 myCoreToStg dflags this_mod prepd_binds
 603          ------------------  Code generation ------------------
 604          abstractC <- {-# SCC "CodeGen" #-}
 605                       codeGen dflags this_mod data_tycons
 606                               foreign_stubs dir_imps cost_centre_info
 607                               stg_binds hpc_info
 608          ------------------  Convert to CPS --------------------
 609          --continuationC <- cmmCPS dflags abstractC
 610          continuationC <- cmmToRawCmm abstractC
 611          ------------------  Code output -----------------------
 612          (stub_h_exists,stub_c_exists)
 613              <- codeOutput dflags this_mod location foreign_stubs
 614                 dependencies continuationC
 615          return stub_c_exists
 616
 617 hscConst :: b -> a -> Comp b
 618 hscConst b a = return b
 619
 620 hscInteractive :: (ModIface, ModDetails, CgGuts)
 621                -> Comp (InteractiveStatus, ModIface, ModDetails)
 622 hscInteractive (iface, details, cgguts)
 623 #ifdef GHCI
 624     = do hsc_env <- gets compHscEnv
 625          mod_summary <- gets compModSummary
 626          liftIO $ do
 627          let CgGuts{ -- This is the last use of the ModGuts in a compilation.
 628                      -- From now on, we just use the bits we need.
 629                      cg_module   = this_mod,
 630                      cg_binds    = core_binds,
 631                      cg_tycons   = tycons,
 632                      cg_foreign  = foreign_stubs } = cgguts
 633              dflags = hsc_dflags hsc_env
 634              location = ms_location mod_summary
 635              data_tycons = filter isDataTyCon tycons
 636              -- cg_tycons includes newtypes, for the benefit of External Core,
 637              -- but we don't generate any code for newtypes
 638
 639          -------------------
 640          -- PREPARE FOR CODE GENERATION
 641          -- Do saturation and convert to A-normal form
 642          prepd_binds <- {-# SCC "CorePrep" #-}
 643                         corePrepPgm dflags core_binds data_tycons ;
 644          -----------------  Generate byte code ------------------
 645          comp_bc <- byteCodeGen dflags prepd_binds data_tycons (md_modBreaks details)
 646          ------------------ Create f-x-dynamic C-side stuff ---
 647          (istub_h_exists, istub_c_exists)
 648              <- outputForeignStubs dflags this_mod location foreign_stubs
 649          return (InteractiveRecomp istub_c_exists comp_bc, iface, details)
 650 #else
 651     = panic "GHC not compiled with interpreter"
 652 #endif
 653
 654 ------------------------------
 655
 656 hscFileCheck :: HscEnv -> ModSummary -> Bool -> IO (Maybe HscChecked)
 657 hscFileCheck hsc_env mod_summary compileToCore = do {
 658             -------------------
 659             -- PARSE
 660             -------------------
 661         ; let dflags    = hsc_dflags hsc_env
 662               hspp_file = ms_hspp_file mod_summary
 663               hspp_buf  = ms_hspp_buf  mod_summary
 664
 665         ; maybe_parsed <- myParseModule dflags hspp_file hspp_buf
 666
 667         ; case maybe_parsed of {
 668              Left err -> do { printBagOfErrors dflags (unitBag err)
 669                             ; return Nothing } ;
 670              Right rdr_module -> do {
 671
 672             -------------------
 673             -- RENAME and TYPECHECK
 674             -------------------
 675           (tc_msgs, maybe_tc_result)
 676                 <- _scc_ "Typecheck-Rename"
 677                    tcRnModule hsc_env (ms_hsc_src mod_summary)
 678                         True{-save renamed syntax-}
 679                         rdr_module
 680
 681         ; printErrorsAndWarnings dflags tc_msgs
 682         ; case maybe_tc_result of {
 683              Nothing -> return (Just (HscChecked rdr_module Nothing Nothing Nothing));
 684              Just tc_result -> do
 685                 let type_env = tcg_type_env tc_result
 686                     md = ModDetails {
 687                                 md_types     = type_env,
 688                                 md_exports   = tcg_exports   tc_result,
 689                                 md_insts     = tcg_insts     tc_result,
 690                                 md_fam_insts = tcg_fam_insts tc_result,
 691                                 md_modBreaks = emptyModBreaks,
 692                                 md_rules     = [panic "no rules"],
 693                                    -- Rules are CoreRules, not the
 694                                    -- RuleDecls we get out of the typechecker
 695                                 md_vect_info =
 696                                   panic "HscMain.hscFileCheck: no VectInfo"
 697                                    -- VectInfo is added by the Core
 698                                    -- vectorisation pass
 699                           }
 700                     rnInfo = do decl <- tcg_rn_decls tc_result
 701                                 imports <- tcg_rn_imports tc_result
 702                                 let exports = tcg_rn_exports tc_result
 703                                 let doc = tcg_doc tc_result
 704                                     hmi = tcg_hmi tc_result
 705                                 return (decl,imports,exports,doc,hmi)
 706                 maybeModGuts <-
 707                  if compileToCore then
 708                    deSugar hsc_env (ms_location mod_summary) tc_result
 709                  else
 710                    return Nothing
 711                 return (Just (HscChecked rdr_module
 712                                    rnInfo
 713                                    (Just (tcg_binds tc_result,
 714                                           tcg_rdr_env tc_result,
 715                                           md))
 716                                    (fmap mg_binds maybeModGuts)))
 717         }}}}
 718
 719
 720 hscCmmFile :: DynFlags -> FilePath -> IO Bool
 721 hscCmmFile dflags filename = do
 722   maybe_cmm <- parseCmmFile dflags filename
 723   case maybe_cmm of
 724     Nothing -> return False
 725     Just cmm -> do
 726         --continuationC <- cmmCPS dflags [cmm]
 727         continuationC <- cmmToRawCmm [cmm]
 728         codeOutput dflags no_mod no_loc NoStubs [] continuationC
 729         return True
 730   where
 731         no_mod = panic "hscCmmFile: no_mod"
 732         no_loc = ModLocation{ ml_hs_file  = Just filename,
 733                               ml_hi_file  = panic "hscCmmFile: no hi file",
 734                               ml_obj_file = panic "hscCmmFile: no obj file" }
 735
 736
 737 myParseModule dflags src_filename maybe_src_buf
 738  =    --------------------------  Parser  ----------------
 739       showPass dflags "Parser" >>
 740       {-# SCC "Parser" #-} do
 741
 742         -- sometimes we already have the buffer in memory, perhaps
 743         -- because we needed to parse the imports out of it, or get the
 744         -- module name.
 745       buf <- case maybe_src_buf of
 746                 Just b  -> return b
 747                 Nothing -> hGetStringBuffer src_filename
 748
 749       let loc  = mkSrcLoc (mkFastString src_filename) 1 0
 750
 751       case unP parseModule (mkPState buf loc dflags) of {
 752
 753         PFailed span err -> return (Left (mkPlainErrMsg span err));
 754
 755         POk pst rdr_module -> do {
 756
 757       let {ms = getMessages pst};
 758       printErrorsAndWarnings dflags ms;
 759       when (errorsFound dflags ms) $ exitWith (ExitFailure 1);
 760
 761       dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
 762
 763       dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"
 764                            (ppSourceStats False rdr_module) ;
 765
 766       return (Right rdr_module)
 767         -- ToDo: free the string buffer later.
 768       }}
 769
 770
 771 myCoreToStg dflags this_mod prepd_binds
 772  = do
 773       stg_binds <- {-# SCC "Core2Stg" #-}
 774              coreToStg (thisPackage dflags) prepd_binds
 775
 776       (stg_binds2, cost_centre_info) <- {-# SCC "Stg2Stg" #-}
 777              stg2stg dflags this_mod stg_binds
 778
 779       return (stg_binds2, cost_centre_info)
 780 \end{code}
 781
 782
 783 %************************************************************************
 784 %*                                                                      *
 785 \subsection{Compiling a do-statement}
 786 %*                                                                      *
 787 %************************************************************************
 788
 789 When the UnlinkedBCOExpr is linked you get an HValue of type
 790         IO [HValue]
 791 When you run it you get a list of HValues that should be
 792 the same length as the list of names; add them to the ClosureEnv.
 793
 794 A naked expression returns a singleton Name [it].
 795
 796         What you type                   The IO [HValue] that hscStmt returns
 797         -------------                   ------------------------------------
 798         let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
 799                                         bindings: [x,y,...]
 800
 801         pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
 802                                         bindings: [x,y,...]
 803
 804         expr (of IO type)       ==>     expr >>= \ v -> return [v]
 805           [NB: result not printed]      bindings: [it]
 806
 807
 808         expr (of non-IO type,
 809           result showable)      ==>     let v = expr in print v >> return [v]
 810                                         bindings: [it]
 811
 812         expr (of non-IO type,
 813           result not showable)  ==>     error
 814
 815 \begin{code}
 816 #ifdef GHCI
 817 hscStmt         -- Compile a stmt all the way to an HValue, but don't run it
 818   :: HscEnv
 819   -> String                     -- The statement
 820   -> IO (Maybe ([Id], HValue))
 821
 822 hscStmt hsc_env stmt
 823   = do  { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt
 824         ; case maybe_stmt of {
 825              Nothing      -> return Nothing ;   -- Parse error
 826              Just Nothing -> return Nothing ;   -- Empty line
 827              Just (Just parsed_stmt) -> do {    -- The real stuff
 828
 829                 -- Rename and typecheck it
 830           let icontext = hsc_IC hsc_env
 831         ; maybe_tc_result <- tcRnStmt hsc_env icontext parsed_stmt
 832
 833         ; case maybe_tc_result of {
 834                 Nothing -> return Nothing ;
 835                 Just (ids, tc_expr) -> do {
 836
 837                 -- Desugar it
 838         ; let rdr_env  = ic_rn_gbl_env icontext
 839               type_env = mkTypeEnv (map AnId (ic_tmp_ids icontext))
 840         ; mb_ds_expr <- deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr
 841
 842         ; case mb_ds_expr of {
 843                 Nothing -> return Nothing ;
 844                 Just ds_expr -> do {
 845
 846                 -- Then desugar, code gen, and link it
 847         ; let src_span = srcLocSpan interactiveSrcLoc
 848         ; hval <- compileExpr hsc_env src_span ds_expr
 849
 850         ; return (Just (ids, hval))
 851         }}}}}}}
 852
 853 hscTcExpr       -- Typecheck an expression (but don't run it)
 854   :: HscEnv
 855   -> String                     -- The expression
 856   -> IO (Maybe Type)
 857
 858 hscTcExpr hsc_env expr
 859   = do  { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr
 860         ; let icontext = hsc_IC hsc_env
 861         ; case maybe_stmt of {
 862              Nothing      -> return Nothing ;   -- Parse error
 863              Just (Just (L _ (ExprStmt expr _ _)))
 864                         -> tcRnExpr hsc_env icontext expr ;
 865              Just other -> do { errorMsg (hsc_dflags hsc_env) (text "not an expression:" <+> quotes (text expr)) ;
 866                                 return Nothing } ;
 867              } }
 868
 869 hscKcType       -- Find the kind of a type
 870   :: HscEnv
 871   -> String                     -- The type
 872   -> IO (Maybe Kind)
 873
 874 hscKcType hsc_env str
 875   = do  { maybe_type <- hscParseType (hsc_dflags hsc_env) str
 876         ; let icontext = hsc_IC hsc_env
 877         ; case maybe_type of {
 878              Just ty -> tcRnType hsc_env icontext ty ;
 879              Nothing -> return Nothing } }
 880 #endif
 881 \end{code}
 882
 883 \begin{code}
 884 #ifdef GHCI
 885 hscParseStmt :: DynFlags -> String -> IO (Maybe (Maybe (LStmt RdrName)))
 886 hscParseStmt = hscParseThing parseStmt
 887
 888 hscParseType :: DynFlags -> String -> IO (Maybe (LHsType RdrName))
 889 hscParseType = hscParseThing parseType
 890 #endif
 891
 892 hscParseIdentifier :: DynFlags -> String -> IO (Maybe (Located RdrName))
 893 hscParseIdentifier = hscParseThing parseIdentifier
 894
 895 hscParseThing :: Outputable thing
 896               => Lexer.P thing
 897               -> DynFlags -> String
 898               -> IO (Maybe thing)
 899         -- Nothing => Parse error (message already printed)
 900         -- Just x  => success
 901 hscParseThing parser dflags str
 902  = showPass dflags "Parser" >>
 903       {-# SCC "Parser" #-} do
 904
 905       buf <- stringToStringBuffer str
 906
 907       let loc  = mkSrcLoc FSLIT("<interactive>") 1 0
 908
 909       case unP parser (mkPState buf loc dflags) of {
 910
 911         PFailed span err -> do { printError span err;
 912                                  return Nothing };
 913
 914         POk pst thing -> do {
 915
 916       let {ms = getMessages pst};
 917       printErrorsAndWarnings dflags ms;
 918       when (errorsFound dflags ms) $ exitWith (ExitFailure 1);
 919
 920       --ToDo: can't free the string buffer until we've finished this
 921       -- compilation sweep and all the identifiers have gone away.
 922       dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing);
 923       return (Just thing)
 924       }}
 925 \end{code}
 926
 927 %************************************************************************
 928 %*                                                                      *
 929         Desugar, simplify, convert to bytecode, and link an expression
 930 %*                                                                      *
 931 %************************************************************************
 932
 933 \begin{code}
 934 #ifdef GHCI
 935 compileExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
 936
 937 compileExpr hsc_env srcspan ds_expr
 938   = do  { let { dflags  = hsc_dflags hsc_env ;
 939                 lint_on = dopt Opt_DoCoreLinting dflags }
 940
 941                 -- Flatten it
 942         ; flat_expr <- flattenExpr hsc_env ds_expr
 943
 944                 -- Simplify it
 945         ; simpl_expr <- simplifyExpr dflags flat_expr
 946
 947                 -- Tidy it (temporary, until coreSat does cloning)
 948         ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
 949
 950                 -- Prepare for codegen
 951         ; prepd_expr <- corePrepExpr dflags tidy_expr
 952
 953                 -- Lint if necessary
 954                 -- ToDo: improve SrcLoc
 955         ; if lint_on then
 956                 let ictxt = hsc_IC hsc_env
 957                     tyvars = varSetElems (ic_tyvars ictxt)
 958                 in
 959                 case lintUnfolding noSrcLoc tyvars prepd_expr of
 960                    Just err -> pprPanic "compileExpr" err
 961                    Nothing  -> return ()
 962           else
 963                 return ()
 964
 965                 -- Convert to BCOs
 966         ; bcos <- coreExprToBCOs dflags prepd_expr
 967
 968                 -- link it
 969         ; hval <- linkExpr hsc_env srcspan bcos
 970
 971         ; return hval
 972      }
 973 #endif
 974 \end{code}
 975
 976
 977 %************************************************************************
 978 %*                                                                      *
 979         Statistics on reading interfaces
 980 %*                                                                      *
 981 %************************************************************************
 982
 983 \begin{code}
 984 dumpIfaceStats :: HscEnv -> IO ()
 985 dumpIfaceStats hsc_env
 986   = do  { eps <- readIORef (hsc_EPS hsc_env)
 987         ; dumpIfSet (dump_if_trace || dump_rn_stats)
 988                     "Interface statistics"
 989                     (ifaceStats eps) }
 990   where
 991     dflags = hsc_dflags hsc_env
 992     dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
 993     dump_if_trace = dopt Opt_D_dump_if_trace dflags
 994 \end{code}
 995
 996 %************************************************************************
 997 %*                                                                      *
 998         Progress Messages: Module i of n
 999 %*                                                                      *
1000 %************************************************************************
1001
1002 \begin{code}
1003 showModuleIndex Nothing = ""
1004 showModuleIndex (Just (i,n)) = "[" ++ padded ++ " of " ++ n_str ++ "] "
1005     where
1006         n_str = show n
1007         i_str = show i
1008         padded = replicate (length n_str - length i_str) ' ' ++ i_str
1009 \end{code}
1010