X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fspecialise%2FSpecialise.lhs;h=8bacb9e862cb81f7dc782230ccdb61995891fe31;hb=8c92ca4a29a3943b47ec931f18e77a302465aaed;hp=16d3748f3adea759ef4dcfa6f4a0caaca3bd0a9f;hpb=d254a44b8392ff0a4327f1916ef921887ce78769;p=ghc-hetmet.git

diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs
index 16d3748..8bacb9e 100644
--- a/ghc/compiler/specialise/Specialise.lhs
+++ b/ghc/compiler/specialise/Specialise.lhs
@@ -9,9 +9,9 @@ module Specialise ( specProgram ) where
 #include "HsVersions.h"
 
 import CmdLineOpts	( DynFlags, DynFlag(..) )
-import Id		( Id, idName, idType, mkUserLocal, idSpecialisation, isDataConWrapId )
+import Id		( Id, idName, idType, mkUserLocal ) 
 import TcType		( Type, mkTyVarTy, tcSplitSigmaTy, 
-			  tyVarsOfTypes, tyVarsOfTheta, 
+			  tyVarsOfTypes, tyVarsOfTheta, isClassPred,
 			  mkForAllTys, tcCmpType
 			)
 import Subst		( Subst, mkSubst, substTy, mkSubst, extendSubstList, mkInScopeSet,
@@ -43,7 +43,7 @@ import List		( partition )
 import Util		( zipEqual, zipWithEqual, cmpList, lengthIs,
 			  equalLength, lengthAtLeast, notNull )
 import Outputable
-
+import FastString
 
 infixr 9 `thenSM`
 \end{code}
@@ -787,8 +787,6 @@ specDefn subst calls (fn, rhs)
   |  rhs_tyvars `lengthIs` n_tyvars 	-- Rhs of fn's defn has right number of big lambdas
   && rhs_bndrs  `lengthAtLeast` n_dicts	-- and enough dict args
   && notNull calls_for_me		-- And there are some calls to specialise
-  && not (isDataConWrapId fn)		-- And it's not a data con wrapper, which have
-					-- stupid overloading that simply discard the dictionary
 
 -- At one time I tried not specialising small functions
 -- but sometimes there are big functions marked INLINE
@@ -887,7 +885,7 @@ specDefn subst calls (fn, rhs)
 	let
 		-- The rule to put in the function's specialisation is:
 		--	forall b,d, d1',d2'.  f t1 b t3 d d1' d2' = f1 b d  
-           spec_env_rule = Rule (_PK_ ("SPEC " ++ showSDoc (ppr fn)))
+           spec_env_rule = Rule (mkFastString ("SPEC " ++ showSDoc (ppr fn)))
 				AlwaysActive
 			        (poly_tyvars ++ rhs_dicts')
 				inst_args 
@@ -1003,6 +1001,10 @@ callDetailsToList calls = [ (id,tys,dicts)
 
 mkCallUDs subst f args 
   | null theta
+  || not (all isClassPred theta)	
+	-- Only specialise if all overloading is on class params. 
+	-- In ptic, with implicit params, the type args
+	-- *don't* say what the value of the implicit param is!
   || not (spec_tys `lengthIs` n_tyvars)
   || not ( dicts   `lengthIs` n_dicts)
   || maybeToBool (lookupRule (\act -> True) (substInScope subst) f args)
@@ -1025,10 +1027,9 @@ mkCallUDs subst f args
     spec_tys = [mk_spec_ty tv ty | (tv, Type ty) <- tyvars `zip` args]
     dicts    = [dict_expr | (_, dict_expr) <- theta `zip` (drop n_tyvars args)]
     
-    mk_spec_ty tyvar ty | tyvar `elemVarSet` constrained_tyvars
-			= Just ty
-			| otherwise
-			= Nothing
+    mk_spec_ty tyvar ty 
+	| tyvar `elemVarSet` constrained_tyvars = Just ty
+	| otherwise				= Nothing
 
 ------------------------------------------------------------			
 plusUDs :: UsageDetails -> UsageDetails -> UsageDetails
@@ -1104,7 +1105,7 @@ splitUDs bndrs uds@(MkUD {dict_binds = orig_dbs,
     dump_db (free_dbs, dump_dbs, dump_idset) db@(bind, fvs)
 	| dump_idset `intersectsVarSet` fvs	-- Dump it
 	= (free_dbs, dump_dbs `snocBag` db,
-	   dump_idset `unionVarSet` mkVarSet (bindersOf bind))
+	   extendVarSetList dump_idset (bindersOf bind))
 
 	| otherwise	-- Don't dump it
 	= (free_dbs `snocBag` db, dump_dbs, dump_idset)