X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FHscMain.lhs;h=26247b143ad2279b27df7be5ca5d2da7675011fa;hp=ca2bb7e81e5a1bd6c870b75d1c7e07d534bbc7be;hb=7bb3d1fc79521d591cd9f824893963141a7997b6;hpb=18ea99aa2e3de03524099029a02f7e4f71fb729c diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index ca2bb7e..26247b1 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -1,38 +1,47 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1993-2000 % - -\section[GHC_Main]{Main driver for Glasgow Haskell compiler} - \begin{code} +-- | Main driver for the compiling plain Haskell source code. +-- +-- This module implements compilation of a Haskell-only source file. It is +-- /not/ concerned with preprocessing of source files; this is handled in +-- "DriverPipeline". +-- module HscMain ( newHscEnv, hscCmmFile - , hscFileCheck , hscParseIdentifier + , hscSimplify + , hscNormalIface, hscWriteIface, hscGenHardCode #ifdef GHCI , hscStmt, hscTcExpr, hscKcType , compileExpr #endif + , HsCompiler(..) + , hscOneShotCompiler, hscNothingCompiler + , hscInteractiveCompiler, hscBatchCompiler , hscCompileOneShot -- :: Compiler HscStatus , hscCompileBatch -- :: Compiler (HscStatus, ModIface, ModDetails) , hscCompileNothing -- :: Compiler (HscStatus, ModIface, ModDetails) , hscCompileInteractive -- :: Compiler (InteractiveStatus, ModIface, ModDetails) - , HscStatus (..) - , InteractiveStatus (..) - , HscChecked (..) + , HscStatus' (..) + , InteractiveStatus, HscStatus + + -- The new interface + , hscParse + , hscTypecheck + , hscTypecheckRename + , hscDesugar + , makeSimpleIface + , makeSimpleDetails ) where -#include "HsVersions.h" - #ifdef GHCI -import HsSyn ( Stmt(..), LStmt, LHsType ) import CodeOutput ( outputForeignStubs ) import ByteCodeGen ( byteCodeGen, coreExprToBCOs ) import Linker ( HValue, linkExpr ) -import CoreSyn ( CoreExpr ) import CoreTidy ( tidyExpr ) import CorePrep ( corePrepExpr ) -import Flattening ( flattenExpr ) import Desugar ( deSugarExpr ) import SimplCore ( simplifyExpr ) import TcRnDriver ( tcRnStmt, tcRnExpr, tcRnType ) @@ -41,44 +50,54 @@ import PrelNames ( iNTERACTIVE ) import {- Kind parts of -} Type ( Kind ) import CoreLint ( lintUnfolding ) import DsMeta ( templateHaskellNames ) -import SrcLoc ( SrcSpan, noSrcLoc, interactiveSrcLoc, srcLocSpan ) +import SrcLoc ( SrcSpan, noSrcLoc, interactiveSrcLoc, srcLocSpan, noSrcSpan ) import VarSet import VarEnv ( emptyTidyEnv ) #endif -import Var ( Id ) -import Module ( emptyModuleEnv, ModLocation(..) ) -import RdrName ( GlobalRdrEnv, RdrName, emptyGlobalRdrEnv ) -import HsSyn ( HsModule, LHsBinds, HsGroup, LIE, LImportDecl, HsDoc, - HaddockModInfo ) +import Id ( Id ) +import Module ( emptyModuleEnv, ModLocation(..), Module ) +import RdrName +import HsSyn import CoreSyn import SrcLoc ( Located(..) ) import StringBuffer import Parser import Lexer import SrcLoc ( mkSrcLoc ) -import TcRnDriver ( tcRnModule, tcRnExtCore ) +import TcRnDriver ( tcRnModule ) import TcIface ( typecheckIface ) import TcRnMonad ( initIfaceCheck, TcGblEnv(..) ) import IfaceEnv ( initNameCache ) import LoadIface ( ifaceStats, initExternalPackageState ) import PrelInfo ( wiredInThings, basicKnownKeyNames ) -import MkIface ( checkOldIface, mkIface, writeIfaceFile ) +import MkIface import Desugar ( deSugar ) -import Flattening ( flatten ) import SimplCore ( core2core ) -import TidyPgm ( tidyProgram, mkBootModDetails ) +import TidyPgm import CorePrep ( corePrepPgm ) import CoreToStg ( coreToStg ) -import TyCon ( isDataTyCon ) +import qualified StgCmm ( codeGen ) +import StgSyn +import CostCentre +import TyCon ( TyCon, isDataTyCon ) import Name ( Name, NamedThing(..) ) import SimplStg ( stg2stg ) import CodeGen ( codeGen ) +import Cmm ( Cmm ) +import PprCmm ( pprCmms ) import CmmParse ( parseCmmFile ) +import CmmBuildInfoTables import CmmCPS +import CmmCPSZ import CmmInfo +import OptimizationFuel ( initOptFuelState ) +import CmmCvt +import CmmTx +import CmmContFlowOpt import CodeOutput ( codeOutput ) import NameEnv ( emptyNameEnv ) +import Fingerprint ( Fingerprint ) import DynFlags import ErrUtils @@ -88,17 +107,18 @@ import Outputable import HscStats ( ppSourceStats ) import HscTypes import MkExternalCore ( emitExternalCore ) -import ParserCore -import ParserCoreUtils import FastString -import UniqFM ( emptyUFM ) +import LazyUniqFM ( emptyUFM ) +import UniqSupply ( initUs_ ) import Bag ( unitBag ) +import Exception +-- import MonadUtils import Control.Monad -import System.Exit -import System.IO +-- import System.IO import Data.IORef \end{code} +#include "HsVersions.h" %************************************************************************ @@ -108,25 +128,29 @@ import Data.IORef %************************************************************************ \begin{code} -newHscEnv :: DynFlags -> IO HscEnv -newHscEnv dflags +newHscEnv :: GhcApiCallbacks -> DynFlags -> IO HscEnv +newHscEnv callbacks dflags = do { eps_var <- newIORef initExternalPackageState ; us <- mkSplitUniqSupply 'r' ; nc_var <- newIORef (initNameCache us knownKeyNames) ; fc_var <- newIORef emptyUFM - ; mlc_var <- newIORef emptyModuleEnv + ; mlc_var <- newIORef emptyModuleEnv + ; optFuel <- initOptFuelState ; return (HscEnv { hsc_dflags = dflags, + hsc_callbacks = callbacks, hsc_targets = [], hsc_mod_graph = [], - hsc_IC = emptyInteractiveContext, - hsc_HPT = emptyHomePackageTable, - hsc_EPS = eps_var, - hsc_NC = nc_var, - hsc_FC = fc_var, - hsc_MLC = mlc_var, + hsc_IC = emptyInteractiveContext, + hsc_HPT = emptyHomePackageTable, + hsc_EPS = eps_var, + hsc_NC = nc_var, + hsc_FC = fc_var, + hsc_MLC = mlc_var, + hsc_OptFuel = optFuel, + hsc_type_env_var = Nothing, hsc_global_rdr_env = emptyGlobalRdrEnv, hsc_global_type_env = emptyNameEnv } ) } - + knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta, -- where templateHaskellNames are defined @@ -138,6 +162,108 @@ knownKeyNames = map getName wiredInThings \end{code} +\begin{code} +-- | parse a file, returning the abstract syntax +hscParse :: GhcMonad m => + ModSummary + -> m (Located (HsModule RdrName)) +hscParse mod_summary = do + hsc_env <- getSession + let dflags = hsc_dflags hsc_env + src_filename = ms_hspp_file mod_summary + maybe_src_buf = ms_hspp_buf mod_summary + -------------------------- Parser ---------------- + liftIO $ showPass dflags "Parser" + {-# SCC "Parser" #-} do + + -- sometimes we already have the buffer in memory, perhaps + -- because we needed to parse the imports out of it, or get the + -- module name. + buf <- case maybe_src_buf of + Just b -> return b + Nothing -> liftIO $ hGetStringBuffer src_filename + + let loc = mkSrcLoc (mkFastString src_filename) 1 0 + + case unP parseModule (mkPState buf loc dflags) of + PFailed span err -> + throwOneError (mkPlainErrMsg span err) + + POk pst rdr_module -> do + let ms@(warns,errs) = getMessages pst + logWarnings warns + if errorsFound dflags ms then + liftIO $ throwIO $ mkSrcErr errs + else liftIO $ do + dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ; + dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" + (ppSourceStats False rdr_module) ; + return rdr_module + -- ToDo: free the string buffer later. + +-- | Rename and typecheck a module +hscTypecheck :: GhcMonad m => + ModSummary -> Located (HsModule RdrName) + -> m TcGblEnv +hscTypecheck mod_summary rdr_module = do + hsc_env <- getSession + r <- {-# SCC "Typecheck-Rename" #-} + ioMsgMaybe $ tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module + return r + +-- XXX: should this really be a Maybe X? Check under which circumstances this +-- can become a Nothing and decide whether this should instead throw an +-- exception/signal an error. +type RenamedStuff = + (Maybe (HsGroup Name, [LImportDecl Name], Maybe [LIE Name], + Maybe (HsDoc Name), HaddockModInfo Name)) + +-- | Rename and typecheck a module, additionally returning the renamed syntax +hscTypecheckRename :: + GhcMonad m => + ModSummary -> Located (HsModule RdrName) + -> m (TcGblEnv, RenamedStuff) +hscTypecheckRename mod_summary rdr_module = do + hsc_env <- getSession + tc_result + <- {-# SCC "Typecheck-Rename" #-} + ioMsgMaybe $ tcRnModule hsc_env (ms_hsc_src mod_summary) True rdr_module + + let -- This 'do' is in the Maybe monad! + rn_info = do { decl <- tcg_rn_decls tc_result + ; let imports = tcg_rn_imports tc_result + exports = tcg_rn_exports tc_result + doc = tcg_doc tc_result + hmi = tcg_hmi tc_result + ; return (decl,imports,exports,doc,hmi) } + + return (tc_result, rn_info) + +-- | Convert a typechecked module to Core +hscDesugar :: GhcMonad m => ModSummary -> TcGblEnv -> m ModGuts +hscDesugar mod_summary tc_result = + withSession $ \hsc_env -> + ioMsgMaybe $ deSugar hsc_env (ms_location mod_summary) tc_result + +-- | Make a 'ModIface' from the results of typechecking. Used when +-- not optimising, and the interface doesn't need to contain any +-- unfoldings or other cross-module optimisation info. +-- ToDo: the old interface is only needed to get the version numbers, +-- we should use fingerprint versions instead. +makeSimpleIface :: GhcMonad m => + Maybe ModIface -> TcGblEnv -> ModDetails + -> m (ModIface,Bool) +makeSimpleIface maybe_old_iface tc_result details = + withSession $ \hsc_env -> + ioMsgMaybe $ mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) details tc_result + +-- | Make a 'ModDetails' from the results of typechecking. Used when +-- typechecking only, as opposed to full compilation. +makeSimpleDetails :: GhcMonad m => TcGblEnv -> m ModDetails +makeSimpleDetails tc_result = + withSession $ \hsc_env -> liftIO $ mkBootModDetailsTc hsc_env tc_result +\end{code} + %************************************************************************ %* * The main compiler pipeline @@ -177,225 +303,287 @@ error. This is the only thing that isn't caught by the type-system. \begin{code} -data HscChecked - = HscChecked - -- parsed - (Located (HsModule RdrName)) - -- renamed - (Maybe (HsGroup Name, [LImportDecl Name], Maybe [LIE Name], - Maybe (HsDoc Name), HaddockModInfo Name)) - -- typechecked - (Maybe (LHsBinds Id, GlobalRdrEnv, ModDetails)) - -- desugared - (Maybe [CoreBind]) - -- Status of a compilation to hard-code or nothing. -data HscStatus +data HscStatus' a = HscNoRecomp - | HscRecomp Bool -- Has stub files. - -- This is a hack. We can't compile C files here - -- since it's done in DriverPipeline. For now we - -- just return True if we want the caller to compile - -- them for us. - --- Status of a compilation to byte-code. -data InteractiveStatus - = InteractiveNoRecomp - | InteractiveRecomp Bool -- Same as HscStatus - CompiledByteCode - - --- I want Control.Monad.State! --Lemmih 03/07/2006 -newtype Comp a = Comp {runComp :: CompState -> IO (a, CompState)} - -instance Monad Comp where - g >>= fn = Comp $ \s -> runComp g s >>= \(a,s') -> runComp (fn a) s' - return a = Comp $ \s -> return (a,s) - fail = error - -evalComp :: Comp a -> CompState -> IO a -evalComp comp st = do (val,_st') <- runComp comp st - return val - -data CompState - = CompState - { compHscEnv :: HscEnv - , compModSummary :: ModSummary - , compOldIface :: Maybe ModIface - } - -get :: Comp CompState -get = Comp $ \s -> return (s,s) - -modify :: (CompState -> CompState) -> Comp () -modify f = Comp $ \s -> return ((), f s) - -gets :: (CompState -> a) -> Comp a -gets getter = do st <- get - return (getter st) - -liftIO :: IO a -> Comp a -liftIO ioA = Comp $ \s -> do a <- ioA - return (a,s) - -type NoRecomp result = ModIface -> Comp result -type FrontEnd core = Comp (Maybe core) + | HscRecomp + Bool -- Has stub files. This is a hack. We can't compile C files here + -- since it's done in DriverPipeline. For now we just return True + -- if we want the caller to compile them for us. + a + +-- This is a bit ugly. Since we use a typeclass below and would like to avoid +-- functional dependencies, we have to parameterise the typeclass over the +-- result type. Therefore we need to artificially distinguish some types. We +-- do this by adding type tags which will simply be ignored by the caller. +type HscStatus = HscStatus' () +type InteractiveStatus = HscStatus' (Maybe (CompiledByteCode, ModBreaks)) + -- INVARIANT: result is @Nothing@ <=> input was a boot file + +type OneShotResult = HscStatus +type BatchResult = (HscStatus, ModIface, ModDetails) +type NothingResult = (HscStatus, ModIface, ModDetails) +type InteractiveResult = (InteractiveStatus, ModIface, ModDetails) -- FIXME: The old interface and module index are only using in 'batch' and -- 'interactive' mode. They should be removed from 'oneshot' mode. -type Compiler result = HscEnv +type Compiler result = GhcMonad m => + HscEnv -> ModSummary -> Bool -- True <=> source unchanged -> Maybe ModIface -- Old interface, if available -> Maybe (Int,Int) -- Just (i,n) <=> module i of n (for msgs) - -> IO (Maybe result) - - --- This functions checks if recompilation is necessary and --- then combines the FrontEnd and BackEnd to a working compiler. -hscMkCompiler :: NoRecomp result -- What to do when recompilation isn't required. - -> (Maybe (Int,Int) -> Bool -> Comp ()) - -> FrontEnd core - -> (core -> Comp result) -- Backend. - -> Compiler result -hscMkCompiler norecomp messenger frontend backend - hsc_env mod_summary source_unchanged - mbOldIface mbModIndex - = flip evalComp (CompState hsc_env mod_summary mbOldIface) $ - do (recomp_reqd, mbCheckedIface) - <- {-# SCC "checkOldIface" #-} - liftIO $ checkOldIface hsc_env mod_summary - source_unchanged mbOldIface - -- save the interface that comes back from checkOldIface. - -- In one-shot mode we don't have the old iface until this - -- point, when checkOldIface reads it from the disk. - modify (\s -> s{ compOldIface = mbCheckedIface }) - case mbCheckedIface of - Just iface | not recomp_reqd - -> do messenger mbModIndex False - result <- norecomp iface - return (Just result) - _otherwise - -> do messenger mbModIndex True - mbCore <- frontend - case mbCore of - Nothing - -> return Nothing - Just core - -> do result <- backend core - return (Just result) + -> m result + +data HsCompiler a + = HsCompiler { + -- | The main interface. + hscCompile :: GhcMonad m => + HscEnv -> ModSummary -> Bool + -> Maybe ModIface -> Maybe (Int, Int) + -> m a, + + -- | Called when no recompilation is necessary. + hscNoRecomp :: GhcMonad m => + ModIface -> m a, + + -- | Called to recompile the module. + hscRecompile :: GhcMonad m => + ModSummary -> Maybe Fingerprint -> m a, + + hscBackend :: GhcMonad m => + TcGblEnv -> ModSummary -> Maybe Fingerprint -> m a, + + -- | Code generation for Boot modules. + hscGenBootOutput :: GhcMonad m => + TcGblEnv -> ModSummary -> Maybe Fingerprint -> m a, + + -- | Code generation for normal modules. + hscGenOutput :: GhcMonad m => + ModGuts -> ModSummary -> Maybe Fingerprint -> m a + } + +genericHscCompile :: GhcMonad m => + HsCompiler a + -> (Maybe (Int,Int) -> Bool -> ModSummary -> m ()) + -> HscEnv -> ModSummary -> Bool + -> Maybe ModIface -> Maybe (Int, Int) + -> m a +genericHscCompile compiler hscMessage + hsc_env mod_summary source_unchanged + mb_old_iface0 mb_mod_index = + withTempSession (\_ -> hsc_env) $ do + (recomp_reqd, mb_checked_iface) + <- {-# SCC "checkOldIface" #-} + liftIO $ checkOldIface hsc_env mod_summary + source_unchanged mb_old_iface0 + -- save the interface that comes back from checkOldIface. + -- In one-shot mode we don't have the old iface until this + -- point, when checkOldIface reads it from the disk. + let mb_old_hash = fmap mi_iface_hash mb_checked_iface + case mb_checked_iface of + Just iface | not recomp_reqd + -> do hscMessage mb_mod_index False mod_summary + hscNoRecomp compiler iface + _otherwise + -> do hscMessage mb_mod_index True mod_summary + hscRecompile compiler mod_summary mb_old_hash + +genericHscRecompile :: GhcMonad m => + HsCompiler a + -> ModSummary -> Maybe Fingerprint + -> m a +genericHscRecompile compiler mod_summary mb_old_hash + | ExtCoreFile <- ms_hsc_src mod_summary = + panic "GHC does not currently support reading External Core files" + | otherwise = do + tc_result <- hscFileFrontEnd mod_summary + hscBackend compiler tc_result mod_summary mb_old_hash + +genericHscBackend :: GhcMonad m => + HsCompiler a + -> TcGblEnv -> ModSummary -> Maybe Fingerprint + -> m a +genericHscBackend compiler tc_result mod_summary mb_old_hash + | HsBootFile <- ms_hsc_src mod_summary = + hscGenBootOutput compiler tc_result mod_summary mb_old_hash + | otherwise = do + guts <- hscDesugar mod_summary tc_result + hscGenOutput compiler guts mod_summary mb_old_hash -------------------------------------------------------------- -- Compilers -------------------------------------------------------------- --- 1 2 3 4 5 6 7 8 9 +hscOneShotCompiler :: HsCompiler OneShotResult +hscOneShotCompiler = + HsCompiler { + + hscCompile = \hsc_env mod_summary src_changed mb_old_iface mb_i_of_n -> do + -- One-shot mode needs a knot-tying mutable variable for interface + -- files. See TcRnTypes.TcGblEnv.tcg_type_env_var. + type_env_var <- liftIO $ newIORef emptyNameEnv + let + mod = ms_mod mod_summary + hsc_env' = hsc_env{ hsc_type_env_var = Just (mod, type_env_var) } + --- + genericHscCompile hscOneShotCompiler + oneShotMsg hsc_env' mod_summary src_changed + mb_old_iface mb_i_of_n + + , hscNoRecomp = \_old_iface -> do + withSession (liftIO . dumpIfaceStats) + return HscNoRecomp + + , hscRecompile = genericHscRecompile hscOneShotCompiler + + , hscBackend = genericHscBackend hscOneShotCompiler + + , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do + (iface, changed, _) <- hscSimpleIface tc_result mb_old_iface + hscWriteIface iface changed mod_summary + return (HscRecomp False ()) + + , hscGenOutput = \guts0 mod_summary mb_old_iface -> do + guts <- hscSimplify guts0 + (iface, changed, _details, cgguts) + <- hscNormalIface guts mb_old_iface + hscWriteIface iface changed mod_summary + hasStub <- hscGenHardCode cgguts mod_summary + return (HscRecomp hasStub ()) + } + -- Compile Haskell, boot and extCore in OneShot mode. -hscCompileOneShot :: Compiler HscStatus -hscCompileOneShot = hscCompileHardCode norecompOneShot oneShotMsg hscOneShot (hscConst (HscRecomp False)) +hscCompileOneShot :: Compiler OneShotResult +hscCompileOneShot = hscCompile hscOneShotCompiler + +-------------------------------------------------------------- + +hscBatchCompiler :: HsCompiler BatchResult +hscBatchCompiler = + HsCompiler { + + hscCompile = genericHscCompile hscBatchCompiler batchMsg + + , hscNoRecomp = \iface -> do + details <- genModDetails iface + return (HscNoRecomp, iface, details) + + , hscRecompile = genericHscRecompile hscBatchCompiler + + , hscBackend = genericHscBackend hscBatchCompiler + + , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do + (iface, changed, details) + <- hscSimpleIface tc_result mb_old_iface + hscWriteIface iface changed mod_summary + return (HscRecomp False (), iface, details) + + , hscGenOutput = \guts0 mod_summary mb_old_iface -> do + guts <- hscSimplify guts0 + (iface, changed, details, cgguts) + <- hscNormalIface guts mb_old_iface + hscWriteIface iface changed mod_summary + hasStub <- hscGenHardCode cgguts mod_summary + return (HscRecomp hasStub (), iface, details) + } -- Compile Haskell, boot and extCore in batch mode. hscCompileBatch :: Compiler (HscStatus, ModIface, ModDetails) -hscCompileBatch = hscCompileHardCode norecompBatch batchMsg hscBatch hscNothing - --- Compile to hardcode (C,asm,...). This general structure is shared by OneShot and Batch. -hscCompileHardCode :: NoRecomp result -- No recomp necessary - -> (Maybe (Int,Int) -> Bool -> Comp ()) -- Message callback - -> ((ModIface, ModDetails, CgGuts) -> Comp result) -- Compile normal file - -> ((ModIface, ModDetails, ModGuts) -> Comp result) -- Compile boot file - -> Compiler result -hscCompileHardCode norecomp msg compNormal compBoot hsc_env mod_summary = - compiler hsc_env mod_summary - where mkComp = hscMkCompiler norecomp msg - -- How to compile nonBoot files. - nonBootComp inp = hscSimplify inp >>= hscNormalIface >>= - hscWriteIface >>= compNormal - -- How to compile boot files. - bootComp inp = hscSimpleIface inp >>= hscWriteIface >>= compBoot - compiler - = case ms_hsc_src mod_summary of - ExtCoreFile - -> mkComp hscCoreFrontEnd nonBootComp - HsSrcFile - -> mkComp hscFileFrontEnd nonBootComp - HsBootFile - -> mkComp hscFileFrontEnd bootComp - --- Type-check Haskell, boot and extCore. --- Does it make sense to compile extCore to nothing? -hscCompileNothing :: Compiler (HscStatus, ModIface, ModDetails) -hscCompileNothing hsc_env mod_summary - = compiler hsc_env mod_summary - where mkComp = hscMkCompiler norecompBatch batchMsg - pipeline inp = hscSimpleIface inp >>= hscIgnoreIface >>= hscNothing - compiler - = case ms_hsc_src mod_summary of - ExtCoreFile - -> mkComp hscCoreFrontEnd pipeline - HsSrcFile - -> mkComp hscFileFrontEnd pipeline - HsBootFile - -> mkComp hscFileFrontEnd pipeline +hscCompileBatch = hscCompile hscBatchCompiler + +-------------------------------------------------------------- + +hscInteractiveCompiler :: HsCompiler InteractiveResult +hscInteractiveCompiler = + HsCompiler { + hscCompile = genericHscCompile hscInteractiveCompiler batchMsg + + , hscNoRecomp = \iface -> do + details <- genModDetails iface + return (HscNoRecomp, iface, details) + + , hscRecompile = genericHscRecompile hscInteractiveCompiler + + , hscBackend = genericHscBackend hscInteractiveCompiler + + , hscGenBootOutput = \tc_result _mod_summary mb_old_iface -> do + (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface + return (HscRecomp False Nothing, iface, details) + + , hscGenOutput = \guts0 mod_summary mb_old_iface -> do + guts <- hscSimplify guts0 + (iface, _changed, details, cgguts) + <- hscNormalIface guts mb_old_iface + hscInteractive (iface, details, cgguts) mod_summary + } -- Compile Haskell, extCore to bytecode. hscCompileInteractive :: Compiler (InteractiveStatus, ModIface, ModDetails) -hscCompileInteractive hsc_env mod_summary = - hscMkCompiler norecompInteractive batchMsg - frontend backend - hsc_env mod_summary - where backend inp = hscSimplify inp >>= hscNormalIface >>= hscIgnoreIface >>= hscInteractive - frontend = case ms_hsc_src mod_summary of - ExtCoreFile -> hscCoreFrontEnd - HsSrcFile -> hscFileFrontEnd - HsBootFile -> panic bootErrorMsg - bootErrorMsg = "Compiling a HsBootFile to bytecode doesn't make sense. " ++ - "Use 'hscCompileBatch' instead." +hscCompileInteractive = hscCompile hscInteractiveCompiler -------------------------------------------------------------- --- NoRecomp handlers --------------------------------------------------------------- - -norecompOneShot :: NoRecomp HscStatus -norecompOneShot old_iface - = do hsc_env <- gets compHscEnv - liftIO $ do - dumpIfaceStats hsc_env - return HscNoRecomp -norecompBatch :: NoRecomp (HscStatus, ModIface, ModDetails) -norecompBatch = norecompWorker HscNoRecomp False +hscNothingCompiler :: HsCompiler NothingResult +hscNothingCompiler = + HsCompiler { + hscCompile = genericHscCompile hscNothingCompiler batchMsg + + , hscNoRecomp = \iface -> do + details <- genModDetails iface + return (HscNoRecomp, iface, details) + + , hscRecompile = \mod_summary mb_old_hash -> + case ms_hsc_src mod_summary of + ExtCoreFile -> + panic "hscCompileNothing: cannot do external core" + _otherwise -> do + tc_result <- hscFileFrontEnd mod_summary + hscBackend hscNothingCompiler tc_result mod_summary mb_old_hash + + , hscBackend = \tc_result _mod_summary mb_old_iface -> do + (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface + return (HscRecomp False (), iface, details) + + , hscGenBootOutput = \_ _ _ -> + panic "hscCompileNothing: hscGenBootOutput should not be called" + + , hscGenOutput = \_ _ _ -> + panic "hscCompileNothing: hscGenOutput should not be called" + } +-- Type-check Haskell and .hs-boot only (no external core) +hscCompileNothing :: Compiler (HscStatus, ModIface, ModDetails) +hscCompileNothing = hscCompile hscNothingCompiler -norecompInteractive :: NoRecomp (InteractiveStatus, ModIface, ModDetails) -norecompInteractive = norecompWorker InteractiveNoRecomp True +-------------------------------------------------------------- +-- NoRecomp handlers +-------------------------------------------------------------- -norecompWorker :: a -> Bool -> NoRecomp (a, ModIface, ModDetails) -norecompWorker a isInterp old_iface - = do hsc_env <- gets compHscEnv - mod_summary <- gets compModSummary - liftIO $ do - new_details <- {-# SCC "tcRnIface" #-} - initIfaceCheck hsc_env $ - typecheckIface old_iface - dumpIfaceStats hsc_env - return (a, old_iface, new_details) +genModDetails :: GhcMonad m => ModIface -> m ModDetails +genModDetails old_iface = + withSession $ \hsc_env -> liftIO $ do + new_details <- {-# SCC "tcRnIface" #-} + initIfaceCheck hsc_env $ + typecheckIface old_iface + dumpIfaceStats hsc_env + return new_details -------------------------------------------------------------- -- Progress displayers. -------------------------------------------------------------- -oneShotMsg :: Maybe (Int,Int) -> Bool -> Comp () -oneShotMsg _mb_mod_index recomp - = do hsc_env <- gets compHscEnv +oneShotMsg :: GhcMonad m => Maybe (Int,Int) -> Bool -> ModSummary -> m () +oneShotMsg _mb_mod_index recomp _mod_summary + = do hsc_env <- getSession liftIO $ do if recomp then return () else compilationProgressMsg (hsc_dflags hsc_env) $ "compilation IS NOT required" -batchMsg :: Maybe (Int,Int) -> Bool -> Comp () -batchMsg mb_mod_index recomp - = do hsc_env <- gets compHscEnv - mod_summary <- gets compModSummary +batchMsg :: GhcMonad m => Maybe (Int,Int) -> Bool -> ModSummary -> m () +batchMsg mb_mod_index recomp mod_summary + = do hsc_env <- getSession let showMsg msg = compilationProgressMsg (hsc_dflags hsc_env) $ (showModuleIndex mb_mod_index ++ msg ++ showModMsg (hscTarget (hsc_dflags hsc_env)) recomp mod_summary) @@ -409,127 +597,66 @@ batchMsg mb_mod_index recomp -------------------------------------------------------------- -- FrontEnds -------------------------------------------------------------- - -hscCoreFrontEnd :: FrontEnd ModGuts -hscCoreFrontEnd = - do hsc_env <- gets compHscEnv - mod_summary <- gets compModSummary - liftIO $ do - ------------------- - -- PARSE - ------------------- - inp <- readFile (ms_hspp_file mod_summary) - case parseCore inp 1 of - FailP s - -> do errorMsg (hsc_dflags hsc_env) (text s{-ToDo: wrong-}) - return Nothing - OkP rdr_module - ------------------- - -- RENAME and TYPECHECK - ------------------- - -> do (tc_msgs, maybe_tc_result) <- {-# SCC "TypeCheck" #-} - tcRnExtCore hsc_env rdr_module - printErrorsAndWarnings (hsc_dflags hsc_env) tc_msgs - case maybe_tc_result of - Nothing -> return Nothing - Just mod_guts -> return (Just mod_guts) -- No desugaring to do! - - -hscFileFrontEnd :: FrontEnd ModGuts -hscFileFrontEnd = - do hsc_env <- gets compHscEnv - mod_summary <- gets compModSummary - liftIO $ do - ------------------- - -- PARSE - ------------------- - let dflags = hsc_dflags hsc_env - hspp_file = ms_hspp_file mod_summary - hspp_buf = ms_hspp_buf mod_summary - maybe_parsed <- myParseModule dflags hspp_file hspp_buf - case maybe_parsed of - Left err - -> do printBagOfErrors dflags (unitBag err) - return Nothing - Right rdr_module - ------------------- - -- RENAME and TYPECHECK - ------------------- - -> do (tc_msgs, maybe_tc_result) - <- {-# SCC "Typecheck-Rename" #-} - tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module - printErrorsAndWarnings dflags tc_msgs - case maybe_tc_result of - Nothing - -> return Nothing - Just tc_result - ------------------- - -- DESUGAR - ------------------- - -> {-# SCC "DeSugar" #-} deSugar hsc_env (ms_location mod_summary) tc_result +hscFileFrontEnd :: GhcMonad m => ModSummary -> m TcGblEnv +hscFileFrontEnd mod_summary = + do rdr_module <- hscParse mod_summary + hscTypecheck mod_summary rdr_module -------------------------------------------------------------- -- Simplifiers -------------------------------------------------------------- -hscSimplify :: ModGuts -> Comp ModGuts +hscSimplify :: GhcMonad m => ModGuts -> m ModGuts hscSimplify ds_result - = do hsc_env <- gets compHscEnv - liftIO $ do - ------------------- - -- SIMPLIFY - ------------------- + = do hsc_env <- getSession simpl_result <- {-# SCC "Core2Core" #-} - core2core hsc_env ds_result + liftIO $ core2core hsc_env ds_result return simpl_result -------------------------------------------------------------- -- Interface generators -------------------------------------------------------------- --- HACK: we return ModGuts even though we know it's not gonna be used. --- We do this because the type signature needs to be identical --- in structure to the type of 'hscNormalIface'. -hscSimpleIface :: ModGuts -> Comp (ModIface, Bool, ModDetails, ModGuts) -hscSimpleIface ds_result - = do hsc_env <- gets compHscEnv - mod_summary <- gets compModSummary - maybe_old_iface <- gets compOldIface - liftIO $ do - details <- mkBootModDetails hsc_env ds_result - (new_iface, no_change) +hscSimpleIface :: GhcMonad m => + TcGblEnv + -> Maybe Fingerprint + -> m (ModIface, Bool, ModDetails) +hscSimpleIface tc_result mb_old_iface + = do hsc_env <- getSession + details <- liftIO $ mkBootModDetailsTc hsc_env tc_result + (new_iface, no_change) <- {-# SCC "MkFinalIface" #-} - mkIface hsc_env maybe_old_iface ds_result details + ioMsgMaybe $ mkIfaceTc hsc_env mb_old_iface details tc_result -- And the answer is ... - dumpIfaceStats hsc_env - return (new_iface, no_change, details, ds_result) - -hscNormalIface :: ModGuts -> Comp (ModIface, Bool, ModDetails, CgGuts) -hscNormalIface simpl_result - = do hsc_env <- gets compHscEnv - mod_summary <- gets compModSummary - maybe_old_iface <- gets compOldIface - liftIO $ do - ------------------- - -- TIDY - ------------------- + liftIO $ dumpIfaceStats hsc_env + return (new_iface, no_change, details) + +hscNormalIface :: GhcMonad m => + ModGuts + -> Maybe Fingerprint + -> m (ModIface, Bool, ModDetails, CgGuts) +hscNormalIface simpl_result mb_old_iface + = do hsc_env <- getSession + (cg_guts, details) <- {-# SCC "CoreTidy" #-} - tidyProgram hsc_env simpl_result + liftIO $ tidyProgram hsc_env simpl_result - ------------------- -- BUILD THE NEW ModIface and ModDetails -- and emit external core if necessary -- This has to happen *after* code gen so that the back-end -- info has been set. Not yet clear if it matters waiting -- until after code output (new_iface, no_change) - <- {-# SCC "MkFinalIface" #-} - mkIface hsc_env maybe_old_iface simpl_result details + <- {-# SCC "MkFinalIface" #-} + ioMsgMaybe $ mkIface hsc_env mb_old_iface + details simpl_result -- Emit external core - emitExternalCore (hsc_dflags hsc_env) (availsToNameSet (mg_exports simpl_result)) cg_guts -- Move this? --Lemmih 03/07/2006 - dumpIfaceStats hsc_env + -- This should definitely be here and not after CorePrep, + -- because CorePrep produces unqualified constructor wrapper declarations, + -- so its output isn't valid External Core (without some preprocessing). + liftIO $ emitExternalCore (hsc_dflags hsc_env) cg_guts + liftIO $ dumpIfaceStats hsc_env - ------------------- -- Return the prepared code. return (new_iface, no_change, details, cg_guts) @@ -537,43 +664,23 @@ hscNormalIface simpl_result -- BackEnd combinators -------------------------------------------------------------- -hscWriteIface :: (ModIface, Bool, ModDetails, a) -> Comp (ModIface, ModDetails, a) -hscWriteIface (iface, no_change, details, a) - = do mod_summary <- gets compModSummary - hsc_env <- gets compHscEnv +hscWriteIface :: GhcMonad m => + ModIface -> Bool + -> ModSummary + -> m () +hscWriteIface iface no_change mod_summary + = do hsc_env <- getSession let dflags = hsc_dflags hsc_env liftIO $ do unless no_change $ writeIfaceFile dflags (ms_location mod_summary) iface - return (iface, details, a) - -hscIgnoreIface :: (ModIface, Bool, ModDetails, a) -> Comp (ModIface, ModDetails, a) -hscIgnoreIface (iface, no_change, details, a) - = return (iface, details, a) - --- Don't output any code. -hscNothing :: (ModIface, ModDetails, a) -> Comp (HscStatus, ModIface, ModDetails) -hscNothing (iface, details, a) - = return (HscRecomp False, iface, details) - --- Generate code and return both the new ModIface and the ModDetails. -hscBatch :: (ModIface, ModDetails, CgGuts) -> Comp (HscStatus, ModIface, ModDetails) -hscBatch (iface, details, cgguts) - = do hasStub <- hscCompile cgguts - return (HscRecomp hasStub, iface, details) - --- Here we don't need the ModIface and ModDetails anymore. -hscOneShot :: (ModIface, ModDetails, CgGuts) -> Comp HscStatus -hscOneShot (_, _, cgguts) - = do hasStub <- hscCompile cgguts - return (HscRecomp hasStub) - --- Compile to hard-code. -hscCompile :: CgGuts -> Comp Bool -hscCompile cgguts - = do hsc_env <- gets compHscEnv - mod_summary <- gets compModSummary - liftIO $ do + +-- | Compile to hard-code. +hscGenHardCode :: GhcMonad m => + CgGuts -> ModSummary + -> m Bool -- ^ @True@ <=> stub.c exists +hscGenHardCode cgguts mod_summary + = withSession $ \hsc_env -> liftIO $ do let CgGuts{ -- This is the last use of the ModGuts in a compilation. -- From now on, we just use the bits we need. cg_module = this_mod, @@ -582,7 +689,7 @@ hscCompile cgguts cg_dir_imps = dir_imps, cg_foreign = foreign_stubs, cg_dep_pkgs = dependencies, - cg_hpc_info = hpc_info } = cgguts + cg_hpc_info = hpc_info } = cgguts dflags = hsc_dflags hsc_env location = ms_location mod_summary data_tycons = filter isDataTyCon tycons @@ -598,36 +705,44 @@ hscCompile cgguts (stg_binds, cost_centre_info) <- {-# SCC "CoreToStg" #-} myCoreToStg dflags this_mod prepd_binds + ------------------ Code generation ------------------ - abstractC <- {-# SCC "CodeGen" #-} - codeGen dflags this_mod data_tycons - foreign_stubs dir_imps cost_centre_info - stg_binds hpc_info - ------------------ Convert to CPS -------------------- - --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm - continuationC <- cmmToRawCmm abstractC + cmms <- if dopt Opt_TryNewCodeGen (hsc_dflags hsc_env) + then do cmms <- tryNewCodeGen hsc_env this_mod data_tycons + dir_imps cost_centre_info + stg_binds hpc_info + return cmms + else {-# SCC "CodeGen" #-} + codeGen dflags this_mod data_tycons + dir_imps cost_centre_info + stg_binds hpc_info + + --- Optionally run experimental Cmm transformations --- + -- cmms <- optionallyConvertAndOrCPS hsc_env cmms + -- unless certain dflags are on, the identity function ------------------ Code output ----------------------- - (stub_h_exists,stub_c_exists) + rawcmms <- cmmToRawCmm cmms + dumpIfSet_dyn dflags Opt_D_dump_cmmz "Raw Cmm" (ppr rawcmms) + (_stub_h_exists, stub_c_exists) <- codeOutput dflags this_mod location foreign_stubs - dependencies continuationC + dependencies rawcmms return stub_c_exists -hscConst :: b -> a -> Comp b -hscConst b a = return b - -hscInteractive :: (ModIface, ModDetails, CgGuts) - -> Comp (InteractiveStatus, ModIface, ModDetails) -hscInteractive (iface, details, cgguts) +hscInteractive :: GhcMonad m => + (ModIface, ModDetails, CgGuts) + -> ModSummary + -> m (InteractiveStatus, ModIface, ModDetails) #ifdef GHCI - = do hsc_env <- gets compHscEnv - mod_summary <- gets compModSummary +hscInteractive (iface, details, cgguts) mod_summary + = do hsc_env <- getSession liftIO $ do let CgGuts{ -- This is the last use of the ModGuts in a compilation. -- From now on, we just use the bits we need. cg_module = this_mod, cg_binds = core_binds, cg_tycons = tycons, - cg_foreign = foreign_stubs } = cgguts + cg_foreign = foreign_stubs, + cg_modBreaks = mod_breaks } = cgguts dflags = hsc_dflags hsc_env location = ms_location mod_summary data_tycons = filter isDataTyCon tycons @@ -640,132 +755,108 @@ hscInteractive (iface, details, cgguts) prepd_binds <- {-# SCC "CorePrep" #-} corePrepPgm dflags core_binds data_tycons ; ----------------- Generate byte code ------------------ - comp_bc <- byteCodeGen dflags prepd_binds data_tycons (md_modBreaks details) + comp_bc <- byteCodeGen dflags prepd_binds data_tycons mod_breaks ------------------ Create f-x-dynamic C-side stuff --- - (istub_h_exists, istub_c_exists) + (_istub_h_exists, istub_c_exists) <- outputForeignStubs dflags this_mod location foreign_stubs - return (InteractiveRecomp istub_c_exists comp_bc, iface, details) + return (HscRecomp istub_c_exists (Just (comp_bc, mod_breaks)) + , iface, details) #else - = panic "GHC not compiled with interpreter" +hscInteractive _ _ = panic "GHC not compiled with interpreter" #endif ------------------------------ -hscFileCheck :: HscEnv -> ModSummary -> Bool -> IO (Maybe HscChecked) -hscFileCheck hsc_env mod_summary compileToCore = do { - ------------------- - -- PARSE - ------------------- - ; let dflags = hsc_dflags hsc_env - hspp_file = ms_hspp_file mod_summary - hspp_buf = ms_hspp_buf mod_summary - - ; maybe_parsed <- myParseModule dflags hspp_file hspp_buf - - ; case maybe_parsed of { - Left err -> do { printBagOfErrors dflags (unitBag err) - ; return Nothing } ; - Right rdr_module -> do { - - ------------------- - -- RENAME and TYPECHECK - ------------------- - (tc_msgs, maybe_tc_result) - <- _scc_ "Typecheck-Rename" - tcRnModule hsc_env (ms_hsc_src mod_summary) - True{-save renamed syntax-} - rdr_module - - ; printErrorsAndWarnings dflags tc_msgs - ; case maybe_tc_result of { - Nothing -> return (Just (HscChecked rdr_module Nothing Nothing Nothing)); - Just tc_result -> do - let type_env = tcg_type_env tc_result - md = ModDetails { - md_types = type_env, - md_exports = tcg_exports tc_result, - md_insts = tcg_insts tc_result, - md_fam_insts = tcg_fam_insts tc_result, - md_modBreaks = emptyModBreaks, - md_rules = [panic "no rules"], - -- Rules are CoreRules, not the - -- RuleDecls we get out of the typechecker - md_vect_info = noVectInfo - -- VectInfo is added by the Core - -- vectorisation pass - } - rnInfo = do decl <- tcg_rn_decls tc_result - imports <- tcg_rn_imports tc_result - let exports = tcg_rn_exports tc_result - let doc = tcg_doc tc_result - hmi = tcg_hmi tc_result - return (decl,imports,exports,doc,hmi) - maybeModGuts <- - if compileToCore then - deSugar hsc_env (ms_location mod_summary) tc_result - else - return Nothing - return (Just (HscChecked rdr_module - rnInfo - (Just (tcg_binds tc_result, - tcg_rdr_env tc_result, - md)) - (fmap mg_binds maybeModGuts))) - }}}} - - -hscCmmFile :: DynFlags -> FilePath -> IO Bool -hscCmmFile dflags filename = do - maybe_cmm <- parseCmmFile dflags filename - case maybe_cmm of - Nothing -> return False - Just cmm -> do - --continuationC <- cmmCPS dflags [cmm] >>= cmmToRawCmm - continuationC <- cmmToRawCmm [cmm] - codeOutput dflags no_mod no_loc NoStubs [] continuationC - return True +hscCmmFile :: GhcMonad m => HscEnv -> FilePath -> m () +hscCmmFile hsc_env filename = do + dflags <- return $ hsc_dflags hsc_env + cmm <- ioMsgMaybe $ + parseCmmFile dflags filename + cmms <- liftIO $ optionallyConvertAndOrCPS hsc_env [cmm] + rawCmms <- liftIO $ cmmToRawCmm cmms + _ <- liftIO $ codeOutput dflags no_mod no_loc NoStubs [] rawCmms + return () where no_mod = panic "hscCmmFile: no_mod" no_loc = ModLocation{ ml_hs_file = Just filename, ml_hi_file = panic "hscCmmFile: no hi file", ml_obj_file = panic "hscCmmFile: no obj file" } - -myParseModule :: DynFlags -> FilePath -> Maybe StringBuffer - -> IO (Either ErrMsg (Located (HsModule RdrName))) -myParseModule dflags src_filename maybe_src_buf - = -------------------------- Parser ---------------- - showPass dflags "Parser" >> - {-# SCC "Parser" #-} do - - -- sometimes we already have the buffer in memory, perhaps - -- because we needed to parse the imports out of it, or get the - -- module name. - buf <- case maybe_src_buf of - Just b -> return b - Nothing -> hGetStringBuffer src_filename - - let loc = mkSrcLoc (mkFastString src_filename) 1 0 - - case unP parseModule (mkPState buf loc dflags) of { - - PFailed span err -> return (Left (mkPlainErrMsg span err)); - - POk pst rdr_module -> do { - - let {ms = getMessages pst}; - printErrorsAndWarnings dflags ms; - when (errorsFound dflags ms) $ exitWith (ExitFailure 1); - - dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ; - - dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" - (ppSourceStats False rdr_module) ; - - return (Right rdr_module) - -- ToDo: free the string buffer later. - }} - +-------------------- Stuff for new code gen --------------------- + +tryNewCodeGen :: HscEnv -> Module -> [TyCon] -> [Module] + -> CollectedCCs + -> [(StgBinding,[(Id,[Id])])] + -> HpcInfo + -> IO [Cmm] +tryNewCodeGen hsc_env this_mod data_tycons imported_mods + cost_centre_info stg_binds hpc_info + | not (dopt Opt_TryNewCodeGen (hsc_dflags hsc_env)) + = return [] + | otherwise + = do { let dflags = hsc_dflags hsc_env + ; prog <- StgCmm.codeGen dflags this_mod data_tycons imported_mods + cost_centre_info stg_binds hpc_info + ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Cmm produced by new codegen" + (pprCmms prog) + + ; prog <- return $ map (runTx $ runCmmOpts cmmCfgOptsZ) prog + -- Control flow optimisation + + -- Note: Have to thread the module's SRT through all the procedures + -- because we greedily build it as we go. + ; us <- mkSplitUniqSupply 'S' + ; let topSRT = initUs_ us emptySRT + ; (topSRT, prog) <- foldM (protoCmmCPSZ hsc_env) (topSRT, []) prog + -- The main CPS conversion + + ; prog <- return $ map (runTx $ runCmmOpts cmmCfgOptsZ) (srtToData topSRT : prog) + -- Control flow optimisation, again + + ; let prog' = map cmmOfZgraph prog + ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (ppr prog') + ; return prog' } + + +optionallyConvertAndOrCPS :: HscEnv -> [Cmm] -> IO [Cmm] +optionallyConvertAndOrCPS hsc_env cmms = + do let dflags = hsc_dflags hsc_env + -------- Optionally convert to and from zipper ------ + cmms <- if dopt Opt_ConvertToZipCfgAndBack dflags + then mapM (testCmmConversion hsc_env) cmms + else return cmms + --------- Optionally convert to CPS (MDA) ----------- + cmms <- if not (dopt Opt_ConvertToZipCfgAndBack dflags) && + dopt Opt_RunCPS dflags + then cmmCPS dflags cmms + else return cmms + return cmms + + +testCmmConversion :: HscEnv -> Cmm -> IO Cmm +testCmmConversion hsc_env cmm = + do let dflags = hsc_dflags hsc_env + showPass dflags "CmmToCmm" + dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (ppr cmm) + --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm + us <- mkSplitUniqSupply 'C' + let cfopts = runTx $ runCmmOpts cmmCfgOptsZ + let cvtm = do g <- cmmToZgraph cmm + return $ cfopts g + let zgraph = initUs_ us cvtm + us <- mkSplitUniqSupply 'S' + let topSRT = initUs_ us emptySRT + (_, [cps_zgraph]) <- protoCmmCPSZ hsc_env (topSRT, []) zgraph + let chosen_graph = if dopt Opt_RunCPSZ dflags then cps_zgraph else zgraph + dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (ppr chosen_graph) + showPass dflags "Convert from Z back to Cmm" + let cvt = cmmOfZgraph $ cfopts $ chosen_graph + dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (ppr cvt) + return cvt + +myCoreToStg :: DynFlags -> Module -> [CoreBind] + -> IO ( [(StgBinding,[(Id,[Id])])] -- output program + , CollectedCCs) -- cost centre info (declared and used) myCoreToStg dflags this_mod prepd_binds = do @@ -814,113 +905,108 @@ A naked expression returns a singleton Name [it]. \begin{code} #ifdef GHCI hscStmt -- Compile a stmt all the way to an HValue, but don't run it - :: HscEnv + :: GhcMonad m => + HscEnv -> String -- The statement - -> IO (Maybe ([Id], HValue)) - -hscStmt hsc_env stmt - = do { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt - ; case maybe_stmt of { - Nothing -> return Nothing ; -- Parse error - Just Nothing -> return Nothing ; -- Empty line - Just (Just parsed_stmt) -> do { -- The real stuff - - -- Rename and typecheck it - let icontext = hsc_IC hsc_env - ; maybe_tc_result <- tcRnStmt hsc_env icontext parsed_stmt - - ; case maybe_tc_result of { - Nothing -> return Nothing ; - Just (ids, tc_expr) -> do { - - -- Desugar it - ; let rdr_env = ic_rn_gbl_env icontext - type_env = mkTypeEnv (map AnId (ic_tmp_ids icontext)) - ; mb_ds_expr <- deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr - - ; case mb_ds_expr of { - Nothing -> return Nothing ; - Just ds_expr -> do { - - -- Then desugar, code gen, and link it - ; let src_span = srcLocSpan interactiveSrcLoc - ; hval <- compileExpr hsc_env src_span ds_expr - - ; return (Just (ids, hval)) - }}}}}}} + -> m (Maybe ([Id], HValue)) + -- ^ 'Nothing' <==> empty statement (or comment only), but no parse error +hscStmt hsc_env stmt = do + maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt + case maybe_stmt of + Nothing -> return Nothing + Just parsed_stmt -> do -- The real stuff + + -- Rename and typecheck it + let icontext = hsc_IC hsc_env + (ids, tc_expr) <- ioMsgMaybe $ tcRnStmt hsc_env icontext parsed_stmt + -- Desugar it + let rdr_env = ic_rn_gbl_env icontext + type_env = mkTypeEnv (map AnId (ic_tmp_ids icontext)) + ds_expr <- ioMsgMaybe $ + deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr + + -- Then desugar, code gen, and link it + let src_span = srcLocSpan interactiveSrcLoc + hval <- liftIO $ compileExpr hsc_env src_span ds_expr + + return $ Just (ids, hval) + hscTcExpr -- Typecheck an expression (but don't run it) - :: HscEnv + :: GhcMonad m => + HscEnv -> String -- The expression - -> IO (Maybe Type) - -hscTcExpr hsc_env expr - = do { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr - ; let icontext = hsc_IC hsc_env - ; case maybe_stmt of { - Nothing -> return Nothing ; -- Parse error - Just (Just (L _ (ExprStmt expr _ _))) - -> tcRnExpr hsc_env icontext expr ; - Just other -> do { errorMsg (hsc_dflags hsc_env) (text "not an expression:" <+> quotes (text expr)) ; - return Nothing } ; - } } - -hscKcType -- Find the kind of a type - :: HscEnv - -> String -- The type - -> IO (Maybe Kind) - -hscKcType hsc_env str - = do { maybe_type <- hscParseType (hsc_dflags hsc_env) str - ; let icontext = hsc_IC hsc_env - ; case maybe_type of { - Just ty -> tcRnType hsc_env icontext ty ; - Nothing -> return Nothing } } + -> m Type + +hscTcExpr hsc_env expr = do + maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr + let icontext = hsc_IC hsc_env + case maybe_stmt of + Just (L _ (ExprStmt expr _ _)) -> do + ty <- ioMsgMaybe $ tcRnExpr hsc_env icontext expr + return ty + _ -> do throw $ mkSrcErr $ unitBag $ mkPlainErrMsg + noSrcSpan + (text "not an expression:" <+> quotes (text expr)) + +-- | Find the kind of a type +hscKcType + :: GhcMonad m => + HscEnv + -> String -- ^ The type + -> m Kind + +hscKcType hsc_env str = do + ty <- hscParseType (hsc_dflags hsc_env) str + let icontext = hsc_IC hsc_env + ioMsgMaybe $ tcRnType hsc_env icontext ty + #endif \end{code} \begin{code} #ifdef GHCI -hscParseStmt :: DynFlags -> String -> IO (Maybe (Maybe (LStmt RdrName))) +hscParseStmt :: GhcMonad m => DynFlags -> String -> m (Maybe (LStmt RdrName)) hscParseStmt = hscParseThing parseStmt -hscParseType :: DynFlags -> String -> IO (Maybe (LHsType RdrName)) +hscParseType :: GhcMonad m => DynFlags -> String -> m (LHsType RdrName) hscParseType = hscParseThing parseType #endif -hscParseIdentifier :: DynFlags -> String -> IO (Maybe (Located RdrName)) +hscParseIdentifier :: GhcMonad m => DynFlags -> String -> m (Located RdrName) hscParseIdentifier = hscParseThing parseIdentifier -hscParseThing :: Outputable thing +hscParseThing :: (Outputable thing, GhcMonad m) => Lexer.P thing -> DynFlags -> String - -> IO (Maybe thing) + -> m thing -- Nothing => Parse error (message already printed) -- Just x => success hscParseThing parser dflags str - = showPass dflags "Parser" >> + = (liftIO $ showPass dflags "Parser") >> {-# SCC "Parser" #-} do - buf <- stringToStringBuffer str + buf <- liftIO $ stringToStringBuffer str - let loc = mkSrcLoc FSLIT("") 1 0 + let loc = mkSrcLoc (fsLit "") 1 0 - case unP parser (mkPState buf loc dflags) of { + case unP parser (mkPState buf loc dflags) of - PFailed span err -> do { printError span err; - return Nothing }; + PFailed span err -> do + let msg = mkPlainErrMsg span err + throw (mkSrcErr (unitBag msg)) - POk pst thing -> do { + POk pst thing -> do - let {ms = getMessages pst}; - printErrorsAndWarnings dflags ms; - when (errorsFound dflags ms) $ exitWith (ExitFailure 1); + let ms@(warns, errs) = getMessages pst + logWarnings warns + when (errorsFound dflags ms) $ -- handle -Werror + throw (mkSrcErr errs) - --ToDo: can't free the string buffer until we've finished this - -- compilation sweep and all the identifiers have gone away. - dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing); - return (Just thing) - }} + --ToDo: can't free the string buffer until we've finished this + -- compilation sweep and all the identifiers have gone away. + liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing) + return thing \end{code} %************************************************************************ @@ -937,11 +1023,8 @@ compileExpr hsc_env srcspan ds_expr = do { let { dflags = hsc_dflags hsc_env ; lint_on = dopt Opt_DoCoreLinting dflags } - -- Flatten it - ; flat_expr <- flattenExpr hsc_env ds_expr - -- Simplify it - ; simpl_expr <- simplifyExpr dflags flat_expr + ; simpl_expr <- simplifyExpr dflags ds_expr -- Tidy it (temporary, until coreSat does cloning) ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr @@ -999,6 +1082,7 @@ dumpIfaceStats hsc_env %************************************************************************ \begin{code} +showModuleIndex :: Maybe (Int, Int) -> String showModuleIndex Nothing = "" showModuleIndex (Just (i,n)) = "[" ++ padded ++ " of " ++ n_str ++ "] " where @@ -1006,4 +1090,3 @@ showModuleIndex (Just (i,n)) = "[" ++ padded ++ " of " ++ n_str ++ "] " i_str = show i padded = replicate (length n_str - length i_str) ' ' ++ i_str \end{code} -