X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnDriver.lhs;h=8468f8753723667761adfac5b624223047fa438b;hp=05777df471c803f65bcb8f33511edd9e1ec01eb8;hb=c1681a73fa4ca4cf8758264ae387ac09a9e900d8;hpb=c94fac1c94f35f344edd6818db13a3fc021674b5 diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 05777df..8468f87 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -12,7 +12,6 @@ module TcRnDriver ( tcRnLookupName, tcRnGetInfo, getModuleExports, - tcRnRecoverDataCon, #endif tcRnModule, tcTopSrcDecls, @@ -62,7 +61,6 @@ import CoreSyn import ErrUtils import Id import Var -import VarSet import Module import UniqFM import Name @@ -89,6 +87,7 @@ import TysWiredIn import IdInfo import {- Kind parts of -} Type import BasicTypes +import Foreign.Ptr( Ptr ) #endif import FastString @@ -98,7 +97,6 @@ import Bag import Control.Monad ( unless ) import Data.Maybe ( isJust ) -import Foreign.Ptr ( Ptr ) \end{code} @@ -199,7 +197,7 @@ tcRnModule hsc_env hsc_src save_rn_syntax \begin{code} tcRnImports :: HscEnv -> Module -> [LImportDecl RdrName] -> TcM TcGblEnv tcRnImports hsc_env this_mod import_decls - = do { (rn_imports, rdr_env, imports) <- rnImports import_decls ; + = do { (rn_imports, rdr_env, imports,hpc_info) <- rnImports import_decls ; ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface) ; dep_mods = imp_dep_mods imports @@ -211,7 +209,8 @@ tcRnImports hsc_env this_mod import_decls ; want_instances :: ModuleName -> Bool ; want_instances mod = mod `elemUFM` dep_mods && mod /= moduleName this_mod - ; home_insts = hptInstances hsc_env want_instances + ; (home_insts, home_fam_insts) = hptInstances hsc_env + want_instances } ; -- Record boot-file info in the EPS, so that it's @@ -221,11 +220,15 @@ tcRnImports hsc_env this_mod import_decls -- Update the gbl env ; updGblEnv ( \ gbl -> - gbl { tcg_rdr_env = plusOccEnv (tcg_rdr_env gbl) rdr_env, - tcg_imports = tcg_imports gbl `plusImportAvails` imports, - tcg_rn_imports = fmap (const rn_imports) (tcg_rn_imports gbl), - tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts - }) $ do { + gbl { + tcg_rdr_env = plusOccEnv (tcg_rdr_env gbl) rdr_env, + tcg_imports = tcg_imports gbl `plusImportAvails` imports, + tcg_rn_imports = fmap (const rn_imports) (tcg_rn_imports gbl), + tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts, + tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl) + home_fam_insts, + tcg_hpc = hpc_info + }) $ do { ; traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) -- Fail if there are any errors so far @@ -311,6 +314,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) mg_types = final_type_env, mg_insts = tcg_insts tcg_env, mg_fam_insts = tcg_fam_insts tcg_env, + mg_inst_env = tcg_inst_env tcg_env, mg_fam_inst_env = tcg_fam_inst_env tcg_env, mg_rules = [], mg_binds = core_binds, @@ -320,8 +324,9 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) mg_fix_env = emptyFixityEnv, mg_deprecs = NoDeprecs, mg_foreign = NoStubs, - mg_hpc_info = noHpcInfo, - mg_modBreaks = emptyModBreaks + mg_hpc_info = emptyHpcInfo False, + mg_modBreaks = emptyModBreaks, + mg_vect_info = noVectInfo } } ; tcCoreDump mod_guts ; @@ -691,10 +696,10 @@ tcTopSrcDecls boot_details (tc_val_binds, tcl_env) <- tcTopBinds val_binds ; setLclTypeEnv tcl_env $ do { - -- Now GHC-generated derived bindings and generics - -- Do not generate warnings from compiler-generated code - (tc_deriv_binds, tcl_env) <- discardWarnings $ setOptM Opt_GlasgowExts $ - tcTopBinds deriv_binds ; + -- Now GHC-generated derived bindings and generics. + -- Do not generate warnings from compiler-generated code. + (tc_deriv_binds, tcl_env) <- discardWarnings $ + tcTopBinds deriv_binds ; -- Second pass over class and instance declarations, traceTc (text "Tc6") ; @@ -739,23 +744,16 @@ checkMain :: TcM TcGblEnv checkMain = do { tcg_env <- getGblEnv ; dflags <- getDOpts ; - let { main_mod = mainModIs dflags ; - main_fn = case mainFunIs dflags of { - Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn)) ; - Nothing -> main_RDR_Unqual } } ; - - check_main dflags tcg_env main_mod main_fn + check_main dflags tcg_env } - -check_main dflags tcg_env main_mod main_fn +check_main dflags tcg_env | mod /= main_mod = traceTc (text "checkMain not" <+> ppr main_mod <+> ppr mod) >> return tcg_env | otherwise - = addErrCtxt mainCtxt $ - do { mb_main <- lookupSrcOcc_maybe main_fn + = do { mb_main <- lookupSrcOcc_maybe main_fn -- Check that 'main' is in scope -- It might be imported from another module! ; case mb_main of { @@ -763,17 +761,19 @@ check_main dflags tcg_env main_mod main_fn ; complain_no_main ; return tcg_env } ; Just main_name -> do + { traceTc (text "checkMain found" <+> ppr main_mod <+> ppr main_fn) ; let { rhs = nlHsApp (nlHsVar runMainIOName) (nlHsVar main_name) } -- :Main.main :: IO () = runMainIO main - ; (main_expr, ty) <- setSrcSpan (srcLocSpan (getSrcLoc main_name)) $ + ; (main_expr, ty) <- addErrCtxt mainCtxt $ + setSrcSpan (srcLocSpan (getSrcLoc main_name)) $ tcInferRho rhs -- See Note [Root-main Id] ; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN (mkVarOccFS FSLIT("main")) - (getSrcLoc main_name) + (getSrcSpan main_name) ; root_main_id = Id.mkExportedLocalId root_main_name ty ; main_bind = noLoc (VarBind root_main_id main_expr) } @@ -786,17 +786,25 @@ check_main dflags tcg_env main_mod main_fn }) }}} where - mod = tcg_mod tcg_env - + mod = tcg_mod tcg_env + main_mod = mainModIs dflags + main_is_flag = mainFunIs dflags + + main_fn = case main_is_flag of + Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn)) + Nothing -> main_RDR_Unqual + complain_no_main | ghcLink dflags == LinkInMemory = return () | otherwise = failWithTc noMainMsg -- In interactive mode, don't worry about the absence of 'main' -- In other modes, fail altogether, so that we don't go on -- and complain a second time when processing the export list. - mainCtxt = ptext SLIT("When checking the type of the main function") <+> quotes (ppr main_fn) - noMainMsg = ptext SLIT("The main function") <+> quotes (ppr main_fn) + mainCtxt = ptext SLIT("When checking the type of the") <+> pp_main_fn + noMainMsg = ptext SLIT("The") <+> pp_main_fn <+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod) + pp_main_fn | isJust main_is_flag = ptext SLIT("main function") <+> quotes (ppr main_fn) + | otherwise = ptext SLIT("function") <+> quotes (ppr main_fn) \end{code} Note [Root-main Id] @@ -826,26 +834,25 @@ setInteractiveContext hsc_env icxt thing_inside -- Initialise the tcg_inst_env with instances -- from all home modules. This mimics the more selective -- call to hptInstances in tcRnModule - dfuns = hptInstances hsc_env (\mod -> True) + dfuns = fst (hptInstances hsc_env (\mod -> True)) in updGblEnv (\env -> env { tcg_rdr_env = ic_rn_gbl_env icxt, tcg_inst_env = extendInstEnvList (tcg_inst_env env) dfuns }) $ - tcExtendIdEnv (typeEnvIds (ic_type_env icxt)) $ - -- tcExtendIdEnv does lots: + tcExtendGhciEnv (ic_tmp_ids icxt) $ + -- tcExtendGhciEnv does lots: -- - it extends the local type env (tcl_env) with the given Ids, -- - it extends the local rdr env (tcl_rdr) with the Names from -- the given Ids -- - it adds the free tyvars of the Ids to the tcl_tyvars -- set. -- - -- We should have no Ids with the same name in the - -- ic_type_env, otherwise we'll end up with shadowing in the - -- tcl_rdr, and it's random which one will be in scope. + -- later ids in ic_tmp_ids must shadow earlier ones with the same + -- OccName, and tcExtendIdEnv implements this behaviour. - do { traceTc (text "setIC" <+> ppr (ic_type_env icxt)) + do { traceTc (text "setIC" <+> ppr (ic_tmp_ids icxt)) ; thing_inside } \end{code} @@ -854,9 +861,10 @@ setInteractiveContext hsc_env icxt thing_inside tcRnStmt :: HscEnv -> InteractiveContext -> LStmt RdrName - -> IO (Maybe (InteractiveContext, [Name], LHsExpr Id)) - -- The returned [Name] is the same as the input except for - -- ExprStmt, in which case the returned [Name] is [itName] + -> IO (Maybe ([Id], LHsExpr Id)) + -- The returned [Id] is the list of new Ids bound by + -- this statement. It can be used to extend the + -- InteractiveContext via extendInteractiveContext. -- -- The returned TypecheckedHsExpr is of type IO [ () ], -- a list of the bound values, coerced to (). @@ -891,8 +899,6 @@ tcRnStmt hsc_env ictxt rdr_stmt -- up to have tidy types global_ids = map globaliseAndTidy zonked_ids ; - bound_names = map idName global_ids ; - {- --------------------------------------------- At one stage I removed any shadowed bindings from the type_env; they are inaccessible but might, I suppose, cause a space leak if we leave them there. @@ -911,15 +917,13 @@ tcRnStmt hsc_env ictxt rdr_stmt Hence this code is commented out -------------------------------------------------- -} - - new_ic = extendInteractiveContext ictxt global_ids emptyVarSet ; } ; dumpOptTcRn Opt_D_dump_tc (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids, text "Typechecked expr" <+> ppr zonked_expr]) ; - returnM (new_ic, bound_names, zonked_expr) + returnM (global_ids, zonked_expr) } where bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"), @@ -1201,13 +1205,6 @@ lookup_rdr_name rdr_name = do { return good_names } -tcRnRecoverDataCon :: HscEnv -> Ptr () -> IO (Maybe DataCon) -tcRnRecoverDataCon hsc_env ptr - = initTcPrintErrors hsc_env iNTERACTIVE $ - setInteractiveContext hsc_env (hsc_IC hsc_env) $ do - name <- dataConInfoPtrToName ptr - tcLookupDataCon name - tcRnLookupName :: HscEnv -> Name -> IO (Maybe TyThing) tcRnLookupName hsc_env name = initTcPrintErrors hsc_env iNTERACTIVE $