From 5538aeebb0a92ec73552d92df3afbb70612ca56d Mon Sep 17 00:00:00 2001 From: simonpj Date: Fri, 14 Feb 2003 14:22:25 +0000 Subject: [PATCH] [project @ 2003-02-14 14:22:24 by simonpj] ------------------------------------- Do the top-level tcSimpifyTop (to resolve monomorphic constraints) once for the whole program, rather than once per splice group ------------------------------------- This change makes the trivial program main = return () work again. It had stopped working (emitting an error about Monad m being unconstrained) because the 'checkMain' stuff (which knows special things about 'main' was happening only *after* all the groups of decls in the module had been dealt with and zonked (incl tcSimplifyTop). Better to postpone. A little more plumbing, but one fewer unexpected happenings. --- ghc/compiler/typecheck/TcHsSyn.lhs | 2 + ghc/compiler/typecheck/TcRnDriver.lhs | 150 ++++++++++++++++----------------- ghc/compiler/typecheck/TcRnMonad.lhs | 6 ++ ghc/compiler/typecheck/TcRnTypes.lhs | 7 +- 4 files changed, 88 insertions(+), 77 deletions(-) diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 0ca5d60..79fbcd1 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -818,6 +818,8 @@ zonkForeignExports env ls = mappM (zonkForeignExport env) ls zonkForeignExport :: ZonkEnv -> TcForeignDecl -> TcM (TypecheckedForeignDecl) zonkForeignExport env (ForeignExport i hs_ty spec isDeprec src_loc) = returnM (ForeignExport (zonkIdOcc env i) undefined spec isDeprec src_loc) +zonkForeignExport env for_imp + = returnM for_imp -- Foreign imports don't need zonking \end{code} \begin{code} diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index d225b6c..89dc247 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} @@ -600,26 +595,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) ; + 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) -> #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,10 +668,10 @@ 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 +695,16 @@ 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 (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 ; + return (tc_envs, src_fvs) }} ------------------------------------------------ @@ -702,43 +738,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, @@ -806,9 +807,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} @@ -1091,26 +1098,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) }} diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs index 03e2186..927f7e2 100644 --- a/ghc/compiler/typecheck/TcRnMonad.lhs +++ b/ghc/compiler/typecheck/TcRnMonad.lhs @@ -246,6 +246,12 @@ updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) -> setLclEnv :: m -> TcRn m a -> TcRn n a setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env }) + +getEnvs :: TcRn m (TcGblEnv, m) +getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) } + +setEnvs :: (TcGblEnv, m) -> TcRn m a -> TcRn m a +setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env }) \end{code} Command-line flags diff --git a/ghc/compiler/typecheck/TcRnTypes.lhs b/ghc/compiler/typecheck/TcRnTypes.lhs index a42cbc8..790911b 100644 --- a/ghc/compiler/typecheck/TcRnTypes.lhs +++ b/ghc/compiler/typecheck/TcRnTypes.lhs @@ -278,7 +278,7 @@ data TcGblEnv -- tc_pcs, tc_hpt, *and* tc_insts -- This field is mutable so that it can be updated inside a -- Template Haskell splice, which might suck in some new - -- instance declarations. This is a slightly differen strategy + -- instance declarations. This is a slightly different strategy -- than for the type envt, where we look up first in tcg_type_env -- and then in the mutable EPS, because the InstEnv for this module -- is constructed (in principle at least) only from the modules @@ -292,7 +292,10 @@ data TcGblEnv tcg_imports :: ImportAvails, -- Information about what was imported -- from where, including things bound -- in this module - -- The next fields are always fully zonked + + -- The next fields accumulate the payload of the module + -- The binds, rules and foreign-decl fiels are collected + -- initially in un-zonked form and are finally zonked in tcRnSrcDecls tcg_binds :: MonoBinds Id, -- Value bindings in this module tcg_deprecs :: Deprecations, -- ...Deprecations tcg_insts :: [DFunId], -- ...Instances -- 1.7.10.4