X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnDriver.lhs;h=40171671048914b2a45d9e240e01d4f21aa6546a;hp=773f307053344ef19f2aa8a070867c3f1c72b02f;hb=924142621ebc30a3c16368e0df3466ee14185ddd;hpb=6ea06bbf08517d9805feb82df65cc56ecbaf23a4 diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 773f307..4017167 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 ) @@ -299,7 +300,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) -- any mutually recursive types are done right -- Just discard the auxiliary bindings; they are generated -- only for Haskell source code, and should already be in Core - (tcg_env, _aux_binds, _dm_ids) <- tcTyAndClassDecls emptyModDetails rn_decls ; + (tcg_env, _aux_binds, _dm_ids, _) <- tcTyAndClassDecls emptyModDetails rn_decls ; setGblEnv tcg_env $ do { -- Make the new type env available to stuff slurped from interface files @@ -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, @@ -390,30 +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_imp_specs = imp_specs, - 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', imp_specs', rules') - <- zonkTopDecls all_ev_binds binds sig_ns rules 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_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) @@ -480,6 +484,7 @@ 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) <- captureConstraints $ setGblEnv tcg_env $ do { @@ -492,10 +497,11 @@ 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 - ; (tcg_env, aux_binds, dm_ids) + ; (tcg_env, aux_binds, dm_ids, _) <- tcTyAndClassDecls emptyModDetails tycl_decls ; setGblEnv tcg_env $ tcExtendIdEnv dm_ids $ do { @@ -505,6 +511,7 @@ tcRnHsBootDecls decls ; traceTc "Tc3" empty ; (tcg_env, inst_infos, _deriv_binds) <- tcInstDecls1 (concat tycl_decls) inst_decls deriv_decls + ; setGblEnv tcg_env $ do { -- Typecheck value declarations @@ -639,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 @@ -831,12 +842,13 @@ 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 traceTc "Tc2" empty ; - (tcg_env, aux_binds, dm_ids) <- tcTyAndClassDecls boot_details tycl_decls ; + (tcg_env, aux_binds, dm_ids, kc_decls) <- tcTyAndClassDecls boot_details tycl_decls ; -- If there are any errors, tcTyAndClassDecls fails here setGblEnv tcg_env $ @@ -873,21 +885,25 @@ tcTopSrcDecls boot_details setLclTypeEnv tcl_env $ do { -- Environment doesn't change now - -- Second pass over class and instance declarations, + -- Second pass over class and instance declarations, + -- now using the kind-checked decls traceTc "Tc6" empty ; - inst_binds <- tcInstDecls2 (concat tycl_decls) inst_infos ; + inst_binds <- tcInstDecls2 kc_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` @@ -899,15 +915,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 - , tcg_imp_specs = tcg_imp_specs tcg_env ++ specs1 ++ specs2 ++ specs3 + -- 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} @@ -1308,9 +1326,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) <- captureConstraints (tcInferRho rn_expr) ; - ((qtvs, dicts, _), lie_top) <- captureConstraints (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) } ; @@ -1487,7 +1512,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 [] @@ -1551,18 +1576,19 @@ 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) + , 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 @@ -1640,9 +1666,4 @@ ppr_rules [] = empty ppr_rules rs = vcat [ptext (sLit "{-# RULES"), nest 2 (pprRules rs), ptext (sLit "#-}")] - -ppr_gen_tycons :: [TyCon] -> SDoc -ppr_gen_tycons [] = empty -ppr_gen_tycons tcs = vcat [ptext (sLit "Tycons with generics:"), - nest 2 (fsep (map ppr (filter tyConHasGenerics tcs)))] \end{code}