ghc/compiler/coreSyn/CoreUtils.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[CoreUtils]{Utility functions on @Core@ syntax}
   5
   6 \begin{code}
   7 module CoreUtils (
   8         coreExprType, coreAltsType,
   9
  10         exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap, exprIsValue,
  11         exprOkForSpeculation, exprIsBig, hashExpr,
  12         exprArity,
  13         cheapEqExpr, eqExpr, applyTypeToArgs
  14     ) where
  15
  16 #include "HsVersions.h"
  17
  18
  19 import {-# SOURCE #-} CoreUnfold        ( isEvaldUnfolding )
  20
  21 import CoreSyn
  22 import PprCore          ( pprCoreExpr )
  23 import Var              ( IdOrTyVar, isId, isTyVar )
  24 import VarSet
  25 import VarEnv
  26 import Name             ( isLocallyDefined, hashName )
  27 import Const            ( Con, isWHNFCon, conIsTrivial, conIsCheap, conIsDupable,
  28                           conType, conOkForSpeculation, conStrictness, hashCon
  29                         )
  30 import Id               ( Id, idType, setIdType, idUnique, idAppIsBottom,
  31                           getIdArity, idName,
  32                           getIdSpecialisation, setIdSpecialisation,
  33                           getInlinePragma, setInlinePragma,
  34                           getIdUnfolding, setIdUnfolding, idInfo
  35                         )
  36 import IdInfo           ( arityLowerBound, InlinePragInfo(..), lbvarInfo, LBVarInfo(..) )
  37 import Type             ( Type, mkFunTy, mkForAllTy,
  38                           splitFunTy_maybe, tyVarsOfType, tyVarsOfTypes,
  39                           isNotUsgTy, mkUsgTy, unUsgTy, UsageAnn(..),
  40                           tidyTyVar, applyTys, isUnLiftedType
  41                         )
  42 import Demand           ( isPrim, isLazy )
  43 import Unique           ( buildIdKey, augmentIdKey )
  44 import Util             ( zipWithEqual, mapAccumL )
  45 import Outputable
  46 import TysPrim          ( alphaTy )     -- Debugging only
  47 \end{code}
  48
  49
  50 %************************************************************************
  51 %*                                                                      *
  52 \subsection{Find the type of a Core atom/expression}
  53 %*                                                                      *
  54 %************************************************************************
  55
  56 \begin{code}
  57 coreExprType :: CoreExpr -> Type
  58
  59 coreExprType (Var var)              = idType var
  60 coreExprType (Let _ body)           = coreExprType body
  61 coreExprType (Case _ _ alts)        = coreAltsType alts
  62 coreExprType (Note (Coerce ty _) e) = ty
  63 coreExprType (Note (TermUsg u) e)   = mkUsgTy u (unUsgTy (coreExprType e))
  64 coreExprType (Note other_note e)    = coreExprType e
  65 coreExprType e@(Con con args)       = applyTypeToArgs e (conType con) args
  66
  67 coreExprType (Lam binder expr)
  68   | isId binder    = (case (lbvarInfo . idInfo) binder of
  69                        IsOneShotLambda -> mkUsgTy UsOnce
  70                        otherwise       -> id) $
  71                      idType binder `mkFunTy` coreExprType expr
  72   | isTyVar binder = mkForAllTy binder (coreExprType expr)
  73
  74 coreExprType e@(App _ _)
  75   = case collectArgs e of
  76         (fun, args) -> applyTypeToArgs e (coreExprType fun) args
  77
  78 coreExprType other = pprTrace "coreExprType" (pprCoreExpr other) alphaTy
  79
  80 coreAltsType :: [CoreAlt] -> Type
  81 coreAltsType ((_,_,rhs) : _) = coreExprType rhs
  82 \end{code}
  83
  84 \begin{code}
  85 -- The first argument is just for debugging
  86 applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
  87 applyTypeToArgs e op_ty [] = op_ty
  88
  89 applyTypeToArgs e op_ty (Type ty : args)
  90   =     -- Accumulate type arguments so we can instantiate all at once
  91     ASSERT2( all isNotUsgTy tys, ppr e <+> text "of" <+> ppr op_ty <+> text "to" <+> ppr (Type ty : args) <+> text "i.e." <+> ppr tys )
  92     applyTypeToArgs e (applyTys op_ty tys) rest_args
  93   where
  94     (tys, rest_args)        = go [ty] args
  95     go tys (Type ty : args) = go (ty:tys) args
  96     go tys rest_args        = (reverse tys, rest_args)
  97
  98 applyTypeToArgs e op_ty (other_arg : args)
  99   = case (splitFunTy_maybe op_ty) of
 100         Just (_, res_ty) -> applyTypeToArgs e res_ty args
 101         Nothing -> pprPanic "applyTypeToArgs" (pprCoreExpr e)
 102 \end{code}
 103
 104
 105 %************************************************************************
 106 %*                                                                      *
 107 \subsection{Figuring out things about expressions}
 108 %*                                                                      *
 109 %************************************************************************
 110
 111 @exprIsTrivial@ is true of expressions we are unconditionally
 112                 happy to duplicate; simple variables and constants,
 113                 and type applications.
 114
 115 @exprIsBottom@  is true of expressions that are guaranteed to diverge
 116
 117
 118 \begin{code}
 119 exprIsTrivial (Type _)       = True
 120 exprIsTrivial (Var v)        = True
 121 exprIsTrivial (App e arg)    = isTypeArg arg && exprIsTrivial e
 122 exprIsTrivial (Note _ e)     = exprIsTrivial e
 123 exprIsTrivial (Con con args) = conIsTrivial con && all isTypeArg args
 124 exprIsTrivial (Lam b body)   | isTyVar b = exprIsTrivial body
 125 exprIsTrivial other          = False
 126 \end{code}
 127
 128
 129 @exprIsDupable@ is true of expressions that can be duplicated at a modest
 130                 cost in code size.  This will only happen in different case
 131                 branches, so there's no issue about duplicating work.
 132
 133                 That is, exprIsDupable returns True of (f x) even if
 134                 f is very very expensive to call.
 135
 136                 Its only purpose is to avoid fruitless let-binding
 137                 and then inlining of case join points
 138
 139
 140 \begin{code}
 141 exprIsDupable (Type _)       = True
 142 exprIsDupable (Con con args) = conIsDupable con &&
 143                                all exprIsDupable args &&
 144                                valArgCount args <= dupAppSize
 145
 146 exprIsDupable (Note _ e)     = exprIsDupable e
 147 exprIsDupable expr           = case collectArgs expr of
 148                                   (Var f, args) ->  valArgCount args <= dupAppSize
 149                                   other         ->  False
 150
 151 dupAppSize :: Int
 152 dupAppSize = 4          -- Size of application we are prepared to duplicate
 153 \end{code}
 154
 155 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
 156 it is obviously in weak head normal form, or is cheap to get to WHNF.
 157 [Note that that's not the same as exprIsDupable; an expression might be
 158 big, and hence not dupable, but still cheap.]
 159
 160 By ``cheap'' we mean a computation we're willing to:
 161         push inside a lambda, or
 162         inline at more than one place
 163 That might mean it gets evaluated more than once, instead of being
 164 shared.  The main examples of things which aren't WHNF but are
 165 ``cheap'' are:
 166
 167   *     case e of
 168           pi -> ei
 169
 170         where e, and all the ei are cheap; and
 171
 172   *     let x = e
 173         in b
 174
 175         where e and b are cheap; and
 176
 177   *     op x1 ... xn
 178
 179         where op is a cheap primitive operator
 180
 181   *     error "foo"
 182
 183 Notice that a variable is considered 'cheap': we can push it inside a lambda,
 184 because sharing will make sure it is only evaluated once.
 185
 186 \begin{code}
 187 exprIsCheap :: CoreExpr -> Bool
 188 exprIsCheap (Type _)            = True
 189 exprIsCheap (Var _)             = True
 190 exprIsCheap (Con con args)      = conIsCheap con && all exprIsCheap args
 191 exprIsCheap (Note _ e)          = exprIsCheap e
 192 exprIsCheap (Lam x e)           = if isId x then True else exprIsCheap e
 193
 194 --      I'm not at all convinced about these two!!
 195 --      [SLPJ June 99]
 196 -- exprIsCheap (Let bind body)  = all exprIsCheap (rhssOfBind bind) && exprIsCheap body
 197 -- exprIsCheap (Case scrut _ alts) = exprIsCheap scrut &&
 198 --                                   all (\(_,_,rhs) -> exprIsCheap rhs) alts
 199
 200 exprIsCheap other_expr   -- look for manifest partial application
 201   = case collectArgs other_expr of
 202         (f, args) -> isPap f (valArgCount args) && all exprIsCheap args
 203 \end{code}
 204
 205 \begin{code}
 206 isPap :: CoreExpr               -- Function
 207       -> Int                    -- Number of value args
 208       -> Bool
 209 isPap (Var f) n_val_args
 210   =    idAppIsBottom f n_val_args
 211                                 -- Application of a function which
 212                                 -- always gives bottom; we treat this as
 213                                 -- a WHNF, because it certainly doesn't
 214                                 -- need to be shared!
 215
 216     || n_val_args == 0          -- Just a type application of
 217                                 -- a variable (f t1 t2 t3)
 218                                 -- counts as WHNF
 219
 220     || n_val_args < arityLowerBound (getIdArity f)
 221
 222 isPap fun n_val_args = False
 223 \end{code}
 224
 225 exprOkForSpeculation returns True of an UNLIFTED-TYPE expression that it is safe
 226 to evaluate even if normal order eval might not evaluate the expression
 227 at all.  E.G.
 228         let x = case y# +# 1# of { r# -> I# r# }
 229         in E
 230 ==>
 231         case y# +# 1# of { r# ->
 232         let x = I# r#
 233         in E
 234         }
 235
 236 We can only do this if the (y+1) is ok for speculation: it has no
 237 side effects, and can't diverge or raise an exception.
 238
 239 \begin{code}
 240 exprOkForSpeculation :: CoreExpr -> Bool
 241 exprOkForSpeculation (Var v)        = True      -- Unlifted type => already evaluated
 242
 243 exprOkForSpeculation (Note _ e)           = exprOkForSpeculation e
 244 exprOkForSpeculation (Let (NonRec b r) e) = isUnLiftedType (idType b) &&
 245                                             exprOkForSpeculation r &&
 246                                             exprOkForSpeculation e
 247 exprOkForSpeculation (Let (Rec _) _) = False
 248 exprOkForSpeculation (Case _ _ _)    = False    -- Conservative
 249 exprOkForSpeculation (App _ _)       = False
 250
 251 exprOkForSpeculation (Con con args)
 252   = conOkForSpeculation con &&
 253     and (zipWith ok (filter isValArg args) (fst (conStrictness con)))
 254   where
 255     ok arg demand | isLazy demand = True
 256                   | isPrim demand = exprOkForSpeculation arg
 257                   | otherwise     = False
 258
 259 exprOkForSpeculation other = panic "exprOkForSpeculation"
 260         -- Lam, Type
 261 \end{code}
 262
 263
 264 \begin{code}
 265 exprIsBottom :: CoreExpr -> Bool        -- True => definitely bottom
 266 exprIsBottom e = go 0 e
 267                where
 268                 -- n is the number of args
 269                  go n (Note _ e)   = go n e
 270                  go n (Let _ e)    = go n e
 271                  go n (Case e _ _) = go 0 e     -- Just check the scrut
 272                  go n (App e _)    = go (n+1) e
 273                  go n (Var v)      = idAppIsBottom v n
 274                  go n (Con _ _)    = False
 275                  go n (Lam _ _)    = False
 276 \end{code}
 277
 278 @exprIsValue@ returns true for expressions that are certainly *already*
 279 evaluated to WHNF.  This is used to decide wether it's ok to change
 280         case x of _ -> e   ===>   e
 281
 282 and to decide whether it's safe to discard a `seq`
 283
 284 So, it does *not* treat variables as evaluated, unless they say they are
 285
 286 \begin{code}
 287 exprIsValue :: CoreExpr -> Bool         -- True => Value-lambda, constructor, PAP
 288 exprIsValue (Type ty)     = True        -- Types are honorary Values; we don't mind
 289                                         -- copying them
 290 exprIsValue (Var v)       = isEvaldUnfolding (getIdUnfolding v)
 291 exprIsValue (Lam b e)     = isId b || exprIsValue e
 292 exprIsValue (Note _ e)    = exprIsValue e
 293 exprIsValue (Let _ e)     = False
 294 exprIsValue (Case _ _ _)  = False
 295 exprIsValue (Con con _)   = isWHNFCon con
 296 exprIsValue e@(App _ _)   = case collectArgs e of
 297                                   (Var v, args) -> fun_arity > valArgCount args
 298                                                 where
 299                                                    fun_arity  = arityLowerBound (getIdArity v)
 300                                   _             -> False
 301 \end{code}
 302
 303 \begin{code}
 304 exprArity :: CoreExpr -> Int    -- How many value lambdas are at the top
 305 exprArity (Lam b e) | isTyVar b = exprArity e
 306                     | otherwise = 1 + exprArity e
 307 exprArity other                 = 0
 308 \end{code}
 309
 310
 311 %************************************************************************
 312 %*                                                                      *
 313 \subsection{Equality}
 314 %*                                                                      *
 315 %************************************************************************
 316
 317 @cheapEqExpr@ is a cheap equality test which bales out fast!
 318         True  => definitely equal
 319         False => may or may not be equal
 320
 321 \begin{code}
 322 cheapEqExpr :: Expr b -> Expr b -> Bool
 323
 324 cheapEqExpr (Var v1) (Var v2) = v1==v2
 325 cheapEqExpr (Con con1 args1) (Con con2 args2)
 326   = con1 == con2 &&
 327     and (zipWithEqual "cheapEqExpr" cheapEqExpr args1 args2)
 328
 329 cheapEqExpr (App f1 a1) (App f2 a2)
 330   = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
 331
 332 cheapEqExpr (Type t1) (Type t2) = t1 == t2
 333
 334 cheapEqExpr _ _ = False
 335
 336 exprIsBig :: Expr b -> Bool
 337 -- Returns True of expressions that are too big to be compared by cheapEqExpr
 338 exprIsBig (Var v)      = False
 339 exprIsBig (Type t)     = False
 340 exprIsBig (App f a)    = exprIsBig f || exprIsBig a
 341 exprIsBig (Con _ args) = any exprIsBig args
 342 exprIsBig other        = True
 343 \end{code}
 344
 345
 346 \begin{code}
 347 eqExpr :: CoreExpr -> CoreExpr -> Bool
 348         -- Works ok at more general type, but only needed at CoreExpr
 349 eqExpr e1 e2
 350   = eq emptyVarEnv e1 e2
 351   where
 352   -- The "env" maps variables in e1 to variables in ty2
 353   -- So when comparing lambdas etc,
 354   -- we in effect substitute v2 for v1 in e1 before continuing
 355     eq env (Var v1) (Var v2) = case lookupVarEnv env v1 of
 356                                   Just v1' -> v1' == v2
 357                                   Nothing  -> v1  == v2
 358
 359     eq env (Con c1 es1) (Con c2 es2) = c1 == c2 && eq_list env es1 es2
 360     eq env (App f1 a1)  (App f2 a2)  = eq env f1 f2 && eq env a1 a2
 361     eq env (Lam v1 e1)  (Lam v2 e2)  = eq (extendVarEnv env v1 v2) e1 e2
 362     eq env (Let (NonRec v1 r1) e1)
 363            (Let (NonRec v2 r2) e2)   = eq env r1 r2 && eq (extendVarEnv env v1 v2) e1 e2
 364     eq env (Let (Rec ps1) e1)
 365            (Let (Rec ps2) e2)        = length ps1 == length ps2 &&
 366                                        and (zipWith eq_rhs ps1 ps2) &&
 367                                        eq env' e1 e2
 368                                      where
 369                                        env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2]
 370                                        eq_rhs (_,r1) (_,r2) = eq env' r1 r2
 371     eq env (Case e1 v1 a1)
 372            (Case e2 v2 a2)           = eq env e1 e2 &&
 373                                        length a1 == length a2 &&
 374                                        and (zipWith (eq_alt env') a1 a2)
 375                                      where
 376                                        env' = extendVarEnv env v1 v2
 377
 378     eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2
 379     eq env (Type t1)    (Type t2)    = t1 == t2
 380     eq env e1           e2           = False
 381
 382     eq_list env []       []       = True
 383     eq_list env (e1:es1) (e2:es2) = eq env e1 e2 && eq_list env es1 es2
 384     eq_list env es1      es2      = False
 385
 386     eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 &&
 387                                          eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2
 388
 389     eq_note env (SCC cc1)      (SCC cc2)      = cc1 == cc2
 390     eq_note env (Coerce f1 t1) (Coerce f2 t2) = f1==f2 && t1==t2
 391     eq_note env InlineCall     InlineCall     = True
 392     eq_note env other1         other2         = False
 393 \end{code}
 394
 395 %************************************************************************
 396 %*                                                                      *
 397 \subsection{Hashing}
 398 %*                                                                      *
 399 %************************************************************************
 400
 401 \begin{code}
 402 hashExpr :: CoreExpr -> Int
 403 hashExpr (Note _ e)              = hashExpr e
 404 hashExpr (Let (NonRec b r) e)    = hashId b
 405 hashExpr (Let (Rec ((b,r):_)) e) = hashId b
 406 hashExpr (Case _ b _)            = hashId b
 407 hashExpr (App f e)               = hashExpr f
 408 hashExpr (Var v)                 = hashId v
 409 hashExpr (Con con args)          = hashArgs args (hashCon con)
 410 hashExpr (Lam b _)               = hashId b
 411 hashExpr (Type t)                = trace "hashExpr: type" 0             -- Shouldn't happen
 412
 413 hashArgs []              con = con
 414 hashArgs (Type t : args) con = hashArgs args con
 415 hashArgs (arg    : args) con = hashExpr arg
 416
 417 hashId :: Id -> Int
 418 hashId id = hashName (idName id)
 419 \end{code}