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, isDataConWorkId_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 )
  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   | UfFCall     ForeignCall (HsType name)
  73
  74 data UfNote name = UfSCC CostCentre
  75                  | UfCoerce (HsType name)
  76                  | UfInlineCall
  77                  | UfInlineMe
  78                  | UfCoreNote String
  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
  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) = UfLit l
 112 toUfExpr (Type ty) = UfType (toHsType ty)
 113 toUfExpr (Lam x b) = UfLam (toUfBndr x) (toUfExpr b)
 114 toUfExpr (App f a) = toUfApp f [a]
 115 toUfExpr (Case s x as) = UfCase (toUfExpr s) (getName x) (map toUfAlt as)
 116 toUfExpr (Let b e)     = UfLet (toUfBind b) (toUfExpr e)
 117 toUfExpr (Note n e)    = UfNote (toUfNote n) (toUfExpr e)
 118
 119 ---------------------
 120 toUfNote (SCC cc)       = UfSCC cc
 121 toUfNote (Coerce t1 _)  = UfCoerce (toHsType t1)
 122 toUfNote InlineCall     = UfInlineCall
 123 toUfNote InlineMe       = UfInlineMe
 124 toUfNote (CoreNote s)   = UfCoreNote s
 125
 126 ---------------------
 127 toUfBind (NonRec b r) = UfNonRec (toUfBndr b) (toUfExpr r)
 128 toUfBind (Rec prs)    = UfRec [(toUfBndr b, toUfExpr r) | (b,r) <- prs]
 129
 130 ---------------------
 131 toUfAlt (c,bs,r) = (toUfCon c, map getName bs, toUfExpr r)
 132
 133 ---------------------
 134 toUfCon (DataAlt dc) | isTupleTyCon tc = UfTupleAlt (mk_hs_tup_con tc dc)
 135                      | otherwise       = UfDataAlt (getName dc)
 136                      where
 137                        tc = dataConTyCon dc
 138
 139 toUfCon (LitAlt l)   = UfLitAlt l
 140 toUfCon DEFAULT      = UfDefault
 141
 142 ---------------------
 143 mk_hs_tup_con tc dc = HsTupCon (tupleTyConBoxity tc) (dataConSourceArity dc)
 144
 145 ---------------------
 146 toUfBndr x | isId x    = UfValBinder (getName x) (toHsType (varType x))
 147            | otherwise = UfTyBinder  (getName x) (varType x)
 148
 149 ---------------------
 150 toUfApp (App f a) as = toUfApp f (a:as)
 151 toUfApp (Var v) as
 152   = case isDataConWorkId_maybe v of
 153         -- We convert the *worker* for tuples into UfTuples
 154         Just dc |  isTupleTyCon tc && saturated
 155                 -> UfTuple (mk_hs_tup_con tc dc) tup_args
 156           where
 157             val_args  = dropWhile isTypeArg as
 158             saturated = val_args `lengthIs` idArity v
 159             tup_args  = map toUfExpr val_args
 160             tc        = dataConTyCon dc
 161         ;
 162
 163         other -> mkUfApps (toUfVar v) as
 164
 165 toUfApp e as = mkUfApps (toUfExpr e) as
 166
 167 mkUfApps = foldl (\f a -> UfApp f (toUfExpr a))
 168
 169 ---------------------
 170 toUfVar v = case isFCallId_maybe v of
 171                 -- Foreign calls have special syntax
 172                 Just fcall -> UfFCall fcall (toHsType (idType v))
 173                 other      -> UfVar (getName v)
 174 \end{code}
 175
 176
 177 %************************************************************************
 178 %*                                                                      *
 179 \subsection[HsCore-print]{Printing Core unfoldings}
 180 %*                                                                      *
 181 %************************************************************************
 182
 183 \begin{code}
 184 instance OutputableBndr name => Outputable (UfExpr name) where
 185     ppr e = pprUfExpr noParens e
 186
 187
 188 -- Small-hack alert: this instance allows us to do a getOccName on RdrNames.
 189 -- Important because we want to pretty-print UfExprs, and we have to
 190 -- print an '@' before tyvar-binders in a case alternative.
 191 instance NamedThing RdrName where
 192     getOccName n = rdrNameOcc n
 193     getName n    = pprPanic "instance NamedThing RdrName" (ppr n)
 194
 195 noParens :: SDoc -> SDoc
 196 noParens pp = pp
 197
 198 pprUfExpr :: OutputableBndr name => (SDoc -> SDoc) -> UfExpr name -> SDoc
 199         -- The function adds parens in context that need
 200         -- an atomic value (e.g. function args)
 201
 202 pprUfExpr add_par (UfVar v)       = ppr v
 203 pprUfExpr add_par (UfLit l)       = ppr l
 204 pprUfExpr add_par (UfFCall cc ty) = braces (ppr cc <+> ppr ty)
 205 pprUfExpr add_par (UfType ty)     = char '@' <+> pprParendHsType ty
 206
 207 pprUfExpr add_par e@(UfLam _ _)   = add_par (char '\\' <+> hsep (map (pprBndr LambdaBind) bndrs)
 208                                              <+> ptext SLIT("->") <+> pprUfExpr noParens body)
 209                                   where (bndrs,body) = collectUfBndrs e
 210 pprUfExpr add_par app@(UfApp _ _) = add_par (pprUfApp app)
 211 pprUfExpr add_par (UfTuple c as)  = hsTupParens c (interpp'SP as)
 212
 213 pprUfExpr add_par (UfCase scrut bndr alts)
 214       = add_par (hsep [ptext SLIT("case"), pprUfExpr noParens scrut, ptext SLIT("of"), ppr bndr,
 215                        braces (hsep (map pp_alt alts))])
 216       where
 217         pp_alt (UfTupleAlt tup_con, bs, rhs) = hsTupParens tup_con (interpp'SP bs) <+> ppr_rhs rhs
 218         pp_alt (c,                  bs, rhs) = ppr c <+> hsep (map (pprBndr CaseBind) bs) <+> ppr_rhs rhs
 219
 220         ppr_rhs rhs = ptext SLIT("->") <+> pprUfExpr noParens rhs <> semi
 221
 222 pprUfExpr add_par (UfLet (UfNonRec b rhs) body)
 223       = add_par (hsep [ptext SLIT("let"),
 224                        braces (pprBndr LetBind b <+> equals <+> pprUfExpr noParens rhs),
 225                        ptext SLIT("in"), pprUfExpr noParens body])
 226
 227 pprUfExpr add_par (UfLet (UfRec pairs) body)
 228       = add_par (hsep [ptext SLIT("__letrec"), braces (hsep (map pp_pair pairs)),
 229                        ptext SLIT("in"), pprUfExpr noParens body])
 230       where
 231         pp_pair (b,rhs) = ppr b <+> equals <+> pprUfExpr noParens rhs <> semi
 232
 233 pprUfExpr add_par (UfNote note body) = add_par (ppr note <+> pprUfExpr parens body)
 234
 235 pprUfApp (UfApp fun arg) = pprUfApp fun <+> pprUfExpr parens arg
 236 pprUfApp fun             = pprUfExpr parens fun
 237
 238 collectUfBndrs :: UfExpr name -> ([UfBinder name], UfExpr name)
 239 collectUfBndrs expr
 240   = go [] expr
 241   where
 242     go bs (UfLam b e) = go (b:bs) e
 243     go bs e           = (reverse bs, e)
 244
 245 instance Outputable name => Outputable (UfNote name) where
 246     ppr (UfSCC cc)    = pprCostCentreCore cc
 247     ppr (UfCoerce ty) = ptext SLIT("__coerce") <+> pprParendHsType ty
 248     ppr UfInlineCall  = ptext SLIT("__inline_call")
 249     ppr UfInlineMe    = ptext SLIT("__inline_me")
 250     ppr (UfCoreNote s)= ptext SLIT("__core_note") <+> pprHsString (mkFastString s)
 251
 252 instance Outputable name => Outputable (UfConAlt name) where
 253     ppr UfDefault          = text "__DEFAULT"
 254     ppr (UfLitAlt l)       = ppr l
 255     ppr (UfDataAlt d)      = ppr d
 256
 257 instance Outputable name => Outputable (UfBinder name) where
 258     ppr (UfValBinder name ty)  = hsep [ppr name, dcolon, pprParendHsType ty]
 259     ppr (UfTyBinder name kind) = char '@' <+> pprHsTyVarBndr name kind
 260
 261 instance OutputableBndr name => OutputableBndr (UfBinder name) where
 262     pprBndr _ (UfValBinder name ty)  = hsep [ppr name, dcolon, pprParendHsType ty]
 263     pprBndr _ (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 `eqKind` 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 -> check n1
 313                        Nothing -> check n1
 314    where
 315         check n1 = eqNameByOcc (getName n1) (getName n2)
 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 (UfFCall c1 ty1)  (UfFCall 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 (UfCoreNote s1) (UfCoreNote s2) = s1==s2
 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 _ _ = False
 361 \end{code}
 362
 363
 364 %************************************************************************
 365 %*                                                                      *
 366 \subsection{Rules in interface files}
 367 %*                                                                      *
 368 %************************************************************************
 369
 370 \begin{code}
 371 pprHsIdInfo :: OutputableBndr 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             Arity
 377   | HsStrictness        StrictSig
 378   | HsUnfold            InlinePragInfo (UfExpr name)
 379   | HsNoCafRefs
 380   | HsWorker            name Arity      -- Worker, if any see IdInfo.WorkerInfo
 381                                         -- for why we want arity here.
 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") <> ppr prag <+> parens (pprUfExpr noParens unf)
 387 ppr_hs_info (HsArity arity)     = ptext SLIT("__A") <+> int arity
 388 ppr_hs_info (HsStrictness str)  = ptext SLIT("__S") <+> pprIfaceStrictSig str
 389 ppr_hs_info HsNoCafRefs         = ptext SLIT("__C")
 390 ppr_hs_info (HsWorker w a)      = ptext SLIT("__P") <+> ppr w <+> int a
 391 \end{code}
 392