ghc/compiler/hsSyn/HsCore.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
   3 %
   4 %************************************************************************
   5 %*                                                                      *
   6 \section[HsCore]{Core-syntax unfoldings in Haskell interface files}
   7 %*                                                                      *
   8 %************************************************************************
   9
  10 We could either use this, or parameterise @GenCoreExpr@ on @Types@ and
  11 @TyVars@ as well.  Currently trying the former... MEGA SIGH.
  12
  13 \begin{code}
  14 module HsCore (
  15         UfExpr(..), UfAlts(..), UfBinder(..), UfCoercion(..),
  16         UfDefault(..), UfBinding(..),
  17         UfArg(..), UfPrimOp(..)
  18     ) where
  19
  20 #include "HsVersions.h"
  21
  22 -- friends:
  23 import HsTypes          ( HsType, pprParendHsType )
  24 import PrimOp           ( PrimOp, tagOf_PrimOp )
  25 import Kind             ( Kind {- instance Outputable -} )
  26 import Type             ( GenType {- instance Outputable -} )
  27
  28 -- others:
  29 import Literal          ( Literal )
  30 import Util             ( panic )
  31 import CostCentre
  32 import Outputable
  33 \end{code}
  34
  35 %************************************************************************
  36 %*                                                                      *
  37 \subsection[HsCore-types]{Types for read/written Core unfoldings}
  38 %*                                                                      *
  39 %************************************************************************
  40
  41 \begin{code}
  42 data UfExpr name
  43   = UfVar       name
  44   | UfLit       Literal
  45   | UfCon       name [UfArg name]
  46   | UfPrim      (UfPrimOp name) [UfArg name]
  47   | UfLam       (UfBinder name)   (UfExpr name)
  48   | UfApp       (UfExpr name) (UfArg name)
  49   | UfCase      (UfExpr name) (UfAlts name)
  50   | UfLet       (UfBinding name)  (UfExpr name)
  51   | UfSCC       CostCentre (UfExpr name)
  52   | UfCoerce    (UfCoercion name) (HsType name) (UfExpr name)
  53
  54 data UfPrimOp name
  55   = UfCCallOp   FAST_STRING          -- callee
  56                 Bool                 -- True <=> casm, rather than ccall
  57                 Bool                 -- True <=> might cause GC
  58                 [HsType name] -- arg types, incl state token
  59                                      -- (which will be first)
  60                 (HsType name) -- return type
  61
  62   | UfOtherOp   name
  63
  64 data UfCoercion name = UfIn name | UfOut name
  65
  66 data UfAlts name
  67   = UfAlgAlts  [(name, [name], UfExpr name)]
  68                 (UfDefault name)
  69   | UfPrimAlts [(Literal, UfExpr name)]
  70                 (UfDefault name)
  71
  72 data UfDefault name
  73   = UfNoDefault
  74   | UfBindDefault name (UfExpr name)
  75
  76 data UfBinding name
  77   = UfNonRec    (UfBinder name)
  78                 (UfExpr name)
  79   | UfRec       [(UfBinder name, UfExpr name)]
  80
  81 data UfBinder name
  82   = UfValBinder name (HsType name)
  83   | UfTyBinder  name Kind
  84
  85 data UfArg name
  86   = UfVarArg    name
  87   | UfLitArg    Literal
  88   | UfTyArg     (HsType name)
  89 \end{code}
  90
  91 %************************************************************************
  92 %*                                                                      *
  93 \subsection[HsCore-print]{Printing Core unfoldings}
  94 %*                                                                      *
  95 %************************************************************************
  96
  97 \begin{code}
  98 instance Outputable name => Outputable (UfExpr name) where
  99     ppr (UfVar v) = ppr v
 100     ppr (UfLit l) = ppr l
 101
 102     ppr (UfCon c as)
 103       = hsep [text "UfCon", ppr c, ppr as, char ')']
 104     ppr (UfPrim o as)
 105       = hsep [text "UfPrim", ppr o, ppr as, char ')']
 106
 107     ppr (UfLam b body)
 108       = hsep [char '\\', ppr b, ptext SLIT("->"), ppr body]
 109
 110     ppr (UfApp fun (UfTyArg ty))
 111       = hsep [ppr fun, char '@', pprParendHsType ty]
 112
 113     ppr (UfApp fun (UfLitArg lit))
 114       = hsep [ppr fun, ppr lit]
 115
 116     ppr (UfApp fun (UfVarArg var))
 117       = hsep [ppr fun, ppr var]
 118
 119     ppr (UfCase scrut alts)
 120       = hsep [ptext SLIT("case"), ppr scrut, ptext SLIT("of {"), pp_alts alts, char '}']
 121       where
 122         pp_alts (UfAlgAlts alts deflt)
 123           = hsep [hsep (punctuate semi (map pp_alt alts)), pp_deflt deflt]
 124           where
 125            pp_alt (c,bs,rhs) = hsep [ppr c, ppr bs, ppr_arrow, ppr rhs]
 126         pp_alts (UfPrimAlts alts deflt)
 127           = hsep [hsep (punctuate semi (map pp_alt alts)), pp_deflt deflt]
 128           where
 129            pp_alt (l,rhs) = hsep [ppr l, ppr_arrow, ppr rhs]
 130
 131         pp_deflt UfNoDefault = empty
 132         pp_deflt (UfBindDefault b rhs) = hsep [ppr b, ppr_arrow, ppr rhs]
 133
 134         ppr_arrow = ptext SLIT("->")
 135
 136     ppr (UfLet (UfNonRec b rhs) body)
 137       = hsep [ptext SLIT("let"), ppr b, equals, ppr rhs, ptext SLIT("in"), ppr body]
 138     ppr (UfLet (UfRec pairs) body)
 139       = hsep [ptext SLIT("letrec"), braces (hsep (punctuate semi (map pp_pair pairs))), ptext SLIT("in"), ppr body]
 140       where
 141         pp_pair (b,rhs) = hsep [ppr b, equals, ppr rhs]
 142
 143     ppr (UfSCC uf_cc body)
 144       = hsep [ptext SLIT("_scc_ <cost-centre[ToDo]>"), ppr body]
 145
 146 instance Outputable name => Outputable (UfPrimOp name) where
 147     ppr (UfCCallOp str is_casm can_gc arg_tys result_ty)
 148       = let
 149             before = ptext (if is_casm then SLIT("_casm_ ``") else SLIT("_ccall_ "))
 150             after  = if is_casm then text "'' " else space
 151         in
 152         hcat [before, ptext str, after,
 153                    brackets (ppr arg_tys), space, ppr result_ty]
 154
 155     ppr (UfOtherOp op)
 156       = ppr op
 157
 158 instance Outputable name => Outputable (UfArg name) where
 159     ppr (UfVarArg v)    = ppr v
 160     ppr (UfLitArg l)    = ppr l
 161     ppr (UfTyArg ty)    = pprParendHsType ty
 162
 163 instance Outputable name => Outputable (UfBinder name) where
 164     ppr (UfValBinder name ty)  = hsep [ppr name, ptext SLIT("::"), ppr ty]
 165     ppr (UfTyBinder name kind) = hsep [ppr name, ptext SLIT("::"), ppr kind]
 166 \end{code}
 167