From 8fbe28ca67a6c07575aee35bfade43e967ad792e Mon Sep 17 00:00:00 2001 From: simonpj Date: Tue, 21 Nov 2000 09:30:17 +0000 Subject: [PATCH] [project @ 2000-11-21 09:30:16 by simonpj] Fix renamer bugs --- ghc/compiler/basicTypes/Unique.lhs | 9 +++++++-- ghc/compiler/main/HscTypes.lhs | 5 +++++ ghc/compiler/prelude/TysWiredIn.lhs | 26 ++++++++++++++------------ ghc/compiler/rename/Rename.lhs | 2 +- ghc/compiler/rename/RnIfaces.lhs | 8 +++----- ghc/compiler/typecheck/TcInstDcls.lhs | 16 ++++++++++++---- 6 files changed, 42 insertions(+), 24 deletions(-) diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs index e8b4e38..feb4e8e 100644 --- a/ghc/compiler/basicTypes/Unique.lhs +++ b/ghc/compiler/basicTypes/Unique.lhs @@ -287,9 +287,14 @@ Allocation of unique supply characters: mkAlphaTyVarUnique i = mkUnique '1' i mkPreludeClassUnique i = mkUnique '2' i + +-- Prelude type constructors occupy *three* slots. +-- The first is for the tycon itself; the latter two +-- are for the generic to/from Ids. See TysWiredIn.mk_tc_gen_info. + mkPreludeTyConUnique i = mkUnique '3' (3*i) -mkTupleTyConUnique Boxed a = mkUnique '4' a -mkTupleTyConUnique Unboxed a = mkUnique '5' a +mkTupleTyConUnique Boxed a = mkUnique '4' (3*a) +mkTupleTyConUnique Unboxed a = mkUnique '5' (3*a) -- Data constructor keys occupy *two* slots. The first is used for the -- data constructor itself and its wrapper function (the function that diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index c60c575..49f12f2 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -257,6 +257,11 @@ instance NamedThing TyThing where getName (ATyCon tc) = getName tc getName (AClass cl) = getName cl +instance Outputable TyThing where + ppr (AnId id) = ptext SLIT("AnId") <+> ppr id + ppr (ATyCon tc) = ptext SLIT("ATyCon") <+> ppr tc + ppr (AClass cl) = ptext SLIT("AClass") <+> ppr cl + typeEnvClasses env = [cl | AClass cl <- nameEnvElts env] typeEnvTyCons env = [tc | ATyCon tc <- nameEnvElts env] diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index c63d3e1..15f3451 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -178,6 +178,20 @@ pcTyCon new_or_data is_rec name tyvars argvrcs cons kind = mkArrowKinds (map tyVarKind tyvars) boxedTypeKind gen_info = mk_tc_gen_info mod (nameUnique name) name tycon +-- We generate names for the generic to/from Ids by incrementing +-- the TyCon unique. So each Prelude tycon needs 3 slots, one +-- for itself and two more for the generic Ids. +mk_tc_gen_info mod tc_uniq tc_name tycon + = mkTyConGenInfo tycon name1 name2 + where + tc_occ_name = nameOccName tc_name + occ_name1 = mkGenOcc1 tc_occ_name + occ_name2 = mkGenOcc2 tc_occ_name + fn1_key = incrUnique tc_uniq + fn2_key = incrUnique fn1_key + name1 = mkWiredInName mod occ_name1 fn1_key + name2 = mkWiredInName mod occ_name2 fn2_key + pcDataCon :: Name -> [TyVar] -> ClassContext -> [TauType] -> TyCon -> DataCon -- The unique is the first of two free uniques; -- the first is used for the datacon itself and the worker; @@ -246,18 +260,6 @@ mk_tuple boxity arity = (tycon, tuple_con) mod = mkPrelModule mod_name gen_info = mk_tc_gen_info mod tc_uniq tc_name tycon -mk_tc_gen_info mod tc_uniq tc_name tycon - = gen_info - where - tc_occ_name = nameOccName tc_name - occ_name1 = mkGenOcc1 tc_occ_name - occ_name2 = mkGenOcc2 tc_occ_name - fn1_key = incrUnique tc_uniq - fn2_key = incrUnique fn1_key - name1 = mkWiredInName mod occ_name1 fn1_key - name2 = mkWiredInName mod occ_name2 fn2_key - gen_info = mkTyConGenInfo tycon name1 name2 - unitTyCon = tupleTyCon Boxed 0 unitDataConId = dataConId (head (tyConDataCons unitTyCon)) diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 41abf2e..23d53a6 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -110,7 +110,7 @@ renameExpr dflags hit hst pcs this_module expr ; renameSource dflags hit hst pcs this_module $ initRnMS rdr_env emptyLocalFixityEnv SourceMode (rnExpr expr) `thenRn` \ (e,fvs) -> - closeDecls [] fvs `thenRn` \ decls -> + slurpImpDecls fvs `thenRn` \ decls -> doptRn Opt_D_dump_rn `thenRn` \ dump_rn -> ioToRnM (dumpIfSet dump_rn "Renamer:" (ppr e)) `thenRn_` returnRn (Just (print_unqual, (e, decls))) diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index d1e4174..e62b780 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -213,22 +213,20 @@ slurpImpDecls source_fvs = traceRn (text "slurpImp" <+> fsep (map ppr (nameSetToList source_fvs))) `thenRn_` -- The current slurped-set records all local things - getSlurped `thenRn` \ source_binders -> - slurpSourceRefs source_binders source_fvs `thenRn` \ (decls, needed) -> + slurpSourceRefs source_fvs `thenRn` \ (decls, needed) -> -- Then get everything else closeDecls decls needed ------------------------------------------------------- -slurpSourceRefs :: NameSet -- Variables defined in source - -> FreeVars -- Variables referenced in source +slurpSourceRefs :: FreeVars -- Variables referenced in source -> RnMG ([RenamedHsDecl], FreeVars) -- Un-satisfied needs -- The declaration (and hence home module) of each gate has -- already been loaded -slurpSourceRefs source_binders source_fvs +slurpSourceRefs source_fvs = go_outer [] -- Accumulating decls emptyFVs -- Unsatisfied needs emptyFVs -- Accumulating gates diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index a8a3de0..a49220d 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -31,7 +31,7 @@ import TcEnv ( TcEnv, tcExtendGlobalValEnv, tcExtendTyVarEnvForMeths, tcAddImportedIdInfo, tcInstId, tcLookupClass, InstInfo(..), pprInstInfo, simpleInstInfoTyCon, simpleInstInfoTy, - newDFunName, tcExtendTyVarEnv, tcGetInstEnv + newDFunName, tcExtendTyVarEnv ) import InstEnv ( InstEnv, extendInstEnv, pprInstEnv ) import TcMonoType ( tcTyVars, tcHsSigType, kcHsSigType ) @@ -196,6 +196,11 @@ tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod decls imported_inst_info hst_dfuns = foldModuleEnv ((++) . md_insts) [] hst in + traceTc (text "inst env before" <+> pprInstEnv inst_env0) `thenNF_Tc_` + traceTc (vcat [text "imp" <+> ppr imported_dfuns, + text "hst" <+> ppr hst_dfuns, + text "local" <+> hsep (map pprInstInfo local_inst_info), + text "gen" <+> hsep (map pprInstInfo generic_inst_info)]) `thenNF_Tc_` addInstDFuns inst_env0 imported_dfuns `thenNF_Tc` \ inst_env1 -> addInstDFuns inst_env1 hst_dfuns `thenNF_Tc` \ inst_env2 -> addInstInfos inst_env2 local_inst_info `thenNF_Tc` \ inst_env3 -> @@ -207,8 +212,10 @@ tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod decls -- 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) -> + traceTc (vcat [text "deriv" <+> hsep (map pprInstInfo deriv_inst_info)]) `thenNF_Tc_` addInstInfos inst_env4 deriv_inst_info `thenNF_Tc` \ final_inst_env -> + traceTc (text "inst env after" <+> pprInstEnv final_inst_env) `thenNF_Tc_` returnTc (inst_env1, final_inst_env, generic_inst_info ++ deriv_inst_info ++ local_inst_info, @@ -220,11 +227,12 @@ addInstInfos inst_env infos = addInstDFuns inst_env (map iDFunId infos) addInstDFuns :: InstEnv -> [DFunId] -> NF_TcM InstEnv addInstDFuns dfuns infos = getDOptsTc `thenTc` \ dflags -> - extendInstEnv dflags dfuns infos `bind` \ (inst_env', errs) -> + let + (inst_env', errs) = extendInstEnv dflags dfuns infos + in + traceTc (text "addInstDFuns" <+> vcat errs) `thenNF_Tc_` addErrsTc errs `thenNF_Tc_` returnTc inst_env' - where - bind x f = f x \end{code} \begin{code} -- 1.7.10.4