Commit a3bab050 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Fix recursive superclasses (again). Fixes Trac #4809.

This patch finally deals with the super-delicate question of
superclases in possibly-recursive dictionaries.  The key idea
is the DFun Superclass Invariant (see TcInstDcls):

     In the body of a DFun, every superclass argument to the
     returned dictionary is
       either   * one of the arguments of the DFun,
       or       * constant, bound at top level

To establish the invariant, we add new "silent" superclass
argument(s) to each dfun, so that the dfun does not do superclass
selection internally.  There's a bit of hoo-ha to make sure that
we don't print those silent arguments in error messages; a knock
on effect was a change in interface-file format.

A second change is that instead of the complex and fragile
"self dictionary binding" in TcInstDcls and TcClassDcl,
using the same mechanism for existential pattern bindings.
See Note [Subtle interaction of recursion and overlap] in TcInstDcls
and Note [Binding when looking up instances] in InstEnv.

Main notes are here:

  * Note [Silent Superclass Arguments] in TcInstDcls,
    including the DFun Superclass Invariant

Main code changes are:

  * The code for MkId.mkDictFunId and mkDictFunTy

  * DFunUnfoldings get a little more complicated;
    their arguments are a new type DFunArg (in CoreSyn)

  * No "self" argument in tcInstanceMethod
  * No special tcSimplifySuperClasss
  * No "dependents" argument to EvDFunApp

IMPORTANT
   It turns out that it's quite tricky to generate the right
   DFunUnfolding for a specialised dfun, when you use SPECIALISE
   INSTANCE.  For now I've just commented it out (in DsBinds) but
   that'll lose some optimisation, and I need to get back to
   this.
