X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FHscMain.lhs;h=9a7a255395a2aa03280c5c6fb017c2b7bca9ed46;hp=2d1f71e33b2693a7b7c17404dc197ae1ff336da4;hb=6a05ec5ef5373f61b7f9f5bdc344483417fa801b;hpb=913c612f25e118f06a2c21617fbccf34b80f1146 diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 2d1f71e..9a7a255 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -25,11 +25,10 @@ module HscMain #include "HsVersions.h" #ifdef GHCI -import HsSyn ( Stmt(..), LStmt, LHsType ) +import HsSyn ( StmtLR(..), 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 ) @@ -47,13 +46,13 @@ import VarEnv ( emptyTidyEnv ) #endif import Var ( Id ) -import Module ( emptyModuleEnv, ModLocation(..) ) +import Module ( emptyModuleEnv, ModLocation(..), Module ) import RdrName ( GlobalRdrEnv, RdrName, emptyGlobalRdrEnv ) import HsSyn ( HsModule, LHsBinds, HsGroup, LIE, LImportDecl, HsDoc, HaddockModInfo ) import CoreSyn import SrcLoc ( Located(..) ) -import StringBuffer ( hGetStringBuffer, stringToStringBuffer ) +import StringBuffer import Parser import Lexer import SrcLoc ( mkSrcLoc ) @@ -65,18 +64,24 @@ import LoadIface ( ifaceStats, initExternalPackageState ) import PrelInfo ( wiredInThings, basicKnownKeyNames ) import MkIface ( checkOldIface, mkIface, writeIfaceFile ) import Desugar ( deSugar ) -import Flattening ( flatten ) import SimplCore ( core2core ) import TidyPgm ( tidyProgram, mkBootModDetails ) 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 ) @@ -92,6 +97,7 @@ import ParserCore import ParserCoreUtils import FastString import UniqFM ( emptyUFM ) +import UniqSupply ( initUs_ ) import Bag ( unitBag ) import Control.Monad @@ -203,6 +209,7 @@ data InteractiveStatus = InteractiveNoRecomp | InteractiveRecomp Bool -- Same as HscStatus CompiledByteCode + ModBreaks -- I want Control.Monad.State! --Lemmih 03/07/2006 @@ -239,7 +246,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. @@ -250,17 +256,50 @@ 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 backend boot_backend + where + backend inp = hscSimplify inp >>= hscNormalIface >>= hscWriteIface >>= hscOneShot + boot_backend inp = hscSimpleIface inp >>= hscWriteIface >> return (HscRecomp False) + +-- Compile Haskell, boot and extCore in batch mode. +hscCompileBatch :: Compiler (HscStatus, ModIface, ModDetails) +hscCompileBatch + = hscCompiler norecompBatch batchMsg backend boot_backend + where + backend inp = hscSimplify inp >>= hscNormalIface >>= hscWriteIface >>= hscBatch + boot_backend inp = hscSimpleIface inp >>= hscWriteIface >>= hscNothing + +-- Type-check Haskell, boot and extCore. +-- Does it make sense to compile extCore to nothing? +hscCompileNothing :: Compiler (HscStatus, ModIface, ModDetails) +hscCompileNothing + = hscCompiler norecompBatch batchMsg backend backend + where + backend inp = hscSimpleIface inp >>= hscIgnoreIface >>= hscNothing --- 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, extCore to bytecode. +hscCompileInteractive :: Compiler (InteractiveStatus, ModIface, ModDetails) +hscCompileInteractive + = hscCompiler norecompInteractive batchMsg backend boot_backend + where + backend inp = hscSimplify inp >>= hscNormalIface >>= hscIgnoreIface >>= hscInteractive + boot_backend = panic "hscCompileInteractive: can't do boot files here" + +hscCompiler + :: NoRecomp result -- No recomp necessary + -> (Maybe (Int,Int) -> Bool -> Comp ()) -- Message callback + -> (ModGuts -> Comp result) -- Compile normal file + -> (ModGuts -> Comp result) -- Compile boot file + -> Compiler result +hscCompiler norecomp messenger nonBootComp bootComp hsc_env mod_summary + source_unchanged mbOldIface mbModIndex = flip evalComp (CompState hsc_env mod_summary mbOldIface) $ do (recomp_reqd, mbCheckedIface) <- {-# SCC "checkOldIface" #-} @@ -277,86 +316,28 @@ hscMkCompiler norecomp messenger frontend backend return (Just result) _otherwise -> do messenger mbModIndex True - mbCore <- frontend - case mbCore of + mb_modguts <- frontend + case mb_modguts 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 = hscCompileHardCode norecompOneShot oneShotMsg hscOneShot (hscConst (HscRecomp False)) - --- 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 + where + frontend :: Comp (Maybe ModGuts) -- Front end + -- backend :: (ModGuts -> Comp result) -- Backend. + (frontend,backend) = 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." + ExtCoreFile -> (hscCoreFrontEnd, nonBootComp) + HsSrcFile -> (hscFileFrontEnd, nonBootComp) + HsBootFile -> (hscFileFrontEnd, bootComp) -------------------------------------------------------------- -- NoRecomp handlers -------------------------------------------------------------- norecompOneShot :: NoRecomp HscStatus -norecompOneShot old_iface +norecompOneShot _old_iface = do hsc_env <- gets compHscEnv liftIO $ do dumpIfaceStats hsc_env @@ -369,9 +350,9 @@ 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 + _mod_summary <- gets compModSummary liftIO $ do new_details <- {-# SCC "tcRnIface" #-} initIfaceCheck hsc_env $ @@ -410,7 +391,7 @@ batchMsg mb_mod_index recomp -- FrontEnds -------------------------------------------------------------- -hscCoreFrontEnd :: FrontEnd ModGuts +hscCoreFrontEnd :: Comp (Maybe ModGuts) hscCoreFrontEnd = do hsc_env <- gets compHscEnv mod_summary <- gets compModSummary @@ -435,7 +416,7 @@ hscCoreFrontEnd = Just mod_guts -> return (Just mod_guts) -- No desugaring to do! -hscFileFrontEnd :: FrontEnd ModGuts +hscFileFrontEnd :: Comp (Maybe ModGuts) hscFileFrontEnd = do hsc_env <- gets compHscEnv mod_summary <- gets compModSummary @@ -493,7 +474,7 @@ hscSimplify ds_result hscSimpleIface :: ModGuts -> Comp (ModIface, Bool, ModDetails, ModGuts) hscSimpleIface ds_result = do hsc_env <- gets compHscEnv - mod_summary <- gets compModSummary + _mod_summary <- gets compModSummary maybe_old_iface <- gets compOldIface liftIO $ do details <- mkBootModDetails hsc_env ds_result @@ -507,7 +488,7 @@ hscSimpleIface ds_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 ------------------- @@ -548,12 +529,12 @@ 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) +hscNothing (iface, details, _) = return (HscRecomp False, iface, details) -- Generate code and return both the new ModIface and the ModDetails. @@ -599,26 +580,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 - ------------------ Convert to CPS -------------------- - --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm - continuationC <- cmmToRawCmm abstractC + --- 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 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) #ifdef GHCI +hscInteractive (iface, details, cgguts) = do hsc_env <- gets compHscEnv mod_summary <- gets compModSummary liftIO $ do @@ -627,7 +606,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 @@ -640,13 +620,13 @@ 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 (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 ------------------------------ @@ -671,7 +651,7 @@ hscFileCheck hsc_env mod_summary compileToCore = do { -- RENAME and TYPECHECK ------------------- (tc_msgs, maybe_tc_result) - <- _scc_ "Typecheck-Rename" + <- {-# SCC "Typecheck-Rename" #-} tcRnModule hsc_env (ms_hsc_src mod_summary) True{-save renamed syntax-} rdr_module @@ -686,7 +666,6 @@ hscFileCheck hsc_env mod_summary compileToCore = do { 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 @@ -720,9 +699,9 @@ hscCmmFile dflags filename = do 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 + cmms <- optionallyConvertAndOrCPS dflags [cmm] + rawCmms <- cmmToRawCmm cmms + codeOutput dflags no_mod no_loc NoStubs [] rawCmms return True where no_mod = panic "hscCmmFile: no_mod" @@ -730,7 +709,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" >> @@ -765,6 +778,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" #-} @@ -859,7 +876,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 } ; } } @@ -997,6 +1014,7 @@ dumpIfaceStats hsc_env %************************************************************************ \begin{code} +showModuleIndex :: Maybe (Int, Int) -> String showModuleIndex Nothing = "" showModuleIndex (Just (i,n)) = "[" ++ padded ++ " of " ++ n_str ++ "] " where