X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fspecialise%2FSpecialise.lhs;h=4d8efdd8c5c2c55dae5cf832fb3f16af9c5906cc;hp=4a1cc4c37bc2129165f96134fb3c6b8ca9f5a9ad;hb=e79c9ce01d0ce4412bd4bcd99c8c728a6a2ec569;hpb=6ccd648bf016aa9cfa13612f0f19be6badea16d1

diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs
index 4a1cc4c..4d8efdd 100644
--- 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}
 
 %************************************************************************
 %*									*