X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FPprCore.lhs;h=864f4bdcb021d2d556a182b1d1115326cff96d67;hb=2d4b82a0a94edeaedd9d0c4b3f023ac8d1d59766;hp=29a822a6ad5d29d25f4f1e9923cb8e7078d25d8c;hpb=bf64f2050e84ea4afffe8af993a271a1e8dd5cab;p=ghc-hetmet.git

diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs
index 29a822a..864f4bd 100644
--- a/ghc/compiler/coreSyn/PprCore.lhs
+++ b/ghc/compiler/coreSyn/PprCore.lhs
@@ -11,7 +11,7 @@
 module PprCore (
 	pprCoreExpr, pprParendExpr,
 	pprCoreBinding, pprCoreBindings, pprCoreAlt,
-	pprIdRules
+	pprRules
     ) where
 
 #include "HsVersions.h"
@@ -19,29 +19,28 @@ module PprCore (
 import CoreSyn
 import CostCentre	( pprCostCentreCore )
 import Var		( Var )
-import Id		( Id, idType, isDataConWorkId_maybe, idLBVarInfo, idArity,
-			  idInfo, idInlinePragma, idOccInfo,
-#ifdef OLD_STRICTNESS
-			  idDemandInfo, 
-#endif
-			  globalIdDetails, isGlobalId, isExportedId, 
-			  isSpecPragmaId, idNewDemandInfo
+import Id		( Id, idType, isDataConWorkId_maybe, idArity,
+			  idInfo, globalIdDetails, isGlobalId, isExportedId 
 			)
 import Var		( TyVar, isTyVar, tyVarKind )
 import IdInfo		( IdInfo, megaSeqIdInfo, 
+			  inlinePragInfo, occInfo, newDemandInfo, 
+			  lbvarInfo, hasNoLBVarInfo,
 			  arityInfo, ppArityInfo, 
 			  specInfo, pprNewStrictness,
 			  workerInfo, ppWorkerInfo,
-			  newStrictnessInfo, cafInfo, ppCafInfo,
+			  newStrictnessInfo, cafInfo, ppCafInfo, specInfoRules
+			)
+import NewDemand	( isTop )
 #ifdef OLD_STRICTNESS
-			  cprInfo, ppCprInfo, 
-			  strictnessInfo, ppStrictnessInfo, 
+import Id		( idDemandInfo )
+import IdInfo		( cprInfo, ppCprInfo, strictnessInfo, ppStrictnessInfo ) 
 #endif
-			)
+
 import DataCon		( dataConTyCon )
 import TyCon		( tupleTyConBoxity, isTupleTyCon )
 import Type		( pprParendType, pprType, pprParendKind )
-import BasicTypes	( tupleParens )
+import BasicTypes	( tupleParens, isNoOcc, isAlwaysActive )
 import Util             ( lengthIs )
 import Outputable
 import FastString       ( mkFastString )
@@ -102,7 +101,7 @@ ppr_bind (Rec binds)  	       = vcat (map pp binds)
 ppr_binding :: OutputableBndr b => (b, Expr b) -> SDoc
 ppr_binding (val_bdr, expr)
   = pprBndr LetBind val_bdr $$ 
-    (ppr val_bdr <+> equals <+> pprCoreExpr expr)
+    hang (ppr val_bdr <+> equals) 2 (pprCoreExpr expr)
 \end{code}
 
 \begin{code}
@@ -153,11 +152,12 @@ ppr_expr add_par expr@(App fun arg)
 	other -> add_par (hang (pprParendExpr fun) 2 pp_args)
     }
 
