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 \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   | UfLit       Literal
  47   | UfCon       name [UfArg name]
  48   | UfPrim      (UfPrimOp name) [UfArg name]
  49   | UfLam       (UfBinder name)   (UfExpr name)
  50   | UfApp       (UfExpr name) (UfArg name)
  51   | UfCase      (UfExpr name) (UfAlts name)
  52   | UfLet       (UfBinding name)  (UfExpr name)
  53   | UfSCC       CostCentre (UfExpr name)
  54   | UfCoerce    (UfCoercion name) (HsType name) (UfExpr name)
  55
  56 data UfPrimOp name
  57   = UfCCallOp   FAST_STRING          -- callee
  58                 Bool                 -- True <=> casm, rather than ccall
  59                 Bool                 -- True <=> might cause GC
  60                 [HsType name] -- arg types, incl state token
  61                                      -- (which will be first)
  62                 (HsType name) -- return type
  63
  64   | UfOtherOp   name
  65
  66 data UfCoercion name = UfIn name | UfOut name
  67
  68 data UfAlts name
  69   = UfAlgAlts  [(name, [UfBinder name], UfExpr name)]
  70                 (UfDefault name)
  71   | UfPrimAlts [(Literal, UfExpr name)]
  72                 (UfDefault name)
  73
  74 data UfDefault name
  75   = UfNoDefault
  76   | UfBindDefault (UfBinder name)
  77                   (UfExpr name)
  78
  79 data UfBinding name
  80   = UfNonRec    (UfBinder name)
  81                 (UfExpr name)
  82   | UfRec       [(UfBinder name, UfExpr name)]
  83
  84 data UfBinder name
  85   = UfValBinder name (HsType name)
  86   | UfTyBinder  name Kind
  87   | UfUsageBinder name
  88
  89 data UfArg name
  90   = UfVarArg    name
  91   | UfLitArg    Literal
  92   | UfTyArg     (HsType name)
  93   | UfUsageArg  name
  94 \end{code}
  95
  96 %************************************************************************
  97 %*                                                                      *
  98 \subsection[HsCore-print]{Printing Core unfoldings}
  99 %*                                                                      *
 100 %************************************************************************
 101
 102 \begin{code}
 103 instance Outputable name => Outputable (UfExpr name) where
 104     ppr sty (UfVar v) = ppr sty v
 105     ppr sty (UfLit l) = ppr sty l
 106
 107     ppr sty (UfCon c as)
 108       = ppCat [ppStr "(UfCon", ppr sty c, ppr sty as, ppStr ")"]
 109     ppr sty (UfPrim o as)
 110       = ppCat [ppStr "(UfPrim", ppr sty o, ppr sty as, ppStr ")"]
 111
 112     ppr sty (UfLam b body)
 113       = ppCat [ppChar '\\', ppr sty b, ppStr "->", ppr sty body]
 114
 115     ppr sty (UfApp fun (UfTyArg ty))
 116       = ppCat [ppr sty fun, ppStr "@", pprParendHsType sty ty]
 117
 118     ppr sty (UfApp fun (UfLitArg lit))
 119       = ppCat [ppr sty fun, ppr sty lit]
 120
 121     ppr sty (UfApp fun (UfVarArg var))
 122       = ppCat [ppr sty fun, ppr sty var]
 123
 124     ppr sty (UfCase scrut alts)
 125       = ppCat [ppStr "case", ppr sty scrut, ppStr "of {", pp_alts alts, ppStr "}"]
 126       where
 127         pp_alts (UfAlgAlts alts deflt)
 128           = ppCat [ppInterleave ppSemi (map pp_alt alts), pp_deflt deflt]
 129           where
 130            pp_alt (c,bs,rhs) = ppCat [ppr sty c, ppr sty bs, ppStr "->", ppr sty rhs]
 131         pp_alts (UfPrimAlts alts deflt)
 132           = ppCat [ppInterleave ppSemi (map pp_alt alts), pp_deflt deflt]
 133           where
 134            pp_alt (l,rhs) = ppCat [ppr sty l, ppStr "->", ppr sty rhs]
 135
 136         pp_deflt UfNoDefault = ppNil
 137         pp_deflt (UfBindDefault b rhs) = ppCat [ppr sty b, ppStr "->", ppr sty rhs]
 138
 139     ppr sty (UfLet (UfNonRec b rhs) body)
 140       = ppCat [ppStr "let", ppr sty b, ppEquals, ppr sty rhs, ppStr "in", ppr sty body]
 141     ppr sty (UfLet (UfRec pairs) body)
 142       = ppCat [ppStr "letrec {", ppInterleave ppSemi (map pp_pair pairs), ppStr "} in", ppr sty body]
 143       where
 144         pp_pair (b,rhs) = ppCat [ppr sty b, ppEquals, ppr sty rhs]
 145
 146     ppr sty (UfSCC uf_cc body)
 147       = ppCat [ppStr "_scc_ <cost-centre[ToDo]>", ppr sty body]
 148
 149 instance Outputable name => Outputable (UfPrimOp name) where
 150     ppr sty (UfCCallOp str is_casm can_gc arg_tys result_ty)
 151       = let
 152             before = ppStr (if is_casm then "_casm_ ``" else "_ccall_ ")
 153             after  = if is_casm then ppStr "'' " else ppSP
 154         in
 155         ppBesides [before, ppPStr str, after,
 156                    ppLbrack, ppr sty arg_tys, ppRbrack, ppSP, ppr sty result_ty]
 157
 158     ppr sty (UfOtherOp op)
 159       = ppr sty op
 160
 161 instance Outputable name => Outputable (UfArg name) where
 162     ppr sty (UfVarArg v)        = ppr sty v
 163     ppr sty (UfLitArg l)        = ppr sty l
 164     ppr sty (UfTyArg ty)        = pprParendHsType sty ty
 165     ppr sty (UfUsageArg name)   = ppr sty name
 166
 167 instance Outputable name => Outputable (UfBinder name) where
 168     ppr sty (UfValBinder name ty)  = ppCat [ppr sty name, ppStr "::", ppr sty ty]
 169     ppr sty (UfTyBinder name kind) = ppCat [ppr sty name, ppStr "::", ppr sty kind]
 170     ppr sty (UfUsageBinder name)   = ppr sty name
 171 \end{code}
 172