Completely new treatment of INLINE pragmas (big patch)

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

diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs
index 4d8efdd..4a1cc4c 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 ) 
+                         isLocalId, idUnfolding ) 
 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 )
+import CoreUnfold      ( mkUnfolding, mkInlineRule )
 import SimplUtils      ( interestingArg )
 import Var             ( DictId )
 import VarSet
@@ -43,6 +43,7 @@ import Name
 import MkId            ( voidArgId, realWorldPrimId )
 import FiniteMap
 import Maybes          ( catMaybes, isJust )
+import BasicTypes      ( Arity )
 import Bag
 import Util
 import Outputable
@@ -831,10 +832,14 @@ specDefn subst calls fn rhs
     n_dicts           = length theta
     inline_prag        = idInlinePragma fn
 
-       -- 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
+       -- 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
 
     rhs_dict_ids = take n_dicts rhs_ids
     body         = mkLams (drop n_dicts rhs_ids) rhs_body
@@ -922,10 +927,13 @@ specDefn subst calls fn rhs
                -- 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)
-
-          ; return (Just (spec_pr, final_uds, spec_env_rule)) } }
+               -- 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)) } }
       where
        my_zipEqual xs ys zs
         | debugIsOn && not (equalLength xs ys && equalLength ys zs)
@@ -1090,11 +1098,6 @@ 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}
 
 %************************************************************************
 %*                                                                     *