CoreUtils.lhs 63.7 KB
 partain committed Mar 19, 1996 1 %  Simon Marlow committed Oct 11, 2006 2 % (c) The University of Glasgow 2006  simonm committed Dec 02, 1998 3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998  partain committed Mar 19, 1996 4 %  Simon Marlow committed Oct 11, 2006 5 6  Utility functions on @Core@ syntax  partain committed Mar 19, 1996 7 8  \begin{code}  batterseapower committed Jul 31, 2008 9 -- | Commonly useful utilites for manipulating the Core language  partain committed Mar 19, 1996 10 module CoreUtils (  Ian Lynagh committed Sep 27, 2011 11  -- * Constructing expressions  dimitris committed Nov 16, 2011 12 13  mkCast, mkTick, mkTickNoHNF,  Simon Marlow committed Nov 02, 2011 14  bindNonRec, needsCaseBinding,  dreixel committed Nov 16, 2011 15  mkAltExpr,  simonm committed Dec 02, 1998 16   Ian Lynagh committed Sep 27, 2011 17 18  -- * Taking expressions apart findDefault, findAlt, isDefaultAlt, mergeAlts, trimConArgs,  simonpj committed Feb 26, 2001 19   Ian Lynagh committed Sep 27, 2011 20  -- * Properties of expressions  Simon Marlow committed Nov 02, 2011 21  exprType, coreAltType, coreAltsType,  Simon Marlow committed Nov 02, 2011 22  exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsBottom,  simonpj@microsoft.com committed Dec 21, 2010 23  exprIsCheap, exprIsExpandable, exprIsCheap', CheapAppFun,  Ian Lynagh committed Sep 27, 2011 24 25  exprIsHNF, exprOkForSpeculation, exprIsBig, exprIsConLike, rhsIsStatic, isCheapApp, isExpandableApp,  simonpj committed Oct 18, 2001 26   Ian Lynagh committed Sep 27, 2011 27 28 29  -- * Expression and bindings size coreBindsSize, exprSize, CoreStats(..), coreBindsStats,  simonpj committed Mar 27, 2000 30   Ian Lynagh committed Sep 27, 2011 31 32  -- * Hashing hashExpr,  simonpj committed Mar 23, 2000 33   Ian Lynagh committed Sep 27, 2011 34 35  -- * Equality cheapEqExpr, eqExpr, eqExprX,  chak@cse.unsw.edu.au. committed Sep 20, 2006 36   Ian Lynagh committed Sep 27, 2011 37 38  -- * Eta reduction tryEtaReduce,  simonpj@microsoft.com committed Sep 13, 2010 39   Ian Lynagh committed Sep 27, 2011 40 41  -- * Manipulating data constructors and types applyTypeToArgs, applyTypeToArg,  42  dataConRepInstPat, dataConRepFSInstPat  simonpj committed Dec 19, 1996 43  ) where  partain committed Mar 19, 1996 44   simonm committed Jan 08, 1998 45 #include "HsVersions.h"  partain committed Mar 19, 1996 46   simonm committed Dec 02, 1998 47 import CoreSyn  Simon Marlow committed Oct 11, 2006 48 49 50 import PprCore import Var import SrcLoc  simonm committed Dec 02, 1998 51 import VarEnv  simonpj@microsoft.com committed Aug 13, 2009 52 import VarSet  Simon Marlow committed Oct 11, 2006 53 54 55 56 57 58 59 60 61 62 import Name import Literal import DataCon import PrimOp import Id import IdInfo import Type import Coercion import TyCon import Unique  simonm committed Dec 02, 1998 63 import Outputable  Simon Marlow committed Oct 11, 2006 64 65 import TysPrim import FastString  simonpj@microsoft.com committed Nov 24, 2006 66 import Maybes  Simon Marlow committed Oct 11, 2006 67 import Util  68 import Pair  Ian Lynagh committed Dec 03, 2006 69 70 import Data.Word import Data.Bits  dreixel committed Nov 11, 2011 71 import Data.List ( mapAccumL )  simonm committed Dec 02, 1998 72 \end{code}  partain committed Mar 19, 1996 73   simonm committed Dec 02, 1998 74   partain committed Mar 19, 1996 75 %************************************************************************  Ian Lynagh committed Sep 27, 2011 76 %* *  partain committed Mar 19, 1996 77 \subsection{Find the type of a Core atom/expression}  Ian Lynagh committed Sep 27, 2011 78 %* *  partain committed Mar 19, 1996 79 80 81 %************************************************************************ \begin{code}  simonpj committed Mar 23, 2000 82 exprType :: CoreExpr -> Type  batterseapower committed Jul 31, 2008 83 84 85 -- ^ Recover the type of a well-typed Core expression. Fails when -- applied to the actual 'CoreSyn.Type' expression as it cannot -- really be said to have a type  Ian Lynagh committed Sep 27, 2011 86 87 88 89 exprType (Var var) = idType var exprType (Lit lit) = literalType lit exprType (Coercion co) = coercionType co exprType (Let _ body) = exprType body  twanvl committed Jan 25, 2008 90 exprType (Case _ _ ty _) = ty  91 exprType (Cast _ co) = pSnd (coercionKind co)  Simon Marlow committed Nov 02, 2011 92 exprType (Tick _ e) = exprType e  simonpj@microsoft.com committed May 02, 2007 93 exprType (Lam binder expr) = mkPiType binder (exprType expr)  simonpj committed Mar 23, 2000 94 exprType e@(App _ _)  simonm committed Dec 02, 1998 95  = case collectArgs e of  Ian Lynagh committed Sep 27, 2011 96  (fun, args) -> applyTypeToArgs e (exprType fun) args  partain committed Mar 19, 1996 97   simonpj committed Mar 23, 2000 98 exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy  simonpj committed Dec 18, 1998 99   simonpj committed Sep 30, 2004 100 coreAltType :: CoreAlt -> Type  batterseapower committed Jul 31, 2008 101 -- ^ Returns the type of the alternatives right hand side  Ian Lynagh committed Sep 27, 2011 102 coreAltType (_,bs,rhs)  simonpj@microsoft.com committed Aug 13, 2009 103 104 105 106 107  | any bad_binder bs = expandTypeSynonyms ty | otherwise = ty -- Note [Existential variables and silly type synonyms] where ty = exprType rhs free_tvs = tyVarsOfType ty  108  bad_binder b = isTyVar b && b elemVarSet free_tvs  simonpj@microsoft.com committed Apr 22, 2008 109 110  coreAltsType :: [CoreAlt] -> Type  batterseapower committed Jul 31, 2008 111 -- ^ Returns the type of the first alternative, which should be the same as for all alternatives  simonpj@microsoft.com committed Apr 22, 2008 112 coreAltsType (alt:_) = coreAltType alt  Ian Lynagh committed Sep 27, 2011 113 coreAltsType [] = panic "corAltsType"  partain committed Mar 19, 1996 114 115 \end{code}  simonpj@microsoft.com committed Aug 13, 2009 116 117 118 Note [Existential variables and silly type synonyms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider  Ian Lynagh committed Sep 27, 2011 119 120 121 122  data T = forall a. T (Funny a) type Funny a = Bool f :: T -> Bool f (T x) = x  simonpj@microsoft.com committed Aug 13, 2009 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139  Now, the type of 'x' is (Funny a), where 'a' is existentially quantified. That means that 'exprType' and 'coreAltsType' may give a result that *appears* to mention an out-of-scope type variable. See Trac #3409 for a more real-world example. Various possibilities suggest themselves: - Ignore the problem, and make Lint not complain about such variables - Expand all type synonyms (or at least all those that discard arguments) This is tricky, because at least for top-level things we want to retain the type the user originally specified. - Expand synonyms on the fly, when the problem arises. That is what we are doing here. It's not too expensive, I think.  partain committed Mar 19, 1996 140 \begin{code}  simonpj committed Nov 01, 2001 141 applyTypeToArg :: Type -> CoreExpr -> Type  batterseapower committed Jul 31, 2008 142 -- ^ Determines the type resulting from applying an expression to a function with the given type  simonpj committed Nov 01, 2001 143 applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty  twanvl committed Jan 25, 2008 144 applyTypeToArg fun_ty _ = funResultTy fun_ty  simonpj committed Nov 01, 2001 145   simonpj committed May 18, 1999 146 applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type  batterseapower committed Jul 31, 2008 147 148 -- ^ A more efficient version of 'applyTypeToArg' when we have several arguments. -- The first argument is just for debugging, and gives some context  twanvl committed Jan 25, 2008 149 applyTypeToArgs _ op_ty [] = op_ty  partain committed Mar 19, 1996 150   simonm committed Dec 02, 1998 151 applyTypeToArgs e op_ty (Type ty : args)  Ian Lynagh committed Sep 27, 2011 152  = -- Accumulate type arguments so we can instantiate all at once  simonpj committed Nov 01, 2001 153  go [ty] args  simonpj committed Feb 10, 1998 154  where  simonpj committed Nov 01, 2001 155  go rev_tys (Type ty : args) = go (ty:rev_tys) args  156  go rev_tys rest_args = applyTypeToArgs e op_ty' rest_args  Ian Lynagh committed Sep 27, 2011 157 158 159 160  where op_ty' = applyTysD msg op_ty (reverse rev_tys) msg = ptext (sLit "applyTypeToArgs") <+> panic_msg e op_ty  simonpj committed Feb 10, 1998 161   twanvl committed Jan 25, 2008 162 applyTypeToArgs e op_ty (_ : args)  simonpj committed Feb 10, 1998 163  = case (splitFunTy_maybe op_ty) of  Ian Lynagh committed Sep 27, 2011 164 165  Just (_, res_ty) -> applyTypeToArgs e res_ty args Nothing -> pprPanic "applyTypeToArgs" (panic_msg e op_ty)  simonpj@microsoft.com committed Sep 05, 2008 166 167 168  panic_msg :: CoreExpr -> Type -> SDoc panic_msg e op_ty = pprCoreExpr e $$ppr op_ty  partain committed Mar 19, 1996 169 170 \end{code}  simonpj committed Mar 23, 2000 171 %************************************************************************  Ian Lynagh committed Sep 27, 2011 172 %* *  simonpj committed Mar 27, 2000 173 \subsection{Attaching notes}  Ian Lynagh committed Sep 27, 2011 174 %* *  simonpj committed Mar 23, 2000 175 176 177 %************************************************************************ \begin{code}  178 179 -- | Wrap the given expression in the coercion safely, dropping -- identity coercions and coalescing nested coercions  dimitris committed Nov 16, 2011 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 mkCast :: CoreExpr -> Coercion -> CoreExpr mkCast e co | isReflCo co = e mkCast (Coercion e_co) co = Coercion new_co where -- g :: (s1 ~# s2) ~# (t1 ~# t2) -- g1 :: s1 ~# t1 -- g2 :: s2 ~# t2 new_co = mkSymCo g1 mkTransCo e_co mkTransCo g2 [_reflk, g1, g2] = decomposeCo 3 co -- Remember, (~#) :: forall k. k -> k -> * -- so it takes *three* arguments, not two mkCast (Cast expr co2) co  Ian Lynagh committed Sep 27, 2011 195  = ASSERT(let { Pair from_ty _to_ty = coercionKind co;  196 197  Pair _from_ty2 to_ty2 = coercionKind co2} in from_ty eqType to_ty2 )  dimitris committed Nov 16, 2011 198  mkCast expr (mkTransCo co2 co)  chak@cse.unsw.edu.au. committed Sep 18, 2006 199   dimitris committed Nov 16, 2011 200 mkCast expr co  201 202  = let Pair from_ty _to_ty = coercionKind co in -- if to_ty eqType from_ty  chak@cse.unsw.edu.au. committed Sep 18, 2006 203 -- then expr  Ian Lynagh committed Sep 27, 2011 204 -- else  205  WARN(not (from_ty eqType exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr$$ text "::" <+> ppr (exprType expr) <> text ")" $$ppr co$$ pprEqPred (coercionKind co))  chak@cse.unsw.edu.au. committed Sep 18, 2006 206  (Cast expr co)  simonpj committed Mar 23, 2000 207 208 209 \end{code} \begin{code}  Simon Marlow committed Nov 02, 2011 210 211 212 213 -- | Wraps the given expression in the source annotation, dropping the -- annotation if possible. mkTick :: Tickish Id -> CoreExpr -> CoreExpr  Simon Marlow committed Nov 04, 2011 214 215 216 217 218 219 220 221 222 mkTick t (Var x) | isFunTy (idType x) = Tick t (Var x) | otherwise = if tickishCounts t then if tickishScoped t && tickishCanSplit t then Tick (mkNoScope t) (Var x) else Tick t (Var x) else Var x  Simon Marlow committed Nov 02, 2011 223 224 225 mkTick t (Cast e co) = Cast (mkTick t e) co -- Move tick inside cast  Simon Marlow committed Nov 22, 2011 226 mkTick _ (Coercion co) = Coercion co  Simon Marlow committed Nov 22, 2011 227   Simon Marlow committed Nov 15, 2011 228 229 mkTick t (Lit l) | not (tickishCounts t) = Lit l  Simon Marlow committed Nov 02, 2011 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275  mkTick t expr@(App f arg) | not (isRuntimeArg arg) = App (mkTick t f) arg | isSaturatedConApp expr = if not (tickishCounts t) then tickHNFArgs t expr else if tickishScoped t && tickishCanSplit t then Tick (mkNoScope t) (tickHNFArgs (mkNoTick t) expr) else Tick t expr mkTick t (Lam x e) -- if this is a type lambda, or the tick does not count entries, -- then we can push the tick inside: | not (isRuntimeVar x) || not (tickishCounts t) = Lam x (mkTick t e) -- if it is both counting and scoped, we split the tick into its -- two components, keep the counting tick on the outside of the lambda -- and push the scoped tick inside. The point of this is that the -- counting tick can probably be floated, and the lambda may then be -- in a position to be beta-reduced. | tickishScoped t && tickishCanSplit t = Tick (mkNoScope t) (Lam x (mkTick (mkNoTick t) e)) -- just a counting tick: leave it on the outside | otherwise = Tick t (Lam x e) mkTick t other = Tick t other isSaturatedConApp :: CoreExpr -> Bool isSaturatedConApp e = go e [] where go (App f a) as = go f (a:as) go (Var fun) args = isConLikeId fun && idArity fun == valArgCount args go (Cast f _) as = go f as go _ _ = False mkTickNoHNF :: Tickish Id -> CoreExpr -> CoreExpr mkTickNoHNF t e | exprIsHNF e = tickHNFArgs t e | otherwise = mkTick t e -- push a tick into the arguments of a HNF (call or constructor app) tickHNFArgs :: Tickish Id -> CoreExpr -> CoreExpr tickHNFArgs t e = push t e where push t (App f (Type u)) = App (push t f) (Type u) push t (App f arg) = App (push t f) (mkTick t arg) push _t e = e  simonpj committed Mar 23, 2000 276 277 \end{code}  simonpj committed Mar 27, 2000 278 %************************************************************************  Ian Lynagh committed Sep 27, 2011 279 %* *  simonpj committed Mar 27, 2000 280 \subsection{Other expression construction}  Ian Lynagh committed Sep 27, 2011 281 %* *  simonpj committed Mar 27, 2000 282 283 284 285 %************************************************************************ \begin{code} bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr  batterseapower committed Jul 31, 2008 286 287 288 289 290 291 292 -- ^ @bindNonRec x r b@ produces either: -- -- > let x = r in b -- -- or: -- -- > case r of x { _DEFAULT_ -> b }  simonpj committed Mar 27, 2000 293 --  batterseapower committed Jul 31, 2008 294 295 -- depending on whether we have to use a @case@ or @let@ -- binding for the expression (see 'needsCaseBinding').  simonpj committed Mar 27, 2000 296 -- It's used by the desugarer to avoid building bindings  batterseapower committed Jul 31, 2008 297 298 299 -- that give Core Lint a heart attack, although actually -- the simplifier deals with them perfectly well. See -- also 'MkCore.mkCoreLet'  Ian Lynagh committed Sep 27, 2011 300 bindNonRec bndr rhs body  batterseapower committed Jul 31, 2008 301  | needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT, [], body)]  Ian Lynagh committed Sep 27, 2011 302  | otherwise = Let (NonRec bndr rhs) body  simonpj committed Sep 26, 2001 303   batterseapower committed Jul 31, 2008 304 305 -- | Tests whether we have to use a @case@ rather than @let@ binding for this expression -- as per the invariants of 'CoreExpr': see "CoreSyn#let_app_invariant"  twanvl committed Jan 25, 2008 306 needsCaseBinding :: Type -> CoreExpr -> Bool  simonpj committed Sep 26, 2001 307 needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)  Ian Lynagh committed Sep 27, 2011 308 309 310  -- Make a case expression instead of a let -- These can arise either from the desugarer, -- or from beta reductions: (\x.e) (x +# y)  simonpj committed Mar 27, 2000 311 312 313 \end{code} \begin{code}  batterseapower committed Jul 31, 2008 314 315 316 317 318 319 mkAltExpr :: AltCon -- ^ Case alternative constructor -> [CoreBndr] -- ^ Things bound by the pattern match -> [Type] -- ^ The type arguments to the case alternative -> CoreExpr -- ^ This guy constructs the value that the scrutinee must have -- given that you are in one particular branch of a case  simonpj committed Mar 27, 2000 320 mkAltExpr (DataAlt con) args inst_tys  chak@cse.unsw.edu.au. committed Sep 18, 2006 321  = mkConApp con (map Type inst_tys ++ varsToCoreExprs args)  simonpj committed Mar 27, 2000 322 323 mkAltExpr (LitAlt lit) [] [] = Lit lit  Ian Lynagh committed May 03, 2007 324 325 mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt" mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT"  simonpj committed Mar 27, 2000 326 327 \end{code}  simonpj committed Feb 26, 2001 328 329  %************************************************************************  Ian Lynagh committed Sep 27, 2011 330 %* *  simonpj committed Feb 26, 2001 331 \subsection{Taking expressions apart}  Ian Lynagh committed Sep 27, 2011 332 %* *  simonpj committed Feb 26, 2001 333 334 %************************************************************************  simonpj committed Jun 25, 2001 335 336 The default alternative must be first, if it exists at all. This makes it easy to find, though it makes matching marginally harder.  simonpj committed Feb 26, 2001 337 338  \begin{code}  batterseapower committed Jul 31, 2008 339 -- | Extract the default case alternative  simonpj committed Feb 26, 2001 340 findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)  simonpj committed Jun 25, 2001 341 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)  Ian Lynagh committed Sep 27, 2011 342 findDefault alts = (alts, Nothing)  simonpj committed Feb 26, 2001 343   simonpj@microsoft.com committed Apr 02, 2009 344 345 346 347 348 isDefaultAlt :: CoreAlt -> Bool isDefaultAlt (DEFAULT, _, _) = True isDefaultAlt _ = False  Ian Lynagh committed Sep 27, 2011 349 -- | Find the case alternative corresponding to a particular  batterseapower committed Jul 31, 2008 350 -- constructor: panics if no such constructor exists  simonpj@microsoft.com committed Apr 02, 2009 351 352 353 findAlt :: AltCon -> [CoreAlt] -> Maybe CoreAlt -- A "Nothing" result *is* legitmiate -- See Note [Unreachable code]  simonpj committed Feb 26, 2001 354 findAlt con alts  simonpj committed Jun 25, 2001 355  = case alts of  Ian Lynagh committed Sep 27, 2011 356  (deflt@(DEFAULT,_,_):alts) -> go alts (Just deflt)  simonpj@microsoft.com committed Apr 02, 2009 357  _ -> go alts Nothing  simonpj committed Feb 26, 2001 358  where  Ian Lynagh committed Sep 27, 2011 359  go [] deflt = deflt  simonpj committed Dec 22, 2004 360  go (alt@(con1,_,_) : alts) deflt  Ian Lynagh committed Sep 27, 2011 361 362 363 364  = case con cmpAltCon con1 of LT -> deflt -- Missed it already; the alts are in increasing order EQ -> Just alt GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt  simonmar committed Aug 03, 2005 365   simonpj@microsoft.com committed Apr 12, 2006 366 367 --------------------------------- mergeAlts :: [CoreAlt] -> [CoreAlt] -> [CoreAlt]  batterseapower committed Jul 31, 2008 368 369 -- ^ Merge alternatives preserving order; alternatives in -- the first argument shadow ones in the second  simonpj@microsoft.com committed Apr 12, 2006 370 371 372 373 mergeAlts [] as2 = as2 mergeAlts as1 [] = as1 mergeAlts (a1:as1) (a2:as2) = case a1 cmpAlt a2 of  Ian Lynagh committed Sep 27, 2011 374 375 376  LT -> a1 : mergeAlts as1 (a2:as2) EQ -> a1 : mergeAlts as1 as2 -- Discard a2 GT -> a2 : mergeAlts (a1:as1) as2  simonpj@microsoft.com committed Feb 09, 2007 377 378 379 380  --------------------------------- trimConArgs :: AltCon -> [CoreArg] -> [CoreArg]  batterseapower committed Jul 31, 2008 381 382 383 384 385 386 -- ^ Given: -- -- > case (C a b x y) of -- > C b x y -> ... -- -- We want to drop the leading type argument of the scrutinee  simonpj@microsoft.com committed Feb 09, 2007 387 388 389 -- leaving the arguments to match agains the pattern trimConArgs DEFAULT args = ASSERT( null args ) []  twanvl committed Jan 25, 2008 390 trimConArgs (LitAlt _) args = ASSERT( null args ) []  simonpj@microsoft.com committed Feb 09, 2007 391 trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args  simonpj committed Feb 26, 2001 392 393 \end{code}  simonpj@microsoft.com committed Apr 02, 2009 394 395 396 Note [Unreachable code] ~~~~~~~~~~~~~~~~~~~~~~~ It is possible (although unusual) for GHC to find a case expression  Ian Lynagh committed Sep 27, 2011 397 that cannot match. For example:  simonpj@microsoft.com committed Apr 02, 2009 398 399 400  data Col = Red | Green | Blue x = Red  Ian Lynagh committed Sep 27, 2011 401  f v = case x of  simonpj@microsoft.com committed Apr 02, 2009 402  Red -> ...  Ian Lynagh committed Sep 27, 2011 403  _ -> ...(case x of { Green -> e1; Blue -> e2 })...  simonpj@microsoft.com committed Apr 02, 2009 404 405 406 407 408 409 410 411  Suppose that for some silly reason, x isn't substituted in the case expression. (Perhaps there's a NOINLINE on it, or profiling SCC stuff gets in the way; cf Trac #3118.) Then the full-lazines pass might produce this x = Red lvl = case x of { Green -> e1; Blue -> e2 })  Ian Lynagh committed Sep 27, 2011 412  f v = case x of  simonpj@microsoft.com committed Apr 02, 2009 413  Red -> ...  Ian Lynagh committed Sep 27, 2011 414  _ -> ...lvl...  simonpj@microsoft.com committed Apr 02, 2009 415 416 417 418 419 420 421 422 423  Now if x gets inlined, we won't be able to find a matching alternative for 'Red'. That's because 'lvl' is unreachable. So rather than crashing we generate (error "Inaccessible alternative"). Similar things can happen (augmented by GADTs) when the Simplifier filters down the matching alternatives in Simplify.rebuildCase.  partain committed Mar 19, 1996 424 %************************************************************************  Ian Lynagh committed Sep 27, 2011 425 %* *  426  exprIsTrivial  Ian Lynagh committed Sep 27, 2011 427 %* *  partain committed Mar 19, 1996 428 429 %************************************************************************  430 431 Note [exprIsTrivial] ~~~~~~~~~~~~~~~~~~~~  simonmar committed May 22, 2000 432 @exprIsTrivial@ is true of expressions we are unconditionally happy to  Ian Lynagh committed Sep 27, 2011 433 434 435  duplicate; simple variables and constants, and type applications. Note that primop Ids aren't considered trivial unless  simonmar committed May 22, 2000 436   simonpj@microsoft.com committed Sep 11, 2009 437 438 Note [Variable are trivial] ~~~~~~~~~~~~~~~~~~~~~~~~~~~  simonpj committed Oct 18, 2001 439 440 There used to be a gruesome test for (hasNoBinding v) in the Var case:  Ian Lynagh committed Sep 27, 2011 441  exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0  batterseapower committed Jul 31, 2008 442 443 The idea here is that a constructor worker, like \$wJust, is really short for (\x -> \$wJust x), becuase \$wJust has no binding.  simonpj committed Oct 18, 2001 444 445 446 447 448 449 So it should be treated like a lambda. Ditto unsaturated primops. But now constructor workers are not "have-no-binding" Ids. And completely un-applied primops and foreign-call Ids are sufficiently rare that I plan to allow them to be duplicated and put up with saturating them.  Simon Marlow committed Nov 02, 2011 450 451 452 453 454 Note [Tick trivial] ~~~~~~~~~~~~~~~~~~~ Ticks are not trivial. If we treat "tick x" as trivial, it will be inlined inside lambdas and the entry count will be skewed, for example. Furthermore "scc x" will turn into just "x" in mkTick.  simonpj committed Sep 11, 2003 455   simonm committed Dec 02, 1998 456 \begin{code}  twanvl committed Jan 25, 2008 457 exprIsTrivial :: CoreExpr -> Bool  simonpj@microsoft.com committed Sep 11, 2009 458 exprIsTrivial (Var _) = True -- See Note [Variables are trivial]  459 460 exprIsTrivial (Type _) = True exprIsTrivial (Coercion _) = True  twanvl committed Jan 25, 2008 461 462 exprIsTrivial (Lit lit) = litIsTrivial lit exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e  Simon Marlow committed Nov 02, 2011 463 exprIsTrivial (Tick _ _) = False -- See Note [Tick trivial]  twanvl committed Jan 25, 2008 464 465 466 exprIsTrivial (Cast e _) = exprIsTrivial e exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body exprIsTrivial _ = False  partain committed Mar 19, 1996 467 468 \end{code}  Simon Marlow committed Nov 02, 2011 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 When substituting in a breakpoint we need to strip away the type cruft from a trivial expression and get back to the Id. The invariant is that the expression we're substituting was originally trivial according to exprIsTrivial. \begin{code} getIdFromTrivialExpr :: CoreExpr -> Id getIdFromTrivialExpr e = go e where go (Var v) = v go (App f t) | not (isRuntimeArg t) = go f go (Cast e _) = go e go (Lam b e) | not (isRuntimeVar b) = go e go e = pprPanic "getIdFromTrivialExpr" (ppr e) \end{code}  484 485 exprIsBottom is a very cheap and cheerful function; it may return False for bottoming expressions, but it never costs much to ask.  Ian Lynagh committed Sep 27, 2011 486 See also CoreArity.exprBotStrictness_maybe, but that's a bit more  487 488 489 490 expensive. \begin{code} exprIsBottom :: CoreExpr -> Bool  Ian Lynagh committed Sep 27, 2011 491 exprIsBottom e  492 493  = go 0 e where  Ian Lynagh committed Sep 27, 2011 494 495 496  go n (Var v) = isBottomingId v && n >= idArity v go n (App e a) | isTypeArg a = go n e | otherwise = go (n+1) e  Simon Marlow committed Nov 02, 2011 497  go n (Tick _ e) = go n e  Ian Lynagh committed Sep 27, 2011 498 499 500  go n (Cast e _) = go n e go n (Let _ e) = go n e go _ _ = False  501 502 \end{code}  partain committed Mar 19, 1996 503   504 %************************************************************************  Ian Lynagh committed Sep 27, 2011 505 %* *  506  exprIsDupable  Ian Lynagh committed Sep 27, 2011 507 %* *  508 509 510 511 %************************************************************************ Note [exprIsDupable] ~~~~~~~~~~~~~~~~~~~~  Ian Lynagh committed Sep 27, 2011 512 513 514 @exprIsDupable@ is true of expressions that can be duplicated at a modest cost in code size. This will only happen in different case branches, so there's no issue about duplicating work.  simonpj committed Jun 22, 1999 515   Ian Lynagh committed Sep 27, 2011 516 517  That is, exprIsDupable returns True of (f x) even if f is very very expensive to call.  simonpj committed Jun 22, 1999 518   Ian Lynagh committed Sep 27, 2011 519 520  Its only purpose is to avoid fruitless let-binding and then inlining of case join points  simonpj committed May 18, 1999 521 522   partain committed Mar 19, 1996 523 \begin{code}  twanvl committed Jan 25, 2008 524 exprIsDupable :: CoreExpr -> Bool  simonpj@microsoft.com committed Feb 14, 2011 525 526 exprIsDupable e = isJust (go dupAppSize e)  simonpj committed Mar 23, 2000 527  where  simonpj@microsoft.com committed Feb 14, 2011 528  go :: Int -> CoreExpr -> Maybe Int  529 530 531  go n (Type {}) = Just n go n (Coercion {}) = Just n go n (Var {}) = decrement n  Simon Marlow committed Nov 02, 2011 532  go n (Tick _ e) = go n e  533  go n (Cast e _) = go n e  simonpj@microsoft.com committed Feb 14, 2011 534 535 536 537 538 539 540  go n (App f a) | Just n' <- go n a = go n' f go n (Lit lit) | litIsDupable lit = decrement n go _ _ = Nothing decrement :: Int -> Maybe Int decrement 0 = Nothing decrement n = Just (n-1)  simonm committed Dec 02, 1998 541 542  dupAppSize :: Int  Ian Lynagh committed Sep 27, 2011 543 544 545 546 dupAppSize = 8 -- Size of term we are prepared to duplicate -- This is *just* big enough to make test MethSharing -- inline enough join points. Really it should be -- smaller, and could be if we fixed Trac #4960.  simonm committed Dec 02, 1998 547 \end{code}  partain committed Mar 19, 1996 548   549 %************************************************************************  Ian Lynagh committed Sep 27, 2011 550 %* *  551  exprIsCheap, exprIsExpandable  Ian Lynagh committed Sep 27, 2011 552 %* *  553 554 %************************************************************************  simonpj@microsoft.com committed May 05, 2010 555 556 Note [exprIsCheap] See also Note [Interaction of exprIsCheap and lone variables] ~~~~~~~~~~~~~~~~~~ in CoreUnfold.lhs  simonm committed Dec 02, 1998 557 558 559 560 @exprIsCheap@ looks at a Core expression and returns \tr{True} if it is obviously in weak head normal form, or is cheap to get to WHNF. [Note that that's not the same as exprIsDupable; an expression might be big, and hence not dupable, but still cheap.]  simonpj committed Jun 22, 1999 561 562  By cheap'' we mean a computation we're willing to:  Ian Lynagh committed Sep 27, 2011 563 564  push inside a lambda, or inline at more than one place  simonpj committed Jun 22, 1999 565 566 567 That might mean it gets evaluated more than once, instead of being shared. The main examples of things which aren't WHNF but are cheap'' are:  simonm committed Dec 02, 1998 568   Ian Lynagh committed Sep 27, 2011 569 570 571  * case e of pi -> ei (where e, and all the ei are cheap)  simonm committed Dec 02, 1998 572   Ian Lynagh committed Sep 27, 2011 573 574  * let x = e in b (where e and b are cheap)  simonm committed Dec 02, 1998 575   Ian Lynagh committed Sep 27, 2011 576 577  * op x1 ... xn (where op is a cheap primitive operator)  simonm committed Dec 02, 1998 578   Ian Lynagh committed Sep 27, 2011 579 580  * error "foo" (because we are happy to substitute it inside a lambda)  simonpj committed Jun 22, 1999 581   simonmar committed May 26, 1999 582 583 584 Notice that a variable is considered 'cheap': we can push it inside a lambda, because sharing will make sure it is only evaluated once.  simonpj@microsoft.com committed May 05, 2010 585 586 587 Note [exprIsCheap and exprIsHNF] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Note that exprIsHNF does not imply exprIsCheap. Eg  Ian Lynagh committed Sep 27, 2011 588  let x = fac 20 in Just x  simonpj@microsoft.com committed May 05, 2010 589 590 591 This responds True to exprIsHNF (you can discard a seq), but False to exprIsCheap.  simonm committed Dec 02, 1998 592 \begin{code}  simonpj@microsoft.com committed Dec 02, 2009 593 594 595 596 exprIsCheap :: CoreExpr -> Bool exprIsCheap = exprIsCheap' isCheapApp exprIsExpandable :: CoreExpr -> Bool  Ian Lynagh committed Sep 27, 2011 597 exprIsExpandable = exprIsCheap' isExpandableApp -- See Note [CONLIKE pragma] in BasicTypes  simonpj@microsoft.com committed Dec 02, 2009 598   simonpj@microsoft.com committed Dec 21, 2010 599 600 type CheapAppFun = Id -> Int -> Bool exprIsCheap' :: CheapAppFun -> CoreExpr -> Bool  601 602 603 604 605 606 607 exprIsCheap' _ (Lit _) = True exprIsCheap' _ (Type _) = True exprIsCheap' _ (Coercion _) = True exprIsCheap' _ (Var _) = True exprIsCheap' good_app (Cast e _) = exprIsCheap' good_app e exprIsCheap' good_app (Lam x e) = isRuntimeVar x || exprIsCheap' good_app e  simonpj@microsoft.com committed Dec 02, 2009 608   Ian Lynagh committed Sep 27, 2011 609 610 611 612 613 614 exprIsCheap' good_app (Case e _ _ alts) = exprIsCheap' good_app e && and [exprIsCheap' good_app rhs | (_,_,rhs) <- alts] -- Experimentally, treat (case x of ...) as cheap -- (and case __coerce x etc.) -- This improves arities of overloaded functions where -- there is only dictionary selection (no construction) involved  simonpj@microsoft.com committed Nov 19, 2009 615   Simon Marlow committed Nov 02, 2011 616 617 618 619 620 621 exprIsCheap' good_app (Tick t e) | tickishCounts t = False | otherwise = exprIsCheap' good_app e -- never duplicate ticks. If we get this wrong, then HPC's entry -- counts will be off (check test in libraries/hpc/tests/raytrace)  Ian Lynagh committed Sep 27, 2011 622 exprIsCheap' good_app (Let (NonRec x _) e)  simonpj@microsoft.com committed May 05, 2010 623  | isUnLiftedType (idType x) = exprIsCheap' good_app e  Ian Lynagh committed Sep 27, 2011 624 625 626 627 628  | otherwise = False -- Strict lets always have cheap right hand sides, -- and do no allocation, so just look at the body -- Non-strict lets do allocation so we don't treat them as cheap -- See also  simonpj committed Sep 07, 2000 629   Ian Lynagh committed Sep 27, 2011 630 exprIsCheap' good_app other_expr -- Applications and variables  simonpj@microsoft.com committed Aug 14, 2006 631  = go other_expr []  simonpj committed Mar 23, 2000 632  where  Ian Lynagh committed Sep 27, 2011 633  -- Accumulate value arguments, then decide  simonpj@microsoft.com committed Feb 15, 2011 634  go (Cast e _) val_args = go e val_args  simonpj@microsoft.com committed Aug 14, 2006 635  go (App f a) val_args | isRuntimeArg a = go f (a:val_args)  Ian Lynagh committed Sep 27, 2011 636  | otherwise = go f val_args  simonpj@microsoft.com committed Aug 14, 2006 637   Ian Lynagh committed Sep 27, 2011 638 639  go (Var _) [] = True -- Just a type application of a variable -- (f t1 t2 t3) counts as WHNF  simonpj@microsoft.com committed Aug 14, 2006 640  go (Var f) args  simonpj@microsoft.com committed Dec 22, 2010 641  = case idDetails f of  Ian Lynagh committed Sep 27, 2011 642 643 644 645 646 647 648 649 650 651  RecSelId {} -> go_sel args ClassOpId {} -> go_sel args PrimOpId op -> go_primop op args _ | good_app f (length args) -> go_pap args | isBottomingId f -> True | otherwise -> False -- Application of a function which -- always gives bottom; we treat this as cheap -- because it certainly doesn't need to be shared!  twanvl committed Jan 25, 2008 652  go _ _ = False  Ian Lynagh committed Sep 27, 2011 653   simonpj@microsoft.com committed Aug 14, 2006 654  --------------  Simon Marlow committed May 24, 2011 655 656 657  go_pap args = all (exprIsCheap' good_app) args -- Used to be "all exprIsTrivial args" due to concerns about -- duplicating nested constructor applications, but see #4978.  Ian Lynagh committed Sep 27, 2011 658 659  -- The principle here is that -- let x = a +# b in c *# x  Simon Peyton Jones committed Jun 11, 2011 660 661  -- should behave equivalently to -- c *# (a +# b)  Ian Lynagh committed Sep 27, 2011 662  -- Since lets with cheap RHSs are accepted,  Simon Peyton Jones committed Jun 11, 2011 663  -- so should paps with cheap arguments  Simon Marlow committed May 24, 2011 664   simonpj@microsoft.com committed Aug 14, 2006 665  --------------  simonpj@microsoft.com committed Dec 02, 2009 666  go_primop op args = primOpIsCheap op && all (exprIsCheap' good_app) args  Ian Lynagh committed Sep 27, 2011 667 668 669 670 671  -- In principle we should worry about primops -- that return a type variable, since the result -- might be applied to something, but I'm not going -- to bother to check the number of args  simonpj@microsoft.com committed Aug 14, 2006 672  --------------  Ian Lynagh committed Sep 27, 2011 673 674 675 676 677  go_sel [arg] = exprIsCheap' good_app arg -- I'm experimenting with making record selection go_sel _ = False -- look cheap, so we will substitute it inside a -- lambda. Particularly for dictionary field selection. -- BUT: Take care with (sel d x)! The (sel d) might be cheap, but -- there's no guarantee that (sel d x) will be too. Hence (n_val_args == 1)  simonpj@microsoft.com committed Mar 18, 2009 678   simonpj@microsoft.com committed Dec 21, 2010 679 isCheapApp :: CheapAppFun  simonpj@microsoft.com committed Dec 02, 2009 680 isCheapApp fn n_val_args  Ian Lynagh committed Sep 27, 2011 681  = isDataConWorkId fn  simonpj@microsoft.com committed Dec 02, 2009 682  || n_val_args < idArity fn  simonpj@microsoft.com committed Mar 18, 2009 683   simonpj@microsoft.com committed Dec 21, 2010 684 isExpandableApp :: CheapAppFun  simonpj@microsoft.com committed Dec 02, 2009 685 686 687 688 689 690 691 692 isExpandableApp fn n_val_args = isConLikeId fn || n_val_args < idArity fn || go n_val_args (idType fn) where -- See if all the arguments are PredTys (implicit params or classes) -- If so we'll regard it as expandable; see Note [Expandable overloadings] go 0 _ = True  Ian Lynagh committed Sep 27, 2011 693  go n_val_args ty  simonpj@microsoft.com committed Dec 02, 2009 694 695  | Just (_, ty) <- splitForAllTy_maybe ty = go n_val_args ty | Just (arg, ty) <- splitFunTy_maybe ty  Simon Peyton Jones committed Sep 07, 2011 696  , isPredTy arg = go (n_val_args-1) ty  simonpj@microsoft.com committed Dec 02, 2009 697  | otherwise = False  simonpj committed May 18, 1999 698 699 \end{code}  simonpj@microsoft.com committed Dec 02, 2009 700 701 702 703 704 705 706 707 708 709 710 711 712 Note [Expandable overloadings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose the user wrote this {-# RULE forall x. foo (negate x) = h x #-} f x = ....(foo (negate x)).... He'd expect the rule to fire. But since negate is overloaded, we might get this: f = \d -> let n = negate d in \x -> ...foo (n x)... So we treat the application of a function (negate in this case) to a *dictionary* as expandable. In effect, every function is CONLIKE when it's applied only to dictionaries.  713 %************************************************************************  Ian Lynagh committed Sep 27, 2011 714 %* *  715  exprOkForSpeculation  Ian Lynagh committed Sep 27, 2011 716 %* *  717 718 %************************************************************************  simonpj committed May 18, 1999 719 \begin{code}  Simon Peyton Jones committed Nov 11, 2011 720 -----------------------------  batterseapower committed Jul 31, 2008 721 722 -- | 'exprOkForSpeculation' returns True of an expression that is: --  Ian Lynagh committed Sep 27, 2011 723 -- * Safe to evaluate even if normal order eval might not  batterseapower committed Jul 31, 2008 724 725 726 727 -- evaluate the expression at all, or -- -- * Safe /not/ to evaluate even if normal order would do so --  simonpj@microsoft.com committed Jan 25, 2011 728 729 -- It is usually called on arguments of unlifted type, but not always -- In particular, Simplify.rebuildCase calls it on lifted types  Ian Lynagh committed Sep 27, 2011 730 -- when a 'case' is a plain 'seq'. See the example in  simonpj@microsoft.com committed Jan 25, 2011 731 732 -- Note [exprOkForSpeculation: case expressions] below --  batterseapower committed Jul 31, 2008 733 734 -- Precisely, it returns @True@ iff: --  Ian Lynagh committed Sep 27, 2011 735 736 -- * The expression guarantees to terminate, -- * soon,  batterseapower committed Jul 31, 2008 737 738 739 740 741 742 743 744 745 746 747 -- * without raising an exception, -- * without causing a side effect (e.g. writing a mutable variable) -- -- Note that if @exprIsHNF e@, then @exprOkForSpecuation e@. -- As an example of the considerations in this test, consider: -- -- > let x = case y# +# 1# of { r# -> I# r# } -- > in E -- -- being translated to: --  Ian Lynagh committed Sep 27, 2011 748 -- > case y# +# 1# of { r# ->  batterseapower committed Jul 31, 2008 749 -- > let x = I# r#  Ian Lynagh committed Sep 27, 2011 750 -- > in E  batterseapower committed Jul 31, 2008 751 -- > }  Ian Lynagh committed Sep 27, 2011 752 --  batterseapower committed Jul 31, 2008 753 754 -- We can only do this if the @y + 1@ is ok for speculation: it has no -- side effects, and can't diverge or raise an exception.  Simon Peyton Jones committed Sep 05, 2011 755 756 757 exprOkForSpeculation :: Expr b -> Bool -- Polymorphic in binder type -- There is one call at a non-Id binder type, in SetLevels  758 759 760 exprOkForSpeculation (Lit _) = True exprOkForSpeculation (Type _) = True exprOkForSpeculation (Coercion _) = True  Simon Peyton Jones committed Nov 11, 2011 761 762 exprOkForSpeculation (Var v) = appOkForSpeculation v [] exprOkForSpeculation (Cast e _) = exprOkForSpeculation e  Simon Marlow committed Nov 02, 2011 763 764 765 766 767 768 769  -- Tick annotations that *tick* cannot be speculated, because these -- are meant to identify whether or not (and how often) the particular -- source expression was evaluated at runtime. exprOkForSpeculation (Tick tickish e) | tickishCounts tickish = False | otherwise = exprOkForSpeculation e  simonpj@microsoft.com committed Jan 25, 2011 770   Ian Lynagh committed Sep 27, 2011 771 exprOkForSpeculation (Case e _ _ alts)  772 773  = exprOkForSpeculation e -- Note [exprOkForSpeculation: case expressions] && all (\(_,_,rhs) -> exprOkForSpeculation rhs) alts  Ian Lynagh committed Sep 27, 2011 774  && altsAreExhaustive alts -- Note [exprOkForSpeculation: exhaustive alts]  775   simonpj committed Mar 23, 2000 776 exprOkForSpeculation other_expr  simonpj committed Oct 24, 2001 777  = case collectArgs other_expr of  Simon Peyton Jones committed Nov 11, 2011 778  (Var f, args) -> appOkForSpeculation f args  twanvl committed Jan 25, 2008 779  _ -> False  Ian Lynagh committed Sep 27, 2011 780   Simon Peyton Jones committed Nov 11, 2011 781 782 783 784 785 786 787 788 789 790 ----------------------------- appOkForSpeculation :: Id -> [Expr b] -> Bool appOkForSpeculation fun args = case idDetails fun of DFunId new_type -> not new_type -- DFuns terminate, unless the dict is implemented -- with a newtype in which case they may not DataConWorkId {} -> True -- The strictness of the constructor has already  Ian Lynagh committed Sep 27, 2011 791 792  -- been expressed by its "wrapper", so we don't need -- to take the arguments into account  simonpj committed Oct 24, 2001 793   Simon Peyton Jones committed Nov 11, 2011 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817  PrimOpId op | isDivOp op -- Special case for dividing operations that fail , [arg1, Lit lit] <- args -- only if the divisor is zero -> not (isZeroLit lit) && exprOkForSpeculation arg1 -- Often there is a literal divisor, and this -- can get rid of a thunk in an inner looop | DataToTagOp <- op -- See Note [dataToTag speculation] -> True | otherwise -> primOpOkForSpeculation op && all exprOkForSpeculation args -- A bit conservative: we don't really need -- to care about lazy arguments, but this is easy _other -> isUnLiftedType (idType fun) -- c.f. the Var case of exprIsHNF || idArity fun > n_val_args -- Partial apps || (n_val_args ==0 && isEvaldUnfolding (idUnfolding fun)) -- Let-bound values where n_val_args = valArgCount args -----------------------------  Simon Peyton Jones committed Sep 05, 2011 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 altsAreExhaustive :: [Alt b] -> Bool -- True <=> the case alterantives are definiely exhaustive -- False <=> they may or may not be altsAreExhaustive [] = False -- Should not happen altsAreExhaustive ((con1,_,_) : alts) = case con1 of DEFAULT -> True LitAlt {} -> False DataAlt c -> 1 + length alts == tyConFamilySize (dataConTyCon c) -- It is possible to have an exhaustive case that does not -- enumerate all constructors, notably in a GADT match, but -- we behave conservatively here -- I don't think it's important -- enough to deserve special treatment  batterseapower committed Jul 31, 2008 833 -- | True of dyadic operators that can fail only if the second arg is zero!  simonpj committed Oct 24, 2001 834 isDivOp :: PrimOp -> Bool  Ian Lynagh committed Sep 27, 2011 835 836 -- This function probably belongs in PrimOp, or even in -- an automagically generated file.. but it's such a  simonpj committed Oct 24, 2001 837 -- special case I thought I'd leave it here for now.  Ian Lynagh committed Sep 27, 2011 838 839 840 841 isDivOp IntQuotOp = True isDivOp IntRemOp = True isDivOp WordQuotOp = True isDivOp WordRemOp = True  simonpj committed Oct 24, 2001 842 843 isDivOp FloatDivOp = True isDivOp DoubleDivOp = True  twanvl committed Jan 25, 2008 844 isDivOp _ = False  partain committed Mar 19, 1996 845 846 \end{code}  847 Note [exprOkForSpeculation: case expressions]  Ian Lynagh committed Sep 27, 2011 848 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  849 850 It's always sound for exprOkForSpeculation to return False, and we don't want it to take too long, so it bales out on complicated-looking  Ian Lynagh committed Sep 27, 2011 851 terms. Notably lets, which can be stacked very deeply; and in any  852 853 854 855 case the argument of exprOkForSpeculation is usually in a strict context, so any lets will have been floated away. However, we keep going on case-expressions. An example like this one  simonpj@microsoft.com committed Jan 25, 2011 856 showed up in DPH code (Trac #3717):  857 858 859 860 861 862 863 864 865  foo :: Int -> Int foo 0 = 0 foo n = (if n < 5 then 1 else 2) seq foo (n-1) If exprOkForSpeculation doesn't look through case expressions, you get this: T.$wfoo = \ (ww :: GHC.Prim.Int#) -> case ww of ds { __DEFAULT -> case (case <# ds 5 of _ {  Ian Lynagh committed Oct 23, 2010 866 867  GHC.Types.False -> lvl1; GHC.Types.True -> lvl})  868 869 870 871 872 873 874  of _ { __DEFAULT -> T.\$wfoo (GHC.Prim.-# ds_XkE 1) }; 0 -> 0 } The inner case is redundant, and should be nuked.  Simon Peyton Jones committed Sep 05, 2011 875 876 877 Note [exprOkForSpeculation: exhaustive alts] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We might have something like  Ian Lynagh committed Sep 27, 2011 878  case x of {  Simon Peyton Jones committed Sep 05, 2011 879 880  A -> ... _ -> ...(case x of { B -> ...; C -> ... })...  Ian Lynagh committed Sep 27, 2011 881 882 Here, the inner case is fine, becuase the A alternative can't happen, but it's not ok to float the inner case outside  Simon Peyton Jones committed Sep 05, 2011 883 884 885 886 887 the outer one (even if we know x is evaluated outside), because then it would be non-exhaustive. See Trac #5453. Similarly, this is a valid program (albeit a slightly dodgy one) let v = case x of { B -> ...; C -> ... }  Ian Lynagh committed Sep 27, 2011 888  in case x of  Simon Peyton Jones committed Sep 05, 2011 889 890 891 892 893 894 895 896  A -> ... _ -> ...v...v.... But we don't want to speculate the v binding. One could try to be clever, but the easy fix is simpy to regard a non-exhaustive case as *not* okForSpeculation.  simonpj@microsoft.com committed Jan 25, 2011 897 898 899 900 901 902 903 904 905 906 907 908 909 Note [dataToTag speculation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Is this OK? f x = let v::Int# = dataToTag# x in ... We say "yes", even though 'x' may not be evaluated. Reasons * dataToTag#'s strictness means that its argument often will be evaluated, but FloatOut makes that temporarily untrue case x of y -> let v = dataToTag# y in ... --> case x of y -> let v = dataToTag# x in ... Note that we look at 'x' instead of 'y' (this is to improve  Ian Lynagh committed Sep 27, 2011 910 911  floating in FloatOut). So Lint complains.  simonpj@microsoft.com committed Jan 25, 2011 912 913  Moreover, it really *might* improve floating to let the v-binding float out  Ian Lynagh committed Sep 27, 2011 914   simonpj@microsoft.com committed Jan 25, 2011 915 916 917  * CorePrep makes sure dataToTag#'s argument is evaluated, just before code gen. Until then, it's not guaranteed  918   919 %************************************************************************  Ian Lynagh committed Sep 27, 2011 920 %* *  921  exprIsHNF, exprIsConLike  Ian Lynagh committed Sep 27, 2011 922 %* *  923 924 %************************************************************************  partain committed Mar 19, 1996 925 \begin{code}  Ian Lynagh committed Sep 27, 2011 926 -- Note [exprIsHNF] See also Note [exprIsCheap and exprIsHNF]  927 -- ~~~~~~~~~~~~~~~~  Ian Lynagh committed Sep 27, 2011 928 929 -- | exprIsHNF returns true for expressions that are certainly /already/ -- evaluated to /head/ normal form. This is used to decide whether it's ok  930 931 932 933 934 935 936 937 938 -- to change: -- -- > case x of _ -> e -- -- into: -- -- > e -- -- and to decide whether it's safe to discard a 'seq'.  Ian Lynagh committed Sep 27, 2011 939 --  940 941 942 943 944 945 946 947 948 949 950 951 952 953 -- So, it does /not/ treat variables as evaluated, unless they say they are. -- However, it /does/ treat partial applications and constructor applications -- as values, even if their arguments are non-trivial, provided the argument -- type is lifted. For example, both of these are values: -- -- > (:) (f x) (map f xs) -- > map (...redex...) -- -- because 'seq' on such things completes immediately. -- -- For unlifted argument types, we have to be careful: -- -- > C (f x :: Int#) --  Ian Lynagh committed Sep 27, 2011 954 -- Suppose @f x@ diverges; then @C (f x)@ is not a value. However this can't  955 956 -- happen: see "CoreSyn#let_app_invariant". This invariant states that arguments of -- unboxed type must be ok-for-speculation (or trivial).  Ian Lynagh committed Sep 27, 2011 957 exprIsHNF :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP  958 exprIsHNF = exprIsHNFlike isDataConWorkId isEvaldUnfolding  partain committed Mar 19, 1996 959 960 \end{code}  rl@cse.unsw.edu.au committed Nov 04, 2009 961 \begin{code}  962 963 964 -- | Similar to 'exprIsHNF' but includes CONLIKE functions as well as -- data constructors. Conlike arguments are considered interesting by the -- inliner.  Ian Lynagh committed Sep 27, 2011 965 exprIsConLike :: CoreExpr -> Bool -- True => lambda, conlike, PAP  966 967 exprIsConLike = exprIsHNFlike isConLikeId isConLikeUnfolding  rl@cse.unsw.edu.au committed Nov 04, 2009 968 969 970 971 972 973 974 -- | Returns true for values or value-like expressions. These are lambdas, -- constructors / CONLIKE functions (as determined by the function argument) -- or PAPs. -- exprIsHNFlike :: (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool exprIsHNFlike is_con is_con_unf = is_hnf_like where  975  is_hnf_like (Var v) -- NB: There are no value args at this point  Ian Lynagh committed Sep 27, 2011 976 977 978  = is_con v -- Catches nullary constructors, -- so that [] and () are values, for example || idArity v > 0 -- Catches (e.g.) primops that don't have unfoldings  rl@cse.unsw.edu.au committed Nov 04, 2009 979  || is_con_unf (idUnfolding v)  Ian Lynagh committed Sep 27, 2011 980 981 982 983  -- Check the thing's unfolding; it might be bound to a value -- We don't look through loop breakers here, which is a bit conservative -- but otherwise I worry that if an Id's unfolding is just itself, -- we could get an infinite loop  rl@cse.unsw.edu.au committed Nov 04, 2009 984 985  is_hnf_like (Lit _) = True  Simon Peyton Jones committed Nov 11, 2011 986  is_hnf_like (Type _) = True -- Types are honorary Values;  rl@cse.unsw.edu.au committed Nov 04, 2009 987  -- we don't mind copying them  988  is_hnf_like (Coercion _) = True -- Same for coercions  rl@cse.unsw.edu.au committed Nov 04, 2009 989  is_hnf_like (Lam b e) = isRuntimeVar b || is_hnf_like e  Simon Marlow committed Nov 02, 2011 990 991 992  is_hnf_like (Tick tickish e) = not (tickishCounts tickish) && is_hnf_like e -- See Note [exprIsHNF Tick]  Simon Peyton Jones committed Nov 11, 2011 993 994  is_hnf_like (Cast e _) = is_hnf_like e is_hnf_like (App e (Type _)) = is_hnf_like e  995  is_hnf_like (App e (Coercion _)) = is_hnf_like e  Simon Peyton Jones committed Nov 11, 2011 996 997 998  is_hnf_like (App e a) = app_is_value e [a] is_hnf_like (Let _ e) = is_hnf_like e -- Lazy let(rec)s don't affect us is_hnf_like _ = False  rl@cse.unsw.edu.au committed Nov 04, 2009 999 1000  -- There is at least one value argument