X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnDriver.lhs;h=b9f7913d44f0fe08e29685fc38bf31d0f44488c4;hp=a42e85dadbe215df158b44cb381e6055240691cc;hb=5ccf658872ea2304f34eda6b1fb840fc1bfc0ba0;hpb=e8fa04cf0d656c4a2ff737278b8cea9fce3b5a2b diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index a42e85d..b9f7913 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -2,15 +2,16 @@ % (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section[TcModule]{Typechecking a whole module} +\section[TcMovectle]{Typechecking a whole module} \begin{code} module TcRnDriver ( #ifdef GHCI tcRnStmt, tcRnExpr, tcRnType, tcRnLookupRdrName, - getModuleExports, + getModuleExports, #endif + tcRnImports, tcRnLookupName, tcRnGetInfo, tcRnModule, @@ -72,7 +73,7 @@ import Outputable import DataCon import Type import Class -import TcType ( tyClsNamesOfDFunHead ) +import TcType ( orphNamesOfDFunHead ) import Inst ( tcGetInstEnvs ) import Data.List ( sortBy ) @@ -290,7 +291,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) setEnvs tc_envs $ do { - rn_decls <- checkNoErrs $ rnTyClDecls ldecls ; + (rn_decls, _fvs) <- checkNoErrs $ rnTyClDecls [ldecls] ; -- Dump trace of renaming part rnDump (ppr rn_decls) ; @@ -328,6 +329,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) mg_inst_env = tcg_inst_env tcg_env, mg_fam_inst_env = tcg_fam_inst_env tcg_env, mg_rules = [], + mg_vect_decls = [], mg_anns = [], mg_binds = core_binds, @@ -348,7 +350,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) mkFakeGroup :: [LTyClDecl a] -> HsGroup a mkFakeGroup decls -- Rather clumsy; lots of unused fields - = emptyRdrGroup { hs_tyclds = decls } + = emptyRdrGroup { hs_tyclds = [decls] } \end{code} @@ -364,7 +366,7 @@ tcRnSrcDecls :: ModDetails -> [LHsDecl RdrName] -> TcM TcGblEnv -- Reason: solely to report unused imports and bindings tcRnSrcDecls boot_iface decls = do { -- Do all the declarations - (tc_envs, lie) <- getConstraints $ tc_rn_src_decls boot_iface decls ; + (tc_envs, lie) <- captureConstraints $ tc_rn_src_decls boot_iface decls ; ; traceTc "Tc8" empty ; ; setEnvs tc_envs $ do { @@ -390,28 +392,32 @@ tcRnSrcDecls boot_iface decls -- It's a waste of time; and we may get debug warnings -- about strangely-typed TyCons! - -- Zonk the final code. This must be done last. - -- Even simplifyTop may do some unification. + -- Zonk the final code. This must be done last. + -- Even simplifyTop may do some unification. -- This pass also warns about missing type signatures - let { (tcg_env, _) = tc_envs - ; TcGblEnv { tcg_type_env = type_env, - tcg_binds = binds, - tcg_sigs = sig_ns, - tcg_ev_binds = cur_ev_binds, - tcg_rules = rules, - tcg_fords = fords } = tcg_env + let { (tcg_env, _) = tc_envs + ; TcGblEnv { tcg_type_env = type_env, + tcg_binds = binds, + tcg_sigs = sig_ns, + tcg_ev_binds = cur_ev_binds, + tcg_imp_specs = imp_specs, + tcg_rules = rules, + tcg_vects = vects, + tcg_fords = fords } = tcg_env ; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ; - (bind_ids, ev_binds', binds', fords', rules') - <- zonkTopDecls all_ev_binds binds sig_ns rules fords ; - - let { final_type_env = extendTypeEnvWithIds type_env bind_ids - ; tcg_env' = tcg_env { tcg_binds = binds', - tcg_ev_binds = ev_binds', - tcg_rules = rules', - tcg_fords = fords' } } ; - - setGlobalTypeEnv tcg_env' final_type_env + (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects') + <- zonkTopDecls all_ev_binds binds sig_ns rules vects imp_specs fords ; + + let { final_type_env = extendTypeEnvWithIds type_env bind_ids + ; tcg_env' = tcg_env { tcg_binds = binds', + tcg_ev_binds = ev_binds', + tcg_imp_specs = imp_specs', + tcg_rules = rules', + tcg_vects = vects', + tcg_fords = fords' } } ; + + setGlobalTypeEnv tcg_env' final_type_env } } tc_rn_src_decls :: ModDetails -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv) @@ -478,9 +484,10 @@ tcRnHsBootDecls decls hs_fords = for_decls, hs_defds = def_decls, hs_ruleds = rule_decls, + hs_vects = vect_decls, hs_annds = _, hs_valds = val_binds }) <- rnTopSrcDecls first_group - ; (gbl_env, lie) <- getConstraints $ setGblEnv tcg_env $ do { + ; (gbl_env, lie) <- captureConstraints $ setGblEnv tcg_env $ do { -- Check for illegal declarations @@ -490,6 +497,7 @@ tcRnHsBootDecls decls ; mapM_ (badBootDecl "foreign") for_decls ; mapM_ (badBootDecl "default") def_decls ; mapM_ (badBootDecl "rule") rule_decls + ; mapM_ (badBootDecl "vect") vect_decls -- Typecheck type/class decls ; traceTc "Tc2" empty @@ -502,7 +510,8 @@ tcRnHsBootDecls decls -- Family instance declarations are rejected here ; traceTc "Tc3" empty ; (tcg_env, inst_infos, _deriv_binds) - <- tcInstDecls1 tycl_decls inst_decls deriv_decls + <- tcInstDecls1 (concat tycl_decls) inst_decls deriv_decls + ; setGblEnv tcg_env $ do { -- Typecheck value declarations @@ -637,7 +646,11 @@ checkHiBootIface = case [dfun | inst <- local_insts, let dfun = instanceDFunId inst, idType dfun `tcEqType` boot_inst_ty ] of - [] -> do { addErrTc (instMisMatch boot_inst); return Nothing } + [] -> do { traceTc "check_inst" (vcat [ text "local_insts" <+> vcat (map (ppr . idType . instanceDFunId) local_insts) + , text "boot_inst" <+> ppr boot_inst + , text "boot_inst_ty" <+> ppr boot_inst_ty + ]) + ; addErrTc (instMisMatch boot_inst); return Nothing } (dfun:_) -> return (Just (local_boot_dfun, dfun)) where boot_dfun = instanceDFunId boot_inst @@ -829,6 +842,7 @@ tcTopSrcDecls boot_details hs_defds = default_decls, hs_annds = annotation_decls, hs_ruleds = rule_decls, + hs_vects = vect_decls, hs_valds = val_binds }) = do { -- Type-check the type and class decls, and all imported decls -- The latter come in via tycl_decls @@ -844,7 +858,7 @@ tcTopSrcDecls boot_details -- and import the supporting declarations traceTc "Tc3" empty ; (tcg_env, inst_infos, deriv_binds) - <- tcInstDecls1 tycl_decls inst_decls deriv_decls; + <- tcInstDecls1 (concat tycl_decls) inst_decls deriv_decls; setGblEnv tcg_env $ do { -- Foreign import declarations next. @@ -860,32 +874,35 @@ tcTopSrcDecls boot_details -- 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) ; + (tc_aux_binds, specs1, tcl_env) <- discardWarnings (tcTopBinds aux_binds) ; + (tc_deriv_binds, specs2, tcl_env) <- setLclTypeEnv tcl_env $ + discardWarnings (tcTopBinds deriv_binds) ; -- Value declarations next traceTc "Tc5" empty ; - (tc_val_binds, tcl_env) <- setLclTypeEnv tcl_env $ - tcTopBinds val_binds; + (tc_val_binds, specs3, tcl_env) <- setLclTypeEnv tcl_env $ + tcTopBinds val_binds; setLclTypeEnv tcl_env $ do { -- Environment doesn't change now - -- Second pass over class and instance declarations, + -- Second pass over class and instance declarations, traceTc "Tc6" empty ; - inst_binds <- tcInstDecls2 tycl_decls inst_infos ; + inst_binds <- tcInstDecls2 (concat tycl_decls) inst_infos ; - -- Foreign exports + -- Foreign exports traceTc "Tc7" empty ; - (foe_binds, foe_decls) <- tcForeignExports foreign_decls ; + (foe_binds, foe_decls) <- tcForeignExports foreign_decls ; -- Annotations - annotations <- tcAnnotations annotation_decls ; + annotations <- tcAnnotations annotation_decls ; - -- Rules - rules <- tcRules rule_decls ; + -- Rules + rules <- tcRules rule_decls ; - -- Wrap up + -- Vectorisation declarations + vects <- tcVectDecls vect_decls ; + + -- Wrap up traceTc "Tc7a" empty ; tcg_env <- getGblEnv ; let { all_binds = tc_val_binds `unionBags` @@ -897,14 +914,17 @@ tcTopSrcDecls boot_details ; sig_names = mkNameSet (collectHsValBinders val_binds) `minusNameSet` getTypeSigNames val_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 + -- 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_imp_specs = tcg_imp_specs tcg_env ++ specs1 ++ specs2 ++ + specs3 , tcg_sigs = tcg_sigs tcg_env `unionNameSets` sig_names - , 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) + , tcg_rules = tcg_rules tcg_env ++ rules + , tcg_vects = tcg_vects tcg_env ++ vects + , tcg_anns = tcg_anns tcg_env ++ annotations + , tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ; + return (tcg_env', tcl_env) }}}}}} \end{code} @@ -1079,7 +1099,8 @@ tcRnStmt hsc_env ictxt rdr_stmt setInteractiveContext hsc_env ictxt $ do { -- Rename; use CmdLineMode because tcRnStmt is only used interactively - (([rn_stmt], _), fvs) <- rnStmts GhciStmt [rdr_stmt] (return ((), emptyFVs)) ; + (([rn_stmt], _), fvs) <- rnStmts GhciStmt [rdr_stmt] $ \_ -> + return ((), emptyFVs) ; traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ; failIfErrsM ; rnDump (ppr rn_stmt) ; @@ -1184,7 +1205,7 @@ runPlans (p:ps) = tryTcLIE_ (runPlans ps) p -------------------- mkPlan :: LStmt Name -> TcM PlanResult -mkPlan (L loc (ExprStmt expr _ _)) -- An expression typed at the prompt +mkPlan (L loc (ExprStmt expr _ _ _)) -- An expression typed at the prompt = do { uniq <- newUnique -- is treated very specially ; let fresh_it = itName uniq the_bind = L loc $ mkFunBind (L loc fresh_it) matches @@ -1193,7 +1214,7 @@ mkPlan (L loc (ExprStmt expr _ _)) -- An expression typed at the prompt bind_stmt = L loc $ BindStmt (nlVarPat fresh_it) expr (HsVar bindIOName) noSyntaxExpr print_it = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it)) - (HsVar thenIOName) placeHolderType + (HsVar thenIOName) noSyntaxExpr placeHolderType -- The plans are: -- [it <- e; print it] but not if it::() @@ -1221,7 +1242,7 @@ mkPlan (L loc (ExprStmt expr _ _)) -- An expression typed at the prompt mkPlan stmt@(L loc (BindStmt {})) | [v] <- collectLStmtBinders stmt -- One binder, for a bind stmt = do { let print_v = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar v)) - (HsVar thenIOName) placeHolderType + (HsVar thenIOName) noSyntaxExpr placeHolderType ; print_bind_result <- doptM Opt_PrintBindResult ; let print_plan = do @@ -1271,7 +1292,7 @@ tcGhciStmts stmts -- OK, we're ready to typecheck the stmts traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ; - ((tc_stmts, ids), lie) <- getConstraints $ tc_io_stmts stmts $ \ _ -> + ((tc_stmts, ids), lie) <- captureConstraints $ tc_io_stmts stmts $ \ _ -> mapM tcLookupId names ; -- Look up the names right in the middle, -- where they will all be in scope @@ -1283,7 +1304,7 @@ tcGhciStmts stmts traceTc "TcRnDriver.tcGhciStmts: done" empty ; return (ids, mkHsDictLet (EvBinds const_binds) $ - noLoc (HsDo GhciStmt tc_stmts (mk_return ids) io_ret_ty)) + noLoc (HsDo GhciStmt tc_stmts (mk_return ids) noSyntaxExpr io_ret_ty)) } \end{code} @@ -1304,9 +1325,16 @@ tcRnExpr hsc_env ictxt rdr_expr -- Now typecheck the expression; -- it might have a rank-2 type (e.g. :t runST) - ((_tc_expr, res_ty), lie) <- getConstraints (tcInferRho rn_expr) ; - ((qtvs, dicts, _), lie_top) <- getConstraints (simplifyInfer False {- No MR for now -} - (tyVarsOfType res_ty) lie) ; + + uniq <- newUnique ; + let { fresh_it = itName uniq } ; + ((_tc_expr, res_ty), lie) <- captureConstraints (tcInferRho rn_expr) ; + ((qtvs, dicts, _), lie_top) <- captureConstraints $ + simplifyInfer TopLevel + False {- No MR for now -} + [(fresh_it, res_ty)] + lie ; + _ <- simplifyInteractive lie_top ; -- Ignore the dicionary bindings let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts res_ty) } ; @@ -1483,7 +1511,7 @@ lookupInsts (ATyCon tc) , let dfun = instanceDFunId ispec , relevant dfun ] } where - relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df) + relevant df = tc_name `elemNameSet` orphNamesOfDFunHead (idType df) tc_name = tyConName tc lookupInsts _ = return [] @@ -1547,18 +1575,20 @@ tcCoreDump mod_guts -- It's unpleasant having both pprModGuts and pprModDetails here pprTcGblEnv :: TcGblEnv -> SDoc pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, - tcg_insts = insts, - tcg_fam_insts = fam_insts, - tcg_rules = rules, - tcg_imports = imports }) + tcg_insts = insts, + tcg_fam_insts = fam_insts, + tcg_rules = rules, + tcg_vects = vects, + tcg_imports = imports }) = vcat [ ppr_types insts type_env , ppr_tycons fam_insts type_env - , ppr_insts insts - , ppr_fam_insts fam_insts - , vcat (map ppr rules) - , ppr_gen_tycons (typeEnvTyCons type_env) - , ptext (sLit "Dependent modules:") <+> - ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports)) + , ppr_insts insts + , ppr_fam_insts fam_insts + , vcat (map ppr rules) + , vcat (map ppr vects) + , ppr_gen_tycons (typeEnvTyCons type_env) + , ptext (sLit "Dependent modules:") <+> + ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports)) , ptext (sLit "Dependent packages:") <+> ppr (sortBy stablePackageIdCmp $ imp_dep_pkgs imports)] where -- The two uses of sortBy are just to reduce unnecessary