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(..), UfConAlt(..),
  17         HsIdInfo(..), pprHsIdInfo,
  18
  19         eq_ufExpr, eq_ufBinders, pprUfExpr,
  20
  21         toUfExpr, toUfBndr
  22     ) where
  23
  24 #include "HsVersions.h"
  25
  26 -- friends:
  27 import HsTypes          ( HsType, pprParendHsType, pprHsTyVarBndr, toHsType,
  28                           HsTupCon(..), hsTupParens,
  29                           emptyEqHsEnv, extendEqHsEnv, eqListBy,
  30                           eq_hsType, eq_hsVar, eq_hsVars
  31                         )
  32
  33 -- others:
  34 import Id               ( idArity, idType, isDataConId_maybe, isPrimOpId_maybe )
  35 import Var              ( varType, isId )
  36 import IdInfo           ( ArityInfo, InlinePragInfo,
  37                           pprInlinePragInfo, ppArityInfo, ppStrictnessInfo
  38                         )
  39 import Name             ( Name, getName )
  40 import CoreSyn
  41 import CostCentre       ( pprCostCentreCore )
  42 import PrimOp           ( PrimOp(CCallOp) )
  43 import Demand           ( StrictnessInfo )
  44 import Literal          ( Literal, maybeLitLit )
  45 import PrimOp           ( CCall, pprCCallOp )
  46 import DataCon          ( dataConTyCon )
  47 import TyCon            ( isTupleTyCon, tupleTyConBoxity )
  48 import Type             ( Kind )
  49 import CostCentre
  50 import SrcLoc           ( SrcLoc )
  51 import Outputable
  52 \end{code}
  53
  54 %************************************************************************
  55 %*                                                                      *
  56 \subsection[HsCore-types]{Types for read/written Core unfoldings}
  57 %*                                                                      *
  58 %************************************************************************
  59
  60 \begin{code}
  61 data UfExpr name
  62   = UfVar       name
  63   | UfType      (HsType name)
  64   | UfTuple     (HsTupCon name) [UfExpr name]           -- Type arguments omitted
  65   | UfLam       (UfBinder name) (UfExpr name)
  66   | UfApp       (UfExpr name)   (UfExpr name)
  67   | UfCase      (UfExpr name) name [UfAlt name]
  68   | UfLet       (UfBinding name)  (UfExpr name)
  69   | UfNote      (UfNote name) (UfExpr name)
  70   | UfLit       Literal
  71   | UfLitLit    FAST_STRING (HsType name)
  72   | UfCCall     CCall (HsType name)
  73
  74 data UfNote name = UfSCC CostCentre
  75                  | UfCoerce (HsType name)
  76                  | UfInlineCall
  77                  | UfInlineMe
  78
  79 type UfAlt name = (UfConAlt name, [name], UfExpr name)
  80
  81 data UfConAlt name = UfDefault
  82                    | UfDataAlt name
  83                    | UfTupleAlt (HsTupCon name)
  84                    | UfLitAlt Literal
  85                    | UfLitLitAlt FAST_STRING (HsType name)
  86
  87 data UfBinding name
  88   = UfNonRec    (UfBinder name)
  89                 (UfExpr name)
  90   | UfRec       [(UfBinder name, UfExpr name)]
  91
  92 data UfBinder name
  93   = UfValBinder name (HsType name)
  94   | UfTyBinder  name Kind
  95 \end{code}
  96
  97
  98 %************************************************************************
  99 %*                                                                      *
 100 \subsection{Converting from Core to UfCore}
 101 %*                                                                      *
 102 %************************************************************************
 103
 104 \begin{code}
 105 toUfExpr :: CoreExpr -> UfExpr Name
 106 toUfExpr (Var v) = toUfVar v
 107 toUfExpr (Lit l) = case maybeLitLit l of
 108                         Just (s,ty) -> UfLitLit s (toHsType ty)
 109                         Nothing     -> UfLit l
 110 toUfExpr (Type ty) = UfType (toHsType ty)
 111 toUfExpr (Lam x b) = UfLam (toUfBndr x) (toUfExpr b)
 112 toUfExpr (App f a) = toUfApp f [a]
 113 toUfExpr (Case s x as) = UfCase (toUfExpr s) (getName x) (map toUfAlt as)
 114 toUfExpr (Let b e)     = UfLet (toUfBind b) (toUfExpr e)
 115 toUfExpr (Note n e)    = UfNote (toUfNote n) (toUfExpr e)
 116
 117 ---------------------
 118 toUfNote (SCC cc)       = UfSCC cc
 119 toUfNote (Coerce t1 _)  = UfCoerce (toHsType t1)
 120 toUfNote InlineCall     = UfInlineCall
 121 toUfNote InlineMe       = UfInlineMe
 122
 123 ---------------------
 124 toUfBind (NonRec b r) = UfNonRec (toUfBndr b) (toUfExpr r)
 125 toUfBind (Rec prs)    = UfRec [(toUfBndr b, toUfExpr r) | (b,r) <- prs]
 126
 127 ---------------------
 128 toUfAlt (c,bs,r) = (toUfCon c, map getName bs, toUfExpr r)
 129
 130 ---------------------
 131 toUfCon (DataAlt dc) | isTupleTyCon tc = UfTupleAlt (HsTupCon (getName dc) (tupleTyConBoxity tc))
 132                      | otherwise       = UfDataAlt (getName dc)
 133                      where
 134                        tc = dataConTyCon dc
 135
 136 toUfCon (LitAlt l)   = case maybeLitLit l of
 137                          Just (s,ty) -> UfLitLitAlt s (toHsType ty)
 138                          Nothing     -> UfLitAlt l
 139 toUfCon DEFAULT      = UfDefault
 140
 141 ---------------------
 142 toUfBndr x | isId x    = UfValBinder (getName x) (toHsType (varType x))
 143            | otherwise = UfTyBinder  (getName x) (varType x)
 144
 145 ---------------------
 146 toUfApp (App f a) as = toUfApp f (a:as)
 147 toUfApp (Var v) as
 148   = case isDataConId_maybe v of
 149         -- We convert the *worker* for tuples into UfTuples
 150         Just dc | isTupleTyCon tc && saturated -> UfTuple (HsTupCon (getName dc) (tupleTyConBoxity tc)) tup_args
 151           where
 152             val_args  = dropWhile isTypeArg as
 153             saturated = length val_args == idArity v
 154             tup_args  = map toUfExpr val_args
 155             tc        = dataConTyCon dc
 156         ;
 157
 158         other -> mkUfApps (toUfVar v) as
 159
 160 toUfApp e as = mkUfApps (toUfExpr e) as
 161
 162 mkUfApps = foldl (\f a -> UfApp f (toUfExpr a))
 163
 164 ---------------------
 165 toUfVar v = case isPrimOpId_maybe v of
 166                 -- Ccalls has special syntax
 167                 Just (CCallOp cc) -> UfCCall cc (toHsType (idType v))
 168                 other             -> UfVar (getName v)
 169 \end{code}
 170
 171
 172 %************************************************************************
 173 %*                                                                      *
 174 \subsection[HsCore-print]{Printing Core unfoldings}
 175 %*                                                                      *
 176 %************************************************************************
 177
 178 \begin{code}
 179 instance Outputable name => Outputable (UfExpr name) where
 180     ppr e = pprUfExpr noParens e
 181
 182 noParens :: SDoc -> SDoc
 183 noParens pp = pp
 184
 185 pprUfExpr :: Outputable name => (SDoc -> SDoc) -> UfExpr name -> SDoc
 186         -- The function adds parens in context that need
 187         -- an atomic value (e.g. function args)
 188
 189 pprUfExpr add_par (UfVar v)       = ppr v
 190 pprUfExpr add_par (UfLit l)       = ppr l
 191 pprUfExpr add_par (UfLitLit l ty) = add_par (hsep [ptext SLIT("__litlit"), pprHsString l, pprParendHsType ty])
 192 pprUfExpr add_par (UfCCall cc ty) = braces (pprCCallOp cc <+> ppr ty)
 193 pprUfExpr add_par (UfType ty)     = char '@' <+> pprParendHsType ty
 194
 195 pprUfExpr add_par e@(UfLam _ _)   = add_par (char '\\' <+> hsep (map ppr bndrs)
 196                                              <+> ptext SLIT("->") <+> pprUfExpr noParens body)
 197                                   where (bndrs,body) = collectUfBndrs e
 198 pprUfExpr add_par (UfApp fun arg) = add_par (pprUfExpr noParens fun <+> pprUfExpr parens arg)
 199 pprUfExpr add_par (UfTuple c as)  = hsTupParens c (interpp'SP as)
 200
 201 pprUfExpr add_par (UfCase scrut bndr alts)
 202       = add_par (hsep [ptext SLIT("case"), pprUfExpr noParens scrut, ptext SLIT("of"), ppr bndr,
 203                        braces (hsep (map pp_alt alts))])
 204       where
 205         pp_alt (UfTupleAlt tup_con, bs, rhs) = hsTupParens tup_con (interpp'SP bs) <+> ppr_rhs rhs
 206         pp_alt (c,                  bs, rhs) = ppr c <+> interppSP bs <+> ppr_rhs rhs
 207
 208         ppr_rhs rhs = ptext SLIT("->") <+> pprUfExpr noParens rhs <> semi
 209
 210 pprUfExpr add_par (UfLet (UfNonRec b rhs) body)
 211       = add_par (hsep [ptext SLIT("let"),
 212                        braces (ppr b <+> equals <+> pprUfExpr noParens rhs),
 213                        ptext SLIT("in"), pprUfExpr noParens body])
 214
 215 pprUfExpr add_par (UfLet (UfRec pairs) body)
 216       = add_par (hsep [ptext SLIT("__letrec"), braces (hsep (map pp_pair pairs)),
 217                        ptext SLIT("in"), pprUfExpr noParens body])
 218       where
 219         pp_pair (b,rhs) = ppr b <+> equals <+> pprUfExpr noParens rhs <> semi
 220
 221 pprUfExpr add_par (UfNote note body) = add_par (ppr note <+> pprUfExpr parens body)
 222
 223 collectUfBndrs :: UfExpr name -> ([UfBinder name], UfExpr name)
 224 collectUfBndrs expr
 225   = go [] expr
 226   where
 227     go bs (UfLam b e) = go (b:bs) e
 228     go bs e           = (reverse bs, e)
 229
 230 instance Outputable name => Outputable (UfNote name) where
 231     ppr (UfSCC cc)    = pprCostCentreCore cc
 232     ppr (UfCoerce ty) = ptext SLIT("__coerce") <+> pprParendHsType ty
 233     ppr UfInlineCall  = ptext SLIT("__inline_call")
 234     ppr UfInlineMe    = ptext SLIT("__inline_me")
 235
 236 instance Outputable name => Outputable (UfConAlt name) where
 237     ppr UfDefault          = text "__DEFAULT"
 238     ppr (UfLitAlt l)       = ppr l
 239     ppr (UfLitLitAlt l ty) = parens (hsep [ptext SLIT("__litlit"), pprHsString l, pprParendHsType ty])
 240     ppr (UfDataAlt d)      = ppr d
 241
 242 instance Outputable name => Outputable (UfBinder name) where
 243     ppr (UfValBinder name ty)  = hsep [ppr name, dcolon, pprParendHsType ty]
 244     ppr (UfTyBinder name kind) = char '@' <+> pprHsTyVarBndr name kind
 245 \end{code}
 246
 247
 248 %************************************************************************
 249 %*                                                                      *
 250 \subsection[HsCore-print]{Equality, for interface file checking
 251 %*                                                                      *
 252 %************************************************************************
 253
 254 \begin{code}
 255 instance Ord name => Eq (UfExpr name) where
 256   (==) a b = eq_ufExpr emptyEqHsEnv a b
 257
 258 -----------------
 259 eq_ufBinder env (UfValBinder n1 t1) (UfValBinder n2 t2) k
 260   = eq_hsType env t1 t2 && k (extendEqHsEnv env n1 n2)
 261 eq_ufBinder env (UfTyBinder n1 k1) (UfTyBinder n2 k2) k
 262   = k1==k2 && k (extendEqHsEnv env n1 n2)
 263 eq_ufBinder _ _ _ _ = False
 264
 265 -----------------
 266 eq_ufBinders env []       []       k = k env
 267 eq_ufBinders env (b1:bs1) (b2:bs2) k = eq_ufBinder env b1 b2 (\env -> eq_ufBinders env bs1 bs2 k)
 268 eq_ufBinders env _        _        _ = False
 269
 270 -----------------
 271 eq_ufExpr env (UfVar v1)        (UfVar v2)        = eq_hsVar env v1 v2
 272 eq_ufExpr env (UfLit l1)        (UfLit l2)        = l1 == l2
 273 eq_ufExpr env (UfLitLit l1 ty1) (UfLitLit l2 ty2) = l1==l2 && eq_hsType env ty1 ty2
 274 eq_ufExpr env (UfCCall c1 ty1)  (UfCCall c2 ty2)  = c1==c2 && eq_hsType env ty1 ty2
 275 eq_ufExpr env (UfType ty1)      (UfType ty2)      = eq_hsType env ty1 ty2
 276 eq_ufExpr env (UfTuple n1 as1)  (UfTuple n2 as2)  = n1==n2 && eqListBy (eq_ufExpr env) as1 as2
 277 eq_ufExpr env (UfLam b1 body1)  (UfLam b2 body2)  = eq_ufBinder env b1 b2 (\env -> eq_ufExpr env body1 body2)
 278 eq_ufExpr env (UfApp f1 a1)     (UfApp f2 a2)     = eq_ufExpr env f1 f2 && eq_ufExpr env a1 a2
 279
 280 eq_ufExpr env (UfCase s1 b1 as1) (UfCase s2 b2 as2)
 281   = eq_ufExpr env s1 s2 &&
 282     eqListBy (eq_ufAlt (extendEqHsEnv env b1 b2)) as1 as2
 283   where
 284     eq_ufAlt env (c1,bs1,r1) (c2,bs2,r2)
 285         = eq_ufConAlt env c1 c2 && eq_hsVars env bs1 bs2 (\env -> eq_ufExpr env r1 r2)
 286
 287 eq_ufExpr env (UfLet (UfNonRec b1 r1) x1) (UfLet (UfNonRec b2 r2) x2)
 288   = eq_ufExpr env r1 r2 && eq_ufBinder env b1 b2 (\env -> eq_ufExpr env x1 x2)
 289
 290 eq_ufExpr env (UfLet (UfRec as1) x1) (UfLet (UfRec as2) x2)
 291   = eq_ufBinders env bs1 bs2 (\env -> eqListBy (eq_ufExpr env) rs1 rs2 && eq_ufExpr env x1 x2)
 292   where
 293     (bs1,rs1) = unzip as1
 294     (bs2,rs2) = unzip as2
 295
 296 eq_ufExpr env (UfNote n1 r1) (UfNote n2 r2)
 297   = eq_ufNote n1 n2 && eq_ufExpr env r1 r2
 298   where
 299     eq_ufNote (UfSCC c1)    (UfSCC c2)    = c1==c2
 300     eq_ufNote (UfCoerce t1) (UfCoerce t2) = eq_hsType env t1 t2
 301     eq_ufNote UfInlineCall  UfInlineCall  = True
 302     eq_ufNote UfInlineMe    UfInlineMe    = True
 303     eq_ufNote _             _             = False
 304
 305 eq_ufExpr env _ _ = False
 306
 307 -----------------
 308 eq_ufConAlt env UfDefault           UfDefault           = True
 309 eq_ufConAlt env (UfDataAlt n1)      (UfDataAlt n2)      = n1==n2
 310 eq_ufConAlt env (UfTupleAlt c1)     (UfTupleAlt c2)     = c1==c2
 311 eq_ufConAlt env (UfLitAlt l1)       (UfLitAlt l2)       = l1==l2
 312 eq_ufConAlt env (UfLitLitAlt s1 t1) (UfLitLitAlt s2 t2) = s1==s2 && eq_hsType env t1 t2
 313 eq_ufConAlt env _ _ = False
 314 \end{code}
 315
 316
 317 %************************************************************************
 318 %*                                                                      *
 319 \subsection{Rules in interface files}
 320 %*                                                                      *
 321 %************************************************************************
 322
 323 \begin{code}
 324 pprHsIdInfo []   = empty
 325 pprHsIdInfo info = ptext SLIT("{-##") <+> hsep (map ppr info) <+> ptext SLIT("##-}")
 326
 327 data HsIdInfo name
 328   = HsArity             ArityInfo
 329   | HsStrictness        StrictnessInfo
 330   | HsUnfold            InlinePragInfo (UfExpr name)
 331   | HsNoCafRefs
 332   | HsCprInfo
 333   | HsWorker            name            -- Worker, if any
 334   deriving( Eq )
 335 -- NB: Specialisations and rules come in separately and are
 336 -- only later attached to the Id.  Partial reason: some are orphans.
 337
 338 instance Outputable name => Outputable (HsIdInfo name) where
 339   ppr (HsUnfold prag unf) = ptext SLIT("__U") <> pprInlinePragInfo prag <+> parens (ppr unf)
 340   ppr (HsArity arity)     = ppArityInfo arity
 341   ppr (HsStrictness str)  = ptext SLIT("__S") <+> ppStrictnessInfo str
 342   ppr HsNoCafRefs         = ptext SLIT("__C")
 343   ppr HsCprInfo           = ptext SLIT("__M")
 344   ppr (HsWorker w)        = ptext SLIT("__P") <+> ppr w
 345 \end{code}
 346