X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fspecialise%2FSpecConstr.lhs;h=7eb3529d4e191930eaa03d86977c506d151d0fce;hb=baa26ed728b6164f2827a97133306131aa89ed6f;hp=1897e1a01d9bce3cbb29c67c54dcf1574f5bc0f8;hpb=207151a384d187c29baa5bf3ec2405c27d58c1df;p=ghc-hetmet.git

diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs
index 1897e1a..7eb3529 100644
--- a/compiler/specialise/SpecConstr.lhs
+++ b/compiler/specialise/SpecConstr.lhs
@@ -22,11 +22,10 @@ import CoreUtils
 import CoreUnfold	( couldBeSmallEnoughToInline )
 import CoreLint		( showPass, endPass )
 import CoreFVs 		( exprsFreeVars )
-import CoreTidy		( tidyRules )
-import PprCore		( pprRules )
 import WwLib		( mkWorkerArgs )
 import DataCon		( dataConRepArity, dataConUnivTyVars )
 import Coercion	
+import Rules
 import Type		hiding( substTy )
 import Id		( Id, idName, idType, isDataConWorkId_maybe, idArity,
 			  mkUserLocal, mkSysLocal, idUnfolding, isLocalId )
@@ -34,7 +33,6 @@ import Var
 import VarEnv
 import VarSet
 import Name
-import Rules		( addIdSpecialisations, mkLocalRule, rulesOfBinds )
 import OccName		( mkSpecOcc )
 import ErrUtils		( dumpIfSet_dyn )
 import DynFlags		( DynFlags(..), DynFlag(..) )
@@ -463,7 +461,7 @@ specConstrProgram dflags us binds
 	endPass dflags "SpecConstr" Opt_D_dump_spec binds'
 
 	dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
-		  (pprRules (tidyRules emptyTidyEnv (rulesOfBinds binds')))
+		      (pprRulesForUser (rulesOfBinds binds'))
 
 	return binds'
   where
@@ -498,9 +496,9 @@ data ScEnv = SCE { sc_size  :: Maybe Int,	-- Size threshold
 
 ---------------------
 -- As we go, we apply a substitution (sc_subst) to the current term
-type InExpr = CoreExpr		-- *Before* applying the subst
+type InExpr = CoreExpr		-- _Before_ applying the subst
 
-type OutExpr = CoreExpr		-- *After* applying the subst
+type OutExpr = CoreExpr		-- _After_ applying the subst
 type OutId   = Id
 type OutVar  = Var
 
@@ -509,12 +507,12 @@ type HowBoundEnv = VarEnv HowBound	-- Domain is OutVars
 
 ---------------------
 type ValueEnv = IdEnv Value		-- Domain is OutIds
-data Value    = ConVal AltCon [CoreArg]	-- *Saturated* constructors
+data Value    = ConVal AltCon [CoreArg]	-- _Saturated_ constructors
 	      | LambdaVal		-- Inlinable lambdas or PAPs
 
 instance Outputable Value where
    ppr (ConVal con args) = ppr con <+> interpp'SP args
-   ppr LambdaVal	 = ptext SLIT("<Lambda>")
+   ppr LambdaVal	 = ptext (sLit "<Lambda>")
 
 ---------------------
 initScEnv :: DynFlags -> ScEnv
@@ -685,10 +683,10 @@ A pattern binds b, x::a, y::b, z::b->a, but not 'a'!
 -}
 
 instance Outputable ArgOcc where
-  ppr (ScrutOcc xs) = ptext SLIT("scrut-occ") <> ppr xs
-  ppr UnkOcc 	    = ptext SLIT("unk-occ")
-  ppr BothOcc 	    = ptext SLIT("both-occ")
-  ppr NoOcc    	    = ptext SLIT("no-occ")
+  ppr (ScrutOcc xs) = ptext (sLit "scrut-occ") <> ppr xs
+  ppr UnkOcc 	    = ptext (sLit "unk-occ")
+  ppr BothOcc 	    = ptext (sLit "both-occ")
+  ppr NoOcc    	    = ptext (sLit "no-occ")
 
 -- Experimentally, this vesion of combineOcc makes ScrutOcc "win", so
 -- that if the thing is scrutinised anywhere then we get to see that
@@ -707,7 +705,7 @@ combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]
 combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys
 
 setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage
--- *Overwrite* the occurrence info for the scrutinee, if the scrutinee 
+-- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee
 -- is a variable, and an interesting variable
 setScrutOcc env usg (Cast e _) occ = setScrutOcc env usg e occ
 setScrutOcc env usg (Note _ e) occ = setScrutOcc env usg e occ
@@ -796,7 +794,7 @@ scExpr' env (Case scrut b ty alts)
 	   ; let (usg', arg_occs) = lookupOccs usg bs'
 		 scrut_occ = case con of
 				DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)
-				_ofther	   -> ScrutOcc emptyUFM
+				_      	   -> ScrutOcc emptyUFM
 	   ; return (usg', scrut_occ, (con,bs',rhs')) }
 
 scExpr' env (Let (NonRec bndr rhs) body)
@@ -1024,13 +1022,13 @@ specialise env bind_calls (fn, arg_bndrs, body, arg_occs)
 	; case sc_count env of
 	    Just max | spec_count' > max
 		-> pprTrace "SpecConstr: too many specialisations for one function (see -fspec-constr-count):" 
-			 (vcat [ptext SLIT("Function:") <+> ppr fn,
-				ptext SLIT("Specialisations:") <+> ppr (pats ++ [p | OS p _ _ _ <- specs])])
+			 (vcat [ptext (sLit "Function:") <+> ppr fn,
+				ptext (sLit "Specialisations:") <+> ppr (pats ++ [p | OS p _ _ _ <- specs])])
 			 return (nullUsage, spec_info)
 
-	    _normal_case -> do
-				
-	{ (spec_usgs, new_specs) <- mapAndUnzipM (spec_one env fn arg_bndrs body)
+	    _normal_case -> do {
+
+	  (spec_usgs, new_specs) <- mapAndUnzipM (spec_one env fn arg_bndrs body)
 					         (pats `zip` [spec_count..])
 
 	; let spec_usg = combineUsages spec_usgs
@@ -1218,7 +1216,7 @@ argToPat in_scope val_env (Cast arg co) arg_occ
 	  else do
 	{ -- Make a wild-card pattern for the coercion
 	  uniq <- getUniqueUs
-	; let co_name = mkSysTvName uniq FSLIT("sg")
+	; let co_name = mkSysTvName uniq (fsLit "sg")
 	      co_var = mkCoVar co_name (mkCoKind ty1 ty2)
 	; return (interesting, Cast arg' (mkTyVarTy co_var)) } }
 
@@ -1288,7 +1286,7 @@ argToPat _in_scope _val_env arg _arg_occ
 
 wildCardPat :: Type -> UniqSM (Bool, CoreArg)
 wildCardPat ty = do { uniq <- getUniqueUs
-		    ; let id = mkSysLocal FSLIT("sc") uniq ty
+		    ; let id = mkSysLocal (fsLit "sc") uniq ty
 		    ; return (False, Var id) }
 
 argsToPats :: InScopeSet -> ValueEnv