X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fspecialise%2FSpecialise.lhs;h=037db7a71deb02ecbd35345811c5101fd3645e9d;hb=79b22beb4d2eca1877d99d55838ba6ce69658405;hp=c4a4936f512e3527b39bc35a990e6be288c1f78d;hpb=baa26ed728b6164f2827a97133306131aa89ed6f;p=ghc-hetmet.git

diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs
index c4a4936..037db7a 100644
--- a/compiler/specialise/Specialise.lhs
+++ b/compiler/specialise/Specialise.lhs
@@ -14,10 +14,9 @@ module Specialise ( specProgram ) where
 
 #include "HsVersions.h"
 
-import DynFlags	( DynFlags, DynFlag(..) )
 import Id		( Id, idName, idType, mkUserLocal, idCoreRules,
-			  idInlinePragma, setInlinePragma, setIdUnfolding,
-			  isLocalId ) 
+			  idInlineActivation, setInlineActivation, setIdUnfolding,
+                          isLocalId, idArity, setIdArity ) 
 import TcType		( Type, mkTyVarTy, tcSplitSigmaTy, 
 			  tyVarsOfTypes, tyVarsOfTheta, isClassPred,
 			  tcCmpType, isUnLiftedType
@@ -36,7 +35,6 @@ import CoreSyn
 import Rules
 import CoreUtils	( exprIsTrivial, applyTypeToArgs, mkPiTypes )
 import CoreFVs		( exprFreeVars, exprsFreeVars, idFreeVars )
-import CoreLint		( showPass, endPass )
 import UniqSupply	( UniqSupply,
 			  UniqSM, initUs_,
 			  MonadUnique(..)
@@ -45,7 +43,6 @@ import Name
 import MkId		( voidArgId, realWorldPrimId )
 import FiniteMap
 import Maybes		( catMaybes, isJust )
-import ErrUtils		( dumpIfSet_dyn )
 import Bag
 import Util
 import Outputable
@@ -578,20 +575,9 @@ Hence, the invariant is this:
 %************************************************************************
 
 \begin{code}
-specProgram :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]
-specProgram dflags us binds = do
-   
-	showPass dflags "Specialise"
-
-	let binds' = initSM us (do (binds', uds') <- go binds
-			           return (dumpAllDictBinds uds' binds'))
-
-	endPass dflags "Specialise" Opt_D_dump_spec binds'
-
-	dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
-		      (pprRulesForUser (rulesOfBinds binds'))
-
-	return binds'
+specProgram :: UniqSupply -> [CoreBind] -> [CoreBind]
+specProgram us binds = initSM us (do (binds', uds') <- go binds
+			             return (dumpAllDictBinds uds' binds'))
   where
 	-- We need to start with a Subst that knows all the things
 	-- that are in scope, so that the substitution engine doesn't
@@ -840,10 +826,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
@@ -920,6 +907,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:
@@ -927,17 +918,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
@@ -1082,7 +1073,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,