[project @ 2003-11-12 17:27:00 by sof]

[ghc-hetmet.git] / ghc / compiler / specialise / Specialise.lhs

diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs
index c9ffa0b..006e06d 100644 (file)
--- 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,
@@ -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
@@ -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