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