X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FHscMain.lhs;h=ff1c11577b44fa93d8e155e4634c0bd9dae432f0;hb=40739684494d88dde2efad64f15be2acbcc884a2;hp=01525492ee857454a8d22b7ee488b4cf5f4ab26f;hpb=16a2f6a8a381af31c23b6a41a851951da9bc1803;p=ghc-hetmet.git diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 0152549..ff1c115 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -7,7 +7,6 @@ \begin{code} module HscMain ( newHscEnv, hscCmmFile - , hscFileCheck , hscParseIdentifier #ifdef GHCI , hscStmt, hscTcExpr, hscKcType @@ -19,13 +18,19 @@ 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(..), LStmt, LHsType ) import CodeOutput ( outputForeignStubs ) import ByteCodeGen ( byteCodeGen, coreExprToBCOs ) import Linker ( HValue, linkExpr ) @@ -47,9 +52,8 @@ import VarEnv ( emptyTidyEnv ) import Var ( Id ) import Module ( emptyModuleEnv, ModLocation(..), Module ) -import RdrName ( GlobalRdrEnv, RdrName, emptyGlobalRdrEnv ) -import HsSyn ( HsModule, LHsBinds, HsGroup, LIE, LImportDecl, HsDoc, - HaddockModInfo ) +import RdrName +import HsSyn import CoreSyn import SrcLoc ( Located(..) ) import StringBuffer @@ -62,10 +66,10 @@ 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 SimplCore ( core2core ) -import TidyPgm ( tidyProgram, mkBootModDetails ) +import TidyPgm import CorePrep ( corePrepPgm ) import CoreToStg ( coreToStg ) import StgSyn @@ -144,6 +148,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 @@ -183,18 +266,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)) - -- desugared - (Maybe [CoreBind]) - -- Status of a compilation to hard-code or nothing. data HscStatus = HscNoRecomp @@ -256,41 +327,6 @@ type Compiler result = HscEnv -> 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 ()) - -> Comp (Maybe ModGuts) -- Front end - -> (ModGuts -> 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) - -------------------------------------------------------------- -- Compilers -------------------------------------------------------------- @@ -333,9 +369,34 @@ hscCompiler -> (ModGuts -> Comp result) -- Compile normal file -> (ModGuts -> Comp result) -- Compile boot file -> Compiler result -hscCompiler norecomp msg nonBootComp bootComp hsc_env mod_summary = - hscMkCompiler norecomp msg frontend backend hsc_env mod_summary +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" #-} + 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 + mb_modguts <- frontend + case mb_modguts of + Nothing + -> return Nothing + Just core + -> do result <- backend core + return (Just result) where + frontend :: Comp (Maybe ModGuts) -- Front end + -- backend :: (ModGuts -> Comp result) -- Backend. (frontend,backend) = case ms_hsc_src mod_summary of ExtCoreFile -> (hscCoreFrontEnd, nonBootComp) @@ -487,10 +548,10 @@ hscSimpleIface ds_result _mod_summary <- gets compModSummary maybe_old_iface <- gets compOldIface liftIO $ do - details <- mkBootModDetails hsc_env ds_result + details <- mkBootModDetailsDs hsc_env ds_result (new_iface, no_change) <- {-# SCC "MkFinalIface" #-} - mkIface hsc_env maybe_old_iface ds_result details + mkIface hsc_env maybe_old_iface details ds_result -- And the answer is ... dumpIfaceStats hsc_env return (new_iface, no_change, details, ds_result) @@ -515,7 +576,7 @@ 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 dumpIfaceStats hsc_env @@ -594,17 +655,9 @@ hscCompile cgguts codeGen dflags this_mod data_tycons dir_imps cost_centre_info stg_binds hpc_info - -------- Optionally convert to and from zipper ------ - cmms <- - if dopt Opt_ConvertToZipCfgAndBack dflags - then mapM (testCmmConversion dflags) cmms - else return cmms - ------------ Optionally convert to CPS -------------- - cmms <- - if not (dopt Opt_ConvertToZipCfgAndBack dflags) && - dopt Opt_RunCPSZ dflags - then cmmCPS dflags cmms - else return cmms + --- Optionally run experimental Cmm transformations --- + cmms <- optionallyConvertAndOrCPS dflags cmms + -- ^ unless certain dflags are on, the identity function ------------------ Code output ----------------------- rawcmms <- cmmToRawCmm cmms (_stub_h_exists, stub_c_exists) @@ -649,78 +702,15 @@ hscInteractive _ = panic "GHC not compiled with interpreter" ------------------------------ -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_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 - cmm <- testCmmConversion dflags cmm - --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" @@ -728,6 +718,20 @@ 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"