X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FHscMain.lhs;h=0b8a5a26758829bde29becd500621c5caaeabf15;hp=6c09b97c93d25e4c0fe04be9e5db9d660de4d4f2;hb=4c6a3f787abcaed009a574196d82237d9ae64fc8;hpb=d5934bbb856aa0aa620c9b2e0fa51c90a1a5a048 diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 6c09b97..0b8a5a2 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -7,8 +7,11 @@ \begin{code} module HscMain ( newHscEnv, hscCmmFile - , hscFileCheck , hscParseIdentifier + , hscSimplify + , evalComp + , hscNormalIface, hscWriteIface, hscOneShot + , CompState (..) #ifdef GHCI , hscStmt, hscTcExpr, hscKcType , compileExpr @@ -19,21 +22,24 @@ module HscMain , hscCompileInteractive -- :: Compiler (InteractiveStatus, ModIface, ModDetails) , HscStatus (..) , InteractiveStatus (..) - , HscChecked (..) + + -- The new interface + , parseFile + , typecheckModule + , typecheckRenameModule + , deSugarModule + , makeSimpleIface + , makeSimpleDetails ) where #include "HsVersions.h" #ifdef GHCI -import HsSyn ( Stmt(..), LHsExpr, LStmt, LHsType ) -import Module ( Module ) 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 ) @@ -43,37 +49,46 @@ import {- Kind parts of -} Type ( Kind ) import CoreLint ( lintUnfolding ) import DsMeta ( templateHaskellNames ) import SrcLoc ( SrcSpan, noSrcLoc, interactiveSrcLoc, srcLocSpan ) +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 Module ( emptyModuleEnv, ModLocation(..), Module ) +import RdrName +import HsSyn +import CoreSyn import SrcLoc ( Located(..) ) -import StringBuffer ( hGetStringBuffer, stringToStringBuffer ) +import StringBuffer import Parser -import Lexer ( P(..), ParseResult(..), mkPState ) +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 StgSyn +import CostCentre import TyCon ( isDataTyCon ) import Name ( Name, NamedThing(..) ) import SimplStg ( stg2stg ) import CodeGen ( codeGen ) +import Cmm ( Cmm ) import CmmParse ( parseCmmFile ) +import CmmCPS +import CmmCPSZ +import CmmInfo +import CmmCvt +import CmmTx +import CmmContFlowOpt import CodeOutput ( codeOutput ) import NameEnv ( emptyNameEnv ) @@ -85,13 +100,13 @@ 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 Control.Monad +import System.Exit import System.IO import Data.IORef \end{code} @@ -134,6 +149,85 @@ knownKeyNames = map getName wiredInThings \end{code} +\begin{code} +-- | parse a file, returning the abstract syntax +parseFile :: HscEnv -> ModSummary -> IO (Maybe (Located (HsModule RdrName))) +parseFile hsc_env mod_summary + = do + maybe_parsed <- myParseModule dflags hspp_file hspp_buf + case maybe_parsed of + Left err + -> do printBagOfErrors dflags (unitBag err) + return Nothing + Right rdr_module + -> return (Just rdr_module) + where + dflags = hsc_dflags hsc_env + hspp_file = ms_hspp_file mod_summary + hspp_buf = ms_hspp_buf mod_summary + +-- | Rename and typecheck a module +typecheckModule :: HscEnv -> ModSummary -> Located (HsModule RdrName) + -> IO (Maybe TcGblEnv) +typecheckModule hsc_env mod_summary rdr_module + = do + (tc_msgs, maybe_tc_result) + <- {-# SCC "Typecheck-Rename" #-} + tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module + printErrorsAndWarnings dflags tc_msgs + return maybe_tc_result + where + dflags = hsc_dflags hsc_env + +type RenamedStuff = + (Maybe (HsGroup Name, [LImportDecl Name], Maybe [LIE Name], + Maybe (HsDoc Name), HaddockModInfo Name)) + +-- | Rename and typecheck a module, additinoally returning the renamed syntax +typecheckRenameModule :: HscEnv -> ModSummary -> Located (HsModule RdrName) + -> IO (Maybe (TcGblEnv, RenamedStuff)) +typecheckRenameModule hsc_env mod_summary rdr_module + = do + (tc_msgs, maybe_tc_result) + <- {-# SCC "Typecheck-Rename" #-} + tcRnModule hsc_env (ms_hsc_src mod_summary) True rdr_module + printErrorsAndWarnings dflags tc_msgs + case maybe_tc_result of + Nothing -> return Nothing + Just tc_result -> do + let rn_info = 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 + let hmi = tcg_hmi tc_result + return (decl,imports,exports,doc,hmi) + return (Just (tc_result, rn_info)) + where + dflags = hsc_dflags hsc_env + +-- | Convert a typechecked module to Core +deSugarModule :: HscEnv -> ModSummary -> TcGblEnv -> IO (Maybe ModGuts) +deSugarModule hsc_env mod_summary tc_result + = 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 :: HscEnv -> Maybe ModIface -> TcGblEnv -> ModDetails + -> IO (ModIface,Bool) +makeSimpleIface hsc_env maybe_old_iface tc_result details = do + mkIfaceTc hsc_env maybe_old_iface details tc_result + +-- | Make a 'ModDetails' from the results of typechecking. Used when +-- typechecking only, as opposed to full compilation. +makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails +makeSimpleDetails hsc_env tc_result = mkBootModDetailsTc hsc_env tc_result + +-- deSugarModule :: HscEnv -> TcGblEnv -> IO Core +\end{code} + %************************************************************************ %* * The main compiler pipeline @@ -173,17 +267,6 @@ 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)) - - -- Status of a compilation to hard-code or nothing. data HscStatus = HscNoRecomp @@ -191,13 +274,14 @@ data HscStatus -- 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 - -- it for us. + -- them for us. -- Status of a compilation to byte-code. data InteractiveStatus = InteractiveNoRecomp | InteractiveRecomp Bool -- Same as HscStatus CompiledByteCode + ModBreaks -- I want Control.Monad.State! --Lemmih 03/07/2006 @@ -234,7 +318,6 @@ liftIO ioA = Comp $ \s -> do a <- ioA return (a,s) type NoRecomp result = ModIface -> Comp result -type FrontEnd core = Comp (Maybe core) -- FIXME: The old interface and module index are only using in 'batch' and -- 'interactive' mode. They should be removed from 'oneshot' mode. @@ -245,17 +328,59 @@ type Compiler result = HscEnv -> Maybe (Int,Int) -- Just (i,n) <=> module i of n (for msgs) -> IO (Maybe result) +-------------------------------------------------------------- +-- Compilers +-------------------------------------------------------------- + +-- Compile Haskell, boot and extCore in OneShot mode. +hscCompileOneShot :: Compiler HscStatus +hscCompileOneShot + = hscCompiler norecompOneShot oneShotMsg (genComp backend boot_backend) + where + backend inp = hscSimplify inp >>= hscNormalIface >>= hscWriteIface >>= hscOneShot + boot_backend inp = hscSimpleIface inp >>= hscWriteIface >> return (Just (HscRecomp False)) --- 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 +-- Compile Haskell, boot and extCore in batch mode. +hscCompileBatch :: Compiler (HscStatus, ModIface, ModDetails) +hscCompileBatch + = hscCompiler norecompBatch batchMsg (genComp backend boot_backend) + where + backend inp = hscSimplify inp >>= hscNormalIface >>= hscWriteIface >>= hscBatch + boot_backend inp = hscSimpleIface inp >>= hscWriteIface >>= hscNothing + +-- Compile Haskell, extCore to bytecode. +hscCompileInteractive :: Compiler (InteractiveStatus, ModIface, ModDetails) +hscCompileInteractive + = hscCompiler norecompInteractive batchMsg (genComp backend boot_backend) + where + backend inp = hscSimplify inp >>= hscNormalIface >>= hscIgnoreIface >>= hscInteractive + boot_backend _ = panic "hscCompileInteractive: HsBootFile" + +-- Type-check Haskell and .hs-boot only (no external core) +hscCompileNothing :: Compiler (HscStatus, ModIface, ModDetails) +hscCompileNothing + = hscCompiler norecompBatch batchMsg comp + where + backend tc = hscSimpleIface tc >>= hscIgnoreIface >>= hscNothing + + comp = do -- genComp doesn't fit here, because we want to omit + -- desugaring and for the backend to take a TcGblEnv + mod_summary <- gets compModSummary + case ms_hsc_src mod_summary of + ExtCoreFile -> panic "hscCompileNothing: cannot do external core" + _other -> do + mb_tc <- hscFileFrontEnd + case mb_tc of + Nothing -> return Nothing + Just tc_result -> backend tc_result + +hscCompiler + :: NoRecomp result -- No recomp necessary + -> (Maybe (Int,Int) -> Bool -> Comp ()) -- Message callback + -> Comp (Maybe result) + -> Compiler result +hscCompiler norecomp messenger recomp hsc_env mod_summary + source_unchanged mbOldIface mbModIndex = flip evalComp (CompState hsc_env mod_summary mbOldIface) $ do (recomp_reqd, mbCheckedIface) <- {-# SCC "checkOldIface" #-} @@ -272,91 +397,36 @@ hscMkCompiler norecomp messenger frontend backend 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) - --------------------------------------------------------------- --- Compilers --------------------------------------------------------------- - --- 1 2 3 4 5 6 7 8 9 --- Compile Haskell, boot and extCore in OneShot mode. -hscCompileOneShot :: Compiler HscStatus -hscCompileOneShot hsc_env mod_summary = - compiler hsc_env mod_summary - where mkComp = hscMkCompiler norecompOneShot oneShotMsg - -- How to compile nonBoot files. - nonBootComp inp = hscSimplify inp >>= hscNormalIface >>= - hscWriteIface >>= hscOneShot - -- How to compile boot files. - bootComp inp = hscSimpleIface inp >>= hscWriteIface >>= hscConst (HscRecomp False) - compiler - = case ms_hsc_src mod_summary of - ExtCoreFile - -> mkComp hscCoreFrontEnd nonBootComp - HsSrcFile - -> mkComp hscFileFrontEnd nonBootComp - HsBootFile - -> mkComp hscFileFrontEnd bootComp - --- Compile Haskell, boot and extCore in batch mode. -hscCompileBatch :: Compiler (HscStatus, ModIface, ModDetails) -hscCompileBatch hsc_env mod_summary - = compiler hsc_env mod_summary - where mkComp = hscMkCompiler norecompBatch batchMsg - nonBootComp inp = hscSimplify inp >>= hscNormalIface >>= - hscWriteIface >>= hscBatch - bootComp inp = hscSimpleIface inp >>= hscWriteIface >>= hscNothing - 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 - --- 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." + recomp + +-- the usual way to build the Comp (Maybe result) to pass to hscCompiler +genComp :: (ModGuts -> Comp (Maybe a)) + -> (TcGblEnv -> Comp (Maybe a)) + -> Comp (Maybe a) +genComp backend boot_backend = do + mod_summary <- gets compModSummary + case ms_hsc_src mod_summary of + ExtCoreFile -> do + panic "GHC does not currently support reading External Core files" + _not_core -> do + mb_tc <- hscFileFrontEnd + case mb_tc of + Nothing -> return Nothing + Just tc_result -> + case ms_hsc_src mod_summary of + HsBootFile -> boot_backend tc_result + _other -> do + mb_guts <- hscDesugar tc_result + case mb_guts of + Nothing -> return Nothing + Just guts -> backend guts -------------------------------------------------------------- -- NoRecomp handlers -------------------------------------------------------------- norecompOneShot :: NoRecomp HscStatus -norecompOneShot old_iface +norecompOneShot _old_iface = do hsc_env <- gets compHscEnv liftIO $ do dumpIfaceStats hsc_env @@ -369,9 +439,8 @@ norecompInteractive :: NoRecomp (InteractiveStatus, ModIface, ModDetails) norecompInteractive = norecompWorker InteractiveNoRecomp True norecompWorker :: a -> Bool -> NoRecomp (a, ModIface, ModDetails) -norecompWorker a isInterp old_iface +norecompWorker a _isInterp old_iface = do hsc_env <- gets compHscEnv - mod_summary <- gets compModSummary liftIO $ do new_details <- {-# SCC "tcRnIface" #-} initIfaceCheck hsc_env $ @@ -402,40 +471,14 @@ batchMsg mb_mod_index recomp liftIO $ do if recomp then showMsg "Compiling " - else if verbosity (hsc_dflags hsc_env) >= 1 + else if verbosity (hsc_dflags hsc_env) >= 2 then showMsg "Skipping " else return () -------------------------------------------------------------- -- 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 :: Comp (Maybe TcGblEnv) hscFileFrontEnd = do hsc_env <- gets compHscEnv mod_summary <- gets compModSummary @@ -459,14 +502,23 @@ hscFileFrontEnd = <- {-# 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 + return maybe_tc_result + +-------------------------------------------------------------- +-- Desugaring +-------------------------------------------------------------- + +hscDesugar :: TcGblEnv -> Comp (Maybe ModGuts) +hscDesugar tc_result + = do mod_summary <- gets compModSummary + hsc_env <- gets compHscEnv + liftIO $ do + ------------------- + -- DESUGAR + ------------------- + ds_result <- {-# SCC "DeSugar" #-} + deSugar hsc_env (ms_location mod_summary) tc_result + return ds_result -------------------------------------------------------------- -- Simplifiers @@ -476,13 +528,11 @@ hscSimplify :: ModGuts -> Comp ModGuts hscSimplify ds_result = do hsc_env <- gets compHscEnv liftIO $ do - flat_result <- {-# SCC "Flattening" #-} - flatten hsc_env ds_result ------------------- -- SIMPLIFY ------------------- simpl_result <- {-# SCC "Core2Core" #-} - core2core hsc_env flat_result + core2core hsc_env ds_result return simpl_result -------------------------------------------------------------- @@ -492,24 +542,23 @@ hscSimplify ds_result -- 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 +hscSimpleIface :: TcGblEnv -> Comp (ModIface, Bool, ModDetails, TcGblEnv) +hscSimpleIface tc_result = do hsc_env <- gets compHscEnv - mod_summary <- gets compModSummary maybe_old_iface <- gets compOldIface liftIO $ do - details <- mkBootModDetails hsc_env ds_result + details <- mkBootModDetailsTc hsc_env tc_result (new_iface, no_change) <- {-# SCC "MkFinalIface" #-} - mkIface hsc_env maybe_old_iface ds_result details + mkIfaceTc hsc_env maybe_old_iface details tc_result -- And the answer is ... dumpIfaceStats hsc_env - return (new_iface, no_change, details, ds_result) + return (new_iface, no_change, details, tc_result) hscNormalIface :: ModGuts -> Comp (ModIface, Bool, ModDetails, CgGuts) hscNormalIface simpl_result = do hsc_env <- gets compHscEnv - mod_summary <- gets compModSummary + _mod_summary <- gets compModSummary maybe_old_iface <- gets compOldIface liftIO $ do ------------------- @@ -526,9 +575,12 @@ hscNormalIface simpl_result -- until after code output (new_iface, no_change) <- {-# SCC "MkFinalIface" #-} - mkIface hsc_env maybe_old_iface simpl_result details + mkIface hsc_env maybe_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 + -- 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). + emitExternalCore (hsc_dflags hsc_env) cg_guts dumpIfaceStats hsc_env ------------------- @@ -550,25 +602,25 @@ hscWriteIface (iface, no_change, details, a) return (iface, details, a) hscIgnoreIface :: (ModIface, Bool, ModDetails, a) -> Comp (ModIface, ModDetails, a) -hscIgnoreIface (iface, no_change, details, 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) +hscNothing :: (ModIface, ModDetails, a) -> Comp (Maybe (HscStatus, ModIface, ModDetails)) +hscNothing (iface, details, _) + = return (Just (HscRecomp False, iface, details)) -- Generate code and return both the new ModIface and the ModDetails. -hscBatch :: (ModIface, ModDetails, CgGuts) -> Comp (HscStatus, ModIface, ModDetails) +hscBatch :: (ModIface, ModDetails, CgGuts) -> Comp (Maybe (HscStatus, ModIface, ModDetails)) hscBatch (iface, details, cgguts) = do hasStub <- hscCompile cgguts - return (HscRecomp hasStub, iface, details) + return (Just (HscRecomp hasStub, iface, details)) -- Here we don't need the ModIface and ModDetails anymore. -hscOneShot :: (ModIface, ModDetails, CgGuts) -> Comp HscStatus +hscOneShot :: (ModIface, ModDetails, CgGuts) -> Comp (Maybe HscStatus) hscOneShot (_, _, cgguts) = do hasStub <- hscCompile cgguts - return (HscRecomp hasStub) + return (Just (HscRecomp hasStub)) -- Compile to hard-code. hscCompile :: CgGuts -> Comp Bool @@ -601,23 +653,24 @@ hscCompile cgguts <- {-# SCC "CoreToStg" #-} myCoreToStg dflags this_mod prepd_binds ------------------ Code generation ------------------ - abstractC <- {-# SCC "CodeGen" #-} + cmms <- {-# SCC "CodeGen" #-} codeGen dflags this_mod data_tycons - foreign_stubs dir_imps cost_centre_info + dir_imps cost_centre_info stg_binds hpc_info + --- Optionally run experimental Cmm transformations --- + cmms <- optionallyConvertAndOrCPS dflags cmms + -- ^ unless certain dflags are on, the identity function ------------------ Code output ----------------------- - (stub_h_exists,stub_c_exists) + rawcmms <- cmmToRawCmm cmms + (_stub_h_exists, stub_c_exists) <- codeOutput dflags this_mod location foreign_stubs - dependencies abstractC + 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) + -> Comp (Maybe (InteractiveStatus, ModIface, ModDetails)) #ifdef GHCI +hscInteractive (iface, details, cgguts) = do hsc_env <- gets compHscEnv mod_summary <- gets compModSummary liftIO $ do @@ -626,7 +679,8 @@ hscInteractive (iface, details, cgguts) 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 @@ -639,76 +693,26 @@ 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 + 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 (Just (InteractiveRecomp istub_c_exists comp_bc mod_breaks, iface, details)) #else - = panic "GHC not compiled with interpreter" +hscInteractive _ = panic "GHC not compiled with interpreter" #endif ------------------------------ -hscFileCheck :: HscEnv -> ModSummary -> IO (Maybe HscChecked) -hscFileCheck hsc_env mod_summary = 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)); - 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_rules = [panic "no rules"] } - -- Rules are CoreRules, not the - -- RuleDecls we get out of the typechecker - 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) - return (Just (HscChecked rdr_module - rnInfo - (Just (tcg_binds tc_result, - tcg_rdr_env tc_result, - md)))) - }}}} - - hscCmmFile :: DynFlags -> FilePath -> IO Bool hscCmmFile dflags filename = do maybe_cmm <- parseCmmFile dflags filename case maybe_cmm of Nothing -> return False Just cmm -> do - codeOutput dflags no_mod no_loc NoStubs [] [cmm] + cmms <- optionallyConvertAndOrCPS dflags [cmm] + rawCmms <- cmmToRawCmm cmms + codeOutput dflags no_mod no_loc NoStubs [] rawCmms return True where no_mod = panic "hscCmmFile: no_mod" @@ -716,7 +720,41 @@ hscCmmFile dflags filename = do ml_hi_file = panic "hscCmmFile: no hi file", ml_obj_file = panic "hscCmmFile: no obj file" } - +optionallyConvertAndOrCPS :: DynFlags -> [Cmm] -> IO [Cmm] +optionallyConvertAndOrCPS dflags cmms = + do -------- Optionally convert to and from zipper ------ + cmms <- if dopt Opt_ConvertToZipCfgAndBack dflags + then mapM (testCmmConversion dflags) cmms + else return cmms + --------- Optionally convert to CPS (MDA) ----------- + cmms <- if not (dopt Opt_ConvertToZipCfgAndBack dflags) && + dopt Opt_RunCPSZ dflags + then cmmCPS dflags cmms + else return cmms + return cmms + + +testCmmConversion :: DynFlags -> Cmm -> IO Cmm +testCmmConversion dflags cmm = + do 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 + cps_zgraph <- protoCmmCPSZ dflags 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 + -- return cmm -- don't use the conversion + +myParseModule :: DynFlags -> FilePath -> Maybe StringBuffer + -> IO (Either ErrMsg (Located (HsModule RdrName))) myParseModule dflags src_filename maybe_src_buf = -------------------------- Parser ---------------- showPass dflags "Parser" >> @@ -735,8 +773,12 @@ myParseModule dflags src_filename maybe_src_buf PFailed span err -> return (Left (mkPlainErrMsg span err)); - POk _ rdr_module -> do { + 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" @@ -747,6 +789,10 @@ myParseModule dflags src_filename maybe_src_buf }} +myCoreToStg :: DynFlags -> Module -> [CoreBind] + -> IO ( [(StgBinding,[(Id,[Id])])] -- output program + , CollectedCCs) -- cost centre info (declared and used) + myCoreToStg dflags this_mod prepd_binds = do stg_binds <- {-# SCC "Core2Stg" #-} @@ -796,7 +842,7 @@ A naked expression returns a singleton Name [it]. hscStmt -- Compile a stmt all the way to an HValue, but don't run it :: HscEnv -> String -- The statement - -> IO (Maybe (HscEnv, [Name], HValue)) + -> IO (Maybe ([Id], HValue)) hscStmt hsc_env stmt = do { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt @@ -811,12 +857,11 @@ hscStmt hsc_env stmt ; case maybe_tc_result of { Nothing -> return Nothing ; - Just (new_ic, bound_names, tc_expr) -> do { - + Just (ids, tc_expr) -> do { -- Desugar it - ; let rdr_env = ic_rn_gbl_env new_ic - type_env = ic_type_env new_ic + ; 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 { @@ -827,7 +872,7 @@ hscStmt hsc_env stmt ; let src_span = srcLocSpan interactiveSrcLoc ; hval <- compileExpr hsc_env src_span ds_expr - ; return (Just (hsc_env{ hsc_IC=new_ic }, bound_names, hval)) + ; return (Just (ids, hval)) }}}}}}} hscTcExpr -- Typecheck an expression (but don't run it) @@ -842,7 +887,7 @@ hscTcExpr hsc_env expr 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)) ; + Just _ -> do { errorMsg (hsc_dflags hsc_env) (text "not an expression:" <+> quotes (text expr)) ; return Nothing } ; } } @@ -891,7 +936,11 @@ hscParseThing parser dflags str PFailed span err -> do { printError span err; return Nothing }; - POk _ thing -> do { + POk pst thing -> do { + + let {ms = getMessages pst}; + printErrorsAndWarnings dflags ms; + when (errorsFound dflags ms) $ exitWith (ExitFailure 1); --ToDo: can't free the string buffer until we've finished this -- compilation sweep and all the identifiers have gone away. @@ -914,11 +963,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 @@ -929,7 +975,10 @@ compileExpr hsc_env srcspan ds_expr -- Lint if necessary -- ToDo: improve SrcLoc ; if lint_on then - case lintUnfolding noSrcLoc [] prepd_expr of + let ictxt = hsc_IC hsc_env + tyvars = varSetElems (ic_tyvars ictxt) + in + case lintUnfolding noSrcLoc tyvars prepd_expr of Just err -> pprPanic "compileExpr" err Nothing -> return () else @@ -973,6 +1022,7 @@ dumpIfaceStats hsc_env %************************************************************************ \begin{code} +showModuleIndex :: Maybe (Int, Int) -> String showModuleIndex Nothing = "" showModuleIndex (Just (i,n)) = "[" ++ padded ++ " of " ++ n_str ++ "] " where