X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Fspecialise%2FSpecConstr.lhs;h=6622764ca91693b95000fab97eaab630107b32b0;hb=0171936c9092666692c69a7f93fa75af976330cb;hp=824b1e55dff48d0f8c93935b916b0ab412035339;hpb=9e93335020e64a811dbbb223e1727c76933a93ae;p=ghc-hetmet.git

diff --git a/ghc/compiler/specialise/SpecConstr.lhs b/ghc/compiler/specialise/SpecConstr.lhs
index 824b1e5..6622764 100644
--- a/ghc/compiler/specialise/SpecConstr.lhs
+++ b/ghc/compiler/specialise/SpecConstr.lhs
@@ -12,8 +12,9 @@ module SpecConstr(
 
 import CoreSyn
 import CoreLint		( showPass, endPass )
-import CoreUtils	( exprType, eqExpr )
+import CoreUtils	( exprType, eqExpr, mkPiTypes )
 import CoreFVs 		( exprsFreeVars )
+import WwLib		( mkWorkerArgs )
 import DataCon		( dataConRepArity )
 import Type		( tyConAppArgs )
 import PprCore		( pprCoreRules )
@@ -489,8 +490,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 +503,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
 	
-	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 AlwaysActive bndrs pats (mkVarApps (Var spec_id) bndrs)
+	(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 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 +561,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