ghc/compiler/hsSyn/HsCore.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
   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(..), UfAlt, UfBinder(..), UfNote(..),
  16         UfBinding(..), UfCon(..),
  17         HsIdInfo(..), HsStrictnessInfo(..),
  18         IfaceSig(..), UfRuleBody(..)
  19     ) where
  20
  21 #include "HsVersions.h"
  22
  23 -- friends:
  24 import HsTypes          ( HsType, pprParendHsType )
  25
  26 -- others:
  27 import IdInfo           ( ArityInfo, UpdateInfo, InlinePragInfo, CprInfo )
  28 import CoreSyn          ( CoreBndr, CoreExpr )
  29 import Demand           ( Demand )
  30 import Const            ( Literal )
  31 import Type             ( Kind )
  32 import CostCentre
  33 import SrcLoc           ( SrcLoc )
  34 import Outputable
  35 \end{code}
  36
  37 %************************************************************************
  38 %*                                                                      *
  39 \subsection[HsCore-types]{Types for read/written Core unfoldings}
  40 %*                                                                      *
  41 %************************************************************************
  42
  43 \begin{code}
  44 data UfExpr name
  45   = UfVar       name
  46   | UfType      (HsType name)
  47   | UfCon       (UfCon name) [UfExpr name]
  48   | UfTuple     name [UfExpr name]              -- Type arguments omitted
  49   | UfLam       (UfBinder name)   (UfExpr name)
  50   | UfApp       (UfExpr name) (UfExpr name)
  51   | UfCase      (UfExpr name) name [UfAlt name]
  52   | UfLet       (UfBinding name)  (UfExpr name)
  53   | UfNote      (UfNote name) (UfExpr name)
  54
  55 data UfNote name = UfSCC CostCentre
  56                  | UfCoerce (HsType name)
  57                  | UfInlineCall
  58                  | UfInlineMe
  59
  60 type UfAlt name = (UfCon name, [name], UfExpr name)
  61
  62 data UfCon name = UfDefault
  63                 | UfDataCon name
  64                 | UfLitCon Literal
  65                 | UfLitLitCon FAST_STRING (HsType name)
  66                 | UfPrimOp name
  67                 | UfCCallOp FAST_STRING    -- callee
  68                             Bool           -- True => dynamic (first arg is fun. pointer)
  69                             Bool           -- True <=> casm, rather than ccall
  70                             Bool           -- True <=> might cause GC
  71
  72 data UfBinding name
  73   = UfNonRec    (UfBinder name)
  74                 (UfExpr name)
  75   | UfRec       [(UfBinder name, UfExpr name)]
  76
  77 data UfBinder name
  78   = UfValBinder name (HsType name)
  79   | UfTyBinder  name Kind
  80 \end{code}
  81
  82
  83 %************************************************************************
  84 %*                                                                      *
  85 \subsection[HsCore-print]{Printing Core unfoldings}
  86 %*                                                                      *
  87 %************************************************************************
  88
  89 \begin{code}
  90 instance Outputable name => Outputable (UfExpr name) where
  91     ppr (UfVar v) = ppr v
  92     ppr (UfType ty) = char '@' <+> pprParendHsType ty
  93
  94     ppr (UfCon c as)
  95       = hsep [text "UfCon", ppr c, ppr as]
  96
  97     ppr (UfTuple c as) = parens (hsep (punctuate comma (map ppr as)))
  98
  99     ppr (UfLam b body)
 100       = hsep [char '\\', ppr b, ptext SLIT("->"), ppr body]
 101
 102     ppr (UfApp fun arg) = ppr fun <+> ppr arg
 103
 104     ppr (UfCase scrut bndr alts)
 105       = hsep [ptext SLIT("case"), ppr scrut, ptext SLIT("of"), ppr bndr,
 106               braces (hsep (punctuate semi (map pp_alt alts)))]
 107       where
 108         pp_alt (c,bs,rhs) = hsep [ppr c, ppr bs, ppr_arrow, ppr rhs]
 109
 110         ppr_arrow = ptext SLIT("->")
 111
 112     ppr (UfLet (UfNonRec b rhs) body)
 113       = hsep [ptext SLIT("let"), ppr b, equals, ppr rhs, ptext SLIT("in"), ppr body]
 114     ppr (UfLet (UfRec pairs) body)
 115       = hsep [ptext SLIT("letrec"), braces (hsep (punctuate semi (map pp_pair pairs))), ptext SLIT("in"), ppr body]
 116       where
 117         pp_pair (b,rhs) = hsep [ppr b, equals, ppr rhs]
 118
 119     ppr (UfNote note body)
 120       = hsep [ptext SLIT("_NOTE_ [ToDo]>"), ppr body]
 121
 122 instance Outputable name => Outputable (UfCon name) where
 123     ppr UfDefault          = text "DEFAULT"
 124     ppr (UfLitCon l)       = ppr l
 125     ppr (UfLitLitCon l ty) = ppr l
 126     ppr (UfDataCon d)      = ppr d
 127     ppr (UfPrimOp p)       = ppr p
 128     ppr (UfCCallOp str is_dyn is_casm can_gc)
 129       = hcat [before, ptext str, after]
 130       where
 131             before = (if is_dyn then ptext SLIT("_dyn_") else empty) <>
 132                      ptext (if is_casm then SLIT("_casm_ ``") else SLIT("_ccall_ "))
 133             after  = if is_casm then text "'' " else space
 134
 135 instance Outputable name => Outputable (UfBinder name) where
 136     ppr (UfValBinder name ty)  = hsep [ppr name, dcolon, ppr ty]
 137     ppr (UfTyBinder name kind) = hsep [ppr name, dcolon, ppr kind]
 138 \end{code}
 139
 140
 141 %************************************************************************
 142 %*                                                                      *
 143 \subsection{Signatures in interface files}
 144 %*                                                                      *
 145 %************************************************************************
 146
 147 \begin{code}
 148 data IfaceSig name
 149   = IfaceSig    name
 150                 (HsType name)
 151                 [HsIdInfo name]
 152                 SrcLoc
 153
 154 instance (Outputable name) => Outputable (IfaceSig name) where
 155     ppr (IfaceSig var ty info _)
 156       = hang (hsep [ppr var, dcolon])
 157              4 (ppr ty $$ ifPprDebug (vcat (map ppr info)))
 158
 159 data HsIdInfo name
 160   = HsArity             ArityInfo
 161   | HsStrictness        HsStrictnessInfo
 162   | HsUnfold            InlinePragInfo (UfExpr name)
 163   | HsUpdate            UpdateInfo
 164   | HsSpecialise        (UfRuleBody name)
 165   | HsNoCafRefs
 166   | HsCprInfo           CprInfo
 167   | HsWorker            name            -- Worker, if any
 168
 169 instance Outputable name => Outputable (HsIdInfo name) where
 170   ppr (HsUnfold _ unf) = ptext (SLIT("Unfolding:")) <+> ppr unf
 171   ppr other            = empty  -- Havn't got around to this yet
 172
 173 data HsStrictnessInfo
 174   = HsStrictnessInfo ([Demand], Bool)
 175   | HsBottom
 176 \end{code}
 177
 178
 179 %************************************************************************
 180 %*                                                                      *
 181 \subsection{Rules in interface files}
 182 %*                                                                      *
 183 %************************************************************************
 184
 185 \begin{code}
 186 data UfRuleBody name = UfRuleBody   FAST_STRING [UfBinder name] [UfExpr name] (UfExpr name)     -- Pre typecheck
 187                      | CoreRuleBody FAST_STRING [CoreBndr]      [CoreExpr]    CoreExpr          -- Post typecheck
 188 \end{code}