compiler/main/HscMain.lhs

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