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