X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnDriver.lhs;h=8a3ca329e6dba3d01d7923c7e08b39a18b74184d;hb=c0624c7661a229bfeed128ca96b07e2f4d5d677c;hp=00891a153e84c534c89dbf9938d424e3838d7203;hpb=dbc254c3dcd64761015a3d1c191ac742caafbf4c;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 00891a1..8a3ca32 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -8,19 +8,27 @@ module TcRnDriver ( #ifdef GHCI mkGlobalContext, getModuleContents, #endif - tcRnModule, checkOldIface, importSupportingDecls, + tcRnModule, checkOldIface, + importSupportingDecls, tcTopSrcDecls, tcRnIface, tcRnExtCore, tcRnStmt, tcRnExpr, tcRnThing ) where #include "HsVersions.h" +#ifdef GHCI +import {-# SOURCE #-} TcSplice ( tcSpliceDecls ) +import DsMeta ( qTyConName ) +#endif + import CmdLineOpts ( DynFlag(..), opt_PprStyle_Debug, dopt ) -import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..), +import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsExpr(..), Stmt(..), Pat(VarPat), HsStmtContext(..), RuleDecl(..), + HsGroup(..), SpliceDecl(..), mkSimpleMatch, placeHolderType, toHsType, andMonoBinds, isSrcRule, collectStmtsBinders ) -import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameStmt, RdrNameHsExpr ) +import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameStmt, RdrNameHsExpr, + emptyGroup, mkGroup, findSplice, addImpDecls ) import PrelNames ( iNTERACTIVE, ioTyConName, printName, returnIOName, bindIOName, failIOName, thenIOName, runIOName, @@ -30,7 +38,7 @@ import MkId ( unsafeCoerceId ) import RdrName ( RdrName, getRdrName, mkUnqual, mkRdrUnqual, lookupRdrEnv, elemRdrEnv ) -import RnHsSyn ( RenamedHsDecl, RenamedStmt, RenamedTyClDecl, +import RnHsSyn ( RenamedStmt, RenamedTyClDecl, ruleDeclFVs, instDeclFVs, tyClDeclFVs ) import TcHsSyn ( TypecheckedHsExpr, TypecheckedRuleDecl, zonkTopBinds, zonkTopDecls, mkHsLet, @@ -66,10 +74,11 @@ import TcTyClsDecls ( tcTyAndClassDecls ) import RnNames ( rnImports, exportsFromAvail, reportUnusedNames ) import RnIfaces ( slurpImpDecls, checkVersions, RecompileRequired, outOfDate ) import RnHiFiles ( readIface, loadOldIface ) -import RnEnv ( lookupSrcName, lookupOccRn, +import RnEnv ( lookupSrcName, lookupOccRn, plusGlobalRdrEnv, ubiquitousNames, implicitModuleFVs, implicitStmtFVs, dataTcOccs ) import RnExpr ( rnStmts, rnExpr ) -import RnSource ( rnSrcDecls, rnExtCoreDecls, checkModDeprec, rnStats ) +import RnNames ( importsFromLocalDecls ) +import RnSource ( rnSrcDecls, checkModDeprec, rnStats ) import OccName ( varName ) import CoreUnfold ( unfoldingTemplate ) @@ -80,7 +89,7 @@ import ErrUtils ( mkDumpDoc, showPass ) 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, moduleUserString, moduleEnvElts ) import Name ( Name, isExternalName, getSrcLoc, nameOccName ) import NameEnv ( delListFromNameEnv ) import NameSet @@ -92,7 +101,7 @@ import HscTypes ( PersistentCompilerState(..), InteractiveContext(..), ModIface, ModDetails(..), ModGuts(..), HscEnv(..), ModIface(..), ModDetails(..), IfaceDecls(..), - GhciMode(..), + GhciMode(..), noDependencies, Deprecations(..), plusDeprecs, emptyGlobalRdrEnv, GenAvailInfo(Avail), availsToNameSet, @@ -104,7 +113,7 @@ import HscTypes ( PersistentCompilerState(..), InteractiveContext(..), #ifdef GHCI import RdrName ( rdrEnvElts ) import RnHiFiles ( loadInterface ) -import RnEnv ( mkGlobalRdrEnv, plusGlobalRdrEnv ) +import RnEnv ( mkGlobalRdrEnv ) import HscTypes ( GlobalRdrElt(..), GlobalRdrEnv, ImportReason(..), Provenance(..), isLocalGRE ) #endif @@ -137,9 +146,9 @@ tcRnModule hsc_env pcs 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 @@ -164,7 +173,6 @@ 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 ; updGblEnv (\gbl -> gbl { tcg_exports = export_avails }) @@ -213,7 +221,7 @@ tcRnIface hsc_env pcs -- Get the supporting decls, and typecheck them all together -- so that any mutually recursive types are done right extra_decls <- slurpImpDecls needed ; - env <- typecheckIfaceDecls (decls ++ extra_decls) ; + env <- typecheckIfaceDecls (group `addImpDecls` extra_decls) ; returnM (ModDetails { md_types = tcg_type_env env, md_insts = tcg_insts env, @@ -224,9 +232,9 @@ tcRnIface hsc_env pcs rule_decls = dcl_rules iface_decls inst_decls = dcl_insts iface_decls tycl_decls = dcl_tycl iface_decls - decls = map RuleD rule_decls ++ - map InstD inst_decls ++ - map TyClD tycl_decls + group = emptyGroup { hs_ruleds = rule_decls, + hs_instds = inst_decls, + hs_tyclds = tycl_decls } needed = unionManyNameSets (map ruleDeclFVs rule_decls) `unionNameSets` unionManyNameSets (map instDeclFVs inst_decls) `unionNameSets` unionManyNameSets (map tyClDeclFVs tycl_decls) `unionNameSets` @@ -352,7 +360,7 @@ tcUserStmt (ExprStmt expr _ loc) the_bind = FunMonoBind fresh_it False [ mkSimpleMatch [] expr placeHolderType loc ] loc in - tryTc_ (do { -- Try this if the other fails + tryTcLIE_ (do { -- Try this if the other fails traceTc (text "tcs 1b") ; tc_stmts [ LetStmt (MonoBind the_bind [] NonRecursive), @@ -398,7 +406,7 @@ tc_stmts stmts -- Simplify the context right here, so that we fail -- if there aren't enough instances. Notably, when we see -- e - -- we use tryTc_ to try it <- e + -- we use recoverTc_ to try it <- e -- and then let it = e -- It's the simplify step that rejects the first. traceTc (text "tcs 3") ; @@ -471,16 +479,23 @@ tcRnThing hsc_env pcs ictxt rdr_name let { rdr_names = dataTcOccs rdr_name } ; (msgs_s, mb_names) <- initRnInteractive ictxt - (mapAndUnzipM (tryM . lookupOccRn) rdr_names) ; + (mapAndUnzipM (tryTc . lookupOccRn) rdr_names) ; let { names = catMaybes mb_names } ; if null names then do { addMessages (head msgs_s) ; failM } else do { - mapM_ addMessages msgs_s ; -- Add deprecation warnings - mapM tcLookupGlobal names -- and lookup up the entities - }} + -- Add deprecation warnings + mapM_ addMessages msgs_s ; + + -- Slurp in the supporting declarations + tcg_env <- importSupportingDecls (mkFVs names) ; + setGblEnv tcg_env $ do { + + -- And lookup up the entities + mapM tcLookupGlobal names + }}} \end{code} @@ -523,18 +538,19 @@ 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 - (rn_local_decls, fvs) <- initRn (InterfaceMode this_mod) - (rnExtCoreDecls local_decls) ; + let { local_group = mkGroup local_decls } ; + (_, rn_local_decls, fvs) <- 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 ++ extra_decls) ; + tcg_env <- typecheckIfaceDecls (rn_local_decls `addImpDecls` extra_decls) ; setGblEnv tcg_env $ do { -- Now the core bindings - core_prs <- tcCoreBinds [d | CoreD d <- rn_local_decls] ; + core_prs <- tcCoreBinds (hs_coreds rn_local_decls) ; tcExtendGlobalValEnv (map fst core_prs) $ do { -- Wrap up @@ -548,6 +564,7 @@ tcRnExtCore hsc_env pcs mod_guts = ModGuts { mg_module = this_mod, 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, @@ -574,38 +591,45 @@ tcRnExtCore hsc_env pcs %* * %************************************************************************ +\begin{code} tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, FreeVars) -- Returns the variables free in the decls -tcRnSrcDecls [] = getGblEnv + -- Reason: solely to report unused imports and bindings +tcRnSrcDecls [] = do { tcg_env <- getGblEnv ; return (tcg_env, emptyFVs) } tcRnSrcDecls ds = do { let { (first_group, group_tail) = findSplice ds } ; - tcg_env <- tcRnGroup first_group ; + -- Type check the decls up to, but not including, the first splice + (tcg_env, src_fvs1) <- tcRnGroup first_group ; + -- If there is no splice, we're done case group_tail of - Nothing -> return gbl_env - Just (splice_expr, rest_ds) -> do { + Nothing -> return (tcg_env, src_fvs1) + Just (SpliceDecl splice_expr splice_loc, rest_ds) -> do { setGblEnv tcg_env $ 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, fvs) <- initRn SourceMode $ + addSrcLoc splice_loc $ + rnExpr splice_expr ; + tcg_env <- importSupportingDecls (fvs `addOneFV` qTyConName) ; setGblEnv tcg_env $ do { -- Execute the splice spliced_decls <- tcSpliceDecls rn_splice_expr ; -- Glue them on the front of the remaining decls and loop - tcRnSrcDeclsDecls (splice_decls ++ rest_ds) - }}}} + (tcg_env, src_fvs2) <- tcRnSrcDecls (spliced_decls ++ rest_ds) ; -findSplice :: [HsDecl a] -> ([HsDecl a], Maybe (HsExpr a, [HsDecl a])) -findSplice [] = ([], Nothing) -findSplice (SpliceD e : ds) = ([], Just (e, ds)) -findSplice (d : ds) = (d:gs, rest) - where - (gs, rest) = findSplice ds + return (tcg_env, src_fvs1 `plusFV` src_fvs2) + } +#endif /* GHCI */ + }}} +\end{code} %************************************************************************ @@ -614,7 +638,7 @@ findSplice (d : ds) = (d:gs, rest) %* * %************************************************************************ -tcRnSrcDecls takes a bunch of top-level source-code declarations, and +tcRnGroup takes a bunch of top-level source-code declarations, and * renames them * gets supporting declarations from interface files * typechecks them @@ -626,9 +650,9 @@ declarations. It expects there to be an incoming TcGblEnv in the monad; it augments it and returns the new TcGblEnv. \begin{code} -tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, FreeVars) +tcRnGroup :: HsGroup RdrName -> TcM (TcGblEnv, FreeVars) -- Returns the variables free in the decls -tcRnSrcDecls decls +tcRnGroup decls = do { -- Rename the declarations (tcg_env, rn_decls, src_fvs) <- rnTopSrcDecls decls ; setGblEnv tcg_env $ do { @@ -639,26 +663,37 @@ tcRnSrcDecls decls }} ------------------------------------------------ -rnTopSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, [RenamedHsDecl], FreeVars) -rnTopSrcDecls decls - = do { (tcg_env, rn_src_decls, src_fvs) <- initRn SourceMode (rnSrcDecls decls) ; +rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name, FreeVars) +rnTopSrcDecls group + = do { -- Bring top level binders into scope + (rdr_env, imports) <- importsFromLocalDecls group ; + updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` + tcg_rdr_env gbl, + tcg_imports = imports `plusImportAvails` + tcg_imports gbl }) + $ do { + + 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) ; setGblEnv tcg_env $ do { failIfErrsM ; -- Import consquential imports rn_imp_decls <- slurpImpDecls (src_fvs `plusFV` implicitModuleFVs src_fvs) ; - let { rn_decls = rn_src_decls ++ rn_imp_decls } ; + let { rn_decls = rn_src_decls `addImpDecls` rn_imp_decls } ; -- Dump trace of renaming part - rnDump (vcat (map ppr rn_decls)) ; + rnDump (ppr rn_decls) ; rnStats rn_imp_decls ; return (tcg_env, rn_decls, src_fvs) - }} + }}} ------------------------------------------------ -tcTopSrcDecls :: [RenamedHsDecl] -> TcM TcGblEnv +tcTopSrcDecls :: HsGroup Name -> TcM TcGblEnv tcTopSrcDecls rn_decls = fixM (\ unf_env -> do { -- Loop back the final environment, including the fully zonked @@ -695,7 +730,13 @@ tcTopSrcDecls rn_decls return tcg_env' }) -tc_src_decls unf_env decls +tc_src_decls unf_env + (HsGroup { hs_tyclds = tycl_decls, + hs_instds = inst_decls, + hs_fords = foreign_decls, + hs_defds = default_decls, + hs_ruleds = rule_decls, + hs_valds = val_binds }) = do { -- Type-check the type and class decls, and all imported decls traceTc (text "Tc2") ; tcg_env <- tcTyClDecls unf_env tycl_decls ; @@ -712,14 +753,14 @@ tc_src_decls unf_env decls -- Foreign import declarations next. No zonking necessary -- here; we can tuck them straight into the global environment. traceTc (text "Tc4") ; - (fi_ids, fi_decls) <- tcForeignImports decls ; + (fi_ids, fi_decls) <- tcForeignImports foreign_decls ; tcExtendGlobalValEnv fi_ids $ updGblEnv (\gbl -> gbl { tcg_fords = tcg_fords gbl ++ fi_decls }) $ do { -- Default declarations traceTc (text "Tc4a") ; - default_tys <- tcDefaults decls ; + default_tys <- tcDefaults default_decls ; updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do { -- Value declarations next @@ -740,7 +781,7 @@ tc_src_decls unf_env decls -- Foreign exports -- They need to be zonked, so we return them traceTc (text "Tc7") ; - (foe_binds, foe_decls) <- tcForeignExports decls ; + (foe_binds, foe_decls) <- tcForeignExports foreign_decls ; -- Rules -- Need to partition them because the source rules @@ -760,12 +801,6 @@ tc_src_decls unf_env decls return (tcg_env, all_binds, src_rules, foe_decls) }}}}}}}}} - where - tycl_decls = [d | TyClD d <- decls] - rule_decls = [d | RuleD d <- decls] - inst_decls = [d | InstD d <- decls] - val_decls = [d | ValD d <- decls] - val_binds = foldr ThenBinds EmptyBinds val_decls \end{code} \begin{code} @@ -888,9 +923,9 @@ importSupportingDecls fvs = do { traceRn (text "Import supporting decls for" <+> ppr (nameSetToList fvs)) ; decls <- slurpImpDecls fvs ; traceRn (text "...namely:" <+> vcat (map ppr decls)) ; - typecheckIfaceDecls decls } + typecheckIfaceDecls (mkGroup decls) } -typecheckIfaceDecls :: [RenamedHsDecl] -> TcM TcGblEnv +typecheckIfaceDecls :: HsGroup Name -> TcM TcGblEnv -- The decls are all interface-file declarations -- Usually they are all from other modules, but when we are reading -- this module's interface from a file, it's possible that some of @@ -900,12 +935,10 @@ typecheckIfaceDecls :: [RenamedHsDecl] -> TcM TcGblEnv -- 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. -typecheckIfaceDecls decls - = do { let { tycl_decls = [d | TyClD d <- decls] ; - inst_decls = [d | InstD d <- decls] ; - rule_decls = [d | RuleD d <- decls] } ; - - -- Typecheck the type, class, and interface-sig decls +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) ; setGblEnv tcg_env $ do { @@ -1141,11 +1174,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) + , ppr (moduleEnvElts (imp_dep_mods imports)) + , ppr (imp_dep_pkgs imports)] pprModGuts :: ModGuts -> SDoc pprModGuts (ModGuts { mg_types = type_env,