[project @ 2001-09-14 15:44:13 by simonpj]

[ghc-hetmet.git] / ghc / compiler / coreSyn / PprCore.lhs

diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs
index ad211e8..19fb641 100644 (file)
--- a/ghc/compiler/coreSyn/PprCore.lhs
+++ b/ghc/compiler/coreSyn/PprCore.lhs
@@ -20,16 +20,18 @@ module PprCore (
 import CoreSyn
 import CostCentre      ( pprCostCentreCore )
 import Id              ( Id, idType, isDataConId_maybe, idLBVarInfo, idArity,
-                         idInfo, idInlinePragma, idDemandInfo, idOccInfo
+                         idInfo, idInlinePragma, idDemandInfo, idOccInfo,
+                         globalIdDetails, isGlobalId, isExportedId, isSpecPragmaId
                        )
 import Var             ( isTyVar )
 import IdInfo          ( IdInfo, megaSeqIdInfo, 
-                         arityInfo, ppArityInfo, ppFlavourInfo, flavourInfo,
+                         arityInfo, ppArityInfo, 
                          specInfo, cprInfo, ppCprInfo, 
-                         strictnessInfo, ppStrictnessInfo, cafInfo, ppCafInfo,
+                         strictnessInfo, ppStrictnessInfo, cgInfo,
                          cprInfo, ppCprInfo, 
                          workerInfo, ppWorkerInfo,
-                          tyGenInfo, ppTyGenInfo
+                          tyGenInfo, ppTyGenInfo,
+                         newDemandInfo, newStrictnessInfo
                        )
 import DataCon         ( dataConTyCon )
 import TyCon           ( tupleTyConBoxity, isTupleTyCon )
@@ -165,7 +167,7 @@ ppr_expr add_par pe expr@(Lam _ _)
     in
     add_par $
     hang (ptext SLIT("\\") <+> sep (map (pBndr pe LambdaBind) bndrs) <+> arrow)
-        4 (ppr_noparend_expr pe body)
+        2 (ppr_noparend_expr pe body)
 
 ppr_expr add_par pe expr@(App fun arg)
   = case collectArgs expr of { (fun, args) -> 
@@ -184,9 +186,9 @@ ppr_expr add_par pe expr@(App fun arg)
                             tc        = dataConTyCon dc
                             saturated = length val_args == idArity f
 
-                  other -> add_par (hang (pOcc pe f) 4 pp_args)
+                  other -> add_par (hang (pOcc pe f) 2 pp_args)
 
-       other -> add_par (hang (ppr_parend_expr pe fun) 4 pp_args)
+       other -> add_par (hang (ppr_parend_expr pe fun) 2 pp_args)
     }
 
 ppr_expr add_par pe (Case expr var [(con,args,rhs)])
@@ -207,7 +209,7 @@ ppr_expr add_par pe (Case expr var alts)
   = add_par $
     sep [sep [ptext SLIT("case") <+> ppr_noparend_expr pe expr,
              ptext SLIT("of") <+> ppr_bndr var <+> char '{'],
-        nest 4 (sep (punctuate semi (map (ppr_alt pe) alts))),
+        nest 2 (sep (punctuate semi (map (ppr_alt pe) alts))),
         char '}'
     ]
   where
@@ -229,7 +231,7 @@ ppr_expr add_par pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
   = add_par
     (hang (ptext SLIT("let {"))
          2 (hsep [hang (hsep [pBndr pe LetBind val_bdr, equals])
-                          4 (ppr_noparend_expr pe rhs),
+                          2 (ppr_noparend_expr pe rhs),
        ptext SLIT("} in")])
      $$
      ppr_noparend_expr pe expr)
@@ -260,7 +262,7 @@ ppr_expr add_par pe (Note (Coerce to_ty from_ty) expr)
 #else
 ppr_expr add_par pe (Note (Coerce to_ty from_ty) expr)
   = add_par $
-    sep [sep [ptext SLIT("__coerce"), nest 4 (pTy pe to_ty)],
+    sep [sep [ptext SLIT("__coerce"), nest 2 (pTy pe to_ty)],
         ppr_parend_expr pe expr]
 #endif
 
@@ -271,7 +273,7 @@ ppr_expr add_par pe (Note InlineMe expr)
   = add_par $ ptext SLIT("__inline_me") <+> ppr_parend_expr pe expr
 
 ppr_alt pe (con, args, rhs) 
-  = hang (ppr_case_pat pe con args) 4 (ppr_noparend_expr pe rhs)
+  = hang (ppr_case_pat pe con args) 2 (ppr_noparend_expr pe rhs)
 
 ppr_case_pat pe con@(DataAlt dc) args
   | isTupleTyCon tc
@@ -297,7 +299,7 @@ and @pprCoreExpr@ functions.
 \begin{code}
 -- Used for printing dump info
 pprCoreBinder LetBind binder
-  = vcat [sig, pragmas, ppr binder]
+  = vcat [sig, pprIdDetails binder, pragmas, ppr binder]
   where
     sig     = pprTypedBinder binder
     pragmas = ppIdInfo binder (idInfo binder)
@@ -327,20 +329,26 @@ pprIdBndr id = ppr id <+>
               (megaSeqIdInfo (idInfo id) `seq`
                        -- Useful for poking on black holes
                ifPprDebug (ppr (idInlinePragma id) <+> ppr (idOccInfo id) <+> 
-                           ppr (idDemandInfo id)) <+> ppr (idLBVarInfo id))
+                           ppr (idDemandInfo id)) <+> ppr (newDemandInfo (idInfo id)) <+>
+                           ppr (idLBVarInfo id))
 \end{code}
 
 
 \begin{code}
+pprIdDetails :: Id -> SDoc
+pprIdDetails id | isGlobalId id     = ppr (globalIdDetails id)
+               | isExportedId id   = ptext SLIT("[Exported]")
+               | isSpecPragmaId id = ptext SLIT("[SpecPrag]")
+               | otherwise         = empty
+
 ppIdInfo :: Id -> IdInfo -> SDoc
 ppIdInfo b info
-  = hsep [
-           ppFlavourInfo (flavourInfo info),
-           ppArityInfo a,
+  = hsep [  ppArityInfo a,
             ppTyGenInfo g,
            ppWorkerInfo (workerInfo info),
            ppStrictnessInfo s,
-           ppCafInfo c,
+           ppr (newStrictnessInfo info),
+--         pprCgInfo c,
             ppCprInfo m,
            pprCoreRules b p
        -- Inline pragma, occ, demand, lbvar info
@@ -351,7 +359,7 @@ ppIdInfo b info
     a = arityInfo info
     g = tyGenInfo info
     s = strictnessInfo info
-    c = cafInfo info
+--  c = cgInfo info
     m = cprInfo info
     p = specInfo info
 \end{code}
@@ -372,7 +380,7 @@ pprCoreRule pp_fn (Rule name tpl_vars tpl_args rhs)
   = doubleQuotes (ptext name) <+> 
     sep [
          ptext SLIT("__forall") <+> braces (sep (map pprTypedBinder tpl_vars)),
-         nest 4 (pp_fn <+> sep (map pprArg tpl_args)),
-         nest 4 (ptext SLIT("=") <+> pprCoreExpr rhs)
+         nest 2 (pp_fn <+> sep (map pprArg tpl_args)),
+         nest 2 (ptext SLIT("=") <+> pprCoreExpr rhs)
     ] <+> semi
 \end{code}