Commit c4f3290f authored by simonpj's avatar simonpj
Browse files

[project @ 1998-04-08 16:48:14 by simonpj]

Specialisation works at last
parent d488074e
......@@ -268,7 +268,8 @@ ifaceId get_idinfo needed_ids is_rec id rhs
prag_pretty
| opt_OmitInterfacePragmas = empty
| otherwise = hsep [arity_pretty, strict_pretty, unfold_pretty, spec_pretty, pp_double_semi]
| otherwise = hsep [arity_pretty, strict_pretty, unfold_pretty,
spec_pretty, pp_double_semi]
------------ Arity --------------
arity_pretty = ppArityInfo (arityInfo idinfo)
......@@ -313,15 +314,16 @@ ifaceId get_idinfo needed_ids is_rec id rhs
guidance = calcUnfoldingGuidance opt_InterfaceUnfoldThreshold rhs
------------ Specialisations --------------
spec_pretty = hsep (map pp_spec (specEnvToList (getIdSpecialisation id)))
spec_list = specEnvToList (getIdSpecialisation id)
spec_pretty = hsep (map pp_spec spec_list)
pp_spec (tyvars, tys, rhs) = hsep [ptext SLIT("_P_"),
if null tyvars then ptext SLIT("[ ]")
else brackets (interpp'SP tyvars),
else brackets (interppSP tyvars),
-- The lexer interprets "[]" as a CONID. Sigh.
hsep (map pprParendType tys),
ptext SLIT("="),
pprIfaceUnfolding rhs
]
]
------------ Extra free Ids --------------
new_needed_ids = (needed_ids `minusIdSet` unitIdSet id) `unionIdSets`
......@@ -329,18 +331,25 @@ ifaceId get_idinfo needed_ids is_rec id rhs
extra_ids | opt_OmitInterfacePragmas = emptyIdSet
| otherwise = worker_ids `unionIdSets`
unfold_ids
unfold_ids `unionIdSets`
spec_ids
worker_ids | has_worker = unitIdSet work_id
| otherwise = emptyIdSet
unfold_ids | show_unfold = free_vars
spec_ids = foldr add emptyIdSet spec_list
where
add (_, _, rhs) = unionIdSets (find_fvs rhs)
unfold_ids | show_unfold = find_fvs rhs
| otherwise = emptyIdSet
where
(_,free_vars) = addExprFVs interesting emptyIdSet rhs
interesting bound id = isLocallyDefined id &&
not (id `elementOfIdSet` bound) &&
not (omitIfaceSigForId id)
find_fvs expr = free_vars
where
(_,free_vars) = addExprFVs interesting emptyIdSet expr
interesting bound id = isLocallyDefined id &&
not (id `elementOfIdSet` bound) &&
not (omitIfaceSigForId id)
\end{code}
\begin{code}
......
......@@ -556,6 +556,14 @@ rnIdInfo (HsArity arity) = returnRn (HsArity arity)
rnIdInfo (HsUpdate update) = returnRn (HsUpdate update)
rnIdInfo (HsFBType fb) = returnRn (HsFBType fb)
rnIdInfo (HsArgUsage au) = returnRn (HsArgUsage au)
rnIdInfo (HsSpecialise tyvars tys expr)
= bindTyVarsRn doc tyvars $ \ tyvars' ->
rnCoreExpr expr `thenRn` \ expr' ->
mapRn rnHsType tys `thenRn` \ tys' ->
returnRn (HsSpecialise tyvars' tys' expr')
where
doc = text "Specialise in interface pragma"
rnStrict (HsStrictnessInfo demands (Just (worker,cons)))
-- The sole purpose of the "cons" field is so that we can mark the constructors
......
......@@ -159,6 +159,11 @@ occAnalTop :: OccEnv -- What's in scope
occAnalTop env [] = (emptyDetails, nullIdEnv, [])
-- Special case for eliminating indirections
-- Note: it's a shortcoming that this only works for
-- non-recursive bindings. Elminating indirections
-- makes perfect sense for recursive bindings too, but
-- it's more complicated to implement, so I haven't done so
occAnalTop env (NonRec exported_id (Var local_id) : binds)
| isExported exported_id && -- Only if this is exported
......
......@@ -130,7 +130,7 @@ completeVar env inline_call var args result_ty
---------- Specialisation stuff
(ty_args, remaining_args) = initialTyArgs args
maybe_specialisation = lookupSpecEnv (getIdSpecialisation var) ty_args
maybe_specialisation = lookupSpecEnv (ppr var) (getIdSpecialisation var) ty_args
Just (spec_bindings, spec_template) = maybe_specialisation
......
......@@ -1092,6 +1092,15 @@ completeBind env binder@(_,occ_info) new_id new_rhs
in
(env2, [])
{- This case is WRONG. It attempts to exploit knowledge that indirections
are eliminated (by OccurAnal), but they *aren't* for recursive bindings.
If this case is enabled, then
rec { local = (a,b)
global = local
... = case global of ...
}
never gets simplified
| atomic_rhs -- Rhs is atomic, and new_id is exported
&& case eta'd_rhs of { Var v -> isLocallyDefined v && not (isExported v); other -> False }
= -- The local variable v will be eliminated next time round
......@@ -1099,6 +1108,7 @@ completeBind env binder@(_,occ_info) new_id new_rhs
-- this time round.
-- This case is an optional improvement; saves a simplifier iteration
(env, [(new_id, eta'd_rhs)])
-}
| otherwise -- Non-atomic
= let
......
......@@ -16,6 +16,7 @@ module SpecEnv (
import Type ( Type, GenType, mkTyVarTy, matchTys, tyVarsOfTypes, applyToTyVars )
import TyVar ( TyVar, GenTyVar, TyVarEnv, tyVarFlexi, setTyVarFlexi, lookupTyVarEnv, tyVarSetToList )
import Unify ( Subst, unifyTyListsX )
import Outputable
import Maybes
import Util ( assertPanic )
\end{code}
......@@ -84,17 +85,25 @@ The thing we are looking up can have an
arbitrary "flexi" part.
\begin{code}
lookupSpecEnv :: SpecEnv value -- The envt
lookupSpecEnv :: SDoc -- For error report
-> SpecEnv value -- The envt
-> [GenType flexi] -- Key
-> Maybe (TyVarEnv (GenType flexi), value)
lookupSpecEnv EmptySE key = Nothing
lookupSpecEnv (SpecEnv alist) key
lookupSpecEnv doc EmptySE key = Nothing
lookupSpecEnv doc (SpecEnv alist) key
= find alist
where
find [] = Nothing
find ((tpl, val) : rest)
= case matchTys tpl key of
=
#ifdef DEBUG
if length tpl > length key then
pprTrace "lookupSpecEnv" (doc <+> ppr tpl <+> ppr key) $
Nothing
else
#endif
case matchTys tpl key of
Nothing -> find rest
Just (subst, leftovers) -> ASSERT( null leftovers )
Just (subst, val)
......
......@@ -26,20 +26,23 @@ import Type ( Type, mkTyVarTy, splitSigmaTy, instantiateTy, isDictTy,
tyVarsOfType, tyVarsOfTypes, applyTys, mkForAllTys
)
import TyCon ( TyCon )
import TyVar ( TyVar, alphaTyVars,
import TyVar ( TyVar, mkTyVar,
TyVarSet, mkTyVarSet, isEmptyTyVarSet, intersectTyVarSets,
elementOfTyVarSet, unionTyVarSets, emptyTyVarSet,
minusTyVarSet,
TyVarEnv, mkTyVarEnv, delFromTyVarEnv
)
import Kind ( mkBoxedTypeKind )
import CoreSyn
import PprCore () -- Instances
import Name ( NamedThing(..), getSrcLoc )
import Name ( NamedThing(..), getSrcLoc, mkSysLocalName )
import SrcLoc ( noSrcLoc )
import SpecEnv ( addToSpecEnv, lookupSpecEnv, specEnvValues )
import UniqSupply ( UniqSupply,
UniqSM, initUs, thenUs, returnUs, getUnique, mapUs
)
import Unique ( mkAlphaTyVarUnique )
import FiniteMap
import Maybes ( MaybeErr(..), maybeToBool )
import Bag
......@@ -725,7 +728,7 @@ specBind (NonRec bndr rhs) body_uds
new_bind | null spec_defns = NonRec bndr' rhs'
| otherwise = Rec ((bndr',rhs'):spec_defns)
in
returnSM ( new_bind : dict_binds, all_uds )
returnSM ( new_bind : mkDictBinds dict_binds, all_uds )
specBind (Rec pairs) body_uds
= mapSM (specDefn (calls body_uds)) pairs `thenSM` \ stuff ->
......@@ -737,7 +740,7 @@ specBind (Rec pairs) body_uds
= splitUDs (map (ValBinder . fst) pairs) (spec_uds `plusUDs` body_uds)
new_bind = Rec (spec_defns ++ pairs')
in
returnSM ( new_bind : dict_binds, all_uds )
returnSM ( new_bind : mkDictBinds dict_binds, all_uds )
specDefn :: CallDetails -- Info on how it is used in its scope
-> (Id, CoreExpr) -- The thing being bound and its un-processed RHS
......@@ -764,7 +767,7 @@ specDefn calls (fn, rhs)
(spec_defns, spec_uds, spec_env_stuff) = unzip3 stuff
fn' = addIdSpecialisations fn spec_env_stuff
rhs' = foldr Lam (foldr Let body' dict_binds) rhs_bndrs
rhs' = foldr Lam (mkDictLets dict_binds body') rhs_bndrs
in
returnSM ((fn',rhs'),
spec_defns,
......@@ -779,7 +782,7 @@ specDefn calls (fn, rhs)
(tyvars, theta, tau) = splitSigmaTy fn_type
n_tyvars = length tyvars
n_dicts = length theta
mk_spec_tys call_ts = zipWith mk_spec_ty call_ts alphaTyVars
mk_spec_tys call_ts = zipWith mk_spec_ty call_ts tyVarTemplates
where
mk_spec_ty (Just ty) _ = ty
mk_spec_ty Nothing tyvar = mkTyVarTy tyvar
......@@ -812,7 +815,7 @@ specDefn calls (fn, rhs)
-- f1 = /\ b d -> (..rhs of f..) t1 b t3 d d1 d2
-- and the type of this binder
let
spec_tyvars = [tyvar | (tyvar, Nothing) <- alphaTyVars `zip` call_ts]
spec_tyvars = [tyvar | (tyvar, Nothing) <- tyVarTemplates `zip` call_ts]
spec_tys = mk_spec_tys call_ts
spec_rhs = mkTyLam spec_tyvars $
mkGenApp rhs (map TyArg spec_tys ++ map VarArg call_ds)
......@@ -867,7 +870,7 @@ type FreeDicts = IdSet
data UsageDetails
= MkUD {
dict_binds :: !(Bag (DictVar, CoreExpr, TyVarSet, FreeDicts)),
dict_binds :: !(Bag DictBind),
-- Floated dictionary bindings
-- The order is important;
-- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1
......@@ -877,9 +880,11 @@ data UsageDetails
calls :: !CallDetails
}
type DictBind = (DictVar, CoreExpr, TyVarSet, FreeDicts)
emptyUDs = MkUD { dict_binds = emptyBag, calls = emptyFM }
type ProtoUsageDetails = ([CoreBinding], -- Dict bindings
type ProtoUsageDetails = ([DictBind],
[(Id, [Maybe Type], [DictVar])]
)
......@@ -950,11 +955,19 @@ dumpAllDictBinds (MkUD {dict_binds = dbs}) binds
where
add (dict,rhs,_,_) binds = NonRec dict rhs : binds
mkDictBinds :: [DictBind] -> [CoreBinding]
mkDictBinds = map (\(d,r,_,_) -> NonRec d r)
mkDictLets :: [DictBind] -> CoreExpr -> CoreExpr
mkDictLets dbs body = foldr mk body dbs
where
mk (d,r,_,_) e = Let (NonRec d r) e
dumpUDs :: [CoreBinder]
-> UsageDetails -> CoreExpr
-> (UsageDetails, CoreExpr)
dumpUDs bndrs uds body
= (free_uds, foldr Let body dict_binds)
= (free_uds, mkDictLets dict_binds body)
where
(free_uds, (dict_binds, _)) = splitUDs bndrs uds
......@@ -1000,7 +1013,7 @@ splitUDs bndrs uds@(MkUD {dict_binds = orig_dbs,
= (free_dbs `snocBag` db, dump_dbs, dump_idset)
| otherwise -- Dump it
= (free_dbs, dump_dbs `snocBag` NonRec dict rhs,
= (free_dbs, dump_dbs `snocBag` db,
dump_idset `addOneToIdSet` dict)
\end{code}
......@@ -1010,13 +1023,16 @@ the given UDs
\begin{code}
specUDs :: [(TyVar,Type)] -> [(DictVar,DictVar)] -> ProtoUsageDetails -> SpecM UsageDetails
specUDs tv_env_list dict_env_list (dbs, calls)
= specDBs dict_env dbs `thenSM` \ (dict_env', dbs') ->
= specDBs dict_env_list dbs `thenSM` \ (dict_env_list', dbs') ->
let
dict_env = mkIdEnv dict_env_list'
in
returnSM (MkUD { dict_binds = dbs',
calls = listToCallDetails (map (inst_call dict_env') calls)
calls = listToCallDetails (map (inst_call dict_env) calls)
})
where
tv_env = mkTyVarEnv tv_env_list
dict_env = mkIdEnv dict_env_list
bound_tyvars = mkTyVarSet (map fst tv_env_list)
tv_env = mkTyVarEnv tv_env_list -- Doesn't change
inst_call dict_env (id, tys, dicts) = (id, map inst_maybe_ty tys,
map (lookupId dict_env) dicts)
......@@ -1026,14 +1042,22 @@ specUDs tv_env_list dict_env_list (dbs, calls)
specDBs dict_env []
= returnSM (dict_env, emptyBag)
specDBs dict_env (NonRec dict rhs : dbs)
specDBs dict_env ((dict, rhs, ftvs, fvs) : dbs)
= newIdSM dict (instantiateTy tv_env (idType dict)) `thenSM` \ dict' ->
let
dict_env' = addOneToIdEnv dict_env dict dict'
rhs' = instantiateDictRhs tv_env dict_env rhs
rhs' = foldl App (foldr Lam rhs (t_bndrs ++ d_bndrs)) (t_args ++ d_args)
(t_bndrs, t_args) = unzip [(TyBinder tv, TyArg ty) | (tv,ty) <- tv_env_list,
tv `elementOfTyVarSet` ftvs]
(d_bndrs, d_args) = unzip [(ValBinder d, VarArg d') | (d,d') <- dict_env,
d `elementOfIdSet` fvs]
dict_env' = (dict,dict') : dict_env
ftvs' = tyVarsOfTypes [ty | TyArg ty <- t_args] `unionTyVarSets`
(ftvs `minusTyVarSet` bound_tyvars)
fvs' = mkIdSet [d | VarArg d <- d_args] `unionIdSets`
(fvs `minusIdSet` mkIdSet [d | ValBinder d <- d_bndrs])
in
specDBs dict_env' dbs `thenSM` \ (dict_env'', dbs') ->
returnSM ( dict_env'', mkDB dict' rhs' `consBag` dbs' )
returnSM ( dict_env'', (dict', rhs', ftvs', fvs') `consBag` dbs' )
\end{code}
%************************************************************************
......@@ -1042,31 +1066,22 @@ specUDs tv_env_list dict_env_list (dbs, calls)
%* *
%************************************************************************
\begin{code}
tyVarTemplates :: [TyVar]
tyVarTemplates = map mk [1..]
where
mk i = mkTyVar (mkSysLocalName uniq occ noSrcLoc) mkBoxedTypeKind
where
uniq = mkAlphaTyVarUnique i
occ = _PK_ ("$t" ++ show i)
\end{code}
\begin{code}
lookupId:: IdEnv Id -> Id -> Id
lookupId env id = case lookupIdEnv env id of
Nothing -> id
Just id' -> id'
instantiateDictRhs :: TyVarEnv Type -> IdEnv Id -> CoreExpr -> CoreExpr
-- Cheapo function for simple RHSs
instantiateDictRhs ty_env id_env rhs
= go rhs
where
go_arg (VarArg a) = VarArg (lookupId id_env a)
go_arg (TyArg t) = TyArg (instantiateTy ty_env t)
go (App e1 arg) = App (go e1) (go_arg arg)
go (Var v) = Var (lookupId id_env v)
go (Lit l) = Lit l
go (Con con args) = Con con (map go_arg args)
go (Note n e) = Note (go_note n) (go e)
go (Case e alts) = Case (go e) alts -- See comment below re alts
go other = pprPanic "instantiateDictRhs" (ppr rhs)
go_note (Coerce t1 t2) = Coerce (instantiateTy ty_env t1) (instantiateTy ty_env t2)
go_note note = note
dictRhsFVs :: CoreExpr -> IdSet
-- Cheapo function for simple RHSs
dictRhsFVs e
......
......@@ -16,9 +16,10 @@ import CoreUtils ( coreExprType )
import MkId ( mkWorkerId )
import Id ( getInlinePragma, getIdStrictness,
addIdStrictness, addInlinePragma, idWantsToBeINLINEd,
IdSet, emptyIdSet, addOneToIdSet,
IdSet, emptyIdSet, addOneToIdSet, unionIdSets,
GenId, Id
)
import Type ( splitAlgTyConApp_maybe )
import IdInfo ( noIdInfo, mkStrictnessInfo, setStrictnessInfo, StrictnessInfo(..) )
import SaLib
import UniqSupply ( returnUs, thenUs, mapUs, getUnique, UniqSM )
......@@ -230,21 +231,32 @@ tryWW fn_id rhs
-- make the wrapper.
-- These are needed when we write an interface file.
getWorkerIdAndCons wrap_id wrapper_fn
= go wrapper_fn
= (get_work_id wrapper_fn, get_cons wrapper_fn)
where
go (Lam _ body) = go body
go (Case _ (AlgAlts [(con,_,rhs)] _)) = let (wrap_id, cons) = go rhs
in (wrap_id, cons `addOneToIdSet` con)
{-
get_work_id (Lam _ body) = get_work_id body
get_work_id (Case _ (AlgAlts [(_,_,rhs)] _)) = get_work_id rhs
get_work_id (Note _ body) = get_work_id body
get_work_id (Let _ body) = get_work_id body
get_work_id (App fn _) = get_work_id fn
get_work_id (Var work_id) = work_id
get_work_id other = pprPanic "getWorkerIdAndCons" (ppr wrap_id)
get_cons (Lam _ body) = get_cons body
get_cons (Let (NonRec _ rhs) body) = get_cons rhs `unionIdSets` get_cons body
get_cons (Case e (AlgAlts [(con,_,rhs)] _)) = (get_cons e `unionIdSets` get_cons rhs)
`addOneToIdSet` con
-- Coercions don't mention the construtor now,
-- so I don't think we need this
go (Let (NonRec _ (Coerce (CoerceOut con) _ _)) body)
= let (wrap_id, cons) = go body
in (wrap_id, cons `addOneToIdSet` con)
-}
go other = (get_work_id other, emptyIdSet)
get_work_id (App fn _) = get_work_id fn
get_work_id (Var work_id) = work_id
get_work_id other = pprPanic "getWorkerIdAndCons" (ppr wrap_id)
-- but we must still put the constructor in the interface
-- file so that the RHS of the newtype decl is imported
get_cons (Note (Coerce to_ty from_ty) body)
= get_cons body `addOneToIdSet` con
where
con = case splitAlgTyConApp_maybe from_ty of
Just (_, _, [con]) -> con
other -> pprPanic "getWorkerIdAndCons" (ppr to_ty)
get_cons other = emptyIdSet
\end{code}
......@@ -324,9 +324,11 @@ mkWW ((arg,WwUnpack new_or_data True cs) : ds)
unpk_args_w_ds = zipEqual "mkWW" unpk_args cs
in
mkWW (unpk_args_w_ds ++ ds) `thenUs` \ (wrap_fn, worker_args, work_fn) ->
returnUs (\ wrapper_body -> mk_unpk_case new_or_data arg unpk_args data_con arg_tycon (wrap_fn wrapper_body),
returnUs (\ wrapper_body -> mk_unpk_case new_or_data arg unpk_args data_con arg_tycon
(wrap_fn wrapper_body),
worker_args,
\ worker_body -> work_fn (mk_pk_let new_or_data arg data_con tycon_arg_tys unpk_args worker_body))
\ worker_body -> work_fn (mk_pk_let new_or_data arg data_con
tycon_arg_tys unpk_args worker_body))
where
inst_con_arg_tys = dataConArgTys data_con tycon_arg_tys
(arg_tycon, tycon_arg_tys, data_con)
......
......@@ -469,7 +469,7 @@ lookupInst :: Inst s
-- Dictionaries
lookupInst dict@(Dict _ clas tys orig loc)
= case lookupSpecEnv (classInstEnv clas) tys of
= case lookupSpecEnv (ppr clas) (classInstEnv clas) tys of
Just (tenv, dfun_id)
-> let
......@@ -549,7 +549,7 @@ lookupSimpleInst :: ClassInstEnv
-> NF_TcM s (Maybe ThetaType) -- Here are the needed (c,t)s
lookupSimpleInst class_inst_env clas tys
= case lookupSpecEnv class_inst_env tys of
= case lookupSpecEnv (ppr clas) class_inst_env tys of
Nothing -> returnNF_Tc Nothing
Just (tenv, dfun)
......
......@@ -875,7 +875,7 @@ tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc)
tcExpr (HsVar name) sig_ty `thenTc` \ (spec_expr, spec_lie) ->
case maybe_spec_name of
Nothing -> -- Just specialise "f" by building a pecPragmaId binding
Nothing -> -- Just specialise "f" by building a SpecPragmaId binding
-- It is the thing that makes sure we don't prematurely
-- dead-code-eliminate the binding we are really interested in.
newSpecPragmaId name sig_ty `thenNF_Tc` \ spec_id ->
......
......@@ -9,7 +9,9 @@ module TcClassDcl ( tcClassDecl1, tcClassDecls2, tcMethodBind, badMethodErr ) wh
#include "HsVersions.h"
import HsSyn ( HsDecl(..), ClassDecl(..), Sig(..), MonoBinds(..),
InPat(..), andMonoBinds, getTyVarName
InPat(..), HsBinds(..), GRHSsAndBinds(..), GRHS(..),
HsExpr(..), HsLit(..),
unguardedRHS, andMonoBinds, getTyVarName
)
import HsPragmas ( ClassPragmas(..) )
import BasicTypes ( NewOrData(..), TopLevelFlag(..), RecFlag(..) )
......@@ -20,7 +22,7 @@ import RnHsSyn ( RenamedClassDecl(..), RenamedClassPragmas(..),
import TcHsSyn ( TcMonoBinds )
import Inst ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, newDicts, newMethod )
import TcEnv ( TcIdOcc(..), tcAddImportedIdInfo,
import TcEnv ( TcIdOcc(..), GlobalValueEnv, tcAddImportedIdInfo,
tcLookupClass, tcLookupTyVar,
tcExtendGlobalTyVars, tcExtendLocalValEnv
)
......@@ -32,10 +34,11 @@ import TcSimplify ( tcSimplifyAndCheck )
import TcType ( TcType, TcTyVar, TcTyVarSet, tcInstSigTyVars,
zonkSigTyVar, tcInstSigTcType
)
import PrelVals ( nO_METHOD_BINDING_ERROR_ID )
import FieldLabel ( firstFieldLabelTag )
import Bag ( unionManyBags )
import Class ( mkClass, classBigSig, Class )
import CmdLineOpts ( opt_GlasgowExts )
import CmdLineOpts ( opt_GlasgowExts, opt_WarnMissingMethods )
import MkId ( mkDataCon, mkSuperDictSelId,
mkMethodSelId, mkDefaultMethodId
)
......@@ -55,7 +58,7 @@ import TyCon ( mkDataTyCon )
import Kind ( mkBoxedTypeKind, mkArrowKind )
import Unique ( Unique, Uniquable(..) )
import Util
import Maybes ( assocMaybe, maybeToBool )
import Maybes ( assocMaybe, maybeToBool, seqMaybe )
-- import TcPragmas ( tcGenPragmas, tcClassOpPragmas )
......@@ -206,7 +209,7 @@ tcClassContext rec_class rec_tyvars context pragmas
returnTc (mkSuperDictSelId uniq rec_class index ty)
tcClassSig :: TcEnv s -- Knot tying only!
tcClassSig :: GlobalValueEnv -- Knot tying only!
-> Class -- ...ditto...
-> [TyVar] -- The class type variable, used for error check only
-> RenamedClassOpSig
......@@ -404,30 +407,13 @@ tcDefaultMethodBinds clas default_binds
-- Typecheck the default bindings
let
tc_dm meth_bind
= case [pair | pair@(sel_id,_) <- sel_ids_w_dms,
idName sel_id == bndr_name] of
[] -> -- Binding for something that isn't in the class signature
failWithTc (badMethodErr bndr_name clas)
((sel_id, Just dm_id):_) ->
-- We're looking at a default-method binding, so the dm_id
-- is sure to be there! Hence the inner "Just".
-- Normal case
tcMethodBind clas origin inst_tys clas_tyvars
sel_id meth_bind [{- No prags -}]
`thenTc` \ (bind, insts, (_, local_dm_id)) ->
returnTc (bind, insts, (clas_tyvars, RealId dm_id, local_dm_id))
where
bndr_name = case meth_bind of
FunMonoBind name _ _ _ -> name
PatMonoBind (VarPatIn name) _ _ -> name
tc_dm sel_id_w_dm@(_, Just dm_id)
= tcMethodBind clas origin inst_tys clas_tyvars
default_binds [{-no prags-}] False
sel_id_w_dm `thenTc` \ (bind, insts, (_, local_dm_id)) ->
returnTc (bind, insts, (clas_tyvars, RealId dm_id, local_dm_id))
in
mapAndUnzip3Tc tc_dm
(flatten default_binds []) `thenTc` \ (defm_binds, insts_needed, abs_bind_stuff) ->
mapAndUnzip3Tc tc_dm sel_ids_w_dms `thenTc` \ (defm_binds, insts_needed, abs_bind_stuff) ->
-- Check the context
newDicts origin [(clas,inst_tys)] `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
......@@ -453,12 +439,12 @@ tcDefaultMethodBinds clas default_binds
where
(tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
sel_ids_w_dms = op_sel_ids `zip` defm_ids
origin = ClassDeclOrigin
flatten EmptyMonoBinds rest = rest
flatten (AndMonoBinds b1 b2) rest = flatten b1 (flatten b2 rest)
flatten a_bind rest = a_bind : rest
sel_ids_w_dms = [pair | pair@(_, Just _) <- op_sel_ids `zip` defm_ids]
-- Just the ones for which there is an explicit
-- user default declaration
origin = ClassDeclOrigin
\end{code}
@tcMethodBind@ is used to type-check both default-method and
......@@ -470,36 +456,49 @@ tyvar sets.
tcMethodBind
:: Class
-> InstOrigin s
-> [TcType s] -- Instance types
-> [TcTyVar s] -- Free variables of those instance types
-- they'll be signature tyvars, and we
-- want to check that they don't bound
-> Id -- The method selector
-> RenamedMonoBinds -- Method binding (just one)
-> [RenamedSig] -- Pramgas (just for this one)
-> [TcType s] -- Instance types
-> [TcTyVar s] -- Free variables of those instance types
-- they'll be signature tyvars, and we
-- want to check that they don't bound
-> RenamedMonoBinds -- Method binding (pick the right one from in here)
-> [RenamedSig] -- Pramgas (just for this one)
-> Bool -- True <=> supply default decl if no explicit decl
-- This is true for instance decls,
-- false for class decls
-> (Id, Maybe Id) -- The method selector and default-method Id
-> TcM s (TcMonoBinds s, LIE s, (LIE s, TcIdOcc s))
tcMethodBind clas origin inst_tys inst_tyvars sel_id meth_bind prags
= tcAddSrcLoc src_loc $
tcMethodBind clas origin inst_tys inst_tyvars
meth_binds prags supply_default_bind
(sel_id, maybe_dm_id)
| no_user_bind && not supply_default_bind
= pprPanic "tcMethodBind" (ppr clas <+> ppr inst_tys)
| otherwise
= tcGetSrcLoc `thenNF_Tc` \ loc ->
-- Warn if no method binding, only if -fwarn-missing-methods
warnTc (opt_WarnMissingMethods && no_user_bind && no_user_default)
(omittedMethodWarn sel_id clas) `thenNF_Tc_`
newMethod origin (RealId sel_id) inst_tys `thenNF_Tc` \ meth@(_, TcId meth_id) ->
tcInstSigTcType (idType meth_id) `thenNF_Tc` \ (tyvars', rho_ty') ->
let
(theta', tau') = splitRhoTy rho_ty'
sig_info = TySigInfo meth_name meth_id tyvars' theta' tau' src_loc
meth_name = idName meth_id
meth_bind' = case meth_bind of
FunMonoBind _ fix matches loc -> FunMonoBind meth_name fix matches loc
PatMonoBind (VarPatIn _) rhs loc -> PatMonoBind (VarPatIn meth_name) rhs loc
-- The renamer just puts the selector ID as the binder in the method binding
-- but we must use the method name; so we substitute it here. Crude but simple.
(theta', tau') = splitRhoTy rho_ty'
meth_name = idName meth_id
sig_info = TySigInfo meth_name meth_id tyvars' theta' tau' loc
meth_bind = mk_meth_bind meth_name loc
meth_prags = find_prags meth_name prags
in
tcExtendLocalValEnv [meth_name] [meth_id] (
tcPragmaSigs prags
tcPragmaSigs meth_prags
) `thenTc` \ (prag_info_fn, prag_binds, prag_lie) ->
-- Check that the signatures match
tcExtendGlobalTyVars inst_tyvars (
tcAddErrCtxt (methodCtxt sel_id) $