X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnDriver.lhs;h=59fbb31a4c3f05b692e8f8f39bc35a3d41f64ae8;hb=8655d6ca41df4aa77a559d4067ad3815797b9803;hp=ae5a12ed845515615a9ab54d49b42a73f8d26489;hpb=8133c305d14d748d7720272b1eaa67847d00e241;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index ae5a12e..59fbb31 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -6,59 +6,60 @@ \begin{code} module TcRnDriver ( #ifdef GHCI - mkGlobalContext, getModuleContents, + mkGlobalContext, getModuleContents, tcRnStmt, tcRnThing, tcRnExpr, #endif tcRnModule, checkOldIface, importSupportingDecls, tcTopSrcDecls, - tcRnIface, tcRnExtCore, tcRnStmt, tcRnExpr, tcRnThing + tcRnIface, tcRnExtCore ) where #include "HsVersions.h" #ifdef GHCI -import {-# SOURCE #-} TcSplice( tcSpliceDecls ) +import {-# SOURCE #-} TcSplice ( tcSpliceDecls ) +import DsMeta ( templateHaskellNames ) #endif import CmdLineOpts ( DynFlag(..), opt_PprStyle_Debug, dopt ) -import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..), +import DriverState ( v_MainModIs, v_MainFunIs ) +import DriverUtil ( split_longest_prefix ) +import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsExpr(..), Stmt(..), Pat(VarPat), HsStmtContext(..), RuleDecl(..), - HsGroup(..), + HsGroup(..), SpliceDecl(..), mkSimpleMatch, placeHolderType, toHsType, andMonoBinds, isSrcRule, collectStmtsBinders ) import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameStmt, RdrNameHsExpr, - emptyGroup, mkGroup, findSplice, addImpDecls ) + emptyGroup, mkGroup, findSplice, addImpDecls, main_RDR_Unqual ) -import PrelNames ( iNTERACTIVE, ioTyConName, printName, - returnIOName, bindIOName, failIOName, thenIOName, runIOName, - dollarMainName, itName, mAIN_Name +import PrelNames ( iNTERACTIVE, ioTyConName, printName, monadNames, + returnIOName, runIOName, + dollarMainName, itName, mAIN_Name, unsafeCoerceName ) import MkId ( unsafeCoerceId ) -import RdrName ( RdrName, getRdrName, mkUnqual, mkRdrUnqual, +import RdrName ( RdrName, getRdrName, mkRdrUnqual, lookupRdrEnv, elemRdrEnv ) -import RnHsSyn ( RenamedHsDecl, RenamedStmt, RenamedTyClDecl, +import RnHsSyn ( RenamedStmt, RenamedTyClDecl, ruleDeclFVs, instDeclFVs, tyClDeclFVs ) import TcHsSyn ( TypecheckedHsExpr, TypecheckedRuleDecl, - zonkTopBinds, zonkTopDecls, mkHsLet, + zonkTopDecls, mkHsLet, zonkTopExpr, zonkTopBndrs ) -import TcExpr ( tcExpr_id ) +import TcExpr ( tcInferRho, tcCheckRho ) import TcRnMonad import TcMType ( newTyVarTy, zonkTcType ) import TcType ( Type, liftedTypeKind, - tyVarsOfType, tcFunResultTy, + tyVarsOfType, tcFunResultTy, tidyTopType, mkForAllTys, mkFunTys, mkTyConApp, tcSplitForAllTys ) -import TcMatches ( tcStmtsAndThen ) -import Inst ( showLIE ) +import TcMatches ( tcStmtsAndThen, TcStmtCtxt(..) ) +import Inst ( showLIE, tcStdSyntaxName ) import TcBinds ( tcTopBinds ) import TcClassDcl ( tcClassDecls2 ) import TcDefaults ( tcDefaults ) -import TcEnv ( RecTcGblEnv, - tcExtendGlobalValEnv, - tcExtendGlobalEnv, +import TcEnv ( tcExtendGlobalValEnv, tcExtendInstEnv, tcExtendRules, tcLookupTyCon, tcLookupGlobal, tcLookupId @@ -70,25 +71,25 @@ import TcInstDcls ( tcInstDecls1, tcIfaceInstDecls, tcInstDecls2 ) import TcSimplify ( tcSimplifyTop, tcSimplifyInfer ) import TcTyClsDecls ( tcTyAndClassDecls ) -import RnNames ( rnImports, exportsFromAvail, reportUnusedNames ) +import RnNames ( importsFromLocalDecls, rnImports, exportsFromAvail, + reportUnusedNames ) import RnIfaces ( slurpImpDecls, checkVersions, RecompileRequired, outOfDate ) import RnHiFiles ( readIface, loadOldIface ) import RnEnv ( lookupSrcName, lookupOccRn, plusGlobalRdrEnv, ubiquitousNames, implicitModuleFVs, implicitStmtFVs, dataTcOccs ) import RnExpr ( rnStmts, rnExpr ) -import RnNames ( importsFromLocalDecls ) import RnSource ( rnSrcDecls, checkModDeprec, rnStats ) -import OccName ( varName ) import CoreUnfold ( unfoldingTemplate ) import CoreSyn ( IdCoreRule, Bind(..) ) import PprCore ( pprIdRules, pprCoreBindings ) import TysWiredIn ( mkListTy, unitTy ) -import ErrUtils ( mkDumpDoc, showPass ) +import ErrUtils ( mkDumpDoc, showPass, pprBagOfErrors ) import Id ( Id, mkLocalId, isLocalId, idName, idType, idUnfolding, setIdLocalExported ) import IdInfo ( GlobalIdDetails(..) ) import Var ( Var, setGlobalIdDetails ) -import Module ( Module, moduleName, moduleUserString ) +import Module ( Module, ModuleName, mkHomeModule, mkModuleName, moduleName, moduleUserString, moduleEnvElts ) +import OccName ( mkVarOcc ) import Name ( Name, isExternalName, getSrcLoc, nameOccName ) import NameEnv ( delListFromNameEnv ) import NameSet @@ -100,7 +101,7 @@ import HscTypes ( PersistentCompilerState(..), InteractiveContext(..), ModIface, ModDetails(..), ModGuts(..), HscEnv(..), ModIface(..), ModDetails(..), IfaceDecls(..), - GhciMode(..), + GhciMode(..), noDependencies, Deprecations(..), plusDeprecs, emptyGlobalRdrEnv, GenAvailInfo(Avail), availsToNameSet, @@ -117,7 +118,8 @@ import HscTypes ( GlobalRdrElt(..), GlobalRdrEnv, ImportReason(..), Provenance( isLocalGRE ) #endif -import Maybe ( catMaybes ) +import DATA_IOREF ( readIORef ) +import FastString ( mkFastString ) import Panic ( showException ) import List ( partition ) import Util ( sortLt ) @@ -138,16 +140,20 @@ tcRnModule :: HscEnv -> PersistentCompilerState -> IO (PersistentCompilerState, Maybe TcGblEnv) tcRnModule hsc_env pcs - (HsModule this_mod _ exports import_decls local_decls mod_deprec loc) + (HsModule maybe_mod exports import_decls local_decls mod_deprec loc) = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ; + let { this_mod = case maybe_mod of + Nothing -> mkHomeModule mAIN_Name -- 'module M where' is omitted + Just mod -> mod } ; -- The normal case + initTc hsc_env pcs this_mod $ addSrcLoc loc $ do { -- Deal with imports; sets tcg_rdr_env, tcg_imports (rdr_env, imports) <- rnImports import_decls ; updGblEnv ( \ gbl -> gbl { tcg_rdr_env = rdr_env, - tcg_imports = imports }) + tcg_imports = tcg_imports gbl `plusImportAvails` imports }) $ do { - traceRn (text "rn1") ; + traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) ; -- Fail if there are any errors so far -- The error printing (if needed) takes advantage -- of the tcg_env we have now set @@ -155,12 +161,7 @@ tcRnModule hsc_env pcs traceRn (text "rn1a") ; -- Rename and type check the declarations - (tcg_env, src_fvs) <- tcRnSrcDecls local_decls ; - setGblEnv tcg_env $ do { - traceRn (text "rn2") ; - - -- Check for 'main' - (tcg_env, main_fvs) <- checkMain ; + (tcg_env, src_dus) <- tcRnSrcDecls local_decls ; setGblEnv tcg_env $ do { traceRn (text "rn3") ; @@ -172,14 +173,17 @@ tcRnModule hsc_env pcs updGblEnv (\gbl -> gbl { tcg_deprecs = tcg_deprecs gbl `plusDeprecs` mod_deprecs }) $ do { - traceRn (text "rn4") ; -- Process the export list - export_avails <- exportsFromAvail exports ; + export_avails <- exportsFromAvail maybe_mod exports ; updGblEnv (\gbl -> gbl { tcg_exports = export_avails }) $ do { - -- Get the supporting decls for the exports - -- This is important *only* to gether usage information + -- Get any supporting decls for the exports that have not already + -- been sucked in for the declarations in the body of the module. + -- (This can happen if something is imported only to be re-exported.) + -- + -- Importing these supporting declarations is required + -- *only* to gether usage information -- (see comments with MkIface.mkImportInfo for why) -- For OneShot compilation we could just throw away the decls -- but for Batch or Interactive we must put them in the type @@ -189,13 +193,13 @@ tcRnModule hsc_env pcs setGblEnv tcg_env $ do { -- Report unused names - let { used_fvs = src_fvs `plusFV` main_fvs `plusFV` export_fvs } ; - reportUnusedNames tcg_env used_fvs ; + let { all_dus = src_dus `plusDU` usesOnly export_fvs } ; + reportUnusedNames tcg_env all_dus ; -- Dump output and return tcDump tcg_env ; return tcg_env - }}}}}}}} + }}}}}}} \end{code} @@ -256,13 +260,17 @@ hsCoreRules rules = [(id,rule) | IfaceRuleOut id rule <- rules] %************************************************************************ \begin{code} +#ifdef GHCI tcRnStmt :: HscEnv -> PersistentCompilerState -> InteractiveContext -> RdrNameStmt -> IO (PersistentCompilerState, Maybe (InteractiveContext, [Name], TypecheckedHsExpr)) - -- The returned [Id] is the same as the input except for + -- The returned [Name] is the same as the input except for -- ExprStmt, in which case the returned [Name] is [itName] + -- + -- The returned TypecheckedHsExpr is of type IO [ () ], + -- a list of the bound values, coerced to (). tcRnStmt hsc_env pcs ictxt rdr_stmt = initTc hsc_env pcs iNTERACTIVE $ @@ -374,33 +382,41 @@ tcUserStmt stmt = tc_stmts [stmt] --------------------------- tc_stmts stmts - = do { io_ids <- mappM tcLookupId - [returnIOName, failIOName, bindIOName, thenIOName] ; - ioTyCon <- tcLookupTyCon ioTyConName ; - res_ty <- newTyVarTy liftedTypeKind ; + = do { ioTyCon <- tcLookupTyCon ioTyConName ; let { - names = collectStmtsBinders stmts ; - return_id = head io_ids ; -- Rather gruesome + ret_ty = mkListTy unitTy ; + names = collectStmtsBinders stmts ; + + stmt_ctxt = SC { sc_what = DoExpr, + sc_rhs = check_rhs, + sc_body = check_body, + sc_ty = ret_ty } ; + + check_rhs rhs rhs_ty = tcCheckRho rhs (mkTyConApp ioTyCon [rhs_ty]) ; + check_body body = tcCheckRho body (mkTyConApp ioTyCon [ret_ty]) ; - io_ty = (\ ty -> mkTyConApp ioTyCon [ty], res_ty) ; + -- ret_expr is the expression + -- returnIO [coerce () x, .., coerce () z] + ret_stmt = ResultStmt ret_expr noSrcLoc ; + ret_expr = HsApp (HsVar returnIOName) + (ExplicitList placeHolderType (map mk_item names)) ; + mk_item name = HsApp (HsVar unsafeCoerceName) (HsVar name) ; - -- mk_return builds the expression - -- returnIO @ [()] [coerce () x, .., coerce () z] - mk_return ids = HsApp (TyApp (HsVar return_id) [mkListTy unitTy]) - (ExplicitList unitTy (map mk_item ids)) ; + all_stmts = stmts ++ [ret_stmt] ; - mk_item id = HsApp (TyApp (HsVar unsafeCoerceId) [idType id, unitTy]) - (HsVar id) } ; + io_ty = mkTyConApp ioTyCon [] + } ; -- OK, we're ready to typecheck the stmts traceTc (text "tcs 2") ; ((ids, tc_stmts), lie) <- - getLIE $ tcStmtsAndThen combine DoExpr io_ty stmts $ + getLIE $ + tcStmtsAndThen combine stmt_ctxt all_stmts $ do { -- Look up the names right in the middle, -- where they will all be in scope ids <- mappM tcLookupId names ; - return (ids, [ResultStmt (mk_return ids) noSrcLoc]) + return (ids, []) } ; -- Simplify the context right here, so that we fail @@ -413,9 +429,10 @@ tc_stmts stmts const_binds <- tcSimplifyTop lie ; -- Build result expression and zonk it + io_ids <- mappM (tcStdSyntaxName DoOrigin io_ty) monadNames ; let { expr = mkHsLet const_binds $ HsDo DoExpr tc_stmts io_ids - (mkTyConApp ioTyCon [mkListTy unitTy]) noSrcLoc } ; + (mkTyConApp ioTyCon [ret_ty]) noSrcLoc } ; zonked_expr <- zonkTopExpr expr ; zonked_ids <- zonkTopBndrs ids ; @@ -446,8 +463,7 @@ tcRnExpr hsc_env pcs ictxt rdr_expr -- Now typecheck the expression; -- it might have a rank-2 type (e.g. :t runST) - -- Hence the hole type (c.f. TcExpr.tcExpr_id) - ((tc_expr, res_ty), lie) <- getLIE (tcExpr_id rn_expr) ; + ((tc_expr, res_ty), lie) <- getLIE (tcInferRho rn_expr) ; ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ; tcSimplifyTop lie_top ; @@ -478,16 +494,27 @@ tcRnThing hsc_env pcs ictxt rdr_name -- constructor and type class identifiers. let { rdr_names = dataTcOccs rdr_name } ; - (msgs_s, mb_names) <- initRnInteractive ictxt - (mapAndUnzipM (tryTc . lookupOccRn) rdr_names) ; - let { names = catMaybes mb_names } ; + -- results :: [(Messages, Maybe Name)] + results <- initRnInteractive ictxt + (mapM (tryTc . lookupOccRn) rdr_names) ; - if null names then - do { addMessages (head msgs_s) ; failM } - else do { + -- The successful lookups will be (Just name) + let { (warns_s, good_names) = unzip [ (msgs, name) + | (msgs, Just name) <- results] ; + errs_s = [msgs | (msgs, Nothing) <- results] } ; - mapM_ addMessages msgs_s ; -- Add deprecation warnings - mapM tcLookupGlobal names -- and lookup up the entities + -- Fail if nothing good happened, else add warnings + if null good_names then -- Fail + do { addMessages (head errs_s) ; failM } + else -- Add deprecation warnings + mapM_ addMessages warns_s ; + + -- Slurp in the supporting declarations + tcg_env <- importSupportingDecls (mkFVs good_names) ; + setGblEnv tcg_env $ do { + + -- And lookup up the entities + mapM tcLookupGlobal good_names }} \end{code} @@ -506,6 +533,7 @@ initRnInteractive ictxt rn_thing = initRn CmdLineMode $ setLocalRdrEnv (ic_rn_local_env ictxt) $ rn_thing +#endif \end{code} %************************************************************************ @@ -520,8 +548,8 @@ tcRnExtCore :: HscEnv -> PersistentCompilerState -> IO (PersistentCompilerState, Maybe ModGuts) -- Nothing => some error occurred -tcRnExtCore hsc_env pcs - (HsModule this_mod _ _ _ local_decls _ loc) +tcRnExtCore hsc_env pcs (HsModule (Just this_mod) _ _ decls _ loc) + -- For external core, the module name is syntactically reqd -- Rename the (Core) module. It's a bit like an interface -- file: all names are original names = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ; @@ -531,19 +559,26 @@ tcRnExtCore hsc_env pcs -- Rename the source, only in interface mode. -- rnSrcDecls handles fixity decls etc too, which won't occur -- but that doesn't matter - let { local_group = mkGroup local_decls } ; - (_, rn_local_decls, fvs) <- initRn (InterfaceMode this_mod) + let { local_group = mkGroup decls } ; + (_, rn_decls, dus) <- initRn (InterfaceMode this_mod) (rnSrcDecls local_group) ; failIfErrsM ; - -- Get the supporting decls, and typecheck them all together - -- so that any mutually recursive types are done right - extra_decls <- slurpImpDecls fvs ; - tcg_env <- typecheckIfaceDecls (rn_local_decls `addImpDecls` extra_decls) ; + -- Get the supporting decls + rn_imp_decls <- slurpImpDecls (duUses dus) ; + let { rn_decls = rn_decls `addImpDecls` rn_imp_decls } ; + + -- Dump trace of renaming part + rnDump (ppr rn_decls) ; + rnStats rn_imp_decls ; + + -- Typecheck them all together so that + -- any mutually recursive types are done right + tcg_env <- typecheckIfaceDecls rn_decls ; setGblEnv tcg_env $ do { -- Now the core bindings - core_prs <- tcCoreBinds (hs_coreds rn_local_decls) ; + core_prs <- tcCoreBinds (hs_coreds rn_decls) ; tcExtendGlobalValEnv (map fst core_prs) $ do { -- Wrap up @@ -555,8 +590,9 @@ tcRnExtCore hsc_env pcs final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ; mod_guts = ModGuts { mg_module = this_mod, - mg_usages = [], -- ToDo: compute usage - mg_dir_imps = [], -- ?? + mg_usages = [], -- ToDo: compute usage + mg_dir_imps = [], -- ?? + mg_deps = noDependencies, -- ?? mg_exports = my_exports, mg_types = final_type_env, mg_insts = tcg_insts tcg_env, @@ -584,38 +620,85 @@ tcRnExtCore hsc_env pcs %************************************************************************ \begin{code} -tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, FreeVars) +tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, DefUses) -- Returns the variables free in the decls -- Reason: solely to report unused imports and bindings -tcRnSrcDecls [] = do { tcg_env <- getGblEnv ; return (tcg_env, emptyFVs) } -tcRnSrcDecls ds +tcRnSrcDecls decls + = do { -- Do all the declarations + ((tc_envs, dus), lie) <- getLIE (tc_rn_src_decls decls) ; + + -- tcSimplifyTop deals with constant or ambiguous InstIds. + -- How could there be ambiguous ones? They can only arise if a + -- top-level decl falls under the monomorphism + -- restriction, and no subsequent decl instantiates its + -- type. (Usually, ambiguous type variables are resolved + -- during the generalisation step.) + traceTc (text "Tc8") ; + setEnvs tc_envs $ do { + -- Setting the global env exposes the instances to tcSimplifyTop + -- Setting the local env exposes the local Ids, so that + -- we get better error messages (monomorphism restriction) + inst_binds <- tcSimplifyTop lie ; + + -- Backsubstitution. This must be done last. + -- 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 } ; + + (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `andMonoBinds` inst_binds) + rules fords ; + + return (tcg_env { tcg_type_env = extendTypeEnvWithIds type_env bind_ids, + tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' }, + dus) + }} + +tc_rn_src_decls :: [RdrNameHsDecl] -> TcM ((TcGblEnv, TcLclEnv), DefUses) + +tc_rn_src_decls ds = do { let { (first_group, group_tail) = findSplice ds } ; + -- If ds is [] we get ([], Nothing) -- Type check the decls up to, but not including, the first splice - (tcg_env, src_fvs1) <- tcRnGroup first_group ; + (tc_envs@(_,tcl_env), src_dus1) <- tcRnGroup first_group ; + + -- Bale out if errors; for example, error recovery when checking + -- the RHS of 'main' can mean that 'main' is not in the envt for + -- the subsequent checkMain test + failIfErrsM ; - -- If there is no splice, we're done - case group_tail of - Nothing -> return (tcg_env, src_fvs1) - Just (splice_expr, rest_ds) -> do { + setEnvs tc_envs $ - setGblEnv tcg_env $ do { + -- If there is no splice, we're nearly done + case group_tail of { + Nothing -> do { -- Last thing: check for `main' + (tcg_env, main_fvs) <- checkMain ; + return ((tcg_env, tcl_env), + src_dus1 `plusDU` usesOnly main_fvs) + } ; + -- If there's a splice, we must carry on + Just (SpliceDecl splice_expr splice_loc, rest_ds) -> do { #ifndef GHCI failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler") #else + -- Rename the splice expression, and get its supporting decls - (rn_splice_expr, fvs) <- initRn SourceMode (rnExpr splice_expr) ; - tcg_env <- importSupportingDecls fvs ; + (rn_splice_expr, splice_fvs) <- initRn SourceMode $ + addSrcLoc splice_loc $ + rnExpr splice_expr ; + tcg_env <- importSupportingDecls (splice_fvs `plusFV` templateHaskellNames) ; setGblEnv tcg_env $ do { -- Execute the splice spliced_decls <- tcSpliceDecls rn_splice_expr ; -- Glue them on the front of the remaining decls and loop - (tcg_env, src_fvs2) <- tcRnSrcDecls (spliced_decls ++ rest_ds) ; + (tc_envs, src_dus2) <- tc_rn_src_decls (spliced_decls ++ rest_ds) ; - return (tcg_env, src_fvs1 `plusFV` src_fvs2) + return (tc_envs, src_dus1 `plusDU` usesOnly splice_fvs `plusDU` src_dus2) } #endif /* GHCI */ }}} @@ -640,20 +723,21 @@ declarations. It expects there to be an incoming TcGblEnv in the monad; it augments it and returns the new TcGblEnv. \begin{code} -tcRnGroup :: HsGroup RdrName -> TcM (TcGblEnv, FreeVars) - -- Returns the variables free in the decls +tcRnGroup :: HsGroup RdrName -> TcM ((TcGblEnv, TcLclEnv), DefUses) + -- Returns the variables free in the decls, for unused-binding reporting tcRnGroup decls = do { -- Rename the declarations - (tcg_env, rn_decls, src_fvs) <- rnTopSrcDecls decls ; + (tcg_env, rn_decls, src_dus) <- rnTopSrcDecls decls ; setGblEnv tcg_env $ do { -- Typecheck the declarations - tcg_env <- tcTopSrcDecls rn_decls ; - return (tcg_env, src_fvs) + tc_envs <- tcTopSrcDecls rn_decls ; + + return (tc_envs, src_dus) }} ------------------------------------------------ -rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name, FreeVars) +rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name, DefUses) rnTopSrcDecls group = do { -- Bring top level binders into scope (rdr_env, imports) <- importsFromLocalDecls group ; @@ -666,12 +750,13 @@ rnTopSrcDecls group failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations -- Rename the source decls - (tcg_env, rn_src_decls, src_fvs) <- initRn SourceMode (rnSrcDecls group) ; + (tcg_env, rn_src_decls, src_dus) <- initRn SourceMode (rnSrcDecls group) ; setGblEnv tcg_env $ do { failIfErrsM ; -- Import consquential imports + let { src_fvs = duUses src_dus } ; rn_imp_decls <- slurpImpDecls (src_fvs `plusFV` implicitModuleFVs src_fvs) ; let { rn_decls = rn_src_decls `addImpDecls` rn_imp_decls } ; @@ -679,48 +764,12 @@ rnTopSrcDecls group rnDump (ppr rn_decls) ; rnStats rn_imp_decls ; - return (tcg_env, rn_decls, src_fvs) + return (tcg_env, rn_decls, src_dus) }}} ------------------------------------------------ -tcTopSrcDecls :: HsGroup Name -> TcM TcGblEnv -tcTopSrcDecls rn_decls - = fixM (\ unf_env -> do { - -- Loop back the final environment, including the fully zonked - -- versions of bindings from this module. In the presence of mutual - -- recursion, interface type signatures may mention variables defined - -- in this module, which is why the knot is so big - - -- Do the main work - ((tcg_env, binds, rules, fords), lie) <- getLIE ( - tc_src_decls unf_env rn_decls - ) ; - - -- tcSimplifyTop deals with constant or ambiguous InstIds. - -- How could there be ambiguous ones? They can only arise if a - -- top-level decl falls under the monomorphism - -- restriction, and no subsequent decl instantiates its - -- type. (Usually, ambiguous type variables are resolved - -- during the generalisation step.) - traceTc (text "Tc8") ; - inst_binds <- setGblEnv tcg_env (tcSimplifyTop lie) ; - -- The setGblEnv exposes the instances to tcSimplifyTop - - -- Backsubstitution. This must be done last. - -- Even tcSimplifyTop may do some unification. - traceTc (text "Tc9") ; - (ids, binds', fords', rules') <- zonkTopDecls (binds `andMonoBinds` inst_binds) - rules fords ; - - let { tcg_env' = tcg_env { tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) ids, - tcg_binds = tcg_binds tcg_env `andMonoBinds` binds', - tcg_rules = tcg_rules tcg_env ++ rules', - tcg_fords = tcg_fords tcg_env ++ fords' } } ; - - return tcg_env' - }) - -tc_src_decls unf_env +tcTopSrcDecls :: HsGroup Name -> TcM (TcGblEnv, TcLclEnv) +tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls, hs_instds = inst_decls, hs_fords = foreign_decls, @@ -728,8 +777,9 @@ tc_src_decls unf_env 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 <- tcTyClDecls unf_env tycl_decls ; + tcg_env <- tcTyClDecls tycl_decls ; setGblEnv tcg_env $ do { -- Source-language instances, including derivings, @@ -766,7 +816,7 @@ tc_src_decls unf_env (cls_dm_binds, dm_ids) <- tcClassDecls2 tycl_decls ; tcExtendGlobalValEnv dm_ids $ do { inst_binds <- tcInstDecls2 inst_infos ; - showLIE "after instDecls2" ; + showLIE (text "after instDecls2") ; -- Foreign exports -- They need to be zonked, so we return them @@ -787,15 +837,20 @@ tc_src_decls unf_env let { all_binds = tc_val_binds `AndMonoBinds` inst_binds `AndMonoBinds` cls_dm_binds `AndMonoBinds` - foe_binds } ; + foe_binds ; - return (tcg_env, all_binds, src_rules, foe_decls) + -- Extend the GblEnv with the (as yet un-zonked) + -- bindings, rules, foreign decls + tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `andMonoBinds` all_binds, + tcg_rules = tcg_rules tcg_env ++ src_rules, + tcg_fords = tcg_fords tcg_env ++ foe_decls } } ; + + return (tcg_env', lcl_env) }}}}}}}}} \end{code} \begin{code} -tcTyClDecls :: RecTcGblEnv - -> [RenamedTyClDecl] +tcTyClDecls :: [RenamedTyClDecl] -> TcM TcGblEnv -- tcTyClDecls deals with @@ -806,30 +861,21 @@ tcTyClDecls :: RecTcGblEnv -- persistent compiler state to reflect the things imported from -- other modules -tcTyClDecls unf_env tycl_decls - -- (unf_env :: RecTcGblEnv) is used for type-checking interface pragmas - -- which is done lazily [ie failure just drops the pragma - -- without having any global-failure effect]. - +tcTyClDecls tycl_decls = checkNoErrs $ -- tcTyAndClassDecls recovers internally, but if anything gave rise to -- an error we'd better stop now, to avoid a cascade traceTc (text "TyCl1") `thenM_` - tcTyAndClassDecls tycl_decls `thenM` \ tycl_things -> - tcExtendGlobalEnv tycl_things $ - - -- Interface type signatures - -- We tie a knot so that the Ids read out of interfaces are in scope - -- when we read their pragmas. - -- What we rely on is that pragmas are typechecked lazily; if - -- any type errors are found (ie there's an inconsistency) - -- we silently discard the pragma - traceTc (text "TyCl2") `thenM_` - tcInterfaceSigs unf_env tycl_decls `thenM` \ sig_ids -> - tcExtendGlobalValEnv sig_ids $ - - getGblEnv -- Return the TcLocals environment + tcTyAndClassDecls tycl_decls `thenM` \ tcg_env -> + -- Returns the extended environment + setGblEnv tcg_env $ + + traceTc (text "TyCl2") `thenM_` + tcInterfaceSigs tycl_decls `thenM` \ tcg_env -> + -- Returns the extended environment + + returnM tcg_env \end{code} @@ -873,26 +919,44 @@ check_old_iface iface_path source_unchanged maybe_iface returnM (outOfDate, maybe_iface) else - case maybe_iface of + case maybe_iface of { Just old_iface -> -- Use the one we already have checkVersions source_unchanged old_iface `thenM` \ recomp -> returnM (recomp, Just old_iface) - Nothing -- Try and read it from a file - -> getModule `thenM` \ this_mod -> - readIface this_mod iface_path False `thenM` \ read_result -> - case read_result of - Left err -> -- Old interface file not found, or garbled; give up - traceHiDiffs ( - text "Cannot read old interface file:" - $$ nest 4 (text (showException err))) `thenM_` - returnM (outOfDate, Nothing) - - Right parsed_iface -> - initRn (InterfaceMode this_mod) - (loadOldIface parsed_iface) `thenM` \ m_iface -> - checkVersions source_unchanged m_iface `thenM` \ recomp -> - returnM (recomp, Just m_iface) + ; Nothing -> + + -- Try and read the old interface for the current module + -- from the .hi file left from the last time we compiled it + getModule `thenM` \ this_mod -> + readIface this_mod iface_path False `thenM` \ read_result -> + case read_result of { + Left err -> -- Old interface file not found, or garbled; give up + traceHiDiffs (text "FYI: cannot read old interface file:" + $$ nest 4 (text (showException err))) `thenM_` + returnM (outOfDate, Nothing) + + ; Right parsed_iface -> + + -- We found the file and parsed it; now load it + tryTc (initRn (InterfaceMode this_mod) + (loadOldIface parsed_iface)) `thenM` \ ((_,errs), mb_iface) -> + case mb_iface of { + Nothing -> -- Something went wrong in loading. The main likely thing + -- is that the usages mentioned B.f, where B.hi and B.hs no + -- longer exist. Then newGlobalName2 fails with an error message + -- This isn't an error; we just don't have an old iface file to + -- look at. Spit out a traceHiDiffs for info though. + traceHiDiffs (text "FYI: loading old interface file failed" + $$ nest 4 (docToSDoc (pprBagOfErrors errs))) `thenM_` + return (outOfDate, Nothing) + + ; Just iface -> + + -- At last, we have got the old iface; check its versions + checkVersions source_unchanged iface `thenM` \ recomp -> + returnM (recomp, Just iface) + }}} \end{code} @@ -923,13 +987,13 @@ typecheckIfaceDecls :: HsGroup Name -> TcM TcGblEnv -- That is why the tcExtendX functions need to do partitioning. -- -- If all the decls are from other modules, the returned TcGblEnv - -- will have an empty tc_genv, but its tc_inst_env and tc_ist - -- caches may have been augmented. + -- will have an empty tc_genv, but its tc_inst_env + -- cache may have been augmented. typecheckIfaceDecls (HsGroup { hs_tyclds = tycl_decls, hs_instds = inst_decls, hs_ruleds = rule_decls }) = do { -- Typecheck the type, class, and interface-sig decls - tcg_env <- fixM (\ unf_env -> tcTyClDecls unf_env tycl_decls) ; + tcg_env <- tcTyClDecls tycl_decls ; setGblEnv tcg_env $ do { -- Typecheck the instance decls, and rules @@ -1049,10 +1113,21 @@ noRdrEnvErr mod = ptext SLIT("No top-level environment available for module") checkMain = do { ghci_mode <- getGhciMode ; tcg_env <- getGblEnv ; - check_main ghci_mode tcg_env + + mb_main_mod <- readMutVar v_MainModIs ; + mb_main_fn <- readMutVar v_MainFunIs ; + let { main_mod = case mb_main_mod of { + Just mod -> mkModuleName mod ; + Nothing -> mAIN_Name } ; + main_fn = case mb_main_fn of { + Just fn -> mkRdrUnqual (mkVarOcc (mkFastString fn)) ; + Nothing -> main_RDR_Unqual } } ; + + check_main ghci_mode tcg_env main_mod main_fn } -check_main ghci_mode tcg_env + +check_main ghci_mode tcg_env main_mod main_fn -- If we are in module Main, check that 'main' is defined. -- It may be imported from another module, in which case -- we have to drag in its. @@ -1067,39 +1142,35 @@ check_main ghci_mode tcg_env -- -- Blimey: a whole page of code to do this... - | mod_name /= mAIN_Name + | mod_name /= main_mod = return (tcg_env, emptyFVs) - | not (main_RDR_Unqual `elemRdrEnv` rdr_env) + -- Check that 'main' is in scope + -- It might be imported from another module! + -- + -- We use a guard for this (rather than letting lookupSrcName fail) + -- because it's not an error in ghci) + | not (main_fn `elemRdrEnv` rdr_env) = do { complain_no_main; return (tcg_env, emptyFVs) } - | otherwise - = do { -- Check that 'main' is in scope - -- It might be imported from another module! - main_name <- lookupSrcName main_RDR_Unqual ; - failIfErrsM ; + | otherwise -- OK, so the appropriate 'main' is in scope + -- + = do { main_name <- lookupSrcName main_fn ; tcg_env <- importSupportingDecls (unitFV runIOName) ; - setGblEnv tcg_env $ do { + + addSrcLoc (getSrcLoc main_name) $ + addErrCtxt mainCtxt $ + setGblEnv tcg_env $ do { -- $main :: IO () = runIO main let { rhs = HsApp (HsVar runIOName) (HsVar main_name) } ; + (main_expr, ty) <- tcInferRho rhs ; - (main_bind, top_lie) <- getLIE ( - addSrcLoc (getSrcLoc main_name) $ - addErrCtxt mainCtxt $ do { - (main_expr, ty) <- tcExpr_id rhs ; - let { dollar_main_id = setIdLocalExported (mkLocalId dollarMainName ty) } ; - return (VarMonoBind dollar_main_id main_expr) - }) ; - - inst_binds <- tcSimplifyTop top_lie ; - - (ids, binds') <- zonkTopBinds (main_bind `andMonoBinds` inst_binds) ; - - let { tcg_env' = tcg_env { - tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) ids, - tcg_binds = tcg_binds tcg_env `andMonoBinds` binds' } } ; + let { dollar_main_id = setIdLocalExported (mkLocalId dollarMainName ty) ; + main_bind = VarMonoBind dollar_main_id main_expr ; + tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env + `andMonoBinds` main_bind } } ; return (tcg_env', unitFV main_name) }} @@ -1107,18 +1178,15 @@ check_main ghci_mode tcg_env mod_name = moduleName (tcg_mod tcg_env) rdr_env = tcg_rdr_env tcg_env - main_RDR_Unqual :: RdrName - main_RDR_Unqual = mkUnqual varName FSLIT("main") - -- Don't get a RdrName from PrelNames.mainName, because - -- nameRdrNamegets an Orig RdrName, and we want a Qual or Unqual one. - -- An Unqual one will do just fine - complain_no_main | ghci_mode == Interactive = return () - | otherwise = addErr noMainMsg + | 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 'main'") - noMainMsg = ptext SLIT("No 'main' defined in module Main") + 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) + <+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod) \end{code} @@ -1164,11 +1232,14 @@ tcCoreDump mod_guts pprTcGblEnv :: TcGblEnv -> SDoc pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, tcg_insts = dfun_ids, - tcg_rules = rules }) + tcg_rules = rules, + tcg_imports = imports }) = vcat [ ppr_types dfun_ids type_env , ppr_insts dfun_ids , vcat (map ppr rules) - , ppr_gen_tycons (typeEnvTyCons type_env)] + , ppr_gen_tycons (typeEnvTyCons type_env) + , ptext SLIT("Dependent modules:") <+> ppr (moduleEnvElts (imp_dep_mods imports)) + , ptext SLIT("Dependent packages:") <+> ppr (imp_dep_pkgs imports)] pprModGuts :: ModGuts -> SDoc pprModGuts (ModGuts { mg_types = type_env, @@ -1201,7 +1272,7 @@ ppr_sigs ids -- Convert to HsType so that we get source-language style printing -- And sort by RdrName = vcat $ map ppr_sig $ sortLt lt_sig $ - [ (getRdrName id, toHsType (idType id)) + [ (getRdrName id, toHsType (tidyTopType (idType id))) | id <- ids ] where lt_sig (n1,_) (n2,_) = n1 < n2 @@ -1215,9 +1286,8 @@ ppr_rules rs = vcat [ptext SLIT("{-# RULES"), ptext SLIT("#-}")] ppr_gen_tycons [] = empty -ppr_gen_tycons tcs = vcat [ptext SLIT("{-# Generic type constructor details"), - vcat (map ppr_gen_tycon tcs), - ptext SLIT("#-}") +ppr_gen_tycons tcs = vcat [ptext SLIT("Generic type constructor details:"), + nest 2 (vcat (map ppr_gen_tycon tcs)) ] -- x&y are now Id's, not CoreExpr's