Rollback INLINE patches

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

diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs
index 4a1cc4c..4d8efdd 100644 (file)
--- a/compiler/specialise/Specialise.lhs
+++ b/compiler/specialise/Specialise.lhs
@@ -16,7 +16,7 @@ module Specialise ( specProgram ) where
 
 import Id              ( Id, idName, idType, mkUserLocal, idCoreRules,
                          idInlinePragma, setInlinePragma, setIdUnfolding,
-                         isLocalId, idUnfolding ) 
+                         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
@@ -832,14 +831,10 @@ specDefn subst calls fn rhs
     n_dicts           = length theta
     inline_prag        = idInlinePragma 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
@@ -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 `setInlinePragma` inline_prag, 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)
@@ -1098,6 +1090,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}
 
 %************************************************************************
 %*                                                                     *