2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 Utility functions on @Core@ syntax
11 mkInlineMe, mkSCC, mkCoerce,
12 bindNonRec, needsCaseBinding,
13 mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,
15 -- Taking expressions apart
16 findDefault, findAlt, isDefaultAlt, mergeAlts, trimConArgs,
18 -- Properties of expressions
19 exprType, coreAltType,
20 exprIsDupable, exprIsTrivial, exprIsCheap,
21 exprIsHNF,exprOkForSpeculation, exprIsBig,
22 exprIsConApp_maybe, exprIsBottom,
25 -- Arity and eta expansion
26 manifestArity, exprArity,
27 exprEtaExpandArity, etaExpand,
36 cheapEqExpr, tcEqExpr, tcEqExprX, applyTypeToArgs, applyTypeToArg,
38 dataConOrigInstPat, dataConRepInstPat, dataConRepFSInstPat
41 #include "HsVersions.h"
77 import GHC.Exts -- For `xori`
81 %************************************************************************
83 \subsection{Find the type of a Core atom/expression}
85 %************************************************************************
88 exprType :: CoreExpr -> Type
90 exprType (Var var) = idType var
91 exprType (Lit lit) = literalType lit
92 exprType (Let _ body) = exprType body
93 exprType (Case _ _ ty alts) = ty
94 exprType (Cast e co) = snd (coercionKind co)
95 exprType (Note other_note e) = exprType e
96 exprType (Lam binder expr) = mkPiType binder (exprType expr)
98 = case collectArgs e of
99 (fun, args) -> applyTypeToArgs e (exprType fun) args
101 exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
103 coreAltType :: CoreAlt -> Type
104 coreAltType (_,_,rhs) = exprType rhs
107 @mkPiType@ makes a (->) type or a forall type, depending on whether
108 it is given a type variable or a term variable. We cleverly use the
109 lbvarinfo field to figure out the right annotation for the arrove in
110 case of a term variable.
113 mkPiType :: Var -> Type -> Type -- The more polymorphic version
114 mkPiTypes :: [Var] -> Type -> Type -- doesn't work...
116 mkPiTypes vs ty = foldr mkPiType ty vs
119 | isId v = mkFunTy (idType v) ty
120 | otherwise = mkForAllTy v ty
124 applyTypeToArg :: Type -> CoreExpr -> Type
125 applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty
126 applyTypeToArg fun_ty other_arg = funResultTy fun_ty
128 applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
129 -- A more efficient version of applyTypeToArg
130 -- when we have several args
131 -- The first argument is just for debugging
132 applyTypeToArgs e op_ty [] = op_ty
134 applyTypeToArgs e op_ty (Type ty : args)
135 = -- Accumulate type arguments so we can instantiate all at once
138 go rev_tys (Type ty : args) = go (ty:rev_tys) args
139 go rev_tys rest_args = applyTypeToArgs e op_ty' rest_args
141 op_ty' = applyTys op_ty (reverse rev_tys)
143 applyTypeToArgs e op_ty (other_arg : args)
144 = case (splitFunTy_maybe op_ty) of
145 Just (_, res_ty) -> applyTypeToArgs e res_ty args
146 Nothing -> pprPanic "applyTypeToArgs" (pprCoreExpr e $$ ppr op_ty)
151 %************************************************************************
153 \subsection{Attaching notes}
155 %************************************************************************
157 mkNote removes redundant coercions, and SCCs where possible
161 mkNote :: Note -> CoreExpr -> CoreExpr
162 mkNote (SCC cc) expr = mkSCC cc expr
163 mkNote InlineMe expr = mkInlineMe expr
164 mkNote note expr = Note note expr
168 Drop trivial InlineMe's. This is somewhat important, because if we have an unfolding
169 that looks like (Note InlineMe (Var v)), the InlineMe doesn't go away because it may
170 not be *applied* to anything.
172 We don't use exprIsTrivial here, though, because we sometimes generate worker/wrapper
175 f = inline_me (coerce t fw)
176 As usual, the inline_me prevents the worker from getting inlined back into the wrapper.
177 We want the split, so that the coerces can cancel at the call site.
179 However, we can get left with tiresome type applications. Notably, consider
180 f = /\ a -> let t = e in (t, w)
181 Then lifting the let out of the big lambda gives
183 f = /\ a -> let t = inline_me (t' a) in (t, w)
184 The inline_me is to stop the simplifier inlining t' right back
185 into t's RHS. In the next phase we'll substitute for t (since
186 its rhs is trivial) and *then* we could get rid of the inline_me.
187 But it hardly seems worth it, so I don't bother.
190 mkInlineMe (Var v) = Var v
191 mkInlineMe e = Note InlineMe e
197 mkCoerce :: Coercion -> CoreExpr -> CoreExpr
198 mkCoerce co (Cast expr co2)
199 = ASSERT(let { (from_ty, _to_ty) = coercionKind co;
200 (_from_ty2, to_ty2) = coercionKind co2} in
201 from_ty `coreEqType` to_ty2 )
202 mkCoerce (mkTransCoercion co2 co) expr
205 = let (from_ty, to_ty) = coercionKind co in
206 -- if to_ty `coreEqType` from_ty
209 ASSERT2(from_ty `coreEqType` (exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ ppr (coercionKindPredTy co))
214 mkSCC :: CostCentre -> Expr b -> Expr b
215 -- Note: Nested SCC's *are* preserved for the benefit of
216 -- cost centre stack profiling
217 mkSCC cc (Lit lit) = Lit lit
218 mkSCC cc (Lam x e) = Lam x (mkSCC cc e) -- Move _scc_ inside lambda
219 mkSCC cc (Note (SCC cc') e) = Note (SCC cc) (Note (SCC cc') e)
220 mkSCC cc (Note n e) = Note n (mkSCC cc e) -- Move _scc_ inside notes
221 mkSCC cc (Cast e co) = Cast (mkSCC cc e) co -- Move _scc_ inside cast
222 mkSCC cc expr = Note (SCC cc) expr
226 %************************************************************************
228 \subsection{Other expression construction}
230 %************************************************************************
233 bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
234 -- (bindNonRec x r b) produces either
237 -- case r of x { _DEFAULT_ -> b }
239 -- depending on whether x is unlifted or not
240 -- It's used by the desugarer to avoid building bindings
241 -- that give Core Lint a heart attack. Actually the simplifier
242 -- deals with them perfectly well.
244 bindNonRec bndr rhs body
245 | needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT,[],body)]
246 | otherwise = Let (NonRec bndr rhs) body
248 needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
249 -- Make a case expression instead of a let
250 -- These can arise either from the desugarer,
251 -- or from beta reductions: (\x.e) (x +# y)
255 mkAltExpr :: AltCon -> [CoreBndr] -> [Type] -> CoreExpr
256 -- This guy constructs the value that the scrutinee must have
257 -- when you are in one particular branch of a case
258 mkAltExpr (DataAlt con) args inst_tys
259 = mkConApp con (map Type inst_tys ++ varsToCoreExprs args)
260 mkAltExpr (LitAlt lit) [] []
262 mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt"
263 mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT"
265 mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
266 mkIfThenElse guard then_expr else_expr
267 -- Not going to be refining, so okay to take the type of the "then" clause
268 = Case guard (mkWildId boolTy) (exprType then_expr)
269 [ (DataAlt falseDataCon, [], else_expr), -- Increasing order of tag!
270 (DataAlt trueDataCon, [], then_expr) ]
274 %************************************************************************
276 \subsection{Taking expressions apart}
278 %************************************************************************
280 The default alternative must be first, if it exists at all.
281 This makes it easy to find, though it makes matching marginally harder.
284 findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
285 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
286 findDefault alts = (alts, Nothing)
288 findAlt :: AltCon -> [CoreAlt] -> CoreAlt
291 (deflt@(DEFAULT,_,_):alts) -> go alts deflt
292 other -> go alts panic_deflt
294 panic_deflt = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
297 go (alt@(con1,_,_) : alts) deflt
298 = case con `cmpAltCon` con1 of
299 LT -> deflt -- Missed it already; the alts are in increasing order
301 GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt
303 isDefaultAlt :: CoreAlt -> Bool
304 isDefaultAlt (DEFAULT, _, _) = True
305 isDefaultAlt other = False
307 ---------------------------------
308 mergeAlts :: [CoreAlt] -> [CoreAlt] -> [CoreAlt]
309 -- Merge preserving order; alternatives in the first arg
310 -- shadow ones in the second
311 mergeAlts [] as2 = as2
312 mergeAlts as1 [] = as1
313 mergeAlts (a1:as1) (a2:as2)
314 = case a1 `cmpAlt` a2 of
315 LT -> a1 : mergeAlts as1 (a2:as2)
316 EQ -> a1 : mergeAlts as1 as2 -- Discard a2
317 GT -> a2 : mergeAlts (a1:as1) as2
320 ---------------------------------
321 trimConArgs :: AltCon -> [CoreArg] -> [CoreArg]
322 -- Given case (C a b x y) of
324 -- we want to drop the leading type argument of the scrutinee
325 -- leaving the arguments to match agains the pattern
327 trimConArgs DEFAULT args = ASSERT( null args ) []
328 trimConArgs (LitAlt lit) args = ASSERT( null args ) []
329 trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args
333 %************************************************************************
335 \subsection{Figuring out things about expressions}
337 %************************************************************************
339 @exprIsTrivial@ is true of expressions we are unconditionally happy to
340 duplicate; simple variables and constants, and type
341 applications. Note that primop Ids aren't considered
344 @exprIsBottom@ is true of expressions that are guaranteed to diverge
347 There used to be a gruesome test for (hasNoBinding v) in the
349 exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
350 The idea here is that a constructor worker, like $wJust, is
351 really short for (\x -> $wJust x), becuase $wJust has no binding.
352 So it should be treated like a lambda. Ditto unsaturated primops.
353 But now constructor workers are not "have-no-binding" Ids. And
354 completely un-applied primops and foreign-call Ids are sufficiently
355 rare that I plan to allow them to be duplicated and put up with
358 SCC notes. We do not treat (_scc_ "foo" x) as trivial, because
359 a) it really generates code, (and a heap object when it's
360 a function arg) to capture the cost centre
361 b) see the note [SCC-and-exprIsTrivial] in Simplify.simplLazyBind
364 exprIsTrivial (Var v) = True -- See notes above
365 exprIsTrivial (Type _) = True
366 exprIsTrivial (Lit lit) = litIsTrivial lit
367 exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e
368 exprIsTrivial (Note (SCC _) e) = False -- See notes above
369 exprIsTrivial (Note _ e) = exprIsTrivial e
370 exprIsTrivial (Cast e co) = exprIsTrivial e
371 exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body
372 exprIsTrivial other = False
376 @exprIsDupable@ is true of expressions that can be duplicated at a modest
377 cost in code size. This will only happen in different case
378 branches, so there's no issue about duplicating work.
380 That is, exprIsDupable returns True of (f x) even if
381 f is very very expensive to call.
383 Its only purpose is to avoid fruitless let-binding
384 and then inlining of case join points
388 exprIsDupable (Type _) = True
389 exprIsDupable (Var v) = True
390 exprIsDupable (Lit lit) = litIsDupable lit
391 exprIsDupable (Note InlineMe e) = True
392 exprIsDupable (Note _ e) = exprIsDupable e
393 exprIsDupable (Cast e co) = exprIsDupable e
397 go (Var v) n_args = True
398 go (App f a) n_args = n_args < dupAppSize
401 go other n_args = False
404 dupAppSize = 4 -- Size of application we are prepared to duplicate
407 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
408 it is obviously in weak head normal form, or is cheap to get to WHNF.
409 [Note that that's not the same as exprIsDupable; an expression might be
410 big, and hence not dupable, but still cheap.]
412 By ``cheap'' we mean a computation we're willing to:
413 push inside a lambda, or
414 inline at more than one place
415 That might mean it gets evaluated more than once, instead of being
416 shared. The main examples of things which aren't WHNF but are
421 (where e, and all the ei are cheap)
424 (where e and b are cheap)
427 (where op is a cheap primitive operator)
430 (because we are happy to substitute it inside a lambda)
432 Notice that a variable is considered 'cheap': we can push it inside a lambda,
433 because sharing will make sure it is only evaluated once.
436 exprIsCheap :: CoreExpr -> Bool
437 exprIsCheap (Lit lit) = True
438 exprIsCheap (Type _) = True
439 exprIsCheap (Var _) = True
440 exprIsCheap (Note InlineMe e) = True
441 exprIsCheap (Note _ e) = exprIsCheap e
442 exprIsCheap (Cast e co) = exprIsCheap e
443 exprIsCheap (Lam x e) = isRuntimeVar x || exprIsCheap e
444 exprIsCheap (Case e _ _ alts) = exprIsCheap e &&
445 and [exprIsCheap rhs | (_,_,rhs) <- alts]
446 -- Experimentally, treat (case x of ...) as cheap
447 -- (and case __coerce x etc.)
448 -- This improves arities of overloaded functions where
449 -- there is only dictionary selection (no construction) involved
450 exprIsCheap (Let (NonRec x _) e)
451 | isUnLiftedType (idType x) = exprIsCheap e
453 -- strict lets always have cheap right hand sides,
454 -- and do no allocation.
456 exprIsCheap other_expr -- Applications and variables
459 -- Accumulate value arguments, then decide
460 go (App f a) val_args | isRuntimeArg a = go f (a:val_args)
461 | otherwise = go f val_args
463 go (Var f) [] = True -- Just a type application of a variable
464 -- (f t1 t2 t3) counts as WHNF
466 = case globalIdDetails f of
467 RecordSelId {} -> go_sel args
468 ClassOpId _ -> go_sel args
469 PrimOpId op -> go_primop op args
471 DataConWorkId _ -> go_pap args
472 other | length args < idArity f -> go_pap args
474 other -> isBottomingId f
475 -- Application of a function which
476 -- always gives bottom; we treat this as cheap
477 -- because it certainly doesn't need to be shared!
479 go other args = False
482 go_pap args = all exprIsTrivial args
483 -- For constructor applications and primops, check that all
484 -- the args are trivial. We don't want to treat as cheap, say,
486 -- We'll put up with one constructor application, but not dozens
489 go_primop op args = primOpIsCheap op && all exprIsCheap args
490 -- In principle we should worry about primops
491 -- that return a type variable, since the result
492 -- might be applied to something, but I'm not going
493 -- to bother to check the number of args
496 go_sel [arg] = exprIsCheap arg -- I'm experimenting with making record selection
497 go_sel other = False -- look cheap, so we will substitute it inside a
498 -- lambda. Particularly for dictionary field selection.
499 -- BUT: Take care with (sel d x)! The (sel d) might be cheap, but
500 -- there's no guarantee that (sel d x) will be too. Hence (n_val_args == 1)
503 exprOkForSpeculation returns True of an expression that it is
505 * safe to evaluate even if normal order eval might not
506 evaluate the expression at all, or
508 * safe *not* to evaluate even if normal order would do so
512 the expression guarantees to terminate,
514 without raising an exception,
515 without causing a side effect (e.g. writing a mutable variable)
517 NB: if exprIsHNF e, then exprOkForSpecuation e
520 let x = case y# +# 1# of { r# -> I# r# }
523 case y# +# 1# of { r# ->
528 We can only do this if the (y+1) is ok for speculation: it has no
529 side effects, and can't diverge or raise an exception.
532 exprOkForSpeculation :: CoreExpr -> Bool
533 exprOkForSpeculation (Lit _) = True
534 exprOkForSpeculation (Type _) = True
535 -- Tick boxes are *not* suitable for speculation
536 exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
537 && not (isTickBoxOp v)
538 exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
539 exprOkForSpeculation (Cast e co) = exprOkForSpeculation e
540 exprOkForSpeculation other_expr
541 = case collectArgs other_expr of
542 (Var f, args) -> spec_ok (globalIdDetails f) args
546 spec_ok (DataConWorkId _) args
547 = True -- The strictness of the constructor has already
548 -- been expressed by its "wrapper", so we don't need
549 -- to take the arguments into account
551 spec_ok (PrimOpId op) args
552 | isDivOp op, -- Special case for dividing operations that fail
553 [arg1, Lit lit] <- args -- only if the divisor is zero
554 = not (isZeroLit lit) && exprOkForSpeculation arg1
555 -- Often there is a literal divisor, and this
556 -- can get rid of a thunk in an inner looop
559 = primOpOkForSpeculation op &&
560 all exprOkForSpeculation args
561 -- A bit conservative: we don't really need
562 -- to care about lazy arguments, but this is easy
564 spec_ok other args = False
566 isDivOp :: PrimOp -> Bool
567 -- True of dyadic operators that can fail
568 -- only if the second arg is zero
569 -- This function probably belongs in PrimOp, or even in
570 -- an automagically generated file.. but it's such a
571 -- special case I thought I'd leave it here for now.
572 isDivOp IntQuotOp = True
573 isDivOp IntRemOp = True
574 isDivOp WordQuotOp = True
575 isDivOp WordRemOp = True
576 isDivOp IntegerQuotRemOp = True
577 isDivOp IntegerDivModOp = True
578 isDivOp FloatDivOp = True
579 isDivOp DoubleDivOp = True
580 isDivOp other = False
585 exprIsBottom :: CoreExpr -> Bool -- True => definitely bottom
586 exprIsBottom e = go 0 e
588 -- n is the number of args
589 go n (Note _ e) = go n e
590 go n (Cast e co) = go n e
591 go n (Let _ e) = go n e
592 go n (Case e _ _ _) = go 0 e -- Just check the scrut
593 go n (App e _) = go (n+1) e
594 go n (Var v) = idAppIsBottom v n
596 go n (Lam _ _) = False
597 go n (Type _) = False
599 idAppIsBottom :: Id -> Int -> Bool
600 idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
603 @exprIsHNF@ returns true for expressions that are certainly *already*
604 evaluated to *head* normal form. This is used to decide whether it's ok
607 case x of _ -> e ===> e
609 and to decide whether it's safe to discard a `seq`
611 So, it does *not* treat variables as evaluated, unless they say they are.
613 But it *does* treat partial applications and constructor applications
614 as values, even if their arguments are non-trivial, provided the argument
616 e.g. (:) (f x) (map f xs) is a value
617 map (...redex...) is a value
618 Because `seq` on such things completes immediately
620 For unlifted argument types, we have to be careful:
622 Suppose (f x) diverges; then C (f x) is not a value. However this can't
623 happen: see CoreSyn Note [CoreSyn let/app invariant]. Args of unboxed
624 type must be ok-for-speculation (or trivial).
627 exprIsHNF :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
628 exprIsHNF (Var v) -- NB: There are no value args at this point
629 = isDataConWorkId v -- Catches nullary constructors,
630 -- so that [] and () are values, for example
631 || idArity v > 0 -- Catches (e.g.) primops that don't have unfoldings
632 || isEvaldUnfolding (idUnfolding v)
633 -- Check the thing's unfolding; it might be bound to a value
634 -- A worry: what if an Id's unfolding is just itself:
635 -- then we could get an infinite loop...
637 exprIsHNF (Lit l) = True
638 exprIsHNF (Type ty) = True -- Types are honorary Values;
639 -- we don't mind copying them
640 exprIsHNF (Lam b e) = isRuntimeVar b || exprIsHNF e
641 exprIsHNF (Note _ e) = exprIsHNF e
642 exprIsHNF (Cast e co) = exprIsHNF e
643 exprIsHNF (App e (Type _)) = exprIsHNF e
644 exprIsHNF (App e a) = app_is_value e [a]
645 exprIsHNF other = False
647 -- There is at least one value argument
648 app_is_value (Var fun) args
649 = idArity fun > valArgCount args -- Under-applied function
650 || isDataConWorkId fun -- or data constructor
651 app_is_value (Note n f) as = app_is_value f as
652 app_is_value (Cast f _) as = app_is_value f as
653 app_is_value (App f a) as = app_is_value f (a:as)
654 app_is_value other as = False
658 -- These InstPat functions go here to avoid circularity between DataCon and Id
659 dataConRepInstPat = dataConInstPat dataConRepArgTys (repeat (FSLIT("ipv")))
660 dataConRepFSInstPat = dataConInstPat dataConRepArgTys
661 dataConOrigInstPat = dataConInstPat dc_arg_tys (repeat (FSLIT("ipv")))
663 dc_arg_tys dc = map mkPredTy (dataConTheta dc) ++ dataConOrigArgTys dc
664 -- Remember to include the existential dictionaries
666 dataConInstPat :: (DataCon -> [Type]) -- function used to find arg tys
667 -> [FastString] -- A long enough list of FSs to use for names
668 -> [Unique] -- An equally long list of uniques, at least one for each binder
670 -> [Type] -- Types to instantiate the universally quantified tyvars
671 -> ([TyVar], [CoVar], [Id]) -- Return instantiated variables
672 -- dataConInstPat arg_fun fss us con inst_tys returns a triple
673 -- (ex_tvs, co_tvs, arg_ids),
675 -- ex_tvs are intended to be used as binders for existential type args
677 -- co_tvs are intended to be used as binders for coercion args and the kinds
678 -- of these vars have been instantiated by the inst_tys and the ex_tys
680 -- arg_ids are indended to be used as binders for value arguments, including
681 -- dicts, and their types have been instantiated with inst_tys and ex_tys
684 -- The following constructor T1
687 -- T1 :: forall b. Int -> b -> T(a,b)
690 -- has representation type
691 -- forall a. forall a1. forall b. (a :=: (a1,b)) =>
694 -- dataConInstPat fss us T1 (a1',b') will return
696 -- ([a1'', b''], [c :: (a1', b'):=:(a1'', b'')], [x :: Int, y :: b''])
698 -- where the double-primed variables are created with the FastStrings and
699 -- Uniques given as fss and us
700 dataConInstPat arg_fun fss uniqs con inst_tys
701 = (ex_bndrs, co_bndrs, id_bndrs)
703 univ_tvs = dataConUnivTyVars con
704 ex_tvs = dataConExTyVars con
705 arg_tys = arg_fun con
706 eq_spec = dataConEqSpec con
707 eq_preds = eqSpecPreds eq_spec
710 n_co = length eq_spec
712 -- split the Uniques and FastStrings
713 (ex_uniqs, uniqs') = splitAt n_ex uniqs
714 (co_uniqs, id_uniqs) = splitAt n_co uniqs'
716 (ex_fss, fss') = splitAt n_ex fss
717 (co_fss, id_fss) = splitAt n_co fss'
719 -- Make existential type variables
720 ex_bndrs = zipWith3 mk_ex_var ex_uniqs ex_fss ex_tvs
721 mk_ex_var uniq fs var = mkTyVar new_name kind
723 new_name = mkSysTvName uniq fs
726 -- Make the instantiating substitution
727 subst = zipOpenTvSubst (univ_tvs ++ ex_tvs) (inst_tys ++ map mkTyVarTy ex_bndrs)
729 -- Make new coercion vars, instantiating kind
730 co_bndrs = zipWith3 mk_co_var co_uniqs co_fss eq_preds
731 mk_co_var uniq fs eq_pred = mkCoVar new_name co_kind
733 new_name = mkSysTvName uniq fs
734 co_kind = substTy subst (mkPredTy eq_pred)
736 -- make value vars, instantiating types
737 mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (substTy subst ty) noSrcLoc
738 id_bndrs = zipWith3 mk_id_var id_uniqs id_fss arg_tys
740 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
741 -- Returns (Just (dc, [x1..xn])) if the argument expression is
742 -- a constructor application of the form (dc x1 .. xn)
743 exprIsConApp_maybe (Cast expr co)
744 = -- Here we do the PushC reduction rule as described in the FC paper
745 case exprIsConApp_maybe expr of {
747 Just (dc, dc_args) ->
749 -- The transformation applies iff we have
750 -- (C e1 ... en) `cast` co
751 -- where co :: (T t1 .. tn) :=: (T s1 ..sn)
752 -- That is, with a T at the top of both sides
753 -- The left-hand one must be a T, because exprIsConApp returned True
754 -- but the right-hand one might not be. (Though it usually will.)
756 let (from_ty, to_ty) = coercionKind co
757 (from_tc, from_tc_arg_tys) = splitTyConApp from_ty
758 -- The inner one must be a TyConApp
760 case splitTyConApp_maybe to_ty of {
762 Just (to_tc, to_tc_arg_tys)
763 | from_tc /= to_tc -> Nothing
764 -- These two Nothing cases are possible; we might see
765 -- (C x y) `cast` (g :: T a ~ S [a]),
766 -- where S is a type function. In fact, exprIsConApp
767 -- will probably not be called in such circumstances,
768 -- but there't nothing wrong with it
772 tc_arity = tyConArity from_tc
774 (univ_args, rest1) = splitAt tc_arity dc_args
775 (ex_args, rest2) = splitAt n_ex_tvs rest1
776 (co_args, val_args) = splitAt n_cos rest2
778 arg_tys = dataConRepArgTys dc
779 dc_univ_tyvars = dataConUnivTyVars dc
780 dc_ex_tyvars = dataConExTyVars dc
781 dc_eq_spec = dataConEqSpec dc
782 dc_tyvars = dc_univ_tyvars ++ dc_ex_tyvars
783 n_ex_tvs = length dc_ex_tyvars
784 n_cos = length dc_eq_spec
786 -- Make the "theta" from Fig 3 of the paper
787 gammas = decomposeCo tc_arity co
788 new_tys = gammas ++ map (\ (Type t) -> t) ex_args
789 theta = zipOpenTvSubst dc_tyvars new_tys
791 -- First we cast the existential coercion arguments
792 cast_co (tv,ty) (Type co) = Type $ mkSymCoercion (substTyVar theta tv)
794 `mkTransCoercion` (substTy theta ty)
795 new_co_args = zipWith cast_co dc_eq_spec co_args
797 -- ...and now value arguments
798 new_val_args = zipWith cast_arg arg_tys val_args
799 cast_arg arg_ty arg = mkCoerce (substTy theta arg_ty) arg
802 ASSERT( length univ_args == tc_arity )
803 ASSERT( from_tc == dataConTyCon dc )
804 ASSERT( and (zipWith coreEqType [t | Type t <- univ_args] from_tc_arg_tys) )
805 ASSERT( all isTypeArg (univ_args ++ ex_args) )
806 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 )
808 Just (dc, map Type to_tc_arg_tys ++ ex_args ++ new_co_args ++ new_val_args)
812 -- We do not want to tell the world that we have a
813 -- Cons, to *stop* Case of Known Cons, which removes
815 exprIsConApp_maybe (Note (TickBox {}) expr)
817 exprIsConApp_maybe (Note (BinaryTickBox {}) expr)
821 exprIsConApp_maybe (Note _ expr)
822 = exprIsConApp_maybe expr
823 -- We ignore InlineMe notes in case we have
824 -- x = __inline_me__ (a,b)
825 -- All part of making sure that INLINE pragmas never hurt
826 -- Marcin tripped on this one when making dictionaries more inlinable
828 -- In fact, we ignore all notes. For example,
829 -- case _scc_ "foo" (C a b) of
831 -- should be optimised away, but it will be only if we look
832 -- through the SCC note.
834 exprIsConApp_maybe expr = analyse (collectArgs expr)
836 analyse (Var fun, args)
837 | Just con <- isDataConWorkId_maybe fun,
838 args `lengthAtLeast` dataConRepArity con
839 -- Might be > because the arity excludes type args
842 -- Look through unfoldings, but only cheap ones, because
843 -- we are effectively duplicating the unfolding
844 analyse (Var fun, [])
845 | let unf = idUnfolding fun,
847 = exprIsConApp_maybe (unfoldingTemplate unf)
849 analyse other = Nothing
854 %************************************************************************
856 \subsection{Eta reduction and expansion}
858 %************************************************************************
861 exprEtaExpandArity :: DynFlags -> CoreExpr -> Arity
862 {- The Arity returned is the number of value args the
863 thing can be applied to without doing much work
865 exprEtaExpandArity is used when eta expanding
868 It returns 1 (or more) to:
869 case x of p -> \s -> ...
870 because for I/O ish things we really want to get that \s to the top.
871 We are prepared to evaluate x each time round the loop in order to get that
873 It's all a bit more subtle than it looks:
877 Consider one-shot lambdas
878 let x = expensive in \y z -> E
879 We want this to have arity 2 if the \y-abstraction is a 1-shot lambda
880 Hence the ArityType returned by arityType
882 2. The state-transformer hack
884 The one-shot lambda special cause is particularly important/useful for
885 IO state transformers, where we often get
886 let x = E in \ s -> ...
888 and the \s is a real-world state token abstraction. Such abstractions
889 are almost invariably 1-shot, so we want to pull the \s out, past the
890 let x=E, even if E is expensive. So we treat state-token lambdas as
891 one-shot even if they aren't really. The hack is in Id.isOneShotBndr.
893 3. Dealing with bottom
896 f = \x -> error "foo"
897 Here, arity 1 is fine. But if it is
901 then we want to get arity 2. Tecnically, this isn't quite right, because
903 should diverge, but it'll converge if we eta-expand f. Nevertheless, we
904 do so; it improves some programs significantly, and increasing convergence
905 isn't a bad thing. Hence the ABot/ATop in ArityType.
907 Actually, the situation is worse. Consider
911 Can we eta-expand here? At first the answer looks like "yes of course", but
914 This should diverge! But if we eta-expand, it won't. Again, we ignore this
915 "problem", because being scrupulous would lose an important transformation for
921 Non-recursive newtypes are transparent, and should not get in the way.
922 We do (currently) eta-expand recursive newtypes too. So if we have, say
924 newtype T = MkT ([T] -> Int)
928 where f has arity 1. Then: etaExpandArity e = 1;
929 that is, etaExpandArity looks through the coerce.
931 When we eta-expand e to arity 1: eta_expand 1 e T
932 we want to get: coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
934 HOWEVER, note that if you use coerce bogusly you can ge
936 And since negate has arity 2, you might try to eta expand. But you can't
937 decopose Int to a function type. Hence the final case in eta_expand.
941 exprEtaExpandArity dflags e = arityDepth (arityType dflags e)
943 -- A limited sort of function type
944 data ArityType = AFun Bool ArityType -- True <=> one-shot
945 | ATop -- Know nothing
948 arityDepth :: ArityType -> Arity
949 arityDepth (AFun _ ty) = 1 + arityDepth ty
952 andArityType ABot at2 = at2
953 andArityType ATop at2 = ATop
954 andArityType (AFun t1 at1) (AFun t2 at2) = AFun (t1 && t2) (andArityType at1 at2)
955 andArityType at1 at2 = andArityType at2 at1
957 arityType :: DynFlags -> CoreExpr -> ArityType
958 -- (go1 e) = [b1,..,bn]
959 -- means expression can be rewritten \x_b1 -> ... \x_bn -> body
960 -- where bi is True <=> the lambda is one-shot
962 arityType dflags (Note n e) = arityType dflags e
963 -- Not needed any more: etaExpand is cleverer
964 -- | ok_note n = arityType dflags e
965 -- | otherwise = ATop
967 arityType dflags (Cast e co) = arityType dflags e
969 arityType dflags (Var v)
970 = mk (idArity v) (arg_tys (idType v))
972 mk :: Arity -> [Type] -> ArityType
973 -- The argument types are only to steer the "state hack"
974 -- Consider case x of
976 -- False -> \(s:RealWorld) -> e
977 -- where foo has arity 1. Then we want the state hack to
978 -- apply to foo too, so we can eta expand the case.
979 mk 0 tys | isBottomingId v = ABot
980 | (ty:tys) <- tys, isStateHackType ty = AFun True ATop
982 mk n (ty:tys) = AFun (isStateHackType ty) (mk (n-1) tys)
983 mk n [] = AFun False (mk (n-1) [])
985 arg_tys :: Type -> [Type] -- Ignore for-alls
987 | Just (_, ty') <- splitForAllTy_maybe ty = arg_tys ty'
988 | Just (arg,res) <- splitFunTy_maybe ty = arg : arg_tys res
991 -- Lambdas; increase arity
992 arityType dflags (Lam x e)
993 | isId x = AFun (isOneShotBndr x) (arityType dflags e)
994 | otherwise = arityType dflags e
996 -- Applications; decrease arity
997 arityType dflags (App f (Type _)) = arityType dflags f
998 arityType dflags (App f a) = case arityType dflags f of
999 AFun one_shot xs | exprIsCheap a -> xs
1002 -- Case/Let; keep arity if either the expression is cheap
1003 -- or it's a 1-shot lambda
1004 -- The former is not really right for Haskell
1005 -- f x = case x of { (a,b) -> \y. e }
1007 -- f x y = case x of { (a,b) -> e }
1008 -- The difference is observable using 'seq'
1009 arityType dflags (Case scrut _ _ alts)
1010 = case foldr1 andArityType [arityType dflags rhs | (_,_,rhs) <- alts] of
1011 xs | exprIsCheap scrut -> xs
1012 xs@(AFun one_shot _) | one_shot -> AFun True ATop
1015 arityType dflags (Let b e)
1016 = case arityType dflags e of
1017 xs | cheap_bind b -> xs
1018 xs@(AFun one_shot _) | one_shot -> AFun True ATop
1021 cheap_bind (NonRec b e) = is_cheap (b,e)
1022 cheap_bind (Rec prs) = all is_cheap prs
1023 is_cheap (b,e) = (dopt Opt_DictsCheap dflags && isDictId b)
1025 -- If the experimental -fdicts-cheap flag is on, we eta-expand through
1026 -- dictionary bindings. This improves arities. Thereby, it also
1027 -- means that full laziness is less prone to floating out the
1028 -- application of a function to its dictionary arguments, which
1029 -- can thereby lose opportunities for fusion. Example:
1030 -- foo :: Ord a => a -> ...
1031 -- foo = /\a \(d:Ord a). let d' = ...d... in \(x:a). ....
1032 -- -- So foo has arity 1
1034 -- f = \x. foo dInt $ bar x
1036 -- The (foo DInt) is floated out, and makes ineffective a RULE
1037 -- foo (bar x) = ...
1039 -- One could go further and make exprIsCheap reply True to any
1040 -- dictionary-typed expression, but that's more work.
1042 arityType dflags other = ATop
1044 {- NOT NEEDED ANY MORE: etaExpand is cleverer
1045 ok_note InlineMe = False
1046 ok_note other = True
1047 -- Notice that we do not look through __inline_me__
1048 -- This may seem surprising, but consider
1049 -- f = _inline_me (\x -> e)
1050 -- We DO NOT want to eta expand this to
1051 -- f = \x -> (_inline_me (\x -> e)) x
1052 -- because the _inline_me gets dropped now it is applied,
1061 etaExpand :: Arity -- Result should have this number of value args
1063 -> CoreExpr -> Type -- Expression and its type
1065 -- (etaExpand n us e ty) returns an expression with
1066 -- the same meaning as 'e', but with arity 'n'.
1068 -- Given e' = etaExpand n us e ty
1070 -- ty = exprType e = exprType e'
1072 -- Note that SCCs are not treated specially. If we have
1073 -- etaExpand 2 (\x -> scc "foo" e)
1074 -- = (\xy -> (scc "foo" e) y)
1075 -- So the costs of evaluating 'e' (not 'e y') are attributed to "foo"
1077 etaExpand n us expr ty
1078 | manifestArity expr >= n = expr -- The no-op case
1080 = eta_expand n us expr ty
1083 -- manifestArity sees how many leading value lambdas there are
1084 manifestArity :: CoreExpr -> Arity
1085 manifestArity (Lam v e) | isId v = 1 + manifestArity e
1086 | otherwise = manifestArity e
1087 manifestArity (Note _ e) = manifestArity e
1088 manifestArity (Cast e _) = manifestArity e
1091 -- etaExpand deals with for-alls. For example:
1093 -- where E :: forall a. a -> a
1095 -- (/\b. \y::a -> E b y)
1097 -- It deals with coerces too, though they are now rare
1098 -- so perhaps the extra code isn't worth it
1100 eta_expand n us expr ty
1102 -- The ILX code generator requires eta expansion for type arguments
1103 -- too, but alas the 'n' doesn't tell us how many of them there
1104 -- may be. So we eagerly eta expand any big lambdas, and just
1105 -- cross our fingers about possible loss of sharing in the ILX case.
1106 -- The Right Thing is probably to make 'arity' include
1107 -- type variables throughout the compiler. (ToDo.)
1109 -- Saturated, so nothing to do
1112 -- Short cut for the case where there already
1113 -- is a lambda; no point in gratuitously adding more
1114 eta_expand n us (Lam v body) ty
1116 = Lam v (eta_expand n us body (applyTy ty (mkTyVarTy v)))
1119 = Lam v (eta_expand (n-1) us body (funResultTy ty))
1121 -- We used to have a special case that stepped inside Coerces here,
1122 -- thus: eta_expand n us (Note note@(Coerce _ ty) e) _
1123 -- = Note note (eta_expand n us e ty)
1124 -- BUT this led to an infinite loop
1125 -- Example: newtype T = MkT (Int -> Int)
1126 -- eta_expand 1 (coerce (Int->Int) e)
1127 -- --> coerce (Int->Int) (eta_expand 1 T e)
1129 -- --> coerce (Int->Int) (coerce T
1130 -- (\x::Int -> eta_expand 1 (coerce (Int->Int) e)))
1131 -- by the splitNewType_maybe case below
1134 eta_expand n us expr ty
1135 = ASSERT2 (exprType expr `coreEqType` ty, ppr (exprType expr) $$ ppr ty)
1136 case splitForAllTy_maybe ty of {
1139 Lam lam_tv (eta_expand n us2 (App expr (Type (mkTyVarTy lam_tv))) (substTyWith [tv] [mkTyVarTy lam_tv] ty'))
1141 lam_tv = setVarName tv (mkSysTvName uniq FSLIT("etaT"))
1142 -- Using tv as a base retains its tyvar/covar-ness
1146 case splitFunTy_maybe ty of {
1147 Just (arg_ty, res_ty) -> Lam arg1 (eta_expand (n-1) us2 (App expr (Var arg1)) res_ty)
1149 arg1 = mkSysLocal FSLIT("eta") uniq arg_ty
1155 -- newtype T = MkT ([T] -> Int)
1156 -- Consider eta-expanding this
1159 -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
1161 case splitNewTypeRepCo_maybe ty of {
1163 mkCoerce (mkSymCoercion co) (eta_expand n us (mkCoerce co expr) ty1) ;
1166 -- We have an expression of arity > 0, but its type isn't a function
1167 -- This *can* legitmately happen: e.g. coerce Int (\x. x)
1168 -- Essentially the programmer is playing fast and loose with types
1169 -- (Happy does this a lot). So we simply decline to eta-expand.
1174 exprArity is a cheap-and-cheerful version of exprEtaExpandArity.
1175 It tells how many things the expression can be applied to before doing
1176 any work. It doesn't look inside cases, lets, etc. The idea is that
1177 exprEtaExpandArity will do the hard work, leaving something that's easy
1178 for exprArity to grapple with. In particular, Simplify uses exprArity to
1179 compute the ArityInfo for the Id.
1181 Originally I thought that it was enough just to look for top-level lambdas, but
1182 it isn't. I've seen this
1184 foo = PrelBase.timesInt
1186 We want foo to get arity 2 even though the eta-expander will leave it
1187 unchanged, in the expectation that it'll be inlined. But occasionally it
1188 isn't, because foo is blacklisted (used in a rule).
1190 Similarly, see the ok_note check in exprEtaExpandArity. So
1191 f = __inline_me (\x -> e)
1192 won't be eta-expanded.
1194 And in any case it seems more robust to have exprArity be a bit more intelligent.
1195 But note that (\x y z -> f x y z)
1196 should have arity 3, regardless of f's arity.
1199 exprArity :: CoreExpr -> Arity
1202 go (Var v) = idArity v
1203 go (Lam x e) | isId x = go e + 1
1205 go (Note n e) = go e
1206 go (Cast e _) = go e
1207 go (App e (Type t)) = go e
1208 go (App f a) | exprIsCheap a = (go f - 1) `max` 0
1209 -- NB: exprIsCheap a!
1210 -- f (fac x) does not have arity 2,
1211 -- even if f has arity 3!
1212 -- NB: `max 0`! (\x y -> f x) has arity 2, even if f is
1213 -- unknown, hence arity 0
1217 %************************************************************************
1219 \subsection{Equality}
1221 %************************************************************************
1223 @cheapEqExpr@ is a cheap equality test which bales out fast!
1224 True => definitely equal
1225 False => may or may not be equal
1228 cheapEqExpr :: Expr b -> Expr b -> Bool
1230 cheapEqExpr (Var v1) (Var v2) = v1==v2
1231 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
1232 cheapEqExpr (Type t1) (Type t2) = t1 `coreEqType` t2
1234 cheapEqExpr (App f1 a1) (App f2 a2)
1235 = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
1237 cheapEqExpr _ _ = False
1239 exprIsBig :: Expr b -> Bool
1240 -- Returns True of expressions that are too big to be compared by cheapEqExpr
1241 exprIsBig (Lit _) = False
1242 exprIsBig (Var v) = False
1243 exprIsBig (Type t) = False
1244 exprIsBig (App f a) = exprIsBig f || exprIsBig a
1245 exprIsBig (Cast e _) = exprIsBig e -- Hopefully coercions are not too big!
1246 exprIsBig other = True
1251 tcEqExpr :: CoreExpr -> CoreExpr -> Bool
1252 -- Used in rule matching, so does *not* look through
1253 -- newtypes, predicate types; hence tcEqExpr
1255 tcEqExpr e1 e2 = tcEqExprX rn_env e1 e2
1257 rn_env = mkRnEnv2 (mkInScopeSet (exprFreeVars e1 `unionVarSet` exprFreeVars e2))
1259 tcEqExprX :: RnEnv2 -> CoreExpr -> CoreExpr -> Bool
1260 tcEqExprX env (Var v1) (Var v2) = rnOccL env v1 == rnOccR env v2
1261 tcEqExprX env (Lit lit1) (Lit lit2) = lit1 == lit2
1262 tcEqExprX env (App f1 a1) (App f2 a2) = tcEqExprX env f1 f2 && tcEqExprX env a1 a2
1263 tcEqExprX env (Lam v1 e1) (Lam v2 e2) = tcEqExprX (rnBndr2 env v1 v2) e1 e2
1264 tcEqExprX env (Let (NonRec v1 r1) e1)
1265 (Let (NonRec v2 r2) e2) = tcEqExprX env r1 r2
1266 && tcEqExprX (rnBndr2 env v1 v2) e1 e2
1267 tcEqExprX env (Let (Rec ps1) e1)
1268 (Let (Rec ps2) e2) = equalLength ps1 ps2
1269 && and (zipWith eq_rhs ps1 ps2)
1270 && tcEqExprX env' e1 e2
1272 env' = foldl2 rn_bndr2 env ps2 ps2
1273 rn_bndr2 env (b1,_) (b2,_) = rnBndr2 env b1 b2
1274 eq_rhs (_,r1) (_,r2) = tcEqExprX env' r1 r2
1275 tcEqExprX env (Case e1 v1 t1 a1)
1276 (Case e2 v2 t2 a2) = tcEqExprX env e1 e2
1277 && tcEqTypeX env t1 t2
1278 && equalLength a1 a2
1279 && and (zipWith (eq_alt env') a1 a2)
1281 env' = rnBndr2 env v1 v2
1283 tcEqExprX env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && tcEqExprX env e1 e2
1284 tcEqExprX env (Cast e1 co1) (Cast e2 co2) = tcEqTypeX env co1 co2 && tcEqExprX env e1 e2
1285 tcEqExprX env (Type t1) (Type t2) = tcEqTypeX env t1 t2
1286 tcEqExprX env e1 e2 = False
1288 eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 && tcEqExprX (rnBndrs2 env vs1 vs2) r1 r2
1290 eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2
1291 eq_note env (CoreNote s1) (CoreNote s2) = s1 == s2
1292 eq_note env other1 other2 = False
1296 %************************************************************************
1298 \subsection{The size of an expression}
1300 %************************************************************************
1303 coreBindsSize :: [CoreBind] -> Int
1304 coreBindsSize bs = foldr ((+) . bindSize) 0 bs
1306 exprSize :: CoreExpr -> Int
1307 -- A measure of the size of the expressions
1308 -- It also forces the expression pretty drastically as a side effect
1309 exprSize (Var v) = v `seq` 1
1310 exprSize (Lit lit) = lit `seq` 1
1311 exprSize (App f a) = exprSize f + exprSize a
1312 exprSize (Lam b e) = varSize b + exprSize e
1313 exprSize (Let b e) = bindSize b + exprSize e
1314 exprSize (Case e b t as) = seqType t `seq` exprSize e + varSize b + 1 + foldr ((+) . altSize) 0 as
1315 exprSize (Cast e co) = (seqType co `seq` 1) + exprSize e
1316 exprSize (Note n e) = noteSize n + exprSize e
1317 exprSize (Type t) = seqType t `seq` 1
1319 noteSize (SCC cc) = cc `seq` 1
1320 noteSize InlineMe = 1
1321 noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations
1323 varSize :: Var -> Int
1324 varSize b | isTyVar b = 1
1325 | otherwise = seqType (idType b) `seq`
1326 megaSeqIdInfo (idInfo b) `seq`
1329 varsSize = foldr ((+) . varSize) 0
1331 bindSize (NonRec b e) = varSize b + exprSize e
1332 bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs
1334 pairSize (b,e) = varSize b + exprSize e
1336 altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
1340 %************************************************************************
1342 \subsection{Hashing}
1344 %************************************************************************
1347 hashExpr :: CoreExpr -> Int
1348 -- Two expressions that hash to the same Int may be equal (but may not be)
1349 -- Two expressions that hash to the different Ints are definitely unequal
1351 -- But "unequal" here means "not identical"; two alpha-equivalent
1352 -- expressions may hash to the different Ints
1354 -- The emphasis is on a crude, fast hash, rather than on high precision
1356 -- We must be careful that \x.x and \y.y map to the same hash code,
1357 -- (at least if we want the above invariant to be true)
1359 hashExpr e = fromIntegral (hash_expr (1,emptyVarEnv) e .&. 0x7fffffff)
1360 -- UniqFM doesn't like negative Ints
1362 type HashEnv = (Int, VarEnv Int) -- Hash code for bound variables
1364 hash_expr :: HashEnv -> CoreExpr -> Word32
1365 -- Word32, because we're expecting overflows here, and overflowing
1366 -- signed types just isn't cool. In C it's even undefined.
1367 hash_expr env (Note _ e) = hash_expr env e
1368 hash_expr env (Cast e co) = hash_expr env e
1369 hash_expr env (Var v) = hashVar env v
1370 hash_expr env (Lit lit) = fromIntegral (hashLiteral lit)
1371 hash_expr env (App f e) = hash_expr env f * fast_hash_expr env e
1372 hash_expr env (Let (NonRec b r) e) = hash_expr (extend_env env b) e * fast_hash_expr env r
1373 hash_expr env (Let (Rec ((b,r):_)) e) = hash_expr (extend_env env b) e
1374 hash_expr env (Case e _ _ _) = hash_expr env e
1375 hash_expr env (Lam b e) = hash_expr (extend_env env b) e
1376 hash_expr env (Type t) = WARN(True, text "hash_expr: type") 1
1377 -- Shouldn't happen. Better to use WARN than trace, because trace
1378 -- prevents the CPR optimisation kicking in for hash_expr.
1380 fast_hash_expr env (Var v) = hashVar env v
1381 fast_hash_expr env (Type t) = fast_hash_type env t
1382 fast_hash_expr env (Lit lit) = fromIntegral (hashLiteral lit)
1383 fast_hash_expr env (Cast e co) = fast_hash_expr env e
1384 fast_hash_expr env (Note n e) = fast_hash_expr env e
1385 fast_hash_expr env (App f a) = fast_hash_expr env a -- A bit idiosyncratic ('a' not 'f')!
1386 fast_hash_expr env other = 1
1388 fast_hash_type :: HashEnv -> Type -> Word32
1389 fast_hash_type env ty
1390 | Just tv <- getTyVar_maybe ty = hashVar env tv
1391 | Just (tc,tys) <- splitTyConApp_maybe ty = let hash_tc = fromIntegral (hashName (tyConName tc))
1392 in foldr (\t n -> fast_hash_type env t + n) hash_tc tys
1395 extend_env :: HashEnv -> Var -> (Int, VarEnv Int)
1396 extend_env (n,env) b = (n+1, extendVarEnv env b n)
1398 hashVar :: HashEnv -> Var -> Word32
1400 = fromIntegral (lookupVarEnv env v `orElse` hashName (idName v))
1403 %************************************************************************
1405 \subsection{Determining non-updatable right-hand-sides}
1407 %************************************************************************
1409 Top-level constructor applications can usually be allocated
1410 statically, but they can't if the constructor, or any of the
1411 arguments, come from another DLL (because we can't refer to static
1412 labels in other DLLs).
1414 If this happens we simply make the RHS into an updatable thunk,
1415 and 'exectute' it rather than allocating it statically.
1418 rhsIsStatic :: PackageId -> CoreExpr -> Bool
1419 -- This function is called only on *top-level* right-hand sides
1420 -- Returns True if the RHS can be allocated statically, with
1421 -- no thunks involved at all.
1423 -- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or
1424 -- refers to, CAFs; and (ii) in CoreToStg to decide whether to put an
1425 -- update flag on it.
1427 -- The basic idea is that rhsIsStatic returns True only if the RHS is
1428 -- (a) a value lambda
1429 -- (b) a saturated constructor application with static args
1431 -- BUT watch out for
1432 -- (i) Any cross-DLL references kill static-ness completely
1433 -- because they must be 'executed' not statically allocated
1434 -- ("DLL" here really only refers to Windows DLLs, on other platforms,
1435 -- this is not necessary)
1437 -- (ii) We treat partial applications as redexes, because in fact we
1438 -- make a thunk for them that runs and builds a PAP
1439 -- at run-time. The only appliations that are treated as
1440 -- static are *saturated* applications of constructors.
1442 -- We used to try to be clever with nested structures like this:
1443 -- ys = (:) w ((:) w [])
1444 -- on the grounds that CorePrep will flatten ANF-ise it later.
1445 -- But supporting this special case made the function much more
1446 -- complicated, because the special case only applies if there are no
1447 -- enclosing type lambdas:
1448 -- ys = /\ a -> Foo (Baz ([] a))
1449 -- Here the nested (Baz []) won't float out to top level in CorePrep.
1451 -- But in fact, even without -O, nested structures at top level are
1452 -- flattened by the simplifier, so we don't need to be super-clever here.
1456 -- f = \x::Int. x+7 TRUE
1457 -- p = (True,False) TRUE
1459 -- d = (fst p, False) FALSE because there's a redex inside
1460 -- (this particular one doesn't happen but...)
1462 -- h = D# (1.0## /## 2.0##) FALSE (redex again)
1463 -- n = /\a. Nil a TRUE
1465 -- t = /\a. (:) (case w a of ...) (Nil a) FALSE (redex)
1468 -- This is a bit like CoreUtils.exprIsHNF, with the following differences:
1469 -- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
1471 -- b) (C x xs), where C is a contructors is updatable if the application is
1474 -- c) don't look through unfolding of f in (f x).
1476 -- When opt_RuntimeTypes is on, we keep type lambdas and treat
1477 -- them as making the RHS re-entrant (non-updatable).
1479 rhsIsStatic this_pkg rhs = is_static False rhs
1481 is_static :: Bool -- True <=> in a constructor argument; must be atomic
1484 is_static False (Lam b e) = isRuntimeVar b || is_static False e
1486 is_static in_arg (Note (SCC _) e) = False
1487 is_static in_arg (Note _ e) = is_static in_arg e
1488 is_static in_arg (Cast e co) = is_static in_arg e
1490 is_static in_arg (Lit lit)
1492 MachLabel _ _ -> False
1494 -- A MachLabel (foreign import "&foo") in an argument
1495 -- prevents a constructor application from being static. The
1496 -- reason is that it might give rise to unresolvable symbols
1497 -- in the object file: under Linux, references to "weak"
1498 -- symbols from the data segment give rise to "unresolvable
1499 -- relocation" errors at link time This might be due to a bug
1500 -- in the linker, but we'll work around it here anyway.
1503 is_static in_arg other_expr = go other_expr 0
1505 go (Var f) n_val_args
1506 #if mingw32_TARGET_OS
1507 | not (isDllName this_pkg (idName f))
1509 = saturated_data_con f n_val_args
1510 || (in_arg && n_val_args == 0)
1511 -- A naked un-applied variable is *not* deemed a static RHS
1513 -- Reason: better to update so that the indirection gets shorted
1514 -- out, and the true value will be seen
1515 -- NB: if you change this, you'll break the invariant that THUNK_STATICs
1516 -- are always updatable. If you do so, make sure that non-updatable
1517 -- ones have enough space for their static link field!
1519 go (App f a) n_val_args
1520 | isTypeArg a = go f n_val_args
1521 | not in_arg && is_static True a = go f (n_val_args + 1)
1522 -- The (not in_arg) checks that we aren't in a constructor argument;
1523 -- if we are, we don't allow (value) applications of any sort
1525 -- NB. In case you wonder, args are sometimes not atomic. eg.
1526 -- x = D# (1.0## /## 2.0##)
1527 -- can't float because /## can fail.
1529 go (Note (SCC _) f) n_val_args = False
1530 go (Note _ f) n_val_args = go f n_val_args
1531 go (Cast e co) n_val_args = go e n_val_args
1533 go other n_val_args = False
1535 saturated_data_con f n_val_args
1536 = case isDataConWorkId_maybe f of
1537 Just dc -> n_val_args == dataConRepArity dc