parent 62f76a3c
......@@ -49,7 +49,7 @@ module Id (
isImplicitId, isDeadBinder, isDictId, isStrictId,
isExportedId, isLocalId, isGlobalId,
isRecordSelector, isNaughtyRecordSelector,
isClassOpId_maybe, isDFunId,
isClassOpId_maybe, isDFunId, dfunNSilent,
isPrimOpId, isPrimOpId_maybe,
isFCallId, isFCallId_maybe,
isDataConWorkId, isDataConWorkId_maybe, isDataConId_maybe, idDataCon,
......@@ -332,8 +332,13 @@ isPrimOpId id = case Var.idDetails id of
_ -> False
isDFunId id = case Var.idDetails id of
DFunId _ -> True
_ -> False
DFunId {} -> True
_ -> False
dfunNSilent :: Id -> Int
dfunNSilent id = case Var.idDetails id of
DFunId ns _ -> ns
_ -> pprTrace "dfunSilent: not a dfun:" (ppr id) 0
isPrimOpId_maybe id = case Var.idDetails id of
PrimOpId op -> Just op
......
......@@ -128,11 +128,17 @@ data IdDetails
| TickBoxOpId TickBoxOp -- ^ The 'Id' is for a HPC tick box (both traditional and binary)
| DFunId Bool -- ^ A dictionary function.
-- True <=> the class has only one method, so may be
-- implemented with a newtype, so it might be bad
-- to be strict on this dictionary
| DFunId Int Bool -- ^ A dictionary function.
-- Int = the number of "silent" arguments to the dfun
-- e.g. class D a => C a where ...
-- instance C a => C [a]
-- has is_silent = 1, because the dfun
-- has type dfun :: (D a, C a) => C [a]
-- See the DFun Superclass Invariant in TcInstDcls
--
-- Bool = True <=> the class has only one method, so may be
-- implemented with a newtype, so it might be bad
-- to be strict on this dictionary
instance Outputable IdDetails where
ppr = pprIdDetails
......@@ -148,8 +154,9 @@ pprIdDetails other = brackets (pp other)
pp (PrimOpId _) = ptext (sLit "PrimOp")
pp (FCallId _) = ptext (sLit "ForeignCall")
pp (TickBoxOpId _) = ptext (sLit "TickBoxOp")
pp (DFunId b) = ptext (sLit "DFunId") <>
ppWhen b (ptext (sLit "(newtype)"))
pp (DFunId ns nt) = ptext (sLit "DFunId")
<> ppWhen (ns /= 0) (brackets (int ns))
<> ppWhen nt (ptext (sLit "(nt)"))
pp (RecSelId { sel_naughty = is_naughty })
= brackets $ ptext (sLit "RecSel")
<> ppWhen is_naughty (ptext (sLit "(naughty)"))
......
......@@ -13,8 +13,7 @@ have a standard form, namely:
\begin{code}
module MkId (
mkDictFunId, mkDefaultMethodId,
mkDictSelId,
mkDictFunId, mkDictFunTy, mkDefaultMethodId, mkDictSelId,
mkDataConIds,
mkPrimOpId, mkFCallId, mkTickBoxOpId, mkBreakPointOpId,
......@@ -492,15 +491,11 @@ mkDictSelId no_unf name clas
dictSelRule :: Int -> Arity -> Arity
-> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
-- Oh, very clever
-- sel_i t1..tk (df s1..sn d1..dm) = op_i_helper s1..sn d1..dm
-- Tries to persuade the argument to look like a constructor
-- application, using exprIsConApp_maybe, and then selects
-- from it
-- sel_i t1..tk (D t1..tk op1 ... opm) = opi
--
-- NB: the data constructor has the same number of type and
-- coercion args as the selector
--
-- This only works for *value* superclasses
-- There are no selector functions for equality superclasses
dictSelRule val_index n_ty_args n_eq_args id_unf args
| (dict_arg : _) <- drop n_ty_args args
, Just (_, _, con_args) <- exprIsConApp_maybe id_unf dict_arg
......@@ -839,12 +834,29 @@ mkDictFunId :: Name -- Name to use for the dict fun;
-> Class
-> [Type]
-> Id
-- Implements the DFun Superclass Invariant (see TcInstDcls)
mkDictFunId dfun_name inst_tyvars dfun_theta clas inst_tys
= mkExportedLocalVar (DFunId is_nt) dfun_name dfun_ty vanillaIdInfo
mkDictFunId dfun_name tvs theta clas tys
= mkExportedLocalVar (DFunId n_silent is_nt)
dfun_name
dfun_ty
vanillaIdInfo
where
is_nt = isNewTyCon (classTyCon clas)
dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
(n_silent, dfun_ty) = mkDictFunTy tvs theta clas tys
mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> (Int, Type)
mkDictFunTy tvs theta clas tys
= (length silent_theta, dfun_ty)
where
dfun_ty = mkSigmaTy tvs (silent_theta ++ theta) (mkDictTy clas tys)
silent_theta = filterOut discard $
substTheta (zipTopTvSubst (classTyVars clas) tys)
(classSCTheta clas)
-- See Note [Silent Superclass Arguments]
discard pred = isEmptyVarSet (tyVarsOfPred pred)
|| any (`tcEqPred` pred) theta
-- See the DFun Superclass Invariant in TcInstDcls
\end{code}
......
......@@ -432,7 +432,7 @@ idUnfoldingVars id = stableUnfoldingVars (realIdUnfolding id)
stableUnfoldingVars :: Unfolding -> VarSet
stableUnfoldingVars (CoreUnfolding { uf_tmpl = rhs, uf_src = src })
| isStableSource src = exprFreeVars rhs
stableUnfoldingVars (DFunUnfolding _ _ args) = exprsFreeVars args
stableUnfoldingVars (DFunUnfolding _ _ args) = exprsFreeVars (dfunArgExprs args)
stableUnfoldingVars _ = emptyVarSet
\end{code}
......
......@@ -574,7 +574,9 @@ substUnfoldingSC subst unf -- Short-cut version
| otherwise = substUnfolding subst unf
substUnfolding subst (DFunUnfolding ar con args)
= DFunUnfolding ar con (map (substExpr (text "dfun-unf") subst) args)
= DFunUnfolding ar con (map subst_arg args)
where
subst_arg = fmap (substExpr (text "dfun-unf") subst)
substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src })
-- Retain an InlineRule!
......
......@@ -4,7 +4,7 @@
%
\begin{code}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveDataTypeable, DeriveFunctor #-}
-- | CoreSyn holds all the main data types for use by for the Glasgow Haskell Compiler midsection
module CoreSyn (
......@@ -37,9 +37,9 @@ module CoreSyn (
notSccNote,
-- * Unfolding data types
Unfolding(..), UnfoldingGuidance(..), UnfoldingSource(..),
-- Abstract everywhere but in CoreUnfold.lhs
Unfolding(..), UnfoldingGuidance(..), UnfoldingSource(..),
DFunArg(..), dfunArgExprs,
-- ** Constructing 'Unfolding's
noUnfolding, evaldUnfolding, mkOtherCon,
unSaturatedOk, needSaturated, boringCxtOk, boringCxtNotOk,
......@@ -437,10 +437,7 @@ data Unfolding
DataCon -- The dictionary data constructor (possibly a newtype datacon)
[CoreExpr] -- The [CoreExpr] are the superclasses and methods [op1,op2],
-- in positional order.
-- They are usually variables, but can be trivial expressions
-- instead (e.g. a type application).
[DFunArg CoreExpr] -- Specification of superclasses and methods, in positional order
| CoreUnfolding { -- An unfolding for an Id with no pragma,
-- or perhaps a NOINLINE pragma
......@@ -478,7 +475,24 @@ data Unfolding
-- uf_guidance: Tells us about the /size/ of the unfolding template
------------------------------------------------
data UnfoldingSource
data DFunArg e -- Given (df a b d1 d2 d3)
= DFunPolyArg e -- Arg is (e a b d1 d2 d3)
| DFunConstArg e -- Arg is e, which is constant
| DFunLamArg Int -- Arg is one of [a,b,d1,d2,d3], zero indexed
deriving( Functor )
-- 'e' is often CoreExpr, which are usually variables, but can
-- be trivial expressions instead (e.g. a type application).
dfunArgExprs :: [DFunArg e] -> [e]
dfunArgExprs [] = []
dfunArgExprs (DFunPolyArg e : as) = e : dfunArgExprs as
dfunArgExprs (DFunConstArg e : as) = e : dfunArgExprs as
dfunArgExprs (DFunLamArg {} : as) = dfunArgExprs as
------------------------------------------------
data UnfoldingSource
= InlineRhs -- The current rhs of the function
-- Replace uf_tmpl each time around
......
......@@ -197,7 +197,7 @@ tidyIdBndr env@(tidy_env, var_env) id
------------ Unfolding --------------
tidyUnfolding :: TidyEnv -> Unfolding -> Unfolding -> Unfolding
tidyUnfolding tidy_env (DFunUnfolding ar con ids) _
= DFunUnfolding ar con (map (tidyExpr tidy_env) ids)
= DFunUnfolding ar con (map (fmap (tidyExpr tidy_env)) ids)
tidyUnfolding tidy_env
unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src })
unf_from_rhs
......
......@@ -91,7 +91,7 @@ mkImplicitUnfolding expr = mkTopUnfolding False (simpleOptExpr expr)
mkSimpleUnfolding :: CoreExpr -> Unfolding
mkSimpleUnfolding = mkUnfolding InlineRhs False False
mkDFunUnfolding :: Type -> [CoreExpr] -> Unfolding
mkDFunUnfolding :: Type -> [DFunArg CoreExpr] -> Unfolding
mkDFunUnfolding dfun_ty ops
= DFunUnfolding dfun_nargs data_con ops
where
......@@ -1270,9 +1270,11 @@ exprIsConApp_maybe id_unf expr
in if sat then True else
pprTrace "Unsaturated dfun" (ppr fun <+> int dfun_nargs $$ ppr args) False
, let (dfun_tvs, _cls, dfun_res_tys) = tcSplitDFunTy (idType fun)
subst = zipOpenTvSubst dfun_tvs (stripTypeArgs (takeList dfun_tvs args))
= Just (con, substTys subst dfun_res_tys,
[mkApps op args | op <- ops])
subst = zipOpenTvSubst dfun_tvs (stripTypeArgs (takeList dfun_tvs args))
mk_arg (DFunConstArg e) = e
mk_arg (DFunLamArg i) = args !! i
mk_arg (DFunPolyArg e) = mkApps e args
= Just (con, substTys subst dfun_res_tys, map mk_arg ops)
-- Look through unfoldings, but only cheap ones, because
-- we are effectively duplicating the unfolding
......
......@@ -692,7 +692,7 @@ exprOkForSpeculation other_expr
-- A bit conservative: we don't really need
-- to care about lazy arguments, but this is easy
spec_ok (DFunId new_type) _ = not new_type
spec_ok (DFunId _ new_type) _ = not new_type
-- DFuns terminate, unless the dict is implemented with a newtype
-- in which case they may not
......
......@@ -415,8 +415,7 @@ instance Outputable Unfolding where
ppr NoUnfolding = ptext (sLit "No unfolding")
ppr (OtherCon cs) = ptext (sLit "OtherCon") <+> ppr cs
ppr (DFunUnfolding ar con ops) = ptext (sLit "DFun") <> parens (ptext (sLit "arity=") <> int ar)
<+> ppr con
<+> brackets (pprWithCommas pprParendExpr ops)
<+> ppr con <+> brackets (pprWithCommas ppr ops)
ppr (CoreUnfolding { uf_src = src
, uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf
, uf_is_conlike=conlike, uf_is_cheap=cheap
......@@ -437,6 +436,11 @@ instance Outputable Unfolding where
| otherwise = empty
-- Don't print the RHS or we get a quadratic
-- blowup in the size of the printout!
instance Outputable e => Outputable (DFunArg e) where
ppr (DFunPolyArg e) = braces (ppr e)
ppr (DFunConstArg e) = ppr e
ppr (DFunLamArg i) = char '<' <> int i <> char '>'
\end{code}
-----------------------------------------------------
......
......@@ -11,7 +11,7 @@ lower levels it is preserved with @let@/@letrec@s).
\begin{code}
module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
dsHsWrapper, dsTcEvBinds, dsEvBinds, wrapDsEvBinds,
dsHsWrapper, dsTcEvBinds, dsEvBinds, wrapDsEvBinds,
DsEvBind(..), AutoScc(..)
) where
......@@ -90,7 +90,7 @@ dsLHsBind auto_scc (L loc bind)
dsHsBind :: AutoScc -> HsBind Id -> DsM (OrdList (Id,CoreExpr))
dsHsBind _ (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless })
= do { core_expr <- dsLExpr expr
= do { core_expr <- dsLExpr expr
-- Dictionary bindings are always VarBinds,
-- so we only need do this here
......@@ -230,11 +230,11 @@ dsEvBinds bs = return (map dsEvGroup sccs)
mk_node b@(EvBind var term) = (b, var, free_vars_of term)
free_vars_of :: EvTerm -> [EvVar]
free_vars_of (EvId v) = [v]
free_vars_of (EvCast v co) = v : varSetElems (tyVarsOfType co)
free_vars_of (EvCoercion co) = varSetElems (tyVarsOfType co)
free_vars_of (EvDFunApp _ _ vs _) = vs
free_vars_of (EvSuperClass d _) = [d]
free_vars_of (EvId v) = [v]
free_vars_of (EvCast v co) = v : varSetElems (tyVarsOfType co)
free_vars_of (EvCoercion co) = varSetElems (tyVarsOfType co)
free_vars_of (EvDFunApp _ _ vs) = vs
free_vars_of (EvSuperClass d _) = [d]
dsEvGroup :: SCC EvBind -> DsEvBind
dsEvGroup (AcyclicSCC (EvBind co_var (EvSuperClass dict n)))
......@@ -261,10 +261,10 @@ dsEvGroup (CyclicSCC bs)
ds_pair (EvBind v r) = (v, dsEvTerm r)
dsEvTerm :: EvTerm -> CoreExpr
dsEvTerm (EvId v) = Var v
dsEvTerm (EvCast v co) = Cast (Var v) co
dsEvTerm (EvDFunApp df tys vars _deps) = Var df `mkTyApps` tys `mkVarApps` vars
dsEvTerm (EvCoercion co) = Type co
dsEvTerm (EvId v) = Var v
dsEvTerm (EvCast v co) = Cast (Var v) co
dsEvTerm (EvDFunApp df tys vars) = Var df `mkTyApps` tys `mkVarApps` vars
dsEvTerm (EvCoercion co) = Type co
dsEvTerm (EvSuperClass d n)
= ASSERT( isClassPred (classSCTheta cls !! n) )
-- We can only select *dictionary* superclasses
......@@ -537,31 +537,17 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
specUnfolding :: (CoreExpr -> CoreExpr) -> Type
-> Unfolding -> DsM (Unfolding, OrdList (Id,CoreExpr))
{- [Dec 10: TEMPORARILY commented out, until we can straighten out how to
generate unfoldings for specialised DFuns
specUnfolding wrap_fn spec_ty (DFunUnfolding _ _ ops)
= do { let spec_rhss = map wrap_fn ops
; spec_ids <- mapM (mkSysLocalM (fsLit "spec") . exprType) spec_rhss
; return (mkDFunUnfolding spec_ty (map Var spec_ids), toOL (spec_ids `zip` spec_rhss)) }
-}
specUnfolding _ _ _
= return (noUnfolding, nilOL)
{-
mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> TyVarEnv Type
-- If any of the tyvars is missing from any of the lists in
-- the second arg, return a binding in the result
mkArbitraryTypeEnv tyvars exports
= go emptyVarEnv exports
where
go env [] = env
go env ((ltvs, _, _, _) : exports)
= go env' exports
where
env' = foldl extend env [tv | tv <- tyvars
, not (tv `elem` ltvs)
, not (tv `elemVarEnv` env)]
extend env tv = extendVarEnv env tv (dsMkArbitraryType tv)
-}
dsMkArbitraryType :: TcTyVar -> Type
dsMkArbitraryType tv = anyTypeOfKind (tyVarKind tv)
\end{code}
......
......@@ -449,9 +449,6 @@ data EvTerm
| EvDFunApp DFunId -- Dictionary instance application
[Type] [EvVar]
[EvVar] -- The dependencies, which is generally a bigger list than
-- the arguments of the dfun.
-- See Note [Dependencies in self dictionaries] in TcSimplify
| EvSuperClass DictId Int -- n'th superclass. Used for both equalities and
-- dictionaries, even though the former have no
......@@ -578,7 +575,7 @@ instance Outputable EvTerm where
ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendType co
ppr (EvCoercion co) = ppr co
ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n))
ppr (EvDFunApp df tys ts deps) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts, ppr deps ]
ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ]
\end{code}
%************************************************************************
......
......@@ -12,9 +12,13 @@ data HsSplice i
data MatchGroup a
data GRHSs a
instance Typeable1 HsSplice
instance Data i => Data (HsSplice i)
instance Typeable1 HsExpr
instance Data i => Data (HsExpr i)
instance Typeable1 MatchGroup
instance Data i => Data (MatchGroup i)
instance Typeable1 GRHSs
instance Data i => Data (GRHSs i)
type LHsExpr a = Located (HsExpr a)
......
......@@ -7,5 +7,6 @@ import Data.Data
data Pat i
type LPat i = Located (Pat i)
instance Typeable1 Pat
instance Data i => Data (Pat i)
\end{code}
......@@ -19,6 +19,7 @@ import HscTypes
import BasicTypes
import Demand
import Annotations
import CoreSyn
import IfaceSyn
import Module
import Name
......@@ -1145,7 +1146,7 @@ instance Binary IfaceBinding where
instance Binary IfaceIdDetails where
put_ bh IfVanillaId = putByte bh 0
put_ bh (IfRecSelId a b) = do { putByte bh 1; put_ bh a; put_ bh b }
put_ bh IfDFunId = putByte bh 2
put_ bh (IfDFunId n) = do { putByte bh 2; put_ bh n }
get bh = do
h <- getByte bh
case h of
......@@ -1153,7 +1154,7 @@ instance Binary IfaceIdDetails where
1 -> do a <- get bh
b <- get bh
return (IfRecSelId a b)
_ -> return IfDFunId
_ -> do { n <- get bh; return (IfDFunId n) }
instance Binary IfaceIdInfo where
put_ bh NoInfo = putByte bh 0
......@@ -1245,6 +1246,16 @@ instance Binary IfaceUnfolding where
_ -> do e <- get bh
return (IfCompulsory e)
instance Binary (DFunArg IfaceExpr) where
put_ bh (DFunPolyArg e) = putByte bh 0 >> put_ bh e
put_ bh (DFunConstArg e) = putByte bh 1 >> put_ bh e
put_ bh (DFunLamArg i) = putByte bh 2 >> put_ bh i
get bh = do { h <- getByte bh
; case h of
0 -> do { a <- get bh; return (DFunPolyArg a) }
1 -> do { a <- get bh; return (DFunConstArg a) }
_ -> do { a <- get bh; return (DFunLamArg a) } }
instance Binary IfaceNote where
put_ bh (IfaceSCC aa) = do
putByte bh 0
......
......@@ -27,7 +27,8 @@ module IfaceSyn (
#include "HsVersions.h"
import IfaceType
import CoreSyn( DFunArg, dfunArgExprs )
import PprCore() -- Printing DFunArgs
import Demand
import Annotations
import Class
......@@ -183,7 +184,7 @@ type IfaceAnnTarget = AnnTarget OccName
data IfaceIdDetails
= IfVanillaId
| IfRecSelId IfaceTyCon Bool
| IfDFunId
| IfDFunId Int -- Number of silent args
data IfaceIdInfo
= NoInfo -- When writing interface file without -O
......@@ -226,7 +227,7 @@ data IfaceUnfolding
| IfLclWrapper Arity IfLclName -- because the worker can simplify to a function in
-- another module.
| IfDFunUnfold [IfaceExpr]
| IfDFunUnfold [DFunArg IfaceExpr]
--------------------------------
data IfaceExpr
......@@ -675,7 +676,7 @@ instance Outputable IfaceIdDetails where
ppr IfVanillaId = empty
ppr (IfRecSelId tc b) = ptext (sLit "RecSel") <+> ppr tc
<+> if b then ptext (sLit "<naughty>") else empty
ppr IfDFunId = ptext (sLit "DFunId")
ppr (IfDFunId ns) = ptext (sLit "DFunId") <> brackets (int ns)
instance Outputable IfaceIdInfo where
ppr NoInfo = empty
......@@ -699,8 +700,7 @@ instance Outputable IfaceUnfolding where
ppr (IfExtWrapper a wkr) = ptext (sLit "Worker(ext0:") <+> ppr wkr
<+> parens (ptext (sLit "arity") <+> int a)
ppr (IfDFunUnfold ns) = ptext (sLit "DFun:")
<+> brackets (pprWithCommas pprParendIfaceExpr ns)
<+> brackets (pprWithCommas ppr ns)
-- -----------------------------------------------------------------------------
-- Finding the Names in IfaceSyn
......@@ -822,7 +822,7 @@ freeNamesIfUnfold (IfCompulsory e) = freeNamesIfExpr e
freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e
freeNamesIfUnfold (IfExtWrapper _ v) = unitNameSet v
freeNamesIfUnfold (IfLclWrapper {}) = emptyNameSet
freeNamesIfUnfold (IfDFunUnfold vs) = fnList freeNamesIfExpr vs
freeNamesIfUnfold (IfDFunUnfold vs) = fnList freeNamesIfExpr (dfunArgExprs vs)
freeNamesIfExpr :: IfaceExpr -> NameSet
freeNamesIfExpr (IfaceExt v) = unitNameSet v
......@@ -858,7 +858,6 @@ freeNamesIfExpr (IfaceLet (IfaceRec as) x)
freeNamesIfExpr _ = emptyNameSet
freeNamesIfTc :: IfaceTyCon -> NameSet
freeNamesIfTc (IfaceTc tc) = unitNameSet tc
-- ToDo: shouldn't we include IfaceIntTc & co.?
......
......@@ -1471,7 +1471,7 @@ toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id))
--------------------------
toIfaceIdDetails :: IdDetails -> IfaceIdDetails
toIfaceIdDetails VanillaId = IfVanillaId
toIfaceIdDetails (DFunId {}) = IfDFunId
toIfaceIdDetails (DFunId ns _) = IfDFunId ns
toIfaceIdDetails (RecSelId { sel_naughty = n
, sel_tycon = tc }) = IfRecSelId (toIfaceTyCon tc) n
toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other)
......@@ -1536,7 +1536,7 @@ toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity
if_rhs = toIfaceExpr rhs
toIfUnfolding lb (DFunUnfolding _ar _con ops)
= Just (HsUnfold lb (IfDFunUnfold (map toIfaceExpr ops)))
= Just (HsUnfold lb (IfDFunUnfold (map (fmap toIfaceExpr) ops)))
-- No need to serialise the data constructor;
-- we can recover it from the type of the dfun
......
......@@ -986,8 +986,8 @@ do_one (IfaceRec pairs) thing_inside
\begin{code}
tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails
tcIdDetails _ IfVanillaId = return VanillaId
tcIdDetails ty IfDFunId
= return (DFunId (isNewTyCon (classTyCon cls)))
tcIdDetails ty (IfDFunId ns)
= return (DFunId ns (isNewTyCon (classTyCon cls)))
where
(_, cls, _) = tcSplitDFunTy ty
......@@ -1051,12 +1051,15 @@ tcUnfolding name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)
}
tcUnfolding name dfun_ty _ (IfDFunUnfold ops)
= do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops
= do { mb_ops1 <- forkM_maybe doc $ mapM tc_arg ops
; return (case mb_ops1 of
Nothing -> noUnfolding
Just ops1 -> mkDFunUnfolding dfun_ty ops1) }
where
doc = text "Class ops for dfun" <+> ppr name
tc_arg (DFunPolyArg e) = do { e' <- tcIfaceExpr e; return (DFunPolyArg e') }
tc_arg (DFunConstArg e) = do { e' <- tcIfaceExpr e; return (DFunConstArg e') }
tc_arg (DFunLamArg i) = return (DFunLamArg i)
tcUnfolding name ty info (IfExtWrapper arity wkr)
= tcIfaceWrapper name ty info arity (tcIfaceExtId wkr)
......
......@@ -712,7 +712,7 @@ addExternal expose_all id = (new_needed_ids, show_unfold)
CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src, uf_guidance = guide }
| show_unfolding src guide
-> Just (unf_ext_ids src unf_rhs)
DFunUnfolding _ _ ops -> Just (exprsFvsInOrder ops)
DFunUnfolding _ _ ops -> Just (exprsFvsInOrder (dfunArgExprs ops))
_ -> Nothing
where
unf_ext_ids (InlineWrapper v) _ = (unitVarSet v, [v])
......
......@@ -702,7 +702,7 @@ simplUnfolding :: SimplEnv-> TopLevelFlag
simplUnfolding env _ _ _ _ (DFunUnfolding ar con ops)
= return (DFunUnfolding ar con ops')
where
ops' = map (substExpr (text "simplUnfolding") env) ops
ops' = map (fmap (substExpr (text "simplUnfolding") env)) ops
simplUnfolding env top_lvl id _ _
(CoreUnfolding { uf_tmpl = expr, uf_arity = arity
......
......@@ -404,10 +404,18 @@ addLocalInst home_ie ispec
-- This is important because the template variables must
-- not overlap with anything in the things being looked up
-- (since we do unification).
-- We use tcInstSkolType because we don't want to allocate fresh
-- *meta* type variables.
--
-- We use tcInstSkolType because we don't want to allocate fresh
-- *meta* type variables.
--
-- We use UnkSkol --- and *not* InstSkol or PatSkol --- because
-- these variables must be bindable by tcUnifyTys. See
-- the call to tcUnifyTys in InstEnv, and the special
-- treatment that instanceBindFun gives to isOverlappableTyVar
-- This is absurdly delicate.
let dfun = instanceDFunId ispec
; (tvs', theta', tau') <- tcInstSkolType InstSkol (idType dfun)
; (tvs', theta', tau') <- tcInstSkolType UnkSkol (idType dfun)
; let (cls, tys') = tcSplitDFunHead tau'
dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
ispec' = setInstanceDFunId ispec dfun'
......
......@@ -229,45 +229,35 @@ tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn (sel_id, dm_info)
tcInstanceMethodBody (ClsSkol clas)
tyvars
[this_dict]
Nothing
dm_id_w_inline local_dm_id
dm_sig_fn IsDefaultMethod meth_bind }
---------------
tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar]
-> Maybe EvBind
-> Id -> Id
-> SigFun -> TcSpecPrags -> LHsBind Name
-> TcM (LHsBind Id)
tcInstanceMethodBody skol_info tyvars dfun_ev_vars
this_dict meth_id local_meth_id
meth_id local_meth_id
meth_sig_fn specs
(L loc bind)
= do { -- Typecheck the binding, first extending the envt
-- so that when tcInstSig looks up the local_meth_id to find
-- its signature, we'll find it in the environment
let full_given = case this_dict of
Nothing -> dfun_ev_vars
Just (EvBind dict _) -> dict : dfun_ev_vars
lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) })
-- Substitue the local_meth_name for the binder
let lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) })
-- Substitute the local_meth_name for the binder
-- NB: the binding is always a FunBind
; (ev_binds, (tc_bind, _))
<- checkConstraints skol_info tyvars full_given $
<- checkConstraints skol_info tyvars dfun_ev_vars $
tcExtendIdEnv [local_meth_id] $
tcPolyBinds TopLevel meth_sig_fn no_prag_fn
NonRecursive NonRecursive
[lm_bind]
-- Add the binding for this_dict, if we have one
; ev_binds' <- case this_dict of
Nothing -> return ev_binds
Just (EvBind self rhs) -> extendTcEvBinds ev_binds self rhs
; let full_bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
; let full_bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
, abs_exports = [(tyvars, meth_id, local_meth_id, specs)]
, abs_ev_binds = ev_binds'
, abs_ev_binds = ev_binds
, abs_binds = tc_bind }
; return (L loc full_bind) }
......@@ -538,7 +528,7 @@ mkGenericInstance clas (hs_ty, binds) = do
let
inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars]
dfun_id = mkDictFunId dfun_name tyvars inst_theta clas [inst_ty]
ispec = mkLocalInstance dfun_id overlap_flag
ispec = mkLocalInstance dfun_id overlap_flag
return (InstInfo { iSpec = ispec, iBinds = VanillaInst binds [] False })
\end{code}
......
......@@ -373,14 +373,14 @@ renameDeriv is_boot gen_binds insts
, mkFVs (map dataConName (tyConDataCons tc)))
-- See Note [Newtype deriving and unused constructors]
rn_inst_info (InstInfo { iSpec = inst, iBinds = VanillaInst binds sigs standalone_deriv })
rn_inst_info inst_info@(InstInfo { iSpec = inst, iBinds = VanillaInst binds sigs standalone_deriv })
= -- Bring the right type variables into
-- scope (yuk), and rename the method binds
ASSERT( null sigs )