From: sof Date: Thu, 4 Sep 1997 19:57:35 +0000 (+0000) Subject: [project @ 1997-09-04 19:56:48 by sof] X-Git-Tag: Approximately_1000_patches_recorded~22 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=bd8ead09270aec70f5495f1a2b20b6d2ea1ff44f [project @ 1997-09-04 19:56:48 by sof] ppr tidy up --- diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs index 480d247..a14a279 100644 --- a/ghc/compiler/simplStg/SimplStg.lhs +++ b/ghc/compiler/simplStg/SimplStg.lhs @@ -34,7 +34,8 @@ import Id ( nullIdEnv, lookupIdEnv, addOneToIdEnv, ) import Maybes ( maybeToBool ) import PprType ( GenType{-instance Outputable-} ) -import Outputable ( PprStyle, Outputable(..) ) +import ErrUtils ( doIfSet ) +import Outputable ( PprStyle, Outputable(..), printErrs, pprDumpStyle ) import Pretty ( Doc, ($$), vcat, text, ptext ) import UniqSupply ( splitUniqSupply, UniqSupply ) import Util ( mapAccumL, panic, assertPanic ) @@ -43,7 +44,6 @@ import Util ( mapAccumL, panic, assertPanic ) \begin{code} stg2stg :: [StgToDo] -- spec of what stg-to-stg passes to do -> FAST_STRING -- module name (profiling only) - -> PprStyle -- printing style (for debugging only) -> UniqSupply -- a name supply -> [StgBinding] -- input... -> IO @@ -51,16 +51,13 @@ stg2stg :: [StgToDo] -- spec of what stg-to-stg passes to do ([CostCentre], -- local cost-centres that need to be decl'd [CostCentre])) -- "extern" cost-centres -stg2stg stg_todos module_name ppr_style us binds +stg2stg stg_todos module_name us binds = case (splitUniqSupply us) of { (us4now, us4later) -> - (if do_verbose_stg2stg then - hPutStr stderr "VERBOSE STG-TO-STG:\n" >> - hPutStr stderr (show - (($$) (ptext SLIT("*** Core2Stg:")) - (vcat (map (ppr ppr_style) (setStgVarInfo False binds))) - )) - else return ()) >> + doIfSet do_verbose_stg2stg + (printErrs (text "VERBOSE STG-TO-STG:" $$ + text "*** Core2Stg:" $$ + vcat (map (ppr pprDumpStyle) (setStgVarInfo False binds)))) >> -- Do the main business! foldl_mn do_stg_pass (binds, us4now, ([],[])) stg_todos @@ -110,7 +107,7 @@ stg2stg stg_todos module_name ppr_style us binds ------------- stg_linter = if False --LATER: opt_DoStgLinting (ToDo) - then lintStgBindings ppr_style + then lintStgBindings pprDumpStyle else ( \ whodunnit binds -> binds ) ------------------------------------------- @@ -154,7 +151,7 @@ stg2stg stg_todos module_name ppr_style us binds (if do_verbose_stg2stg then hPutStr stderr (show (($$) (text ("*** "++what++":")) - (vcat (map (ppr ppr_style) binds2)) + (vcat (map (ppr pprDumpStyle) binds2)) )) else return ()) >> let diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs index 053d8e7..70bbf41 100644 --- a/ghc/compiler/stgSyn/StgLint.lhs +++ b/ghc/compiler/stgSyn/StgLint.lhs @@ -61,7 +61,7 @@ lintStgBindings sty whodunnit binds ptext SLIT("*** Stg Lint Errors: in "),text whodunnit, ptext SLIT(" ***"), msg sty, ptext SLIT("*** Offending Program ***"), - vcat (map (pprPlainStgBinding sty) binds), + pprStgBindings sty binds, ptext SLIT("*** End of Offense ***")]) where lint_binds :: [StgBinding] -> LintM () diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs index 04003f9..7a7a65f 100644 --- a/ghc/compiler/stgSyn/StgSyn.lhs +++ b/ghc/compiler/stgSyn/StgSyn.lhs @@ -30,7 +30,7 @@ module StgSyn ( SYN_IE(StgBinding), SYN_IE(StgExpr), SYN_IE(StgRhs), SYN_IE(StgCaseAlts), SYN_IE(StgCaseDefault), - pprPlainStgBinding, + pprStgBinding, pprStgBindings, getArgPrimRep, isLitLitArg, stgArity, @@ -498,18 +498,18 @@ Robin Popplestone asked for semi-colon separators on STG binds; here's hoping he likes terminators instead... Ditto for case alternatives. \begin{code} -pprStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee) => +pprGenStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee) => PprStyle -> GenStgBinding bndr bdee -> Doc -pprStgBinding sty (StgNonRec bndr rhs) +pprGenStgBinding sty (StgNonRec bndr rhs) = hang (hsep [ppr sty bndr, equals]) 4 ((<>) (ppr sty rhs) semi) -pprStgBinding sty (StgCoerceBinding bndr occ) +pprGenStgBinding sty (StgCoerceBinding bndr occ) = hang (hsep [ppr sty bndr, equals, ptext SLIT("{-Coerce-}")]) 4 ((<>) (ppr sty occ) semi) -pprStgBinding sty (StgRec pairs) +pprGenStgBinding sty (StgRec pairs) = vcat ((ifPprDebug sty (ptext SLIT("{- StgRec (begin) -}"))) : (map (ppr_bind sty) pairs) ++ [(ifPprDebug sty (ptext SLIT("{- StgRec (end) -}")))]) where @@ -517,8 +517,11 @@ pprStgBinding sty (StgRec pairs) = hang (hsep [ppr sty bndr, equals]) 4 ((<>) (ppr sty expr) semi) -pprPlainStgBinding :: PprStyle -> StgBinding -> Doc -pprPlainStgBinding sty b = pprStgBinding sty b +pprStgBinding :: PprStyle -> StgBinding -> Doc +pprStgBinding sty bind = pprGenStgBinding sty bind + +pprStgBindings :: PprStyle -> [StgBinding] -> Doc +pprStgBindings sty binds = vcat (map (pprGenStgBinding sty) binds) \end{code} \begin{code} @@ -527,7 +530,7 @@ instance (Outputable bdee) => Outputable (GenStgArg bdee) where instance (Outputable bndr, Outputable bdee, Ord bdee) => Outputable (GenStgBinding bndr bdee) where - ppr = pprStgBinding + ppr = pprGenStgBinding instance (Outputable bndr, Outputable bdee, Ord bdee) => Outputable (GenStgExpr bndr bdee) where @@ -594,17 +597,17 @@ pprStgExpr sty (StgLet (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag a pprStgExpr sty (StgLet bind expr@(StgLet _ _)) = ($$) - (sep [hang (ptext SLIT("let {")) 2 (hsep [pprStgBinding sty bind, ptext SLIT("} in")])]) + (sep [hang (ptext SLIT("let {")) 2 (hsep [pprGenStgBinding sty bind, ptext SLIT("} in")])]) (ppr sty expr) -- general case pprStgExpr sty (StgLet bind expr) - = sep [hang (ptext SLIT("let {")) 2 (pprStgBinding sty bind), + = sep [hang (ptext SLIT("let {")) 2 (pprGenStgBinding sty bind), hang (ptext SLIT("} in ")) 2 (ppr sty expr)] pprStgExpr sty (StgLetNoEscape lvs_whole lvs_rhss bind expr) = sep [hang (ptext SLIT("let-no-escape {")) - 2 (pprStgBinding sty bind), + 2 (pprGenStgBinding sty bind), hang ((<>) (ptext SLIT("} in ")) (ifPprDebug sty ( nest 4 (