Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
bd8ead09
Commit
bd8ead09
authored
Sep 04, 1997
by
sof
Browse files
[project @ 1997-09-04 19:56:48 by sof]
ppr tidy up
parent
7483b805
Changes
3
Hide whitespace changes
Inline
Side-by-side
ghc/compiler/simplStg/SimplStg.lhs
View file @
bd8ead09
...
...
@@ -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
_s
tyle
then lintStgBindings ppr
DumpS
tyle
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
_s
tyle) binds2))
(vcat (map (ppr ppr
DumpS
tyle) binds2))
))
else return ()) >>
let
...
...
ghc/compiler/stgSyn/StgLint.lhs
View file @
bd8ead09
...
...
@@ -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 (pprPlain
StgBinding sty
)
binds
)
,
ppr
StgBinding
s
sty binds,
ptext SLIT("*** End of Offense ***")])
where
lint_binds :: [StgBinding] -> LintM ()
...
...
ghc/compiler/stgSyn/StgSyn.lhs
View file @
bd8ead09
...
...
@@ -30,7 +30,7 @@ module StgSyn (
SYN_IE(StgBinding), SYN_IE(StgExpr), SYN_IE(StgRhs),
SYN_IE(StgCaseAlts), SYN_IE(StgCaseDefault),
ppr
Plain
StgBinding,
ppr
StgBinding, ppr
StgBinding
s
,
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) =>
ppr
Gen
StgBinding :: (Outputable bndr, Outputable bdee, Ord bdee) =>
PprStyle -> GenStgBinding bndr bdee -> Doc
pprStgBinding sty (StgNonRec bndr rhs)
ppr
Gen
StgBinding sty (StgNonRec bndr rhs)
= hang (hsep [ppr sty bndr, equals])
4 ((<>) (ppr sty rhs) semi)
pprStgBinding sty (StgCoerceBinding bndr occ)
ppr
Gen
StgBinding sty (StgCoerceBinding bndr occ)
= hang (hsep [ppr sty bndr, equals, ptext SLIT("{-Coerce-}")])
4 ((<>) (ppr sty occ) semi)
pprStgBinding sty (StgRec pairs)
ppr
Gen
StgBinding 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 = ppr
Gen
StgBinding
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 [ppr
Gen
StgBinding 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 (ppr
Gen
StgBinding 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 (ppr
Gen
StgBinding sty bind),
hang ((<>) (ptext SLIT("} in "))
(ifPprDebug sty (
nest 4 (
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment