Add the notion of "constructor-like" Ids for rule-matching

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

diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs
index 4a1cc4c..015332f 100644 (file)
--- a/compiler/specialise/Specialise.lhs
+++ b/compiler/specialise/Specialise.lhs
@@ -15,8 +15,8 @@ module Specialise ( specProgram ) where
 #include "HsVersions.h"
 
 import Id              ( Id, idName, idType, mkUserLocal, idCoreRules,
-                         idInlinePragma, setInlinePragma, setIdUnfolding,
-                         isLocalId, idUnfolding ) 
+                         idInlineActivation, setInlineActivation, setIdUnfolding,
+                          isLocalId ) 
 import TcType          ( Type, mkTyVarTy, tcSplitSigmaTy, 
                          tyVarsOfTypes, tyVarsOfTheta, isClassPred,
                          tcCmpType, isUnLiftedType
@@ -26,7 +26,7 @@ import CoreSubst      ( Subst, mkEmptySubst, extendTvSubstList, lookupIdSubst,
                          cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs,
                          extendIdSubst
                        ) 
-import CoreUnfold      ( mkUnfolding, mkInlineRule )
+import CoreUnfold      ( mkUnfolding )
 import SimplUtils      ( interestingArg )
 import Var             ( DictId )
 import VarSet
@@ -43,7 +43,6 @@ import Name
 import MkId            ( voidArgId, realWorldPrimId )
 import FiniteMap
 import Maybes          ( catMaybes, isJust )
-import BasicTypes      ( Arity )
 import Bag
 import Util
 import Outputable
@@ -830,16 +829,12 @@ specDefn subst calls fn rhs
     (tyvars, theta, _) = tcSplitSigmaTy fn_type
     n_tyvars          = length tyvars
     n_dicts           = length theta
-    inline_prag        = idInlinePragma fn
+    inline_act         = idInlineActivation fn
 
-       -- Figure out whether the function has an INLINE pragma
-       -- See Note [Inline specialisations]
-    fn_has_inline_rule :: Maybe Arity   -- Gives arity of the *specialised* inline rule
-    fn_has_inline_rule = case idUnfolding fn of
-                          InlineRule { uf_arity = arity } -> Just (arity - n_dicts)
-                          _other                          -> Nothing
-
-    (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs
+       -- It's important that we "see past" any INLINE pragma
+       -- else we'll fail to specialise an INLINE thing
+    (inline_rhs, rhs_inside) = dropInline rhs
+    (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs_inside
 
     rhs_dict_ids = take n_dicts rhs_ids
     body         = mkLams (drop n_dicts rhs_ids) rhs_body
@@ -918,7 +913,7 @@ 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 
@@ -927,13 +922,10 @@ specDefn subst calls fn rhs
                -- Add the { d1' = dx1; d2' = dx2 } usage stuff
                final_uds = foldr addDictBind rhs_uds dx_binds
 
-               -- See Note [Inline specialisations]
-               final_spec_f | Just spec_arity <- fn_has_inline_rule
-                            = spec_f `setInlinePragma` inline_prag
-                                     `setIdUnfolding`  mkInlineRule spec_rhs spec_arity
-                            | otherwise 
-                            = spec_f
-          ; return (Just ((final_spec_f, spec_rhs), final_uds, spec_env_rule)) } }
+               spec_pr | inline_rhs = (spec_f `setInlineActivation` inline_act, Note InlineMe spec_rhs)
+                       | otherwise  = (spec_f,                               spec_rhs)
+
+          ; return (Just (spec_pr, final_uds, spec_env_rule)) } }
       where
        my_zipEqual xs ys zs
         | debugIsOn && not (equalLength xs ys && equalLength ys zs)
@@ -1076,7 +1068,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,
@@ -1098,6 +1091,11 @@ specialised version.
 A case in point is dictionary functions, which are current marked
 INLINE, but which are worth specialising.
 
+\begin{code}
+dropInline :: CoreExpr -> (Bool, CoreExpr)
+dropInline (Note InlineMe rhs) = (True,  rhs)
+dropInline rhs                = (False, rhs)
+\end{code}
 
 %************************************************************************
 %*                                                                     *