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