diff options
Diffstat (limited to 'compiler/simplCore')
| -rw-r--r-- | compiler/simplCore/CoreMonad.hs | 64 | ||||
| -rw-r--r-- | compiler/simplCore/FloatOut.hs | 13 | ||||
| -rw-r--r-- | compiler/simplCore/OccurAnal.hs | 17 | ||||
| -rw-r--r-- | compiler/simplCore/SAT.hs | 14 | ||||
| -rw-r--r-- | compiler/simplCore/SimplCore.hs | 15 | ||||
| -rw-r--r-- | compiler/simplCore/SimplEnv.hs | 21 | ||||
| -rw-r--r-- | compiler/simplCore/SimplMonad.hs | 8 | ||||
| -rw-r--r-- | compiler/simplCore/SimplUtils.hs | 31 | ||||
| -rw-r--r-- | compiler/simplCore/Simplify.hs | 4 |
9 files changed, 91 insertions, 96 deletions
diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs index 9f80a17869..13a7512ffa 100644 --- a/compiler/simplCore/CoreMonad.hs +++ b/compiler/simplCore/CoreMonad.hs @@ -148,30 +148,30 @@ data CoreToDo -- These are diff core-to-core passes, | CorePrep instance Outputable CoreToDo where - ppr (CoreDoSimplify _ _) = ptext (sLit "Simplifier") - ppr (CoreDoPluginPass s _) = ptext (sLit "Core plugin: ") <+> text s - ppr CoreDoFloatInwards = ptext (sLit "Float inwards") - ppr (CoreDoFloatOutwards f) = ptext (sLit "Float out") <> parens (ppr f) - ppr CoreLiberateCase = ptext (sLit "Liberate case") - ppr CoreDoStaticArgs = ptext (sLit "Static argument") - ppr CoreDoCallArity = ptext (sLit "Called arity analysis") - ppr CoreDoStrictness = ptext (sLit "Demand analysis") - ppr CoreDoWorkerWrapper = ptext (sLit "Worker Wrapper binds") - ppr CoreDoSpecialising = ptext (sLit "Specialise") - ppr CoreDoSpecConstr = ptext (sLit "SpecConstr") - ppr CoreCSE = ptext (sLit "Common sub-expression") - ppr CoreDoVectorisation = ptext (sLit "Vectorisation") - ppr CoreDesugar = ptext (sLit "Desugar (before optimization)") - ppr CoreDesugarOpt = ptext (sLit "Desugar (after optimization)") - ppr CoreTidy = ptext (sLit "Tidy Core") - ppr CorePrep = ptext (sLit "CorePrep") - ppr CoreDoPrintCore = ptext (sLit "Print core") - ppr (CoreDoRuleCheck {}) = ptext (sLit "Rule check") - ppr CoreDoNothing = ptext (sLit "CoreDoNothing") - ppr (CoreDoPasses passes) = ptext (sLit "CoreDoPasses") <+> ppr passes + ppr (CoreDoSimplify _ _) = text "Simplifier" + ppr (CoreDoPluginPass s _) = text "Core plugin: " <+> text s + ppr CoreDoFloatInwards = text "Float inwards" + ppr (CoreDoFloatOutwards f) = text "Float out" <> parens (ppr f) + ppr CoreLiberateCase = text "Liberate case" + ppr CoreDoStaticArgs = text "Static argument" + ppr CoreDoCallArity = text "Called arity analysis" + ppr CoreDoStrictness = text "Demand analysis" + ppr CoreDoWorkerWrapper = text "Worker Wrapper binds" + ppr CoreDoSpecialising = text "Specialise" + ppr CoreDoSpecConstr = text "SpecConstr" + ppr CoreCSE = text "Common sub-expression" + ppr CoreDoVectorisation = text "Vectorisation" + ppr CoreDesugar = text "Desugar (before optimization)" + ppr CoreDesugarOpt = text "Desugar (after optimization)" + ppr CoreTidy = text "Tidy Core" + ppr CorePrep = text "CorePrep" + ppr CoreDoPrintCore = text "Print core" + ppr (CoreDoRuleCheck {}) = text "Rule check" + ppr CoreDoNothing = text "CoreDoNothing" + ppr (CoreDoPasses passes) = text "CoreDoPasses" <+> ppr passes pprPassDetails :: CoreToDo -> SDoc -pprPassDetails (CoreDoSimplify n md) = vcat [ ptext (sLit "Max iterations =") <+> int n +pprPassDetails (CoreDoSimplify n md) = vcat [ text "Max iterations =" <+> int n , ppr md ] pprPassDetails _ = Outputable.empty @@ -189,15 +189,15 @@ instance Outputable SimplifierMode where ppr (SimplMode { sm_phase = p, sm_names = ss , sm_rules = r, sm_inline = i , sm_eta_expand = eta, sm_case_case = cc }) - = ptext (sLit "SimplMode") <+> braces ( - sep [ ptext (sLit "Phase =") <+> ppr p <+> + = text "SimplMode" <+> braces ( + sep [ text "Phase =" <+> ppr p <+> brackets (text (concat $ intersperse "," ss)) <> comma , pp_flag i (sLit "inline") <> comma , pp_flag r (sLit "rules") <> comma , pp_flag eta (sLit "eta-expand") <> comma , pp_flag cc (sLit "case-of-case") ]) where - pp_flag f s = ppUnless f (ptext (sLit "no")) <+> ptext s + pp_flag f s = ppUnless f (text "no") <+> ptext s data FloatOutSwitches = FloatOutSwitches { floatOutLambdas :: Maybe Int, -- ^ Just n <=> float lambdas to top level, if @@ -220,11 +220,11 @@ instance Outputable FloatOutSwitches where pprFloatOutSwitches :: FloatOutSwitches -> SDoc pprFloatOutSwitches sw - = ptext (sLit "FOS") <+> (braces $ + = text "FOS" <+> (braces $ sep $ punctuate comma $ - [ ptext (sLit "Lam =") <+> ppr (floatOutLambdas sw) - , ptext (sLit "Consts =") <+> ppr (floatOutConstants sw) - , ptext (sLit "OverSatApps =") <+> ppr (floatOutOverSatApps sw) ]) + [ text "Lam =" <+> ppr (floatOutLambdas sw) + , text "Consts =" <+> ppr (floatOutConstants sw) + , text "OverSatApps =" <+> ppr (floatOutOverSatApps sw) ]) -- The core-to-core pass ordering is derived from the DynFlags: runWhen :: Bool -> CoreToDo -> CoreToDo @@ -360,14 +360,14 @@ plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m) plusSimplCount _ _ = panic "plusSimplCount" -- We use one or the other consistently -pprSimplCount (VerySimplCount n) = ptext (sLit "Total ticks:") <+> int n +pprSimplCount (VerySimplCount n) = text "Total ticks:" <+> int n pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 }) - = vcat [ptext (sLit "Total ticks: ") <+> int tks, + = vcat [text "Total ticks: " <+> int tks, blankLine, pprTickCounts dts, if verboseSimplStats then vcat [blankLine, - ptext (sLit "Log (most recent first)"), + text "Log (most recent first)", nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))] else Outputable.empty ] diff --git a/compiler/simplCore/FloatOut.hs b/compiler/simplCore/FloatOut.hs index 7f920a230e..3c220fed74 100644 --- a/compiler/simplCore/FloatOut.hs +++ b/compiler/simplCore/FloatOut.hs @@ -27,7 +27,6 @@ import Bag import Util import Maybes import Outputable -import FastString import qualified Data.IntMap as M #include "HsVersions.h" @@ -130,9 +129,9 @@ floatOutwards float_sws dflags us pgm let { (tlets, ntlets, lams) = get_stats (sum_stats fss) }; dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "FloatOut stats:" - (hcat [ int tlets, ptext (sLit " Lets floated to top level; "), - int ntlets, ptext (sLit " Lets floated elsewhere; from "), - int lams, ptext (sLit " Lambda groups")]); + (hcat [ int tlets, text " Lets floated to top level; ", + int ntlets, text " Lets floated elsewhere; from ", + int lams, text " Lambda groups"]); return (bagToList (unionManyBags binds_s')) } @@ -481,9 +480,9 @@ data FloatBinds = FB !(Bag FloatLet) -- Destined for top level instance Outputable FloatBinds where ppr (FB fbs defs) - = ptext (sLit "FB") <+> (braces $ vcat - [ ptext (sLit "tops =") <+> ppr fbs - , ptext (sLit "non-tops =") <+> ppr defs ]) + = text "FB" <+> (braces $ vcat + [ text "tops =" <+> ppr fbs + , text "non-tops =" <+> ppr defs ]) flattenTopFloats :: FloatBinds -> Bag CoreBind flattenTopFloats (FB tops defs) diff --git a/compiler/simplCore/OccurAnal.hs b/compiler/simplCore/OccurAnal.hs index 16f819241a..d1c3ca809a 100644 --- a/compiler/simplCore/OccurAnal.hs +++ b/compiler/simplCore/OccurAnal.hs @@ -39,7 +39,6 @@ import Unique import UniqFM import Util import Outputable -import FastString import Data.List import Control.Arrow ( second ) @@ -668,12 +667,12 @@ data Details } instance Outputable Details where - ppr nd = ptext (sLit "ND") <> braces - (sep [ ptext (sLit "bndr =") <+> ppr (nd_bndr nd) - , ptext (sLit "uds =") <+> ppr (nd_uds nd) - , ptext (sLit "inl =") <+> ppr (nd_inl nd) - , ptext (sLit "weak =") <+> ppr (nd_weak nd) - , ptext (sLit "rule =") <+> ppr (nd_active_rule_fvs nd) + ppr nd = text "ND" <> braces + (sep [ text "bndr =" <+> ppr (nd_bndr nd) + , text "uds =" <+> ppr (nd_uds nd) + , text "inl =" <+> ppr (nd_inl nd) + , text "weak =" <+> ppr (nd_weak nd) + , text "rule =" <+> ppr (nd_active_rule_fvs nd) ]) makeNode :: OccEnv -> ImpRuleEdges -> VarSet -> (Var, CoreExpr) -> Node Details @@ -1484,8 +1483,8 @@ data OccEncl -- Do inline into constructor args here instance Outputable OccEncl where - ppr OccRhs = ptext (sLit "occRhs") - ppr OccVanilla = ptext (sLit "occVanilla") + ppr OccRhs = text "occRhs" + ppr OccVanilla = text "occVanilla" type OneShots = [OneShotInfo] -- [] No info diff --git a/compiler/simplCore/SAT.hs b/compiler/simplCore/SAT.hs index ac8da3f45b..38ae1444f1 100644 --- a/compiler/simplCore/SAT.hs +++ b/compiler/simplCore/SAT.hs @@ -127,10 +127,10 @@ pprSATInfo :: SATInfo -> SDoc pprSATInfo staticness = hcat $ map pprStaticness staticness pprStaticness :: Staticness App -> SDoc -pprStaticness (Static (VarApp _)) = ptext (sLit "SV") -pprStaticness (Static (TypeApp _)) = ptext (sLit "ST") -pprStaticness (Static (CoApp _)) = ptext (sLit "SC") -pprStaticness NotStatic = ptext (sLit "NS") +pprStaticness (Static (VarApp _)) = text "SV" +pprStaticness (Static (TypeApp _)) = text "ST" +pprStaticness (Static (CoApp _)) = text "SC" +pprStaticness NotStatic = text "NS" mergeSATInfo :: SATInfo -> SATInfo -> SATInfo @@ -148,9 +148,9 @@ mergeSATInfo l r = zipWith mergeSA l r | c `eqCoercion` c' = Static (CoApp c) | otherwise = NotStatic mergeSA _ _ = pprPanic "mergeSATInfo" $ - ptext (sLit "Left:") - <> pprSATInfo l <> ptext (sLit ", ") - <> ptext (sLit "Right:") + text "Left:" + <> pprSATInfo l <> text ", " + <> text "Right:" <> pprSATInfo r mergeIdSATInfo :: IdSATInfo -> IdSATInfo -> IdSATInfo diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs index 8670e30a29..6badbf83db 100644 --- a/compiler/simplCore/SimplCore.hs +++ b/compiler/simplCore/SimplCore.hs @@ -44,7 +44,6 @@ import DmdAnal ( dmdAnalProgram ) import CallArity ( callArityAnalProgram ) import WorkWrap ( wwTopBinds ) import Vectorise ( vectorise ) -import FastString import SrcLoc import Util import Module @@ -604,11 +603,11 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) -- about to begin, with '1' for the first | iteration_no > max_iterations -- Stop if we've run out of iterations = WARN( debugIsOn && (max_iterations > 2) - , hang (ptext (sLit "Simplifier bailing out after") <+> int max_iterations - <+> ptext (sLit "iterations") + , hang (text "Simplifier bailing out after" <+> int max_iterations + <+> text "iterations" <+> (brackets $ hsep $ punctuate comma $ map (int . simplCountN) (reverse counts_so_far))) - 2 (ptext (sLit "Size =") <+> ppr (coreBindsStats binds))) + 2 (text "Size =" <+> ppr (coreBindsStats binds))) -- Subtract 1 from iteration_no to get the -- number of iterations we actually completed @@ -720,10 +719,10 @@ dump_end_iteration dflags print_unqual iteration_no counts binds rules | otherwise = Nothing -- Show details if Opt_D_dump_simpl_iterations is on - hdr = ptext (sLit "Simplifier iteration=") <> int iteration_no - pp_counts = vcat [ ptext (sLit "---- Simplifier counts for") <+> hdr + hdr = text "Simplifier iteration=" <> int iteration_no + pp_counts = vcat [ text "---- Simplifier counts for" <+> hdr , pprSimplCount counts - , ptext (sLit "---- End of simplifier counts for") <+> hdr ] + , text "---- End of simplifier counts for" <+> hdr ] {- ************************************************************************ @@ -929,7 +928,7 @@ shortMeOut ind_env exported_id local_id then if hasShortableIdInfo exported_id then True -- See Note [Messing up the exported Id's IdInfo] - else WARN( True, ptext (sLit "Not shorting out:") <+> ppr exported_id ) + else WARN( True, text "Not shorting out:" <+> ppr exported_id ) False else False diff --git a/compiler/simplCore/SimplEnv.hs b/compiler/simplCore/SimplEnv.hs index 2f2dea660f..1f77657fe1 100644 --- a/compiler/simplCore/SimplEnv.hs +++ b/compiler/simplCore/SimplEnv.hs @@ -54,7 +54,6 @@ import Coercion hiding ( substCo, substCoVar, substCoVarBndr ) import BasicTypes import MonadUtils import Outputable -import FastString import Util import Data.List @@ -126,10 +125,10 @@ type StaticEnv = SimplEnv -- Just the static part is relevant pprSimplEnv :: SimplEnv -> SDoc -- Used for debugging; selective pprSimplEnv env - = vcat [ptext (sLit "TvSubst:") <+> ppr (seTvSubst env), - ptext (sLit "CvSubst:") <+> ppr (seCvSubst env), - ptext (sLit "IdSubst:") <+> ppr (seIdSubst env), - ptext (sLit "InScope:") <+> vcat (map ppr_one in_scope_vars) + = vcat [text "TvSubst:" <+> ppr (seTvSubst env), + text "CvSubst:" <+> ppr (seCvSubst env), + text "IdSubst:" <+> ppr (seIdSubst env), + text "InScope:" <+> vcat (map ppr_one in_scope_vars) ] where in_scope_vars = varEnvElts (getInScopeVars (seInScope env)) @@ -148,9 +147,9 @@ data SimplSR InExpr instance Outputable SimplSR where - ppr (DoneEx e) = ptext (sLit "DoneEx") <+> ppr e - ppr (DoneId v) = ptext (sLit "DoneId") <+> ppr v - ppr (ContEx _tv _cv _id e) = vcat [ptext (sLit "ContEx") <+> ppr e {-, + ppr (DoneEx e) = text "DoneEx" <+> ppr e + ppr (DoneId v) = text "DoneId" <+> ppr v + ppr (ContEx _tv _cv _id e) = vcat [text "ContEx" <+> ppr e {-, ppr (filter_env tv), ppr (filter_env id) -}] -- where -- fvs = exprFreeVars e @@ -379,9 +378,9 @@ instance Outputable Floats where ppr (Floats binds ff) = ppr ff $$ ppr (fromOL binds) instance Outputable FloatFlag where - ppr FltLifted = ptext (sLit "FltLifted") - ppr FltOkSpec = ptext (sLit "FltOkSpec") - ppr FltCareful = ptext (sLit "FltCareful") + ppr FltLifted = text "FltLifted" + ppr FltOkSpec = text "FltOkSpec" + ppr FltCareful = text "FltCareful" andFF :: FloatFlag -> FloatFlag -> FloatFlag andFF FltCareful _ = FltCareful diff --git a/compiler/simplCore/SimplMonad.hs b/compiler/simplCore/SimplMonad.hs index f165c65db5..074d13b680 100644 --- a/compiler/simplCore/SimplMonad.hs +++ b/compiler/simplCore/SimplMonad.hs @@ -200,14 +200,14 @@ checkedTick t else let sc' = doSimplTick (st_flags st_env) t sc in sc' `seq` return ((), us, sc')) where - msg sc = vcat [ ptext (sLit "When trying") <+> ppr t - , ptext (sLit "To increase the limit, use -fsimpl-tick-factor=N (default 100)") - , ptext (sLit "If you need to do this, let GHC HQ know, and what factor you needed") + msg sc = vcat [ text "When trying" <+> ppr t + , text "To increase the limit, use -fsimpl-tick-factor=N (default 100)" + , text "If you need to do this, let GHC HQ know, and what factor you needed" , pp_details sc , pprSimplCount sc ] pp_details sc | hasDetailedCounts sc = empty - | otherwise = ptext (sLit "To see detailed counts use -ddump-simpl-stats") + | otherwise = text "To see detailed counts use -ddump-simpl-stats" freeTick :: Tick -> SimplM () diff --git a/compiler/simplCore/SimplUtils.hs b/compiler/simplCore/SimplUtils.hs index 846d1cc838..01c2773077 100644 --- a/compiler/simplCore/SimplUtils.hs +++ b/compiler/simplCore/SimplUtils.hs @@ -59,7 +59,6 @@ import BasicTypes import Util import MonadUtils import Outputable -import FastString import Pair import Control.Monad ( when ) @@ -170,23 +169,23 @@ the following invariants hold -} instance Outputable DupFlag where - ppr OkToDup = ptext (sLit "ok") - ppr NoDup = ptext (sLit "nodup") - ppr Simplified = ptext (sLit "simpl") + ppr OkToDup = text "ok" + ppr NoDup = text "nodup" + ppr Simplified = text "simpl" instance Outputable SimplCont where - ppr (Stop ty interesting) = ptext (sLit "Stop") <> brackets (ppr interesting) <+> ppr ty - ppr (CastIt co cont ) = (ptext (sLit "CastIt") <+> ppr co) $$ ppr cont - ppr (TickIt t cont) = (ptext (sLit "TickIt") <+> ppr t) $$ ppr cont + ppr (Stop ty interesting) = text "Stop" <> brackets (ppr interesting) <+> ppr ty + ppr (CastIt co cont ) = (text "CastIt" <+> ppr co) $$ ppr cont + ppr (TickIt t cont) = (text "TickIt" <+> ppr t) $$ ppr cont ppr (ApplyToTy { sc_arg_ty = ty, sc_cont = cont }) - = (ptext (sLit "ApplyToTy") <+> pprParendType ty) $$ ppr cont + = (text "ApplyToTy" <+> pprParendType ty) $$ ppr cont ppr (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_cont = cont }) - = (ptext (sLit "ApplyToVal") <+> ppr dup <+> pprParendExpr arg) + = (text "ApplyToVal" <+> ppr dup <+> pprParendExpr arg) $$ ppr cont - ppr (StrictBind b _ _ _ cont) = (ptext (sLit "StrictBind") <+> ppr b) $$ ppr cont - ppr (StrictArg ai _ cont) = (ptext (sLit "StrictArg") <+> ppr (ai_fun ai)) $$ ppr cont + ppr (StrictBind b _ _ _ cont) = (text "StrictBind" <+> ppr b) $$ ppr cont + ppr (StrictArg ai _ cont) = (text "StrictArg" <+> ppr (ai_fun ai)) $$ ppr cont ppr (Select { sc_dup = dup, sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont }) - = (ptext (sLit "Select") <+> ppr dup <+> ppr bndr) $$ + = (text "Select" <+> ppr dup <+> ppr bndr) $$ ifPprDebug (nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont @@ -241,9 +240,9 @@ data ArgSpec | CastBy OutCoercion -- Cast by this; c.f. CastIt instance Outputable ArgSpec where - ppr (ValArg e) = ptext (sLit "ValArg") <+> ppr e - ppr (TyArg { as_arg_ty = ty }) = ptext (sLit "TyArg") <+> ppr ty - ppr (CastBy c) = ptext (sLit "CastBy") <+> ppr c + ppr (ValArg e) = text "ValArg" <+> ppr e + ppr (TyArg { as_arg_ty = ty }) = text "TyArg" <+> ppr ty + ppr (CastBy c) = text "CastBy" <+> ppr c addValArgTo :: ArgInfo -> OutExpr -> ArgInfo addValArgTo ai arg = ai { ai_args = ValArg arg : ai_args ai @@ -1377,7 +1376,7 @@ tryEtaExpandRhs env bndr rhs ; (new_arity, new_rhs) <- try_expand dflags ; WARN( new_arity < old_id_arity, - (ptext (sLit "Arity decrease:") <+> (ppr bndr <+> ppr old_id_arity + (text "Arity decrease:" <+> (ppr bndr <+> ppr old_id_arity <+> ppr old_arity <+> ppr new_arity) $$ ppr new_rhs) ) -- Note [Arity decrease] in Simplify return (new_arity, new_rhs) } diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs index 2b2b4358bc..6880330c4e 100644 --- a/compiler/simplCore/Simplify.hs +++ b/compiler/simplCore/Simplify.hs @@ -2307,7 +2307,7 @@ missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont -> SimplM (SimplEnv, OutExp -- it "sees" that the entire branch of an outer case is -- inaccessible. So we simply put an error case here instead. missingAlt env case_bndr _ cont - = WARN( True, ptext (sLit "missingAlt") <+> ppr case_bndr ) + = WARN( True, text "missingAlt" <+> ppr case_bndr ) return (env, mkImpossibleExpr (contResultType cont)) {- @@ -2487,7 +2487,7 @@ mkDupableAlt env case_bndr (con, bndrs', rhs') = do unf = mkInlineUnfolding Nothing rhs rhs = mkConApp2 dc (tyConAppArgs scrut_ty) bndrs' - LitAlt {} -> WARN( True, ptext (sLit "mkDupableAlt") + LitAlt {} -> WARN( True, text "mkDupableAlt" <+> ppr case_bndr <+> ppr con ) case_bndr -- The case binder is alive but trivial, so why has |