From 516d3138473d7b097cc572901bd02fce9509f1b8 Mon Sep 17 00:00:00 2001
From: Simon Peyton Jones <simonpj@microsoft.com>
Date: Wed, 28 Mar 2012 09:56:14 +0100
Subject: [PATCH] Add a crucial forkM on the superclass context of IfaceClass
in tcIfaceDecl
The absence of this was causing a loop when typechecking an interface
where the superclass context mentioned an associated type
class C (T a) => D a where
data T a
Fixes Trac #5970
---
compiler/iface/BuildTyCl.lhs | 7 +++----
compiler/iface/LoadIface.lhs | 2 +-
compiler/iface/TcIface.lhs | 36 +++++++++++++++++++++++-----------
compiler/typecheck/FamInst.lhs | 3 +++
4 files changed, 32 insertions(+), 16 deletions(-)
diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs
index 4a93a2bbe4f0..d41ee68d20d0 100644
--- a/compiler/iface/BuildTyCl.lhs
+++ b/compiler/iface/BuildTyCl.lhs
@@ -203,13 +203,13 @@ buildClass :: Bool -- True <=> do not include unfoldings
-> TcRnIf m n Class
buildClass no_unf tycon_name tvs sc_theta fds at_items sig_stuff tc_isrec
- = do { traceIf (text "buildClass")
+ = fixM $ \ rec_clas -> -- Only name generation inside loop
+ do { traceIf (text "buildClass")
; datacon_name <- newImplicitBinder tycon_name mkClassDataConOcc
-- The class name is the 'parent' for this datacon, not its tycon,
-- because one should import the class to get the binding for
-- the datacon
- ; fixM (\ rec_clas -> do { -- Only name generation inside loop
; op_items <- mapM (mk_op_item rec_clas) sig_stuff
-- Build the selector id and default method id
@@ -278,8 +278,7 @@ buildClass no_unf tycon_name tvs sc_theta fds at_items sig_stuff tc_isrec
op_items tycon
}
; traceIf (text "buildClass" <+> ppr tycon)
- ; return result
- })}
+ ; return result }
where
mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem
mk_op_item rec_clas (op_name, dm_spec, _)
diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs
index 107c24c94fff..e798b7c479f7 100644
--- a/compiler/iface/LoadIface.lhs
+++ b/compiler/iface/LoadIface.lhs
@@ -372,7 +372,6 @@ loadDecl ignore_prags mod (_version, decl)
-- the names associated with the decl
main_name <- lookupOrig mod (ifName decl)
-- ; traceIf (text "Loading decl for " <> ppr main_name)
- ; implicit_names <- mapM (lookupOrig mod) (ifaceDeclImplicitBndrs decl)
-- Typecheck the thing, lazily
-- NB. Firstly, the laziness is there in case we never need the
@@ -445,6 +444,7 @@ loadDecl ignore_prags mod (_version, decl)
Nothing ->
pprPanic "loadDecl" (ppr main_name <+> ppr n $$ ppr (decl))
+ ; implicit_names <- mapM (lookupOrig mod) (ifaceDeclImplicitBndrs decl)
; return $ (main_name, thing) :
-- uses the invariant that implicit_names and
-- implictTyThings are bijective
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index e0b0f1d2a85c..badb3c70aaba 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -480,27 +480,41 @@ tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
tc_iface_decl _parent ignore_prags
(IfaceClass {ifCtxt = rdr_ctxt, ifName = tc_occ,
- ifTyVars = tv_bndrs, ifFDs = rdr_fds,
+ ifTyVars = tv_bndrs, ifFDs = rdr_fds,
ifATs = rdr_ats, ifSigs = rdr_sigs,
ifRec = tc_isrec })
-- ToDo: in hs-boot files we should really treat abstract classes specially,
-- as we do abstract tycons
= bindIfaceTyVars tv_bndrs $ \ tyvars -> do
{ tc_name <- lookupIfaceTop tc_occ
- ; ctxt <- tcIfaceCtxt rdr_ctxt
+ ; traceIf (text "tc-iface-class1" <+> ppr tc_occ)
+ ; ctxt <- mapM tc_sc rdr_ctxt
+ ; traceIf (text "tc-iface-class2" <+> ppr tc_occ)
; sigs <- mapM tc_sig rdr_sigs
; fds <- mapM tc_fd rdr_fds
+ ; traceIf (text "tc-iface-class3" <+> ppr tc_occ)
; cls <- fixM $ \ cls -> do
{ ats <- mapM (tc_at cls) rdr_ats
+ ; traceIf (text "tc-iface-class4" <+> ppr tc_occ)
; buildClass ignore_prags tc_name tyvars ctxt fds ats sigs tc_isrec }
; return (ATyCon (classTyCon cls)) }
where
+ tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred)
+ -- The *length* of the superclasses is used by buildClass, and hence must
+ -- not be inside the thunk. But the *content* maybe recursive and hence
+ -- must be lazy (via forkM). Example:
+ -- class C (T a) => D a where
+ -- data T a
+ -- Here the associated type T is knot-tied with the class, and
+ -- so we must not pull on T too eagerly. See Trac #5970
+ mk_sc_doc pred = ptext (sLit "Superclass") <+> ppr pred
+
tc_sig (IfaceClassOp occ dm rdr_ty)
= do { op_name <- lookupIfaceTop occ
- ; op_ty <- forkM (mk_doc op_name rdr_ty) (tcIfaceType rdr_ty)
+ ; op_ty <- forkM (mk_op_doc op_name rdr_ty) (tcIfaceType rdr_ty)
-- Must be done lazily for just the same reason as the
-- type of a data con; to avoid sucking in types that
- -- it mentions unless it's necessray to do so
+ -- it mentions unless it's necessary to do so
; return (op_name, dm, op_ty) }
tc_at cls (IfaceAT tc_decl defs_decls)
@@ -513,7 +527,7 @@ tc_iface_decl _parent ignore_prags
\tvs' -> liftM2 (\pats tys -> ATD tvs' pats tys noSrcSpan)
(mapM tcIfaceType pat_tys) (tcIfaceType ty)
- mk_doc op_name op_ty = ptext (sLit "Class op") <+> sep [ppr op_name, ppr op_ty]
+ mk_op_doc op_name op_ty = ptext (sLit "Class op") <+> sep [ppr op_name, ppr op_ty]
tc_fd (tvs1, tvs2) = do { tvs1' <- mapM tcIfaceTyVar tvs1
; tvs2' <- mapM tcIfaceTyVar tvs2
@@ -619,8 +633,8 @@ look at it.
\begin{code}
tcIfaceInst :: IfaceClsInst -> IfL ClsInst
-tcIfaceInst (IfaceClsInst { ifDFun = dfun_occ, ifOFlag = oflag,
- ifInstCls = cls, ifInstTys = mb_tcs })
+tcIfaceInst (IfaceClsInst { ifDFun = dfun_occ, ifOFlag = oflag
+ , ifInstCls = cls, ifInstTys = mb_tcs })
= do { dfun <- forkM (ptext (sLit "Dict fun") <+> ppr dfun_occ) $
tcIfaceExtId dfun_occ
; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
@@ -629,10 +643,10 @@ tcIfaceInst (IfaceClsInst { ifDFun = dfun_occ, ifOFlag = oflag,
tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs
, ifFamInstAxiom = axiom_name } )
- = do axiom' <- forkM (ptext (sLit "Axiom") <+> ppr axiom_name) $
- tcIfaceCoAxiom axiom_name
- let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
- return (mkImportedFamInst fam mb_tcs' axiom')
+ = do { axiom' <- forkM (ptext (sLit "Axiom") <+> ppr axiom_name) $
+ tcIfaceCoAxiom axiom_name
+ ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
+ ; return (mkImportedFamInst fam mb_tcs' axiom') }
\end{code}
diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs
index 1e24a530aa3f..e3f646c26430 100644
--- a/compiler/typecheck/FamInst.lhs
+++ b/compiler/typecheck/FamInst.lhs
@@ -84,6 +84,9 @@ instance Eq ModulePair where
instance Ord ModulePair where
mp1 `compare` mp2 = canon mp1 `compare` canon mp2
+instance Outputable ModulePair where
+ ppr (ModulePair m1 m2) = angleBrackets (ppr m1 <> comma <+> ppr m2)
+
-- Sets of module pairs
--
type ModulePairSet = Map ModulePair ()
--
GitLab