[project @ 2002-03-18 15:23:05 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 cdde0eb..8639a93 100644 (file)
--- a/ghc/compiler/coreSyn/PprCore.lhs
+++ b/ghc/compiler/coreSyn/PprCore.lhs
@@ -12,7 +12,7 @@ module PprCore (
        pprCoreExpr, pprParendExpr,
        pprCoreBinding, pprCoreBindings, pprIdBndr,
        pprCoreBinding, pprCoreBindings, pprCoreAlt,
-       pprCoreRules, pprCoreRule, pprIdCoreRule
+       pprIdRules, pprCoreRule
     ) where
 
 #include "HsVersions.h"
@@ -20,24 +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 OLD_STRICTNESS
+                         idDemandInfo, 
+#endif
+                         globalIdDetails, isGlobalId, isExportedId, 
+                         isSpecPragmaId, idNewDemandInfo
                        )
 import Var             ( isTyVar )
 import IdInfo          ( IdInfo, megaSeqIdInfo, 
                          arityInfo, ppArityInfo, 
-                         specInfo, cprInfo, ppCprInfo, 
-                         strictnessInfo, ppStrictnessInfo, 
-                         cprInfo, ppCprInfo, 
+                         specInfo, ppStrictnessInfo, 
                          workerInfo, ppWorkerInfo,
                           tyGenInfo, ppTyGenInfo,
-                         newDemandInfo, newStrictnessInfo
+                         newStrictnessInfo,
+#ifdef OLD_STRICTNESS
+                         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}
 
@@ -184,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)
 
@@ -253,7 +260,7 @@ ppr_expr add_par pe (Note (SCC cc) expr)
 ppr_expr add_par pe (Note (Coerce to_ty from_ty) expr)
  = add_par $
    getPprStyle $ \ sty ->
-   if debugStyle sty && not (ifaceStyle sty) then
+   if debugStyle sty then
       sep [ptext SLIT("__coerce") <+> sep [pTy pe to_ty, pTy pe from_ty],
           ppr_parend_expr pe expr]
    else
@@ -329,8 +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 (newDemandInfo (idInfo id)) <+>
-                           ppr (idLBVarInfo id))
+#ifdef OLD_STRICTNESS
+                           ppr (idDemandInfo id) <+>
+#endif
+                           ppr (idNewDemandInfo id) <+>
+                           ppr (idLBVarInfo id)))
 \end{code}
 
 
@@ -346,10 +356,12 @@ ppIdInfo b info
   = hsep [  ppArityInfo a,
             ppTyGenInfo g,
            ppWorkerInfo (workerInfo info),
+#ifdef OLD_STRICTNESS
            ppStrictnessInfo s,
-           ppr (newStrictnessInfo info),
             ppCprInfo m,
-           pprCoreRules b p
+#endif
+           ppr (newStrictnessInfo info),
+           vcat (map (pprCoreRule (ppr b)) (rulesRules p))
        -- Inline pragma, occ, demand, lbvar info
        -- printed out with all binders (when debug is on); 
        -- see PprCore.pprIdBndr
@@ -357,22 +369,24 @@ ppIdInfo b info
   where
     a = arityInfo info
     g = tyGenInfo info
+#ifdef OLD_STRICTNESS
     s = strictnessInfo info
     m = cprInfo info
+#endif
     p = specInfo info
 \end{code}
 
 
 \begin{code}
-pprCoreRules :: Id -> CoreRules -> SDoc
-pprCoreRules var (Rules rules _) = vcat (map (pprCoreRule (ppr var)) rules)
+pprIdRules :: [IdCoreRule] -> SDoc
+pprIdRules rules = vcat (map pprIdRule rules)
 
-pprIdCoreRule :: IdCoreRule -> SDoc
-pprIdCoreRule (id,rule) = pprCoreRule (ppr id) rule
+pprIdRule :: IdCoreRule -> SDoc
+pprIdRule (id,rule) = pprCoreRule (ppr id) rule
 
 pprCoreRule :: SDoc -> CoreRule -> SDoc
 pprCoreRule pp_fn (BuiltinRule name _)
-  = ifPprDebug (ptext SLIT("Built in rule") <+> doubleQuotes (ptext name))
+  = ifPprDebug (ptext SLIT("Built in rule for") <+> pp_fn <> colon <+> doubleQuotes (ptext name))
 
 pprCoreRule pp_fn (Rule name act tpl_vars tpl_args rhs)
   = doubleQuotes (ptext name) <+> ppr act <+>