X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fspecialise%2FSpecConstr.lhs;h=7463c9bb0adf890f181e18770df9d9b9e80aa79f;hb=78b72ed1e0ffab668e0d4bb31657942970515e4f;hp=c79ec11767bdf3f337935309ba4dbea39a0a3e2f;hpb=d254a44b8392ff0a4327f1916ef921887ce78769;p=ghc-hetmet.git

diff --git a/ghc/compiler/specialise/SpecConstr.lhs b/ghc/compiler/specialise/SpecConstr.lhs
index c79ec11..7463c9b 100644
--- a/ghc/compiler/specialise/SpecConstr.lhs
+++ b/ghc/compiler/specialise/SpecConstr.lhs
@@ -12,23 +12,23 @@ module SpecConstr(
 
 import CoreSyn
 import CoreLint		( showPass, endPass )
-import CoreUtils	( exprType, eqExpr, mkPiTypes )
+import CoreUtils	( exprType, tcEqExpr, mkPiTypes )
 import CoreFVs 		( exprsFreeVars )
-import CoreTidy		( pprTidyIdRules )
+import CoreTidy		( tidyRules )
+import PprCore		( pprRules )
 import WwLib		( mkWorkerArgs )
 import DataCon		( dataConRepArity )
 import Type		( tyConAppArgs )
-import Id		( Id, idName, idType, idSpecialisation,
-			  isDataConId_maybe, 
+import Id		( Id, idName, idType, isDataConWorkId_maybe, 
 			  mkUserLocal, mkSysLocal )
 import Var		( Var )
 import VarEnv
 import VarSet
 import Name		( nameOccName, nameSrcLoc )
-import Rules		( addIdSpecialisations )
+import Rules		( addIdSpecialisations, mkLocalRule, rulesOfBinds )
 import OccName		( mkSpecOcc )
 import ErrUtils		( dumpIfSet_dyn )
-import CmdLineOpts	( DynFlags, DynFlag(..) )
+import DynFlags	( DynFlags, DynFlag(..) )
 import BasicTypes	( Activation(..) )
 import Outputable
 
@@ -37,6 +37,7 @@ import Util		( mapAccumL, lengthAtLeast, notNull )
 import List		( nubBy, partition )
 import UniqSupply
 import Outputable
+import FastString
 \end{code}
 
 -----------------------------------------------------
@@ -181,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 pprTidyIdRules (concat (map bindersOf binds'))))
+		  (pprRules (tidyRules emptyTidyEnv (rulesOfBinds binds')))
 
 	return binds'
   where
@@ -334,11 +335,11 @@ scExpr env (Note n e) = scExpr env e	`thenUs` \ (usg,e') ->
 scExpr env (Lam b e)  = scExpr (extendBndr env b) e	`thenUs` \ (usg,e') ->
 			returnUs (usg, Lam b e')
 
-scExpr env (Case scrut b alts) 
+scExpr env (Case scrut b ty alts) 
   = sc_scrut scrut		`thenUs` \ (scrut_usg, scrut') ->
     mapAndUnzipUs sc_alt alts	`thenUs` \ (alts_usgs, alts') ->
     returnUs (combineUsages alts_usgs `combineUsage` scrut_usg,
-	      Case scrut' b alts')
+	      Case scrut' b ty alts')
   where
     sc_scrut e@(Var v) = returnUs (varUsage env v CaseScrut, e)
     sc_scrut e	       = scExpr env e
@@ -441,7 +442,7 @@ specialise env fn bndrs body (SCU {calls=calls, occs=occs})
 		  (nubBy same_call good_calls `zip` [1..])
   where
     n_bndrs  = length bndrs
-    same_call as1 as2 = and (zipWith eqExpr as1 as2)
+    same_call as1 as2 = and (zipWith tcEqExpr as1 as2)
 
 ---------------------
 good_arg :: ConstrEnv -> IdEnv ArgOcc -> (CoreBndr, CoreArg) -> Bool
@@ -508,11 +509,11 @@ spec_one env fn rhs (pats, rule_number)
 		-- 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))
+	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)
+	rule_rhs  = mkVarApps (Var spec_id) spec_call_args
+	rule      = mkLocalRule rule_name specConstrActivation fn_name bndrs pats rule_rhs
     in
     returnUs (rule, (spec_id, spec_rhs))
 
@@ -581,7 +582,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,
+	(Var fun, args) | Just con <- isDataConWorkId_maybe fun,
 			  args `lengthAtLeast` dataConRepArity con
 		-- Might be > because the arity excludes type args
 		        -> Just (DataAlt con,args)