X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnDriver.lhs;h=30574ae70632e31072bedada0a1a3d974f177c73;hp=bd7630397173de7006c61ba191bd5b8b9fa31d04;hb=7bb3d1fc79521d591cd9f824893963141a7997b6;hpb=cae75f82226638691cfa1e85fc168f4b65ddce4d diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index bd76303..30574ae 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -34,7 +34,6 @@ import DynFlags import StaticFlags import HsSyn import RdrHsSyn - import PrelNames import RdrName import TcHsSyn @@ -45,6 +44,7 @@ import Inst import FamInst import InstEnv import FamInstEnv +import TcAnnotations import TcBinds import TcDefaults import TcEnv @@ -97,6 +97,7 @@ import IdInfo import {- Kind parts of -} Type import BasicTypes import Foreign.Ptr( Ptr ) +import TidyPgm ( globaliseAndTidyId ) #endif import FastString @@ -181,10 +182,11 @@ tcRnModule hsc_env hsc_src save_rn_syntax -- Must be done after processing the exports tcg_env <- checkHiBootIface tcg_env boot_iface ; - -- Make the new type env available to stuff slurped from interface files - -- Must do this after checkHiBootIface, because the latter might add new - -- bindings for boot_dfuns, which may be mentioned in imported unfoldings - writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ; + -- The new type env is already available to stuff slurped from + -- interface files, via TcEnv.updateGlobalTypeEnv + -- It's important that this includes the stuff in checkHiBootIface, + -- because the latter might add new bindings for boot_dfuns, + -- which may be mentioned in imported unfoldings -- Rename the Haddock documentation tcg_env <- rnHaddock module_info maybe_doc tcg_env ; @@ -234,7 +236,7 @@ tcRnImports hsc_env this_mod import_decls 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_rn_imports = rn_imports, tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts, tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl) home_fam_insts, @@ -293,8 +295,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) -- (in fact, it might not even need to be in the scope of -- this tcg_env at all) avails <- getLocalNonValBinders (mkFakeGroup ldecls) ; - tc_envs <- extendGlobalRdrEnvRn False avails - emptyFsEnv {- no fixity decls -} ; + tc_envs <- extendGlobalRdrEnvRn avails emptyFsEnv {- no fixity decls -} ; setEnvs tc_envs $ do { @@ -305,10 +306,12 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) -- Typecheck them all together so that -- any mutually recursive types are done right - tcg_env <- tcTyAndClassDecls emptyModDetails rn_decls ; - -- Make the new type env available to stuff slurped from interface files + -- Just discard the auxiliary bindings; they are generated + -- only for Haskell source code, and should already be in Core + (tcg_env, _aux_binds) <- tcTyAndClassDecls emptyModDetails rn_decls ; setGblEnv tcg_env $ do { + -- Make the new type env available to stuff slurped from interface files -- Now the core bindings core_binds <- initIfaceExtCore (tcExtCoreBindings src_binds) ; @@ -319,7 +322,8 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) my_exports = map (Avail . idName) bndrs ; -- ToDo: export the data types also? - final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ; + final_type_env = + extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ; mod_guts = ModGuts { mg_module = this_mod, mg_boot = False, @@ -390,8 +394,10 @@ tcRnSrcDecls boot_iface decls -- Even tcSimplifyTop may do some unification. traceTc (text "Tc9") ; let { (tcg_env, _) = tc_envs - ; TcGblEnv { tcg_type_env = type_env, tcg_binds = binds, - tcg_rules = rules, tcg_fords = fords } = tcg_env + ; TcGblEnv { tcg_type_env = type_env, + tcg_binds = binds, + tcg_rules = rules, + tcg_fords = fords } = tcg_env ; all_binds = binds `unionBags` inst_binds } ; failIfErrsM ; -- Don't zonk if there have been errors @@ -400,13 +406,13 @@ tcRnSrcDecls boot_iface decls (bind_ids, binds', fords', rules') <- zonkTopDecls all_binds rules fords ; + let { final_type_env = extendTypeEnvWithIds type_env bind_ids - ; tcg_env' = tcg_env { tcg_type_env = final_type_env, - tcg_binds = binds', + ; tcg_env' = tcg_env { tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' } } ; - return (tcg_env' { tcg_binds = tcg_binds tcg_env' }) + setGlobalTypeEnv tcg_env' final_type_env } tc_rn_src_decls :: ModDetails -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv) @@ -468,26 +474,32 @@ tcRnHsBootDecls decls Nothing -> return () -- Rename the declarations - ; (tcg_env, rn_group) <- rnTopSrcDecls first_group + ; (tcg_env, HsGroup { + hs_tyclds = tycl_decls, + hs_instds = inst_decls, + hs_derivds = deriv_decls, + hs_fords = _, + hs_defds = _, -- Todo: check no foreign decls, no rules, + hs_ruleds = _, -- no default decls and no annotation decls + hs_annds = _, + hs_valds = val_binds }) <- rnTopSrcDecls first_group ; setGblEnv tcg_env $ do { - -- Todo: check no foreign decls, no rules, no default decls -- Typecheck type/class decls ; traceTc (text "Tc2") - ; let tycl_decls = hs_tyclds rn_group - ; tcg_env <- tcTyAndClassDecls emptyModDetails tycl_decls + ; (tcg_env, aux_binds) <- tcTyAndClassDecls emptyModDetails tycl_decls ; setGblEnv tcg_env $ do { -- Typecheck instance decls ; traceTc (text "Tc3") ; (tcg_env, inst_infos, _deriv_binds) - <- tcInstDecls1 tycl_decls (hs_instds rn_group) (hs_derivds rn_group) + <- tcInstDecls1 tycl_decls inst_decls deriv_decls ; setGblEnv tcg_env $ do { -- Typecheck value declarations ; traceTc (text "Tc5") - ; val_ids <- tcHsBootSigs (hs_valds rn_group) + ; val_ids <- tcHsBootSigs val_binds -- Wrap up -- No simplification or zonking to do @@ -496,12 +508,19 @@ tcRnHsBootDecls decls -- Make the final type-env -- Include the dfun_ids so that their type sigs - -- are written into the interface file + -- are written into the interface file. + -- And similarly the aux_ids from aux_binds ; let { type_env0 = tcg_type_env gbl_env ; type_env1 = extendTypeEnvWithIds type_env0 val_ids ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids - ; dfun_ids = map iDFunId inst_infos } - ; return (gbl_env { tcg_type_env = type_env2 }) + ; type_env3 = extendTypeEnvWithIds type_env1 aux_ids + ; dfun_ids = map iDFunId inst_infos + ; aux_ids = case aux_binds of + ValBindsOut _ sigs -> [id | L _ (IdSig id) <- sigs] + _ -> panic "tcRnHsBoodDecls" + } + + ; setGlobalTypeEnv gbl_env type_env2 }}}} spliceInHsBootErr (SpliceDecl (L loc _), _) @@ -537,15 +556,6 @@ checkHiBootIface -- Check the exports of the boot module, one by one ; mapM_ check_export boot_exports - -- Check instance declarations - ; mb_dfun_prs <- mapM check_inst boot_insts - ; let tcg_env' = tcg_env { tcg_binds = binds `unionBags` dfun_binds, - tcg_type_env = extendTypeEnvWithIds local_type_env boot_dfuns } - dfun_prs = catMaybes mb_dfun_prs - boot_dfuns = map fst dfun_prs - dfun_binds = listToBag [ noLoc $ VarBind boot_dfun (nlHsVar dfun) - | (boot_dfun, dfun) <- dfun_prs ] - -- Check for no family instances ; unless (null boot_fam_insts) $ panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++ @@ -554,8 +564,17 @@ checkHiBootIface -- be the equivalent to the dfun bindings returned for class -- instances? We can't easily equate tycons... + -- Check instance declarations + ; mb_dfun_prs <- mapM check_inst boot_insts + ; let tcg_env' = tcg_env { tcg_binds = binds `unionBags` dfun_binds } + final_type_env = extendTypeEnvWithIds local_type_env boot_dfuns + dfun_prs = catMaybes mb_dfun_prs + boot_dfuns = map fst dfun_prs + dfun_binds = listToBag [ noLoc $ VarBind boot_dfun (nlHsVar dfun) + | (boot_dfun, dfun) <- dfun_prs ] + ; failIfErrsM - ; return tcg_env' } + ; setGlobalTypeEnv tcg_env' final_type_env } where check_export boot_avail -- boot_avail is exported by the boot iface | name `elem` dfun_names = return () @@ -746,8 +765,8 @@ monad; it augments it and returns the new TcGblEnv. rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name) -- Fails if there are any errors rnTopSrcDecls group - = do { -- Rename the source decls (with no shadowing; error on duplicates) - (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls False group ; + = do { -- Rename the source decls + (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls group ; -- save the renamed syntax, if we want it let { tcg_env' @@ -770,19 +789,16 @@ tcTopSrcDecls boot_details hs_derivds = deriv_decls, hs_fords = foreign_decls, hs_defds = default_decls, + hs_annds = annotation_decls, hs_ruleds = rule_decls, hs_valds = val_binds }) = do { -- Type-check the type and class decls, and all imported decls -- The latter come in via tycl_decls traceTc (text "Tc2") ; - tcg_env <- tcTyAndClassDecls boot_details tycl_decls ; + (tcg_env, aux_binds) <- tcTyAndClassDecls boot_details tycl_decls ; -- If there are any errors, tcTyAndClassDecls fails here - -- Make these type and class decls available to stuff slurped from interface files - writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ; - - setGblEnv tcg_env $ do { -- Source-language instances, including derivings, -- and import the supporting declarations @@ -791,8 +807,7 @@ tcTopSrcDecls boot_details <- tcInstDecls1 tycl_decls inst_decls deriv_decls; setGblEnv tcg_env $ do { - -- Foreign import declarations next. No zonking necessary - -- here; we can tuck them straight into the global environment. + -- Foreign import declarations next. traceTc (text "Tc4") ; (fi_ids, fi_decls) <- tcForeignImports foreign_decls ; tcExtendGlobalValEnv fi_ids $ do { @@ -802,28 +817,33 @@ tcTopSrcDecls boot_details default_tys <- tcDefaults default_decls ; updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do { + -- Now GHC-generated derived bindings, generics, and selectors + -- Do not generate warnings from compiler-generated code; + -- hence the use of discardWarnings + (tc_aux_binds, tcl_env) <- discardWarnings (tcTopBinds aux_binds) ; + (tc_deriv_binds, tcl_env) <- setLclTypeEnv tcl_env $ + discardWarnings (tcTopBinds deriv_binds) ; + -- Value declarations next - -- We also typecheck any extra binds that came out - -- of the "deriving" process (deriv_binds) traceTc (text "Tc5") ; - (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 $ - tcTopBinds deriv_binds ; + (tc_val_binds, tcl_env) <- setLclTypeEnv tcl_env $ + tcTopBinds val_binds; -- Second pass over class and instance declarations, traceTc (text "Tc6") ; - (inst_binds, tcl_env) <- setLclTypeEnv tcl_env $ tcInstDecls2 tycl_decls inst_infos ; - showLIE (text "after instDecls2") ; + (inst_binds, tcl_env) <- setLclTypeEnv tcl_env $ + tcInstDecls2 tycl_decls inst_infos ; + showLIE (text "after instDecls2") ; + + setLclTypeEnv tcl_env $ do { -- Environment doesn't change now -- Foreign exports - -- They need to be zonked, so we return them traceTc (text "Tc7") ; (foe_binds, foe_decls) <- tcForeignExports foreign_decls ; + -- Annotations + annotations <- tcAnnotations annotation_decls ; + -- Rules rules <- tcRules rule_decls ; @@ -832,13 +852,15 @@ tcTopSrcDecls boot_details tcg_env <- getGblEnv ; let { all_binds = tc_val_binds `unionBags` tc_deriv_binds `unionBags` + tc_aux_binds `unionBags` inst_binds `unionBags` - foe_binds ; + foe_binds; -- Extend the GblEnv with the (as yet un-zonked) -- bindings, rules, foreign decls tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds, tcg_rules = tcg_rules tcg_env ++ rules, + tcg_anns = tcg_anns tcg_env ++ annotations, tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ; return (tcg_env', tcl_env) }}}}}} @@ -866,7 +888,7 @@ check_main dflags tcg_env return tcg_env | otherwise - = do { mb_main <- lookupSrcOcc_maybe main_fn + = do { mb_main <- lookupGlobalOccRn_maybe main_fn -- Check that 'main' is in scope -- It might be imported from another module! ; case mb_main of { @@ -907,11 +929,7 @@ check_main dflags tcg_env where 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 + main_fn = getMainFun dflags complain_no_main | ghcLink dflags == LinkInMemory = return () | otherwise = failWithTc noMainMsg @@ -922,8 +940,15 @@ check_main dflags tcg_env 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) + pp_main_fn | main_fn == main_RDR_Unqual = ptext (sLit "function") <+> quotes (ppr main_fn) + | otherwise = ptext (sLit "main function") <+> quotes (ppr main_fn) + +-- | Get the unqualified name of the function to use as the \"main\" for the main module. +-- Either returns the default name or the one configured on the command line with -main-is +getMainFun :: DynFlags -> RdrName +getMainFun dflags = case (mainFunIs dflags) of + Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn)) + Nothing -> main_RDR_Unqual \end{code} Note [Root-main Id] @@ -980,7 +1005,7 @@ setInteractiveContext hsc_env icxt thing_inside tcRnStmt :: HscEnv -> InteractiveContext -> LStmt RdrName - -> IO (Maybe ([Id], LHsExpr Id)) + -> IO (Messages, 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. @@ -1008,8 +1033,9 @@ tcRnStmt hsc_env ictxt rdr_stmt mapM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ; traceTc (text "tcs 1") ; - let { global_ids = map globaliseAndTidy zonked_ids } ; - + let { global_ids = map globaliseAndTidyId zonked_ids } ; + -- Note [Interactively-bound Ids in GHCi] + {- --------------------------------------------- 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. @@ -1038,12 +1064,6 @@ tcRnStmt hsc_env ictxt rdr_stmt where bad_unboxed id = addErr (sep [ptext (sLit "GHCi can't bind a variable of unlifted type:"), nest 2 (ppr id <+> dcolon <+> ppr (idType id))]) - -globaliseAndTidy :: Id -> Id -globaliseAndTidy id -- Note [Interactively-bound Ids in GHCi] - = Id.setIdType (globaliseId VanillaGlobal id) tidy_type - where - tidy_type = tidyTopType (idType id) \end{code} Note [Interactively-bound Ids in GHCi] @@ -1213,7 +1233,7 @@ tcRnExpr just finds the type of an expression tcRnExpr :: HscEnv -> InteractiveContext -> LHsExpr RdrName - -> IO (Maybe Type) + -> IO (Messages, Maybe Type) tcRnExpr hsc_env ictxt rdr_expr = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext hsc_env ictxt $ do { @@ -1242,7 +1262,7 @@ tcRnType just finds the kind of a type tcRnType :: HscEnv -> InteractiveContext -> LHsType RdrName - -> IO (Maybe Kind) + -> IO (Messages, Maybe Kind) tcRnType hsc_env ictxt rdr_type = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext hsc_env ictxt $ do { @@ -1251,7 +1271,7 @@ tcRnType hsc_env ictxt rdr_type failIfErrsM ; -- Now kind-check the type - (ty', kind) <- kcHsType rn_type ; + (ty', kind) <- kcLHsType rn_type ; return kind } where @@ -1269,7 +1289,7 @@ tcRnType hsc_env ictxt rdr_type \begin{code} #ifdef GHCI --- ASSUMES that the module is either in the HomePackageTable or is +-- | ASSUMES that the module is either in the 'HomePackageTable' or is -- a package module with an interface on disk. If neither of these is -- true, then the result will be an error indicating the interface -- could not be found. @@ -1302,7 +1322,7 @@ tcGetModuleExports mod directlyImpMods ; ifaceExportNames (mi_exports iface) } -tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Maybe [Name]) +tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Messages, Maybe [Name]) tcRnLookupRdrName hsc_env rdr_name = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext hsc_env (hsc_IC hsc_env) $ @@ -1337,7 +1357,7 @@ lookup_rdr_name rdr_name = do { return good_names } -tcRnLookupName :: HscEnv -> Name -> IO (Maybe TyThing) +tcRnLookupName :: HscEnv -> Name -> IO (Messages, Maybe TyThing) tcRnLookupName hsc_env name = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext hsc_env (hsc_IC hsc_env) $ @@ -1357,7 +1377,7 @@ tcRnLookupName' name = do tcRnGetInfo :: HscEnv -> Name - -> IO (Maybe (TyThing, Fixity, [Instance])) + -> IO (Messages, Maybe (TyThing, Fixity, [Instance])) -- Used to implemnent :info in GHCi --