X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FPprCore.lhs;h=463f3c95fcc9fa26c6ebf5c008b8dec9a4e0f0cf;hp=f167a1fcfbc702aaacabd4c7d82f0a6cd0bad421;hb=HEAD;hpb=13b1fa907fd5d700167cc4da26668fb356d5ecfc

diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs
index f167a1f..463f3c9 100644
--- a/compiler/coreSyn/PprCore.lhs
+++ b/compiler/coreSyn/PprCore.lhs
@@ -106,7 +106,9 @@ ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc
 	-- The function adds parens in context that need
 	-- an atomic value (e.g. function args)
 
-ppr_expr add_par (Type ty)  = add_par (ptext (sLit "TYPE") <+> ppr ty)	-- Wierd
+ppr_expr add_par (Type ty) = add_par (ptext (sLit "TYPE") <+> ppr ty)	-- Wierd
+
+ppr_expr add_par (Coercion co) = add_par (ptext (sLit "CO") <+> ppr co)
 	           
 ppr_expr _       (Var name) = ppr name
 ppr_expr _       (Lit lit)  = ppr lit
@@ -255,8 +257,8 @@ pprArg :: OutputableBndr a => Expr a -> SDoc
 pprArg (Type ty) 
  | opt_SuppressTypeApplications	= empty
  | otherwise			= ptext (sLit "@") <+> pprParendType ty
-
-pprArg expr      = pprParendExpr expr
+pprArg (Coercion co) = ptext (sLit "@~") <+> pprParendCo co
+pprArg expr          = pprParendExpr expr
 \end{code}
 
 Other printing bits-and-bobs used with the general @pprCoreBinding@
@@ -268,7 +270,7 @@ instance OutputableBndr Var where
 
 pprCoreBinder :: BindingSite -> Var -> SDoc
 pprCoreBinder LetBind binder
-  | isTyCoVar binder = pprKindedTyVarBndr binder
+  | isTyVar binder = pprKindedTyVarBndr binder
   | otherwise      = pprTypedBinder binder $$ 
 		     ppIdInfo binder (idInfo binder)
 
@@ -279,7 +281,7 @@ pprCoreBinder bind_site bndr
 
 pprUntypedBinder :: Var -> SDoc
 pprUntypedBinder binder
-  | isTyCoVar binder = ptext (sLit "@") <+> ppr binder	-- NB: don't print kind
+  | isTyVar binder = ptext (sLit "@") <+> ppr binder	-- NB: don't print kind
   | otherwise      = pprIdBndr binder
 
 pprTypedLCBinder :: BindingSite -> Bool -> Var -> SDoc
@@ -287,7 +289,7 @@ pprTypedLCBinder :: BindingSite -> Bool -> Var -> SDoc
 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)
+  | isTyVar var                         = parens (pprKindedTyVarBndr var)
   | otherwise = parens (hang (pprIdBndr var) 
                            2 (vcat [ dcolon <+> pprType (idType var), pp_unf]))
               where
@@ -298,7 +300,7 @@ pprTypedLCBinder bind_site debug_on var
 pprTypedBinder :: Var -> SDoc
 -- Print binder with a type or kind signature (not paren'd)
 pprTypedBinder binder
-  | isTyCoVar binder		= pprKindedTyVarBndr binder
+  | isTyVar binder		= pprKindedTyVarBndr binder
   | opt_SuppressTypeSignatures	= empty
   | otherwise			= hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder))
 
@@ -415,8 +417,7 @@ instance Outputable Unfolding where
   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 con <+> brackets (pprWithCommas ppr 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
@@ -437,10 +438,15 @@ instance Outputable Unfolding where
              | otherwise          = empty
             -- Don't print the RHS or we get a quadratic 
 	    -- blowup in the size of the printout!
+
+instance Outputable e => Outputable (DFunArg e) where
+  ppr (DFunPolyArg e)  = braces (ppr e)
+  ppr (DFunConstArg e) = ppr e
+  ppr (DFunLamArg i)   = char '<' <> int i <> char '>'
 \end{code}
 
 -----------------------------------------------------
---	Rules
+--      Rules
 -----------------------------------------------------
 
 \begin{code}
@@ -455,11 +461,23 @@ pprRule (BuiltinRule { ru_fn = fn, ru_name = name})
   = ptext (sLit "Built in rule for") <+> ppr fn <> colon <+> doubleQuotes (ftext name)
 
 pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn,
-		ru_bndrs = tpl_vars, ru_args = tpl_args,
-		ru_rhs = rhs })
+                ru_bndrs = tpl_vars, ru_args = tpl_args,
+                ru_rhs = rhs })
   = hang (doubleQuotes (ftext name) <+> ppr act)
        4 (sep [ptext (sLit "forall") <+> braces (sep (map pprTypedBinder tpl_vars)),
-	       nest 2 (ppr fn <+> sep (map pprArg tpl_args)),
-	       nest 2 (ptext (sLit "=") <+> pprCoreExpr rhs)
-	    ])
+               nest 2 (ppr fn <+> sep (map pprArg tpl_args)),
+               nest 2 (ptext (sLit "=") <+> pprCoreExpr rhs)
+            ])
+\end{code}
+
+-----------------------------------------------------
+--      Vectorisation declarations
+-----------------------------------------------------
+
+\begin{code}
+instance Outputable CoreVect where
+  ppr (Vect   var Nothing)  = ptext (sLit "VECTORISE SCALAR") <+> ppr var
+  ppr (Vect   var (Just e)) = hang (ptext (sLit "VECTORISE") <+> ppr var <+> char '=')
+                                4 (pprCoreExpr e)
+  ppr (NoVect var)          = ptext (sLit "NOVECTORISE") <+> ppr var
 \end{code}