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