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