Major patch to fix reporting of unused imports

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

diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs
index 4d8efdd..64d0cdd 100644 (file)
--- a/compiler/specialise/Specialise.lhs
+++ b/compiler/specialise/Specialise.lhs
@@ -14,9 +14,9 @@ module Specialise ( specProgram ) where
 
 #include "HsVersions.h"
 
-import Id              ( Id, idName, idType, mkUserLocal, idCoreRules,
-                         idInlinePragma, setInlinePragma, setIdUnfolding,
-                         isLocalId ) 
+import Id              ( Id, idName, idType, mkUserLocal, idCoreRules, idUnfolding,
+                         idInlineActivation, setInlineActivation, setIdUnfolding,
+                          isLocalId, isDataConWorkId, idArity, setIdArity ) 
 import TcType          ( Type, mkTyVarTy, tcSplitSigmaTy, 
                          tyVarsOfTypes, tyVarsOfTheta, isClassPred,
                          tcCmpType, isUnLiftedType
@@ -27,7 +27,6 @@ import CoreSubst      ( Subst, mkEmptySubst, extendTvSubstList, lookupIdSubst,
                          extendIdSubst
                        ) 
 import CoreUnfold      ( mkUnfolding )
-import SimplUtils      ( interestingArg )
 import Var             ( DictId )
 import VarSet
 import VarEnv
@@ -826,10 +825,11 @@ specDefn subst calls fn rhs
   
   where
     fn_type           = idType fn
+    fn_arity          = idArity fn
     (tyvars, theta, _) = tcSplitSigmaTy fn_type
     n_tyvars          = length tyvars
     n_dicts           = length theta
-    inline_prag        = idInlinePragma fn
+    inline_act         = idInlineActivation fn
 
        -- It's important that we "see past" any INLINE pragma
        -- else we'll fail to specialise an INLINE thing
@@ -906,6 +906,10 @@ specDefn subst calls fn rhs
                 spec_id_ty = mkPiTypes lam_args body_ty
        
            ; spec_f <- newSpecIdSM fn spec_id_ty
+          ; let spec_f_w_arity = setIdArity spec_f (max 0 (fn_arity - n_dicts))
+               -- Adding arity information just propagates it a bit faster
+               -- See Note [Arity decrease] in Simplify
+
            ; (spec_rhs, rhs_uds) <- specExpr rhs_subst2 (mkLams lam_args body)
           ; let
                -- The rule to put in the function's specialisation is:
@@ -913,17 +917,17 @@ specDefn subst calls fn rhs
                rule_name = mkFastString ("SPEC " ++ showSDoc (ppr fn <+> ppr spec_ty_args))
                spec_env_rule = mkLocalRule
                                  rule_name
-                                 inline_prag   -- Note [Auto-specialisation and RULES]
+                                 inline_act    -- Note [Auto-specialisation and RULES]
                                  (idName fn)
                                  (poly_tyvars ++ inst_dict_ids)
                                  inst_args 
-                                 (mkVarApps (Var spec_f) app_args)
+                                 (mkVarApps (Var spec_f_w_arity) app_args)
 
                -- Add the { d1' = dx1; d2' = dx2 } usage stuff
                final_uds = foldr addDictBind rhs_uds dx_binds
 
-               spec_pr | inline_rhs = (spec_f `setInlinePragma` inline_prag, Note InlineMe spec_rhs)
-                       | otherwise  = (spec_f,                               spec_rhs)
+               spec_pr | inline_rhs = (spec_f_w_arity `setInlineActivation` inline_act, Note InlineMe spec_rhs)
+                       | otherwise  = (spec_f_w_arity,                                  spec_rhs)
 
           ; return (Just (spec_pr, final_uds, spec_env_rule)) } }
       where
@@ -1068,7 +1072,8 @@ Note [Inline specialisations]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We transfer to the specialised function any INLINE stuff from the
 original.  This means (a) the Activation in the IdInfo, and (b) any
-InlineMe on the RHS.  
+InlineMe on the RHS.  We do not, however, transfer the RuleMatchInfo
+since we do not expect the specialisation to occur in rewrite rules.
 
 This is a change (Jun06).  Previously the idea is that the point of
 inlining was precisely to specialise the function at its call site,
@@ -1194,13 +1199,13 @@ mkCallUDs f args
        --  *don't* say what the value of the implicit param is!
   || not (spec_tys `lengthIs` n_tyvars)
   || not ( dicts   `lengthIs` n_dicts)
-  || not (any interestingArg dicts)    -- Note [Interesting dictionary arguments]
+  || not (any interestingDict dicts)   -- Note [Interesting dictionary arguments]
   -- See also Note [Specialisations already covered]
-  = -- pprTrace "mkCallUDs: discarding" (vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts, ppr (map interestingArg dicts)]) 
+  = -- pprTrace "mkCallUDs: discarding" (vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts, ppr (map interestingDict dicts)]) 
     emptyUDs   -- Not overloaded, or no specialisation wanted
 
   | otherwise
-  = -- pprTrace "mkCallUDs: keeping" (vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts, ppr (map interestingArg dicts)]) 
+  = -- pprTrace "mkCallUDs: keeping" (vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts, ppr (map interestingDict dicts)]) 
     singleCall f spec_tys dicts
   where
     (tyvars, theta, _) = tcSplitSigmaTy (idType f)
@@ -1224,9 +1229,19 @@ There really is not much point in specialising f wrt the dictionary d,
 because the code for the specialised f is not improved at all, because
 d is lambda-bound.  We simply get junk specialisations.
 
-We re-use the function SimplUtils.interestingArg function to determine
-what sort of dictionary arguments have *some* information in them.
+What is "interesting"?  Just that it has *some* structure.
 
+\begin{code}
+interestingDict :: CoreExpr -> Bool
+-- A dictionary argument is interesting if it has *some* structure
+interestingDict (Var v) =  hasSomeUnfolding (idUnfolding v)
+                       || isDataConWorkId v
+interestingDict (Type _)         = False
+interestingDict (App fn (Type _)) = interestingDict fn
+interestingDict (Note _ a)       = interestingDict a
+interestingDict (Cast e _)       = interestingDict e
+interestingDict _                 = True
+\end{code}
 
 \begin{code}
 plusUDs :: UsageDetails -> UsageDetails -> UsageDetails