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