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