2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[CoreUtils]{Utility functions on @Core@ syntax}
9 mkInlineMe, mkSCC, mkCoerce,
10 bindNonRec, needsCaseBinding,
11 mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,
13 -- Taking expressions apart
14 findDefault, findAlt, isDefaultAlt, mergeAlts,
16 -- Properties of expressions
17 exprType, coreAltType,
18 exprIsDupable, exprIsTrivial, exprIsCheap,
19 exprIsHNF,exprOkForSpeculation, exprIsBig,
20 exprIsConApp_maybe, exprIsBottom,
23 -- Arity and eta expansion
24 manifestArity, exprArity,
25 exprEtaExpandArity, etaExpand,
34 cheapEqExpr, tcEqExpr, tcEqExprX, applyTypeToArgs, applyTypeToArg,
39 #include "HsVersions.h"
42 import GLAEXTS -- For `xori`
45 import CoreFVs ( exprFreeVars )
46 import PprCore ( pprCoreExpr )
47 import Var ( Var, TyVar, CoVar, isCoVar, tyVarKind, setVarUnique,
48 mkCoVar, mkTyVar, mkCoVar )
49 import VarSet ( unionVarSet )
51 import Name ( hashName, mkSysTvName )
53 import Packages ( isDllName )
55 import Literal ( hashLiteral, literalType, litIsDupable,
56 litIsTrivial, isZeroLit, Literal( MachLabel ) )
57 import DataCon ( DataCon, dataConRepArity,
58 isVanillaDataCon, dataConTyCon, dataConRepArgTys,
59 dataConUnivTyVars, dataConExTyVars, dataConEqSpec )
60 import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
61 import Id ( Id, idType, globalIdDetails, idNewStrictness,
62 mkWildId, idArity, idName, idUnfolding, idInfo,
63 isOneShotBndr, isStateHackType, isDataConWorkId_maybe, mkSysLocal,
64 isDataConWorkId, isBottomingId, isDictId
66 import IdInfo ( GlobalIdDetails(..), megaSeqIdInfo )
67 import NewDemand ( appIsBottom )
68 import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
69 splitFunTy, tcEqTypeX,
70 applyTys, isUnLiftedType, seqType, mkTyVarTy,
71 splitForAllTy_maybe, isForAllTy, splitRecNewType_maybe,
72 splitTyConApp_maybe, coreEqType, funResultTy, applyTy,
75 import Coercion ( Coercion, mkTransCoercion, coercionKind,
76 splitNewTypeRepCo_maybe, mkSymCoercion, mkLeftCoercion,
77 mkRightCoercion, decomposeCo, coercionKindPredTy,
78 splitCoercionKind, mkEqPred )
79 import TyCon ( tyConArity )
80 import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
81 import CostCentre ( CostCentre )
82 import BasicTypes ( Arity )
83 import PackageConfig ( PackageId )
84 import Unique ( Unique )
86 import DynFlags ( DynFlags, DynFlag(Opt_DictsCheap), dopt )
87 import TysPrim ( alphaTy ) -- Debugging only
88 import Util ( equalLength, lengthAtLeast, foldl2 )
92 %************************************************************************
94 \subsection{Find the type of a Core atom/expression}
96 %************************************************************************
99 exprType :: CoreExpr -> Type
101 exprType (Var var) = idType var
102 exprType (Lit lit) = literalType lit
103 exprType (Let _ body) = exprType body
104 exprType (Case _ _ ty alts) = ty
106 = let (_, ty) = coercionKind co in ty
107 exprType (Note other_note e) = exprType e
108 exprType (Lam binder expr) = mkPiType binder (exprType expr)
110 = case collectArgs e of
111 (fun, args) -> applyTypeToArgs e (exprType fun) args
113 exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
115 coreAltType :: CoreAlt -> Type
116 coreAltType (_,_,rhs) = exprType rhs
119 @mkPiType@ makes a (->) type or a forall type, depending on whether
120 it is given a type variable or a term variable. We cleverly use the
121 lbvarinfo field to figure out the right annotation for the arrove in
122 case of a term variable.
125 mkPiType :: Var -> Type -> Type -- The more polymorphic version
126 mkPiTypes :: [Var] -> Type -> Type -- doesn't work...
128 mkPiTypes vs ty = foldr mkPiType ty vs
131 | isId v = mkFunTy (idType v) ty
132 | otherwise = mkForAllTy v ty
136 applyTypeToArg :: Type -> CoreExpr -> Type
137 applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty
138 applyTypeToArg fun_ty other_arg = funResultTy fun_ty
140 applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
141 -- A more efficient version of applyTypeToArg
142 -- when we have several args
143 -- The first argument is just for debugging
144 applyTypeToArgs e op_ty [] = op_ty
146 applyTypeToArgs e op_ty (Type ty : args)
147 = -- Accumulate type arguments so we can instantiate all at once
150 go rev_tys (Type ty : args) = go (ty:rev_tys) args
151 go rev_tys rest_args = applyTypeToArgs e op_ty' rest_args
153 op_ty' = applyTys op_ty (reverse rev_tys)
155 applyTypeToArgs e op_ty (other_arg : args)
156 = case (splitFunTy_maybe op_ty) of
157 Just (_, res_ty) -> applyTypeToArgs e res_ty args
158 Nothing -> pprPanic "applyTypeToArgs" (pprCoreExpr e $$ ppr op_ty)
163 %************************************************************************
165 \subsection{Attaching notes}
167 %************************************************************************
169 mkNote removes redundant coercions, and SCCs where possible
173 mkNote :: Note -> CoreExpr -> CoreExpr
174 mkNote (SCC cc) expr = mkSCC cc expr
175 mkNote InlineMe expr = mkInlineMe expr
176 mkNote note expr = Note note expr
180 Drop trivial InlineMe's. This is somewhat important, because if we have an unfolding
181 that looks like (Note InlineMe (Var v)), the InlineMe doesn't go away because it may
182 not be *applied* to anything.
184 We don't use exprIsTrivial here, though, because we sometimes generate worker/wrapper
187 f = inline_me (coerce t fw)
188 As usual, the inline_me prevents the worker from getting inlined back into the wrapper.
189 We want the split, so that the coerces can cancel at the call site.
191 However, we can get left with tiresome type applications. Notably, consider
192 f = /\ a -> let t = e in (t, w)
193 Then lifting the let out of the big lambda gives
195 f = /\ a -> let t = inline_me (t' a) in (t, w)
196 The inline_me is to stop the simplifier inlining t' right back
197 into t's RHS. In the next phase we'll substitute for t (since
198 its rhs is trivial) and *then* we could get rid of the inline_me.
199 But it hardly seems worth it, so I don't bother.
202 mkInlineMe (Var v) = Var v
203 mkInlineMe e = Note InlineMe e
209 mkCoerce :: Coercion -> CoreExpr -> CoreExpr
210 mkCoerce co (Cast expr co2)
211 = ASSERT(let { (from_ty, to_ty) = coercionKind co;
212 (from_ty2, to_ty2) = coercionKind co2} in
213 from_ty `coreEqType` to_ty2 )
214 mkCoerce (mkTransCoercion co2 co) expr
217 = let (from_ty, to_ty) = coercionKind co in
218 -- if to_ty `coreEqType` from_ty
221 ASSERT2(from_ty `coreEqType` (exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ ppr (coercionKindPredTy co))
226 mkSCC :: CostCentre -> Expr b -> Expr b
227 -- Note: Nested SCC's *are* preserved for the benefit of
228 -- cost centre stack profiling
229 mkSCC cc (Lit lit) = Lit lit
230 mkSCC cc (Lam x e) = Lam x (mkSCC cc e) -- Move _scc_ inside lambda
231 mkSCC cc (Note (SCC cc') e) = Note (SCC cc) (Note (SCC cc') e)
232 mkSCC cc (Note n e) = Note n (mkSCC cc e) -- Move _scc_ inside notes
233 mkSCC cc (Cast e co) = Cast (mkSCC cc e) co -- Move _scc_ inside cast
234 mkSCC cc expr = Note (SCC cc) expr
238 %************************************************************************
240 \subsection{Other expression construction}
242 %************************************************************************
245 bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
246 -- (bindNonRec x r b) produces either
249 -- case r of x { _DEFAULT_ -> b }
251 -- depending on whether x is unlifted or not
252 -- It's used by the desugarer to avoid building bindings
253 -- that give Core Lint a heart attack. Actually the simplifier
254 -- deals with them perfectly well.
256 bindNonRec bndr rhs body
257 | needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT,[],body)]
258 | otherwise = Let (NonRec bndr rhs) body
260 needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
261 -- Make a case expression instead of a let
262 -- These can arise either from the desugarer,
263 -- or from beta reductions: (\x.e) (x +# y)
267 mkAltExpr :: AltCon -> [CoreBndr] -> [Type] -> CoreExpr
268 -- This guy constructs the value that the scrutinee must have
269 -- when you are in one particular branch of a case
270 mkAltExpr (DataAlt con) args inst_tys
271 = mkConApp con (map Type inst_tys ++ varsToCoreExprs args)
272 mkAltExpr (LitAlt lit) [] []
275 mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
276 mkIfThenElse guard then_expr else_expr
277 -- Not going to be refining, so okay to take the type of the "then" clause
278 = Case guard (mkWildId boolTy) (exprType then_expr)
279 [ (DataAlt falseDataCon, [], else_expr), -- Increasing order of tag!
280 (DataAlt trueDataCon, [], then_expr) ]
284 %************************************************************************
286 \subsection{Taking expressions apart}
288 %************************************************************************
290 The default alternative must be first, if it exists at all.
291 This makes it easy to find, though it makes matching marginally harder.
294 findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
295 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
296 findDefault alts = (alts, Nothing)
298 findAlt :: AltCon -> [CoreAlt] -> CoreAlt
301 (deflt@(DEFAULT,_,_):alts) -> go alts deflt
302 other -> go alts panic_deflt
304 panic_deflt = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
307 go (alt@(con1,_,_) : alts) deflt
308 = case con `cmpAltCon` con1 of
309 LT -> deflt -- Missed it already; the alts are in increasing order
311 GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt
313 isDefaultAlt :: CoreAlt -> Bool
314 isDefaultAlt (DEFAULT, _, _) = True
315 isDefaultAlt other = False
317 ---------------------------------
318 mergeAlts :: [CoreAlt] -> [CoreAlt] -> [CoreAlt]
319 -- Merge preserving order; alternatives in the first arg
320 -- shadow ones in the second
321 mergeAlts [] as2 = as2
322 mergeAlts as1 [] = as1
323 mergeAlts (a1:as1) (a2:as2)
324 = case a1 `cmpAlt` a2 of
325 LT -> a1 : mergeAlts as1 (a2:as2)
326 EQ -> a1 : mergeAlts as1 as2 -- Discard a2
327 GT -> a2 : mergeAlts (a1:as1) as2
331 %************************************************************************
333 \subsection{Figuring out things about expressions}
335 %************************************************************************
337 @exprIsTrivial@ is true of expressions we are unconditionally happy to
338 duplicate; simple variables and constants, and type
339 applications. Note that primop Ids aren't considered
342 @exprIsBottom@ is true of expressions that are guaranteed to diverge
345 There used to be a gruesome test for (hasNoBinding v) in the
347 exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
348 The idea here is that a constructor worker, like $wJust, is
349 really short for (\x -> $wJust x), becuase $wJust has no binding.
350 So it should be treated like a lambda. Ditto unsaturated primops.
351 But now constructor workers are not "have-no-binding" Ids. And
352 completely un-applied primops and foreign-call Ids are sufficiently
353 rare that I plan to allow them to be duplicated and put up with
356 SCC notes. We do not treat (_scc_ "foo" x) as trivial, because
357 a) it really generates code, (and a heap object when it's
358 a function arg) to capture the cost centre
359 b) see the note [SCC-and-exprIsTrivial] in Simplify.simplLazyBind
362 exprIsTrivial (Var v) = True -- See notes above
363 exprIsTrivial (Type _) = True
364 exprIsTrivial (Lit lit) = litIsTrivial lit
365 exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e
366 exprIsTrivial (Note (SCC _) e) = False -- See notes above
367 exprIsTrivial (Note _ e) = exprIsTrivial e
368 exprIsTrivial (Cast e co) = exprIsTrivial e
369 exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body
370 exprIsTrivial other = False
374 @exprIsDupable@ is true of expressions that can be duplicated at a modest
375 cost in code size. This will only happen in different case
376 branches, so there's no issue about duplicating work.
378 That is, exprIsDupable returns True of (f x) even if
379 f is very very expensive to call.
381 Its only purpose is to avoid fruitless let-binding
382 and then inlining of case join points
386 exprIsDupable (Type _) = True
387 exprIsDupable (Var v) = True
388 exprIsDupable (Lit lit) = litIsDupable lit
389 exprIsDupable (Note InlineMe e) = True
390 exprIsDupable (Note _ e) = exprIsDupable e
391 exprIsDupable (Cast e co) = exprIsDupable e
395 go (Var v) n_args = True
396 go (App f a) n_args = n_args < dupAppSize
399 go other n_args = False
402 dupAppSize = 4 -- Size of application we are prepared to duplicate
405 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
406 it is obviously in weak head normal form, or is cheap to get to WHNF.
407 [Note that that's not the same as exprIsDupable; an expression might be
408 big, and hence not dupable, but still cheap.]
410 By ``cheap'' we mean a computation we're willing to:
411 push inside a lambda, or
412 inline at more than one place
413 That might mean it gets evaluated more than once, instead of being
414 shared. The main examples of things which aren't WHNF but are
419 (where e, and all the ei are cheap)
422 (where e and b are cheap)
425 (where op is a cheap primitive operator)
428 (because we are happy to substitute it inside a lambda)
430 Notice that a variable is considered 'cheap': we can push it inside a lambda,
431 because sharing will make sure it is only evaluated once.
434 exprIsCheap :: CoreExpr -> Bool
435 exprIsCheap (Lit lit) = True
436 exprIsCheap (Type _) = True
437 exprIsCheap (Var _) = True
438 exprIsCheap (Note InlineMe e) = True
439 exprIsCheap (Note _ e) = exprIsCheap e
440 exprIsCheap (Cast e co) = exprIsCheap e
441 exprIsCheap (Lam x e) = isRuntimeVar x || exprIsCheap e
442 exprIsCheap (Case e _ _ alts) = exprIsCheap e &&
443 and [exprIsCheap rhs | (_,_,rhs) <- alts]
444 -- Experimentally, treat (case x of ...) as cheap
445 -- (and case __coerce x etc.)
446 -- This improves arities of overloaded functions where
447 -- there is only dictionary selection (no construction) involved
448 exprIsCheap (Let (NonRec x _) e)
449 | isUnLiftedType (idType x) = exprIsCheap e
451 -- strict lets always have cheap right hand sides,
452 -- and do no allocation.
454 exprIsCheap other_expr -- Applications and variables
457 -- Accumulate value arguments, then decide
458 go (App f a) val_args | isRuntimeArg a = go f (a:val_args)
459 | otherwise = go f val_args
461 go (Var f) [] = True -- Just a type application of a variable
462 -- (f t1 t2 t3) counts as WHNF
464 = case globalIdDetails f of
465 RecordSelId {} -> go_sel args
466 ClassOpId _ -> go_sel args
467 PrimOpId op -> go_primop op args
469 DataConWorkId _ -> go_pap args
470 other | length args < idArity f -> go_pap args
472 other -> isBottomingId f
473 -- Application of a function which
474 -- always gives bottom; we treat this as cheap
475 -- because it certainly doesn't need to be shared!
477 go other args = False
480 go_pap args = all exprIsTrivial args
481 -- For constructor applications and primops, check that all
482 -- the args are trivial. We don't want to treat as cheap, say,
484 -- We'll put up with one constructor application, but not dozens
487 go_primop op args = primOpIsCheap op && all exprIsCheap args
488 -- In principle we should worry about primops
489 -- that return a type variable, since the result
490 -- might be applied to something, but I'm not going
491 -- to bother to check the number of args
494 go_sel [arg] = exprIsCheap arg -- I'm experimenting with making record selection
495 go_sel other = False -- look cheap, so we will substitute it inside a
496 -- lambda. Particularly for dictionary field selection.
497 -- BUT: Take care with (sel d x)! The (sel d) might be cheap, but
498 -- there's no guarantee that (sel d x) will be too. Hence (n_val_args == 1)
501 exprOkForSpeculation returns True of an expression that it is
503 * safe to evaluate even if normal order eval might not
504 evaluate the expression at all, or
506 * safe *not* to evaluate even if normal order would do so
510 the expression guarantees to terminate,
512 without raising an exception,
513 without causing a side effect (e.g. writing a mutable variable)
515 NB: if exprIsHNF e, then exprOkForSpecuation e
518 let x = case y# +# 1# of { r# -> I# r# }
521 case y# +# 1# of { r# ->
526 We can only do this if the (y+1) is ok for speculation: it has no
527 side effects, and can't diverge or raise an exception.
530 exprOkForSpeculation :: CoreExpr -> Bool
531 exprOkForSpeculation (Lit _) = True
532 exprOkForSpeculation (Type _) = True
533 exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
534 exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
535 exprOkForSpeculation (Cast e co) = exprOkForSpeculation e
536 exprOkForSpeculation other_expr
537 = case collectArgs other_expr of
538 (Var f, args) -> spec_ok (globalIdDetails f) args
542 spec_ok (DataConWorkId _) args
543 = True -- The strictness of the constructor has already
544 -- been expressed by its "wrapper", so we don't need
545 -- to take the arguments into account
547 spec_ok (PrimOpId op) args
548 | isDivOp op, -- Special case for dividing operations that fail
549 [arg1, Lit lit] <- args -- only if the divisor is zero
550 = not (isZeroLit lit) && exprOkForSpeculation arg1
551 -- Often there is a literal divisor, and this
552 -- can get rid of a thunk in an inner looop
555 = primOpOkForSpeculation op &&
556 all exprOkForSpeculation args
557 -- A bit conservative: we don't really need
558 -- to care about lazy arguments, but this is easy
560 spec_ok other args = False
562 isDivOp :: PrimOp -> Bool
563 -- True of dyadic operators that can fail
564 -- only if the second arg is zero
565 -- This function probably belongs in PrimOp, or even in
566 -- an automagically generated file.. but it's such a
567 -- special case I thought I'd leave it here for now.
568 isDivOp IntQuotOp = True
569 isDivOp IntRemOp = True
570 isDivOp WordQuotOp = True
571 isDivOp WordRemOp = True
572 isDivOp IntegerQuotRemOp = True
573 isDivOp IntegerDivModOp = True
574 isDivOp FloatDivOp = True
575 isDivOp DoubleDivOp = True
576 isDivOp other = False
581 exprIsBottom :: CoreExpr -> Bool -- True => definitely bottom
582 exprIsBottom e = go 0 e
584 -- n is the number of args
585 go n (Note _ e) = go n e
586 go n (Cast e co) = go n e
587 go n (Let _ e) = go n e
588 go n (Case e _ _ _) = go 0 e -- Just check the scrut
589 go n (App e _) = go (n+1) e
590 go n (Var v) = idAppIsBottom v n
592 go n (Lam _ _) = False
593 go n (Type _) = False
595 idAppIsBottom :: Id -> Int -> Bool
596 idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
599 @exprIsHNF@ returns true for expressions that are certainly *already*
600 evaluated to *head* normal form. This is used to decide whether it's ok
603 case x of _ -> e ===> e
605 and to decide whether it's safe to discard a `seq`
607 So, it does *not* treat variables as evaluated, unless they say they are.
609 But it *does* treat partial applications and constructor applications
610 as values, even if their arguments are non-trivial, provided the argument
612 e.g. (:) (f x) (map f xs) is a value
613 map (...redex...) is a value
614 Because `seq` on such things completes immediately
616 For unlifted argument types, we have to be careful:
618 Suppose (f x) diverges; then C (f x) is not a value. True, but
619 this form is illegal (see the invariants in CoreSyn). Args of unboxed
620 type must be ok-for-speculation (or trivial).
623 exprIsHNF :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
624 exprIsHNF (Var v) -- NB: There are no value args at this point
625 = isDataConWorkId v -- Catches nullary constructors,
626 -- so that [] and () are values, for example
627 || idArity v > 0 -- Catches (e.g.) primops that don't have unfoldings
628 || isEvaldUnfolding (idUnfolding v)
629 -- Check the thing's unfolding; it might be bound to a value
630 -- A worry: what if an Id's unfolding is just itself:
631 -- then we could get an infinite loop...
633 exprIsHNF (Lit l) = True
634 exprIsHNF (Type ty) = True -- Types are honorary Values;
635 -- we don't mind copying them
636 exprIsHNF (Lam b e) = isRuntimeVar b || exprIsHNF e
637 exprIsHNF (Note _ e) = exprIsHNF e
638 exprIsHNF (Cast e co) = exprIsHNF e
639 exprIsHNF (App e (Type _)) = exprIsHNF e
640 exprIsHNF (App e a) = app_is_value e [a]
641 exprIsHNF other = False
643 -- There is at least one value argument
644 app_is_value (Var fun) args
645 | isDataConWorkId fun -- Constructor apps are values
646 || idArity fun > valArgCount args -- Under-applied function
647 = check_args (idType fun) args
648 app_is_value (App f a) as = app_is_value f (a:as)
649 app_is_value other as = False
651 -- 'check_args' checks that unlifted-type args
652 -- are in fact guaranteed non-divergent
653 check_args fun_ty [] = True
654 check_args fun_ty (Type _ : args) = case splitForAllTy_maybe fun_ty of
655 Just (_, ty) -> check_args ty args
656 check_args fun_ty (arg : args)
657 | isUnLiftedType arg_ty = exprOkForSpeculation arg
658 | otherwise = check_args res_ty args
660 (arg_ty, res_ty) = splitFunTy fun_ty
664 -- deep applies a TyConApp coercion as a substitution to a reflexive coercion
665 -- deepCast t [a1,...,an] co corresponds to deep(t, [a1,...,an], co) from
667 deepCast :: Type -> [TyVar] -> Coercion -> Coercion
668 deepCast ty tyVars co
669 = ASSERT( let {(lty, rty) = coercionKind co;
670 Just (tc1, lArgs) = splitTyConApp_maybe lty;
671 Just (tc2, rArgs) = splitTyConApp_maybe rty}
673 tc1 == tc2 && length lArgs == length rArgs &&
674 length lArgs == length tyVars )
675 substTyWith tyVars coArgs ty
677 -- coArgs = [right (left (left co)), right (left co), right co]
678 coArgs = decomposeCo (length tyVars) co
680 -- This goes here to avoid circularity between DataCon and Id
681 dataConInstPat :: [Unique] -- An infinite list of uniques
683 -> [Type] -- Types to instantiate the universally quantified tyvars
684 -> ([TyVar], [CoVar], [Id]) -- Return instantiated variables
685 -- dataConInstPat us con inst_tys returns a triple (ex_tvs, co_tvs, arg_ids),
687 -- ex_tvs are intended to be used as binders for existential type args
689 -- co_tvs are intended to be used as binders for coercion args and the kinds
690 -- of these vars have been instantiated by the inst_tys and the ex_tys
692 -- arg_ids are indended to be used as binders for value arguments, including
693 -- dicts, and have their types instantiated with inst_tys and ex_tys
696 -- The following constructor T1
699 -- T1 :: forall b. Int -> b -> T(a,b)
702 -- has representation type
703 -- forall a. forall a1. forall a2. forall b. (a :=: (a1,a2)) =>
706 -- dataConInstPat us T1 (a1',a2') will return
708 -- ([a1'', a2'', b''],[c :: (a1',a2'):=:(a1'',a2'')],[x :: Int,y :: b''])
710 -- where the double-primed variables are created from the unique list input
711 dataConInstPat uniqs con inst_tys
712 = (ex_bndrs, co_bndrs, id_bndrs)
714 univ_tvs = dataConUnivTyVars con
715 ex_tvs = dataConExTyVars con
716 arg_tys = dataConRepArgTys con
717 eq_spec = dataConEqSpec con
718 eq_preds = [ mkEqPred (mkTyVarTy tv, ty) | (tv,ty) <- eq_spec ]
721 n_co = length eq_spec
722 n_id = length arg_tys
725 (ex_uniqs, uniqs') = splitAt n_ex uniqs
726 (co_uniqs, id_uniqs) = splitAt n_co uniqs'
728 -- make existential type variables
729 mk_ex_var uniq var = setVarUnique var uniq
730 ex_bndrs = zipWith mk_ex_var ex_uniqs ex_tvs
732 -- make the instantiation substitution
733 inst_subst = substTyWith (univ_tvs ++ ex_tvs) (inst_tys ++ map mkTyVarTy ex_bndrs)
735 -- make new coercion vars, instantiating kind
736 mk_co_var uniq eq_pred = mkCoVar new_name (inst_subst (mkPredTy eq_pred))
738 new_name = mkSysTvName uniq FSLIT("co")
740 co_bndrs = zipWith mk_co_var co_uniqs eq_preds
742 -- make value vars, instantiating types
743 mk_id_var uniq ty = mkSysLocal FSLIT("ca") uniq (inst_subst ty)
745 id_bndrs = zipWith mk_id_var id_uniqs arg_tys
748 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
749 -- Returns (Just (dc, [x1..xn])) if the argument expression is
750 -- a constructor application of the form (dc x1 .. xn)
752 exprIsConApp_maybe (Cast expr co)
753 = -- Maybe this is over the top, but here we try to turn
754 -- coerce (S,T) ( x, y )
756 -- ( coerce S x, coerce T y )
757 -- This happens in anger in PrelArrExts which has a coerce
758 -- case coerce memcpy a b of
760 -- where the memcpy is in the IO monad, but the call is in
762 case exprIsConApp_maybe expr of {
766 let (from_ty, to_ty) = coercionKind co in
768 case splitTyConApp_maybe to_ty of {
770 Just (tc, tc_arg_tys) | tc /= dataConTyCon dc -> Nothing
771 -- | not (isVanillaDataCon dc) -> Nothing
773 -- Type constructor must match datacon
775 case splitTyConApp_maybe from_ty of {
777 Just (tc', tc_arg_tys') | tc /= tc' -> Nothing
778 -- Both sides of coercion must have the same type constructor
782 -- here we do the PushC reduction rule as described in the FC paper
783 arity = tyConArity tc
784 n_ex_tvs = length dc_ex_tyvars
786 (univ_args, rest) = splitAt arity args
787 (ex_args, val_args) = splitAt n_ex_tvs rest
789 arg_tys = dataConRepArgTys dc
790 dc_tyvars = dataConUnivTyVars dc
791 dc_ex_tyvars = dataConExTyVars dc
793 deep arg_ty = deepCast arg_ty dc_tyvars co
795 -- first we appropriately cast the value arguments
796 arg_cos = map deep arg_tys
797 new_val_args = zipWith mkCoerce (map deep arg_tys) val_args
799 -- then we cast the existential coercion arguments
800 orig_tvs = dc_tyvars ++ dc_ex_tyvars
801 gammas = decomposeCo arity co
802 new_tys = gammas ++ (map (\ (Type t) -> t) ex_args)
803 theta = substTyWith orig_tvs new_tys
806 , (ty1, ty2) <- splitCoercionKind (tyVarKind tv)
807 = Type $ mkTransCoercion (mkSymCoercion (theta ty1))
808 (mkTransCoercion ty (theta ty2))
811 new_ex_args = zipWith cast_ty dc_ex_tyvars ex_args
814 ASSERT( all isTypeArg (take arity args) )
815 ASSERT( equalLength val_args arg_tys )
816 Just (dc, map Type tc_arg_tys ++ new_ex_args ++ new_val_args)
819 exprIsConApp_maybe (Note _ expr)
820 = exprIsConApp_maybe expr
821 -- We ignore InlineMe notes in case we have
822 -- x = __inline_me__ (a,b)
823 -- All part of making sure that INLINE pragmas never hurt
824 -- Marcin tripped on this one when making dictionaries more inlinable
826 -- In fact, we ignore all notes. For example,
827 -- case _scc_ "foo" (C a b) of
829 -- should be optimised away, but it will be only if we look
830 -- through the SCC note.
832 exprIsConApp_maybe expr = analyse (collectArgs expr)
834 analyse (Var fun, args)
835 | Just con <- isDataConWorkId_maybe fun,
836 args `lengthAtLeast` dataConRepArity con
837 -- Might be > because the arity excludes type args
840 -- Look through unfoldings, but only cheap ones, because
841 -- we are effectively duplicating the unfolding
842 analyse (Var fun, [])
843 | let unf = idUnfolding fun,
845 = exprIsConApp_maybe (unfoldingTemplate unf)
847 analyse other = Nothing
852 %************************************************************************
854 \subsection{Eta reduction and expansion}
856 %************************************************************************
859 exprEtaExpandArity :: DynFlags -> CoreExpr -> Arity
860 {- The Arity returned is the number of value args the
861 thing can be applied to without doing much work
863 exprEtaExpandArity is used when eta expanding
866 It returns 1 (or more) to:
867 case x of p -> \s -> ...
868 because for I/O ish things we really want to get that \s to the top.
869 We are prepared to evaluate x each time round the loop in order to get that
871 It's all a bit more subtle than it looks:
875 Consider one-shot lambdas
876 let x = expensive in \y z -> E
877 We want this to have arity 2 if the \y-abstraction is a 1-shot lambda
878 Hence the ArityType returned by arityType
880 2. The state-transformer hack
882 The one-shot lambda special cause is particularly important/useful for
883 IO state transformers, where we often get
884 let x = E in \ s -> ...
886 and the \s is a real-world state token abstraction. Such abstractions
887 are almost invariably 1-shot, so we want to pull the \s out, past the
888 let x=E, even if E is expensive. So we treat state-token lambdas as
889 one-shot even if they aren't really. The hack is in Id.isOneShotBndr.
891 3. Dealing with bottom
894 f = \x -> error "foo"
895 Here, arity 1 is fine. But if it is
899 then we want to get arity 2. Tecnically, this isn't quite right, because
901 should diverge, but it'll converge if we eta-expand f. Nevertheless, we
902 do so; it improves some programs significantly, and increasing convergence
903 isn't a bad thing. Hence the ABot/ATop in ArityType.
905 Actually, the situation is worse. Consider
909 Can we eta-expand here? At first the answer looks like "yes of course", but
912 This should diverge! But if we eta-expand, it won't. Again, we ignore this
913 "problem", because being scrupulous would lose an important transformation for
919 Non-recursive newtypes are transparent, and should not get in the way.
920 We do (currently) eta-expand recursive newtypes too. So if we have, say
922 newtype T = MkT ([T] -> Int)
926 where f has arity 1. Then: etaExpandArity e = 1;
927 that is, etaExpandArity looks through the coerce.
929 When we eta-expand e to arity 1: eta_expand 1 e T
930 we want to get: coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
932 HOWEVER, note that if you use coerce bogusly you can ge
934 And since negate has arity 2, you might try to eta expand. But you can't
935 decopose Int to a function type. Hence the final case in eta_expand.
939 exprEtaExpandArity dflags e = arityDepth (arityType dflags e)
941 -- A limited sort of function type
942 data ArityType = AFun Bool ArityType -- True <=> one-shot
943 | ATop -- Know nothing
946 arityDepth :: ArityType -> Arity
947 arityDepth (AFun _ ty) = 1 + arityDepth ty
950 andArityType ABot at2 = at2
951 andArityType ATop at2 = ATop
952 andArityType (AFun t1 at1) (AFun t2 at2) = AFun (t1 && t2) (andArityType at1 at2)
953 andArityType at1 at2 = andArityType at2 at1
955 arityType :: DynFlags -> CoreExpr -> ArityType
956 -- (go1 e) = [b1,..,bn]
957 -- means expression can be rewritten \x_b1 -> ... \x_bn -> body
958 -- where bi is True <=> the lambda is one-shot
960 arityType dflags (Note n e) = arityType dflags e
961 -- Not needed any more: etaExpand is cleverer
962 -- | ok_note n = arityType dflags e
963 -- | otherwise = ATop
965 arityType dflags (Cast e co) = arityType dflags e
967 arityType dflags (Var v)
968 = mk (idArity v) (arg_tys (idType v))
970 mk :: Arity -> [Type] -> ArityType
971 -- The argument types are only to steer the "state hack"
972 -- Consider case x of
974 -- False -> \(s:RealWorld) -> e
975 -- where foo has arity 1. Then we want the state hack to
976 -- apply to foo too, so we can eta expand the case.
977 mk 0 tys | isBottomingId v = ABot
978 | (ty:tys) <- tys, isStateHackType ty = AFun True ATop
980 mk n (ty:tys) = AFun (isStateHackType ty) (mk (n-1) tys)
981 mk n [] = AFun False (mk (n-1) [])
983 arg_tys :: Type -> [Type] -- Ignore for-alls
985 | Just (_, ty') <- splitForAllTy_maybe ty = arg_tys ty'
986 | Just (arg,res) <- splitFunTy_maybe ty = arg : arg_tys res
989 -- Lambdas; increase arity
990 arityType dflags (Lam x e)
991 | isId x = AFun (isOneShotBndr x) (arityType dflags e)
992 | otherwise = arityType dflags e
994 -- Applications; decrease arity
995 arityType dflags (App f (Type _)) = arityType dflags f
996 arityType dflags (App f a) = case arityType dflags f of
997 AFun one_shot xs | exprIsCheap a -> xs
1000 -- Case/Let; keep arity if either the expression is cheap
1001 -- or it's a 1-shot lambda
1002 -- The former is not really right for Haskell
1003 -- f x = case x of { (a,b) -> \y. e }
1005 -- f x y = case x of { (a,b) -> e }
1006 -- The difference is observable using 'seq'
1007 arityType dflags (Case scrut _ _ alts)
1008 = case foldr1 andArityType [arityType dflags rhs | (_,_,rhs) <- alts] of
1009 xs | exprIsCheap scrut -> xs
1010 xs@(AFun one_shot _) | one_shot -> AFun True ATop
1013 arityType dflags (Let b e)
1014 = case arityType dflags e of
1015 xs | cheap_bind b -> xs
1016 xs@(AFun one_shot _) | one_shot -> AFun True ATop
1019 cheap_bind (NonRec b e) = is_cheap (b,e)
1020 cheap_bind (Rec prs) = all is_cheap prs
1021 is_cheap (b,e) = (dopt Opt_DictsCheap dflags && isDictId b)
1023 -- If the experimental -fdicts-cheap flag is on, we eta-expand through
1024 -- dictionary bindings. This improves arities. Thereby, it also
1025 -- means that full laziness is less prone to floating out the
1026 -- application of a function to its dictionary arguments, which
1027 -- can thereby lose opportunities for fusion. Example:
1028 -- foo :: Ord a => a -> ...
1029 -- foo = /\a \(d:Ord a). let d' = ...d... in \(x:a). ....
1030 -- -- So foo has arity 1
1032 -- f = \x. foo dInt $ bar x
1034 -- The (foo DInt) is floated out, and makes ineffective a RULE
1035 -- foo (bar x) = ...
1037 -- One could go further and make exprIsCheap reply True to any
1038 -- dictionary-typed expression, but that's more work.
1040 arityType dflags other = ATop
1042 {- NOT NEEDED ANY MORE: etaExpand is cleverer
1043 ok_note InlineMe = False
1044 ok_note other = True
1045 -- Notice that we do not look through __inline_me__
1046 -- This may seem surprising, but consider
1047 -- f = _inline_me (\x -> e)
1048 -- We DO NOT want to eta expand this to
1049 -- f = \x -> (_inline_me (\x -> e)) x
1050 -- because the _inline_me gets dropped now it is applied,
1059 etaExpand :: Arity -- Result should have this number of value args
1061 -> CoreExpr -> Type -- Expression and its type
1063 -- (etaExpand n us e ty) returns an expression with
1064 -- the same meaning as 'e', but with arity 'n'.
1066 -- Given e' = etaExpand n us e ty
1068 -- ty = exprType e = exprType e'
1070 -- Note that SCCs are not treated specially. If we have
1071 -- etaExpand 2 (\x -> scc "foo" e)
1072 -- = (\xy -> (scc "foo" e) y)
1073 -- So the costs of evaluating 'e' (not 'e y') are attributed to "foo"
1075 etaExpand n us expr ty
1076 | manifestArity expr >= n = expr -- The no-op case
1078 = eta_expand n us expr ty
1081 -- manifestArity sees how many leading value lambdas there are
1082 manifestArity :: CoreExpr -> Arity
1083 manifestArity (Lam v e) | isId v = 1 + manifestArity e
1084 | otherwise = manifestArity e
1085 manifestArity (Note _ e) = manifestArity e
1086 manifestArity (Cast e _) = manifestArity e
1089 -- etaExpand deals with for-alls. For example:
1091 -- where E :: forall a. a -> a
1093 -- (/\b. \y::a -> E b y)
1095 -- It deals with coerces too, though they are now rare
1096 -- so perhaps the extra code isn't worth it
1098 eta_expand n us expr ty
1100 -- The ILX code generator requires eta expansion for type arguments
1101 -- too, but alas the 'n' doesn't tell us how many of them there
1102 -- may be. So we eagerly eta expand any big lambdas, and just
1103 -- cross our fingers about possible loss of sharing in the ILX case.
1104 -- The Right Thing is probably to make 'arity' include
1105 -- type variables throughout the compiler. (ToDo.)
1107 -- Saturated, so nothing to do
1110 -- Short cut for the case where there already
1111 -- is a lambda; no point in gratuitously adding more
1112 eta_expand n us (Lam v body) ty
1114 = Lam v (eta_expand n us body (applyTy ty (mkTyVarTy v)))
1117 = Lam v (eta_expand (n-1) us body (funResultTy ty))
1119 -- We used to have a special case that stepped inside Coerces here,
1120 -- thus: eta_expand n us (Note note@(Coerce _ ty) e) _
1121 -- = Note note (eta_expand n us e ty)
1122 -- BUT this led to an infinite loop
1123 -- Example: newtype T = MkT (Int -> Int)
1124 -- eta_expand 1 (coerce (Int->Int) e)
1125 -- --> coerce (Int->Int) (eta_expand 1 T e)
1127 -- --> coerce (Int->Int) (coerce T
1128 -- (\x::Int -> eta_expand 1 (coerce (Int->Int) e)))
1129 -- by the splitNewType_maybe case below
1132 eta_expand n us expr ty
1133 = ASSERT2 (exprType expr `coreEqType` ty, ppr (exprType expr) $$ ppr ty)
1134 case splitForAllTy_maybe ty of {
1136 Lam lam_tv (eta_expand n us2 (App expr (Type (mkTyVarTy lam_tv))) (substTyWith [tv] [mkTyVarTy lam_tv] ty'))
1138 lam_tv = mkTyVar (mkSysTvName uniq FSLIT("etaT")) (tyVarKind tv)
1143 case splitFunTy_maybe ty of {
1144 Just (arg_ty, res_ty) -> Lam arg1 (eta_expand (n-1) us2 (App expr (Var arg1)) res_ty)
1146 arg1 = mkSysLocal FSLIT("eta") uniq arg_ty
1152 -- newtype T = MkT ([T] -> Int)
1153 -- Consider eta-expanding this
1156 -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
1158 case splitNewTypeRepCo_maybe ty of {
1160 mkCoerce co (eta_expand n us (mkCoerce (mkSymCoercion co) expr) ty1) ;
1163 -- We have an expression of arity > 0, but its type isn't a function
1164 -- This *can* legitmately happen: e.g. coerce Int (\x. x)
1165 -- Essentially the programmer is playing fast and loose with types
1166 -- (Happy does this a lot). So we simply decline to eta-expand.
1171 exprArity is a cheap-and-cheerful version of exprEtaExpandArity.
1172 It tells how many things the expression can be applied to before doing
1173 any work. It doesn't look inside cases, lets, etc. The idea is that
1174 exprEtaExpandArity will do the hard work, leaving something that's easy
1175 for exprArity to grapple with. In particular, Simplify uses exprArity to
1176 compute the ArityInfo for the Id.
1178 Originally I thought that it was enough just to look for top-level lambdas, but
1179 it isn't. I've seen this
1181 foo = PrelBase.timesInt
1183 We want foo to get arity 2 even though the eta-expander will leave it
1184 unchanged, in the expectation that it'll be inlined. But occasionally it
1185 isn't, because foo is blacklisted (used in a rule).
1187 Similarly, see the ok_note check in exprEtaExpandArity. So
1188 f = __inline_me (\x -> e)
1189 won't be eta-expanded.
1191 And in any case it seems more robust to have exprArity be a bit more intelligent.
1192 But note that (\x y z -> f x y z)
1193 should have arity 3, regardless of f's arity.
1196 exprArity :: CoreExpr -> Arity
1199 go (Var v) = idArity v
1200 go (Lam x e) | isId x = go e + 1
1202 go (Note n e) = go e
1203 go (Cast e _) = go e
1204 go (App e (Type t)) = go e
1205 go (App f a) | exprIsCheap a = (go f - 1) `max` 0
1206 -- NB: exprIsCheap a!
1207 -- f (fac x) does not have arity 2,
1208 -- even if f has arity 3!
1209 -- NB: `max 0`! (\x y -> f x) has arity 2, even if f is
1210 -- unknown, hence arity 0
1214 %************************************************************************
1216 \subsection{Equality}
1218 %************************************************************************
1220 @cheapEqExpr@ is a cheap equality test which bales out fast!
1221 True => definitely equal
1222 False => may or may not be equal
1225 cheapEqExpr :: Expr b -> Expr b -> Bool
1227 cheapEqExpr (Var v1) (Var v2) = v1==v2
1228 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
1229 cheapEqExpr (Type t1) (Type t2) = t1 `coreEqType` t2
1231 cheapEqExpr (App f1 a1) (App f2 a2)
1232 = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
1234 cheapEqExpr _ _ = False
1236 exprIsBig :: Expr b -> Bool
1237 -- Returns True of expressions that are too big to be compared by cheapEqExpr
1238 exprIsBig (Lit _) = False
1239 exprIsBig (Var v) = False
1240 exprIsBig (Type t) = False
1241 exprIsBig (App f a) = exprIsBig f || exprIsBig a
1242 exprIsBig other = True
1247 tcEqExpr :: CoreExpr -> CoreExpr -> Bool
1248 -- Used in rule matching, so does *not* look through
1249 -- newtypes, predicate types; hence tcEqExpr
1251 tcEqExpr e1 e2 = tcEqExprX rn_env e1 e2
1253 rn_env = mkRnEnv2 (mkInScopeSet (exprFreeVars e1 `unionVarSet` exprFreeVars e2))
1255 tcEqExprX :: RnEnv2 -> CoreExpr -> CoreExpr -> Bool
1256 tcEqExprX env (Var v1) (Var v2) = rnOccL env v1 == rnOccR env v2
1257 tcEqExprX env (Lit lit1) (Lit lit2) = lit1 == lit2
1258 tcEqExprX env (App f1 a1) (App f2 a2) = tcEqExprX env f1 f2 && tcEqExprX env a1 a2
1259 tcEqExprX env (Lam v1 e1) (Lam v2 e2) = tcEqExprX (rnBndr2 env v1 v2) e1 e2
1260 tcEqExprX env (Let (NonRec v1 r1) e1)
1261 (Let (NonRec v2 r2) e2) = tcEqExprX env r1 r2
1262 && tcEqExprX (rnBndr2 env v1 v2) e1 e2
1263 tcEqExprX env (Let (Rec ps1) e1)
1264 (Let (Rec ps2) e2) = equalLength ps1 ps2
1265 && and (zipWith eq_rhs ps1 ps2)
1266 && tcEqExprX env' e1 e2
1268 env' = foldl2 rn_bndr2 env ps2 ps2
1269 rn_bndr2 env (b1,_) (b2,_) = rnBndr2 env b1 b2
1270 eq_rhs (_,r1) (_,r2) = tcEqExprX env' r1 r2
1271 tcEqExprX env (Case e1 v1 t1 a1)
1272 (Case e2 v2 t2 a2) = tcEqExprX env e1 e2
1273 && tcEqTypeX env t1 t2
1274 && equalLength a1 a2
1275 && and (zipWith (eq_alt env') a1 a2)
1277 env' = rnBndr2 env v1 v2
1279 tcEqExprX env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && tcEqExprX env e1 e2
1280 tcEqExprX env (Cast e1 co1) (Cast e2 co2) = tcEqTypeX env co1 co2 && tcEqExprX env e1 e2
1281 tcEqExprX env (Type t1) (Type t2) = tcEqTypeX env t1 t2
1282 tcEqExprX env e1 e2 = False
1284 eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 && tcEqExprX (rnBndrs2 env vs1 vs2) r1 r2
1286 eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2
1287 eq_note env (CoreNote s1) (CoreNote s2) = s1 == s2
1288 eq_note env other1 other2 = False
1292 %************************************************************************
1294 \subsection{The size of an expression}
1296 %************************************************************************
1299 coreBindsSize :: [CoreBind] -> Int
1300 coreBindsSize bs = foldr ((+) . bindSize) 0 bs
1302 exprSize :: CoreExpr -> Int
1303 -- A measure of the size of the expressions
1304 -- It also forces the expression pretty drastically as a side effect
1305 exprSize (Var v) = v `seq` 1
1306 exprSize (Lit lit) = lit `seq` 1
1307 exprSize (App f a) = exprSize f + exprSize a
1308 exprSize (Lam b e) = varSize b + exprSize e
1309 exprSize (Let b e) = bindSize b + exprSize e
1310 exprSize (Case e b t as) = seqType t `seq` exprSize e + varSize b + 1 + foldr ((+) . altSize) 0 as
1311 exprSize (Cast e co) = (seqType co `seq` 1) + exprSize e
1312 exprSize (Note n e) = noteSize n + exprSize e
1313 exprSize (Type t) = seqType t `seq` 1
1315 noteSize (SCC cc) = cc `seq` 1
1316 noteSize InlineMe = 1
1317 noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations
1319 varSize :: Var -> Int
1320 varSize b | isTyVar b = 1
1321 | otherwise = seqType (idType b) `seq`
1322 megaSeqIdInfo (idInfo b) `seq`
1325 varsSize = foldr ((+) . varSize) 0
1327 bindSize (NonRec b e) = varSize b + exprSize e
1328 bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs
1330 pairSize (b,e) = varSize b + exprSize e
1332 altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
1336 %************************************************************************
1338 \subsection{Hashing}
1340 %************************************************************************
1343 hashExpr :: CoreExpr -> Int
1344 -- Two expressions that hash to the same Int may be equal (but may not be)
1345 -- Two expressions that hash to the different Ints are definitely unequal
1347 -- But "unequal" here means "not identical"; two alpha-equivalent
1348 -- expressions may hash to the different Ints
1350 -- The emphasis is on a crude, fast hash, rather than on high precision
1352 hashExpr e | hash < 0 = 77 -- Just in case we hit -maxInt
1355 hash = abs (hash_expr e) -- Negative numbers kill UniqFM
1357 hash_expr (Note _ e) = hash_expr e
1358 hash_expr (Cast e co) = hash_expr e
1359 hash_expr (Let (NonRec b r) e) = hashId b
1360 hash_expr (Let (Rec ((b,r):_)) e) = hashId b
1361 hash_expr (Case _ b _ _) = hashId b
1362 hash_expr (App f e) = hash_expr f * fast_hash_expr e
1363 hash_expr (Var v) = hashId v
1364 hash_expr (Lit lit) = hashLiteral lit
1365 hash_expr (Lam b _) = hashId b
1366 hash_expr (Type t) = trace "hash_expr: type" 1 -- Shouldn't happen
1368 fast_hash_expr (Var v) = hashId v
1369 fast_hash_expr (Lit lit) = hashLiteral lit
1370 fast_hash_expr (App f (Type _)) = fast_hash_expr f
1371 fast_hash_expr (App f a) = fast_hash_expr a
1372 fast_hash_expr (Lam b _) = hashId b
1373 fast_hash_expr other = 1
1376 hashId id = hashName (idName id)
1379 %************************************************************************
1381 \subsection{Determining non-updatable right-hand-sides}
1383 %************************************************************************
1385 Top-level constructor applications can usually be allocated
1386 statically, but they can't if the constructor, or any of the
1387 arguments, come from another DLL (because we can't refer to static
1388 labels in other DLLs).
1390 If this happens we simply make the RHS into an updatable thunk,
1391 and 'exectute' it rather than allocating it statically.
1394 rhsIsStatic :: PackageId -> CoreExpr -> Bool
1395 -- This function is called only on *top-level* right-hand sides
1396 -- Returns True if the RHS can be allocated statically, with
1397 -- no thunks involved at all.
1399 -- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or
1400 -- refers to, CAFs; and (ii) in CoreToStg to decide whether to put an
1401 -- update flag on it.
1403 -- The basic idea is that rhsIsStatic returns True only if the RHS is
1404 -- (a) a value lambda
1405 -- (b) a saturated constructor application with static args
1407 -- BUT watch out for
1408 -- (i) Any cross-DLL references kill static-ness completely
1409 -- because they must be 'executed' not statically allocated
1410 -- ("DLL" here really only refers to Windows DLLs, on other platforms,
1411 -- this is not necessary)
1413 -- (ii) We treat partial applications as redexes, because in fact we
1414 -- make a thunk for them that runs and builds a PAP
1415 -- at run-time. The only appliations that are treated as
1416 -- static are *saturated* applications of constructors.
1418 -- We used to try to be clever with nested structures like this:
1419 -- ys = (:) w ((:) w [])
1420 -- on the grounds that CorePrep will flatten ANF-ise it later.
1421 -- But supporting this special case made the function much more
1422 -- complicated, because the special case only applies if there are no
1423 -- enclosing type lambdas:
1424 -- ys = /\ a -> Foo (Baz ([] a))
1425 -- Here the nested (Baz []) won't float out to top level in CorePrep.
1427 -- But in fact, even without -O, nested structures at top level are
1428 -- flattened by the simplifier, so we don't need to be super-clever here.
1432 -- f = \x::Int. x+7 TRUE
1433 -- p = (True,False) TRUE
1435 -- d = (fst p, False) FALSE because there's a redex inside
1436 -- (this particular one doesn't happen but...)
1438 -- h = D# (1.0## /## 2.0##) FALSE (redex again)
1439 -- n = /\a. Nil a TRUE
1441 -- t = /\a. (:) (case w a of ...) (Nil a) FALSE (redex)
1444 -- This is a bit like CoreUtils.exprIsHNF, with the following differences:
1445 -- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
1447 -- b) (C x xs), where C is a contructors is updatable if the application is
1450 -- c) don't look through unfolding of f in (f x).
1452 -- When opt_RuntimeTypes is on, we keep type lambdas and treat
1453 -- them as making the RHS re-entrant (non-updatable).
1455 rhsIsStatic this_pkg rhs = is_static False rhs
1457 is_static :: Bool -- True <=> in a constructor argument; must be atomic
1460 is_static False (Lam b e) = isRuntimeVar b || is_static False e
1462 is_static in_arg (Note (SCC _) e) = False
1463 is_static in_arg (Note _ e) = is_static in_arg e
1464 is_static in_arg (Cast e co) = is_static in_arg e
1466 is_static in_arg (Lit lit)
1468 MachLabel _ _ -> False
1470 -- A MachLabel (foreign import "&foo") in an argument
1471 -- prevents a constructor application from being static. The
1472 -- reason is that it might give rise to unresolvable symbols
1473 -- in the object file: under Linux, references to "weak"
1474 -- symbols from the data segment give rise to "unresolvable
1475 -- relocation" errors at link time This might be due to a bug
1476 -- in the linker, but we'll work around it here anyway.
1479 is_static in_arg other_expr = go other_expr 0
1481 go (Var f) n_val_args
1482 #if mingw32_TARGET_OS
1483 | not (isDllName this_pkg (idName f))
1485 = saturated_data_con f n_val_args
1486 || (in_arg && n_val_args == 0)
1487 -- A naked un-applied variable is *not* deemed a static RHS
1489 -- Reason: better to update so that the indirection gets shorted
1490 -- out, and the true value will be seen
1491 -- NB: if you change this, you'll break the invariant that THUNK_STATICs
1492 -- are always updatable. If you do so, make sure that non-updatable
1493 -- ones have enough space for their static link field!
1495 go (App f a) n_val_args
1496 | isTypeArg a = go f n_val_args
1497 | not in_arg && is_static True a = go f (n_val_args + 1)
1498 -- The (not in_arg) checks that we aren't in a constructor argument;
1499 -- if we are, we don't allow (value) applications of any sort
1501 -- NB. In case you wonder, args are sometimes not atomic. eg.
1502 -- x = D# (1.0## /## 2.0##)
1503 -- can't float because /## can fail.
1505 go (Note (SCC _) f) n_val_args = False
1506 go (Note _ f) n_val_args = go f n_val_args
1507 go (Cast e co) n_val_args = go e n_val_args
1509 go other n_val_args = False
1511 saturated_data_con f n_val_args
1512 = case isDataConWorkId_maybe f of
1513 Just dc -> n_val_args == dataConRepArity dc