[project @ 2000-01-04 17:40:46 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 ba81cee..92db05f 100644 (file)
--- a/ghc/compiler/coreSyn/PprCore.lhs
+++ b/ghc/compiler/coreSyn/PprCore.lhs
@@ -9,17 +9,24 @@
 
 \begin{code}
 module PprCore (
-       pprCoreExpr, pprIfaceUnfolding, 
-       pprCoreBinding, pprCoreBindings, pprIdBndr
+       pprCoreExpr, pprParendExpr, pprIfaceUnfolding, 
+       pprCoreBinding, pprCoreBindings, pprIdBndr,
+       pprCoreRules, pprCoreRule
     ) where
 
 #include "HsVersions.h"
 
 import CoreSyn
 import CostCentre      ( pprCostCentreCore )
-import Id              ( idType, idInfo, getInlinePragma, getIdDemandInfo, Id )
+import Id              ( idType, idInfo, getInlinePragma, getIdDemandInfo, getIdOccInfo, Id )
 import Var             ( isTyVar )
-import IdInfo          ( ppIdInfo )
+import IdInfo          ( IdInfo,
+                         arityInfo, ppArityInfo, ppFlavourInfo, flavourInfo,
+                         demandInfo, updateInfo, ppUpdateInfo, specInfo, 
+                         strictnessInfo, ppStrictnessInfo, cafInfo, ppCafInfo,
+                         cprInfo, ppCprInfo, lbvarInfo,
+                         workerInfo, ppWorkerInfo
+                       )
 import Const           ( Con(..), DataCon )
 import DataCon         ( isTupleCon, isUnboxedTupleCon )
 import PprType         ( pprParendType, pprTyVarBndr )
@@ -52,10 +59,12 @@ Un-annotated core dumps
 pprCoreBindings :: [CoreBind] -> SDoc
 pprCoreBinding  :: CoreBind   -> SDoc
 pprCoreExpr     :: CoreExpr   -> SDoc
+pprParendExpr   :: CoreExpr   -> SDoc
 
 pprCoreBindings = pprTopBinds pprCoreEnv
 pprCoreBinding  = pprTopBind pprCoreEnv
 pprCoreExpr     = ppr_expr pprCoreEnv
+pprParendExpr   = ppr_parend_expr pprCoreEnv
 
 pprCoreEnv = initCoreEnv pprCoreBinder
 \end{code}
@@ -64,7 +73,10 @@ Printer for unfoldings in interfaces
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 \begin{code}
 pprIfaceUnfolding :: CoreExpr -> SDoc
-pprIfaceUnfolding = ppr_expr pprIfaceEnv
+pprIfaceUnfolding = ppr_parend_expr pprIfaceEnv
+       -- Notice that it's parenthesised
+
+pprIfaceArg = ppr_arg pprIfaceEnv
 
 pprIfaceEnv = initCoreEnv pprIfaceBinder
 \end{code}
@@ -96,9 +108,8 @@ initCoreEnv pbdr
        (Just ppr)              -- tyvar occs
        (Just pprParendType)    -- types
 
-       (Just pbdr) (Just pprIdBndr) -- value vars
-       -- The pprIdBndr part here is a temporary debugging aid
-       -- Revert to ppr if it gets tiresome
+       (Just pbdr) (Just ppr) -- value vars
+       -- Use pprIdBndr for this last one as a debugging device.
 \end{code}
 
 %************************************************************************
@@ -240,21 +251,31 @@ ppr_expr pe (Note (SCC cc) expr)
 
 #ifdef DEBUG
 ppr_expr pe (Note (Coerce to_ty from_ty) expr)
- = \ sty ->
+ = getPprStyle $ \ sty ->
    if debugStyle sty && not (ifaceStyle sty) then
-      sep [hsep [ptext SLIT("__coerce"), pTy pe to_ty, pTy pe from_ty],
-                 ppr_parend_expr pe expr] sty
+      sep [ptext SLIT("__coerce") <+> sep [pTy pe to_ty, pTy pe from_ty],
+          ppr_parend_expr pe expr]
    else
       sep [hsep [ptext SLIT("__coerce"), pTy pe to_ty],
-                 ppr_parend_expr pe expr] sty
+                 ppr_parend_expr pe expr]
 #else
 ppr_expr pe (Note (Coerce to_ty from_ty) expr)
