From: simonmar Date: Fri, 23 Feb 2001 12:24:11 +0000 (+0000) Subject: [project @ 2001-02-23 12:24:10 by simonmar] X-Git-Tag: Approximately_9120_patches~2557 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=20d1c20c49feae6b862c87504bbd9b8c483044f3;p=ghc-hetmet.git [project @ 2001-02-23 12:24:10 by simonmar] Fix a problem with duplicate instances appearing in the interpreter after reloading modules. --- diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 7df53e2..fd2f0a9 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -156,16 +156,13 @@ hscNoRecomp ghci_mode dflags location (Just old_iface) hst hit pcs_ch else do { -- TYPECHECK - maybe_tc_result <- typecheckModule dflags pcs_cl hst - old_iface alwaysQualify (vanillaSyntaxMap, cl_hs_decls) - False{-don't check for Main.main-}; + maybe_tc_result + <- typecheckIface dflags pcs_cl hst old_iface (vanillaSyntaxMap, cl_hs_decls); + case maybe_tc_result of { Nothing -> return (HscFail pcs_cl); - Just (pcs_tc, tc_result) -> do { + Just (pcs_tc, env_tc, local_rules) -> do { - let env_tc = tc_env tc_result - local_rules = tc_rules tc_result - ; -- create a new details from the closed, typechecked, old iface let new_details = mkModDetailsFromIface env_tc local_rules ; @@ -216,7 +213,6 @@ hscRecomp ghci_mode dflags location maybe_checked_iface hst hit pcs_ch ; maybe_tc_result <- _scc_ "TypeCheck" typecheckModule dflags pcs_rn hst new_iface print_unqualified rn_hs_decls - True{-check for Main.main if necessary-} ; case maybe_tc_result of { Nothing -> return (HscFail pcs_ch{-was: pcs_rn-}); Just (pcs_tc, tc_result) -> do { diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index cca7316..650eb71 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -247,7 +247,7 @@ tcDeriving prs mod inst_env_in get_fixity tycl_decls -- Make a Real dfun instead of the dummy one we have so far gen_inst_info :: DFunId -> RenamedMonoBinds -> InstInfo gen_inst_info dfun binds - = InstInfo { iLocal = True, iDFunId = dfun, + = InstInfo { iDFunId = dfun, iBinds = binds, iPrags = [] } rn_meths meths = rnMethodBinds [] meths `thenRn` \ (meths', _) -> returnRn meths' diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index ac92dc3..b684d60 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -57,8 +57,8 @@ import DataCon ( DataCon ) import TyCon ( TyCon ) import Class ( Class, ClassOpItem, ClassContext ) import Name ( Name, OccName, NamedThing(..), - nameOccName, getSrcLoc, mkLocalName, - isLocalName, nameModule_maybe + nameOccName, getSrcLoc, mkLocalName, isLocalName, + nameIsLocalOrFrom, nameModule_maybe ) import Name ( NameEnv, lookupNameEnv, nameEnvElts, extendNameEnvList, emptyNameEnv ) import OccName ( mkDFunOcc, occNameString ) @@ -261,11 +261,7 @@ newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc) \begin{code} isLocalThing :: NamedThing a => Module -> a -> Bool - -- True if the thing has a Local name, - -- or a Global name from the specified module -isLocalThing mod thing = case nameModule_maybe (getName thing) of - Nothing -> True -- A local name - Just m -> m == mod -- A global thing +isLocalThing mod thing = nameIsLocalOrFrom mod (getName thing) \end{code} %************************************************************************ @@ -509,7 +505,6 @@ The InstInfo type summarises the information in an instance declaration \begin{code} data InstInfo = InstInfo { - iLocal :: Bool, -- True <=> it's defined in this module iDFunId :: DFunId, -- The dfun id iBinds :: RenamedMonoBinds, -- Bindings, b iPrags :: [RenamedSig] -- User pragmas recorded for generating specialised instances diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index a094fd9..fd70cff 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -15,8 +15,8 @@ import HsSyn ( HsDecl(..), InstDecl(..), TyClDecl(..), HsType(..), MonoBinds(..), HsExpr(..), HsLit(..), Sig(..), andMonoBindList, collectMonoBinders, isClassDecl ) -import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl, RenamedMonoBinds, - RenamedTyClDecl, RenamedHsType, +import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl, + RenamedMonoBinds, RenamedTyClDecl, RenamedHsType, extractHsTyVars, maybeGenericMatch ) import TcHsSyn ( TcMonoBinds, mkHsConApp ) @@ -31,8 +31,9 @@ import TcDeriv ( tcDeriving ) import TcEnv ( TcEnv, tcExtendGlobalValEnv, tcExtendTyVarEnvForMeths, tcAddImportedIdInfo, tcLookupClass, - InstInfo(..), pprInstInfo, simpleInstInfoTyCon, simpleInstInfoTy, - newDFunName, tcExtendTyVarEnv + InstInfo(..), pprInstInfo, simpleInstInfoTyCon, + simpleInstInfoTy, newDFunName, tcExtendTyVarEnv, + isLocalThing, ) import InstEnv ( InstEnv, extendInstEnv ) import TcMonoType ( tcTyVars, tcHsSigType, kcHsSigType, checkSigTyVars ) @@ -171,7 +172,7 @@ tcInstDecls1 :: PackageInstEnv -> [RenamedHsDecl] -> TcM (PackageInstEnv, InstEnv, [InstInfo], RenamedHsBinds) -tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod decls +tcInstDecls1 inst_env0 prs hst unf_env get_fixity this_mod decls = let inst_decls = [inst_decl | InstD inst_decl <- decls] tycl_decls = [decl | TyClD decl <- decls] @@ -191,7 +192,8 @@ tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod decls -- e) generic instances inst_env4 -- The result of (b) replaces the cached InstEnv in the PCS let - (local_inst_info, imported_inst_info) = partition iLocal (concat inst_infos) + (local_inst_info, imported_inst_info) + = partition (isLocalThing this_mod . iDFunId) (concat inst_infos) imported_dfuns = map (tcAddImportedIdInfo unf_env . iDFunId) imported_inst_info @@ -207,7 +209,8 @@ tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod decls -- we ignore deriving decls from interfaces! -- This stuff computes a context for the derived instance decl, so it -- needs to know about all the instances possible; hecne inst_env4 - tcDeriving prs mod inst_env4 get_fixity tycl_decls `thenTc` \ (deriv_inst_info, deriv_binds) -> + tcDeriving prs this_mod inst_env4 get_fixity tycl_decls + `thenTc` \ (deriv_inst_info, deriv_binds) -> addInstInfos inst_env4 deriv_inst_info `thenNF_Tc` \ final_inst_env -> returnTc (inst_env1, @@ -267,7 +270,7 @@ tcInstDecl1 decl@(InstDecl poly_ty binds uprags maybe_dfun_name src_loc) let dfun_id = mkDictFunId dfun_name clas tyvars inst_tys theta in - returnTc [InstInfo { iLocal = is_local, iDFunId = dfun_id, + returnTc [InstInfo { iDFunId = dfun_id, iBinds = binds, iPrags = uprags }] \end{code} @@ -406,7 +409,7 @@ mkGenericInstance clas loc (hs_ty, binds) dfun_id = mkDictFunId dfun_name clas tyvars inst_tys inst_theta in - returnTc (InstInfo { iLocal = True, iDFunId = dfun_id, + returnTc (InstInfo { iDFunId = dfun_id, iBinds = binds, iPrags = [] }) \end{code} @@ -498,15 +501,13 @@ is the @dfun_theta@ below. First comes the easy case of a non-local instance decl. + \begin{code} tcInstDecl2 :: InstInfo -> NF_TcM (LIE, TcMonoBinds) +-- tcInstDecl2 is called *only* on InstInfos -tcInstDecl2 (InstInfo { iLocal = is_local, iDFunId = dfun_id, +tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = monobinds, iPrags = uprags }) - | not is_local - = returnNF_Tc (emptyLIE, EmptyMonoBinds) - - | otherwise = -- Prime error recovery recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $ tcAddSrcLoc (getSrcLoc dfun_id) $ diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 4718587..50343ef 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -5,7 +5,7 @@ \begin{code} module TcModule ( - typecheckModule, typecheckExpr, TcResults(..) + typecheckModule, typecheckIface, typecheckExpr, TcResults(..) ) where #include "HsVersions.h" @@ -82,18 +82,17 @@ typecheckModule :: DynFlags -> PersistentCompilerState -> HomeSymbolTable - -> ModIface -- Iface for this module + -> ModIface -- Iface for this module (just module & fixities) -> PrintUnqualified -- For error printing -> (SyntaxMap, [RenamedHsDecl]) - -> Bool -- True <=> check for Main.main if Module==Main -> IO (Maybe (PersistentCompilerState, TcResults)) -- The new PCS is Augmented with imported information, -- (but not stuff from this module) -typecheckModule dflags pcs hst mod_iface unqual (syn_map, decls) check_main +typecheckModule dflags pcs hst mod_iface unqual (syn_map, decls) = do { maybe_tc_result <- typecheck dflags syn_map pcs hst unqual $ - tcModule pcs hst get_fixity this_mod decls check_main + tcModule pcs hst get_fixity this_mod decls ; printTcDump dflags maybe_tc_result ; return maybe_tc_result } where @@ -104,6 +103,48 @@ typecheckModule dflags pcs hst mod_iface unqual (syn_map, decls) check_main get_fixity nm = lookupNameEnv fixity_env nm --------------- +typecheckIface + :: DynFlags + -> PersistentCompilerState + -> HomeSymbolTable + -> ModIface -- Iface for this module (just module & fixities) + -> (SyntaxMap, [RenamedHsDecl]) + -> IO (Maybe (PersistentCompilerState, TypeEnv, [TypecheckedRuleDecl])) + -- The new PCS is Augmented with imported information, + -- (but not stuff from this module). + -- The TcResults returned contains only the environment + -- and rules. + + +typecheckIface dflags pcs hst mod_iface (syn_map, decls) + = do { maybe_tc_stuff <- typecheck dflags syn_map pcs hst alwaysQualify $ + tcIfaceImports pcs hst get_fixity this_mod decls + ; printIfaceDump dflags maybe_tc_stuff + ; return maybe_tc_stuff } + where + this_mod = mi_module mod_iface + fixity_env = mi_fixities mod_iface + + get_fixity :: Name -> Maybe Fixity + get_fixity nm = lookupNameEnv fixity_env nm + + tcIfaceImports pcs hst get_fixity this_mod decls + = fixTc (\ ~(unf_env, _, _, _, _) -> + tcImports unf_env pcs hst get_fixity this_mod decls + ) `thenTc` \ (env, new_pcs, local_inst_info, + deriv_binds, local_rules) -> + ASSERT(nullBinds deriv_binds) + let + local_things = filter (isLocalThing this_mod) + (nameEnvElts (getTcGEnv env)) + local_type_env :: TypeEnv + local_type_env = mkTypeEnv local_things + in + + -- throw away local_inst_info + returnTc (new_pcs, local_type_env, local_rules) + +--------------- typecheckExpr :: DynFlags -> Bool -- True <=> wrap in 'print' to get a result of IO type -> PersistentCompilerState @@ -205,10 +246,9 @@ tcModule :: PersistentCompilerState -> (Name -> Maybe Fixity) -> Module -> [RenamedHsDecl] - -> Bool -- True <=> check for Main.main if Mod==Main -> TcM (PersistentCompilerState, TcResults) -tcModule pcs hst get_fixity this_mod decls check_main +tcModule pcs hst get_fixity this_mod decls = fixTc (\ ~(unf_env, _, _) -> -- Loop back the final environment, including the fully zonkec -- versions of bindings from this module. In the presence of mutual @@ -261,9 +301,7 @@ tcModule pcs hst get_fixity this_mod decls check_main tcSimplifyTop lie_alldecls `thenTc` \ const_inst_binds -> -- CHECK THAT main IS DEFINED WITH RIGHT TYPE, IF REQUIRED - (if check_main - then tcCheckMain this_mod - else returnTc ()) `thenTc_` + tcCheckMain this_mod `thenTc_` -- Backsubstitution. This must be done last. -- Even tcSimplifyTop may do some unification. @@ -466,22 +504,34 @@ noMainErr = hsep [ptext SLIT("Module") <+> quotes (ppr mAIN_Name), printTcDump dflags Nothing = return () printTcDump dflags (Just (_, results)) = do dumpIfSet_dyn dflags Opt_D_dump_types - "Type signatures" (dump_sigs results) + "Type signatures" (dump_sigs (tc_env results)) dumpIfSet_dyn dflags Opt_D_dump_tc "Typechecked" (dump_tc results) +printIfaceDump dflags Nothing = return () +printIfaceDump dflags (Just (_, env, rules)) + = do dumpIfSet_dyn dflags Opt_D_dump_types + "Type signatures" (dump_sigs env) + dumpIfSet_dyn dflags Opt_D_dump_tc + "Typechecked" (dump_iface env rules) + dump_tc results = vcat [ppr (tc_binds results), pp_rules (tc_rules results), ppr_gen_tycons [tc | ATyCon tc <- nameEnvElts (tc_env results)] ] -dump_sigs results -- Print type signatures +dump_iface env rules + = vcat [pp_rules rules, + ppr_gen_tycons [tc | ATyCon tc <- nameEnvElts env] + ] + +dump_sigs env -- Print type signatures = -- Convert to HsType so that we get source-language style printing -- And sort by RdrName vcat $ map ppr_sig $ sortLt lt_sig $ [ (toRdrName id, toHsType (idType id)) - | AnId id <- nameEnvElts (tc_env results), + | AnId id <- nameEnvElts env, want_sig id ] where