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