-  = sep [hsep [ptext SLIT("__coerce"), pTy pe to_ty],
+  = sep [sep [ptext SLIT("__coerce"), nest 4 (pTy pe to_ty)],
         ppr_parend_expr pe expr]
 #endif
 
 ppr_expr pe (Note InlineCall expr)
-  = ptext SLIT("__inline") <+> ppr_parend_expr pe expr
+  = ptext SLIT("__inline_call") <+> ppr_parend_expr pe expr
+
+ppr_expr pe (Note InlineMe expr)
+  = ptext SLIT("__inline_me") <+> ppr_parend_expr pe expr
+
+ppr_expr pe (Note (TermUsg u) expr)
+  = \ sty ->
+    if ifaceStyle sty then
+      ppr_expr pe expr sty
+    else
+      (ppr u <+> ppr_expr pe expr) sty
 
 ppr_case_pat pe con@(DataCon dc) args
   | isTupleCon dc
@@ -300,7 +321,7 @@ pprIfaceBinder CaseBind binder = pprUntypedBinder binder
 pprIfaceBinder other    binder = pprTypedBinder binder
 
 pprUntypedBinder binder
-  | isTyVar binder = pprTyVarBndr binder
+  | isTyVar binder = ptext SLIT("@") <+> pprTyVarBndr binder
   | otherwise      = pprIdBndr binder
 
 pprTypedBinder binder
@@ -312,6 +333,59 @@ pprTypedBinder binder
        -- It's important that the type is parenthesised too, at least when
        -- printing interfaces, because we get \ x::(a->b) y::(c->d) -> ...
 
--- When printing any Id binder in debug mode, we print its inline pragma
-pprIdBndr id = ppr id <+> ifPprDebug (ppr (getInlinePragma id) <+> ppr (getIdDemandInfo id)) 
+-- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
+pprIdBndr id = ppr id <+> ifPprDebug (ppr (getInlinePragma id) <+> ppr (getIdOccInfo id) <+> 
+                                     ppr (getIdDemandInfo id)) <+> ppr (lbvarInfo (idInfo id))
+\end{code}
+
+
+\begin{code}
+ppIdInfo :: IdInfo -> SDoc
+ppIdInfo info
+  = hsep [
+           ppFlavourInfo (flavourInfo info),
+           ppArityInfo a,
+           ppUpdateInfo u,
+           ppWorkerInfo (workerInfo info),
+           ppStrictnessInfo s,
+           ppr d,
+           ppCafInfo c,
+            ppCprInfo m,
+           ppr (lbvarInfo info),
+           pprIfaceCoreRules p
+       -- Inline pragma printed out with all binders; see PprCore.pprIdBndr
+       ]
+  where
+    a = arityInfo info
+    d = demandInfo info
+    s = strictnessInfo info
+    u = updateInfo info
+    c = cafInfo info
+    m = cprInfo info
+    p = specInfo info
+\end{code}
+
+
+\begin{code}
+pprCoreRules :: Id -> CoreRules -> SDoc
+pprCoreRules var (Rules rules _) = vcat (map (pprCoreRule (Just var)) rules)
+
+pprIfaceCoreRules :: CoreRules -> SDoc
+pprIfaceCoreRules (Rules rules _) = vcat (map (pprCoreRule Nothing) rules)
+
+pprCoreRule :: Maybe Id -> CoreRule -> SDoc
+pprCoreRule maybe_fn (BuiltinRule _)
+  = ifPprDebug (ptext SLIT("A built in rule"))
+
+pprCoreRule maybe_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 pprIfaceArg tpl_args)),
+         nest 4 (ptext SLIT("=") <+> pprIfaceUnfolding rhs)
+    ] <+> semi
+  where
+    pp_fn = case maybe_fn of
+               Just id -> ppr id
+               Nothing -> empty                -- Interface file
 \end{code}