[project @ 2004-08-05 18:29:47 by krasimir]

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

diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs
index c9627c3..1d172e9 100644 (file)
--- a/ghc/compiler/specialise/Specialise.lhs
+++ b/ghc/compiler/specialise/Specialise.lhs
@@ -9,7 +9,7 @@ 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, isClassPred,
                          mkForAllTys, tcCmpType
@@ -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
@@ -826,10 +824,10 @@ specDefn subst calls (fn, rhs)
     n_tyvars          = length tyvars
     n_dicts           = length theta
 
+    (rhs_tyvars, rhs_ids, rhs_body) 
+       = collectTyAndValBinders (dropInline rhs)
        -- It's important that we "see past" any INLINE pragma
        -- else we'll fail to specialise an INLINE thing
-    (inline_me, rhs')              = dropInline rhs
-    (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs'
 
     rhs_dicts = take n_dicts rhs_ids
     rhs_bndrs = rhs_tyvars ++ rhs_dicts
@@ -912,9 +910,9 @@ specDefn subst calls (fn, rhs)
         | not (equalLength xs ys) = pprPanic "my_zipEqual" (ppr xs $$ ppr ys $$ (ppr fn <+> ppr call_ts) $$ ppr rhs)
         | otherwise               = zipEqual doc xs ys
 
-dropInline :: CoreExpr -> (Bool, CoreExpr) 
-dropInline (Note InlineMe rhs) = (True, rhs)
-dropInline rhs                = (False, rhs)
+dropInline :: CoreExpr -> CoreExpr
+dropInline (Note InlineMe rhs) = rhs
+dropInline rhs                = rhs
 \end{code}
 
 %************************************************************************
@@ -1107,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)