From c048887754562e180e5efbc69c97cdcb24cd2121 Mon Sep 17 00:00:00 2001 From: sof Date: Thu, 5 Jun 1997 10:32:40 +0000 Subject: [PATCH] [project @ 1997-06-05 10:32:40 by sof] Do not use loop breaker modules with 2.0x --- ghc/compiler/typecheck/TcInstDcls.lhs | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 9d36640..6aaedcd 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -34,7 +34,7 @@ import TcHsSyn ( TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcHsBinds), mkHsTyLam, mkHsTyApp, mkHsDictLam, mkHsDictApp ) -import TcBinds ( tcBindWithSigs, TcSigInfo(..) ) +import TcBinds ( tcBindWithSigs, tcPragmaSigs, TcSigInfo(..) ) import TcMonad import RnMonad ( SYN_IE(RnNameSupply) ) import Inst ( Inst, InstOrigin(..), SYN_IE(InstanceMapper), @@ -68,11 +68,11 @@ import Class ( GenClass, GenClassOp, classBigSig, classOps, classOpLocalType, classDefaultMethodId, SYN_IE(Class) ) -import Id ( GenId, idType, isDefaultMethodId_maybe, +import Id ( GenId, idType, isDefaultMethodId_maybe, replacePragmaInfo, isNullaryDataCon, dataConArgTys, SYN_IE(Id) ) import ListSetOps ( minusList ) import Maybes ( maybeToBool, expectJust, seqMaybe ) -import Name ( nameOccName, getOccString, occNameString, moduleString, getOccName, +import Name ( nameOccName, getOccString, occNameString, moduleString, isLocallyDefined, OccName, Name{--O only-}, SYN_IE(Module), NamedThing(..) ) @@ -375,6 +375,10 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty newDicts origin inst_decl_theta' `thenNF_Tc` \ (inst_decl_dicts, _) -> newDicts origin [(clas,inst_ty')] `thenNF_Tc` \ (this_dict, [this_dict_id]) -> + -- Now process any INLINE or SPECIALIZE pragmas for the methods + -- ...[NB May 97; all ignored except INLINE] + tcPragmaSigs uprags `thenTc` \ (prag_fn, spec_binds, spec_lie) -> + -- Check the method bindings let inst_tyvars_set' = mkTyVarSet inst_tyvars' @@ -387,7 +391,7 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty in mapTc check_from_this_class (bagToList (collectMonoBinders monobinds)) `thenTc_` tcExtendGlobalTyVars inst_tyvars_set' ( - mapAndUnzip3Tc (tcMethodBind (getDefmRhs clas) inst_ty' monobinds) + mapAndUnzip3Tc (tcMethodBind (getDefmRhs clas) inst_ty' prag_fn monobinds) (op_sel_ids `zip` [0..]) ) `thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) -> @@ -418,12 +422,6 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty -- Ignore the result; we're only doing -- this to make sure it can be done. - -- Now process any SPECIALIZE pragmas for the methods - let - spec_sigs = [ s | s@(SpecSig _ _ _ _) <- uprags ] - in - tcPragmaSigs spec_sigs `thenTc` \ (_, spec_binds, spec_lie) -> - -- Create the result bindings let dict_bind = VarMonoBind this_dict_id (Dictionary sc_dict_ids meth_ids) @@ -465,12 +463,13 @@ getDefmRhs clas idx = HsVar (getName (classDefaultMethodId clas idx)) tcMethodBind :: (Int -> RenamedHsExpr) -- Function mapping a tag to default RHS -> TcType s -- Instance type + -> (Name -> PragmaInfo) -> RenamedMonoBinds -- Method binding -> (Id, Int) -- Selector ID (and its 0-indexed tag) -- for which binding is wanted -> TcM s (TcMonoBinds s, LIE s, (LIE s, TcIdOcc s)) -tcMethodBind deflt_fn inst_ty meth_binds (sel_id, idx) +tcMethodBind deflt_fn inst_ty prag_fn meth_binds (sel_id, idx) = newMethod origin (RealId sel_id) [inst_ty] `thenNF_Tc` \ meth@(_, TcId meth_id) -> tcInstSigTcType (idType meth_id) `thenNF_Tc` \ (tyvars', rho_ty') -> let @@ -483,8 +482,9 @@ tcMethodBind deflt_fn inst_ty meth_binds (sel_id, idx) Just stuff -> stuff Nothing -> (meth_name, default_bind) - (theta', tau') = splitRhoTy rho_ty' - sig_info = TySigInfo op_name meth_id tyvars' theta' tau' noSrcLoc + (theta', tau') = splitRhoTy rho_ty' + meth_id_w_prags = replacePragmaInfo meth_id (prag_fn meth_name) + sig_info = TySigInfo op_name meth_id_w_prags tyvars' theta' tau' noSrcLoc in tcBindWithSigs [op_name] op_bind [sig_info] nonRecursive (\_ -> NoPragmaInfo) `thenTc` \ (binds, insts, _) -> -- 1.7.10.4