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,
  11         exprIsValue,
  12         exprOkForSpeculation, exprIsBig, hashExpr,
  13         exprArity, exprEtaExpandArity,
  14         cheapEqExpr, eqExpr, applyTypeToArgs
  15     ) where
  16
  17 #include "HsVersions.h"
  18
  19
  20 import {-# SOURCE #-} CoreUnfold        ( isEvaldUnfolding )
  21
  22 import GlaExts          -- For `xori`
  23
  24 import CoreSyn
  25 import PprCore          ( pprCoreExpr )
  26 import Var              ( IdOrTyVar, isId, isTyVar )
  27 import VarSet
  28 import VarEnv
  29 import Name             ( isLocallyDefined, hashName )
  30 import Const            ( Con(..), isWHNFCon, conIsTrivial, conIsCheap, conIsDupable,
  31                           conType, hashCon
  32                         )
  33 import PrimOp           ( primOpOkForSpeculation, primOpStrictness )
  34 import Id               ( Id, idType, setIdType, idUnique, idAppIsBottom,
  35                           getIdArity, idName, isPrimitiveId_maybe,
  36                           getIdSpecialisation, setIdSpecialisation,
  37                           getInlinePragma, setInlinePragma,
  38                           getIdUnfolding, setIdUnfolding, idInfo
  39                         )
  40 import IdInfo           ( arityLowerBound, InlinePragInfo(..), lbvarInfo, LBVarInfo(..) )
  41 import Type             ( Type, mkFunTy, mkForAllTy,
  42                           splitFunTy_maybe, tyVarsOfType, tyVarsOfTypes,
  43                           isNotUsgTy, mkUsgTy, unUsgTy, UsageAnn(..),
  44                           tidyTyVar, applyTys, isUnLiftedType
  45                         )
  46 import Demand           ( isPrim, isLazy )
  47 import Unique           ( buildIdKey, augmentIdKey )
  48 import Util             ( zipWithEqual, mapAccumL )
  49 import Outputable
  50 import TysPrim          ( alphaTy )     -- Debugging only
  51 \end{code}
  52
  53
  54 %************************************************************************
  55 %*                                                                      *
  56 \subsection{Find the type of a Core atom/expression}
  57 %*                                                                      *
  58 %************************************************************************
  59
  60 \begin{code}
  61 coreExprType :: CoreExpr -> Type
  62
  63 coreExprType (Var var)              = idType var
  64 coreExprType (Let _ body)           = coreExprType body
  65 coreExprType (Case _ _ alts)        = coreAltsType alts
  66 coreExprType (Note (Coerce ty _) e) = ty  -- **! should take usage from e
  67 coreExprType (Note (TermUsg u) e)   = mkUsgTy u (unUsgTy (coreExprType e))
  68 coreExprType (Note other_note e)    = coreExprType e
  69 coreExprType e@(Con con args)       = ASSERT2( all (\ a -> case a of { Type ty -> isNotUsgTy ty; _ -> True }) args, ppr e)
  70                                                                                                                                          applyTypeToArgs e (conType con) args
  71
  72 coreExprType (Lam binder expr)
  73   | isId binder    = (case (lbvarInfo . idInfo) binder of
  74                        IsOneShotLambda -> mkUsgTy UsOnce
  75                        otherwise       -> id) $
  76                      idType binder `mkFunTy` coreExprType expr
  77   | isTyVar binder = mkForAllTy binder (coreExprType expr)
  78
  79 coreExprType e@(App _ _)
  80   = case collectArgs e of
  81         (fun, args) -> applyTypeToArgs e (coreExprType fun) args
  82
  83 coreExprType other = pprTrace "coreExprType" (pprCoreExpr other) alphaTy
  84
  85 coreAltsType :: [CoreAlt] -> Type
  86 coreAltsType ((_,_,rhs) : _) = coreExprType rhs
  87 \end{code}
  88
  89 \begin{code}
  90 -- The first argument is just for debugging
  91 applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
  92 applyTypeToArgs e op_ty [] = op_ty
  93
  94 applyTypeToArgs e op_ty (Type ty : args)
  95   =     -- Accumulate type arguments so we can instantiate all at once
  96     ASSERT2( all isNotUsgTy tys, ppr e <+> text "of" <+> ppr op_ty <+> text "to" <+> ppr (Type ty : args) <+> text "i.e." <+> ppr tys )
  97     applyTypeToArgs e (applyTys op_ty tys) rest_args
  98   where
  99     (tys, rest_args)        = go [ty] args
 100     go tys (Type ty : args) = go (ty:tys) args
 101     go tys rest_args        = (reverse tys, rest_args)
 102
 103 applyTypeToArgs e op_ty (other_arg : args)
 104   = case (splitFunTy_maybe op_ty) of
 105         Just (_, res_ty) -> applyTypeToArgs e res_ty args
 106         Nothing -> pprPanic "applyTypeToArgs" (pprCoreExpr e)
 107 \end{code}
 108
 109 %************************************************************************
 110 %*                                                                      *
 111 \subsection{Figuring out things about expressions}
 112 %*                                                                      *
 113 %************************************************************************
 114
 115 @exprIsTrivial@ is true of expressions we are unconditionally
 116                 happy to duplicate; simple variables and constants,
 117                 and type applications.
 118
 119 @exprIsBottom@  is true of expressions that are guaranteed to diverge
 120
 121
 122 \begin{code}
 123 exprIsTrivial (Type _)       = True
 124 exprIsTrivial (Var v)        = True
 125 exprIsTrivial (App e arg)    = isTypeArg arg && exprIsTrivial e
 126 exprIsTrivial (Note _ e)     = exprIsTrivial e
 127 exprIsTrivial (Con con args) = conIsTrivial con && all isTypeArg args
 128 exprIsTrivial (Lam b body)   | isTyVar b = exprIsTrivial body
 129 exprIsTrivial other          = False
 130 \end{code}
 131
 132
 133 @exprIsDupable@ is true of expressions that can be duplicated at a modest
 134                 cost in code size.  This will only happen in different case
 135                 branches, so there's no issue about duplicating work.
 136
 137                 That is, exprIsDupable returns True of (f x) even if
 138                 f is very very expensive to call.
 139
 140                 Its only purpose is to avoid fruitless let-binding
 141                 and then inlining of case join points
 142
 143
 144 \begin{code}
 145 exprIsDupable (Type _)       = True
 146 exprIsDupable (Con con args) = conIsDupable con &&
 147                                all exprIsDupable args &&
 148                                valArgCount args <= dupAppSize
 149
 150 exprIsDupable (Note _ e)     = exprIsDupable e
 151 exprIsDupable expr           = case collectArgs expr of
 152                                   (Var f, args) ->  all exprIsDupable args && valArgCount args <= dupAppSize
 153                                   other         ->  False
 154
 155 dupAppSize :: Int
 156 dupAppSize = 4          -- Size of application we are prepared to duplicate
 157 \end{code}
 158
 159 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
 160 it is obviously in weak head normal form, or is cheap to get to WHNF.
 161 [Note that that's not the same as exprIsDupable; an expression might be
 162 big, and hence not dupable, but still cheap.]
 163
 164 By ``cheap'' we mean a computation we're willing to:
 165         push inside a lambda, or
 166         inline at more than one place
 167 That might mean it gets evaluated more than once, instead of being
 168 shared.  The main examples of things which aren't WHNF but are
 169 ``cheap'' are:
 170
 171   *     case e of
 172           pi -> ei
 173
 174         where e, and all the ei are cheap; and
 175
 176   *     let x = e
 177         in b
 178
 179         where e and b are cheap; and
 180
 181   *     op x1 ... xn
 182
 183         where op is a cheap primitive operator
 184
 185   *     error "foo"
 186
 187 Notice that a variable is considered 'cheap': we can push it inside a lambda,
 188 because sharing will make sure it is only evaluated once.
 189
 190 \begin{code}
 191 exprIsCheap :: CoreExpr -> Bool
 192 exprIsCheap (Type _)            = True
 193 exprIsCheap (Var _)             = True
 194 exprIsCheap (Con con args)      = conIsCheap con && all exprIsCheap args
 195 exprIsCheap (Note _ e)          = exprIsCheap e
 196 exprIsCheap (Lam x e)           = if isId x then True else exprIsCheap e
 197 exprIsCheap other_expr   -- look for manifest partial application
 198   = case collectArgs other_expr of
 199         (f, args) -> isPap f (valArgCount args) && all exprIsCheap args
 200 \end{code}
 201
 202 \begin{code}
 203 isPap :: CoreExpr               -- Function
 204       -> Int                    -- Number of value args
 205       -> Bool
 206 isPap (Var f) n_val_args
 207   =    idAppIsBottom f n_val_args
 208                                 -- Application of a function which
 209                                 -- always gives bottom; we treat this as
 210                                 -- a WHNF, because it certainly doesn't
 211                                 -- need to be shared!
 212
 213     || n_val_args == 0          -- Just a type application of
 214                                 -- a variable (f t1 t2 t3)
 215                                 -- counts as WHNF
 216
 217     || n_val_args < arityLowerBound (getIdArity f)
 218
 219 isPap fun n_val_args = False
 220 \end{code}
 221
 222 exprOkForSpeculation returns True of an expression that it is
 223
 224         * safe to evaluate even if normal order eval might not
 225           evaluate the expression at all, or
 226
 227         * safe *not* to evaluate even if normal order would do so
 228
 229 It returns True iff
 230
 231         the expression guarantees to terminate,
 232         soon,
 233         without raising an exception,
 234         without causing a side effect (e.g. writing a mutable variable)
 235
 236 E.G.
 237         let x = case y# +# 1# of { r# -> I# r# }
 238         in E
 239 ==>
 240         case y# +# 1# of { r# ->
 241         let x = I# r#
 242         in E
 243         }
 244
 245 We can only do this if the (y+1) is ok for speculation: it has no
 246 side effects, and can't diverge or raise an exception.
 247
 248 \begin{code}
 249 exprOkForSpeculation :: CoreExpr -> Bool
 250 exprOkForSpeculation (Var v)              = isUnLiftedType (idType v)
 251 exprOkForSpeculation (Note _ e)           = exprOkForSpeculation e
 252
 253 exprOkForSpeculation (Con (Literal _) args) = True
 254 exprOkForSpeculation (Con (DataCon _) args) = True
 255         -- The strictness of the constructor has already
 256         -- been expressed by its "wrapper", so we don't need
 257         -- to take the arguments into account
 258
 259 exprOkForSpeculation (Con (PrimOp op) args)
 260   = prim_op_ok_for_spec op args
 261
 262 exprOkForSpeculation (App fun arg)      -- Might be application of a primop
 263   = go fun [arg]
 264   where
 265     go (App fun arg) args = go fun (arg:args)
 266     go (Var v)       args = case isPrimitiveId_maybe v of
 267                                 Just op -> prim_op_ok_for_spec op args
 268                                 Nothing -> False
 269     go other args = False
 270
 271 exprOkForSpeculation other = False      -- Conservative
 272
 273 prim_op_ok_for_spec op args
 274  = primOpOkForSpeculation op &&
 275    and (zipWith ok (filter isValArg args) (fst (primOpStrictness op)))
 276  where
 277    ok arg demand | isLazy demand = True
 278                   | otherwise     = exprOkForSpeculation arg
 279 \end{code}
 280
 281
 282 \begin{code}
 283 exprIsBottom :: CoreExpr -> Bool        -- True => definitely bottom
 284 exprIsBottom e = go 0 e
 285                where
 286                 -- n is the number of args
 287                  go n (Note _ e)   = go n e
 288                  go n (Let _ e)    = go n e
 289                  go n (Case e _ _) = go 0 e     -- Just check the scrut
 290                  go n (App e _)    = go (n+1) e
 291                  go n (Var v)      = idAppIsBottom v n
 292                  go n (Con _ _)    = False
 293                  go n (Lam _ _)    = False
 294 \end{code}
 295
 296 @exprIsValue@ returns true for expressions that are certainly *already*
 297 evaluated to WHNF.  This is used to decide wether it's ok to change
 298         case x of _ -> e   ===>   e
 299
 300 and to decide whether it's safe to discard a `seq`
 301
 302 So, it does *not* treat variables as evaluated, unless they say they are
 303
 304 \begin{code}
 305 exprIsValue :: CoreExpr -> Bool         -- True => Value-lambda, constructor, PAP
 306 exprIsValue (Type ty)     = True        -- Types are honorary Values; we don't mind
 307                                         -- copying them
 308 exprIsValue (Var v)       = isEvaldUnfolding (getIdUnfolding v)
 309 exprIsValue (Lam b e)     = isId b || exprIsValue e
 310 exprIsValue (Note _ e)    = exprIsValue e
 311 exprIsValue (Let _ e)     = False
 312 exprIsValue (Case _ _ _)  = False
 313 exprIsValue (Con con _)   = isWHNFCon con
 314 exprIsValue e@(App _ _)   = case collectArgs e of
 315                                   (Var v, args) -> fun_arity > valArgCount args
 316                                                 where
 317                                                    fun_arity  = arityLowerBound (getIdArity v)
 318                                   _             -> False
 319 \end{code}
 320
 321 \begin{code}
 322 exprArity :: CoreExpr -> Int    -- How many value lambdas are at the top
 323 exprArity (Lam b e)     | isTyVar b     = exprArity e
 324                         | otherwise     = 1 + exprArity e
 325
 326 exprArity (Note note e) | ok_note note  = exprArity e
 327                         where
 328                           ok_note (Coerce _ _) = True
 329                                 -- We *do* look through coerces when getting arities.
 330                                 -- Reason: arities are to do with *representation* and
 331                                 -- work duplication.
 332                           ok_note InlineMe     = True
 333                           ok_note InlineCall   = True
 334                           ok_note other        = False
 335                                 -- SCC and TermUsg might be over-conservative?
 336
 337 exprArity other = 0
 338 \end{code}
 339
 340
 341 \begin{code}
 342 exprEtaExpandArity :: CoreExpr -> Int   -- The number of args the thing can be applied to
 343                                         -- without doing much work
 344 -- This is used when eta expanding
 345 --      e  ==>  \xy -> e x y
 346 --
 347 -- It returns 1 (or more) to:
 348 --      case x of p -> \s -> ...
 349 -- because for I/O ish things we really want to get that \s to the top.
 350 -- We are prepared to evaluate x each time round the loop in order to get that
 351 -- Hence "generous" arity
 352
 353 exprEtaExpandArity (Var v)              = arityLowerBound (getIdArity v)
 354 exprEtaExpandArity (Lam x e)
 355   | isId x                              = 1 + exprEtaExpandArity e
 356   | otherwise                           = exprEtaExpandArity e
 357 exprEtaExpandArity (Let bind body)
 358   | all exprIsCheap (rhssOfBind bind)   = exprEtaExpandArity body
 359 exprEtaExpandArity (Case scrut _ alts)
 360   | exprIsCheap scrut                   = min_zero [exprEtaExpandArity rhs | (_,_,rhs) <- alts]
 361
 362 exprEtaExpandArity (Note note e)
 363   | ok_note note                        = exprEtaExpandArity e
 364   where
 365     ok_note (Coerce _ _) = True
 366     ok_note InlineCall   = True
 367     ok_note other        = False
 368         -- Notice that we do not look through __inline_me__
 369         -- This one is a bit more surprising, but consider
 370         --      f = _inline_me (\x -> e)
 371         -- We DO NOT want to eta expand this to
 372         --      f = \x -> (_inline_me (\x -> e)) x
 373         -- because the _inline_me gets dropped now it is applied,
 374         -- giving just
 375         --      f = \x -> e
 376         -- A Bad Idea
 377
 378 exprEtaExpandArity other                = 0     -- Could do better for applications
 379
 380 min_zero :: [Int] -> Int        -- Find the minimum, but zero is the smallest
 381 min_zero (x:xs) = go x xs
 382                 where
 383                   go 0   xs                 = 0         -- Nothing beats zero
 384                   go min []                 = min
 385                   go min (x:xs) | x < min   = go x xs
 386                                 | otherwise = go min xs
 387
 388 \end{code}
 389
 390
 391 %************************************************************************
 392 %*                                                                      *
 393 \subsection{Equality}
 394 %*                                                                      *
 395 %************************************************************************
 396
 397 @cheapEqExpr@ is a cheap equality test which bales out fast!
 398         True  => definitely equal
 399         False => may or may not be equal
 400
 401 \begin{code}
 402 cheapEqExpr :: Expr b -> Expr b -> Bool
 403
 404 cheapEqExpr (Var v1) (Var v2) = v1==v2
 405 cheapEqExpr (Con con1 args1) (Con con2 args2)
 406   = con1 == con2 &&
 407     and (zipWithEqual "cheapEqExpr" cheapEqExpr args1 args2)
 408
 409 cheapEqExpr (App f1 a1) (App f2 a2)
 410   = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
 411
 412 cheapEqExpr (Type t1) (Type t2) = t1 == t2
 413
 414 cheapEqExpr _ _ = False
 415
 416 exprIsBig :: Expr b -> Bool
 417 -- Returns True of expressions that are too big to be compared by cheapEqExpr
 418 exprIsBig (Var v)      = False
 419 exprIsBig (Type t)     = False
 420 exprIsBig (App f a)    = exprIsBig f || exprIsBig a
 421 exprIsBig (Con _ args) = any exprIsBig args
 422 exprIsBig other        = True
 423 \end{code}
 424
 425
 426 \begin{code}
 427 eqExpr :: CoreExpr -> CoreExpr -> Bool
 428         -- Works ok at more general type, but only needed at CoreExpr
 429 eqExpr e1 e2
 430   = eq emptyVarEnv e1 e2
 431   where
 432   -- The "env" maps variables in e1 to variables in ty2
 433   -- So when comparing lambdas etc,
 434   -- we in effect substitute v2 for v1 in e1 before continuing
 435     eq env (Var v1) (Var v2) = case lookupVarEnv env v1 of
 436                                   Just v1' -> v1' == v2
 437                                   Nothing  -> v1  == v2
 438
 439     eq env (Con c1 es1) (Con c2 es2) = c1 == c2 && eq_list env es1 es2
 440     eq env (App f1 a1)  (App f2 a2)  = eq env f1 f2 && eq env a1 a2
 441     eq env (Lam v1 e1)  (Lam v2 e2)  = eq (extendVarEnv env v1 v2) e1 e2
 442     eq env (Let (NonRec v1 r1) e1)
 443            (Let (NonRec v2 r2) e2)   = eq env r1 r2 && eq (extendVarEnv env v1 v2) e1 e2
 444     eq env (Let (Rec ps1) e1)
 445            (Let (Rec ps2) e2)        = length ps1 == length ps2 &&
 446                                        and (zipWith eq_rhs ps1 ps2) &&
 447                                        eq env' e1 e2
 448                                      where
 449                                        env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2]
 450                                        eq_rhs (_,r1) (_,r2) = eq env' r1 r2
 451     eq env (Case e1 v1 a1)
 452            (Case e2 v2 a2)           = eq env e1 e2 &&
 453                                        length a1 == length a2 &&
 454                                        and (zipWith (eq_alt env') a1 a2)
 455                                      where
 456                                        env' = extendVarEnv env v1 v2
 457
 458     eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2
 459     eq env (Type t1)    (Type t2)    = t1 == t2
 460     eq env e1           e2           = False
 461
 462     eq_list env []       []       = True
 463     eq_list env (e1:es1) (e2:es2) = eq env e1 e2 && eq_list env es1 es2
 464     eq_list env es1      es2      = False
 465
 466     eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 &&
 467                                          eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2
 468
 469     eq_note env (SCC cc1)      (SCC cc2)      = cc1 == cc2
 470     eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1==t2 && f1==f2
 471     eq_note env InlineCall     InlineCall     = True
 472     eq_note env other1         other2         = False
 473 \end{code}
 474
 475 %************************************************************************
 476 %*                                                                      *
 477 \subsection{Hashing}
 478 %*                                                                      *
 479 %************************************************************************
 480
 481 \begin{code}
 482 hashExpr :: CoreExpr -> Int
 483 hashExpr e = abs (hash_expr e)
 484         -- Negative numbers kill UniqFM
 485
 486 hash_expr (Note _ e)              = hash_expr e
 487 hash_expr (Let (NonRec b r) e)    = hashId b
 488 hash_expr (Let (Rec ((b,r):_)) e) = hashId b
 489 hash_expr (Case _ b _)            = hashId b
 490 hash_expr (App f e)               = hash_expr f + fast_hash_expr e
 491 hash_expr (Var v)                 = hashId v
 492 hash_expr (Con con args)          = foldr ((+) . fast_hash_expr) (hashCon con) args
 493 hash_expr (Lam b _)               = hashId b
 494 hash_expr (Type t)                = trace "hash_expr: type" 0           -- Shouldn't happen
 495
 496 fast_hash_expr (Var v)          = hashId v
 497 fast_hash_expr (Con con args)   = fast_hash_args args con
 498 fast_hash_expr (App f (Type _)) = fast_hash_expr f
 499 fast_hash_expr (App f a)        = fast_hash_expr a
 500 fast_hash_expr (Lam b _)        = hashId b
 501 fast_hash_expr other            = 0
 502
 503 fast_hash_args []              con = hashCon con
 504 fast_hash_args (Type t : args) con = fast_hash_args args con
 505 fast_hash_args (arg    : args) con = fast_hash_expr arg
 506
 507 hashId :: Id -> Int
 508 hashId id = hashName (idName id)
 509 \end{code}