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