X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FPprCore.lhs;h=3752d1d5bd4239f96653998a4996bc0ad31618de;hb=14a496fd0b3aa821b69eb02736d5f41086576761;hp=950e37bc84cc049f5774f70e726cb28e80866798;hpb=2662dbc5b2c30fc11ccb99e7f9b2dba794d680ba;p=ghc-hetmet.git

diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs
index 950e37b..3752d1d 100644
--- a/compiler/coreSyn/PprCore.lhs
+++ b/compiler/coreSyn/PprCore.lhs
@@ -247,39 +247,37 @@ instance OutputableBndr Var where
 
 pprCoreBinder :: BindingSite -> Var -> SDoc
 pprCoreBinder LetBind binder
-  | isTyVar binder = pprKindedTyVarBndr binder
+  | isTyCoVar binder = pprKindedTyVarBndr binder
   | otherwise      = pprTypedBinder binder $$ 
 		     ppIdInfo binder (idInfo binder)
 
 -- Lambda bound type variables are preceded by "@"
-pprCoreBinder LambdaBind bndr 
-  | isDeadBinder bndr
+pprCoreBinder bind_site bndr 
   = getPprStyle $ \ sty ->
-    if debugStyle sty then
-	parens (pprTypedBinder bndr)
-    else
-	char '_'
-  | otherwise
-  = parens (pprTypedBinder bndr)
-
--- Case bound things don't get a signature or a herald, unless we have debug on
-pprCoreBinder CaseBind bndr 
-  = getPprStyle $ \ sty ->
-    if debugStyle sty then
-	parens (pprTypedBinder bndr)
-    else
-	if isDeadBinder bndr then char '_'
-	else pprUntypedBinder bndr
+    pprTypedLCBinder bind_site (debugStyle sty) bndr
 
 pprUntypedBinder :: Var -> SDoc
 pprUntypedBinder binder
-  | isTyVar binder = ptext (sLit "@") <+> ppr binder	-- NB: don't print kind
+  | isTyCoVar binder = ptext (sLit "@") <+> ppr binder	-- NB: don't print kind
   | otherwise      = pprIdBndr binder
 
+pprTypedLCBinder :: BindingSite -> Bool -> Var -> SDoc
+-- For lambda and case binders, show the unfolding info (usually none)
+pprTypedLCBinder bind_site debug_on var
+  | not debug_on && isDeadBinder var    = char '_'
+  | not debug_on, CaseBind <- bind_site = pprUntypedBinder var  -- No parens, no kind info
+  | isTyCoVar var                         = parens (pprKindedTyVarBndr var)
+  | otherwise = parens (hang (pprIdBndr var) 
+                           2 (vcat [ dcolon <+> pprType (idType var), pp_unf]))
+              where
+		unf_info = unfoldingInfo (idInfo var)
+                pp_unf | hasSomeUnfolding unf_info = ptext (sLit "Unf=") <> ppr unf_info
+                       | otherwise                 = empty
+
 pprTypedBinder :: Var -> SDoc
 -- Print binder with a type or kind signature (not paren'd)
 pprTypedBinder binder
-  | isTyVar binder  = pprKindedTyVarBndr binder
+  | isTyCoVar binder  = pprKindedTyVarBndr binder
   | otherwise	    = hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder))
 
 pprKindedTyVarBndr :: TyVar -> SDoc
@@ -370,37 +368,38 @@ showAttributes stuff
 
 \begin{code}
 instance Outputable UnfoldingGuidance where
-    ppr UnfoldNever  = ptext (sLit "NEVER")
-    ppr (InlineRule { ir_info = info, ir_sat = sat })
-      = ptext (sLit "InlineRule") <> ppr (sat,info)
-    ppr (UnfoldIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount })
+    ppr UnfNever  = ptext (sLit "NEVER")
+    ppr (UnfWhen unsat_ok boring_ok)
+      = ptext (sLit "ALWAYS_IF") <> 
+        parens (ptext (sLit "unsat_ok=") <> ppr unsat_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 InlSatFlag where
-  ppr InlSat         = ptext (sLit "sat")
-  ppr InlUnSat       = ptext (sLit "unsat")
-
-instance Outputable InlineRuleInfo where
-  ppr (InlWrapper w) = ptext (sLit "worker=") <> ppr w
-  ppr InlSmall       = ptext (sLit "small")
-  ppr InlAlways      = ptext (sLit "always")
-  ppr InlVanilla     = ptext (sLit "-")
+instance Outputable UnfoldingSource where
+  ppr InlineCompulsory  = ptext (sLit "Compulsory")
+  ppr (InlineWrapper w) = ptext (sLit "Worker=") <> ppr w
+  ppr InlineStable      = ptext (sLit "InlineStable")
+  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
+  ppr NoUnfolding             	 = ptext (sLit "No unfolding")
+  ppr (OtherCon cs)           	 = ptext (sLit "OtherCon") <+> ppr cs
+  ppr (DFunUnfolding ar con ops) = ptext (sLit "DFun") <> parens (ptext (sLit "arity=") <> int ar)  
+                                   <+> ppr con
+                                   <+> brackets (pprWithCommas pprParendExpr ops)
+  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 = fsep $ punctuate comma 
-                [ ptext (sLit "TopLvl=")     <> ppr top 
+                [ 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
@@ -408,11 +407,8 @@ instance Outputable Unfolding where
                 , ptext (sLit "Expandable=") <> ppr exp
                 , ptext (sLit "Guidance=")   <> ppr g ]
       pp_tmpl = ptext (sLit "Tmpl=") <+> ppr rhs
-      pp_rhs = case g of
-      	      	  UnfoldNever         -> usually_empty
-		  UnfoldIfGoodArgs {} -> usually_empty
-                  _other              -> pp_tmpl
-      usually_empty = ifPprDebug (ptext (sLit "<rhs>"))
+      pp_rhs | isStableSource src = pp_tmpl
+             | otherwise          = empty
             -- Don't print the RHS or we get a quadratic 
 	    -- blowup in the size of the printout!
 \end{code}