From: simonpj Date: Wed, 8 Apr 1998 16:49:10 +0000 (+0000) Subject: [project @ 1998-04-08 16:48:14 by simonpj] X-Git-Tag: Approx_2487_patches~820 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=c4f3290f3d4c2a5c2e81a97717f7fd06ee180f6d;p=ghc-hetmet.git [project @ 1998-04-08 16:48:14 by simonpj] Specialisation works at last --- diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index b72b73e..e3648e7 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -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} diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index ef1b761..d55e522 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -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 diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs index 05c5782..74a36af 100644 --- a/ghc/compiler/simplCore/OccurAnal.lhs +++ b/ghc/compiler/simplCore/OccurAnal.lhs @@ -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 diff --git a/ghc/compiler/simplCore/SimplVar.lhs b/ghc/compiler/simplCore/SimplVar.lhs index 30b9381..7c1340b 100644 --- a/ghc/compiler/simplCore/SimplVar.lhs +++ b/ghc/compiler/simplCore/SimplVar.lhs @@ -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 diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index a4f7a79..a650417 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -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 diff --git a/ghc/compiler/specialise/SpecEnv.lhs b/ghc/compiler/specialise/SpecEnv.lhs index 9569bd1..04ae01a 100644 --- a/ghc/compiler/specialise/SpecEnv.lhs +++ b/ghc/compiler/specialise/SpecEnv.lhs @@ -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) diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index 08f0649..e550294 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -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} %************************************************************************ @@ -1043,30 +1067,21 @@ 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 diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs index 790c9c6..890ade2 100644 --- a/ghc/compiler/stranal/WorkWrap.lhs +++ b/ghc/compiler/stranal/WorkWrap.lhs @@ -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} diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index ed3710a..3c875bb 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -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) diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index c34869c..8582f65 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -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) diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index f2d9c93..d7da495 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -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 -> diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 00c1087e..acfc875 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -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) $ - tcBindWithSigs NotTopLevel [meth_name] meth_bind' [sig_info] + tcBindWithSigs NotTopLevel [meth_name] meth_bind [sig_info] NonRecursive prag_info_fn ) `thenTc` \ (binds, insts, _) -> @@ -515,9 +514,50 @@ tcMethodBind clas origin inst_tys inst_tyvars sel_id meth_bind prags insts `plusLIE` prag_lie, meth) where - src_loc = case meth_bind of - FunMonoBind name _ _ loc -> loc - PatMonoBind (VarPatIn name) _ loc -> loc + sel_name = idName sel_id + + maybe_user_bind = find meth_binds + + no_user_bind = case maybe_user_bind of {Nothing -> True; other -> False} + no_user_default = case maybe_dm_id of {Nothing -> True; other -> False} + + find EmptyMonoBinds = Nothing + find (AndMonoBinds b1 b2) = find b1 `seqMaybe` find b2 + find b@(FunMonoBind op_name _ _ _) = if op_name == sel_name then Just b else Nothing + find b@(PatMonoBind (VarPatIn op_name) _ _) = if op_name == sel_name then Just b else Nothing + find other = panic "Urk! Bad instance method binding" + + -- 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. + mk_meth_bind meth_name loc + = case maybe_user_bind of + Just (FunMonoBind _ fix matches loc) -> FunMonoBind meth_name fix matches loc + Just (PatMonoBind (VarPatIn _) rhs loc) -> PatMonoBind (VarPatIn meth_name) rhs loc + Nothing -> mk_default_bind meth_name loc + + -- Find the prags for this method, and replace the + -- selector name with the method name + find_prags meth_name [] = [] + find_prags meth_name (SpecSig name ty spec loc : prags) + | name == sel_name = SpecSig meth_name ty spec loc : find_prags meth_name prags + find_prags meth_name (InlineSig name loc : prags) + | name == sel_name = InlineSig meth_name loc : find_prags meth_name prags + find_prags meth_name (prag:prags) = find_prags meth_name prags + + mk_default_bind local_meth_name loc + = PatMonoBind (VarPatIn local_meth_name) + (GRHSsAndBindsIn (unguardedRHS (default_expr loc) loc) EmptyBinds) + loc + + default_expr loc + = case maybe_dm_id of + Just dm_id -> HsVar (getName dm_id) -- There's a default method + Nothing -> error_expr loc -- No default method + + error_expr loc = HsApp (HsVar (getName nO_METHOD_BINDING_ERROR_ID)) + (HsLit (HsString (_PK_ (error_msg loc)))) + + error_msg loc = showSDoc (hcat [ppr loc, text "|", ppr sel_id ]) \end{code} Contexts and errors @@ -540,4 +580,8 @@ monoCtxt sel_id badMethodErr bndr clas = hsep [ptext SLIT("Class"), quotes (ppr clas), ptext SLIT("does not have a method"), quotes (ppr bndr)] + +omittedMethodWarn sel_id clas + = sep [ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id), + ptext SLIT("in an instance declaration for") <+> quotes (ppr clas)] \end{code} diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 6106df1..06f17d3 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -2,7 +2,7 @@ module TcEnv( TcIdOcc(..), TcIdBndr, tcIdType, tcIdTyVars, tcInstId, - TcEnv, + TcEnv, GlobalValueEnv, initEnv, getEnv_LocalIds, getEnv_TyCons, getEnv_Classes, @@ -12,7 +12,7 @@ module TcEnv( tcExtendClassEnv, tcLookupClass, tcLookupClassByKey, tcGetTyConsAndClasses, - tcExtendGlobalValEnv, tcExtendLocalValEnv, + tcExtendGlobalValEnv, tcExtendLocalValEnv, tcGetGlobalValEnv, tcSetGlobalValEnv, tcLookupLocalValue, tcLookupLocalValueOK, tcLookupLocalValueByKey, tcLookupGlobalValue, tcLookupGlobalValueByKey, tcLookupGlobalValueMaybe, tcAddImportedIdInfo, tcExplicitLookupGlobal, @@ -123,7 +123,7 @@ data TcEnv s = TcEnv (TyVarEnv s) (TyConEnv s) (ClassEnv s) - (ValueEnv Id) -- Globals + GlobalValueEnv (ValueEnv (TcIdBndr s)) -- Locals (TcRef s (TcTyVarSet s)) -- Free type variables of locals -- ...why mutable? see notes with tcGetGlobalTyVars @@ -133,6 +133,7 @@ type TyConEnv s = UniqFM (TcKind s, Maybe Arity, TyCon) -- Arity present for Sy type ClassEnv s = UniqFM ([TcKind s], Class) -- The kinds are the kinds of the args -- to the class type ValueEnv id = UniqFM id +type GlobalValueEnv = ValueEnv Id -- Globals initEnv :: TcRef s (TcTyVarSet s) -> TcEnv s initEnv mut = TcEnv emptyUFM emptyUFM emptyUFM emptyUFM emptyUFM mut @@ -349,16 +350,26 @@ tcLookupGlobalValueByKeyMaybe uniq = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> returnNF_Tc (lookupUFM_Directly gve uniq) +tcGetGlobalValEnv :: NF_TcM s GlobalValueEnv +tcGetGlobalValEnv + = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> + returnNF_Tc gve + +tcSetGlobalValEnv :: GlobalValueEnv -> TcM s a -> TcM s a +tcSetGlobalValEnv gve scope + = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce _ lve gtvs) -> + tcSetEnv (TcEnv tve tce ce gve lve gtvs) scope + -- Non-monadic version, environment given explicitly -tcExplicitLookupGlobal :: TcEnv s -> Name -> Maybe Id -tcExplicitLookupGlobal (TcEnv tve tce ce gve lve gtvs) name +tcExplicitLookupGlobal :: GlobalValueEnv -> Name -> Maybe Id +tcExplicitLookupGlobal gve name = case maybeWiredInIdName name of Just id -> Just id Nothing -> lookupUFM gve name -- Extract the IdInfo from an IfaceSig imported from an interface file -tcAddImportedIdInfo :: TcEnv s -> Id -> Id +tcAddImportedIdInfo :: GlobalValueEnv -> Id -> Id tcAddImportedIdInfo unf_env id | isLocallyDefined id -- Don't look up locally defined Ids, because they -- have explicit local definitions, so we get a black hole! diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index ea7ccc1..345011b 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -42,8 +42,9 @@ import Id ( idType, dataConArgTys, mkIdWithNewType, Id -- others: import Name ( NamedThing(..) ) import BasicTypes ( IfaceFlavour, Unused ) -import TcEnv ( tcLookupGlobalValueMaybe, tcExtendGlobalValEnv, - TcIdOcc(..), TcIdBndr, tcIdType, tcIdTyVars, tcInstId +import TcEnv ( tcLookupGlobalValueMaybe, tcExtendGlobalValEnv, tcGetGlobalValEnv, + TcIdOcc(..), TcIdBndr, GlobalValueEnv, + tcIdType, tcIdTyVars, tcInstId ) import TcMonad @@ -199,12 +200,12 @@ zonkIdOcc (TcId id) \begin{code} -zonkTopBinds :: TcMonoBinds s -> NF_TcM s (TypecheckedMonoBinds, TcEnv s) +zonkTopBinds :: TcMonoBinds s -> NF_TcM s (TypecheckedMonoBinds, GlobalValueEnv) zonkTopBinds binds -- Top level is implicitly recursive = fixNF_Tc (\ ~(_, new_ids) -> tcExtendGlobalValEnv (bagToList new_ids) $ zonkMonoBinds emptyTyVarEnv binds `thenNF_Tc` \ (binds', new_ids) -> - tcGetEnv `thenNF_Tc` \ env -> + tcGetGlobalValEnv `thenNF_Tc` \ env -> returnNF_Tc ((binds', env), new_ids) ) `thenNF_Tc` \ (stuff, _) -> returnNF_Tc stuff diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index 4f0d6ee..14e4c9f 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -11,9 +11,10 @@ module TcIfaceSig ( tcInterfaceSigs ) where import HsSyn ( HsDecl(..), IfaceSig(..) ) import TcMonad import TcMonoType ( tcHsType, tcHsTypeKind, tcTyVarScope ) -import TcEnv ( tcExtendTyVarEnv, tcExtendGlobalValEnv, +import TcEnv ( tcExtendTyVarEnv, tcExtendGlobalValEnv, tcSetGlobalValEnv, tcLookupTyConByKey, tcLookupGlobalValueMaybe, - tcExplicitLookupGlobal + tcExplicitLookupGlobal, + GlobalValueEnv ) import TcKind ( TcKind, kindToTcKind ) @@ -52,7 +53,7 @@ As always, we do not have to worry about user-pragmas in interface signatures. \begin{code} -tcInterfaceSigs :: TcEnv s -- Envt to use when checking unfoldings +tcInterfaceSigs :: GlobalValueEnv -- Envt to use when checking unfoldings -> [RenamedHsDecl] -- Ignore non-sig-decls in these decls -> TcM s [Id] @@ -159,7 +160,7 @@ an unfolding that isn't going to be looked at. tcPragExpr unf_env name core_expr = forkNF_Tc ( recoverNF_Tc no_unfolding ( - tcSetEnv unf_env $ + tcSetGlobalValEnv unf_env $ tcCoreExpr core_expr `thenTc` \ core_expr' -> returnTc (Just core_expr') )) diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index a629162..2122b6f 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -33,7 +33,7 @@ import RnMonad ( RnNameSupply ) import Inst ( Inst, InstOrigin(..), newDicts, LIE, emptyLIE, plusLIE, plusLIEs ) import TcDeriv ( tcDeriving ) -import TcEnv ( tcExtendGlobalValEnv, tcAddImportedIdInfo ) +import TcEnv ( GlobalValueEnv, tcExtendGlobalValEnv, tcAddImportedIdInfo ) import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, classDataCon ) import TcKind ( TcKind, unifyKind ) import TcMonoType ( tcHsType ) @@ -45,7 +45,7 @@ import TcType ( TcType, TcTyVar, TcTyVarSet, import Bag ( emptyBag, unitBag, unionBags, unionManyBags, foldBag, bagToList, Bag ) -import CmdLineOpts ( opt_GlasgowExts, opt_WarnMissingMethods ) +import CmdLineOpts ( opt_GlasgowExts ) import Class ( classBigSig, Class ) import Id ( isNullaryDataCon, dataConArgTys, replaceIdInfo, idName, Id ) import Maybes ( maybeToBool, seqMaybe, catMaybes ) @@ -53,7 +53,7 @@ import Name ( nameOccName, mkLocalName, isLocallyDefined, Module, NamedThing(..) ) -import PrelVals ( nO_METHOD_BINDING_ERROR_ID, eRROR_ID ) +import PrelVals ( eRROR_ID ) import PprType ( pprParendType, pprConstraint ) import SrcLoc ( SrcLoc, noSrcLoc ) import TyCon ( isSynTyCon, isDataTyCon, tyConDerivings ) @@ -144,7 +144,7 @@ and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm. \end{enumerate} \begin{code} -tcInstDecls1 :: TcEnv s -- Contains IdInfo for dfun ids +tcInstDecls1 :: GlobalValueEnv -- Contains IdInfo for dfun ids -> [RenamedHsDecl] -> Module -- module name for deriving -> RnNameSupply -- for renaming derivings @@ -171,7 +171,7 @@ tcInstDecls1 unf_env decls mod_name rn_name_supply returnTc (full_inst_info, deriv_binds, ddump_deriv) -tcInstDecl1 :: TcEnv s -> Module -> RenamedInstDecl -> NF_TcM s (Bag InstInfo) +tcInstDecl1 :: GlobalValueEnv -> Module -> RenamedInstDecl -> NF_TcM s (Bag InstInfo) tcInstDecl1 unf_env mod_name (InstDecl poly_ty binds uprags (Just dfun_name) src_loc) = -- Prime error recovery, set source location @@ -352,7 +352,7 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_tys tcExtendGlobalValEnv (catMaybes defm_ids) ( -- Default-method Ids may be mentioned in synthesised RHSs - mapAndUnzip3Tc (tcInstMethodBind clas inst_tys' inst_tyvars' monobinds uprags) + mapAndUnzip3Tc (tcMethodBind clas origin inst_tys' inst_tyvars' monobinds uprags True) (op_sel_ids `zip` defm_ids) ) `thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) -> @@ -463,77 +463,6 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_tys %************************************************************************ %* * -\subsection{Processing each method} -%* * -%************************************************************************ - -\begin{code} -tcInstMethodBind - :: Class - -> [TcType s] -- Instance types - -> [TcTyVar s] -- and their free (sig) tyvars - -> RenamedMonoBinds -- Method binding - -> [RenamedSig] -- Pragmas - -> (Id, Maybe Id) -- Selector id and default-method id - -> TcM s (TcMonoBinds s, LIE s, (LIE s, TcIdOcc s)) - -tcInstMethodBind clas inst_tys inst_tyvars meth_binds prags (sel_id, maybe_dm_id) - = tcGetSrcLoc `thenNF_Tc` \ loc -> - tcGetUnique `thenNF_Tc` \ uniq -> - let - sel_name = idName sel_id - meth_occ = getOccName sel_name - default_meth_name = mkLocalName uniq meth_occ loc - maybe_meth_bind = find sel_name meth_binds - the_meth_bind = case maybe_meth_bind of - Just stuff -> stuff - Nothing -> mk_default_bind default_meth_name loc - meth_prags = sigsForMe (== sel_name) prags - in - - -- Warn if no method binding, only if -fwarn-missing-methods - - warnTc (opt_WarnMissingMethods && - not (maybeToBool maybe_meth_bind) && - not (maybeToBool maybe_dm_id)) - (omittedMethodWarn sel_id clas) `thenNF_Tc_` - - -- Typecheck the method binding - tcMethodBind clas origin inst_tys inst_tyvars sel_id the_meth_bind meth_prags - where - origin = InstanceDeclOrigin -- Poor - - find sel EmptyMonoBinds = Nothing - find sel (AndMonoBinds b1 b2) = find sel b1 `seqMaybe` find sel b2 - - find sel b@(FunMonoBind op_name _ _ _) | op_name == sel = Just b - | otherwise = Nothing - find sel b@(PatMonoBind (VarPatIn op_name) _ _) | op_name == sel = Just b - | otherwise = Nothing - find sel other = panic "Urk! Bad instance method binding" - - - mk_default_bind local_meth_name loc - = PatMonoBind (VarPatIn local_meth_name) - (GRHSsAndBindsIn (unguardedRHS (default_expr loc) loc) EmptyBinds) - loc - - default_expr loc - = case maybe_dm_id of - Just dm_id -> HsVar (getName dm_id) -- There's a default method - Nothing -> error_expr loc -- No default method - - error_expr loc - = HsApp (HsVar (getName nO_METHOD_BINDING_ERROR_ID)) - (HsLit (HsString (_PK_ (error_msg loc)))) - - error_msg loc = showSDoc (hcat [ppr loc, text "|", ppr sel_id ]) -\end{code} - - - -%************************************************************************ -%* * \subsection{Checking for a decent instance type} %* * %************************************************************************ @@ -655,10 +584,6 @@ nonBoxedPrimCCallErr clas inst_ty 4 (hsep [ ptext SLIT("class"), ppr clas, ptext SLIT("type"), ppr inst_ty]) -omittedMethodWarn sel_id clas - = sep [ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id), - ptext SLIT("in an instance declaration for") <+> quotes (ppr clas)] - {- Declaring CCallable & CReturnable instances in a module different from where the type was defined. Caused by importing data type diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 96819e4..cdfb8f5 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -120,7 +120,8 @@ tcModule rn_name_supply -- which is done lazily [ie failure just drops the pragma -- without having any global-failure effect]. -- - -- unf_env is also used to get the pragam info for dfuns. + -- unf_env is also used to get the pragam info + -- for imported dfuns and default methods -- The knot for instance information. This isn't used at all -- till we type-check value declarations diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index efcaa9d..7de928a 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -23,7 +23,7 @@ import BasicTypes ( RecFlag(..) ) import TcMonad import Inst ( InstanceMapper ) import TcClassDcl ( tcClassDecl1 ) -import TcEnv ( TcIdOcc(..), tcExtendTyConEnv, tcExtendClassEnv ) +import TcEnv ( TcIdOcc(..), GlobalValueEnv, tcExtendTyConEnv, tcExtendClassEnv ) import TcKind ( TcKind, newKindVar, newKindVars, tcDefaultKind, kindToTcKind ) import TcTyDecls ( tcTyDecl, mkDataBinds ) import TcMonoType ( tcTyVarScope ) @@ -49,7 +49,7 @@ import Util ( panic{-, pprTrace-} ) The main function ~~~~~~~~~~~~~~~~~ \begin{code} -tcTyAndClassDecls1 :: TcEnv s -> InstanceMapper -- Knot tying stuff +tcTyAndClassDecls1 :: GlobalValueEnv -> InstanceMapper -- Knot tying stuff -> [RenamedHsDecl] -> TcM s (TcEnv s) @@ -90,7 +90,7 @@ that the knot-tied TyVars, TyCons and Classes aren't looked at too early. \begin{code} -tcGroup :: TcEnv s -> InstanceMapper -> SCC RenamedHsDecl -> TcM s ([TyCon], [Class]) +tcGroup :: GlobalValueEnv -> InstanceMapper -> SCC RenamedHsDecl -> TcM s ([TyCon], [Class]) tcGroup unf_env inst_mapper scc = -- TIE THE KNOT fixTc ( \ ~(rec_tycons, rec_classes) -> @@ -138,7 +138,7 @@ Dealing with one decl ~~~~~~~~~~~~~~~~~~~~~ \begin{code} tcDecl :: RecFlag -- True => recursive group - -> TcEnv s -> InstanceMapper + -> GlobalValueEnv -> InstanceMapper -> ([TyCon], [Class]) -- Accumulating parameter -> RenamedHsDecl -> TcM s ([TyCon], [Class])