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