X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FPprCore.lhs;h=e20d5ee8c46e3af3ba0a757b3e6240b3286c8acd;hb=ac10f8408520a30e8437496d320b8b86afda2e8f;hp=84e7810fe5d9b9ed25406c4f54f70f17a698cdcb;hpb=a7ecdf96844404b7bc8273d4ff6d85759278427c;p=ghc-hetmet.git

diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs
index 84e7810..e20d5ee 100644
--- a/ghc/compiler/coreSyn/PprCore.lhs
+++ b/ghc/compiler/coreSyn/PprCore.lhs
@@ -19,19 +19,19 @@ module PprCore (
 import CoreSyn
 import CostCentre	( pprCostCentreCore )
 import Var		( Var )
-import Id		( Id, idType, isDataConWorkId_maybe, idLBVarInfo, idArity,
-			  idInfo, idInlinePragma, idOccInfo,
-			  globalIdDetails, isGlobalId, isExportedId, 
-			  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, specInfoRules
 			)
-
+import NewDemand	( isTop )
 #ifdef OLD_STRICTNESS
 import Id		( idDemandInfo )
 import IdInfo		( cprInfo, ppCprInfo, strictnessInfo, ppStrictnessInfo ) 
@@ -40,7 +40,7 @@ import IdInfo		( cprInfo, ppCprInfo, strictnessInfo, ppStrictnessInfo )
 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 )
@@ -101,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}
@@ -301,15 +301,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}