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, 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                  | UfCoreNote String
  80
  81 type UfAlt name = (UfConAlt name, [name], UfExpr name)
  82
  83 data UfConAlt name = UfDefault
  84                    | UfDataAlt name
  85                    | UfTupleAlt HsTupCon
  86                    | UfLitAlt Literal
  87                    | UfLitLitAlt FastString (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 toUfNote (CoreNote s)   = UfCoreNote s
 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 (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 isDataConWorkId_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 = val_args `lengthIs` 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 isFCallId_maybe v of
 177                 -- Foreign calls have special syntax
 178                 Just fcall -> UfFCall fcall (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 OutputableBndr 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 :: OutputableBndr 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 (UfFCall cc ty) = braces (ppr cc <+> ppr ty)
 212 pprUfExpr add_par (UfType ty)     = char '@' <+> pprParendHsType ty
 213
 214 pprUfExpr add_par e@(UfLam _ _)   = add_par (char '\\' <+> hsep (map (pprBndr LambdaBind) 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 (pprBndr CaseBind) bs) <+> ppr_rhs rhs
 226
 227         ppr_rhs rhs = ptext SLIT("->") <+> pprUfExpr noParens rhs <> semi
 228
 229 pprUfExpr add_par (UfLet (UfNonRec b rhs) body)
 230       = add_par (hsep [ptext SLIT("let"),
 231                        braces (pprBndr LetBind b <+> equals <+> pprUfExpr noParens rhs),
 232                        ptext SLIT("in"), pprUfExpr noParens body])
 233
 234 pprUfExpr add_par (UfLet (UfRec pairs) body)
 235       = add_par (hsep [ptext SLIT("__letrec"), braces (hsep (map pp_pair pairs)),
 236                        ptext SLIT("in"), pprUfExpr noParens body])
 237       where
 238         pp_pair (b,rhs) = ppr b <+> equals <+> pprUfExpr noParens rhs <> semi
 239
 240 pprUfExpr add_par (UfNote note body) = add_par (ppr note <+> pprUfExpr parens body)
 241
 242 pprUfApp (UfApp fun arg) = pprUfApp fun <+> pprUfExpr parens arg
 243 pprUfApp fun             = pprUfExpr parens fun
 244
 245 collectUfBndrs :: UfExpr name -> ([UfBinder name], UfExpr name)
 246 collectUfBndrs expr
 247   = go [] expr
 248   where
 249     go bs (UfLam b e) = go (b:bs) e
 250     go bs e           = (reverse bs, e)
 251
 252 instance Outputable name => Outputable (UfNote name) where
 253     ppr (UfSCC cc)    = pprCostCentreCore cc
 254     ppr (UfCoerce ty) = ptext SLIT("__coerce") <+> pprParendHsType ty
 255     ppr UfInlineCall  = ptext SLIT("__inline_call")
 256     ppr UfInlineMe    = ptext SLIT("__inline_me")
 257     ppr (UfCoreNote s)= ptext SLIT("__core_note") <+> pprHsString (mkFastString s)
 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
 269 instance OutputableBndr name => OutputableBndr (UfBinder name) where
 270     pprBndr _ (UfValBinder name ty)  = hsep [ppr name, dcolon, pprParendHsType ty]
 271     pprBndr _ (UfTyBinder name kind) = char '@' <+> pprHsTyVarBndr name kind
 272 \end{code}
 273
 274
 275 %************************************************************************
 276 %*                                                                      *
 277 \subsection[HsCore-print]{Equality, for interface file checking
 278 %*                                                                      *
 279 %************************************************************************
 280
 281         ----------------------------------------
 282                         HACK ALERT
 283         ----------------------------------------
 284
 285 Whe comparing UfExprs, we compare names by converting to RdrNames and comparing
 286 those.  Reason: this is used when comparing ufoldings in interface files, and the
 287 uniques can differ.  Converting to RdrNames makes it more like comparing the file
 288 contents directly.  But this is bad: version numbers can change when only alpha-conversion
 289 has happened.
 290
 291         The hack shows up in eq_ufVar
 292         There are corresponding getOccName calls in MkIface.diffDecls
 293
 294         ----------------------------------------
 295                         END OF HACK ALERT
 296         ----------------------------------------
 297
 298
 299 \begin{code}
 300 instance (NamedThing name, Ord name) => Eq (UfExpr name) where
 301   (==) a b = eq_ufExpr emptyEqHsEnv a b
 302
 303 -----------------
 304 eq_ufBinder env (UfValBinder n1 t1) (UfValBinder n2 t2) k
 305   = eq_hsType env t1 t2 && k (extendEqHsEnv env n1 n2)
 306 eq_ufBinder env (UfTyBinder n1 k1) (UfTyBinder n2 k2) k
 307   = k1 `eqKind` k2 && k (extendEqHsEnv env n1 n2)
 308 eq_ufBinder _ _ _ _ = False
 309
 310 -----------------
 311 eq_ufBinders env []       []       k = k env
 312 eq_ufBinders env (b1:bs1) (b2:bs2) k = eq_ufBinder env b1 b2 (\env -> eq_ufBinders env bs1 bs2 k)
 313 eq_ufBinders env _        _        _ = False
 314
 315 -----------------
 316 eq_ufVar :: (NamedThing name, Ord name) => EqHsEnv name -> name -> name -> Bool
 317 -- Compare *Rdr* names.  A real hack to avoid gratuitous
 318 -- differences when comparing interface files
 319 eq_ufVar env n1 n2 = case lookupFM env n1 of
 320                        Just n1 -> check n1
 321                        Nothing -> check n1
 322    where
 323         check n1 = eqNameByOcc (getName n1) (getName n2)
 324
 325 -----------------
 326 eq_ufExpr :: (NamedThing name, Ord name) => EqHsEnv name -> UfExpr name -> UfExpr name -> Bool
 327 eq_ufExpr env (UfVar v1)        (UfVar v2)        = eq_ufVar env v1 v2
 328 eq_ufExpr env (UfLit l1)        (UfLit l2)        = l1 == l2
 329 eq_ufExpr env (UfLitLit l1 ty1) (UfLitLit l2 ty2) = l1==l2 && eq_hsType env ty1 ty2
 330 eq_ufExpr env (UfFCall c1 ty1)  (UfFCall c2 ty2)  = c1==c2 && eq_hsType env ty1 ty2
 331 eq_ufExpr env (UfType ty1)      (UfType ty2)      = eq_hsType env ty1 ty2
 332 eq_ufExpr env (UfTuple n1 as1)  (UfTuple n2 as2)  = n1==n2 && eqListBy (eq_ufExpr env) as1 as2
 333 eq_ufExpr env (UfLam b1 body1)  (UfLam b2 body2)  = eq_ufBinder env b1 b2 (\env -> eq_ufExpr env body1 body2)
 334 eq_ufExpr env (UfApp f1 a1)     (UfApp f2 a2)     = eq_ufExpr env f1 f2 && eq_ufExpr env a1 a2
 335
 336 eq_ufExpr env (UfCase s1 b1 as1) (UfCase s2 b2 as2)
 337   = eq_ufExpr env s1 s2 &&
 338     eqListBy (eq_ufAlt (extendEqHsEnv env b1 b2)) as1 as2
 339   where
 340     eq_ufAlt env (c1,bs1,r1) (c2,bs2,r2)
 341         = eq_ufConAlt env c1 c2 && eq_hsVars env bs1 bs2 (\env -> eq_ufExpr env r1 r2)
 342
 343 eq_ufExpr env (UfLet (UfNonRec b1 r1) x1) (UfLet (UfNonRec b2 r2) x2)
 344   = eq_ufExpr env r1 r2 && eq_ufBinder env b1 b2 (\env -> eq_ufExpr env x1 x2)
 345
 346 eq_ufExpr env (UfLet (UfRec as1) x1) (UfLet (UfRec as2) x2)
 347   = eq_ufBinders env bs1 bs2 (\env -> eqListBy (eq_ufExpr env) rs1 rs2 && eq_ufExpr env x1 x2)
 348   where
 349     (bs1,rs1) = unzip as1
 350     (bs2,rs2) = unzip as2
 351
 352 eq_ufExpr env (UfNote n1 r1) (UfNote n2 r2)
 353   = eq_ufNote n1 n2 && eq_ufExpr env r1 r2
 354   where
 355     eq_ufNote (UfSCC c1)    (UfSCC c2)    = c1==c2
 356     eq_ufNote (UfCoerce t1) (UfCoerce t2) = eq_hsType env t1 t2
 357     eq_ufNote UfInlineCall  UfInlineCall  = True
 358     eq_ufNote UfInlineMe    UfInlineMe    = True
 359     eq_ufNote (UfCoreNote s1) (UfCoreNote s2) = s1==s2
 360     eq_ufNote _             _             = False
 361
 362 eq_ufExpr env _ _ = False
 363
 364 -----------------
 365 eq_ufConAlt env UfDefault           UfDefault           = True
 366 eq_ufConAlt env (UfDataAlt n1)      (UfDataAlt n2)      = n1==n2
 367 eq_ufConAlt env (UfTupleAlt c1)     (UfTupleAlt c2)     = c1==c2
 368 eq_ufConAlt env (UfLitAlt l1)       (UfLitAlt l2)       = l1==l2
 369 eq_ufConAlt env (UfLitLitAlt s1 t1) (UfLitLitAlt s2 t2) = s1==s2 && eq_hsType env t1 t2
 370 eq_ufConAlt env _ _ = False
 371 \end{code}
 372
 373
 374 %************************************************************************
 375 %*                                                                      *
 376 \subsection{Rules in interface files}
 377 %*                                                                      *
 378 %************************************************************************
 379
 380 \begin{code}
 381 pprHsIdInfo :: OutputableBndr n => [HsIdInfo n] -> SDoc
 382 pprHsIdInfo []   = empty
 383 pprHsIdInfo info = ptext SLIT("{-##") <+> hsep (map ppr_hs_info info) <+> ptext SLIT("##-}")
 384
 385 data HsIdInfo name
 386   = HsArity             Arity
 387   | HsStrictness        StrictSig
 388   | HsUnfold            InlinePragInfo (UfExpr name)
 389   | HsNoCafRefs
 390   | HsWorker            name Arity      -- Worker, if any see IdInfo.WorkerInfo
 391                                         -- for why we want arity here.
 392   deriving( Eq )
 393 -- NB: Specialisations and rules come in separately and are
 394 -- only later attached to the Id.  Partial reason: some are orphans.
 395
 396 ppr_hs_info (HsUnfold prag unf) = ptext SLIT("__U") <> ppr prag <+> parens (pprUfExpr noParens unf)
 397 ppr_hs_info (HsArity arity)     = ptext SLIT("__A") <+> int arity
 398 ppr_hs_info (HsStrictness str)  = ptext SLIT("__S") <+> pprIfaceStrictSig str
 399 ppr_hs_info HsNoCafRefs         = ptext SLIT("__C")
 400 ppr_hs_info (HsWorker w a)      = ptext SLIT("__P") <+> ppr w <+> int a
 401 \end{code}
 402