[project @ 1999-04-27 17:33:49 by sof]

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

diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs
index 133e533..9972096 100644 (file)
--- a/ghc/compiler/coreSyn/PprCore.lhs
+++ b/ghc/compiler/coreSyn/PprCore.lhs
@@ -16,12 +16,19 @@ module PprCore (
 #include "HsVersions.h"
 
 import CoreSyn
+import CostCentre      ( pprCostCentreCore )
 import Id              ( idType, idInfo, getInlinePragma, getIdDemandInfo, Id )
 import Var             ( isTyVar )
-import IdInfo          ( ppIdInfo )
+import IdInfo          ( IdInfo,
+                         arityInfo, ppArityInfo,
+                         demandInfo, updateInfo, ppUpdateInfo, specInfo, 
+                         strictnessInfo, ppStrictnessInfo, cafInfo, ppCafInfo,
+                         cprInfo, ppCprInfo
+                       )
 import Const           ( Con(..), DataCon )
 import DataCon         ( isTupleCon, isUnboxedTupleCon )
 import PprType         ( pprParendType, pprTyVarBndr )
+import SpecEnv         ( specEnvToList )
 import PprEnv
 import Outputable
 \end{code}
@@ -69,13 +76,13 @@ pprIfaceEnv = initCoreEnv pprIfaceBinder
 \end{code}
 
 \begin{code}
-instance Outputable b => Outputable (Bind b f) where
+instance Outputable b => Outputable (Bind b) where
     ppr bind = ppr_bind pprGenericEnv bind
 
-instance Outputable b => Outputable (Expr b f) where
+instance Outputable b => Outputable (Expr b) where
     ppr expr = ppr_expr pprGenericEnv expr
 
-pprGenericEnv :: Outputable b => PprEnv b f
+pprGenericEnv :: Outputable b => PprEnv b
 pprGenericEnv = initCoreEnv (\site -> ppr)
 \end{code}
 
@@ -89,15 +96,14 @@ pprGenericEnv = initCoreEnv (\site -> ppr)
 \begin{code}
 initCoreEnv pbdr
   = initPprEnv
-       (Just ppr)              -- Constants
-       (Just ppr)              -- Cost centres
+       (Just ppr)                      -- Constants
+       (Just pprCostCentreCore)        -- Cost centres
 
        (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}
 
 %************************************************************************
@@ -120,14 +126,14 @@ pprTopBind pe (Rec binds)
 \end{code}
 
 \begin{code}
-ppr_bind :: PprEnv b f -> Bind b f -> SDoc
+ppr_bind :: PprEnv b -> Bind b -> SDoc
 
 ppr_bind pe (NonRec val_bdr expr) = ppr_binding_pe pe (val_bdr, expr)
 ppr_bind pe (Rec binds)          = vcat (map pp binds)
                                  where
                                    pp bind = ppr_binding_pe pe bind <> semi
 
-ppr_binding_pe :: PprEnv b f -> (b, Expr b f) -> SDoc
+ppr_binding_pe :: PprEnv b -> (b, Expr b) -> SDoc
 ppr_binding_pe pe (val_bdr, expr)
   = sep [pBndr pe LetBind val_bdr, 
         nest 2 (equals <+> ppr_expr pe expr)]
@@ -146,7 +152,7 @@ ppr_parend_expr pe expr
 \end{code}
 
 \begin{code}
-ppr_expr :: PprEnv b f -> Expr b f -> SDoc
+ppr_expr :: PprEnv b -> Expr b -> SDoc
 
 ppr_expr pe (Type ty)  = ptext SLIT("TYPE") <+> ppr ty -- Wierd
 
@@ -235,8 +241,7 @@ ppr_expr pe (Let bind expr)
                NonRec _ _ -> SLIT("let {")
 
 ppr_expr pe (Note (SCC cc) expr)
-  = sep [hsep [ptext SLIT("__scc"), pSCC pe cc],
-        ppr_parend_expr pe expr ]
+  = sep [pSCC pe cc, ppr_expr pe expr]
 
 #ifdef DEBUG
 ppr_expr pe (Note (Coerce to_ty from_ty) expr)
@@ -272,7 +277,7 @@ ppr_case_pat pe con args
   where
     ppr_bndr = pBndr pe CaseBind
 
-ppr_arg pe (Type ty) = ptext SLIT("__a") <+> pTy pe ty
+ppr_arg pe (Type ty) = ptext SLIT("@") <+> pTy pe ty
 ppr_arg pe expr      = ppr_parend_expr pe expr
 
 arrow = ptext SLIT("->")
@@ -289,7 +294,7 @@ pprCoreBinder LetBind binder
     sig     = pprTypedBinder binder
     pragmas = ppIdInfo (idInfo binder)
 
--- Lambda bound type variables are preceded by "__a"
+-- Lambda bound type variables are preceded by "@"
 pprCoreBinder LambdaBind bndr = pprTypedBinder bndr
 
 -- Case bound things don't get a signature or a herald
@@ -304,8 +309,8 @@ pprUntypedBinder binder
   | otherwise      = pprIdBndr binder
 
 pprTypedBinder binder
-  | isTyVar binder  = ptext SLIT("__a") <+> pprTyVarBndr binder
-  | otherwise      = pprIdBndr binder <+> ptext SLIT("::") <+> pprParendType (idType binder)
+  | isTyVar binder  = ptext SLIT("@") <+> pprTyVarBndr binder
+  | otherwise      = pprIdBndr binder <+> dcolon <+> pprParendType (idType binder)
        -- The space before the :: is important; it helps the lexer
        -- when reading inferfaces.  Otherwise it would lex "a::b" as one thing.
        --
@@ -315,3 +320,41 @@ pprTypedBinder binder
 -- When printing any Id binder in debug mode, we print its inline pragma
 pprIdBndr id = ppr id <+> ifPprDebug (ppr (getInlinePragma id) <+> ppr (getIdDemandInfo id)) 
 \end{code}
+
+
+\begin{code}
+ppIdInfo :: IdInfo -> SDoc
+ppIdInfo info
+  = hsep [
+           ppArityInfo a,
+           ppUpdateInfo u,
+           ppStrictnessInfo s,
+           ppr d,
+           ppCafInfo c,
+            ppCprInfo m,
+           ppSpecInfo 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}
+ppSpecInfo spec_env
+  = vcat (map pp_item (specEnvToList spec_env))
+  where
+    pp_item (tyvars, tys, rhs) = hsep [ptext SLIT("__P"),
+                                      hsep (map pprParendType tys),
+                                      ptext SLIT("->"),
+                                      ppr head]
+       where
+          (_, body) = collectBinders rhs
+          (head, _) = collectArgs body
+\end{code}
+