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