2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 Utility functions on @Core@ syntax
9 {-# OPTIONS -fno-warn-incomplete-patterns #-}
10 -- The above warning supression flag is a temporary kludge.
11 -- While working on this module you are encouraged to remove it and fix
12 -- any warnings in the module. See
13 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
16 -- | Commonly useful utilites for manipulating the Core language
18 -- * Constructing expressions
19 mkInlineMe, mkSCC, mkCoerce, mkCoerceI,
20 bindNonRec, needsCaseBinding,
21 mkAltExpr, mkPiType, mkPiTypes,
23 -- * Taking expressions apart
24 findDefault, findAlt, isDefaultAlt, mergeAlts, trimConArgs,
26 -- * Properties of expressions
27 exprType, coreAltType, coreAltsType,
28 exprIsDupable, exprIsTrivial, exprIsCheap, exprIsExpandable,
29 exprIsHNF,exprOkForSpeculation, exprIsBig,
30 exprIsConApp_maybe, exprIsBottom,
33 -- * Expression and bindings size
34 coreBindsSize, exprSize,
42 -- * Manipulating data constructors and types
43 applyTypeToArgs, applyTypeToArg,
44 dataConOrigInstPat, dataConRepInstPat, dataConRepFSInstPat
47 #include "HsVersions.h"
81 %************************************************************************
83 \subsection{Find the type of a Core atom/expression}
85 %************************************************************************
88 exprType :: CoreExpr -> Type
89 -- ^ Recover the type of a well-typed Core expression. Fails when
90 -- applied to the actual 'CoreSyn.Type' expression as it cannot
91 -- really be said to have a type
92 exprType (Var var) = idType var
93 exprType (Lit lit) = literalType lit
94 exprType (Let _ body) = exprType body
95 exprType (Case _ _ ty _) = ty
96 exprType (Cast _ co) = snd (coercionKind co)
97 exprType (Note _ e) = exprType e
98 exprType (Lam binder expr) = mkPiType binder (exprType expr)
100 = case collectArgs e of
101 (fun, args) -> applyTypeToArgs e (exprType fun) args
103 exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
105 coreAltType :: CoreAlt -> Type
106 -- ^ Returns the type of the alternatives right hand side
107 coreAltType (_,bs,rhs)
108 | any bad_binder bs = expandTypeSynonyms ty
109 | otherwise = ty -- Note [Existential variables and silly type synonyms]
112 free_tvs = tyVarsOfType ty
113 bad_binder b = isTyVar b && b `elemVarSet` free_tvs
115 coreAltsType :: [CoreAlt] -> Type
116 -- ^ Returns the type of the first alternative, which should be the same as for all alternatives
117 coreAltsType (alt:_) = coreAltType alt
118 coreAltsType [] = panic "corAltsType"
121 Note [Existential variables and silly type synonyms]
122 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
124 data T = forall a. T (Funny a)
129 Now, the type of 'x' is (Funny a), where 'a' is existentially quantified.
130 That means that 'exprType' and 'coreAltsType' may give a result that *appears*
131 to mention an out-of-scope type variable. See Trac #3409 for a more real-world
134 Various possibilities suggest themselves:
136 - Ignore the problem, and make Lint not complain about such variables
138 - Expand all type synonyms (or at least all those that discard arguments)
139 This is tricky, because at least for top-level things we want to
140 retain the type the user originally specified.
142 - Expand synonyms on the fly, when the problem arises. That is what
143 we are doing here. It's not too expensive, I think.
146 mkPiType :: Var -> Type -> Type
147 -- ^ Makes a @(->)@ type or a forall type, depending
148 -- on whether it is given a type variable or a term variable.
149 mkPiTypes :: [Var] -> Type -> Type
150 -- ^ 'mkPiType' for multiple type or value arguments
153 | isId v = mkFunTy (idType v) ty
154 | otherwise = mkForAllTy v ty
156 mkPiTypes vs ty = foldr mkPiType ty vs
160 applyTypeToArg :: Type -> CoreExpr -> Type
161 -- ^ Determines the type resulting from applying an expression to a function with the given type
162 applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty
163 applyTypeToArg fun_ty _ = funResultTy fun_ty
165 applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
166 -- ^ A more efficient version of 'applyTypeToArg' when we have several arguments.
167 -- The first argument is just for debugging, and gives some context
168 applyTypeToArgs _ op_ty [] = op_ty
170 applyTypeToArgs e op_ty (Type ty : args)
171 = -- Accumulate type arguments so we can instantiate all at once
174 go rev_tys (Type ty : args) = go (ty:rev_tys) args
175 go rev_tys rest_args = applyTypeToArgs e op_ty' rest_args
177 op_ty' = applyTysD msg op_ty (reverse rev_tys)
178 msg = ptext (sLit "applyTypeToArgs") <+>
181 applyTypeToArgs e op_ty (_ : args)
182 = case (splitFunTy_maybe op_ty) of
183 Just (_, res_ty) -> applyTypeToArgs e res_ty args
184 Nothing -> pprPanic "applyTypeToArgs" (panic_msg e op_ty)
186 panic_msg :: CoreExpr -> Type -> SDoc
187 panic_msg e op_ty = pprCoreExpr e $$ ppr op_ty
190 %************************************************************************
192 \subsection{Attaching notes}
194 %************************************************************************
196 mkNote removes redundant coercions, and SCCs where possible
200 mkNote :: Note -> CoreExpr -> CoreExpr
201 mkNote (SCC cc) expr = mkSCC cc expr
202 mkNote InlineMe expr = mkInlineMe expr
203 mkNote note expr = Note note expr
207 Drop trivial InlineMe's. This is somewhat important, because if we have an unfolding
208 that looks like (Note InlineMe (Var v)), the InlineMe doesn't go away because it may
209 not be *applied* to anything.
211 We don't use exprIsTrivial here, though, because we sometimes generate worker/wrapper
214 f = inline_me (coerce t fw)
215 As usual, the inline_me prevents the worker from getting inlined back into the wrapper.
216 We want the split, so that the coerces can cancel at the call site.
218 However, we can get left with tiresome type applications. Notably, consider
219 f = /\ a -> let t = e in (t, w)
220 Then lifting the let out of the big lambda gives
222 f = /\ a -> let t = inline_me (t' a) in (t, w)
223 The inline_me is to stop the simplifier inlining t' right back
224 into t's RHS. In the next phase we'll substitute for t (since
225 its rhs is trivial) and *then* we could get rid of the inline_me.
226 But it hardly seems worth it, so I don't bother.
229 -- | Wraps the given expression in an inlining hint unless the expression
230 -- is trivial in some sense, so that doing so would usually hurt us
231 mkInlineMe :: CoreExpr -> CoreExpr
232 mkInlineMe e@(Var _) = e
233 mkInlineMe e@(Note InlineMe _) = e
234 mkInlineMe e = Note InlineMe e
238 -- | Wrap the given expression in the coercion, dropping identity coercions and coalescing nested coercions
239 mkCoerceI :: CoercionI -> CoreExpr -> CoreExpr
241 mkCoerceI (ACo co) e = mkCoerce co e
243 -- | Wrap the given expression in the coercion safely, coalescing nested coercions
244 mkCoerce :: Coercion -> CoreExpr -> CoreExpr
245 mkCoerce co (Cast expr co2)
246 = ASSERT(let { (from_ty, _to_ty) = coercionKind co;
247 (_from_ty2, to_ty2) = coercionKind co2} in
248 from_ty `coreEqType` to_ty2 )
249 mkCoerce (mkTransCoercion co2 co) expr
252 = let (from_ty, _to_ty) = coercionKind co in
253 -- if to_ty `coreEqType` from_ty
256 ASSERT2(from_ty `coreEqType` (exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ ppr (coercionKindPredTy co))
261 -- | Wraps the given expression in the cost centre unless
262 -- in a way that maximises their utility to the user
263 mkSCC :: CostCentre -> Expr b -> Expr b
264 -- Note: Nested SCC's *are* preserved for the benefit of
265 -- cost centre stack profiling
266 mkSCC _ (Lit lit) = Lit lit
267 mkSCC cc (Lam x e) = Lam x (mkSCC cc e) -- Move _scc_ inside lambda
268 mkSCC cc (Note (SCC cc') e) = Note (SCC cc) (Note (SCC cc') e)
269 mkSCC cc (Note n e) = Note n (mkSCC cc e) -- Move _scc_ inside notes
270 mkSCC cc (Cast e co) = Cast (mkSCC cc e) co -- Move _scc_ inside cast
271 mkSCC cc expr = Note (SCC cc) expr
275 %************************************************************************
277 \subsection{Other expression construction}
279 %************************************************************************
282 bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
283 -- ^ @bindNonRec x r b@ produces either:
289 -- > case r of x { _DEFAULT_ -> b }
291 -- depending on whether we have to use a @case@ or @let@
292 -- binding for the expression (see 'needsCaseBinding').
293 -- It's used by the desugarer to avoid building bindings
294 -- that give Core Lint a heart attack, although actually
295 -- the simplifier deals with them perfectly well. See
296 -- also 'MkCore.mkCoreLet'
297 bindNonRec bndr rhs body
298 | needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
299 | otherwise = Let (NonRec bndr rhs) body
301 -- | Tests whether we have to use a @case@ rather than @let@ binding for this expression
302 -- as per the invariants of 'CoreExpr': see "CoreSyn#let_app_invariant"
303 needsCaseBinding :: Type -> CoreExpr -> Bool
304 needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
305 -- Make a case expression instead of a let
306 -- These can arise either from the desugarer,
307 -- or from beta reductions: (\x.e) (x +# y)
311 mkAltExpr :: AltCon -- ^ Case alternative constructor
312 -> [CoreBndr] -- ^ Things bound by the pattern match
313 -> [Type] -- ^ The type arguments to the case alternative
315 -- ^ This guy constructs the value that the scrutinee must have
316 -- given that you are in one particular branch of a case
317 mkAltExpr (DataAlt con) args inst_tys
318 = mkConApp con (map Type inst_tys ++ varsToCoreExprs args)
319 mkAltExpr (LitAlt lit) [] []
321 mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt"
322 mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT"
326 %************************************************************************
328 \subsection{Taking expressions apart}
330 %************************************************************************
332 The default alternative must be first, if it exists at all.
333 This makes it easy to find, though it makes matching marginally harder.
336 -- | Extract the default case alternative
337 findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
338 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
339 findDefault alts = (alts, Nothing)
341 isDefaultAlt :: CoreAlt -> Bool
342 isDefaultAlt (DEFAULT, _, _) = True
343 isDefaultAlt _ = False
346 -- | Find the case alternative corresponding to a particular
347 -- constructor: panics if no such constructor exists
348 findAlt :: AltCon -> [CoreAlt] -> Maybe CoreAlt
349 -- A "Nothing" result *is* legitmiate
350 -- See Note [Unreachable code]
353 (deflt@(DEFAULT,_,_):alts) -> go alts (Just deflt)
357 go (alt@(con1,_,_) : alts) deflt
358 = case con `cmpAltCon` con1 of
359 LT -> deflt -- Missed it already; the alts are in increasing order
361 GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt
363 ---------------------------------
364 mergeAlts :: [CoreAlt] -> [CoreAlt] -> [CoreAlt]
365 -- ^ Merge alternatives preserving order; alternatives in
366 -- the first argument shadow ones in the second
367 mergeAlts [] as2 = as2
368 mergeAlts as1 [] = as1
369 mergeAlts (a1:as1) (a2:as2)
370 = case a1 `cmpAlt` a2 of
371 LT -> a1 : mergeAlts as1 (a2:as2)
372 EQ -> a1 : mergeAlts as1 as2 -- Discard a2
373 GT -> a2 : mergeAlts (a1:as1) as2
376 ---------------------------------
377 trimConArgs :: AltCon -> [CoreArg] -> [CoreArg]
380 -- > case (C a b x y) of
383 -- We want to drop the leading type argument of the scrutinee
384 -- leaving the arguments to match agains the pattern
386 trimConArgs DEFAULT args = ASSERT( null args ) []
387 trimConArgs (LitAlt _) args = ASSERT( null args ) []
388 trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args
391 Note [Unreachable code]
392 ~~~~~~~~~~~~~~~~~~~~~~~
393 It is possible (although unusual) for GHC to find a case expression
394 that cannot match. For example:
396 data Col = Red | Green | Blue
400 _ -> ...(case x of { Green -> e1; Blue -> e2 })...
402 Suppose that for some silly reason, x isn't substituted in the case
403 expression. (Perhaps there's a NOINLINE on it, or profiling SCC stuff
404 gets in the way; cf Trac #3118.) Then the full-lazines pass might produce
408 lvl = case x of { Green -> e1; Blue -> e2 })
413 Now if x gets inlined, we won't be able to find a matching alternative
414 for 'Red'. That's because 'lvl' is unreachable. So rather than crashing
415 we generate (error "Inaccessible alternative").
417 Similar things can happen (augmented by GADTs) when the Simplifier
418 filters down the matching alternatives in Simplify.rebuildCase.
422 %************************************************************************
424 \subsection{Figuring out things about expressions}
426 %************************************************************************
428 @exprIsTrivial@ is true of expressions we are unconditionally happy to
429 duplicate; simple variables and constants, and type
430 applications. Note that primop Ids aren't considered
433 There used to be a gruesome test for (hasNoBinding v) in the
435 exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
436 The idea here is that a constructor worker, like \$wJust, is
437 really short for (\x -> \$wJust x), becuase \$wJust has no binding.
438 So it should be treated like a lambda. Ditto unsaturated primops.
439 But now constructor workers are not "have-no-binding" Ids. And
440 completely un-applied primops and foreign-call Ids are sufficiently
441 rare that I plan to allow them to be duplicated and put up with
444 SCC notes. We do not treat (_scc_ "foo" x) as trivial, because
445 a) it really generates code, (and a heap object when it's
446 a function arg) to capture the cost centre
447 b) see the note [SCC-and-exprIsTrivial] in Simplify.simplLazyBind
450 exprIsTrivial :: CoreExpr -> Bool
451 exprIsTrivial (Var _) = True -- See notes above
452 exprIsTrivial (Type _) = True
453 exprIsTrivial (Lit lit) = litIsTrivial lit
454 exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e
455 exprIsTrivial (Note (SCC _) _) = False -- See notes above
456 exprIsTrivial (Note _ e) = exprIsTrivial e
457 exprIsTrivial (Cast e _) = exprIsTrivial e
458 exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body
459 exprIsTrivial _ = False
463 @exprIsDupable@ is true of expressions that can be duplicated at a modest
464 cost in code size. This will only happen in different case
465 branches, so there's no issue about duplicating work.
467 That is, exprIsDupable returns True of (f x) even if
468 f is very very expensive to call.
470 Its only purpose is to avoid fruitless let-binding
471 and then inlining of case join points
475 exprIsDupable :: CoreExpr -> Bool
476 exprIsDupable (Type _) = True
477 exprIsDupable (Var _) = True
478 exprIsDupable (Lit lit) = litIsDupable lit
479 exprIsDupable (Note InlineMe _) = True
480 exprIsDupable (Note _ e) = exprIsDupable e
481 exprIsDupable (Cast e _) = exprIsDupable e
486 go (App f a) n_args = n_args < dupAppSize
492 dupAppSize = 4 -- Size of application we are prepared to duplicate
495 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
496 it is obviously in weak head normal form, or is cheap to get to WHNF.
497 [Note that that's not the same as exprIsDupable; an expression might be
498 big, and hence not dupable, but still cheap.]
500 By ``cheap'' we mean a computation we're willing to:
501 push inside a lambda, or
502 inline at more than one place
503 That might mean it gets evaluated more than once, instead of being
504 shared. The main examples of things which aren't WHNF but are
509 (where e, and all the ei are cheap)
512 (where e and b are cheap)
515 (where op is a cheap primitive operator)
518 (because we are happy to substitute it inside a lambda)
520 Notice that a variable is considered 'cheap': we can push it inside a lambda,
521 because sharing will make sure it is only evaluated once.
524 exprIsCheap' :: (Id -> Bool) -> CoreExpr -> Bool
525 exprIsCheap' _ (Lit _) = True
526 exprIsCheap' _ (Type _) = True
527 exprIsCheap' _ (Var _) = True
528 exprIsCheap' _ (Note InlineMe _) = True
529 exprIsCheap' is_conlike (Note _ e) = exprIsCheap' is_conlike e
530 exprIsCheap' is_conlike (Cast e _) = exprIsCheap' is_conlike e
531 exprIsCheap' is_conlike (Lam x e) = isRuntimeVar x
532 || exprIsCheap' is_conlike e
533 exprIsCheap' is_conlike (Case e _ _ alts) = exprIsCheap' is_conlike e &&
534 and [exprIsCheap' is_conlike rhs | (_,_,rhs) <- alts]
535 -- Experimentally, treat (case x of ...) as cheap
536 -- (and case __coerce x etc.)
537 -- This improves arities of overloaded functions where
538 -- there is only dictionary selection (no construction) involved
539 exprIsCheap' is_conlike (Let (NonRec x _) e)
540 | isUnLiftedType (idType x) = exprIsCheap' is_conlike e
542 -- strict lets always have cheap right hand sides,
543 -- and do no allocation.
545 exprIsCheap' is_conlike other_expr -- Applications and variables
548 -- Accumulate value arguments, then decide
549 go (App f a) val_args | isRuntimeArg a = go f (a:val_args)
550 | otherwise = go f val_args
552 go (Var _) [] = True -- Just a type application of a variable
553 -- (f t1 t2 t3) counts as WHNF
555 = case idDetails f of
556 RecSelId {} -> go_sel args
557 ClassOpId _ -> go_sel args
558 PrimOpId op -> go_primop op args
560 _ | is_conlike f -> go_pap args
561 | length args < idArity f -> go_pap args
564 -- Application of a function which
565 -- always gives bottom; we treat this as cheap
566 -- because it certainly doesn't need to be shared!
571 go_pap args = all exprIsTrivial args
572 -- For constructor applications and primops, check that all
573 -- the args are trivial. We don't want to treat as cheap, say,
575 -- We'll put up with one constructor application, but not dozens
578 go_primop op args = primOpIsCheap op && all (exprIsCheap' is_conlike) args
579 -- In principle we should worry about primops
580 -- that return a type variable, since the result
581 -- might be applied to something, but I'm not going
582 -- to bother to check the number of args
585 go_sel [arg] = exprIsCheap' is_conlike arg -- I'm experimenting with making record selection
586 go_sel _ = False -- look cheap, so we will substitute it inside a
587 -- lambda. Particularly for dictionary field selection.
588 -- BUT: Take care with (sel d x)! The (sel d) might be cheap, but
589 -- there's no guarantee that (sel d x) will be too. Hence (n_val_args == 1)
591 exprIsCheap :: CoreExpr -> Bool
592 exprIsCheap = exprIsCheap' isDataConWorkId
594 exprIsExpandable :: CoreExpr -> Bool
595 exprIsExpandable = exprIsCheap' isConLikeId
599 -- | 'exprOkForSpeculation' returns True of an expression that is:
601 -- * Safe to evaluate even if normal order eval might not
602 -- evaluate the expression at all, or
604 -- * Safe /not/ to evaluate even if normal order would do so
606 -- Precisely, it returns @True@ iff:
608 -- * The expression guarantees to terminate,
612 -- * without raising an exception,
614 -- * without causing a side effect (e.g. writing a mutable variable)
616 -- Note that if @exprIsHNF e@, then @exprOkForSpecuation e@.
617 -- As an example of the considerations in this test, consider:
619 -- > let x = case y# +# 1# of { r# -> I# r# }
622 -- being translated to:
624 -- > case y# +# 1# of { r# ->
629 -- We can only do this if the @y + 1@ is ok for speculation: it has no
630 -- side effects, and can't diverge or raise an exception.
631 exprOkForSpeculation :: CoreExpr -> Bool
632 exprOkForSpeculation (Lit _) = True
633 exprOkForSpeculation (Type _) = True
634 -- Tick boxes are *not* suitable for speculation
635 exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
636 && not (isTickBoxOp v)
637 exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
638 exprOkForSpeculation (Cast e _) = exprOkForSpeculation e
639 exprOkForSpeculation other_expr
640 = case collectArgs other_expr of
641 (Var f, args) -> spec_ok (idDetails f) args
645 spec_ok (DataConWorkId _) _
646 = True -- The strictness of the constructor has already
647 -- been expressed by its "wrapper", so we don't need
648 -- to take the arguments into account
650 spec_ok (PrimOpId op) args
651 | isDivOp op, -- Special case for dividing operations that fail
652 [arg1, Lit lit] <- args -- only if the divisor is zero
653 = not (isZeroLit lit) && exprOkForSpeculation arg1
654 -- Often there is a literal divisor, and this
655 -- can get rid of a thunk in an inner looop
658 = primOpOkForSpeculation op &&
659 all exprOkForSpeculation args
660 -- A bit conservative: we don't really need
661 -- to care about lazy arguments, but this is easy
665 -- | True of dyadic operators that can fail only if the second arg is zero!
666 isDivOp :: PrimOp -> Bool
667 -- This function probably belongs in PrimOp, or even in
668 -- an automagically generated file.. but it's such a
669 -- special case I thought I'd leave it here for now.
670 isDivOp IntQuotOp = True
671 isDivOp IntRemOp = True
672 isDivOp WordQuotOp = True
673 isDivOp WordRemOp = True
674 isDivOp FloatDivOp = True
675 isDivOp DoubleDivOp = True
680 -- | True of expressions that are guaranteed to diverge upon execution
681 exprIsBottom :: CoreExpr -> Bool
682 exprIsBottom e = go 0 e
684 -- n is the number of args
685 go n (Note _ e) = go n e
686 go n (Cast e _) = go n e
687 go n (Let _ e) = go n e
688 go _ (Case e _ _ _) = go 0 e -- Just check the scrut
689 go n (App e _) = go (n+1) e
690 go n (Var v) = idAppIsBottom v n
692 go _ (Lam _ _) = False
693 go _ (Type _) = False
695 idAppIsBottom :: Id -> Int -> Bool
696 idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
701 -- | This returns true for expressions that are certainly /already/
702 -- evaluated to /head/ normal form. This is used to decide whether it's ok
705 -- > case x of _ -> e
711 -- and to decide whether it's safe to discard a 'seq'.
712 -- So, it does /not/ treat variables as evaluated, unless they say they are.
713 -- However, it /does/ treat partial applications and constructor applications
714 -- as values, even if their arguments are non-trivial, provided the argument
715 -- type is lifted. For example, both of these are values:
717 -- > (:) (f x) (map f xs)
718 -- > map (...redex...)
720 -- Because 'seq' on such things completes immediately.
722 -- For unlifted argument types, we have to be careful:
726 -- Suppose @f x@ diverges; then @C (f x)@ is not a value. However this can't
727 -- happen: see "CoreSyn#let_app_invariant". This invariant states that arguments of
728 -- unboxed type must be ok-for-speculation (or trivial).
729 exprIsHNF :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
730 exprIsHNF (Var v) -- NB: There are no value args at this point
731 = isDataConWorkId v -- Catches nullary constructors,
732 -- so that [] and () are values, for example
733 || idArity v > 0 -- Catches (e.g.) primops that don't have unfoldings
734 || isEvaldUnfolding (idUnfolding v)
735 -- Check the thing's unfolding; it might be bound to a value
736 -- A worry: what if an Id's unfolding is just itself:
737 -- then we could get an infinite loop...
739 exprIsHNF (Lit _) = True
740 exprIsHNF (Type _) = True -- Types are honorary Values;
741 -- we don't mind copying them
742 exprIsHNF (Lam b e) = isRuntimeVar b || exprIsHNF e
743 exprIsHNF (Note _ e) = exprIsHNF e
744 exprIsHNF (Cast e _) = exprIsHNF e
745 exprIsHNF (App e (Type _)) = exprIsHNF e
746 exprIsHNF (App e a) = app_is_value e [a]
749 -- There is at least one value argument
750 app_is_value :: CoreExpr -> [CoreArg] -> Bool
751 app_is_value (Var fun) args
752 = idArity fun > valArgCount args -- Under-applied function
753 || isDataConWorkId fun -- or data constructor
754 app_is_value (Note _ f) as = app_is_value f as
755 app_is_value (Cast f _) as = app_is_value f as
756 app_is_value (App f a) as = app_is_value f (a:as)
757 app_is_value _ _ = False
760 These InstPat functions go here to avoid circularity between DataCon and Id
763 dataConRepInstPat, dataConOrigInstPat :: [Unique] -> DataCon -> [Type] -> ([TyVar], [CoVar], [Id])
764 dataConRepFSInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([TyVar], [CoVar], [Id])
766 dataConRepInstPat = dataConInstPat dataConRepArgTys (repeat ((fsLit "ipv")))
767 dataConRepFSInstPat = dataConInstPat dataConRepArgTys
768 dataConOrigInstPat = dataConInstPat dc_arg_tys (repeat ((fsLit "ipv")))
770 dc_arg_tys dc = map mkPredTy (dataConEqTheta dc) ++ map mkPredTy (dataConDictTheta dc) ++ dataConOrigArgTys dc
771 -- Remember to include the existential dictionaries
773 dataConInstPat :: (DataCon -> [Type]) -- function used to find arg tys
774 -> [FastString] -- A long enough list of FSs to use for names
775 -> [Unique] -- An equally long list of uniques, at least one for each binder
777 -> [Type] -- Types to instantiate the universally quantified tyvars
778 -> ([TyVar], [CoVar], [Id]) -- Return instantiated variables
779 -- dataConInstPat arg_fun fss us con inst_tys returns a triple
780 -- (ex_tvs, co_tvs, arg_ids),
782 -- ex_tvs are intended to be used as binders for existential type args
784 -- co_tvs are intended to be used as binders for coercion args and the kinds
785 -- of these vars have been instantiated by the inst_tys and the ex_tys
786 -- The co_tvs include both GADT equalities (dcEqSpec) and
787 -- programmer-specified equalities (dcEqTheta)
789 -- arg_ids are indended to be used as binders for value arguments,
790 -- and their types have been instantiated with inst_tys and ex_tys
791 -- The arg_ids include both dicts (dcDictTheta) and
792 -- programmer-specified arguments (after rep-ing) (deRepArgTys)
795 -- The following constructor T1
798 -- T1 :: forall b. Int -> b -> T(a,b)
801 -- has representation type
802 -- forall a. forall a1. forall b. (a ~ (a1,b)) =>
805 -- dataConInstPat fss us T1 (a1',b') will return
807 -- ([a1'', b''], [c :: (a1', b')~(a1'', b'')], [x :: Int, y :: b''])
809 -- where the double-primed variables are created with the FastStrings and
810 -- Uniques given as fss and us
811 dataConInstPat arg_fun fss uniqs con inst_tys
812 = (ex_bndrs, co_bndrs, arg_ids)
814 univ_tvs = dataConUnivTyVars con
815 ex_tvs = dataConExTyVars con
816 arg_tys = arg_fun con
817 eq_spec = dataConEqSpec con
818 eq_theta = dataConEqTheta con
819 eq_preds = eqSpecPreds eq_spec ++ eq_theta
822 n_co = length eq_preds
824 -- split the Uniques and FastStrings
825 (ex_uniqs, uniqs') = splitAt n_ex uniqs
826 (co_uniqs, id_uniqs) = splitAt n_co uniqs'
828 (ex_fss, fss') = splitAt n_ex fss
829 (co_fss, id_fss) = splitAt n_co fss'
831 -- Make existential type variables
832 ex_bndrs = zipWith3 mk_ex_var ex_uniqs ex_fss ex_tvs
833 mk_ex_var uniq fs var = mkTyVar new_name kind
835 new_name = mkSysTvName uniq fs
838 -- Make the instantiating substitution
839 subst = zipOpenTvSubst (univ_tvs ++ ex_tvs) (inst_tys ++ map mkTyVarTy ex_bndrs)
841 -- Make new coercion vars, instantiating kind
842 co_bndrs = zipWith3 mk_co_var co_uniqs co_fss eq_preds
843 mk_co_var uniq fs eq_pred = mkCoVar new_name co_kind
845 new_name = mkSysTvName uniq fs
846 co_kind = substTy subst (mkPredTy eq_pred)
848 -- make value vars, instantiating types
849 mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (substTy subst ty) noSrcSpan
850 arg_ids = zipWith3 mk_id_var id_uniqs id_fss arg_tys
852 -- | Returns @Just (dc, [x1..xn])@ if the argument expression is
853 -- a constructor application of the form @dc x1 .. xn@
854 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
855 exprIsConApp_maybe (Cast expr co)
856 = -- Here we do the KPush reduction rule as described in the FC paper
857 case exprIsConApp_maybe expr of {
859 Just (dc, dc_args) ->
861 -- The transformation applies iff we have
862 -- (C e1 ... en) `cast` co
863 -- where co :: (T t1 .. tn) ~ (T s1 ..sn)
864 -- That is, with a T at the top of both sides
865 -- The left-hand one must be a T, because exprIsConApp returned True
866 -- but the right-hand one might not be. (Though it usually will.)
868 let (from_ty, to_ty) = coercionKind co
869 (from_tc, from_tc_arg_tys) = splitTyConApp from_ty
870 -- The inner one must be a TyConApp
872 case splitTyConApp_maybe to_ty of {
874 Just (to_tc, to_tc_arg_tys)
875 | from_tc /= to_tc -> Nothing
876 -- These two Nothing cases are possible; we might see
877 -- (C x y) `cast` (g :: T a ~ S [a]),
878 -- where S is a type function. In fact, exprIsConApp
879 -- will probably not be called in such circumstances,
880 -- but there't nothing wrong with it
884 tc_arity = tyConArity from_tc
886 (univ_args, rest1) = splitAt tc_arity dc_args
887 (ex_args, rest2) = splitAt n_ex_tvs rest1
888 (co_args_spec, rest3) = splitAt n_cos_spec rest2
889 (co_args_theta, val_args) = splitAt n_cos_theta rest3
891 arg_tys = dataConRepArgTys dc
892 dc_univ_tyvars = dataConUnivTyVars dc
893 dc_ex_tyvars = dataConExTyVars dc
894 dc_eq_spec = dataConEqSpec dc
895 dc_eq_theta = dataConEqTheta dc
896 dc_tyvars = dc_univ_tyvars ++ dc_ex_tyvars
897 n_ex_tvs = length dc_ex_tyvars
898 n_cos_spec = length dc_eq_spec
899 n_cos_theta = length dc_eq_theta
901 -- Make the "theta" from Fig 3 of the paper
902 gammas = decomposeCo tc_arity co
903 new_tys = gammas ++ map (\ (Type t) -> t) ex_args
904 theta = zipOpenTvSubst dc_tyvars new_tys
906 -- First we cast the existential coercion arguments
907 cast_co_spec (tv, ty) co
908 = cast_co_theta (mkEqPred (mkTyVarTy tv, ty)) co
909 cast_co_theta eqPred (Type co)
910 | (ty1, ty2) <- getEqPredTys eqPred
911 = Type $ mkSymCoercion (substTy theta ty1)
913 `mkTransCoercion` (substTy theta ty2)
914 new_co_args = zipWith cast_co_spec dc_eq_spec co_args_spec ++
915 zipWith cast_co_theta dc_eq_theta co_args_theta
917 -- ...and now value arguments
918 new_val_args = zipWith cast_arg arg_tys val_args
919 cast_arg arg_ty arg = mkCoerce (substTy theta arg_ty) arg
922 ASSERT( length univ_args == tc_arity )
923 ASSERT( from_tc == dataConTyCon dc )
924 ASSERT( and (zipWith coreEqType [t | Type t <- univ_args] from_tc_arg_tys) )
925 ASSERT( all isTypeArg (univ_args ++ ex_args) )
926 ASSERT2( equalLength val_args arg_tys, ppr dc $$ ppr dc_tyvars $$ ppr dc_ex_tyvars $$ ppr arg_tys $$ ppr dc_args $$ ppr univ_args $$ ppr ex_args $$ ppr val_args $$ ppr arg_tys )
928 Just (dc, map Type to_tc_arg_tys ++ ex_args ++ new_co_args ++ new_val_args)
932 -- We do not want to tell the world that we have a
933 -- Cons, to *stop* Case of Known Cons, which removes
935 exprIsConApp_maybe (Note (TickBox {}) expr)
937 exprIsConApp_maybe (Note (BinaryTickBox {}) expr)
941 exprIsConApp_maybe (Note _ expr)
942 = exprIsConApp_maybe expr
943 -- We ignore InlineMe notes in case we have
944 -- x = __inline_me__ (a,b)
945 -- All part of making sure that INLINE pragmas never hurt
946 -- Marcin tripped on this one when making dictionaries more inlinable
948 -- In fact, we ignore all notes. For example,
949 -- case _scc_ "foo" (C a b) of
951 -- should be optimised away, but it will be only if we look
952 -- through the SCC note.
954 exprIsConApp_maybe expr = analyse (collectArgs expr)
956 analyse (Var fun, args)
957 | Just con <- isDataConWorkId_maybe fun,
958 args `lengthAtLeast` dataConRepArity con
959 -- Might be > because the arity excludes type args
962 -- Look through unfoldings, but only cheap ones, because
963 -- we are effectively duplicating the unfolding
964 analyse (Var fun, [])
965 | let unf = idUnfolding fun,
966 isExpandableUnfolding unf
967 = exprIsConApp_maybe (unfoldingTemplate unf)
974 %************************************************************************
976 \subsection{Equality}
978 %************************************************************************
981 -- | A cheap equality test which bales out fast!
982 -- If it returns @True@ the arguments are definitely equal,
983 -- otherwise, they may or may not be equal.
985 -- See also 'exprIsBig'
986 cheapEqExpr :: Expr b -> Expr b -> Bool
988 cheapEqExpr (Var v1) (Var v2) = v1==v2
989 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
990 cheapEqExpr (Type t1) (Type t2) = t1 `coreEqType` t2
992 cheapEqExpr (App f1 a1) (App f2 a2)
993 = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
995 cheapEqExpr (Cast e1 t1) (Cast e2 t2)
996 = e1 `cheapEqExpr` e2 && t1 `coreEqCoercion` t2
998 cheapEqExpr _ _ = False
1000 exprIsBig :: Expr b -> Bool
1001 -- ^ Returns @True@ of expressions that are too big to be compared by 'cheapEqExpr'
1002 exprIsBig (Lit _) = False
1003 exprIsBig (Var _) = False
1004 exprIsBig (Type _) = False
1005 exprIsBig (App f a) = exprIsBig f || exprIsBig a
1006 exprIsBig (Cast e _) = exprIsBig e -- Hopefully coercions are not too big!
1012 %************************************************************************
1014 \subsection{The size of an expression}
1016 %************************************************************************
1019 coreBindsSize :: [CoreBind] -> Int
1020 coreBindsSize bs = foldr ((+) . bindSize) 0 bs
1022 exprSize :: CoreExpr -> Int
1023 -- ^ A measure of the size of the expressions, strictly greater than 0
1024 -- It also forces the expression pretty drastically as a side effect
1025 exprSize (Var v) = v `seq` 1
1026 exprSize (Lit lit) = lit `seq` 1
1027 exprSize (App f a) = exprSize f + exprSize a
1028 exprSize (Lam b e) = varSize b + exprSize e
1029 exprSize (Let b e) = bindSize b + exprSize e
1030 exprSize (Case e b t as) = seqType t `seq` exprSize e + varSize b + 1 + foldr ((+) . altSize) 0 as
1031 exprSize (Cast e co) = (seqType co `seq` 1) + exprSize e
1032 exprSize (Note n e) = noteSize n + exprSize e
1033 exprSize (Type t) = seqType t `seq` 1
1035 noteSize :: Note -> Int
1036 noteSize (SCC cc) = cc `seq` 1
1037 noteSize InlineMe = 1
1038 noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations
1040 varSize :: Var -> Int
1041 varSize b | isTyVar b = 1
1042 | otherwise = seqType (idType b) `seq`
1043 megaSeqIdInfo (idInfo b) `seq`
1046 varsSize :: [Var] -> Int
1047 varsSize = sum . map varSize
1049 bindSize :: CoreBind -> Int
1050 bindSize (NonRec b e) = varSize b + exprSize e
1051 bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs
1053 pairSize :: (Var, CoreExpr) -> Int
1054 pairSize (b,e) = varSize b + exprSize e
1056 altSize :: CoreAlt -> Int
1057 altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
1061 %************************************************************************
1063 \subsection{Hashing}
1065 %************************************************************************
1068 hashExpr :: CoreExpr -> Int
1069 -- ^ Two expressions that hash to the same @Int@ may be equal (but may not be)
1070 -- Two expressions that hash to the different Ints are definitely unequal.
1072 -- The emphasis is on a crude, fast hash, rather than on high precision.
1074 -- But unequal here means \"not identical\"; two alpha-equivalent
1075 -- expressions may hash to the different Ints.
1077 -- We must be careful that @\\x.x@ and @\\y.y@ map to the same hash code,
1078 -- (at least if we want the above invariant to be true).
1080 hashExpr e = fromIntegral (hash_expr (1,emptyVarEnv) e .&. 0x7fffffff)
1081 -- UniqFM doesn't like negative Ints
1083 type HashEnv = (Int, VarEnv Int) -- Hash code for bound variables
1085 hash_expr :: HashEnv -> CoreExpr -> Word32
1086 -- Word32, because we're expecting overflows here, and overflowing
1087 -- signed types just isn't cool. In C it's even undefined.
1088 hash_expr env (Note _ e) = hash_expr env e
1089 hash_expr env (Cast e _) = hash_expr env e
1090 hash_expr env (Var v) = hashVar env v
1091 hash_expr _ (Lit lit) = fromIntegral (hashLiteral lit)
1092 hash_expr env (App f e) = hash_expr env f * fast_hash_expr env e
1093 hash_expr env (Let (NonRec b r) e) = hash_expr (extend_env env b) e * fast_hash_expr env r
1094 hash_expr env (Let (Rec ((b,_):_)) e) = hash_expr (extend_env env b) e
1095 hash_expr env (Case e _ _ _) = hash_expr env e
1096 hash_expr env (Lam b e) = hash_expr (extend_env env b) e
1097 hash_expr _ (Type _) = WARN(True, text "hash_expr: type") 1
1098 -- Shouldn't happen. Better to use WARN than trace, because trace
1099 -- prevents the CPR optimisation kicking in for hash_expr.
1101 fast_hash_expr :: HashEnv -> CoreExpr -> Word32
1102 fast_hash_expr env (Var v) = hashVar env v
1103 fast_hash_expr env (Type t) = fast_hash_type env t
1104 fast_hash_expr _ (Lit lit) = fromIntegral (hashLiteral lit)
1105 fast_hash_expr env (Cast e _) = fast_hash_expr env e
1106 fast_hash_expr env (Note _ e) = fast_hash_expr env e
1107 fast_hash_expr env (App _ a) = fast_hash_expr env a -- A bit idiosyncratic ('a' not 'f')!
1108 fast_hash_expr _ _ = 1
1110 fast_hash_type :: HashEnv -> Type -> Word32
1111 fast_hash_type env ty
1112 | Just tv <- getTyVar_maybe ty = hashVar env tv
1113 | Just (tc,tys) <- splitTyConApp_maybe ty = let hash_tc = fromIntegral (hashName (tyConName tc))
1114 in foldr (\t n -> fast_hash_type env t + n) hash_tc tys
1117 extend_env :: HashEnv -> Var -> (Int, VarEnv Int)
1118 extend_env (n,env) b = (n+1, extendVarEnv env b n)
1120 hashVar :: HashEnv -> Var -> Word32
1122 = fromIntegral (lookupVarEnv env v `orElse` hashName (idName v))
1125 %************************************************************************
1127 \subsection{Determining non-updatable right-hand-sides}
1129 %************************************************************************
1131 Top-level constructor applications can usually be allocated
1132 statically, but they can't if the constructor, or any of the
1133 arguments, come from another DLL (because we can't refer to static
1134 labels in other DLLs).
1136 If this happens we simply make the RHS into an updatable thunk,
1137 and 'execute' it rather than allocating it statically.
1140 -- | This function is called only on *top-level* right-hand sides.
1141 -- Returns @True@ if the RHS can be allocated statically in the output,
1142 -- with no thunks involved at all.
1143 rhsIsStatic :: PackageId -> CoreExpr -> Bool
1144 -- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or
1145 -- refers to, CAFs; (ii) in CoreToStg to decide whether to put an
1146 -- update flag on it and (iii) in DsExpr to decide how to expand
1149 -- The basic idea is that rhsIsStatic returns True only if the RHS is
1150 -- (a) a value lambda
1151 -- (b) a saturated constructor application with static args
1153 -- BUT watch out for
1154 -- (i) Any cross-DLL references kill static-ness completely
1155 -- because they must be 'executed' not statically allocated
1156 -- ("DLL" here really only refers to Windows DLLs, on other platforms,
1157 -- this is not necessary)
1159 -- (ii) We treat partial applications as redexes, because in fact we
1160 -- make a thunk for them that runs and builds a PAP
1161 -- at run-time. The only appliations that are treated as
1162 -- static are *saturated* applications of constructors.
1164 -- We used to try to be clever with nested structures like this:
1165 -- ys = (:) w ((:) w [])
1166 -- on the grounds that CorePrep will flatten ANF-ise it later.
1167 -- But supporting this special case made the function much more
1168 -- complicated, because the special case only applies if there are no
1169 -- enclosing type lambdas:
1170 -- ys = /\ a -> Foo (Baz ([] a))
1171 -- Here the nested (Baz []) won't float out to top level in CorePrep.
1173 -- But in fact, even without -O, nested structures at top level are
1174 -- flattened by the simplifier, so we don't need to be super-clever here.
1178 -- f = \x::Int. x+7 TRUE
1179 -- p = (True,False) TRUE
1181 -- d = (fst p, False) FALSE because there's a redex inside
1182 -- (this particular one doesn't happen but...)
1184 -- h = D# (1.0## /## 2.0##) FALSE (redex again)
1185 -- n = /\a. Nil a TRUE
1187 -- t = /\a. (:) (case w a of ...) (Nil a) FALSE (redex)
1190 -- This is a bit like CoreUtils.exprIsHNF, with the following differences:
1191 -- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
1193 -- b) (C x xs), where C is a contructors is updatable if the application is
1196 -- c) don't look through unfolding of f in (f x).
1198 rhsIsStatic _this_pkg rhs = is_static False rhs
1200 is_static :: Bool -- True <=> in a constructor argument; must be atomic
1203 is_static False (Lam b e) = isRuntimeVar b || is_static False e
1205 is_static _ (Note (SCC _) _) = False
1206 is_static in_arg (Note _ e) = is_static in_arg e
1207 is_static in_arg (Cast e _) = is_static in_arg e
1209 is_static _ (Lit lit)
1211 MachLabel _ _ _ -> False
1213 -- A MachLabel (foreign import "&foo") in an argument
1214 -- prevents a constructor application from being static. The
1215 -- reason is that it might give rise to unresolvable symbols
1216 -- in the object file: under Linux, references to "weak"
1217 -- symbols from the data segment give rise to "unresolvable
1218 -- relocation" errors at link time This might be due to a bug
1219 -- in the linker, but we'll work around it here anyway.
1222 is_static in_arg other_expr = go other_expr 0
1224 go (Var f) n_val_args
1225 #if mingw32_TARGET_OS
1226 | not (isDllName _this_pkg (idName f))
1228 = saturated_data_con f n_val_args
1229 || (in_arg && n_val_args == 0)
1230 -- A naked un-applied variable is *not* deemed a static RHS
1232 -- Reason: better to update so that the indirection gets shorted
1233 -- out, and the true value will be seen
1234 -- NB: if you change this, you'll break the invariant that THUNK_STATICs
1235 -- are always updatable. If you do so, make sure that non-updatable
1236 -- ones have enough space for their static link field!
1238 go (App f a) n_val_args
1239 | isTypeArg a = go f n_val_args
1240 | not in_arg && is_static True a = go f (n_val_args + 1)
1241 -- The (not in_arg) checks that we aren't in a constructor argument;
1242 -- if we are, we don't allow (value) applications of any sort
1244 -- NB. In case you wonder, args are sometimes not atomic. eg.
1245 -- x = D# (1.0## /## 2.0##)
1246 -- can't float because /## can fail.
1248 go (Note (SCC _) _) _ = False
1249 go (Note _ f) n_val_args = go f n_val_args
1250 go (Cast e _) n_val_args = go e n_val_args
1254 saturated_data_con f n_val_args
1255 = case isDataConWorkId_maybe f of
1256 Just dc -> n_val_args == dataConRepArity dc