X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Ftypecheck%2FTcInstDcls.lhs;h=04fbafb5b199dbe25cdc7f8d321bfcb38723e390;hb=9d7da331989abcd1844e9d03b8d1e4163796fa85;hp=c08dc7a761712e0ea3ecd9f790e328b0a8b4c344;hpb=428d8026a26575512aff9abc23a598ab005fa702;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index c08dc7a..04fbafb 100644
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -9,21 +9,20 @@ module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where
 #include "HsVersions.h"
 
 import HsSyn
-import TcBinds		( tcSpecSigs, badBootDeclErr )
+import TcBinds		( mkPragFun, tcPrags, badBootDeclErr )
 import TcClassDcl	( tcMethodBind, mkMethodBind, badMethodErr, 
 			  tcClassDecl2, getGenericInstances )
 import TcRnMonad       
 import TcMType		( tcSkolSigType, checkValidTheta, checkValidInstHead, instTypeErr, 
 			  checkAmbiguity, SourceTyCtxt(..) )
-import TcType		( mkClassPred, tyVarsOfType, tcSplitInstHeadTy_maybe,
+import TcType		( mkClassPred, tyVarsOfType, 
 			  tcSplitSigmaTy, tcSplitDFunHead, mkTyVarTys,
 			  SkolemInfo(InstSkol), tcSplitDFunTy, pprClassPred )
 import Inst		( tcInstClassOp, newDicts, instToId, showLIE, 
 			  getOverlapFlag, tcExtendLocalInstEnv )
 import InstEnv		( mkLocalInstance, instanceDFunId )
 import TcDeriv		( tcDeriving )
-import TcEnv		( tcExtendGlobalValEnv, tcExtendTyVarEnv,
- 			  InstInfo(..), InstBindings(..), 
+import TcEnv		( InstInfo(..), InstBindings(..), 
 			  newDFunName, tcExtendIdEnv
 			)
 import TcHsType		( kcHsSigType, tcHsKindedType )
@@ -36,13 +35,12 @@ import Var		( Id, idName, idType )
 import MkId		( mkDictFunId, rUNTIME_ERROR_ID )
 import FunDeps		( checkInstFDs )
 import Name		( Name, getSrcLoc )
-import NameSet		( unitNameSet, emptyNameSet )
-import UnicodeUtil	( stringToUtf8 )
 import Maybe		( catMaybes )
 import SrcLoc		( srcLocSpan, unLoc, noLoc, Located(..), srcSpanStart )
 import ListSetOps	( minusList )
 import Outputable
 import Bag
+import BasicTypes	( Activation( AlwaysActive ), InlineSpec(..) )
 import FastString
 \end{code}
 
@@ -135,7 +133,7 @@ tcInstDecls1	-- Deal with both source-code and imported instance decls
    -> TcM (TcGblEnv,		-- The full inst env
 	   [InstInfo],		-- Source-code instance decls to process; 
 				-- contains all dfuns for this module
-	   [HsBindGroup Name])	-- Supporting bindings for derived instances
+	   HsValBinds Name)	-- Supporting bindings for derived instances
 
 tcInstDecls1 tycl_decls inst_decls
   = checkNoErrs $
@@ -370,27 +368,21 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = binds })
 	-- of the inst_tyavars' with something in the envt
     checkSigTyVars inst_tyvars' 	`thenM_`
 
-	-- Deal with 'SPECIALISE instance' pragmas by making them
-	-- look like SPECIALISE pragmas for the dfun
+	-- Deal with 'SPECIALISE instance' pragmas 
     let
-	uprags = case binds of
-		       VanillaInst _ uprags -> uprags
-		       other		    -> []
-	spec_prags = [ L loc (SpecSig (L loc (idName dfun_id)) ty)
-		     | L loc (SpecInstSig ty) <- uprags ]
+	specs = case binds of
+		  VanillaInst _ prags -> filter isSpecInstLSig prags
+		  other	 	      -> []
     in
-    tcExtendGlobalValEnv [dfun_id] (
-	tcExtendTyVarEnv inst_tyvars'	$
-	tcSpecSigs spec_prags
-    )					`thenM` \ prag_binds ->
-
+    tcPrags dfun_id specs			`thenM` \ prags -> 
+    
 	-- Create the result bindings
     let
         dict_constr   = classDataCon clas
 	scs_and_meths = map instToId sc_dicts ++ meth_ids
 	this_dict_id  = instToId this_dict
-	inlines       | null dfun_arg_dicts = emptyNameSet
-		      | otherwise	    = unitNameSet (idName dfun_id)
+	inline_prag | null dfun_arg_dicts = []
+		    | otherwise	= [InlinePrag (Inline AlwaysActive True)]
 		-- Always inline the dfun; this is an experimental decision
 		-- because it makes a big performance difference sometimes.
 		-- Often it means we can do the method selection, and then
@@ -412,7 +404,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = binds })
 		-- Hardly beautiful, but only three extra lines.
 	    nlHsApp (noLoc $ TyApp (nlHsVar rUNTIME_ERROR_ID) 
 				   [idType this_dict_id])
-		  (nlHsLit (HsStringPrim (mkFastString (stringToUtf8 msg))))
+		  (nlHsLit (HsStringPrim (mkFastString msg)))
 
 	  | otherwise	-- The common case
 	  = mkHsConApp dict_constr inst_tys' (map HsVar scs_and_meths)
@@ -432,12 +424,12 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = binds })
 	main_bind = noLoc $ AbsBinds
 		 	    inst_tyvars'
 		 	    (map instToId dfun_arg_dicts)
-		 	    [(inst_tyvars', dfun_id, this_dict_id)] 
-		 	    inlines all_binds
+		 	    [(inst_tyvars', dfun_id, this_dict_id, 
+					    inline_prag ++ prags)] 
+		 	    all_binds
     in
     showLIE (text "instance") 		`thenM_`
-    returnM (unitBag main_bind `unionBags` 
-	     prag_binds )
+    returnM (unitBag main_bind)
 
 
 tcMethods origin clas inst_tyvars' dfun_theta' inst_tys' 
@@ -485,8 +477,9 @@ tcMethods origin clas inst_tyvars' dfun_theta' inst_tys'
 	-- The trouble is that the 'meth_inst' for op, which is 'available', also
 	-- looks like 'op at Int'.  But they are not the same.
     let
+	prag_fn	       = mkPragFun uprags
 	all_insts      = avail_insts ++ catMaybes meth_insts
-	tc_method_bind = tcMethodBind inst_tyvars' dfun_theta' all_insts uprags 
+	tc_method_bind = tcMethodBind inst_tyvars' dfun_theta' all_insts prag_fn
 	meth_ids       = [meth_id | (_,meth_id,_) <- meth_infos]
     in