X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcInstDcls.lhs;h=d35c0de5aaae2d643c984f4e972feb4e0f313da4;hb=321009129c53e5dadf679603da66dbaadf5010be;hp=4f670fa884c6a8c78ef7b7d955b267cea8bf79fd;hpb=00e85a3cb0dd8f268f6c40f898ac92d19ea90081;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index 4f670fa..d35c0de 100644
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -49,7 +49,6 @@ import DataCon		( classDataCon )
 import Class		( Class, classBigSig )
 import Var		( idName, idType )
 import NameSet		
-import Id		( setIdLocalExported )
 import MkId		( mkDictFunId, rUNTIME_ERROR_ID )
 import FunDeps		( checkInstFDs )
 import Generics		( validGenericInstanceType )
@@ -490,7 +489,7 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds })
     addSrcLoc (getSrcLoc dfun_id)			   	$
     addErrCtxt (instDeclCtxt (toHsType (idType dfun_id)))	$
     let
-	inst_ty = idType dfun_id
+	inst_ty 	 = idType dfun_id
 	(inst_tyvars, _) = tcSplitForAllTys inst_ty
 		-- The tyvars of the instance decl scope over the 'where' part
 		-- Those tyvars are inside the dfun_id's type, which is a bit
@@ -545,9 +544,6 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds })
 
 	-- Create the result bindings
     let
-	local_dfun_id = setIdLocalExported dfun_id
-		-- Reason for setIdLocalExported: see notes with MkId.mkDictFunId
-
         dict_constr   = classDataCon clas
 	scs_and_meths = map instToId sc_dicts ++ meth_ids
 	this_dict_id  = instToId this_dict
@@ -593,10 +589,10 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds })
 	main_bind = AbsBinds
 		 	 zonked_inst_tyvars
 		 	 (map instToId dfun_arg_dicts)
-		 	 [(inst_tyvars', local_dfun_id, this_dict_id)] 
+		 	 [(inst_tyvars', dfun_id, this_dict_id)] 
 		 	 inlines all_binds
     in
-    showLIE "instance" 		`thenM_`
+    showLIE (text "instance") 		`thenM_`
     returnM (main_bind `AndMonoBinds` prag_binds `AndMonoBinds` sc_binds_outer)
 
 
@@ -610,19 +606,50 @@ tcMethods clas inst_tyvars inst_tyvars' dfun_theta' inst_tys'
     mappM (addErrTc . badMethodErr clas) bad_bndrs	`thenM_`
 
 	-- Make the method bindings
-    mapAndUnzipM do_one op_items			`thenM` \ (meth_ids, meth_binds_s) ->
+    let
+	mk_method_bind = mkMethodBind InstanceDeclOrigin clas inst_tys' monobinds
+    in
+    mapAndUnzipM mk_method_bind op_items 	`thenM` \ (meth_insts, meth_infos) ->
+
+	-- And type check them
+	-- It's really worth making meth_insts available to the tcMethodBind
+	-- Consider	instance Monad (ST s) where
+	--		  {-# INLINE (>>) #-}
+	--		  (>>) = ...(>>=)...
+	-- If we don't include meth_insts, we end up with bindings like this:
+	--	rec { dict = MkD then bind ...
+	--	      then = inline_me (... (GHC.Base.>>= dict) ...)
+	--	      bind = ... }
+	-- The trouble is that (a) 'then' and 'dict' are mutually recursive, 
+	-- and (b) the inline_me prevents us inlining the >>= selector, which
+	-- would unravel the loop.  Result: (>>) ends up as a loop breaker, and
+	-- is not inlined across modules. Rather ironic since this does not
+	-- happen without the INLINE pragma!  
+	--
+	-- Solution: make meth_insts available, so that 'then' refers directly
+	-- 	     to the local 'bind' rather than going via the dictionary.
+	--
+	-- BUT WATCH OUT!  If the method type mentions the class variable, then
+	-- this optimisation is not right.  Consider
+	--	class C a where
+	--	  op :: Eq a => a
+	--
+	--	instance C Int where
+	--	  op = op
+	-- The occurrence of 'op' on the rhs gives rise to a constraint
+	--	op at Int
+	-- 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
+	all_insts      = avail_insts ++ catMaybes meth_insts
+	xtve	       = inst_tyvars `zip` inst_tyvars'
+	tc_method_bind = tcMethodBind xtve inst_tyvars' dfun_theta' all_insts uprags 
+    in
+    mapM tc_method_bind meth_infos		`thenM` \ meth_binds_s ->
    
-    returnM (meth_ids, andMonoBindList meth_binds_s)
+    returnM ([meth_id | (_,meth_id,_) <- meth_infos], 
+	     andMonoBindList meth_binds_s)
 
-  where
-    xtve = inst_tyvars `zip` inst_tyvars'
-    do_one op_item 
-	= mkMethodBind InstanceDeclOrigin clas 
-		       inst_tys' monobinds op_item 	`thenM` \ (meth_inst, meth_info) ->
-	  tcMethodBind xtve inst_tyvars' dfun_theta' 
-		       avail_insts uprags meth_info	`thenM` \ meth_bind ->
-		-- Could add meth_insts to avail_insts, but not worth the bother
-	  returnM (instToId meth_inst, meth_bind)
 
 -- Derived newtype instances
 tcMethods clas inst_tyvars inst_tyvars' dfun_theta' inst_tys'