[project @ 2002-03-04 17:01:26 by simonmar]

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

diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs
index b8c38a4..25d79f4 100644 (file)
--- a/ghc/compiler/coreSyn/PprCore.lhs
+++ b/ghc/compiler/coreSyn/PprCore.lhs
@@ -20,23 +20,31 @@ module PprCore (
 import CoreSyn
 import CostCentre      ( pprCostCentreCore )
 import Id              ( Id, idType, isDataConId_maybe, idLBVarInfo, idArity,
-                         idInfo, idInlinePragma, idDemandInfo, idOccInfo,
-                         globalIdDetails, isGlobalId, isExportedId, isSpecPragmaId
+                         idInfo, idInlinePragma, idOccInfo,
+#ifdef DEBUG
+                         idDemandInfo, 
+#endif
+                         globalIdDetails, isGlobalId, isExportedId, 
+                         isSpecPragmaId, idNewDemandInfo
                        )
 import Var             ( isTyVar )
 import IdInfo          ( IdInfo, megaSeqIdInfo, 
                          arityInfo, ppArityInfo, 
-                         specInfo, cprInfo, ppCprInfo, 
-                         strictnessInfo, ppStrictnessInfo, cgInfo,
-                         cprInfo, ppCprInfo, 
+                         specInfo, ppStrictnessInfo, 
                          workerInfo, ppWorkerInfo,
-                          tyGenInfo, ppTyGenInfo
+                          tyGenInfo, ppTyGenInfo,
+                         newStrictnessInfo,
+#ifdef DEBUG
+                         cprInfo, ppCprInfo, 
+                         strictnessInfo,
+#endif
                        )
 import DataCon         ( dataConTyCon )
 import TyCon           ( tupleTyConBoxity, isTupleTyCon )
 import PprType         ( pprParendType, pprTyVarBndr )
 import BasicTypes      ( tupleParens )
 import PprEnv
+import Util             ( lengthIs )
 import Outputable
 \end{code}
 
@@ -183,7 +191,7 @@ ppr_expr add_par pe expr@(App fun arg)
                           -> tupleParens (tupleTyConBoxity tc) pp_tup_args
                           where
                             tc        = dataConTyCon dc
-                            saturated = length val_args == idArity f
+                            saturated = val_args `lengthIs` idArity f
 
                   other -> add_par (hang (pOcc pe f) 2 pp_args)
 
@@ -328,7 +336,11 @@ 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))
+#ifdef DEBUG
+                           ppr (idDemandInfo id) <+>
+#endif
+                           ppr (idNewDemandInfo id) <+>
+                           ppr (idLBVarInfo id)))
 \end{code}
 
 
@@ -344,9 +356,11 @@ ppIdInfo b info
   = hsep [  ppArityInfo a,
             ppTyGenInfo g,
            ppWorkerInfo (workerInfo info),
+#ifdef DEBUG
            ppStrictnessInfo s,
---         pprCgInfo c,
             ppCprInfo m,
+#endif
+           ppr (newStrictnessInfo info),
            pprCoreRules b p
        -- Inline pragma, occ, demand, lbvar info
        -- printed out with all binders (when debug is on); 
@@ -355,9 +369,10 @@ ppIdInfo b info
   where
     a = arityInfo info
     g = tyGenInfo info
+#ifdef DEBUG
     s = strictnessInfo info
---  c = cgInfo info
     m = cprInfo info
+#endif
     p = specInfo info
 \end{code}
 
@@ -370,11 +385,11 @@ pprIdCoreRule :: IdCoreRule -> SDoc
 pprIdCoreRule (id,rule) = pprCoreRule (ppr id) rule
 
 pprCoreRule :: SDoc -> CoreRule -> SDoc
-pprCoreRule pp_fn (BuiltinRule _)
-  = ifPprDebug (ptext SLIT("A built in rule"))
+pprCoreRule pp_fn (BuiltinRule name _)
+  = ifPprDebug (ptext SLIT("Built in rule for") <+> pp_fn <> colon <+> doubleQuotes (ptext name))
 
-pprCoreRule pp_fn (Rule name tpl_vars tpl_args rhs)
-  = doubleQuotes (ptext name) <+> 
+pprCoreRule pp_fn (Rule name act tpl_vars tpl_args rhs)
+  = doubleQuotes (ptext name) <+> ppr act <+>
     sep [
          ptext SLIT("__forall") <+> braces (sep (map pprTypedBinder tpl_vars)),
          nest 2 (pp_fn <+> sep (map pprArg tpl_args)),