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