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