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