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