CoreUtils.lhs 70.3 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}  Herbert Valerio Riedel committed May 15, 2014 9 10 {-# LANGUAGE CPP #-}  batterseapower committed Jul 31, 2008 11 -- | Commonly useful utilites for manipulating the Core language  partain committed Mar 19, 1996 12 module CoreUtils (  Ian Lynagh committed Sep 27, 2011 13  -- * Constructing expressions  dimitris committed Nov 16, 2011 14  mkCast,  Simon Marlow committed Aug 02, 2012 15  mkTick, mkTickNoHNF, tickHNFArgs,  Simon Marlow committed Nov 02, 2011 16  bindNonRec, needsCaseBinding,  dreixel committed Nov 16, 2011 17  mkAltExpr,  simonm committed Dec 02, 1998 18   Ian Lynagh committed Sep 27, 2011 19  -- * Taking expressions apart  batterseapower committed Mar 21, 2012 20 21  findDefault, findAlt, isDefaultAlt, mergeAlts, trimConArgs, filterAlts,  simonpj committed Feb 26, 2001 22   Ian Lynagh committed Sep 27, 2011 23  -- * Properties of expressions  Simon Marlow committed Nov 02, 2011 24  exprType, coreAltType, coreAltsType,  Simon Marlow committed Nov 02, 2011 25  exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsBottom,  Simon Peyton Jones committed Apr 27, 2012 26  exprIsCheap, exprIsExpandable, exprIsCheap', CheapAppFun,  Simon Peyton Jones committed May 09, 2012 27  exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprIsWorkFree,  Simon Peyton Jones committed Apr 27, 2012 28 29  exprIsBig, exprIsConLike, rhsIsStatic, isCheapApp, isExpandableApp,  simonpj committed Oct 18, 2001 30   Ian Lynagh committed Sep 27, 2011 31 32 33  -- * Expression and bindings size coreBindsSize, exprSize, CoreStats(..), coreBindsStats,  simonpj committed Mar 27, 2000 34   Ian Lynagh committed Sep 27, 2011 35  -- * Equality  Joachim Breitner committed Dec 17, 2013 36  cheapEqExpr, eqExpr,  chak@cse.unsw.edu.au. committed Sep 20, 2006 37   Ian Lynagh committed Sep 27, 2011 38 39  -- * Eta reduction tryEtaReduce,  simonpj@microsoft.com committed Sep 13, 2010 40   Ian Lynagh committed Sep 27, 2011 41 42  -- * Manipulating data constructors and types applyTypeToArgs, applyTypeToArg,  43  dataConRepInstPat, dataConRepFSInstPat  simonpj committed Dec 19, 1996 44  ) where  partain committed Mar 19, 1996 45   simonm committed Jan 08, 1998 46 #include "HsVersions.h"  partain committed Mar 19, 1996 47   simonm committed Dec 02, 1998 48 import CoreSyn  Simon Marlow committed Oct 11, 2006 49 import PprCore  Simon Peyton Jones committed Aug 19, 2013 50 import CoreFVs( exprFreeVars )  Simon Marlow committed Oct 11, 2006 51 52 import Var import SrcLoc  simonm committed Dec 02, 1998 53 import VarEnv  simonpj@microsoft.com committed Aug 13, 2009 54 import VarSet  Simon Marlow committed Oct 11, 2006 55 56 57 58 59 60 61 62 63 64 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 65 import Outputable  Simon Marlow committed Oct 11, 2006 66 import TysPrim  ian@well-typed.com committed Sep 17, 2012 67 import DynFlags  Simon Marlow committed Oct 11, 2006 68 import FastString  simonpj@microsoft.com committed Nov 24, 2006 69 import Maybes  ian@well-typed.com committed Aug 29, 2012 70 import Platform  Simon Marlow committed Oct 11, 2006 71 import Util  72 import Pair  batterseapower committed Mar 21, 2012 73 import Data.List  simonm committed Dec 02, 1998 74 \end{code}  partain committed Mar 19, 1996 75   simonm committed Dec 02, 1998 76   partain committed Mar 19, 1996 77 %************************************************************************  Ian Lynagh committed Sep 27, 2011 78 %* *  partain committed Mar 19, 1996 79 \subsection{Find the type of a Core atom/expression}  Ian Lynagh committed Sep 27, 2011 80 %* *  partain committed Mar 19, 1996 81 82 83 %************************************************************************ \begin{code}  simonpj committed Mar 23, 2000 84 exprType :: CoreExpr -> Type  batterseapower committed Jul 31, 2008 85 86 87 -- ^ 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 88 89 90 exprType (Var var) = idType var exprType (Lit lit) = literalType lit exprType (Coercion co) = coercionType co  Simon Peyton Jones committed Nov 12, 2013 91 92 93 94 exprType (Let bind body) | NonRec tv rhs <- bind -- See Note [Type bindings] , Type ty <- rhs = substTyWith [tv] [ty] (exprType body) | otherwise = exprType body  twanvl committed Jan 25, 2008 95 exprType (Case _ _ ty _) = ty  96 exprType (Cast _ co) = pSnd (coercionKind co)  Simon Marlow committed Nov 02, 2011 97 exprType (Tick _ e) = exprType e  simonpj@microsoft.com committed May 02, 2007 98 exprType (Lam binder expr) = mkPiType binder (exprType expr)  simonpj committed Mar 23, 2000 99 exprType e@(App _ _)  simonm committed Dec 02, 1998 100  = case collectArgs e of  Ian Lynagh committed Sep 27, 2011 101  (fun, args) -> applyTypeToArgs e (exprType fun) args  partain committed Mar 19, 1996 102   simonpj committed Mar 23, 2000 103 exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy  simonpj committed Dec 18, 1998 104   simonpj committed Sep 30, 2004 105 coreAltType :: CoreAlt -> Type  batterseapower committed Jul 31, 2008 106 -- ^ Returns the type of the alternatives right hand side  Ian Lynagh committed Sep 27, 2011 107 coreAltType (_,bs,rhs)  simonpj@microsoft.com committed Aug 13, 2009 108 109 110 111 112  | any bad_binder bs = expandTypeSynonyms ty | otherwise = ty -- Note [Existential variables and silly type synonyms] where ty = exprType rhs free_tvs = tyVarsOfType ty  113  bad_binder b = isTyVar b && b elemVarSet free_tvs  simonpj@microsoft.com committed Apr 22, 2008 114 115  coreAltsType :: [CoreAlt] -> Type  batterseapower committed Jul 31, 2008 116 -- ^ Returns the type of the first alternative, which should be the same as for all alternatives  simonpj@microsoft.com committed Apr 22, 2008 117 coreAltsType (alt:_) = coreAltType alt  Ian Lynagh committed Sep 27, 2011 118 coreAltsType [] = panic "corAltsType"  partain committed Mar 19, 1996 119 120 \end{code}  Simon Peyton Jones committed Nov 12, 2013 121 122 123 124 125 126 127 128 129 Note [Type bindings] ~~~~~~~~~~~~~~~~~~~~ Core does allow type bindings, although such bindings are not much used, except in the output of the desuguarer. Example: let a = Int in (\x:a. x) Given this, exprType must be careful to substitute 'a' in the result type (Trac #8522).  simonpj@microsoft.com committed Aug 13, 2009 130 131 132 Note [Existential variables and silly type synonyms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider  Ian Lynagh committed Sep 27, 2011 133 134 135 136  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 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153  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 154 \begin{code}  simonpj committed Nov 01, 2001 155 applyTypeToArg :: Type -> CoreExpr -> Type  Simon Peyton Jones committed Aug 29, 2013 156 157 -- ^ Determines the type resulting from applying an expression with given type -- to a given argument expression  simonpj committed Nov 01, 2001 158 applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty  twanvl committed Jan 25, 2008 159 applyTypeToArg fun_ty _ = funResultTy fun_ty  simonpj committed Nov 01, 2001 160   simonpj committed May 18, 1999 161 applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type  batterseapower committed Jul 31, 2008 162 163 -- ^ A more efficient version of 'applyTypeToArg' when we have several arguments. -- The first argument is just for debugging, and gives some context  Simon Peyton Jones committed Aug 29, 2013 164 165 applyTypeToArgs e op_ty args = go op_ty args  simonpj committed Feb 10, 1998 166  where  Simon Peyton Jones committed Aug 29, 2013 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182  go op_ty [] = op_ty go op_ty (Type ty : args) = go_ty_args op_ty [ty] args go op_ty (_ : args) | Just (_, res_ty) <- splitFunTy_maybe op_ty = go res_ty args go _ _ = pprPanic "applyTypeToArgs" panic_msg -- go_ty_args: accumulate type arguments so we can instantiate all at once go_ty_args op_ty rev_tys (Type ty : args) = go_ty_args op_ty (ty:rev_tys) args go_ty_args op_ty rev_tys args = go (applyTysD panic_msg_w_hdr op_ty (reverse rev_tys)) args panic_msg_w_hdr = hang (ptext (sLit "applyTypeToArgs")) 2 panic_msg panic_msg = vcat [ ptext (sLit "Expression:") <+> pprCoreExpr e , ptext (sLit "Type:") <+> ppr op_ty , ptext (sLit "Args:") <+> ppr args ]  partain committed Mar 19, 1996 183 184 \end{code}  simonpj committed Mar 23, 2000 185 %************************************************************************  Ian Lynagh committed Sep 27, 2011 186 %* *  simonpj committed Mar 27, 2000 187 \subsection{Attaching notes}  Ian Lynagh committed Sep 27, 2011 188 %* *  simonpj committed Mar 23, 2000 189 190 191 %************************************************************************ \begin{code}  192 193 -- | Wrap the given expression in the coercion safely, dropping -- identity coercions and coalescing nested coercions  dimitris committed Nov 16, 2011 194 mkCast :: CoreExpr -> Coercion -> CoreExpr  Herbert Valerio Riedel committed Nov 29, 2013 195 196 mkCast e co | ASSERT2( coercionRole co == Representational , ptext (sLit "coercion") <+> ppr co <+> ptext (sLit "passed to mkCast") <+> ppr e <+> ptext (sLit "has wrong role") <+> ppr (coercionRole co) )  Joachim Breitner committed Nov 27, 2013 197  isReflCo co = e  dimitris committed Nov 16, 2011 198 199  mkCast (Coercion e_co) co  Simon Peyton Jones committed Jan 09, 2012 200 201 202 203  | isCoVarType (pSnd (coercionKind co)) -- The guard here checks that g has a (~#) on both sides, -- otherwise decomposeCo fails. Can in principle happen -- with unsafeCoerce  Simon Peyton Jones committed May 07, 2012 204  = Coercion (mkCoCast e_co co)  dimitris committed Nov 16, 2011 205 206  mkCast (Cast expr co2) co  eir@cis.upenn.edu committed Aug 02, 2013 207 208 209 210 211 212  = WARN(let { Pair from_ty _to_ty = coercionKind co; Pair _from_ty2 to_ty2 = coercionKind co2} in not (from_ty eqType to_ty2), vcat ([ ptext (sLit "expr:") <+> ppr expr , ptext (sLit "co2:") <+> ppr co2 , ptext (sLit "co:") <+> ppr co ]) )  dimitris committed Nov 16, 2011 213  mkCast expr (mkTransCo co2 co)  chak@cse.unsw.edu.au. committed Sep 18, 2006 214   dimitris committed Nov 16, 2011 215 mkCast expr co  216 217  = let Pair from_ty _to_ty = coercionKind co in -- if to_ty eqType from_ty  chak@cse.unsw.edu.au. committed Sep 18, 2006 218 -- then expr  Ian Lynagh committed Sep 27, 2011 219 -- else  eir@cis.upenn.edu committed Jun 11, 2014 220  WARN(not (from_ty eqType exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$text "::" <+> ppr (exprType expr) <> text ")"$$ ppr co  ppr (coercionType co))  chak@cse.unsw.edu.au. committed Sep 18, 2006 221  (Cast expr co)  simonpj committed Mar 23, 2000 222 223 224 \end{code} \begin{code}  Simon Marlow committed Nov 02, 2011 225 226 227 228 -- | Wraps the given expression in the source annotation, dropping the -- annotation if possible. mkTick :: Tickish Id -> CoreExpr -> CoreExpr  Simon Marlow committed Nov 04, 2011 229 230 231 232 233 234 235 236 237 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 238 239 240 mkTick t (Cast e co) = Cast (mkTick t e) co -- Move tick inside cast  Simon Marlow committed Nov 22, 2011 241 mkTick _ (Coercion co) = Coercion co  Simon Marlow committed Nov 22, 2011 242   Simon Marlow committed Nov 15, 2011 243 244 mkTick t (Lit l) | not (tickishCounts t) = Lit l  Simon Marlow committed Nov 02, 2011 245 246 247 248 249 250 251  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  Simon Marlow committed Nov 21, 2013 252  then Tick (mkNoScope t) (tickHNFArgs (mkNoCount t) expr)  Simon Marlow committed Nov 02, 2011 253 254 255 256 257 258 259 260 261 262 263 264  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  Simon Marlow committed Nov 21, 2013 265  = Tick (mkNoScope t) (Lam x (mkTick (mkNoCount t) e))  Simon Marlow committed Nov 02, 2011 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290  -- 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 291 292 \end{code}  simonpj committed Mar 27, 2000 293 %************************************************************************  Ian Lynagh committed Sep 27, 2011 294 %* *  simonpj committed Mar 27, 2000 295 \subsection{Other expression construction}  Ian Lynagh committed Sep 27, 2011 296 %* *  simonpj committed Mar 27, 2000 297 298 299 300 %************************************************************************ \begin{code} bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr  batterseapower committed Jul 31, 2008 301 302 303 304 305 306 307 -- ^ @bindNonRec x r b@ produces either: -- -- > let x = r in b -- -- or: -- -- > case r of x { _DEFAULT_ -> b }  simonpj committed Mar 27, 2000 308 --  batterseapower committed Jul 31, 2008 309 310 -- depending on whether we have to use a @case@ or @let@ -- binding for the expression (see 'needsCaseBinding').  simonpj committed Mar 27, 2000 311 -- It's used by the desugarer to avoid building bindings  batterseapower committed Jul 31, 2008 312 313 314 -- 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 315 bindNonRec bndr rhs body  batterseapower committed Jul 31, 2008 316  | needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT, [], body)]  Ian Lynagh committed Sep 27, 2011 317  | otherwise = Let (NonRec bndr rhs) body  simonpj committed Sep 26, 2001 318   batterseapower committed Jul 31, 2008 319 320 -- | 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 321 needsCaseBinding :: Type -> CoreExpr -> Bool  simonpj committed Sep 26, 2001 322 needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)  Ian Lynagh committed Sep 27, 2011 323 324 325  -- 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 326 327 328 \end{code} \begin{code}  batterseapower committed Jul 31, 2008 329 330 331 332 333 334 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 335 mkAltExpr (DataAlt con) args inst_tys  chak@cse.unsw.edu.au. committed Sep 18, 2006 336  = mkConApp con (map Type inst_tys ++ varsToCoreExprs args)  simonpj committed Mar 27, 2000 337 338 mkAltExpr (LitAlt lit) [] [] = Lit lit  Ian Lynagh committed May 03, 2007 339 340 mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt" mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT"  simonpj committed Mar 27, 2000 341 342 \end{code}  simonpj committed Feb 26, 2001 343 344  %************************************************************************  Ian Lynagh committed Sep 27, 2011 345 %* *  simonpj committed Feb 26, 2001 346 \subsection{Taking expressions apart}  Ian Lynagh committed Sep 27, 2011 347 %* *  simonpj committed Feb 26, 2001 348 349 %************************************************************************  simonpj committed Jun 25, 2001 350 351 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 352 353  \begin{code}  batterseapower committed Jul 31, 2008 354 -- | Extract the default case alternative  batterseapower committed Mar 21, 2012 355 findDefault :: [(AltCon, [a], b)] -> ([(AltCon, [a], b)], Maybe b)  simonpj committed Jun 25, 2001 356 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)  Ian Lynagh committed Sep 27, 2011 357 findDefault alts = (alts, Nothing)  simonpj committed Feb 26, 2001 358   batterseapower committed Mar 21, 2012 359 isDefaultAlt :: (AltCon, a, b) -> Bool  simonpj@microsoft.com committed Apr 02, 2009 360 361 362 363 isDefaultAlt (DEFAULT, _, _) = True isDefaultAlt _ = False  Ian Lynagh committed Sep 27, 2011 364 -- | Find the case alternative corresponding to a particular  batterseapower committed Jul 31, 2008 365 -- constructor: panics if no such constructor exists  batterseapower committed Mar 21, 2012 366 findAlt :: AltCon -> [(AltCon, a, b)] -> Maybe (AltCon, a, b)  simonpj@microsoft.com committed Apr 02, 2009 367 368  -- A "Nothing" result *is* legitmiate -- See Note [Unreachable code]  simonpj committed Feb 26, 2001 369 findAlt con alts  simonpj committed Jun 25, 2001 370  = case alts of  Ian Lynagh committed Sep 27, 2011 371  (deflt@(DEFAULT,_,_):alts) -> go alts (Just deflt)  simonpj@microsoft.com committed Apr 02, 2009 372  _ -> go alts Nothing  simonpj committed Feb 26, 2001 373  where  Ian Lynagh committed Sep 27, 2011 374  go [] deflt = deflt  simonpj committed Dec 22, 2004 375  go (alt@(con1,_,_) : alts) deflt  Ian Lynagh committed Sep 27, 2011 376 377 378 379  = 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 380   simonpj@microsoft.com committed Apr 12, 2006 381 ---------------------------------  batterseapower committed Mar 21, 2012 382 mergeAlts :: [(AltCon, a, b)] -> [(AltCon, a, b)] -> [(AltCon, a, b)]  batterseapower committed Jul 31, 2008 383 384 -- ^ Merge alternatives preserving order; alternatives in -- the first argument shadow ones in the second  simonpj@microsoft.com committed Apr 12, 2006 385 386 387 388 mergeAlts [] as2 = as2 mergeAlts as1 [] = as1 mergeAlts (a1:as1) (a2:as2) = case a1 cmpAlt a2 of  Ian Lynagh committed Sep 27, 2011 389 390 391  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 392 393 394 395  --------------------------------- trimConArgs :: AltCon -> [CoreArg] -> [CoreArg]  batterseapower committed Jul 31, 2008 396 397 398 399 400 401 -- ^ 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 402 403 404 -- leaving the arguments to match agains the pattern trimConArgs DEFAULT args = ASSERT( null args ) []  twanvl committed Jan 25, 2008 405 trimConArgs (LitAlt _) args = ASSERT( null args ) []  simonpj@microsoft.com committed Feb 09, 2007 406 trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args  simonpj committed Feb 26, 2001 407 408 \end{code}  batterseapower committed Mar 21, 2012 409 410 411 \begin{code} filterAlts :: [Unique] -- ^ Supply of uniques used in case we have to manufacture a new AltCon -> Type -- ^ Type of scrutinee (used to prune possibilities)  Simon Peyton Jones committed Mar 30, 2012 412  -> [AltCon] -- ^ 'imposs_cons': constructors known to be impossible due to the form of the scrutinee  batterseapower committed Mar 21, 2012 413 414 415  -> [(AltCon, [Var], a)] -- ^ Alternatives -> ([AltCon], Bool, [(AltCon, [Var], a)]) -- Returns:  Simon Peyton Jones committed Mar 30, 2012 416 417 418 419 420 421 422 423  -- 1. Constructors that will never be encountered by the -- *default* case (if any). A superset of imposs_cons -- 2. Whether we managed to refine the default alternative into a specific constructor (for statistics only) -- 3. The new alternatives, trimmed by -- a) remove imposs_cons -- b) remove constructors which can't match because of GADTs -- and with the DEFAULT expanded to a DataAlt if there is exactly -- remaining constructor that can match  batterseapower committed Mar 21, 2012 424 425 426  -- -- NB: the final list of alternatives may be empty: -- This is a tricky corner case. If the data type has no constructors,  Simon Peyton Jones committed Mar 30, 2012 427 428  -- which GHC allows, or if the imposs_cons covers all constructors (after taking -- account of GADTs), then no alternatives can match.  batterseapower committed Mar 21, 2012 429 430 431 432  -- -- If callers need to preserve the invariant that there is always at least one branch -- in a "case" statement then they will need to manually add a dummy case branch that just -- calls "error" or similar.  Simon Peyton Jones committed Jan 02, 2013 433 434 435 436 437 filterAlts us ty imposs_cons alts | Just (tycon, inst_tys) <- splitTyConApp_maybe ty = filter_alts tycon inst_tys | otherwise = (imposs_cons, False, alts)  batterseapower committed Mar 21, 2012 438 439 440  where (alts_wo_default, maybe_deflt) = findDefault alts alt_cons = [con | (con,_,_) <- alts_wo_default]  Simon Peyton Jones committed Jan 02, 2013 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491  filter_alts tycon inst_tys = (imposs_deflt_cons, refined_deflt, merged_alts) where trimmed_alts = filterOut (impossible_alt inst_tys) alts_wo_default imposs_deflt_cons = nub (imposs_cons ++ alt_cons) -- "imposs_deflt_cons" are handled -- EITHER by the context, -- OR by a non-DEFAULT branch in this case expression. merged_alts = mergeAlts trimmed_alts (maybeToList maybe_deflt') -- We need the mergeAlts in case the new default_alt -- has turned into a constructor alternative. -- The merge keeps the inner DEFAULT at the front, if there is one -- and interleaves the alternatives in the right order (refined_deflt, maybe_deflt') = case maybe_deflt of Nothing -> (False, Nothing) Just deflt_rhs | isAlgTyCon tycon -- It's a data type, tuple, or unboxed tuples. , not (isNewTyCon tycon) -- We can have a newtype, if we are just doing an eval: -- case x of { DEFAULT -> e } -- and we don't want to fill in a default for them! , Just all_cons <- tyConDataCons_maybe tycon , let imposs_data_cons = [con | DataAlt con <- imposs_deflt_cons] -- We now know it's a data type impossible con = con elem imposs_data_cons || dataConCannotMatch inst_tys con -> case filterOut impossible all_cons of -- Eliminate the default alternative -- altogether if it can't match: [] -> (False, Nothing) -- It matches exactly one constructor, so fill it in: [con] -> (True, Just (DataAlt con, ex_tvs ++ arg_ids, deflt_rhs)) where (ex_tvs, arg_ids) = dataConRepInstPat us con inst_tys _ -> (False, Just (DEFAULT, [], deflt_rhs)) | debugIsOn, isAlgTyCon tycon , null (tyConDataCons tycon) , not (isFamilyTyCon tycon || isAbstractTyCon tycon) -- Check for no data constructors -- This can legitimately happen for abstract types and type families, -- so don't report that -> pprTrace "prepareDefault" (ppr tycon) (False, Just (DEFAULT, [], deflt_rhs)) | otherwise -> (False, Just (DEFAULT, [], deflt_rhs)) impossible_alt :: [Type] -> (AltCon, a, b) -> Bool impossible_alt _ (con, _, _) | con elem imposs_cons = True impossible_alt inst_tys (DataAlt con, _, _) = dataConCannotMatch inst_tys con impossible_alt _ _ = False  batterseapower committed Mar 21, 2012 492 493 \end{code}  simonpj@microsoft.com committed Apr 02, 2009 494 495 496 Note [Unreachable code] ~~~~~~~~~~~~~~~~~~~~~~~ It is possible (although unusual) for GHC to find a case expression  Ian Lynagh committed Sep 27, 2011 497 that cannot match. For example:  simonpj@microsoft.com committed Apr 02, 2009 498 499 500  data Col = Red | Green | Blue x = Red  Ian Lynagh committed Sep 27, 2011 501  f v = case x of  simonpj@microsoft.com committed Apr 02, 2009 502  Red -> ...  Ian Lynagh committed Sep 27, 2011 503  _ -> ...(case x of { Green -> e1; Blue -> e2 })...  simonpj@microsoft.com committed Apr 02, 2009 504 505 506 507 508 509 510 511  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 512  f v = case x of  simonpj@microsoft.com committed Apr 02, 2009 513  Red -> ...  Ian Lynagh committed Sep 27, 2011 514  _ -> ...lvl...  simonpj@microsoft.com committed Apr 02, 2009 515 516 517 518 519 520 521 522 523  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 524 %************************************************************************  Ian Lynagh committed Sep 27, 2011 525 %* *  526  exprIsTrivial  Ian Lynagh committed Sep 27, 2011 527 %* *  partain committed Mar 19, 1996 528 529 %************************************************************************  530 531 Note [exprIsTrivial] ~~~~~~~~~~~~~~~~~~~~  simonmar committed May 22, 2000 532 @exprIsTrivial@ is true of expressions we are unconditionally happy to  Ian Lynagh committed Sep 27, 2011 533 534 535  duplicate; simple variables and constants, and type applications. Note that primop Ids aren't considered trivial unless  simonmar committed May 22, 2000 536   simonpj@microsoft.com committed Sep 11, 2009 537 538 Note [Variable are trivial] ~~~~~~~~~~~~~~~~~~~~~~~~~~~  simonpj committed Oct 18, 2001 539 540 There used to be a gruesome test for (hasNoBinding v) in the Var case:  Ian Lynagh committed Sep 27, 2011 541  exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0  batterseapower committed Jul 31, 2008 542 The idea here is that a constructor worker, like \$wJust, is  Gabor Greif committed Jan 30, 2013 543 really short for (\x -> \$wJust x), because \\$wJust has no binding.  simonpj committed Oct 18, 2001 544 545 546 547 548 549 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 550 551 552 553 554 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 555   simonm committed Dec 02, 1998 556 \begin{code}  twanvl committed Jan 25, 2008 557 exprIsTrivial :: CoreExpr -> Bool  simonpj@microsoft.com committed Sep 11, 2009 558 exprIsTrivial (Var _) = True -- See Note [Variables are trivial]  559 560 exprIsTrivial (Type _) = True exprIsTrivial (Coercion _) = True  twanvl committed Jan 25, 2008 561 562 exprIsTrivial (Lit lit) = litIsTrivial lit exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e  Simon Marlow committed Nov 02, 2011 563 exprIsTrivial (Tick _ _) = False -- See Note [Tick trivial]  twanvl committed Jan 25, 2008 564 565 566 exprIsTrivial (Cast e _) = exprIsTrivial e exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body exprIsTrivial _ = False  partain committed Mar 19, 1996 567 568 \end{code}  Simon Marlow committed Nov 02, 2011 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 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}  584 exprIsBottom is a very cheap and cheerful function; it may return  Simon Peyton Jones committed Jun 06, 2013 585 586 False for bottoming expressions, but it never costs much to ask. See also CoreArity.exprBotStrictness_maybe, but that's a bit more  587 588 589 590 expensive. \begin{code} exprIsBottom :: CoreExpr -> Bool  Ian Lynagh committed Sep 27, 2011 591 exprIsBottom e  592 593  = go 0 e where  Ian Lynagh committed Sep 27, 2011 594 595 596  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 597  go n (Tick _ e) = go n e  Ian Lynagh committed Sep 27, 2011 598 599 600  go n (Cast e _) = go n e go n (Let _ e) = go n e go _ _ = False  601 602 \end{code}  partain committed Mar 19, 1996 603   604 %************************************************************************  Ian Lynagh committed Sep 27, 2011 605 %* *  606  exprIsDupable  Ian Lynagh committed Sep 27, 2011 607 %* *  608 609 610 611 %************************************************************************ Note [exprIsDupable] ~~~~~~~~~~~~~~~~~~~~  Ian Lynagh committed Sep 27, 2011 612 613 614 @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 615   Ian Lynagh committed Sep 27, 2011 616 617  That is, exprIsDupable returns True of (f x) even if f is very very expensive to call.  simonpj committed Jun 22, 1999 618   Ian Lynagh committed Sep 27, 2011 619 620  Its only purpose is to avoid fruitless let-binding and then inlining of case join points  simonpj committed May 18, 1999 621 622   partain committed Mar 19, 1996 623 \begin{code}  ian@well-typed.com committed Sep 17, 2012 624 625 exprIsDupable :: DynFlags -> CoreExpr -> Bool exprIsDupable dflags e  simonpj@microsoft.com committed Feb 14, 2011 626  = isJust (go dupAppSize e)  simonpj committed Mar 23, 2000 627  where  simonpj@microsoft.com committed Feb 14, 2011 628  go :: Int -> CoreExpr -> Maybe Int  629 630 631  go n (Type {}) = Just n go n (Coercion {}) = Just n go n (Var {}) = decrement n  Simon Marlow committed Nov 02, 2011 632  go n (Tick _ e) = go n e  633  go n (Cast e _) = go n e  simonpj@microsoft.com committed Feb 14, 2011 634  go n (App f a) | Just n' <- go n a = go n' f  ian@well-typed.com committed Sep 17, 2012 635  go n (Lit lit) | litIsDupable dflags lit = decrement n  simonpj@microsoft.com committed Feb 14, 2011 636 637 638 639 640  go _ _ = Nothing decrement :: Int -> Maybe Int decrement 0 = Nothing decrement n = Just (n-1)  simonm committed Dec 02, 1998 641 642  dupAppSize :: Int  Ian Lynagh committed Sep 27, 2011 643 644 645 646 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 647 \end{code}  partain committed Mar 19, 1996 648   649 %************************************************************************  Ian Lynagh committed Sep 27, 2011 650 %* *  651  exprIsCheap, exprIsExpandable  Ian Lynagh committed Sep 27, 2011 652 %* *  653 654 %************************************************************************  Simon Peyton Jones committed May 09, 2012 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 Note [exprIsWorkFree] ~~~~~~~~~~~~~~~~~~~~~ exprIsWorkFree is used when deciding whether to inline something; we don't inline it if doing so might duplicate work, by peeling off a complete copy of the expression. Here we do not want even to duplicate a primop (Trac #5623): eg let x = a #+ b in x +# x we do not want to inline/duplicate x Previously we were a bit more liberal, which led to the primop-duplicating problem. However, being more conservative did lead to a big regression in one nofib benchmark, wheel-sieve1. The situation looks like this: let noFactor_sZ3 :: GHC.Types.Int -> GHC.Types.Bool noFactor_sZ3 = case s_adJ of _ { GHC.Types.I# x_aRs -> case GHC.Prim.<=# x_aRs 2 of _ { GHC.Types.False -> notDivBy ps_adM qs_adN; GHC.Types.True -> lvl_r2Eb }} go = \x. ...(noFactor (I# y))....(go x')... The function 'noFactor' is heap-allocated and then called. Turns out that 'notDivBy' is strict in its THIRD arg, but that is invisible to the caller of noFactor, which therefore cannot do w/w and heap-allocates noFactor's argument. At the moment (May 12) we are just going to put up with this, because the previous more aggressive inlining (which treated 'noFactor' as work-free) was duplicating primops, which in turn was making inner loops of array calculations runs slow (#5623) \begin{code} exprIsWorkFree :: CoreExpr -> Bool -- See Note [exprIsWorkFree] exprIsWorkFree e = go 0 e where -- n is the number of value arguments go _ (Lit {}) = True go _ (Type {}) = True go _ (Coercion {}) = True go n (Cast e _) = go n e go n (Case scrut _ _ alts) = foldl (&&) (exprIsWorkFree scrut) [ go n rhs | (_,_,rhs) <- alts ] -- See Note [Case expressions are work-free] go _ (Let {}) = False  Simon Peyton Jones committed Oct 15, 2012 696  go n (Var v) = isCheapApp v n  Simon Peyton Jones committed May 09, 2012 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713  go n (Tick t e) | tickishCounts t = False | otherwise = go n e go n (Lam x e) | isRuntimeVar x = n==0 || go (n-1) e | otherwise = go n e go n (App f e) | isRuntimeArg e = exprIsWorkFree e && go (n+1) f | otherwise = go n f \end{code} Note [Case expressions are work-free] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Are case-expressions work-free? Consider let v = case x of (p,q) -> p go = \y -> ...case v of ... Should we inline 'v' at its use site inside the loop? At the moment we do. I experimented with saying that case are *not* work-free, but that increased allocation slightly. It's a fairly small effect, and at the moment we go for the slightly more aggressive version which treats  Krzysztof Gogolewski committed Sep 23, 2013 714 (case x of ....) as work-free if the alternatives are.  Simon Peyton Jones committed May 09, 2012 715 716   simonpj@microsoft.com committed May 05, 2010 717 718 Note [exprIsCheap] See also Note [Interaction of exprIsCheap and lone variables] ~~~~~~~~~~~~~~~~~~ in CoreUnfold.lhs  simonm committed Dec 02, 1998 719 720 721 722 @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 723 724  By cheap'' we mean a computation we're willing to:  Ian Lynagh committed Sep 27, 2011 725 726  push inside a lambda, or inline at more than one place  simonpj committed Jun 22, 1999 727 728 729 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 730   Ian Lynagh committed Sep 27, 2011 731 732 733  * case e of pi -> ei (where e, and all the ei are cheap)  simonm committed Dec 02, 1998 734   Ian Lynagh committed Sep 27, 2011 735 736  * let x = e in b (where e and b are cheap)  simonm committed Dec 02, 1998 737   Ian Lynagh committed Sep 27, 2011 738 739  * op x1 ... xn (where op is a cheap primitive operator)  simonm committed Dec 02, 1998 740   Ian Lynagh committed Sep 27, 2011 741 742  * error "foo" (because we are happy to substitute it inside a lambda)  simonpj committed Jun 22, 1999 743   simonmar committed May 26, 1999 744 745 746 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 747 748 749 Note [exprIsCheap and exprIsHNF] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Note that exprIsHNF does not imply exprIsCheap. Eg  Ian Lynagh committed Sep 27, 2011 750  let x = fac 20 in Just x  simonpj@microsoft.com committed May 05, 2010 751 752 753 This responds True to exprIsHNF (you can discard a seq), but False to exprIsCheap.  simonm committed Dec 02, 1998 754 \begin{code}  simonpj@microsoft.com committed Dec 02, 2009 755 exprIsCheap :: CoreExpr -> Bool  Simon Peyton Jones committed Apr 27, 2012 756 exprIsCheap = exprIsCheap' isCheapApp  simonpj@microsoft.com committed Dec 02, 2009 757 758  exprIsExpandable :: CoreExpr -> Bool  Simon Peyton Jones committed Apr 27, 2012 759 exprIsExpandable = exprIsCheap' isExpandableApp -- See Note [CONLIKE pragma] in BasicTypes  simonpj@microsoft.com committed Dec 02, 2009 760   Simon Peyton Jones committed Apr 27, 2012 761 exprIsCheap' :: CheapAppFun -> CoreExpr -> Bool  762 exprIsCheap' _ (Lit _) = True  Simon Peyton Jones committed Apr 27, 2012 763 exprIsCheap' _ (Type _) = True  764 765 766 767 768 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 769   Ian Lynagh committed Sep 27, 2011 770 771 772 773 774 775 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 776   Simon Marlow committed Nov 02, 2011 777 778 779 780 781 782 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)  Simon Peyton Jones committed Dec 12, 2013 783 784 785 786 exprIsCheap' good_app (Let (NonRec _ b) e) = exprIsCheap' good_app b && exprIsCheap' good_app e exprIsCheap' good_app (Let (Rec prs) e) = all (exprIsCheap' good_app . snd) prs && exprIsCheap' good_app e  simonpj committed Sep 07, 2000 787   Ian Lynagh committed Sep 27, 2011 788 exprIsCheap' good_app other_expr -- Applications and variables  simonpj@microsoft.com committed Aug 14, 2006 789  = go other_expr []  simonpj committed Mar 23, 2000 790  where  Ian Lynagh committed Sep 27, 2011 791  -- Accumulate value arguments, then decide  simonpj@microsoft.com committed Feb 15, 2011 792  go (Cast e _) val_args = go e val_args  simonpj@microsoft.com committed Aug 14, 2006 793  go (App f a) val_args | isRuntimeArg a = go f (a:val_args)  Ian Lynagh committed Sep 27, 2011 794  | otherwise = go f val_args  simonpj@microsoft.com committed Aug 14, 2006 795   Simon Peyton Jones committed Oct 15, 2012 796 797 798 799 800 801 802 803 804  go (Var _) [] = True -- Just a type application of a variable -- (f t1 t2 t3) counts as WHNF -- This case is probably handeld by the good_app case -- below, which should have a case for n=0, but putting -- it here too is belt and braces; and it's such a common -- case that checking for null directly seems like a -- good plan  simonpj@microsoft.com committed Aug 14, 2006 805  go (Var f) args  Simon Peyton Jones committed Oct 15, 2012 806 807 808 809  | good_app f (length args) = go_pap args | otherwise  simonpj@microsoft.com committed Dec 22, 2010 810  = case idDetails f of  Simon Peyton Jones committed Oct 15, 2012 811 812 813 814 815  RecSelId {} -> go_sel args ClassOpId {} -> go_sel args PrimOpId op -> go_primop op args _ | isBottomingId f -> True | otherwise -> False  Ian Lynagh committed Sep 27, 2011 816 817 818 819  -- 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 820  go _ _ = False  Ian Lynagh committed Sep 27, 2011 821   simonpj@microsoft.com committed Aug 14, 2006 822  --------------  Simon Marlow committed May 24, 2011 823 824 825  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 826 827  -- The principle here is that -- let x = a +# b in c *# x  Simon Peyton Jones committed Jun 11, 2011 828 829  -- should behave equivalently to -- c *# (a +# b)  Ian Lynagh committed Sep 27, 2011 830  -- Since lets with cheap RHSs are accepted,  Simon Peyton Jones committed Jun 11, 2011 831  -- so should paps with cheap arguments  Simon Marlow committed May 24, 2011 832   simonpj@microsoft.com committed Aug 14, 2006 833  --------------  simonpj@microsoft.com committed Dec 02, 2009 834  go_primop op args = primOpIsCheap op && all (exprIsCheap' good_app) args  Ian Lynagh committed Sep 27, 2011 835 836 837 838 839  -- 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 840  --------------  Ian Lynagh committed Sep 27, 2011 841 842 843 844 845  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)  Simon Peyton Jones committed Apr 27, 2012 846   Simon Peyton Jones committed Oct 15, 2012 847 848 849 850 851 852 853 ------------------------------------- type CheapAppFun = Id -> Int -> Bool -- Is an application of this function to n *value* args -- always cheap, assuming the arguments are cheap? -- Mainly true of partial applications, data constructors, -- and of course true if the number of args is zero  Simon Peyton Jones committed Apr 27, 2012 854 855 isCheapApp :: CheapAppFun isCheapApp fn n_val_args  Simon Peyton Jones committed Oct 15, 2012 856 857  = isDataConWorkId fn || n_val_args == 0  Simon Peyton Jones committed Apr 27, 2012 858 859 860 861 862 863 864 865 866 867  || n_val_args < idArity fn isExpandableApp :: CheapAppFun 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]  Simon Peyton Jones committed Oct 15, 2012 868  -- This incidentally picks up the (n_val_args = 0) case  Simon Peyton Jones committed Apr 27, 2012 869 870 871 872 873 874  go 0 _ = True go n_val_args ty | Just (_, ty) <- splitForAllTy_maybe ty = go n_val_args ty | Just (arg, ty) <- splitFunTy_maybe ty , isPredTy arg = go (n_val_args-1) ty | otherwise = False  simonpj committed May 18, 1999 875 876 \end{code}  Simon Peyton Jones committed Apr 27, 2012 877 878 879 880 881 882 883 884 885 886 887 888 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.  simonpj@microsoft.com committed Dec 02, 2009 889   890 %************************************************************************  Ian Lynagh committed Sep 27, 2011 891 %* *  892  exprOkForSpeculation  Ian Lynagh committed Sep 27, 2011 893 %* *  894 895 %************************************************************************  simonpj committed May 18, 1999 896 \begin{code}  Simon Peyton Jones committed Nov 11, 2011 897 -----------------------------  batterseapower committed Jul 31, 2008 898 899 -- | 'exprOkForSpeculation' returns True of an expression that is: --  Ian Lynagh committed Sep 27, 2011 900 -- * Safe to evaluate even if normal order eval might not  batterseapower committed Jul 31, 2008 901 902 903 904 -- evaluate the expression at all, or -- -- * Safe /not/ to evaluate even if normal order would do so --  simonpj@microsoft.com committed Jan 25, 2011 905 906 -- 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 907 -- when a 'case' is a plain 'seq'. See the example in  simonpj@microsoft.com committed Jan 25, 2011 908 909 -- Note [exprOkForSpeculation: case expressions] below --  batterseapower committed Jul 31, 2008 910 911 -- Precisely, it returns @True@ iff: --  Ian Lynagh committed Sep 27, 2011 912 913 -- * The expression guarantees to terminate, -- * soon,  batterseapower committed Jul 31, 2008 914 915 916 917 918 919 920 921 922 923 924 -- * 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 925 -- > case y# +# 1# of { r# ->  batterseapower committed Jul 31, 2008 926 -- > let x = I# r#  Ian Lynagh committed Sep 27, 2011 927 -- > in E  batterseapower committed Jul 31, 2008 928 -- > }  Ian Lynagh committed Sep 27, 2011 929 --  batterseapower committed Jul 31, 2008 930 931 -- 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 Jan 12, 2012 932 933 934 exprOkForSpeculation, exprOkForSideEffects :: Expr b -> Bool exprOkForSpeculation = expr_ok primOpOkForSpeculation exprOkForSideEffects = expr_ok primOpOkForSideEffects  Simon Peyton Jones committed Sep 05, 2011 935 936  -- Polymorphic in binder type -- There is one call at a non-Id binder type, in SetLevels  Simon Peyton Jones committed Jan 12, 2012 937 938 939 940 941 942 943  expr_ok :: (PrimOp -> Bool) -> Expr b -> Bool expr_ok _ (Lit _) = True expr_ok _ (Type _) = True expr_ok _ (Coercion _) = True expr_ok primop_ok (Var v) = app_ok primop_ok v [] expr_ok primop_ok (Cast e _) = expr_ok primop_ok e  Simon Marlow committed Nov 02, 2011 944 945 946 947  -- 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.  Simon Peyton Jones committed Jan 12, 2012 948 expr_ok primop_ok (Tick tickish e)  Simon Marlow committed Nov 02, 2011 949  | tickishCounts tickish = False  Simon Peyton Jones committed Jan 12, 2012 950  | otherwise = expr_ok primop_ok e  simonpj@microsoft.com committed Jan 25, 2011 951   Simon Peyton Jones committed Jan 12, 2012 952 953 954 955 expr_ok primop_ok (Case e _ _ alts) = expr_ok primop_ok e -- Note [exprOkForSpeculation: case expressions] && all (\(_,_,rhs) -> expr_ok primop_ok rhs) alts && altsAreExhaustive alts -- Note [Exhaustive alts]  956   Simon Peyton Jones committed Jan 12, 2012 957 expr_ok primop_ok other_expr  simonpj committed Oct 24, 2001 958  = case collectArgs other_expr of  Simon Peyton Jones committed Jan 12, 2012 959  (Var f, args) -> app_ok primop_ok f args  twanvl committed Jan 25, 2008 960  _ -> False  Ian Lynagh committed Sep 27, 2011 961   Simon Peyton Jones committed Nov 11, 2011 962 -----------------------------  Simon Peyton Jones committed Jan 12, 2012 963 964 app_ok :: (PrimOp -> Bool) -> Id -> [Expr b] -> Bool app_ok primop_ok fun args  Simon Peyton Jones committed Nov 11, 2011