X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FHscMain.lhs;h=422c2701724f716c4fbb547447cb43f0df6f0527;hb=1717c5831d71bfa63f9d098a2a709feb2d8fbcc9;hp=e170f8fa31f351739aa92ccd39ec4b55d9ba1f24;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index e170f8f..422c270 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -25,11 +25,11 @@ module HscMain #include "HsVersions.h" #ifdef GHCI -import HsSyn ( Stmt(..), LHsExpr, LStmt, LHsType ) -import Module ( Module ) +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 ) @@ -41,13 +41,13 @@ import PrelNames ( iNTERACTIVE ) import Kind ( Kind ) import CoreLint ( lintUnfolding ) import DsMeta ( templateHaskellNames ) -import SrcLoc ( noSrcLoc ) +import SrcLoc ( SrcSpan, noSrcLoc, interactiveSrcLoc, srcLocSpan ) import VarEnv ( emptyTidyEnv ) #endif import Var ( Id ) import Module ( emptyModuleEnv, ModLocation(..) ) -import RdrName ( GlobalRdrEnv, RdrName ) +import RdrName ( GlobalRdrEnv, RdrName, emptyGlobalRdrEnv ) import HsSyn ( HsModule, LHsBinds, HsGroup, LIE, LImportDecl ) import SrcLoc ( Located(..) ) import StringBuffer ( hGetStringBuffer, stringToStringBuffer ) @@ -68,12 +68,12 @@ import TidyPgm ( tidyProgram, mkBootModDetails ) import CorePrep ( corePrepPgm ) import CoreToStg ( coreToStg ) import TyCon ( isDataTyCon ) -import Packages ( mkHomeModules ) import Name ( Name, NamedThing(..) ) import SimplStg ( stg2stg ) import CodeGen ( codeGen ) import CmmParse ( parseCmmFile ) import CodeOutput ( codeOutput ) +import NameEnv ( emptyNameEnv ) import DynFlags import ErrUtils @@ -86,7 +86,7 @@ import MkExternalCore ( emitExternalCore ) import ParserCore import ParserCoreUtils import FastString -import Maybes ( expectJust ) +import UniqFM ( emptyUFM ) import Bag ( unitBag ) import Monad ( unless ) import IO @@ -106,7 +106,8 @@ newHscEnv dflags = do { eps_var <- newIORef initExternalPackageState ; us <- mkSplitUniqSupply 'r' ; nc_var <- newIORef (initNameCache us knownKeyNames) - ; fc_var <- newIORef emptyModuleEnv + ; fc_var <- newIORef emptyUFM + ; mlc_var <- newIORef emptyModuleEnv ; return (HscEnv { hsc_dflags = dflags, hsc_targets = [], hsc_mod_graph = [], @@ -114,7 +115,10 @@ newHscEnv dflags hsc_HPT = emptyHomePackageTable, hsc_EPS = eps_var, hsc_NC = nc_var, - hsc_FC = fc_var } ) } + hsc_FC = fc_var, + hsc_MLC = mlc_var, + hsc_global_rdr_env = emptyGlobalRdrEnv, + hsc_global_type_env = emptyNameEnv } ) } knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta, @@ -214,6 +218,9 @@ data CompState 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) @@ -250,6 +257,10 @@ hscMkCompiler norecomp messenger frontend backend <- {-# 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 @@ -387,9 +398,9 @@ batchMsg mb_mod_index recomp liftIO $ do if recomp then showMsg "Compiling " - else showMsg "Skipping " - - + else if verbosity (hsc_dflags hsc_env) >= 2 + then showMsg "Skipping " + else return () -------------------------------------------------------------- -- FrontEnds @@ -451,10 +462,7 @@ hscFileFrontEnd = ------------------- -- DESUGAR ------------------- - -> do (warns, maybe_ds_result) <- {-# SCC "DeSugar" #-} - deSugar hsc_env tc_result - printBagOfWarnings dflags warns - return maybe_ds_result + -> {-# SCC "DeSugar" #-} deSugar hsc_env tc_result -------------------------------------------------------------- -- Simplifiers @@ -516,7 +524,7 @@ hscNormalIface simpl_result <- {-# SCC "MkFinalIface" #-} mkIface hsc_env maybe_old_iface simpl_result details -- Emit external core - emitExternalCore (hsc_dflags hsc_env) cg_guts -- Move this? --Lemmih 03/07/2006 + emitExternalCore (hsc_dflags hsc_env) (mg_exports simpl_result) cg_guts -- Move this? --Lemmih 03/07/2006 dumpIfaceStats hsc_env ------------------- @@ -569,7 +577,6 @@ hscCompile cgguts cg_tycons = tycons, cg_dir_imps = dir_imps, cg_foreign = foreign_stubs, - cg_home_mods = home_mods, cg_dep_pkgs = dependencies } = cgguts dflags = hsc_dflags hsc_env location = ms_location mod_summary @@ -585,10 +592,10 @@ hscCompile cgguts ----------------- Convert to STG ------------------ (stg_binds, cost_centre_info) <- {-# SCC "CoreToStg" #-} - myCoreToStg dflags home_mods this_mod prepd_binds + myCoreToStg dflags this_mod prepd_binds ------------------ Code generation ------------------ abstractC <- {-# SCC "CodeGen" #-} - codeGen dflags home_mods this_mod data_tycons + codeGen dflags this_mod data_tycons foreign_stubs dir_imps cost_centre_info stg_binds ------------------ Code output ----------------------- @@ -686,7 +693,7 @@ hscFileCheck hsc_env mod_summary = do { hscCmmFile :: DynFlags -> FilePath -> IO Bool hscCmmFile dflags filename = do - maybe_cmm <- parseCmmFile dflags (mkHomeModules []) filename + maybe_cmm <- parseCmmFile dflags filename case maybe_cmm of Nothing -> return False Just cmm -> do @@ -729,13 +736,13 @@ myParseModule dflags src_filename maybe_src_buf }} -myCoreToStg dflags home_mods this_mod prepd_binds +myCoreToStg dflags this_mod prepd_binds = do stg_binds <- {-# SCC "Core2Stg" #-} - coreToStg home_mods prepd_binds + coreToStg (thisPackage dflags) prepd_binds (stg_binds2, cost_centre_info) <- {-# SCC "Stg2Stg" #-} - stg2stg dflags home_mods this_mod stg_binds + stg2stg dflags this_mod stg_binds return (stg_binds2, cost_centre_info) \end{code} @@ -795,14 +802,22 @@ hscStmt hsc_env stmt Nothing -> return Nothing ; Just (new_ic, bound_names, tc_expr) -> do { + + -- Desugar it + ; let rdr_env = ic_rn_gbl_env new_ic + type_env = ic_type_env new_ic + ; 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 - ; hval <- compileExpr hsc_env iNTERACTIVE - (ic_rn_gbl_env new_ic) - (ic_type_env new_ic) - tc_expr + ; let src_span = srcLocSpan interactiveSrcLoc + ; hval <- compileExpr hsc_env src_span ds_expr ; return (Just (hsc_env{ hsc_IC=new_ic }, bound_names, hval)) - }}}}} + }}}}}}} hscTcExpr -- Typecheck an expression (but don't run it) :: HscEnv @@ -829,10 +844,8 @@ 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 ; - Just other -> do { errorMsg (hsc_dflags hsc_env) (text "not an type:" <+> quotes (text str)) ; - return Nothing } ; - Nothing -> return Nothing } } + Just ty -> tcRnType hsc_env icontext ty ; + Nothing -> return Nothing } } #endif \end{code} @@ -884,18 +897,12 @@ hscParseThing parser dflags str \begin{code} #ifdef GHCI -compileExpr :: HscEnv - -> Module -> GlobalRdrEnv -> TypeEnv - -> LHsExpr Id - -> IO HValue +compileExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue -compileExpr hsc_env this_mod rdr_env type_env tc_expr +compileExpr hsc_env srcspan ds_expr = do { let { dflags = hsc_dflags hsc_env ; lint_on = dopt Opt_DoCoreLinting dflags } - -- Desugar it - ; ds_expr <- deSugarExpr hsc_env this_mod rdr_env type_env tc_expr - -- Flatten it ; flat_expr <- flattenExpr hsc_env ds_expr @@ -921,7 +928,7 @@ compileExpr hsc_env this_mod rdr_env type_env tc_expr ; bcos <- coreExprToBCOs dflags prepd_expr -- link it - ; hval <- linkExpr hsc_env bcos + ; hval <- linkExpr hsc_env srcspan bcos ; return hval }