-ppr_expr add_par (Case expr var [(con,args,rhs)])
+ppr_expr add_par (Case expr var ty [(con,args,rhs)])
   = add_par $
     sep [sep [ptext SLIT("case") <+> pprCoreExpr expr,
+	      ifPprDebug (braces (ppr ty)),
 	      hsep [ptext SLIT("of"),
-		    ppr_bndr var,
+		    ppr_bndr var, 
 		    char '{',
 		    ppr_case_pat con args
 	  ]],
@@ -167,9 +167,11 @@ ppr_expr add_par (Case expr var [(con,args,rhs)])
   where
     ppr_bndr = pprBndr CaseBind
 
-ppr_expr add_par (Case expr var alts)
+ppr_expr add_par (Case expr var ty alts)
   = add_par $
-    sep [sep [ptext SLIT("case") <+> pprCoreExpr expr,
+    sep [sep [ptext SLIT("case")
+		<+> pprCoreExpr expr
+		<+> ifPprDebug (braces (ppr ty)),
 	      ptext SLIT("of") <+> ppr_bndr var <+> char '{'],
 	 nest 2 (sep (punctuate semi (map pprCoreAlt alts))),
 	 char '}'
@@ -275,7 +277,7 @@ pprCoreBinder LetBind binder
     pragmas = ppIdInfo binder (idInfo binder)
 
 -- Lambda bound type variables are preceded by "@"
-pprCoreBinder LambdaBind bndr = pprTypedBinder bndr
+pprCoreBinder LambdaBind bndr = parens (pprTypedBinder bndr)
 
 -- Case bound things don't get a signature or a herald
 pprCoreBinder CaseBind bndr = pprUntypedBinder bndr
@@ -287,12 +289,6 @@ pprUntypedBinder binder
 pprTypedBinder binder
   | isTyVar binder  = ptext SLIT("@") <+> pprTyVarBndr binder
   | otherwise	    = pprIdBndr binder <+> dcolon <+> pprType (idType binder)
-	-- The space before the :: is important; it helps the lexer
-	-- when reading inferfaces.  Otherwise it would lex "a::b" as one thing.
-	--
-	-- It's important that the type is parenthesised too, at least when
-	-- printing interfaces, because we get \ x::(a->b) y::(c->d) -> ...
-	--	[Jun 2002: interfaces are now binary, so this doesn't matter]
 
 pprTyVarBndr :: TyVar -> SDoc
 pprTyVarBndr tyvar
@@ -307,15 +303,28 @@ pprTyVarBndr tyvar
 
 -- pprIdBndr does *not* print the type
 -- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
-pprIdBndr id = ppr id <+> 
-	       (megaSeqIdInfo (idInfo id) `seq`
-			-- Useful for poking on black holes
-	        ifPprDebug (ppr (idInlinePragma id) <+> ppr (idOccInfo id) <+> 
+pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id)
+
+pprIdBndrInfo info 
+  = megaSeqIdInfo `seq` doc -- The seq is useful for poking on black holes
+  where
+    prag_info = inlinePragInfo info
+    occ_info  = occInfo info
+    dmd_info  = newDemandInfo info
+    lbv_info  = lbvarInfo info
+
+    no_info = isAlwaysActive prag_info && isNoOcc occ_info && 
+	      (case dmd_info of { Nothing -> True; Just d -> isTop d }) &&
+	      hasNoLBVarInfo lbv_info
+
+    doc | no_info = empty
+ 	| otherwise
+        = brackets $ hcat [ppr prag_info, ppr occ_info, 
+			   ppr dmd_info, ppr lbv_info
 #ifdef OLD_STRICTNESS
-			    ppr (idDemandInfo id) <+>
+			   , ppr (demandInfo id)
 #endif
-			    ppr (idNewDemandInfo id) <+>
-			    ppr (idLBVarInfo id)))
+			  ]
 \end{code}
 
 
@@ -323,12 +332,12 @@ pprIdBndr id = ppr id <+>
 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 [  ppArityInfo a,
+  = brackets $
+    vcat [  ppArityInfo a,
 	    ppWorkerInfo (workerInfo info),
 	    ppCafInfo (cafInfo info),
 #ifdef OLD_STRICTNESS
@@ -336,7 +345,8 @@ ppIdInfo b info
             ppCprInfo m,
 #endif
 	    pprNewStrictness (newStrictnessInfo info),
-	    vcat (map (pprCoreRule (ppr b)) (rulesRules p))
+	    if null rules then empty
+	    else ptext SLIT("RULES:") <+> vcat (map pprRule rules)
 	-- Inline pragma, occ, demand, lbvar info
 	-- printed out with all binders (when debug is on); 
 	-- see PprCore.pprIdBndr
@@ -347,26 +357,28 @@ ppIdInfo b info
     s = strictnessInfo info
     m = cprInfo info
 #endif
-    p = specInfo info
+    rules = specInfoRules (specInfo info)
 \end{code}
 
 
 \begin{code}
-pprIdRules :: [IdCoreRule] -> SDoc
-pprIdRules rules = vcat (map pprIdRule rules)
+instance Outputable CoreRule where
+   ppr = pprRule
 
-pprIdRule :: IdCoreRule -> SDoc
-pprIdRule (id,rule) = pprCoreRule (ppr id) rule
+pprRules :: [CoreRule] -> SDoc
+pprRules rules = vcat (map pprRule rules)
 
-pprCoreRule :: SDoc -> CoreRule -> SDoc
-pprCoreRule pp_fn (BuiltinRule name _)
-  = ptext SLIT("Built in rule for") <+> pp_fn <> colon <+> doubleQuotes (ftext name)
+pprRule :: CoreRule -> SDoc
+pprRule (BuiltinRule { ru_fn = fn, ru_name = name})
+  = ptext SLIT("Built in rule for") <+> ppr fn <> colon <+> doubleQuotes (ftext name)
 
-pprCoreRule pp_fn (Rule name act tpl_vars tpl_args rhs)
+pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn,
+		ru_bndrs = tpl_vars, ru_args = tpl_args,
+		ru_rhs = rhs })
   = doubleQuotes (ftext name) <+> ppr act <+>
     sep [
 	  ptext SLIT("__forall") <+> braces (sep (map pprTypedBinder tpl_vars)),
-	  nest 2 (pp_fn <+> sep (map pprArg tpl_args)),
+	  nest 2 (ppr fn <+> sep (map pprArg tpl_args)),
 	  nest 2 (ptext SLIT("=") <+> pprCoreExpr rhs)
     ] <+> semi
 \end{code}