X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fspecialise%2FSpecialise.lhs;h=006e06d15e99605149e8463bec211c4137f20b67;hb=6195332e01b8b6e6ddfa109af36e4f0798c1ea6a;hp=52eae0436b30b4f4bc94bff114c472f2e6519704;hpb=d069cec2bd92d4156aeab80f7eb1f222a82e4103;p=ghc-hetmet.git

diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs
index 52eae04..006e06d 100644
--- a/ghc/compiler/specialise/Specialise.lhs
+++ b/ghc/compiler/specialise/Specialise.lhs
@@ -9,11 +9,9 @@ module Specialise ( specProgram ) where
 #include "HsVersions.h"
 
 import CmdLineOpts	( DynFlags, DynFlag(..) )
-import Id		( Id, idName, idType, mkUserLocal,
-			  idSpecialisation, modifyIdInfo
-			)
+import Id		( Id, idName, idType, mkUserLocal ) 
 import TcType		( Type, mkTyVarTy, tcSplitSigmaTy, 
-			  tyVarsOfTypes, tyVarsOfTheta, 
+			  tyVarsOfTypes, tyVarsOfTheta, isClassPred,
 			  mkForAllTys, tcCmpType
 			)
 import Subst		( Subst, mkSubst, substTy, mkSubst, extendSubstList, mkInScopeSet,
@@ -26,10 +24,9 @@ import VarSet
 import VarEnv
 import CoreSyn
 import CoreUtils	( applyTypeToArgs )
-import CoreUnfold	( certainlyWillInline )
 import CoreFVs		( exprFreeVars, exprsFreeVars )
+import CoreTidy		( pprTidyIdRules )
 import CoreLint		( showPass, endPass )
-import PprCore		( pprCoreRules )
 import Rules		( addIdSpecialisations, lookupRule )
 
 import UniqSupply	( UniqSupply,
@@ -40,11 +37,13 @@ import Name		( nameOccName, mkSpecOcc, getSrcLoc )
 import FiniteMap
 import Maybes		( catMaybes, maybeToBool )
 import ErrUtils		( dumpIfSet_dyn )
+import BasicTypes	( Activation( AlwaysActive ) )
 import Bag
 import List		( partition )
-import Util		( zipEqual, zipWithEqual, cmpList )
+import Util		( zipEqual, zipWithEqual, cmpList, lengthIs,
+			  equalLength, lengthAtLeast, notNull )
 import Outputable
-
+import FastString
 
 infixr 9 `thenSM`
 \end{code}
@@ -587,7 +586,7 @@ specProgram dflags us binds
 	endPass dflags "Specialise" Opt_D_dump_spec binds'
 
 	dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
-		  (vcat (map dump_specs (concat (map bindersOf binds'))))
+		  (vcat (map pprTidyIdRules (concat (map bindersOf binds'))))
 
 	return binds'
   where
@@ -602,8 +601,6 @@ specProgram dflags us binds
     go (bind:binds) = go binds 				`thenSM` \ (binds', uds) ->
 		      specBind top_subst bind uds	`thenSM` \ (bind', uds') ->
 		      returnSM (bind' ++ binds', uds')
-
-dump_specs var = pprCoreRules var (idSpecialisation var)
 \end{code}
 
 %************************************************************************
@@ -787,10 +784,15 @@ specDefn :: Subst			-- Subst to use for RHS
 
 specDefn subst calls (fn, rhs)
 	-- The first case is the interesting one
-  |  n_tyvars == length rhs_tyvars	-- Rhs of fn's defn has right number of big lambdas
-  && n_dicts  <= length rhs_bndrs	-- and enough dict args
-  && not (null calls_for_me)		-- And there are some calls to specialise
-  && not (certainlyWillInline fn)	-- And it's not small
+  |  rhs_tyvars `lengthIs` n_tyvars 	-- Rhs of fn's defn has right number of big lambdas
+  && rhs_bndrs  `lengthAtLeast` n_dicts	-- and enough dict args
+  && notNull calls_for_me		-- And there are some calls to specialise
+
+-- At one time I tried not specialising small functions
+-- but sometimes there are big functions marked INLINE
+-- that we'd like to specialise.  In particular, dictionary
+-- functions, which Marcin is keen to inline
+--  && not (certainlyWillInline fn)	-- And it's not small
 					-- If it's small, it's better just to inline
 					-- it than to construct lots of specialisations
   =   -- Specialise the body of the function
@@ -822,7 +824,11 @@ specDefn subst calls (fn, rhs)
     n_tyvars	       = length tyvars
     n_dicts	       = length theta
 
-    (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_me, rhs') 		    = dropInline rhs
+    (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs'
+
     rhs_dicts = take n_dicts rhs_ids
     rhs_bndrs = rhs_tyvars ++ rhs_dicts
     body      = mkLams (drop n_dicts rhs_ids) rhs_body
@@ -839,7 +845,7 @@ specDefn subst calls (fn, rhs)
 	                UsageDetails, 			-- Usage details from specialised body
                 	CoreRule)			-- Info for the Id's SpecEnv
     spec_call (CallKey call_ts, (call_ds, call_fvs))
-      = ASSERT( length call_ts == n_tyvars && length call_ds == n_dicts )
+      = ASSERT( call_ts `lengthIs` n_tyvars  && call_ds `lengthIs` n_dicts )
 		-- Calls are only recorded for properly-saturated applications
 	
 	-- Suppose f's defn is 	f = /\ a b c d -> \ d1 d2 -> rhs	
@@ -879,22 +885,34 @@ specDefn subst calls (fn, rhs)
 	let
 		-- The rule to put in the function's specialisation is:
 		--	forall b,d, d1',d2'.  f t1 b t3 d d1' d2' = f1 b d  
-           spec_env_rule = Rule (_PK_ ("SPEC " ++ showSDoc (ppr fn)))
+           spec_env_rule = Rule (mkFastString ("SPEC " ++ showSDoc (ppr fn)))
+				AlwaysActive
 			        (poly_tyvars ++ rhs_dicts')
 				inst_args 
 				(mkTyApps (Var spec_f) (map mkTyVarTy poly_tyvars))
 
 		-- Add the { d1' = dx1; d2' = dx2 } usage stuff
 	   final_uds = foldr addDictBind rhs_uds (my_zipEqual "spec_call" rhs_dicts' call_ds)
+
+	-- NOTE: we don't add back in any INLINE pragma on the RHS, so even if
+	-- the original function said INLINE, the specialised copies won't.
+	-- The idea is that the point of inlining was precisely to specialise
+	-- the function at its call site, and that's not so important for the
+	-- specialised copies.   But it still smells like an ad hoc decision.
+
 	in
-        returnSM ((spec_f, spec_rhs),
+        returnSM ((spec_f, spec_rhs),	
 	          final_uds,
 		  spec_env_rule)
 
       where
 	my_zipEqual doc xs ys 
-	 | length xs /= length ys = pprPanic "my_zipEqual" (ppr xs $$ ppr ys $$ (ppr fn <+> ppr call_ts) $$ ppr rhs)
-	 | otherwise		  = zipEqual doc xs ys
+	 | not (equalLength xs ys) = pprPanic "my_zipEqual" (ppr xs $$ ppr ys $$ (ppr fn <+> ppr call_ts) $$ ppr rhs)
+	 | otherwise		   = zipEqual doc xs ys
+
+dropInline :: CoreExpr -> (Bool, CoreExpr) 
+dropInline (Note InlineMe rhs) = (True, rhs)
+dropInline rhs		       = (False, rhs)
 \end{code}
 
 %************************************************************************
@@ -983,9 +1001,13 @@ callDetailsToList calls = [ (id,tys,dicts)
 
 mkCallUDs subst f args 
   | null theta
-  || length spec_tys /= n_tyvars
-  || length dicts    /= n_dicts
-  || maybeToBool (lookupRule (substInScope subst) f args)
+  || not (all isClassPred theta)	
+	-- Only specialise if all overloading is on class params. 
+	-- In ptic, with implicit params, the type args
+	-- *don't* say what the value of the implicit param is!
+  || not (spec_tys `lengthIs` n_tyvars)
+  || not ( dicts   `lengthIs` n_dicts)
+  || maybeToBool (lookupRule (\act -> True) (substInScope subst) f args)
 	-- There's already a rule covering this call.  A typical case
 	-- is where there's an explicit user-provided rule.  Then
 	-- we don't want to create a specialised version 
@@ -1005,10 +1027,9 @@ mkCallUDs subst f args
     spec_tys = [mk_spec_ty tv ty | (tv, Type ty) <- tyvars `zip` args]
     dicts    = [dict_expr | (_, dict_expr) <- theta `zip` (drop n_tyvars args)]
     
-    mk_spec_ty tyvar ty | tyvar `elemVarSet` constrained_tyvars
-			= Just ty
-			| otherwise
-			= Nothing
+    mk_spec_ty tyvar ty 
+	| tyvar `elemVarSet` constrained_tyvars = Just ty
+	| otherwise				= Nothing
 
 ------------------------------------------------------------			
 plusUDs :: UsageDetails -> UsageDetails -> UsageDetails
@@ -1098,12 +1119,6 @@ splitUDs bndrs uds@(MkUD {dict_binds = orig_dbs,
 %************************************************************************
 
 \begin{code}
-lookupId:: IdEnv Id -> Id -> Id
-lookupId env id = case lookupVarEnv env id of
-			Nothing  -> id
-			Just id' -> id'
-
-----------------------------------------
 type SpecM a = UniqSM a
 
 thenSM    = thenUs