X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnDriver.lhs;h=830dcc2ab4bb4b980cfd1cce3de8017959e27b9d;hb=802b299f16593e95deb6cc2bd5d457444ed92fd1;hp=2aec0068f1586a0ce24f99c0d99c6043c2422da8;hpb=0877011afd5886ee06df2e2723d631ff0686324f;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 2aec006..830dcc2 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -156,11 +156,6 @@ tcRnModule hsc_env pcs -- 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 ; - setGblEnv tcg_env $ do { traceRn (text "rn3") ; -- Check whether the entire module is deprecated @@ -191,13 +186,13 @@ tcRnModule hsc_env pcs setGblEnv tcg_env $ do { -- Report unused names - let { used_fvs = src_fvs `plusFV` main_fvs `plusFV` export_fvs } ; + let { used_fvs = src_fvs `plusFV` export_fvs } ; reportUnusedNames tcg_env used_fvs ; -- Dump output and return tcDump tcg_env ; return tcg_env - }}}}}}}} + }}}}}}} \end{code} @@ -483,24 +478,28 @@ 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 } ; - - if null names then - do { addMessages (head msgs_s) ; failM } - else do { + -- results :: [(Messages, Maybe Name)] + results <- initRnInteractive ictxt + (mapM (tryTc . lookupOccRn) rdr_names) ; - -- Add deprecation warnings - mapM_ addMessages msgs_s ; + -- 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] } ; + -- 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 names) ; + tcg_env <- importSupportingDecls (mkFVs good_names) ; setGblEnv tcg_env $ do { -- And lookup up the entities - mapM tcLookupGlobal names - }}} + mapM tcLookupGlobal good_names + }} \end{code} @@ -548,10 +547,17 @@ tcRnExtCore hsc_env pcs (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 fvs ; + let { rn_decls = rn_local_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 @@ -600,26 +606,67 @@ tcRnExtCore hsc_env pcs tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, FreeVars) -- 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, fvs), 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' }, + fvs) + }} + +tc_rn_src_decls :: [RdrNameHsDecl] -> TcM ((TcGblEnv, TcLclEnv), FreeVars) + +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_fvs1) <- 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 + setEnvs tc_envs $ + + -- If there is no splice, we're nearlydone case group_tail of { - Nothing -> return (tcg_env, src_fvs1) ; - Just (SpliceDecl splice_expr splice_loc, rest_ds) -> + Nothing -> do { -- Last thing: check for `main' + (tcg_env, main_fvs) <- checkMain ; + return ((tcg_env, tcl_env), src_fvs1 `plusFV` 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 - setGblEnv tcg_env $ do { -- Rename the splice expression, and get its supporting decls (rn_splice_expr, fvs) <- initRn SourceMode $ @@ -632,12 +679,12 @@ tcRnSrcDecls ds 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_fvs2) <- tc_rn_src_decls (spliced_decls ++ rest_ds) ; - return (tcg_env, src_fvs1 `plusFV` src_fvs2) - }} + return (tc_envs, src_fvs1 `plusFV` src_fvs2) + } #endif /* GHCI */ - }} + }}} \end{code} @@ -659,16 +706,20 @@ 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), FreeVars) + -- Returns the variables free in the decls, for unused-binding reporting tcRnGroup decls - = do { -- Rename the declarations + = do { showLIE (text "start of tcRnGroup" ++ ppr decls) ; + + -- Rename the declarations (tcg_env, rn_decls, src_fvs) <- rnTopSrcDecls decls ; setGblEnv tcg_env $ do { -- Typecheck the declarations - tcg_env <- tcTopSrcDecls rn_decls ; - return (tcg_env, src_fvs) + tc_envs <- tcTopSrcDecls rn_decls ; + + showLIE (text "end of tcRnGroup" ++ ppr decls) + return (tc_envs, src_fvs) }} ------------------------------------------------ @@ -702,43 +753,8 @@ rnTopSrcDecls group }}} ------------------------------------------------ -tcTopSrcDecls :: HsGroup Name -> TcM TcGblEnv -tcTopSrcDecls rn_decls - = do { -- Do the main work - ((tcg_env, lcl_env, binds, rules, fords), lie) <- getLIE ( - tc_src_decls 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 $ - setLclTypeEnv lcl_env $ - tcSimplifyTop lie ; - -- The setGblEnv exposes the instances to tcSimplifyTop - -- The setLclTypeEnv exposes the local Ids, so that - -- we get better error messages (monomorphism restriction) - - -- Backsubstitution. This must be done last. - -- Even tcSimplifyTop may do some unification. - traceTc (text "Tc9") ; - (bind_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) - bind_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 +tcTopSrcDecls :: HsGroup Name -> TcM (TcGblEnv, TcLclEnv) +tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls, hs_instds = inst_decls, hs_fords = foreign_decls, @@ -746,6 +762,7 @@ tc_src_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 <- tcTyClDecls tycl_decls ; setGblEnv tcg_env $ do { @@ -784,7 +801,7 @@ tc_src_decls (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 @@ -805,9 +822,15 @@ tc_src_decls let { all_binds = tc_val_binds `AndMonoBinds` inst_binds `AndMonoBinds` cls_dm_binds `AndMonoBinds` - foe_binds } ; + foe_binds ; - return (tcg_env, lcl_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} @@ -829,8 +852,9 @@ tcTyClDecls tycl_decls -- an error we'd better stop now, to avoid a cascade traceTc (text "TyCl1") `thenM_` - tcTyAndClassDecls tycl_decls `thenM` \ tycl_things -> - tcExtendGlobalEnv tycl_things $ + tcTyAndClassDecls tycl_decls `thenM` \ tcg_env -> + -- Returns the extended environment + setGblEnv tcg_env $ traceTc (text "TyCl2") `thenM_` tcInterfaceSigs tycl_decls `thenM` \ tcg_env -> @@ -930,8 +954,8 @@ 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 }) @@ -1089,26 +1113,19 @@ check_main ghci_mode tcg_env = do { main_name <- lookupSrcName main_RDR_Unqual ; 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) <- tcExpr_id 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) }}