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.
  12
  13 \begin{code}
  14 #include "HsVersions.h"
  15
  16 module HsCore (
  17         UnfoldingCoreExpr(..), UnfoldingCoreAlts(..),
  18         UnfoldingCoreDefault(..), UnfoldingCoreBinding(..),
  19         UnfoldingCoreAtom(..), UfId(..), UnfoldingType(..),
  20         UnfoldingPrimOp(..), UfCostCentre(..)
  21     ) where
  22
  23 IMP_Ubiq()
  24
  25 -- friends:
  26 import HsTypes          ( MonoType, PolyType )
  27 import PrimOp           ( PrimOp, tagOf_PrimOp )
  28
  29 -- others:
  30 import Literal          ( Literal )
  31 import Outputable       ( Outputable(..) )
  32 import Pretty
  33 import Util             ( panic )
  34 \end{code}
  35
  36 %************************************************************************
  37 %*                                                                      *
  38 \subsection[HsCore-types]{Types for read/written Core unfoldings}
  39 %*                                                                      *
  40 %************************************************************************
  41
  42 \begin{code}
  43 data UnfoldingCoreExpr name
  44   = UfVar       (UfId name)
  45   | UfLit       Literal
  46   | UfCon       name -- must be a "BoringUfId"...
  47                 [UnfoldingType name]
  48                 [UnfoldingCoreAtom name]
  49   | UfPrim      (UnfoldingPrimOp name)
  50                 [UnfoldingType name]
  51                 [UnfoldingCoreAtom name]
  52   | UfLam       (UfBinder name)
  53                 (UnfoldingCoreExpr name)
  54   | UfApp       (UnfoldingCoreExpr name)
  55                 (UnfoldingCoreAtom name)
  56   | UfCase      (UnfoldingCoreExpr name)
  57                 (UnfoldingCoreAlts name)
  58   | UfLet       (UnfoldingCoreBinding name)
  59                 (UnfoldingCoreExpr name)
  60   | UfSCC       (UfCostCentre name)
  61                 (UnfoldingCoreExpr name)
  62
  63 data UnfoldingPrimOp name
  64   = UfCCallOp   FAST_STRING          -- callee
  65                 Bool                 -- True <=> casm, rather than ccall
  66                 Bool                 -- True <=> might cause GC
  67                 [UnfoldingType name] -- arg types, incl state token
  68                                      -- (which will be first)
  69                 (UnfoldingType name) -- return type
  70   | UfOtherOp   PrimOp
  71
  72 data UnfoldingCoreAlts name
  73   = UfCoAlgAlts  [(name, [UfBinder name], UnfoldingCoreExpr name)]
  74                  (UnfoldingCoreDefault name)
  75   | UfCoPrimAlts [(Literal, UnfoldingCoreExpr name)]
  76                  (UnfoldingCoreDefault name)
  77
  78 data UnfoldingCoreDefault name
  79   = UfCoNoDefault
  80   | UfCoBindDefault (UfBinder name)
  81                     (UnfoldingCoreExpr name)
  82
  83 data UnfoldingCoreBinding name
  84   = UfCoNonRec  (UfBinder name)
  85                 (UnfoldingCoreExpr name)
  86   | UfCoRec     [(UfBinder name, UnfoldingCoreExpr name)]
  87
  88 data UnfoldingCoreAtom name
  89   = UfCoVarAtom (UfId name)
  90   | UfCoLitAtom Literal
  91
  92 data UfCostCentre name
  93   = UfPreludeDictsCC
  94                 Bool    -- True <=> is dupd
  95   | UfAllDictsCC FAST_STRING    -- module and group
  96                 FAST_STRING
  97                 Bool    -- True <=> is dupd
  98   | UfUserCC    FAST_STRING
  99                 FAST_STRING FAST_STRING -- module and group
 100                 Bool    -- True <=> is dupd
 101                 Bool    -- True <=> is CAF
 102   | UfAutoCC    (UfId name)
 103                 FAST_STRING FAST_STRING -- module and group
 104                 Bool Bool -- as above
 105   | UfDictCC    (UfId name)
 106                 FAST_STRING FAST_STRING -- module and group
 107                 Bool Bool -- as above
 108
 109 type UfBinder name = (name, UnfoldingType name)
 110
 111 data UfId name
 112   = BoringUfId          name
 113   | SuperDictSelUfId    name name       -- class and superclass
 114   | ClassOpUfId         name name       -- class and class op
 115   | DictFunUfId         name            -- class and type
 116                         (UnfoldingType name)
 117   | ConstMethodUfId     name name       -- class, class op, and type
 118                         (UnfoldingType name)
 119   | DefaultMethodUfId   name name       -- class and class op
 120   | SpecUfId            (UfId name)     -- its unspecialised "parent"
 121                         [Maybe (MonoType name)]
 122   | WorkerUfId          (UfId name)     -- its non-working "parent"
 123   -- more to come?
 124
 125 type UnfoldingType name = PolyType name
 126 \end{code}
 127
 128 %************************************************************************
 129 %*                                                                      *
 130 \subsection[HsCore-print]{Printing Core unfoldings}
 131 %*                                                                      *
 132 %************************************************************************
 133
 134 \begin{code}
 135 instance Outputable name => Outputable (UnfoldingCoreExpr name) where
 136     ppr sty (UfVar v) = pprUfId sty v
 137     ppr sty (UfLit l) = ppr sty l
 138
 139     ppr sty (UfCon c tys as)
 140       = ppCat [ppStr "(UfCon", ppr sty c, ppr sty tys, ppr sty as, ppStr ")"]
 141     ppr sty (UfPrim o tys as)
 142       = ppCat [ppStr "(UfPrim", ppr sty o, ppr sty tys, ppr sty as, ppStr ")"]
 143
 144     ppr sty (UfLam bs body)
 145       = ppCat [ppChar '\\', ppr sty bs, ppStr "->", ppr sty body]
 146
 147     ppr sty (UfApp fun arg)
 148       = ppCat [ppStr "(UfApp", ppr sty fun, ppr sty arg, ppStr ")"]
 149
 150     ppr sty (UfCase scrut alts)
 151       = ppCat [ppStr "case", ppr sty scrut, ppStr "of {", pp_alts alts, ppStr "}"]
 152       where
 153         pp_alts (UfCoAlgAlts alts deflt)
 154           = ppCat [ppInterleave ppSemi (map pp_alt alts), pp_deflt deflt]
 155           where
 156            pp_alt (c,bs,rhs) = ppCat [ppr sty c, ppr sty bs, ppStr "->", ppr sty rhs]
 157         pp_alts (UfCoPrimAlts alts deflt)
 158           = ppCat [ppInterleave ppSemi (map pp_alt alts), pp_deflt deflt]
 159           where
 160            pp_alt (l,rhs) = ppCat [ppr sty l, ppStr "->", ppr sty rhs]
 161
 162         pp_deflt UfCoNoDefault = ppNil
 163         pp_deflt (UfCoBindDefault b rhs) = ppCat [ppr sty b, ppStr "->", ppr sty rhs]
 164
 165     ppr sty (UfLet (UfCoNonRec b rhs) body)
 166       = ppCat [ppStr "let", ppr sty b, ppEquals, ppr sty rhs, ppStr "in", ppr sty body]
 167     ppr sty (UfLet (UfCoRec pairs) body)
 168       = ppCat [ppStr "letrec {", ppInterleave ppSemi (map pp_pair pairs), ppStr "} in", ppr sty body]
 169       where
 170         pp_pair (b,rhs) = ppCat [ppr sty b, ppEquals, ppr sty rhs]
 171
 172     ppr sty (UfSCC uf_cc body)
 173       = ppCat [ppStr "_scc_ <cost-centre[ToDo]>", ppr sty body]
 174
 175 instance Outputable name => Outputable (UnfoldingPrimOp name) where
 176     ppr sty (UfCCallOp str is_casm can_gc arg_tys result_ty)
 177       = let
 178             before = ppStr (if is_casm then "_casm_ ``" else "_ccall_ ")
 179             after  = if is_casm then ppStr "'' " else ppSP
 180         in
 181         ppBesides [before, ppPStr str, after,
 182                 ppLbrack, ppr sty arg_tys, ppRbrack, ppSP, ppr sty result_ty]
 183     ppr sty (UfOtherOp op)
 184       = ppr sty op
 185
 186 instance Outputable name => Outputable (UnfoldingCoreAtom name) where
 187     ppr sty (UfCoVarAtom v) = pprUfId sty v
 188     ppr sty (UfCoLitAtom l)         = ppr sty l
 189
 190 pprUfId sty (BoringUfId v) = ppr sty v
 191 pprUfId sty (SuperDictSelUfId c sc)
 192   = ppBesides [ppStr "({-superdict-}", ppr sty c, ppSP, ppr sty sc, ppStr ")"]
 193 pprUfId sty (ClassOpUfId c op)
 194   = ppBesides [ppStr "({-method-}", ppr sty c, ppSP, ppr sty op, ppStr ")"]
 195 pprUfId sty (DictFunUfId c ty)
 196   = ppBesides [ppStr "({-dfun-}", ppr sty c, ppSP, ppr sty ty, ppStr ")"]
 197 pprUfId sty (ConstMethodUfId c op ty)
 198   = ppBesides [ppStr "({-constm-}", ppr sty c, ppSP, ppr sty op, ppSP, ppr sty ty, ppStr ")"]
 199 pprUfId sty (DefaultMethodUfId c ty)
 200   = ppBesides [ppStr "({-defm-}", ppr sty c, ppSP, ppr sty ty, ppStr ")"]
 201
 202 pprUfId sty (SpecUfId unspec ty_maybes)
 203   = ppBesides [ppStr "({-spec-} ", pprUfId sty unspec,
 204                 ppInterleave ppSP (map pp_ty_maybe ty_maybes), ppStr ")"]
 205   where
 206     pp_ty_maybe Nothing  = ppStr "_N_"
 207     pp_ty_maybe (Just t) = ppr sty t
 208
 209 pprUfId sty (WorkerUfId unwrkr)
 210   = ppBesides [ppStr "({-wrkr-}", pprUfId sty unwrkr, ppStr ")"]
 211 \end{code}
 212