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