From: simonpj <unknown>
Date: Thu, 27 Mar 2003 08:21:27 +0000 (+0000)
Subject: [project @ 2003-03-27 08:21:27 by simonpj]
X-Git-Tag: Approx_11550_changesets_converted~1021
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=3ede7cd49ee06a70dd7e314a72856e71128aace0;p=ghc-hetmet.git

[project @ 2003-03-27 08:21:27 by simonpj]
-------------------------------------
      Respect SPECIALISE pragmas in instance decls
	-------------------------------------

For some time now we have simply been discarding SPECIALISE pragmas
in instance declarations.  I think this was my fault, at some point
when I was re-plumbing TcClassDcl.lhs, but it's been this way for
some time.

The only uses of this facility in the Prelude are in GHC/Float.lhs
and GHC/Real.lhs, which affected the efficiency of the Float and
Double instance of properFraction, floor, ceiling, etc.

Ah well, it's fixed now.
---

diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index bf829aa..d0bdc5e 100644
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -26,13 +26,13 @@ import TcHsSyn		( TcMonoBinds )
 
 import Inst		( Inst, InstOrigin(..), instToId, newDicts, newMethod )
 import TcEnv		( TyThingDetails(..), 
-			  tcLookupClass, tcExtendTyVarEnv2, 
-			  tcExtendTyVarEnv
+			  tcLookupClass, tcExtendLocalValEnv2,
+			  tcExtendTyVarEnv2, tcExtendTyVarEnv
 			)
 import TcTyDecls	( tcMkDataCon )
-import TcBinds		( tcMonoBinds )
+import TcBinds		( tcMonoBinds, tcSpecSigs )
 import TcMonoType	( TcSigInfo(..), tcHsType, tcHsTheta, mkTcSig )
-import TcSimplify	( tcSimplifyCheck )
+import TcSimplify	( tcSimplifyCheck, bindInstsOfLocalFuns )
 import TcUnify		( checkSigTyVars, sigCtxt )
 import TcMType		( tcInstTyVars )
 import TcType		( Type, TyVarDetails(..), TcType, TcThetaType, TcTyVar, 
@@ -452,12 +452,13 @@ tcMethodBind xtve inst_tyvars inst_theta avail_insts prags
 	     (sel_id, meth_id, meth_bind)
   =  	-- Check the bindings; first adding inst_tyvars to the envt
 	-- so that we don't quantify over them in nested places
-    mkTcSig meth_id 				`thenM` \ meth_sig ->
+     mkTcSig meth_id 				`thenM` \ meth_sig ->
 
      tcExtendTyVarEnv2 xtve (
-	addErrCtxt (methodCtxt sel_id)		$
-	getLIE (tcMonoBinds meth_bind [meth_sig] NonRecursive)
-     )						`thenM` \ ((meth_bind, _), meth_lie) ->
+	addErrCtxt (methodCtxt sel_id)			$
+	getLIE 						$
+	tcMonoBinds meth_bind [meth_sig] NonRecursive
+     )							`thenM` \ ((meth_bind,_), meth_lie) ->
 
 	-- Now do context reduction.   We simplify wrt both the local tyvars
 	-- and the ones of the class/instance decl, so that there is
@@ -483,25 +484,42 @@ tcMethodBind xtve inst_tyvars inst_theta avail_insts prags
      checkSigTyVars all_tyvars			`thenM` \ all_tyvars' ->
 
      let
+	sel_name = idName sel_id
+	inline_prags  = [ (is_inl, phase)
+		        | InlineSig is_inl name phase _ <- prags, 
+		          name == sel_name ]
+	spec_prags = [ prag 
+		     | prag@(SpecSig name _ _) <- prags, 
+		       name == sel_name]
+	
 		-- Attach inline pragmas as appropriate
 	(final_meth_id, inlines) 
-	   | (InlineSig inl _ phase _ : _) <- filter is_inline prags
+	   | ((is_inline, phase) : _) <- inline_prags
 	   = (meth_id `setInlinePragma` phase,
-	      if inl then unitNameSet (idName meth_id) else emptyNameSet)
+	      if is_inline then unitNameSet (idName meth_id) else emptyNameSet)
 	   | otherwise
 	   = (meth_id, emptyNameSet)
 
-	is_inline (InlineSig _ name _ _) = name == idName sel_id
-	is_inline other		         = False
-
 	meth_tvs'      = take (length meth_tvs) all_tyvars'
 	poly_meth_bind = AbsBinds meth_tvs'
 				  (map instToId meth_dicts)
      				  [(meth_tvs', final_meth_id, local_meth_id)]
 				  inlines
 				  (lie_binds `andMonoBinds` meth_bind)
+
      in
-     returnM poly_meth_bind
+	-- Deal with specialisation pragmas
+	-- The sel_name is what appears in the pragma
+     tcExtendLocalValEnv2 [(sel_name, final_meth_id)] (
+	getLIE (tcSpecSigs spec_prags)			`thenM` \ (spec_binds1, prag_lie) ->
+     
+	     -- The prag_lie for a SPECIALISE pragma will mention the function itself, 
+	     -- so we have to simplify them away right now lest they float outwards!
+	bindInstsOfLocalFuns prag_lie [final_meth_id]	`thenM` \ spec_binds2 ->
+	returnM (spec_binds1 `andMonoBinds` spec_binds2)
+     )							`thenM` \ spec_binds ->
+
+     returnM (poly_meth_bind `andMonoBinds` spec_binds)
 
 
 mkMethodBind :: InstOrigin