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