summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ghc/compiler/basicTypes/Unique.lhs9
-rw-r--r--ghc/compiler/main/HscTypes.lhs5
-rw-r--r--ghc/compiler/prelude/TysWiredIn.lhs26
-rw-r--r--ghc/compiler/rename/Rename.lhs2
-rw-r--r--ghc/compiler/rename/RnIfaces.lhs8
-rw-r--r--ghc/compiler/typecheck/TcInstDcls.lhs16
6 files changed, 42 insertions, 24 deletions
diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs
index e8b4e38e25..feb4e8ed1c 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 c60c575216..49f12f293a 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 c63d3e193c..15f34514d2 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 41abf2ef51..23d53a6e59 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 d1e4174635..e62b780ea4 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 a8a3de04d9..a49220d33d 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}
View Lorry Controller Status