Print tidy rules in user style, to avoid gratuitous uniques

[ghc-hetmet.git] / compiler / specialise / SpecConstr.lhs

diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs
index 1897e1a..a52de10 100644 (file)
--- a/compiler/specialise/SpecConstr.lhs
+++ b/compiler/specialise/SpecConstr.lhs
@@ -463,7 +463,8 @@ 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')))
+                 (withPprStyle defaultUserStyle $
+                  pprRules (tidyRules emptyTidyEnv (rulesOfBinds binds')))
 
        return binds'
   where
@@ -498,9 +499,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 +510,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 +686,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 +708,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 +797,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 +1025,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 +1219,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 +1289,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