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, pprHsIdInfo,
  20
  21         toUfExpr, toUfBndr, ufBinderName
  22     ) where
  23
  24 #include "HsVersions.h"
  25
  26 -- friends:
  27 import HsTypes          ( HsType, pprParendHsType, pprHsTyVarBndr, toHsType,
  28                           HsTupCon(..), EqHsEnv, hsTupParens,
  29                           emptyEqHsEnv, extendEqHsEnv, eqListBy,
  30                           eq_hsType, 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, NamedThing(..), getName, toRdrName )
  40 import RdrName          ( RdrName, rdrNameOcc )
  41 import OccName          ( isTvOcc )
  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 FiniteMap        ( lookupFM )
  52 import CostCentre
  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
  98 ufBinderName :: UfBinder name -> name
  99 ufBinderName (UfValBinder n _) = n
 100 ufBinderName (UfTyBinder  n _) = n
 101 \end{code}
 102
 103
 104 %************************************************************************
 105 %*                                                                      *
 106 \subsection{Converting from Core to UfCore}
 107 %*                                                                      *
 108 %************************************************************************
 109
 110 \begin{code}
 111 toUfExpr :: CoreExpr -> UfExpr Name
 112 toUfExpr (Var v) = toUfVar v
 113 toUfExpr (Lit l) = case maybeLitLit l of
 114                         Just (s,ty) -> UfLitLit s (toHsType ty)
 115                         Nothing     -> UfLit l
 116 toUfExpr (Type ty) = UfType (toHsType ty)
 117 toUfExpr (Lam x b) = UfLam (toUfBndr x) (toUfExpr b)
 118 toUfExpr (App f a) = toUfApp f [a]
 119 toUfExpr (Case s x as) = UfCase (toUfExpr s) (getName x) (map toUfAlt as)
 120 toUfExpr (Let b e)     = UfLet (toUfBind b) (toUfExpr e)
 121 toUfExpr (Note n e)    = UfNote (toUfNote n) (toUfExpr e)
 122
 123 ---------------------
 124 toUfNote (SCC cc)       = UfSCC cc
 125 toUfNote (Coerce t1 _)  = UfCoerce (toHsType t1)
 126 toUfNote InlineCall     = UfInlineCall
 127 toUfNote InlineMe       = UfInlineMe
 128
 129 ---------------------
 130 toUfBind (NonRec b r) = UfNonRec (toUfBndr b) (toUfExpr r)
 131 toUfBind (Rec prs)    = UfRec [(toUfBndr b, toUfExpr r) | (b,r) <- prs]
 132
 133 ---------------------
 134 toUfAlt (c,bs,r) = (toUfCon c, map getName bs, toUfExpr r)
 135
 136 ---------------------
 137 toUfCon (DataAlt dc) | isTupleTyCon tc = UfTupleAlt (HsTupCon (getName dc) (tupleTyConBoxity tc))
 138                      | otherwise       = UfDataAlt (getName dc)
 139                      where
 140                        tc = dataConTyCon dc
 141
 142 toUfCon (LitAlt l)   = case maybeLitLit l of
 143                          Just (s,ty) -> UfLitLitAlt s (toHsType ty)
 144                          Nothing     -> UfLitAlt l
 145 toUfCon DEFAULT      = UfDefault
 146
 147 ---------------------
 148 toUfBndr x | isId x    = UfValBinder (getName x) (toHsType (varType x))
 149            | otherwise = UfTyBinder  (getName x) (varType x)
 150
 151 ---------------------
 152 toUfApp (App f a) as = toUfApp f (a:as)
 153 toUfApp (Var v) as
 154   = case isDataConId_maybe v of
 155         -- We convert the *worker* for tuples into UfTuples
 156         Just dc |  isTupleTyCon tc && saturated
 157                 -> UfTuple (HsTupCon (getName dc) (tupleTyConBoxity tc)) tup_args
 158           where
 159             val_args  = dropWhile isTypeArg as
 160             saturated = length val_args == idArity v
 161             tup_args  = map toUfExpr val_args
 162             tc        = dataConTyCon dc
 163         ;
 164
 165         other -> mkUfApps (toUfVar v) as
 166
 167 toUfApp e as = mkUfApps (toUfExpr e) as
 168
 169 mkUfApps = foldl (\f a -> UfApp f (toUfExpr a))
 170
 171 ---------------------
 172 toUfVar v = case isPrimOpId_maybe v of
 173                 -- Ccalls has special syntax
 174                 Just (CCallOp cc) -> UfCCall cc (toHsType (idType v))
 175                 other             -> UfVar (getName v)
 176 \end{code}
 177
 178
 179 %************************************************************************
 180 %*                                                                      *
 181 \subsection[HsCore-print]{Printing Core unfoldings}
 182 %*                                                                      *
 183 %************************************************************************
 184
 185 \begin{code}
 186 instance (NamedThing name, Outputable name) => Outputable (UfExpr name) where
 187     ppr e = pprUfExpr noParens e
 188
 189
 190 -- Small-hack alert: this instance allows us to do a getOccName on RdrNames.
 191 -- Important because we want to pretty-print UfExprs, and we have to
 192 -- print an '@' before tyvar-binders in a case alternative.
 193 instance NamedThing RdrName where
 194     getOccName n = rdrNameOcc n
 195     getName n    = pprPanic "instance NamedThing RdrName" (ppr n)
 196
 197 noParens :: SDoc -> SDoc
 198 noParens pp = pp
 199
 200 pprUfExpr :: (NamedThing name, Outputable name) => (SDoc -> SDoc) -> UfExpr name -> SDoc
 201         -- The function adds parens in context that need
 202         -- an atomic value (e.g. function args)
 203
 204 pprUfExpr add_par (UfVar v)       = ppr v
 205 pprUfExpr add_par (UfLit l)       = ppr l
 206 pprUfExpr add_par (UfLitLit l ty) = add_par (hsep [ptext SLIT("__litlit"), pprHsString l, pprParendHsType ty])
 207 pprUfExpr add_par (UfCCall cc ty) = braces (pprCCallOp cc <+> ppr ty)
 208 pprUfExpr add_par (UfType ty)     = char '@' <+> pprParendHsType ty
 209
 210 pprUfExpr add_par e@(UfLam _ _)   = add_par (char '\\' <+> hsep (map ppr bndrs)
 211                                              <+> ptext SLIT("->") <+> pprUfExpr noParens body)
 212                                   where (bndrs,body) = collectUfBndrs e
 213 pprUfExpr add_par (UfApp fun arg) = add_par (pprUfExpr noParens fun <+> pprUfExpr parens arg)
 214 pprUfExpr add_par (UfTuple c as)  = hsTupParens c (interpp'SP as)
 215
 216 pprUfExpr add_par (UfCase scrut bndr alts)
 217       = add_par (hsep [ptext SLIT("case"), pprUfExpr noParens scrut, ptext SLIT("of"), ppr bndr,
 218                        braces (hsep (map pp_alt alts))])
 219       where
 220         pp_alt (UfTupleAlt tup_con, bs, rhs) = hsTupParens tup_con (interpp'SP bs) <+> ppr_rhs rhs
 221         pp_alt (c,                  bs, rhs) = ppr c <+> hsep (map pp_bndr bs) <+> ppr_rhs rhs
 222
 223         ppr_rhs rhs = ptext SLIT("->") <+> pprUfExpr noParens rhs <> semi
 224
 225         -- This use of getOccName is the sole reason for the NamedThing in pprUfExpr's type
 226         pp_bndr v   | isTvOcc (getOccName v) = char '@' <+> ppr v
 227                     | otherwise              = ppr v
 228
 229 pprUfExpr add_par (UfLet (UfNonRec b rhs) body)
 230       = add_par (hsep [ptext SLIT("let"),
 231                        braces (ppr b <+> equals <+> pprUfExpr noParens rhs),
 232                        ptext SLIT("in"), pprUfExpr noParens body])
 233
 234 pprUfExpr add_par (UfLet (UfRec pairs) body)
 235       = add_par (hsep [ptext SLIT("__letrec"), braces (hsep (map pp_pair pairs)),
 236                        ptext SLIT("in"), pprUfExpr noParens body])
 237       where
 238         pp_pair (b,rhs) = ppr b <+> equals <+> pprUfExpr noParens rhs <> semi
 239
 240 pprUfExpr add_par (UfNote note body) = add_par (ppr note <+> pprUfExpr parens body)
 241
 242
 243 collectUfBndrs :: UfExpr name -> ([UfBinder name], UfExpr name)
 244 collectUfBndrs expr
 245   = go [] expr
 246   where
 247     go bs (UfLam b e) = go (b:bs) e
 248     go bs e           = (reverse bs, e)
 249
 250 instance Outputable name => Outputable (UfNote name) where
 251     ppr (UfSCC cc)    = pprCostCentreCore cc
 252     ppr (UfCoerce ty) = ptext SLIT("__coerce") <+> pprParendHsType ty
 253     ppr UfInlineCall  = ptext SLIT("__inline_call")
 254     ppr UfInlineMe    = ptext SLIT("__inline_me")
 255
 256 instance Outputable name => Outputable (UfConAlt name) where
 257     ppr UfDefault          = text "__DEFAULT"
 258     ppr (UfLitAlt l)       = ppr l
 259     ppr (UfLitLitAlt l ty) = parens (hsep [ptext SLIT("__litlit"), pprHsString l, pprParendHsType ty])
 260     ppr (UfDataAlt d)      = ppr d
 261
 262 instance Outputable name => Outputable (UfBinder name) where
 263     ppr (UfValBinder name ty)  = hsep [ppr name, dcolon, pprParendHsType ty]
 264     ppr (UfTyBinder name kind) = char '@' <+> pprHsTyVarBndr name kind
 265 \end{code}
 266
 267
 268 %************************************************************************
 269 %*                                                                      *
 270 \subsection[HsCore-print]{Equality, for interface file checking
 271 %*                                                                      *
 272 %************************************************************************
 273
 274         ----------------------------------------
 275                         HACK ALERT
 276         ----------------------------------------
 277
 278 Whe comparing UfExprs, we compare names by converting to RdrNames and comparing
 279 those.  Reason: this is used when comparing ufoldings in interface files, and the
 280 uniques can differ.  Converting to RdrNames makes it more like comparing the file
 281 contents directly.  But this is bad: version numbers can change when only alpha-conversion
 282 has happened.
 283
 284         The hack shows up in eq_ufVar
 285         There are corresponding getOccName calls in MkIface.diffDecls
 286
 287         ----------------------------------------
 288                         END OF HACK ALERT
 289         ----------------------------------------
 290
 291
 292 \begin{code}
 293 instance (NamedThing name, Ord name) => Eq (UfExpr name) where
 294   (==) a b = eq_ufExpr emptyEqHsEnv a b
 295
 296 -----------------
 297 eq_ufBinder env (UfValBinder n1 t1) (UfValBinder n2 t2) k
 298   = eq_hsType env t1 t2 && k (extendEqHsEnv env n1 n2)
 299 eq_ufBinder env (UfTyBinder n1 k1) (UfTyBinder n2 k2) k
 300   = k1==k2 && k (extendEqHsEnv env n1 n2)
 301 eq_ufBinder _ _ _ _ = False
 302
 303 -----------------
 304 eq_ufBinders env []       []       k = k env
 305 eq_ufBinders env (b1:bs1) (b2:bs2) k = eq_ufBinder env b1 b2 (\env -> eq_ufBinders env bs1 bs2 k)
 306 eq_ufBinders env _        _        _ = False
 307
 308 -----------------
 309 eq_ufVar :: (NamedThing name, Ord name) => EqHsEnv name -> name -> name -> Bool
 310 -- Compare *Rdr* names.  A real hack to avoid gratuitous
 311 -- differences when comparing interface files
 312 eq_ufVar env n1 n2 = case lookupFM env n1 of
 313                        Just n1 -> toRdrName n1 == toRdrName n2
 314                        Nothing -> toRdrName n1 == toRdrName n2
 315
 316
 317 -----------------
 318 eq_ufExpr :: (NamedThing name, Ord name) => EqHsEnv name -> UfExpr name -> UfExpr name -> Bool
 319 eq_ufExpr env (UfVar v1)        (UfVar v2)        = eq_ufVar env v1 v2
 320 eq_ufExpr env (UfLit l1)        (UfLit l2)        = l1 == l2
 321 eq_ufExpr env (UfLitLit l1 ty1) (UfLitLit l2 ty2) = l1==l2 && eq_hsType env ty1 ty2
 322 eq_ufExpr env (UfCCall c1 ty1)  (UfCCall c2 ty2)  = c1==c2 && eq_hsType env ty1 ty2
 323 eq_ufExpr env (UfType ty1)      (UfType ty2)      = eq_hsType env ty1 ty2
 324 eq_ufExpr env (UfTuple n1 as1)  (UfTuple n2 as2)  = n1==n2 && eqListBy (eq_ufExpr env) as1 as2
 325 eq_ufExpr env (UfLam b1 body1)  (UfLam b2 body2)  = eq_ufBinder env b1 b2 (\env -> eq_ufExpr env body1 body2)
 326 eq_ufExpr env (UfApp f1 a1)     (UfApp f2 a2)     = eq_ufExpr env f1 f2 && eq_ufExpr env a1 a2
 327
 328 eq_ufExpr env (UfCase s1 b1 as1) (UfCase s2 b2 as2)
 329   = eq_ufExpr env s1 s2 &&
 330     eqListBy (eq_ufAlt (extendEqHsEnv env b1 b2)) as1 as2
 331   where
 332     eq_ufAlt env (c1,bs1,r1) (c2,bs2,r2)
 333         = eq_ufConAlt env c1 c2 && eq_hsVars env bs1 bs2 (\env -> eq_ufExpr env r1 r2)
 334
 335 eq_ufExpr env (UfLet (UfNonRec b1 r1) x1) (UfLet (UfNonRec b2 r2) x2)
 336   = eq_ufExpr env r1 r2 && eq_ufBinder env b1 b2 (\env -> eq_ufExpr env x1 x2)
 337
 338 eq_ufExpr env (UfLet (UfRec as1) x1) (UfLet (UfRec as2) x2)
 339   = eq_ufBinders env bs1 bs2 (\env -> eqListBy (eq_ufExpr env) rs1 rs2 && eq_ufExpr env x1 x2)
 340   where
 341     (bs1,rs1) = unzip as1
 342     (bs2,rs2) = unzip as2
 343
 344 eq_ufExpr env (UfNote n1 r1) (UfNote n2 r2)
 345   = eq_ufNote n1 n2 && eq_ufExpr env r1 r2
 346   where
 347     eq_ufNote (UfSCC c1)    (UfSCC c2)    = c1==c2
 348     eq_ufNote (UfCoerce t1) (UfCoerce t2) = eq_hsType env t1 t2
 349     eq_ufNote UfInlineCall  UfInlineCall  = True
 350     eq_ufNote UfInlineMe    UfInlineMe    = True
 351     eq_ufNote _             _             = False
 352
 353 eq_ufExpr env _ _ = False
 354
 355 -----------------
 356 eq_ufConAlt env UfDefault           UfDefault           = True
 357 eq_ufConAlt env (UfDataAlt n1)      (UfDataAlt n2)      = n1==n2
 358 eq_ufConAlt env (UfTupleAlt c1)     (UfTupleAlt c2)     = c1==c2
 359 eq_ufConAlt env (UfLitAlt l1)       (UfLitAlt l2)       = l1==l2
 360 eq_ufConAlt env (UfLitLitAlt s1 t1) (UfLitLitAlt s2 t2) = s1==s2 && eq_hsType env t1 t2
 361 eq_ufConAlt env _ _ = False
 362 \end{code}
 363
 364
 365 %************************************************************************
 366 %*                                                                      *
 367 \subsection{Rules in interface files}
 368 %*                                                                      *
 369 %************************************************************************
 370
 371 \begin{code}
 372 pprHsIdInfo :: (NamedThing n, Outputable n) => [HsIdInfo n] -> SDoc
 373 pprHsIdInfo []   = empty
 374 pprHsIdInfo info = ptext SLIT("{-##") <+> hsep (map ppr_hs_info info) <+> ptext SLIT("##-}")
 375
 376 data HsIdInfo name
 377   = HsArity             ArityInfo
 378   | HsStrictness        StrictnessInfo
 379   | HsUnfold            InlinePragInfo (UfExpr name)
 380   | HsNoCafRefs
 381   | HsCprInfo
 382   | HsWorker            name            -- Worker, if any
 383   deriving( Eq )
 384 -- NB: Specialisations and rules come in separately and are
 385 -- only later attached to the Id.  Partial reason: some are orphans.
 386
 387 ppr_hs_info (HsUnfold prag unf) = ptext SLIT("__U") <> pprInlinePragInfo prag <+> parens (pprUfExpr noParens unf)
 388 ppr_hs_info (HsArity arity)     = ppArityInfo arity
 389 ppr_hs_info (HsStrictness str)  = ptext SLIT("__S") <+> ppStrictnessInfo str
 390 ppr_hs_info HsNoCafRefs         = ptext SLIT("__C")
 391 ppr_hs_info HsCprInfo           = ptext SLIT("__M")
 392 ppr_hs_info (HsWorker w)        = ptext SLIT("__P") <+> ppr w
 393 \end{code}
 394