X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fspecialise%2FSpecConstr.lhs;h=ab7ccd41d293e4baaea235338c301d44168ee6b8;hb=9af77fa423926fbda946b31e174173d0ec5ebac8;hp=7f2246ad7b3d4c2c2c970fd544aa6caf660b357c;hpb=b55b1f59999296e208bc1005a580b51fd9ee5dbb;p=ghc-hetmet.git

diff --git a/ghc/compiler/specialise/SpecConstr.lhs b/ghc/compiler/specialise/SpecConstr.lhs
index 7f2246a..ab7ccd4 100644
--- a/ghc/compiler/specialise/SpecConstr.lhs
+++ b/ghc/compiler/specialise/SpecConstr.lhs
@@ -12,13 +12,14 @@ module SpecConstr(
 
 import CoreSyn
 import CoreLint		( showPass, endPass )
-import CoreUtils	( exprType, eqExpr )
+import CoreUtils	( exprType, eqExpr, mkPiTypes )
 import CoreFVs 		( exprsFreeVars )
+import CoreTidy		( pprTidyIdRules )
+import WwLib		( mkWorkerArgs )
 import DataCon		( dataConRepArity )
 import Type		( tyConAppArgs )
-import PprCore		( pprCoreRules, pprCoreRule )
-import Id		( Id, idName, idType, idSpecialisation,
-			  isDataConId_maybe,
+import Id		( Id, idName, idType, 
+			  isDataConId_maybe, 
 			  mkUserLocal, mkSysLocal )
 import Var		( Var )
 import VarEnv
@@ -28,14 +29,15 @@ import Rules		( addIdSpecialisations )
 import OccName		( mkSpecOcc )
 import ErrUtils		( dumpIfSet_dyn )
 import CmdLineOpts	( DynFlags, DynFlag(..) )
+import BasicTypes	( Activation(..) )
 import Outputable
 
 import Maybes		( orElse )
-import Util		( mapAccumL )
+import Util		( mapAccumL, lengthAtLeast, notNull )
 import List		( nubBy, partition )
 import UniqSupply
 import Outputable
-import UniqFM		( ufmToList )
+import FastString
 \end{code}
 
 -----------------------------------------------------
@@ -180,7 +182,7 @@ specConstrProgram dflags us binds
 	endPass dflags "SpecConstr" 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
@@ -188,8 +190,6 @@ specConstrProgram dflags us binds
     go env (bind:binds) = scBind env bind 	`thenUs` \ (env', _, bind') ->
 			  go env' binds 	`thenUs` \ binds' ->
 			  returnUs (bind' : binds')
-
-dump_specs var = pprCoreRules var (idSpecialisation var)
 \end{code}
 
 
@@ -375,7 +375,7 @@ scExpr env e@(App _ _)
 ----------------------
 scBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, ScUsage, CoreBind)
 scBind env (Rec [(fn,rhs)])
-  | not (null val_bndrs)
+  | notNull val_bndrs
   = scExpr env_fn_body body		`thenUs` \ (usg, body') ->
     let
 	SCU { calls = calls, occs = occs } = usg
@@ -432,7 +432,7 @@ specialise env fn bndrs body (SCU {calls=calls, occs=occs})
 	good_calls :: [[CoreArg]]
 	good_calls = [ pats
 		     | (con_env, call_args) <- all_calls,
-		       length call_args >= n_bndrs,	    -- App is saturated
+		       call_args `lengthAtLeast` n_bndrs,	    -- App is saturated
 		       let call = (bndrs `zip` call_args),
 		       any (good_arg con_env occs) call,    -- At least one arg is a constr app
 		       let (_, pats) = argsToPats con_env us call_args
@@ -489,8 +489,8 @@ spec_one :: ScEnv
 	    f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
 -}
 
-spec_one env fn rhs (pats, n)
-  = getUniqueUs 			`thenUs` \ spec_uniq ->
+spec_one env fn rhs (pats, rule_number)
+  = getUniqueUs 		`thenUs` \ spec_uniq ->
     let 
 	fn_name      = idName fn
 	fn_loc       = nameSrcLoc fn_name
@@ -502,13 +502,31 @@ spec_one env fn rhs (pats, n)
 		-- variable may mention a type variable
 	(tvs, ids)   = partition isTyVar vars_to_bind
 	bndrs  	     = tvs ++ ids
+	spec_body    = mkApps rhs pats
+	body_ty	     = exprType spec_body
+	
+	(spec_lam_args, spec_call_args) = mkWorkerArgs bndrs body_ty
+		-- Usual w/w hack to avoid generating 
+		-- a spec_rhs of unlifted type and no args
 	
-	rule_name = _PK_ ("SC:" ++ showSDoc (ppr fn <> int n))
-	spec_rhs  = mkLams bndrs (mkApps rhs pats)
-	spec_id   = mkUserLocal spec_occ spec_uniq (exprType spec_rhs) fn_loc
-	rule      = Rule rule_name bndrs pats (mkVarApps (Var spec_id) bndrs)
+	rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number))
+	spec_rhs  = mkLams spec_lam_args spec_body
+	spec_id   = mkUserLocal spec_occ spec_uniq (mkPiTypes spec_lam_args body_ty) fn_loc
+	rule      = Rule rule_name specConstrActivation
+			 bndrs pats (mkVarApps (Var spec_id) spec_call_args)
     in
     returnUs (rule, (spec_id, spec_rhs))
+
+-- In which phase should the specialise-constructor rules be active?
+-- Originally I made them always-active, but Manuel found that
+-- this defeated some clever user-written rules.  So Plan B
+-- is to make them active only in Phase 0; after all, currently,
+-- the specConstr transformation is only run after the simplifier
+-- has reached Phase 0.  In general one would want it to be 
+-- flag-controllable, but for now I'm leaving it baked in
+--					[SLPJ Oct 01]
+specConstrActivation :: Activation
+specConstrActivation = ActiveAfter 0	-- Baked in; see comments above
 \end{code}
 
 %************************************************************************
@@ -542,7 +560,7 @@ argToPat env us (Var v)	-- Don't uniqify existing vars,
   = (us, Var v)		-- so that we can spot when we pass them twice
 
 argToPat env us arg
-  = (us1, Var (mkSysLocal SLIT("sc") (uniqFromSupply us2) (exprType arg)))
+  = (us1, Var (mkSysLocal FSLIT("sc") (uniqFromSupply us2) (exprType arg)))
   where
     (us1,us2) = splitUniqSupply us
 
@@ -565,7 +583,7 @@ is_con_app_maybe env (Lit lit)
 is_con_app_maybe env expr
   = case collectArgs expr of
 	(Var fun, args) | Just con <- isDataConId_maybe fun,
-			  length args >= dataConRepArity con
+			  args `lengthAtLeast` dataConRepArity con
 		-- Might be > because the arity excludes type args
 		        -> Just (DataAlt con,args)