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