X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FPprCore.lhs;h=4d828b65b0bf7cc26d87e87d2c6cafe20ccdeafd;hb=21eeb926c8bf398e38919429d2375b78be45b14b;hp=55e192d34da812daeb88629468ec3d92ed5b7964;hpb=72462499b891d5779c19f3bda03f96e24f9554ae;p=ghc-hetmet.git

diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs
index 55e192d..4d828b6 100644
--- a/compiler/coreSyn/PprCore.lhs
+++ b/compiler/coreSyn/PprCore.lhs
@@ -17,12 +17,7 @@ import CostCentre
 import Var
 import Id
 import IdInfo
-import NewDemand
-#ifdef OLD_STRICTNESS
-import Id
-import IdInfo
-#endif
-
+import Demand
 import DataCon
 import TyCon
 import Type
@@ -123,7 +118,7 @@ ppr_expr add_par (Cast expr co)
   where
     pprCo co | opt_SuppressCoercions = ptext (sLit "...")
              | otherwise = parens
-                         $ sep [ppr co, dcolon <+> ppr (coercionKindPredTy co)]
+                         $ sep [ppr co, dcolon <+> pprEqPred (coercionKind co)]
 	 
 
 ppr_expr add_par expr@(Lam _ _)
@@ -269,9 +264,6 @@ pprCoreBinder LambdaBind bndr
 
 -- Case bound things don't get a signature or a herald, unless we have debug on
 pprCoreBinder CaseBind bndr 
-  | isDeadBinder bndr	 -- False for tyvars
-  = ptext (sLit "_")
-  | otherwise
   = getPprStyle $ \ sty ->
     if debugStyle sty then
 	parens (pprTypedBinder bndr)
@@ -311,7 +303,7 @@ pprIdBndrInfo info
   where
     prag_info = inlinePragInfo info
     occ_info  = occInfo info
-    dmd_info  = newDemandInfo info
+    dmd_info  = demandInfo info
     lbv_info  = lbvarInfo info
 
     has_prag = not (isDefaultInlinePragma prag_info)
@@ -339,7 +331,7 @@ ppIdInfo id info
     [ (True, pp_scope <> ppr (idDetails id))
     , (has_arity,      ptext (sLit "Arity=") <> int arity)
     , (has_caf_info,   ptext (sLit "Caf=") <> ppr caf_info)
-    , (has_strictness, ptext (sLit "Str=") <> pprNewStrictness str_info)
+    , (has_strictness, ptext (sLit "Str=") <> pprStrictness str_info)
     , (has_unf,        ptext (sLit "Unf=") <> ppr unf_info)
     , (not (null rules), ptext (sLit "RULES:") <+> vcat (map pprRule rules))
     ]	-- Inline pragma, occ, demand, lbvar info
@@ -356,7 +348,7 @@ ppIdInfo id info
     caf_info = cafInfo info
     has_caf_info = not (mayHaveCafRefs caf_info)
 
-    str_info = newStrictnessInfo info
+    str_info = strictnessInfo info
     has_strictness = isJust str_info
 
     unf_info = unfoldingInfo info
@@ -378,42 +370,48 @@ showAttributes stuff
 
 \begin{code}
 instance Outputable UnfoldingGuidance where
-    ppr UnfoldNever  = ptext (sLit "NEVER")
-    ppr UnfoldAlways = ptext (sLit "ALWAYS")
-    ppr (InlineRule { ug_ir_info = inl_info, ug_small = small })
-      = ptext (sLit "InlineRule") <> ppr (inl_info,small)
-    ppr (UnfoldIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount })
+    ppr UnfNever  = ptext (sLit "NEVER")
+    ppr (UnfWhen sat_ok boring_ok)
+      = ptext (sLit "ALWAYS_IF") <> 
+        parens (ptext (sLit "sat_ok=") <> ppr sat_ok <> comma <>
+                ptext (sLit "boring_ok=") <> ppr boring_ok)
+    ppr (UnfIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount })
       = hsep [ ptext (sLit "IF_ARGS"), 
 	       brackets (hsep (map int cs)),
 	       int size,
 	       int discount ]
 
-instance Outputable InlineRuleInfo where
-  ppr (InlWrapper w) = ptext (sLit "worker=") <> ppr w
-  ppr InlSat         = ptext (sLit "sat")
-  ppr InlUnSat       = ptext (sLit "unsat")
+instance Outputable UnfoldingSource where
+  ppr InlineCompulsory  = ptext (sLit "Compulsory")
+  ppr (InlineWrapper w) = ptext (sLit "Worker=") <> ppr w
+  ppr InlineRule        = ptext (sLit "InlineRule")
+  ppr InlineRhs         = ptext (sLit "<vanilla>")
 
 instance Outputable Unfolding where
   ppr NoUnfolding             = ptext (sLit "No unfolding")
   ppr (OtherCon cs)           = ptext (sLit "OtherCon") <+> ppr cs
   ppr (DFunUnfolding con ops) = ptext (sLit "DFun") <+> ppr con
                                  <+> brackets (pprWithCommas pprParendExpr ops)
-  ppr (CoreUnfolding { uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf, uf_is_cheap=cheap
+  ppr (CoreUnfolding { uf_src = src
+                     , uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf
+                     , uf_is_conlike=conlike, uf_is_cheap=cheap
       		     , uf_expandable=exp, uf_guidance=g, uf_arity=arity}) 
 	= ptext (sLit "Unf") <> braces (pp_info $$ pp_rhs)
     where
-      pp_info = hsep [ ptext (sLit "TopLvl=") <> ppr top 
-                     , ptext (sLit "Arity=") <> int arity
-                     , ptext (sLit "Value=") <> ppr hnf
-                     , ptext (sLit "Cheap=") <> ppr cheap
-                     , ptext (sLit "Expandable=") <> ppr exp
-                     , ppr g ]
-      pp_rhs = case g of
-      	      	  UnfoldNever         -> usually_empty
-		  UnfoldIfGoodArgs {} -> usually_empty
-                  _other              -> ppr rhs
-      usually_empty = ifPprDebug (ppr rhs)
-            -- In this case show 'rhs' only in debug mode
+      pp_info = fsep $ punctuate comma 
+                [ ptext (sLit "Src=")        <> ppr src
+                , ptext (sLit "TopLvl=")     <> ppr top 
+                , ptext (sLit "Arity=")      <> int arity
+                , ptext (sLit "Value=")      <> ppr hnf
+                , ptext (sLit "ConLike=")    <> ppr conlike
+                , ptext (sLit "Cheap=")      <> ppr cheap
+                , ptext (sLit "Expandable=") <> ppr exp
+                , ptext (sLit "Guidance=")   <> ppr g ]
+      pp_tmpl = ptext (sLit "Tmpl=") <+> ppr rhs
+      pp_rhs | isInlineRuleSource src = pp_tmpl
+             | otherwise              = empty
+            -- Don't print the RHS or we get a quadratic 
+	    -- blowup in the size of the printout!
 \end{code}
 
 -----------------------------------------------------