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 CoreModule)
 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 ->
 693                                             (CoreModule { cm_module = mg_module mg,
 694                                                           cm_types  = mg_types mg,
 695                                                           cm_binds  = mg_binds mg}))
 696                                     maybeModGuts)))
 697         }}}}
 698
 699
 700 hscCmmFile :: DynFlags -> FilePath -> IO Bool
 701 hscCmmFile dflags filename = do
 702   maybe_cmm <- parseCmmFile dflags filename
 703   case maybe_cmm of
 704     Nothing -> return False
 705     Just cmm -> do
 706         cmms <- optionallyConvertAndOrCPS dflags [cmm]
 707         rawCmms <- cmmToRawCmm cmms
 708         codeOutput dflags no_mod no_loc NoStubs [] rawCmms
 709         return True
 710   where
 711         no_mod = panic "hscCmmFile: no_mod"
 712         no_loc = ModLocation{ ml_hs_file  = Just filename,
 713                               ml_hi_file  = panic "hscCmmFile: no hi file",
 714                               ml_obj_file = panic "hscCmmFile: no obj file" }
 715
 716 optionallyConvertAndOrCPS :: DynFlags -> [Cmm] -> IO [Cmm]
 717 optionallyConvertAndOrCPS dflags cmms =
 718     do   --------  Optionally convert to and from zipper ------
 719        cmms <- if dopt Opt_ConvertToZipCfgAndBack dflags
 720                then mapM (testCmmConversion dflags) cmms
 721                else return cmms
 722          ---------  Optionally convert to CPS (MDA) -----------
 723        cmms <- if not (dopt Opt_ConvertToZipCfgAndBack dflags) &&
 724                   dopt Opt_RunCPSZ dflags
 725                then cmmCPS dflags cmms
 726                else return cmms
 727        return cmms
 728
 729
 730 testCmmConversion :: DynFlags -> Cmm -> IO Cmm
 731 testCmmConversion dflags cmm =
 732     do showPass dflags "CmmToCmm"
 733        dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (ppr cmm)
 734        --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm
 735        us <- mkSplitUniqSupply 'C'
 736        let cfopts = runTx $ runCmmOpts cmmCfgOptsZ
 737        let cvtm = do g <- cmmToZgraph cmm
 738                      return $ cfopts g
 739        let zgraph = initUs_ us cvtm
 740        cps_zgraph <- protoCmmCPSZ dflags zgraph
 741        let chosen_graph = if dopt Opt_RunCPSZ dflags then cps_zgraph else zgraph
 742        dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (ppr chosen_graph)
 743        showPass dflags "Convert from Z back to Cmm"
 744        let cvt = cmmOfZgraph $ cfopts $ chosen_graph
 745        dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (ppr cvt)
 746        return cvt
 747        -- return cmm -- don't use the conversion
 748
 749 myParseModule :: DynFlags -> FilePath -> Maybe StringBuffer
 750               -> IO (Either ErrMsg (Located (HsModule RdrName)))
 751 myParseModule dflags src_filename maybe_src_buf
 752  =    --------------------------  Parser  ----------------
 753       showPass dflags "Parser" >>
 754       {-# SCC "Parser" #-} do
 755
 756         -- sometimes we already have the buffer in memory, perhaps
 757         -- because we needed to parse the imports out of it, or get the
 758         -- module name.
 759       buf <- case maybe_src_buf of
 760                 Just b  -> return b
 761                 Nothing -> hGetStringBuffer src_filename
 762
 763       let loc  = mkSrcLoc (mkFastString src_filename) 1 0
 764
 765       case unP parseModule (mkPState buf loc dflags) of {
 766
 767         PFailed span err -> return (Left (mkPlainErrMsg span err));
 768
 769         POk pst rdr_module -> do {
 770
 771       let {ms = getMessages pst};
 772       printErrorsAndWarnings dflags ms;
 773       when (errorsFound dflags ms) $ exitWith (ExitFailure 1);
 774
 775       dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
 776
 777       dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"
 778                            (ppSourceStats False rdr_module) ;
 779
 780       return (Right rdr_module)
 781         -- ToDo: free the string buffer later.
 782       }}
 783
 784
 785 myCoreToStg :: DynFlags -> Module -> [CoreBind]
 786             -> IO ( [(StgBinding,[(Id,[Id])])]  -- output program
 787                   , CollectedCCs) -- cost centre info (declared and used)
 788
 789 myCoreToStg dflags this_mod prepd_binds
 790  = do
 791       stg_binds <- {-# SCC "Core2Stg" #-}
 792              coreToStg (thisPackage dflags) prepd_binds
 793
 794       (stg_binds2, cost_centre_info) <- {-# SCC "Stg2Stg" #-}
 795              stg2stg dflags this_mod stg_binds
 796
 797       return (stg_binds2, cost_centre_info)
 798 \end{code}
 799
 800
 801 %************************************************************************
 802 %*                                                                      *
 803 \subsection{Compiling a do-statement}
 804 %*                                                                      *
 805 %************************************************************************
 806
 807 When the UnlinkedBCOExpr is linked you get an HValue of type
 808         IO [HValue]
 809 When you run it you get a list of HValues that should be
 810 the same length as the list of names; add them to the ClosureEnv.
 811
 812 A naked expression returns a singleton Name [it].
 813
 814         What you type                   The IO [HValue] that hscStmt returns
 815         -------------                   ------------------------------------
 816         let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
 817                                         bindings: [x,y,...]
 818
 819         pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
 820                                         bindings: [x,y,...]
 821
 822         expr (of IO type)       ==>     expr >>= \ v -> return [v]
 823           [NB: result not printed]      bindings: [it]
 824
 825
 826         expr (of non-IO type,
 827           result showable)      ==>     let v = expr in print v >> return [v]
 828                                         bindings: [it]
 829
 830         expr (of non-IO type,
 831           result not showable)  ==>     error
 832
 833 \begin{code}
 834 #ifdef GHCI
 835 hscStmt         -- Compile a stmt all the way to an HValue, but don't run it
 836   :: HscEnv
 837   -> String                     -- The statement
 838   -> IO (Maybe ([Id], HValue))
 839
 840 hscStmt hsc_env stmt
 841   = do  { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt
 842         ; case maybe_stmt of {
 843              Nothing      -> return Nothing ;   -- Parse error
 844              Just Nothing -> return Nothing ;   -- Empty line
 845              Just (Just parsed_stmt) -> do {    -- The real stuff
 846
 847                 -- Rename and typecheck it
 848           let icontext = hsc_IC hsc_env
 849         ; maybe_tc_result <- tcRnStmt hsc_env icontext parsed_stmt
 850
 851         ; case maybe_tc_result of {
 852                 Nothing -> return Nothing ;
 853                 Just (ids, tc_expr) -> do {
 854
 855                 -- Desugar it
 856         ; let rdr_env  = ic_rn_gbl_env icontext
 857               type_env = mkTypeEnv (map AnId (ic_tmp_ids icontext))
 858         ; mb_ds_expr <- deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr
 859
 860         ; case mb_ds_expr of {
 861                 Nothing -> return Nothing ;
 862                 Just ds_expr -> do {
 863
 864                 -- Then desugar, code gen, and link it
 865         ; let src_span = srcLocSpan interactiveSrcLoc
 866         ; hval <- compileExpr hsc_env src_span ds_expr
 867
 868         ; return (Just (ids, hval))
 869         }}}}}}}
 870
 871 hscTcExpr       -- Typecheck an expression (but don't run it)
 872   :: HscEnv
 873   -> String                     -- The expression
 874   -> IO (Maybe Type)
 875
 876 hscTcExpr hsc_env expr
 877   = do  { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr
 878         ; let icontext = hsc_IC hsc_env
 879         ; case maybe_stmt of {
 880              Nothing      -> return Nothing ;   -- Parse error
 881              Just (Just (L _ (ExprStmt expr _ _)))
 882                         -> tcRnExpr hsc_env icontext expr ;
 883              Just _ -> do { errorMsg (hsc_dflags hsc_env) (text "not an expression:" <+> quotes (text expr)) ;
 884                                 return Nothing } ;
 885              } }
 886
 887 hscKcType       -- Find the kind of a type
 888   :: HscEnv
 889   -> String                     -- The type
 890   -> IO (Maybe Kind)
 891
 892 hscKcType hsc_env str
 893   = do  { maybe_type <- hscParseType (hsc_dflags hsc_env) str
 894         ; let icontext = hsc_IC hsc_env
 895         ; case maybe_type of {
 896              Just ty -> tcRnType hsc_env icontext ty ;
 897              Nothing -> return Nothing } }
 898 #endif
 899 \end{code}
 900
 901 \begin{code}
 902 #ifdef GHCI
 903 hscParseStmt :: DynFlags -> String -> IO (Maybe (Maybe (LStmt RdrName)))
 904 hscParseStmt = hscParseThing parseStmt
 905
 906 hscParseType :: DynFlags -> String -> IO (Maybe (LHsType RdrName))
 907 hscParseType = hscParseThing parseType
 908 #endif
 909
 910 hscParseIdentifier :: DynFlags -> String -> IO (Maybe (Located RdrName))
 911 hscParseIdentifier = hscParseThing parseIdentifier
 912
 913 hscParseThing :: Outputable thing
 914               => Lexer.P thing
 915               -> DynFlags -> String
 916               -> IO (Maybe thing)
 917         -- Nothing => Parse error (message already printed)
 918         -- Just x  => success
 919 hscParseThing parser dflags str
 920  = showPass dflags "Parser" >>
 921       {-# SCC "Parser" #-} do
 922
 923       buf <- stringToStringBuffer str
 924
 925       let loc  = mkSrcLoc FSLIT("<interactive>") 1 0
 926
 927       case unP parser (mkPState buf loc dflags) of {
 928
 929         PFailed span err -> do { printError span err;
 930                                  return Nothing };
 931
 932         POk pst thing -> do {
 933
 934       let {ms = getMessages pst};
 935       printErrorsAndWarnings dflags ms;
 936       when (errorsFound dflags ms) $ exitWith (ExitFailure 1);
 937
 938       --ToDo: can't free the string buffer until we've finished this
 939       -- compilation sweep and all the identifiers have gone away.
 940       dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing);
 941       return (Just thing)
 942       }}
 943 \end{code}
 944
 945 %************************************************************************
 946 %*                                                                      *
 947         Desugar, simplify, convert to bytecode, and link an expression
 948 %*                                                                      *
 949 %************************************************************************
 950
 951 \begin{code}
 952 #ifdef GHCI
 953 compileExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
 954
 955 compileExpr hsc_env srcspan ds_expr
 956   = do  { let { dflags  = hsc_dflags hsc_env ;
 957                 lint_on = dopt Opt_DoCoreLinting dflags }
 958
 959                 -- Flatten it
 960         ; flat_expr <- flattenExpr hsc_env ds_expr
 961
 962                 -- Simplify it
 963         ; simpl_expr <- simplifyExpr dflags flat_expr
 964
 965                 -- Tidy it (temporary, until coreSat does cloning)
 966         ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
 967
 968                 -- Prepare for codegen
 969         ; prepd_expr <- corePrepExpr dflags tidy_expr
 970
 971                 -- Lint if necessary
 972                 -- ToDo: improve SrcLoc
 973         ; if lint_on then
 974                 let ictxt = hsc_IC hsc_env
 975                     tyvars = varSetElems (ic_tyvars ictxt)
 976                 in
 977                 case lintUnfolding noSrcLoc tyvars prepd_expr of
 978                    Just err -> pprPanic "compileExpr" err
 979                    Nothing  -> return ()
 980           else
 981                 return ()
 982
 983                 -- Convert to BCOs
 984         ; bcos <- coreExprToBCOs dflags prepd_expr
 985
 986                 -- link it
 987         ; hval <- linkExpr hsc_env srcspan bcos
 988
 989         ; return hval
 990      }
 991 #endif
 992 \end{code}
 993
 994
 995 %************************************************************************
 996 %*                                                                      *
 997         Statistics on reading interfaces
 998 %*                                                                      *
 999 %************************************************************************
1000
1001 \begin{code}
1002 dumpIfaceStats :: HscEnv -> IO ()
1003 dumpIfaceStats hsc_env
1004   = do  { eps <- readIORef (hsc_EPS hsc_env)
1005         ; dumpIfSet (dump_if_trace || dump_rn_stats)
1006                     "Interface statistics"
1007                     (ifaceStats eps) }
1008   where
1009     dflags = hsc_dflags hsc_env
1010     dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
1011     dump_if_trace = dopt Opt_D_dump_if_trace dflags
1012 \end{code}
1013
1014 %************************************************************************
1015 %*                                                                      *
1016         Progress Messages: Module i of n
1017 %*                                                                      *
1018 %************************************************************************
1019
1020 \begin{code}
1021 showModuleIndex :: Maybe (Int, Int) -> String
1022 showModuleIndex Nothing = ""
1023 showModuleIndex (Just (i,n)) = "[" ++ padded ++ " of " ++ n_str ++ "] "
1024     where
1025         n_str = show n
1026         i_str = show i
1027         padded = replicate (length n_str - length i_str) ' ' ++ i_str
1028 \end{code}
1029