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, exprIsValue,
  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         -- Used exclusively by CoreUnfold.mkUnfolding
 137         -- Returns ValueForm for cheap things, not just values
 138 mkFormSummary expr
 139   = go (0::Int) expr    -- The "n" is the number of *value* arguments so far
 140   where
 141     go n (Con con _) | isWHNFCon con = ValueForm
 142                      | otherwise     = OtherForm
 143
 144     go n (Note _ e)         = go n e
 145
 146     go n (Let (NonRec b r) e) | exprIsCheap r = go n e  -- let f = f' alpha in (f,g)
 147                                                         -- should be treated as a value
 148     go n (Let _            e)                 = OtherForm
 149
 150         -- We want selectors to look like values
 151         -- e.g.  case x of { (a,b) -> a }
 152         -- should give a ValueForm, so that it will be inlined
 153         -- vigorously
 154     go n expr@(Case _ _ _) | exprIsCheap expr = ValueForm
 155                            | otherwise        = OtherForm
 156
 157     go 0 (Lam x e) | isId x    = ValueForm      -- NB: \x.bottom /= bottom!
 158                    | otherwise = go 0 e
 159     go n (Lam x e) | isId x    = go (n-1) e     -- Applied lambda
 160                    | otherwise = go n e
 161
 162     go n (App fun (Type _)) = go n fun          -- Ignore type args
 163     go n (App fun arg)      = go (n+1) fun
 164
 165     go n (Var f) | idAppIsBottom f n = BottomForm
 166     go 0 (Var f)                     = VarForm
 167     go n (Var f) | n < arityLowerBound (getIdArity f) = ValueForm
 168                  | otherwise                          = OtherForm
 169 \end{code}
 170
 171 @exprIsTrivial@ is true of expressions we are unconditionally
 172                 happy to duplicate; simple variables and constants,
 173                 and type applications.
 174
 175 @exprIsBottom@  is true of expressions that are guaranteed to diverge
 176
 177
 178 \begin{code}
 179 exprIsTrivial (Type _)       = True
 180 exprIsTrivial (Var v)        = True
 181 exprIsTrivial (App e arg)    = isTypeArg arg && exprIsTrivial e
 182 exprIsTrivial (Note _ e)     = exprIsTrivial e
 183 exprIsTrivial (Con con args) = conIsTrivial con && all isTypeArg args
 184 exprIsTrivial (Lam b body)   | isTyVar b = exprIsTrivial body
 185 exprIsTrivial other          = False
 186 \end{code}
 187
 188
 189 @exprIsDupable@ is true of expressions that can be duplicated at a modest
 190                 cost in space.  This will only happen in different case
 191                 branches, so there's no issue about duplicating work.
 192                 Its only purpose is to avoid fruitless let-binding
 193                 and then inlining of case join points
 194
 195
 196 \begin{code}
 197 exprIsDupable (Type _)       = True
 198 exprIsDupable (Con con args) = conIsDupable con &&
 199                                all exprIsDupable args &&
 200                                valArgCount args <= dupAppSize
 201
 202 exprIsDupable (Note _ e)     = exprIsDupable e
 203 exprIsDupable expr           = case collectArgs expr of
 204                                   (Var f, args) ->  valArgCount args <= dupAppSize
 205                                   other         ->  False
 206
 207 dupAppSize :: Int
 208 dupAppSize = 4          -- Size of application we are prepared to duplicate
 209 \end{code}
 210
 211 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
 212 it is obviously in weak head normal form, or is cheap to get to WHNF.
 213 [Note that that's not the same as exprIsDupable; an expression might be
 214 big, and hence not dupable, but still cheap.]
 215 By ``cheap'' we mean a computation we're willing to push inside a lambda
 216 in order to bring a couple of lambdas together.  That might mean it gets
 217 evaluated more than once, instead of being shared.  The main examples of things
 218 which aren't WHNF but are ``cheap'' are:
 219
 220   *     case e of
 221           pi -> ei
 222
 223         where e, and all the ei are cheap; and
 224
 225   *     let x = e
 226         in b
 227
 228         where e and b are cheap; and
 229
 230   *     op x1 ... xn
 231
 232         where op is a cheap primitive operator
 233
 234 Notice that a variable is considered 'cheap': we can push it inside a lambda,
 235 because sharing will make sure it is only evaluated once.
 236
 237 \begin{code}
 238 exprIsCheap :: CoreExpr -> Bool
 239 exprIsCheap (Type _)            = True
 240 exprIsCheap (Var _)             = True
 241 exprIsCheap (Con con args)      = conIsCheap con && all exprIsCheap args
 242 exprIsCheap (Note _ e)          = exprIsCheap e
 243 exprIsCheap (Lam x e)           = if isId x then True else exprIsCheap e
 244 exprIsCheap (Let bind body)     = all exprIsCheap (rhssOfBind bind) && exprIsCheap body
 245 exprIsCheap (Case scrut _ alts) = exprIsCheap scrut &&
 246                                   all (\(_,_,rhs) -> exprIsCheap rhs) alts
 247
 248 exprIsCheap other_expr   -- look for manifest partial application
 249   = case collectArgs other_expr of
 250         (f, args) -> isPap f (valArgCount args) && all exprIsCheap args
 251 \end{code}
 252
 253 \begin{code}
 254 isPap :: CoreExpr               -- Function
 255       -> Int                    -- Number of value args
 256       -> Bool
 257 isPap (Var f) n_val_args
 258   =    idAppIsBottom f n_val_args
 259                                 -- Application of a function which
 260                                 -- always gives bottom; we treat this as
 261                                 -- a WHNF, because it certainly doesn't
 262                                 -- need to be shared!
 263
 264     || n_val_args == 0          -- Just a type application of
 265                                 -- a variable (f t1 t2 t3)
 266                                 -- counts as WHNF
 267
 268     || n_val_args < arityLowerBound (getIdArity f)
 269
 270 isPap fun n_val_args = False
 271 \end{code}
 272
 273 exprOkForSpeculation returns True of an UNLIFTED-TYPE expression that it is safe
 274 to evaluate even if normal order eval might not evaluate the expression
 275 at all.  E.G.
 276         let x = case y# +# 1# of { r# -> I# r# }
 277         in E
 278 ==>
 279         case y# +# 1# of { r# ->
 280         let x = I# r#
 281         in E
 282         }
 283
 284 We can only do this if the (y+1) is ok for speculation: it has no
 285 side effects, and can't diverge or raise an exception.
 286
 287 \begin{code}
 288 exprOkForSpeculation :: CoreExpr -> Bool
 289 exprOkForSpeculation (Var v)        = True      -- Unlifted type => already evaluated
 290
 291 exprOkForSpeculation (Note _ e)           = exprOkForSpeculation e
 292 exprOkForSpeculation (Let (NonRec b r) e) = isUnLiftedType (idType b) &&
 293                                             exprOkForSpeculation r &&
 294                                             exprOkForSpeculation e
 295 exprOkForSpeculation (Let (Rec _) _) = False
 296 exprOkForSpeculation (Case _ _ _)    = False    -- Conservative
 297 exprOkForSpeculation (App _ _)       = False
 298
 299 exprOkForSpeculation (Con con args)
 300   = conOkForSpeculation con &&
 301     and (zipWith ok (filter isValArg args) (fst (conStrictness con)))
 302   where
 303     ok arg demand | isLazy demand = True
 304                   | isPrim demand = exprOkForSpeculation arg
 305                   | otherwise     = False
 306
 307 exprOkForSpeculation other = panic "exprOkForSpeculation"
 308         -- Lam, Type
 309 \end{code}
 310
 311
 312 \begin{code}
 313 exprIsBottom :: CoreExpr -> Bool        -- True => definitely bottom
 314 exprIsBottom e = go 0 e
 315                where
 316                 -- n is the number of args
 317                  go n (Note _ e)   = go n e
 318                  go n (Let _ e)    = go n e
 319                  go n (Case e _ _) = go 0 e     -- Just check the scrut
 320                  go n (App e _)    = go (n+1) e
 321                  go n (Var v)      = idAppIsBottom v n
 322                  go n (Con _ _)    = False
 323                  go n (Lam _ _)    = False
 324 \end{code}
 325
 326 @exprIsValue@ returns true for expressions that are evaluated.
 327 It does not treat variables as evaluated.
 328
 329 \begin{code}
 330 exprIsValue :: CoreExpr -> Bool         -- True => Value-lambda, constructor, PAP
 331 exprIsValue (Type ty)     = True        -- Types are honorary Values; we don't mind
 332                                         -- copying them
 333 exprIsValue (Var v)       = False
 334 exprIsValue (Lam b e)     = isId b || exprIsValue e
 335 exprIsValue (Note _ e)    = exprIsValue e
 336 exprIsValue (Let _ e)     = False
 337 exprIsValue (Case _ _ _)  = False
 338 exprIsValue (Con con _)   = isWHNFCon con
 339 exprIsValue e@(App _ _)   = case collectArgs e of
 340                                   (Var v, args) -> fun_arity > valArgCount args
 341                                                 where
 342                                                    fun_arity  = arityLowerBound (getIdArity v)
 343                                   _             -> False
 344 \end{code}
 345
 346 exprIsWHNF reports True for head normal forms.  Note that does not necessarily
 347 mean *normal* forms; constructors might have non-trivial argument expressions, for
 348 example.  We use a let binding for WHNFs, rather than a case binding, even if it's
 349 used strictly.  We try to expose WHNFs by floating lets out of the RHS of lets.
 350
 351         We treat applications of buildId and augmentId as honorary WHNFs,
 352         because we want them to get exposed.
 353         [May 99: I've disabled this because it looks jolly dangerous:
 354          we'll substitute inside lambda with potential big loss of sharing.]
 355
 356 \begin{code}
 357 exprIsWHNF :: CoreExpr -> Bool  -- True => Variable, value-lambda, constructor, PAP
 358 exprIsWHNF (Type ty)          = True    -- Types are honorary WHNFs; we don't mind
 359                                         -- copying them
 360 exprIsWHNF (Var v)            = True
 361 exprIsWHNF (Lam b e)          = isId b || exprIsWHNF e
 362 exprIsWHNF (Note _ e)         = exprIsWHNF e
 363 exprIsWHNF (Let _ e)          = False
 364 exprIsWHNF (Case _ _ _)       = False
 365 exprIsWHNF (Con con _)        = isWHNFCon con
 366 exprIsWHNF e@(App _ _)        = case collectArgs e of
 367                                   (Var v, args) -> n_val_args == 0
 368                                                 || fun_arity > n_val_args
 369 --  [May 99: disabled. See note above]          || v_uniq == buildIdKey
 370 --                                              || v_uniq == augmentIdKey
 371                                                 where
 372                                                    n_val_args = valArgCount args
 373                                                    fun_arity  = arityLowerBound (getIdArity v)
 374                                                    v_uniq     = idUnique v
 375
 376                                   _             -> False
 377 \end{code}
 378
 379 \begin{code}
 380 exprArity :: CoreExpr -> Int    -- How many value lambdas are at the top
 381 exprArity (Lam b e) | isTyVar b = exprArity e
 382                     | otherwise = 1 + exprArity e
 383 exprArity other                 = 0
 384 \end{code}
 385
 386
 387 %************************************************************************
 388 %*                                                                      *
 389 \subsection{Equality}
 390 %*                                                                      *
 391 %************************************************************************
 392
 393 @cheapEqExpr@ is a cheap equality test which bales out fast!
 394         True  => definitely equal
 395         False => may or may not be equal
 396
 397 \begin{code}
 398 cheapEqExpr :: Expr b -> Expr b -> Bool
 399
 400 cheapEqExpr (Var v1) (Var v2) = v1==v2
 401 cheapEqExpr (Con con1 args1) (Con con2 args2)
 402   = con1 == con2 &&
 403     and (zipWithEqual "cheapEqExpr" cheapEqExpr args1 args2)
 404
 405 cheapEqExpr (App f1 a1) (App f2 a2)
 406   = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
 407
 408 cheapEqExpr (Type t1) (Type t2) = t1 == t2
 409
 410 cheapEqExpr _ _ = False
 411 \end{code}
 412
 413
 414 \begin{code}
 415 eqExpr :: CoreExpr -> CoreExpr -> Bool
 416         -- Works ok at more general type, but only needed at CoreExpr
 417 eqExpr e1 e2
 418   = eq emptyVarEnv e1 e2
 419   where
 420   -- The "env" maps variables in e1 to variables in ty2
 421   -- So when comparing lambdas etc,
 422   -- we in effect substitute v2 for v1 in e1 before continuing
 423     eq env (Var v1) (Var v2) = case lookupVarEnv env v1 of
 424                                   Just v1' -> v1' == v2
 425                                   Nothing  -> v1  == v2
 426
 427     eq env (Con c1 es1) (Con c2 es2) = c1 == c2 && eq_list env es1 es2
 428     eq env (App f1 a1)  (App f2 a2)  = eq env f1 f2 && eq env a1 a2
 429     eq env (Lam v1 e1)  (Lam v2 e2)  = eq (extendVarEnv env v1 v2) e1 e2
 430     eq env (Let (NonRec v1 r1) e1)
 431            (Let (NonRec v2 r2) e2)   = eq env r1 r2 && eq (extendVarEnv env v1 v2) e1 e2
 432     eq env (Let (Rec ps1) e1)
 433            (Let (Rec ps2) e2)        = length ps1 == length ps2 &&
 434                                        and (zipWith eq_rhs ps1 ps2) &&
 435                                        eq env' e1 e2
 436                                      where
 437                                        env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2]
 438                                        eq_rhs (_,r1) (_,r2) = eq env' r1 r2
 439     eq env (Case e1 v1 a1)
 440            (Case e2 v2 a2)           = eq env e1 e2 &&
 441                                        length a1 == length a2 &&
 442                                        and (zipWith (eq_alt env') a1 a2)
 443                                      where
 444                                        env' = extendVarEnv env v1 v2
 445
 446     eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2
 447     eq env (Type t1)    (Type t2)    = t1 == t2
 448     eq env e1           e2           = False
 449
 450     eq_list env []       []       = True
 451     eq_list env (e1:es1) (e2:es2) = eq env e1 e2 && eq_list env es1 es2
 452     eq_list env es1      es2      = False
 453
 454     eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 &&
 455                                          eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2
 456
 457     eq_note env (SCC cc1)      (SCC cc2)      = cc1 == cc2
 458     eq_note env (Coerce f1 t1) (Coerce f2 t2) = f1==f2 && t1==t2
 459     eq_note env InlineCall     InlineCall     = True
 460     eq_note env other1         other2         = False
 461 \end{code}
 462