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,
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"
75 import GHC.Exts -- For `xori`
79 %************************************************************************
81 \subsection{Find the type of a Core atom/expression}
83 %************************************************************************
86 exprType :: CoreExpr -> Type
88 exprType (Var var) = idType var
89 exprType (Lit lit) = literalType lit
90 exprType (Let _ body) = exprType body
91 exprType (Case _ _ ty alts) = ty
93 = let (_, ty) = coercionKind co in ty
94 exprType (Note other_note e) = exprType e
95 exprType (Lam binder expr) = mkPiType binder (exprType expr)
97 = case collectArgs e of
98 (fun, args) -> applyTypeToArgs e (exprType fun) args
100 exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
102 coreAltType :: CoreAlt -> Type
103 coreAltType (_,_,rhs) = exprType rhs
106 @mkPiType@ makes a (->) type or a forall type, depending on whether
107 it is given a type variable or a term variable. We cleverly use the
108 lbvarinfo field to figure out the right annotation for the arrove in
109 case of a term variable.
112 mkPiType :: Var -> Type -> Type -- The more polymorphic version
113 mkPiTypes :: [Var] -> Type -> Type -- doesn't work...
115 mkPiTypes vs ty = foldr mkPiType ty vs
118 | isId v = mkFunTy (idType v) ty
119 | otherwise = mkForAllTy v ty
123 applyTypeToArg :: Type -> CoreExpr -> Type
124 applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty
125 applyTypeToArg fun_ty other_arg = funResultTy fun_ty
127 applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
128 -- A more efficient version of applyTypeToArg
129 -- when we have several args
130 -- The first argument is just for debugging
131 applyTypeToArgs e op_ty [] = op_ty
133 applyTypeToArgs e op_ty (Type ty : args)
134 = -- Accumulate type arguments so we can instantiate all at once
137 go rev_tys (Type ty : args) = go (ty:rev_tys) args
138 go rev_tys rest_args = applyTypeToArgs e op_ty' rest_args
140 op_ty' = applyTys op_ty (reverse rev_tys)
142 applyTypeToArgs e op_ty (other_arg : args)
143 = case (splitFunTy_maybe op_ty) of
144 Just (_, res_ty) -> applyTypeToArgs e res_ty args
145 Nothing -> pprPanic "applyTypeToArgs" (pprCoreExpr e $$ ppr op_ty)
150 %************************************************************************
152 \subsection{Attaching notes}
154 %************************************************************************
156 mkNote removes redundant coercions, and SCCs where possible
160 mkNote :: Note -> CoreExpr -> CoreExpr
161 mkNote (SCC cc) expr = mkSCC cc expr
162 mkNote InlineMe expr = mkInlineMe expr
163 mkNote note expr = Note note expr
167 Drop trivial InlineMe's. This is somewhat important, because if we have an unfolding
168 that looks like (Note InlineMe (Var v)), the InlineMe doesn't go away because it may
169 not be *applied* to anything.
171 We don't use exprIsTrivial here, though, because we sometimes generate worker/wrapper
174 f = inline_me (coerce t fw)
175 As usual, the inline_me prevents the worker from getting inlined back into the wrapper.
176 We want the split, so that the coerces can cancel at the call site.
178 However, we can get left with tiresome type applications. Notably, consider
179 f = /\ a -> let t = e in (t, w)
180 Then lifting the let out of the big lambda gives
182 f = /\ a -> let t = inline_me (t' a) in (t, w)
183 The inline_me is to stop the simplifier inlining t' right back
184 into t's RHS. In the next phase we'll substitute for t (since
185 its rhs is trivial) and *then* we could get rid of the inline_me.
186 But it hardly seems worth it, so I don't bother.
189 mkInlineMe (Var v) = Var v
190 mkInlineMe e = Note InlineMe e
196 mkCoerce :: Coercion -> CoreExpr -> CoreExpr
197 mkCoerce co (Cast expr co2)
198 = ASSERT(let { (from_ty, _to_ty) = coercionKind co;
199 (_from_ty2, to_ty2) = coercionKind co2} in
200 from_ty `coreEqType` to_ty2 )
201 mkCoerce (mkTransCoercion co2 co) expr
204 = let (from_ty, to_ty) = coercionKind co in
205 -- if to_ty `coreEqType` from_ty
208 ASSERT2(from_ty `coreEqType` (exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ ppr (coercionKindPredTy co))
213 mkSCC :: CostCentre -> Expr b -> Expr b
214 -- Note: Nested SCC's *are* preserved for the benefit of
215 -- cost centre stack profiling
216 mkSCC cc (Lit lit) = Lit lit
217 mkSCC cc (Lam x e) = Lam x (mkSCC cc e) -- Move _scc_ inside lambda
218 mkSCC cc (Note (SCC cc') e) = Note (SCC cc) (Note (SCC cc') e)
219 mkSCC cc (Note n e) = Note n (mkSCC cc e) -- Move _scc_ inside notes
220 mkSCC cc (Cast e co) = Cast (mkSCC cc e) co -- Move _scc_ inside cast
221 mkSCC cc expr = Note (SCC cc) expr
225 %************************************************************************
227 \subsection{Other expression construction}
229 %************************************************************************
232 bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
233 -- (bindNonRec x r b) produces either
236 -- case r of x { _DEFAULT_ -> b }
238 -- depending on whether x is unlifted or not
239 -- It's used by the desugarer to avoid building bindings
240 -- that give Core Lint a heart attack. Actually the simplifier
241 -- deals with them perfectly well.
243 bindNonRec bndr rhs body
244 | needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT,[],body)]
245 | otherwise = Let (NonRec bndr rhs) body
247 needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
248 -- Make a case expression instead of a let
249 -- These can arise either from the desugarer,
250 -- or from beta reductions: (\x.e) (x +# y)
254 mkAltExpr :: AltCon -> [CoreBndr] -> [Type] -> CoreExpr
255 -- This guy constructs the value that the scrutinee must have
256 -- when you are in one particular branch of a case
257 mkAltExpr (DataAlt con) args inst_tys
258 = mkConApp con (map Type inst_tys ++ varsToCoreExprs args)
259 mkAltExpr (LitAlt lit) [] []
262 mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
263 mkIfThenElse guard then_expr else_expr
264 -- Not going to be refining, so okay to take the type of the "then" clause
265 = Case guard (mkWildId boolTy) (exprType then_expr)
266 [ (DataAlt falseDataCon, [], else_expr), -- Increasing order of tag!
267 (DataAlt trueDataCon, [], then_expr) ]
271 %************************************************************************
273 \subsection{Taking expressions apart}
275 %************************************************************************
277 The default alternative must be first, if it exists at all.
278 This makes it easy to find, though it makes matching marginally harder.
281 findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
282 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
283 findDefault alts = (alts, Nothing)
285 findAlt :: AltCon -> [CoreAlt] -> CoreAlt
288 (deflt@(DEFAULT,_,_):alts) -> go alts deflt
289 other -> go alts panic_deflt
291 panic_deflt = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
294 go (alt@(con1,_,_) : alts) deflt
295 = case con `cmpAltCon` con1 of
296 LT -> deflt -- Missed it already; the alts are in increasing order
298 GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt
300 isDefaultAlt :: CoreAlt -> Bool
301 isDefaultAlt (DEFAULT, _, _) = True
302 isDefaultAlt other = False
304 ---------------------------------
305 mergeAlts :: [CoreAlt] -> [CoreAlt] -> [CoreAlt]
306 -- Merge preserving order; alternatives in the first arg
307 -- shadow ones in the second
308 mergeAlts [] as2 = as2
309 mergeAlts as1 [] = as1
310 mergeAlts (a1:as1) (a2:as2)
311 = case a1 `cmpAlt` a2 of
312 LT -> a1 : mergeAlts as1 (a2:as2)
313 EQ -> a1 : mergeAlts as1 as2 -- Discard a2
314 GT -> a2 : mergeAlts (a1:as1) as2
318 %************************************************************************
320 \subsection{Figuring out things about expressions}
322 %************************************************************************
324 @exprIsTrivial@ is true of expressions we are unconditionally happy to
325 duplicate; simple variables and constants, and type
326 applications. Note that primop Ids aren't considered
329 @exprIsBottom@ is true of expressions that are guaranteed to diverge
332 There used to be a gruesome test for (hasNoBinding v) in the
334 exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
335 The idea here is that a constructor worker, like $wJust, is
336 really short for (\x -> $wJust x), becuase $wJust has no binding.
337 So it should be treated like a lambda. Ditto unsaturated primops.
338 But now constructor workers are not "have-no-binding" Ids. And
339 completely un-applied primops and foreign-call Ids are sufficiently
340 rare that I plan to allow them to be duplicated and put up with
343 SCC notes. We do not treat (_scc_ "foo" x) as trivial, because
344 a) it really generates code, (and a heap object when it's
345 a function arg) to capture the cost centre
346 b) see the note [SCC-and-exprIsTrivial] in Simplify.simplLazyBind
349 exprIsTrivial (Var v) = True -- See notes above
350 exprIsTrivial (Type _) = True
351 exprIsTrivial (Lit lit) = litIsTrivial lit
352 exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e
353 exprIsTrivial (Note (SCC _) e) = False -- See notes above
354 exprIsTrivial (Note _ e) = exprIsTrivial e
355 exprIsTrivial (Cast e co) = exprIsTrivial e
356 exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body
357 exprIsTrivial other = False
361 @exprIsDupable@ is true of expressions that can be duplicated at a modest
362 cost in code size. This will only happen in different case
363 branches, so there's no issue about duplicating work.
365 That is, exprIsDupable returns True of (f x) even if
366 f is very very expensive to call.
368 Its only purpose is to avoid fruitless let-binding
369 and then inlining of case join points
373 exprIsDupable (Type _) = True
374 exprIsDupable (Var v) = True
375 exprIsDupable (Lit lit) = litIsDupable lit
376 exprIsDupable (Note InlineMe e) = True
377 exprIsDupable (Note _ e) = exprIsDupable e
378 exprIsDupable (Cast e co) = exprIsDupable e
382 go (Var v) n_args = True
383 go (App f a) n_args = n_args < dupAppSize
386 go other n_args = False
389 dupAppSize = 4 -- Size of application we are prepared to duplicate
392 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
393 it is obviously in weak head normal form, or is cheap to get to WHNF.
394 [Note that that's not the same as exprIsDupable; an expression might be
395 big, and hence not dupable, but still cheap.]
397 By ``cheap'' we mean a computation we're willing to:
398 push inside a lambda, or
399 inline at more than one place
400 That might mean it gets evaluated more than once, instead of being
401 shared. The main examples of things which aren't WHNF but are
406 (where e, and all the ei are cheap)
409 (where e and b are cheap)
412 (where op is a cheap primitive operator)
415 (because we are happy to substitute it inside a lambda)
417 Notice that a variable is considered 'cheap': we can push it inside a lambda,
418 because sharing will make sure it is only evaluated once.
421 exprIsCheap :: CoreExpr -> Bool
422 exprIsCheap (Lit lit) = True
423 exprIsCheap (Type _) = True
424 exprIsCheap (Var _) = True
425 exprIsCheap (Note InlineMe e) = True
426 exprIsCheap (Note _ e) = exprIsCheap e
427 exprIsCheap (Cast e co) = exprIsCheap e
428 exprIsCheap (Lam x e) = isRuntimeVar x || exprIsCheap e
429 exprIsCheap (Case e _ _ alts) = exprIsCheap e &&
430 and [exprIsCheap rhs | (_,_,rhs) <- alts]
431 -- Experimentally, treat (case x of ...) as cheap
432 -- (and case __coerce x etc.)
433 -- This improves arities of overloaded functions where
434 -- there is only dictionary selection (no construction) involved
435 exprIsCheap (Let (NonRec x _) e)
436 | isUnLiftedType (idType x) = exprIsCheap e
438 -- strict lets always have cheap right hand sides,
439 -- and do no allocation.
441 exprIsCheap other_expr -- Applications and variables
444 -- Accumulate value arguments, then decide
445 go (App f a) val_args | isRuntimeArg a = go f (a:val_args)
446 | otherwise = go f val_args
448 go (Var f) [] = True -- Just a type application of a variable
449 -- (f t1 t2 t3) counts as WHNF
451 = case globalIdDetails f of
452 RecordSelId {} -> go_sel args
453 ClassOpId _ -> go_sel args
454 PrimOpId op -> go_primop op args
456 DataConWorkId _ -> go_pap args
457 other | length args < idArity f -> go_pap args
459 other -> isBottomingId f
460 -- Application of a function which
461 -- always gives bottom; we treat this as cheap
462 -- because it certainly doesn't need to be shared!
464 go other args = False
467 go_pap args = all exprIsTrivial args
468 -- For constructor applications and primops, check that all
469 -- the args are trivial. We don't want to treat as cheap, say,
471 -- We'll put up with one constructor application, but not dozens
474 go_primop op args = primOpIsCheap op && all exprIsCheap args
475 -- In principle we should worry about primops
476 -- that return a type variable, since the result
477 -- might be applied to something, but I'm not going
478 -- to bother to check the number of args
481 go_sel [arg] = exprIsCheap arg -- I'm experimenting with making record selection
482 go_sel other = False -- look cheap, so we will substitute it inside a
483 -- lambda. Particularly for dictionary field selection.
484 -- BUT: Take care with (sel d x)! The (sel d) might be cheap, but
485 -- there's no guarantee that (sel d x) will be too. Hence (n_val_args == 1)
488 exprOkForSpeculation returns True of an expression that it is
490 * safe to evaluate even if normal order eval might not
491 evaluate the expression at all, or
493 * safe *not* to evaluate even if normal order would do so
497 the expression guarantees to terminate,
499 without raising an exception,
500 without causing a side effect (e.g. writing a mutable variable)
502 NB: if exprIsHNF e, then exprOkForSpecuation e
505 let x = case y# +# 1# of { r# -> I# r# }
508 case y# +# 1# of { r# ->
513 We can only do this if the (y+1) is ok for speculation: it has no
514 side effects, and can't diverge or raise an exception.
517 exprOkForSpeculation :: CoreExpr -> Bool
518 exprOkForSpeculation (Lit _) = True
519 exprOkForSpeculation (Type _) = True
520 -- Tick boxes are *not* suitable for speculation
521 exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
522 && not (isTickBoxOp v)
523 exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
524 exprOkForSpeculation (Cast e co) = exprOkForSpeculation e
525 exprOkForSpeculation other_expr
526 = case collectArgs other_expr of
527 (Var f, args) -> spec_ok (globalIdDetails f) args
531 spec_ok (DataConWorkId _) args
532 = True -- The strictness of the constructor has already
533 -- been expressed by its "wrapper", so we don't need
534 -- to take the arguments into account
536 spec_ok (PrimOpId op) args
537 | isDivOp op, -- Special case for dividing operations that fail
538 [arg1, Lit lit] <- args -- only if the divisor is zero
539 = not (isZeroLit lit) && exprOkForSpeculation arg1
540 -- Often there is a literal divisor, and this
541 -- can get rid of a thunk in an inner looop
544 = primOpOkForSpeculation op &&
545 all exprOkForSpeculation args
546 -- A bit conservative: we don't really need
547 -- to care about lazy arguments, but this is easy
549 spec_ok other args = False
551 isDivOp :: PrimOp -> Bool
552 -- True of dyadic operators that can fail
553 -- only if the second arg is zero
554 -- This function probably belongs in PrimOp, or even in
555 -- an automagically generated file.. but it's such a
556 -- special case I thought I'd leave it here for now.
557 isDivOp IntQuotOp = True
558 isDivOp IntRemOp = True
559 isDivOp WordQuotOp = True
560 isDivOp WordRemOp = True
561 isDivOp IntegerQuotRemOp = True
562 isDivOp IntegerDivModOp = True
563 isDivOp FloatDivOp = True
564 isDivOp DoubleDivOp = True
565 isDivOp other = False
570 exprIsBottom :: CoreExpr -> Bool -- True => definitely bottom
571 exprIsBottom e = go 0 e
573 -- n is the number of args
574 go n (Note _ e) = go n e
575 go n (Cast e co) = go n e
576 go n (Let _ e) = go n e
577 go n (Case e _ _ _) = go 0 e -- Just check the scrut
578 go n (App e _) = go (n+1) e
579 go n (Var v) = idAppIsBottom v n
581 go n (Lam _ _) = False
582 go n (Type _) = False
584 idAppIsBottom :: Id -> Int -> Bool
585 idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
588 @exprIsHNF@ returns true for expressions that are certainly *already*
589 evaluated to *head* normal form. This is used to decide whether it's ok
592 case x of _ -> e ===> e
594 and to decide whether it's safe to discard a `seq`
596 So, it does *not* treat variables as evaluated, unless they say they are.
598 But it *does* treat partial applications and constructor applications
599 as values, even if their arguments are non-trivial, provided the argument
601 e.g. (:) (f x) (map f xs) is a value
602 map (...redex...) is a value
603 Because `seq` on such things completes immediately
605 For unlifted argument types, we have to be careful:
607 Suppose (f x) diverges; then C (f x) is not a value. True, but
608 this form is illegal (see the invariants in CoreSyn). Args of unboxed
609 type must be ok-for-speculation (or trivial).
612 exprIsHNF :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
613 exprIsHNF (Var v) -- NB: There are no value args at this point
614 = isDataConWorkId v -- Catches nullary constructors,
615 -- so that [] and () are values, for example
616 || idArity v > 0 -- Catches (e.g.) primops that don't have unfoldings
617 || isEvaldUnfolding (idUnfolding v)
618 -- Check the thing's unfolding; it might be bound to a value
619 -- A worry: what if an Id's unfolding is just itself:
620 -- then we could get an infinite loop...
622 exprIsHNF (Lit l) = True
623 exprIsHNF (Type ty) = True -- Types are honorary Values;
624 -- we don't mind copying them
625 exprIsHNF (Lam b e) = isRuntimeVar b || exprIsHNF e
626 exprIsHNF (Note _ e) = exprIsHNF e
627 exprIsHNF (Cast e co) = exprIsHNF e
628 exprIsHNF (App e (Type _)) = exprIsHNF e
629 exprIsHNF (App e a) = app_is_value e [a]
630 exprIsHNF other = False
632 -- There is at least one value argument
633 app_is_value (Var fun) args
634 | isDataConWorkId fun -- Constructor apps are values
635 || idArity fun > valArgCount args -- Under-applied function
636 = check_args (idType fun) args
637 app_is_value (App f a) as = app_is_value f (a:as)
638 app_is_value other as = False
640 -- 'check_args' checks that unlifted-type args
641 -- are in fact guaranteed non-divergent
642 check_args fun_ty [] = True
643 check_args fun_ty (Type _ : args) = case splitForAllTy_maybe fun_ty of
644 Just (_, ty) -> check_args ty args
645 check_args fun_ty (arg : args)
646 | isUnLiftedType arg_ty = exprOkForSpeculation arg
647 | otherwise = check_args res_ty args
649 (arg_ty, res_ty) = splitFunTy fun_ty
653 -- These InstPat functions go here to avoid circularity between DataCon and Id
654 dataConRepInstPat = dataConInstPat dataConRepArgTys (repeat (FSLIT("ipv")))
655 dataConRepFSInstPat = dataConInstPat dataConRepArgTys
656 dataConOrigInstPat = dataConInstPat dc_arg_tys (repeat (FSLIT("ipv")))
658 dc_arg_tys dc = map mkPredTy (dataConTheta dc) ++ dataConOrigArgTys dc
659 -- Remember to include the existential dictionaries
661 dataConInstPat :: (DataCon -> [Type]) -- function used to find arg tys
662 -> [FastString] -- A long enough list of FSs to use for names
663 -> [Unique] -- An equally long list of uniques, at least one for each binder
665 -> [Type] -- Types to instantiate the universally quantified tyvars
666 -> ([TyVar], [CoVar], [Id]) -- Return instantiated variables
667 -- dataConInstPat arg_fun fss us con inst_tys returns a triple
668 -- (ex_tvs, co_tvs, arg_ids),
670 -- ex_tvs are intended to be used as binders for existential type args
672 -- co_tvs are intended to be used as binders for coercion args and the kinds
673 -- of these vars have been instantiated by the inst_tys and the ex_tys
675 -- arg_ids are indended to be used as binders for value arguments, including
676 -- dicts, and their types have been instantiated with inst_tys and ex_tys
679 -- The following constructor T1
682 -- T1 :: forall b. Int -> b -> T(a,b)
685 -- has representation type
686 -- forall a. forall a1. forall b. (a :=: (a1,b)) =>
689 -- dataConInstPat fss us T1 (a1',b') will return
691 -- ([a1'', b''], [c :: (a1', b'):=:(a1'', b'')], [x :: Int, y :: b''])
693 -- where the double-primed variables are created with the FastStrings and
694 -- Uniques given as fss and us
695 dataConInstPat arg_fun fss uniqs con inst_tys
696 = (ex_bndrs, co_bndrs, id_bndrs)
698 univ_tvs = dataConUnivTyVars con
699 ex_tvs = dataConExTyVars con
700 arg_tys = arg_fun con
701 eq_spec = dataConEqSpec con
702 eq_preds = eqSpecPreds eq_spec
705 n_co = length eq_spec
707 -- split the Uniques and FastStrings
708 (ex_uniqs, uniqs') = splitAt n_ex uniqs
709 (co_uniqs, id_uniqs) = splitAt n_co uniqs'
711 (ex_fss, fss') = splitAt n_ex fss
712 (co_fss, id_fss) = splitAt n_co fss'
714 -- Make existential type variables
715 ex_bndrs = zipWith3 mk_ex_var ex_uniqs ex_fss ex_tvs
716 mk_ex_var uniq fs var = mkTyVar new_name kind
718 new_name = mkSysTvName uniq fs
721 -- Make the instantiating substitution
722 subst = zipOpenTvSubst (univ_tvs ++ ex_tvs) (inst_tys ++ map mkTyVarTy ex_bndrs)
724 -- Make new coercion vars, instantiating kind
725 co_bndrs = zipWith3 mk_co_var co_uniqs co_fss eq_preds
726 mk_co_var uniq fs eq_pred = mkCoVar new_name co_kind
728 new_name = mkSysTvName uniq fs
729 co_kind = substTy subst (mkPredTy eq_pred)
731 -- make value vars, instantiating types
732 mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (substTy subst ty) noSrcLoc
733 id_bndrs = zipWith3 mk_id_var id_uniqs id_fss arg_tys
735 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
736 -- Returns (Just (dc, [x1..xn])) if the argument expression is
737 -- a constructor application of the form (dc x1 .. xn)
738 exprIsConApp_maybe (Cast expr co)
739 = -- Here we do the PushC reduction rule as described in the FC paper
740 case exprIsConApp_maybe expr of {
742 Just (dc, dc_args) ->
744 -- The transformation applies iff we have
745 -- (C e1 ... en) `cast` co
746 -- where co :: (T t1 .. tn) :=: (T s1 ..sn)
747 -- That is, with a T at the top of both sides
748 -- The left-hand one must be a T, because exprIsConApp returned True
749 -- but the right-hand one might not be. (Though it usually will.)
751 let (from_ty, to_ty) = coercionKind co
752 (from_tc, from_tc_arg_tys) = splitTyConApp from_ty
753 -- The inner one must be a TyConApp
755 case splitTyConApp_maybe to_ty of {
757 Just (to_tc, to_tc_arg_tys)
758 | from_tc /= to_tc -> Nothing
759 -- These two Nothing cases are possible; we might see
760 -- (C x y) `cast` (g :: T a ~ S [a]),
761 -- where S is a type function. In fact, exprIsConApp
762 -- will probably not be called in such circumstances,
763 -- but there't nothing wrong with it
767 tc_arity = tyConArity from_tc
769 (univ_args, rest1) = splitAt tc_arity dc_args
770 (ex_args, rest2) = splitAt n_ex_tvs rest1
771 (co_args, val_args) = splitAt n_cos rest2
773 arg_tys = dataConRepArgTys dc
774 dc_univ_tyvars = dataConUnivTyVars dc
775 dc_ex_tyvars = dataConExTyVars dc
776 dc_eq_spec = dataConEqSpec dc
777 dc_tyvars = dc_univ_tyvars ++ dc_ex_tyvars
778 n_ex_tvs = length dc_ex_tyvars
779 n_cos = length dc_eq_spec
781 -- Make the "theta" from Fig 3 of the paper
782 gammas = decomposeCo tc_arity co
783 new_tys = gammas ++ map (\ (Type t) -> t) ex_args
784 theta = zipOpenTvSubst dc_tyvars new_tys
786 -- First we cast the existential coercion arguments
787 cast_co (tv,ty) (Type co) = Type $ mkSymCoercion (substTyVar theta tv)
789 `mkTransCoercion` (substTy theta ty)
790 new_co_args = zipWith cast_co dc_eq_spec co_args
792 -- ...and now value arguments
793 new_val_args = zipWith cast_arg arg_tys val_args
794 cast_arg arg_ty arg = mkCoerce (substTy theta arg_ty) arg
797 ASSERT( length univ_args == tc_arity )
798 ASSERT( from_tc == dataConTyCon dc )
799 ASSERT( and (zipWith coreEqType [t | Type t <- univ_args] from_tc_arg_tys) )
800 ASSERT( all isTypeArg (univ_args ++ ex_args) )
801 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 )
803 Just (dc, map Type to_tc_arg_tys ++ ex_args ++ new_co_args ++ new_val_args)
807 -- We do not want to tell the world that we have a
808 -- Cons, to *stop* Case of Known Cons, which removes
810 exprIsConApp_maybe (Note (TickBox {}) expr)
812 exprIsConApp_maybe (Note (BinaryTickBox {}) expr)
816 exprIsConApp_maybe (Note _ expr)
817 = exprIsConApp_maybe expr
818 -- We ignore InlineMe notes in case we have
819 -- x = __inline_me__ (a,b)
820 -- All part of making sure that INLINE pragmas never hurt
821 -- Marcin tripped on this one when making dictionaries more inlinable
823 -- In fact, we ignore all notes. For example,
824 -- case _scc_ "foo" (C a b) of
826 -- should be optimised away, but it will be only if we look
827 -- through the SCC note.
829 exprIsConApp_maybe expr = analyse (collectArgs expr)
831 analyse (Var fun, args)
832 | Just con <- isDataConWorkId_maybe fun,
833 args `lengthAtLeast` dataConRepArity con
834 -- Might be > because the arity excludes type args
837 -- Look through unfoldings, but only cheap ones, because
838 -- we are effectively duplicating the unfolding
839 analyse (Var fun, [])
840 | let unf = idUnfolding fun,
842 = exprIsConApp_maybe (unfoldingTemplate unf)
844 analyse other = Nothing
849 %************************************************************************
851 \subsection{Eta reduction and expansion}
853 %************************************************************************
856 exprEtaExpandArity :: DynFlags -> CoreExpr -> Arity
857 {- The Arity returned is the number of value args the
858 thing can be applied to without doing much work
860 exprEtaExpandArity is used when eta expanding
863 It returns 1 (or more) to:
864 case x of p -> \s -> ...
865 because for I/O ish things we really want to get that \s to the top.
866 We are prepared to evaluate x each time round the loop in order to get that
868 It's all a bit more subtle than it looks:
872 Consider one-shot lambdas
873 let x = expensive in \y z -> E
874 We want this to have arity 2 if the \y-abstraction is a 1-shot lambda
875 Hence the ArityType returned by arityType
877 2. The state-transformer hack
879 The one-shot lambda special cause is particularly important/useful for
880 IO state transformers, where we often get
881 let x = E in \ s -> ...
883 and the \s is a real-world state token abstraction. Such abstractions
884 are almost invariably 1-shot, so we want to pull the \s out, past the
885 let x=E, even if E is expensive. So we treat state-token lambdas as
886 one-shot even if they aren't really. The hack is in Id.isOneShotBndr.
888 3. Dealing with bottom
891 f = \x -> error "foo"
892 Here, arity 1 is fine. But if it is
896 then we want to get arity 2. Tecnically, this isn't quite right, because
898 should diverge, but it'll converge if we eta-expand f. Nevertheless, we
899 do so; it improves some programs significantly, and increasing convergence
900 isn't a bad thing. Hence the ABot/ATop in ArityType.
902 Actually, the situation is worse. Consider
906 Can we eta-expand here? At first the answer looks like "yes of course", but
909 This should diverge! But if we eta-expand, it won't. Again, we ignore this
910 "problem", because being scrupulous would lose an important transformation for
916 Non-recursive newtypes are transparent, and should not get in the way.
917 We do (currently) eta-expand recursive newtypes too. So if we have, say
919 newtype T = MkT ([T] -> Int)
923 where f has arity 1. Then: etaExpandArity e = 1;
924 that is, etaExpandArity looks through the coerce.
926 When we eta-expand e to arity 1: eta_expand 1 e T
927 we want to get: coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
929 HOWEVER, note that if you use coerce bogusly you can ge
931 And since negate has arity 2, you might try to eta expand. But you can't
932 decopose Int to a function type. Hence the final case in eta_expand.
936 exprEtaExpandArity dflags e = arityDepth (arityType dflags e)
938 -- A limited sort of function type
939 data ArityType = AFun Bool ArityType -- True <=> one-shot
940 | ATop -- Know nothing
943 arityDepth :: ArityType -> Arity
944 arityDepth (AFun _ ty) = 1 + arityDepth ty
947 andArityType ABot at2 = at2
948 andArityType ATop at2 = ATop
949 andArityType (AFun t1 at1) (AFun t2 at2) = AFun (t1 && t2) (andArityType at1 at2)
950 andArityType at1 at2 = andArityType at2 at1
952 arityType :: DynFlags -> CoreExpr -> ArityType
953 -- (go1 e) = [b1,..,bn]
954 -- means expression can be rewritten \x_b1 -> ... \x_bn -> body
955 -- where bi is True <=> the lambda is one-shot
957 arityType dflags (Note n e) = arityType dflags e
958 -- Not needed any more: etaExpand is cleverer
959 -- | ok_note n = arityType dflags e
960 -- | otherwise = ATop
962 arityType dflags (Cast e co) = arityType dflags e
964 arityType dflags (Var v)
965 = mk (idArity v) (arg_tys (idType v))
967 mk :: Arity -> [Type] -> ArityType
968 -- The argument types are only to steer the "state hack"
969 -- Consider case x of
971 -- False -> \(s:RealWorld) -> e
972 -- where foo has arity 1. Then we want the state hack to
973 -- apply to foo too, so we can eta expand the case.
974 mk 0 tys | isBottomingId v = ABot
975 | (ty:tys) <- tys, isStateHackType ty = AFun True ATop
977 mk n (ty:tys) = AFun (isStateHackType ty) (mk (n-1) tys)
978 mk n [] = AFun False (mk (n-1) [])
980 arg_tys :: Type -> [Type] -- Ignore for-alls
982 | Just (_, ty') <- splitForAllTy_maybe ty = arg_tys ty'
983 | Just (arg,res) <- splitFunTy_maybe ty = arg : arg_tys res
986 -- Lambdas; increase arity
987 arityType dflags (Lam x e)
988 | isId x = AFun (isOneShotBndr x) (arityType dflags e)
989 | otherwise = arityType dflags e
991 -- Applications; decrease arity
992 arityType dflags (App f (Type _)) = arityType dflags f
993 arityType dflags (App f a) = case arityType dflags f of
994 AFun one_shot xs | exprIsCheap a -> xs
997 -- Case/Let; keep arity if either the expression is cheap
998 -- or it's a 1-shot lambda
999 -- The former is not really right for Haskell
1000 -- f x = case x of { (a,b) -> \y. e }
1002 -- f x y = case x of { (a,b) -> e }
1003 -- The difference is observable using 'seq'
1004 arityType dflags (Case scrut _ _ alts)
1005 = case foldr1 andArityType [arityType dflags rhs | (_,_,rhs) <- alts] of
1006 xs | exprIsCheap scrut -> xs
1007 xs@(AFun one_shot _) | one_shot -> AFun True ATop
1010 arityType dflags (Let b e)
1011 = case arityType dflags e of
1012 xs | cheap_bind b -> xs
1013 xs@(AFun one_shot _) | one_shot -> AFun True ATop
1016 cheap_bind (NonRec b e) = is_cheap (b,e)
1017 cheap_bind (Rec prs) = all is_cheap prs
1018 is_cheap (b,e) = (dopt Opt_DictsCheap dflags && isDictId b)
1020 -- If the experimental -fdicts-cheap flag is on, we eta-expand through
1021 -- dictionary bindings. This improves arities. Thereby, it also
1022 -- means that full laziness is less prone to floating out the
1023 -- application of a function to its dictionary arguments, which
1024 -- can thereby lose opportunities for fusion. Example:
1025 -- foo :: Ord a => a -> ...
1026 -- foo = /\a \(d:Ord a). let d' = ...d... in \(x:a). ....
1027 -- -- So foo has arity 1
1029 -- f = \x. foo dInt $ bar x
1031 -- The (foo DInt) is floated out, and makes ineffective a RULE
1032 -- foo (bar x) = ...
1034 -- One could go further and make exprIsCheap reply True to any
1035 -- dictionary-typed expression, but that's more work.
1037 arityType dflags other = ATop
1039 {- NOT NEEDED ANY MORE: etaExpand is cleverer
1040 ok_note InlineMe = False
1041 ok_note other = True
1042 -- Notice that we do not look through __inline_me__
1043 -- This may seem surprising, but consider
1044 -- f = _inline_me (\x -> e)
1045 -- We DO NOT want to eta expand this to
1046 -- f = \x -> (_inline_me (\x -> e)) x
1047 -- because the _inline_me gets dropped now it is applied,
1056 etaExpand :: Arity -- Result should have this number of value args
1058 -> CoreExpr -> Type -- Expression and its type
1060 -- (etaExpand n us e ty) returns an expression with
1061 -- the same meaning as 'e', but with arity 'n'.
1063 -- Given e' = etaExpand n us e ty
1065 -- ty = exprType e = exprType e'
1067 -- Note that SCCs are not treated specially. If we have
1068 -- etaExpand 2 (\x -> scc "foo" e)
1069 -- = (\xy -> (scc "foo" e) y)
1070 -- So the costs of evaluating 'e' (not 'e y') are attributed to "foo"
1072 etaExpand n us expr ty
1073 | manifestArity expr >= n = expr -- The no-op case
1075 = eta_expand n us expr ty
1078 -- manifestArity sees how many leading value lambdas there are
1079 manifestArity :: CoreExpr -> Arity
1080 manifestArity (Lam v e) | isId v = 1 + manifestArity e
1081 | otherwise = manifestArity e
1082 manifestArity (Note _ e) = manifestArity e
1083 manifestArity (Cast e _) = manifestArity e
1086 -- etaExpand deals with for-alls. For example:
1088 -- where E :: forall a. a -> a
1090 -- (/\b. \y::a -> E b y)
1092 -- It deals with coerces too, though they are now rare
1093 -- so perhaps the extra code isn't worth it
1095 eta_expand n us expr ty
1097 -- The ILX code generator requires eta expansion for type arguments
1098 -- too, but alas the 'n' doesn't tell us how many of them there
1099 -- may be. So we eagerly eta expand any big lambdas, and just
1100 -- cross our fingers about possible loss of sharing in the ILX case.
1101 -- The Right Thing is probably to make 'arity' include
1102 -- type variables throughout the compiler. (ToDo.)
1104 -- Saturated, so nothing to do
1107 -- Short cut for the case where there already
1108 -- is a lambda; no point in gratuitously adding more
1109 eta_expand n us (Lam v body) ty
1111 = Lam v (eta_expand n us body (applyTy ty (mkTyVarTy v)))
1114 = Lam v (eta_expand (n-1) us body (funResultTy ty))
1116 -- We used to have a special case that stepped inside Coerces here,
1117 -- thus: eta_expand n us (Note note@(Coerce _ ty) e) _
1118 -- = Note note (eta_expand n us e ty)
1119 -- BUT this led to an infinite loop
1120 -- Example: newtype T = MkT (Int -> Int)
1121 -- eta_expand 1 (coerce (Int->Int) e)
1122 -- --> coerce (Int->Int) (eta_expand 1 T e)
1124 -- --> coerce (Int->Int) (coerce T
1125 -- (\x::Int -> eta_expand 1 (coerce (Int->Int) e)))
1126 -- by the splitNewType_maybe case below
1129 eta_expand n us expr ty
1130 = ASSERT2 (exprType expr `coreEqType` ty, ppr (exprType expr) $$ ppr ty)
1131 case splitForAllTy_maybe ty of {
1134 Lam lam_tv (eta_expand n us2 (App expr (Type (mkTyVarTy lam_tv))) (substTyWith [tv] [mkTyVarTy lam_tv] ty'))
1136 lam_tv = setVarName tv (mkSysTvName uniq FSLIT("etaT"))
1137 -- Using tv as a base retains its tyvar/covar-ness
1141 case splitFunTy_maybe ty of {
1142 Just (arg_ty, res_ty) -> Lam arg1 (eta_expand (n-1) us2 (App expr (Var arg1)) res_ty)
1144 arg1 = mkSysLocal FSLIT("eta") uniq arg_ty
1150 -- newtype T = MkT ([T] -> Int)
1151 -- Consider eta-expanding this
1154 -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
1156 case splitNewTypeRepCo_maybe ty of {
1158 mkCoerce (mkSymCoercion co) (eta_expand n us (mkCoerce co expr) ty1) ;
1161 -- We have an expression of arity > 0, but its type isn't a function
1162 -- This *can* legitmately happen: e.g. coerce Int (\x. x)
1163 -- Essentially the programmer is playing fast and loose with types
1164 -- (Happy does this a lot). So we simply decline to eta-expand.
1169 exprArity is a cheap-and-cheerful version of exprEtaExpandArity.
1170 It tells how many things the expression can be applied to before doing
1171 any work. It doesn't look inside cases, lets, etc. The idea is that
1172 exprEtaExpandArity will do the hard work, leaving something that's easy
1173 for exprArity to grapple with. In particular, Simplify uses exprArity to
1174 compute the ArityInfo for the Id.
1176 Originally I thought that it was enough just to look for top-level lambdas, but
1177 it isn't. I've seen this
1179 foo = PrelBase.timesInt
1181 We want foo to get arity 2 even though the eta-expander will leave it
1182 unchanged, in the expectation that it'll be inlined. But occasionally it
1183 isn't, because foo is blacklisted (used in a rule).
1185 Similarly, see the ok_note check in exprEtaExpandArity. So
1186 f = __inline_me (\x -> e)
1187 won't be eta-expanded.
1189 And in any case it seems more robust to have exprArity be a bit more intelligent.
1190 But note that (\x y z -> f x y z)
1191 should have arity 3, regardless of f's arity.
1194 exprArity :: CoreExpr -> Arity
1197 go (Var v) = idArity v
1198 go (Lam x e) | isId x = go e + 1
1200 go (Note n e) = go e
1201 go (Cast e _) = go e
1202 go (App e (Type t)) = go e
1203 go (App f a) | exprIsCheap a = (go f - 1) `max` 0
1204 -- NB: exprIsCheap a!
1205 -- f (fac x) does not have arity 2,
1206 -- even if f has arity 3!
1207 -- NB: `max 0`! (\x y -> f x) has arity 2, even if f is
1208 -- unknown, hence arity 0
1212 %************************************************************************
1214 \subsection{Equality}
1216 %************************************************************************
1218 @cheapEqExpr@ is a cheap equality test which bales out fast!
1219 True => definitely equal
1220 False => may or may not be equal
1223 cheapEqExpr :: Expr b -> Expr b -> Bool
1225 cheapEqExpr (Var v1) (Var v2) = v1==v2
1226 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
1227 cheapEqExpr (Type t1) (Type t2) = t1 `coreEqType` t2
1229 cheapEqExpr (App f1 a1) (App f2 a2)
1230 = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
1232 cheapEqExpr _ _ = False
1234 exprIsBig :: Expr b -> Bool
1235 -- Returns True of expressions that are too big to be compared by cheapEqExpr
1236 exprIsBig (Lit _) = False
1237 exprIsBig (Var v) = False
1238 exprIsBig (Type t) = False
1239 exprIsBig (App f a) = exprIsBig f || exprIsBig a
1240 exprIsBig (Cast e _) = exprIsBig e -- Hopefully coercions are not too big!
1241 exprIsBig other = True
1246 tcEqExpr :: CoreExpr -> CoreExpr -> Bool
1247 -- Used in rule matching, so does *not* look through
1248 -- newtypes, predicate types; hence tcEqExpr
1250 tcEqExpr e1 e2 = tcEqExprX rn_env e1 e2
1252 rn_env = mkRnEnv2 (mkInScopeSet (exprFreeVars e1 `unionVarSet` exprFreeVars e2))
1254 tcEqExprX :: RnEnv2 -> CoreExpr -> CoreExpr -> Bool
1255 tcEqExprX env (Var v1) (Var v2) = rnOccL env v1 == rnOccR env v2
1256 tcEqExprX env (Lit lit1) (Lit lit2) = lit1 == lit2
1257 tcEqExprX env (App f1 a1) (App f2 a2) = tcEqExprX env f1 f2 && tcEqExprX env a1 a2
1258 tcEqExprX env (Lam v1 e1) (Lam v2 e2) = tcEqExprX (rnBndr2 env v1 v2) e1 e2
1259 tcEqExprX env (Let (NonRec v1 r1) e1)
1260 (Let (NonRec v2 r2) e2) = tcEqExprX env r1 r2
1261 && tcEqExprX (rnBndr2 env v1 v2) e1 e2
1262 tcEqExprX env (Let (Rec ps1) e1)
1263 (Let (Rec ps2) e2) = equalLength ps1 ps2
1264 && and (zipWith eq_rhs ps1 ps2)
1265 && tcEqExprX env' e1 e2
1267 env' = foldl2 rn_bndr2 env ps2 ps2
1268 rn_bndr2 env (b1,_) (b2,_) = rnBndr2 env b1 b2
1269 eq_rhs (_,r1) (_,r2) = tcEqExprX env' r1 r2
1270 tcEqExprX env (Case e1 v1 t1 a1)
1271 (Case e2 v2 t2 a2) = tcEqExprX env e1 e2
1272 && tcEqTypeX env t1 t2
1273 && equalLength a1 a2
1274 && and (zipWith (eq_alt env') a1 a2)
1276 env' = rnBndr2 env v1 v2
1278 tcEqExprX env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && tcEqExprX env e1 e2
1279 tcEqExprX env (Cast e1 co1) (Cast e2 co2) = tcEqTypeX env co1 co2 && tcEqExprX env e1 e2
1280 tcEqExprX env (Type t1) (Type t2) = tcEqTypeX env t1 t2
1281 tcEqExprX env e1 e2 = False
1283 eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 && tcEqExprX (rnBndrs2 env vs1 vs2) r1 r2
1285 eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2
1286 eq_note env (CoreNote s1) (CoreNote s2) = s1 == s2
1287 eq_note env other1 other2 = False
1291 %************************************************************************
1293 \subsection{The size of an expression}
1295 %************************************************************************
1298 coreBindsSize :: [CoreBind] -> Int
1299 coreBindsSize bs = foldr ((+) . bindSize) 0 bs
1301 exprSize :: CoreExpr -> Int
1302 -- A measure of the size of the expressions
1303 -- It also forces the expression pretty drastically as a side effect
1304 exprSize (Var v) = v `seq` 1
1305 exprSize (Lit lit) = lit `seq` 1
1306 exprSize (App f a) = exprSize f + exprSize a
1307 exprSize (Lam b e) = varSize b + exprSize e
1308 exprSize (Let b e) = bindSize b + exprSize e
1309 exprSize (Case e b t as) = seqType t `seq` exprSize e + varSize b + 1 + foldr ((+) . altSize) 0 as
1310 exprSize (Cast e co) = (seqType co `seq` 1) + exprSize e
1311 exprSize (Note n e) = noteSize n + exprSize e
1312 exprSize (Type t) = seqType t `seq` 1
1314 noteSize (SCC cc) = cc `seq` 1
1315 noteSize InlineMe = 1
1316 noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations
1318 varSize :: Var -> Int
1319 varSize b | isTyVar b = 1
1320 | otherwise = seqType (idType b) `seq`
1321 megaSeqIdInfo (idInfo b) `seq`
1324 varsSize = foldr ((+) . varSize) 0
1326 bindSize (NonRec b e) = varSize b + exprSize e
1327 bindSize (Rec prs) = foldr ((+) . pairSize) 0 prs
1329 pairSize (b,e) = varSize b + exprSize e
1331 altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
1335 %************************************************************************
1337 \subsection{Hashing}
1339 %************************************************************************
1342 hashExpr :: CoreExpr -> Int
1343 -- Two expressions that hash to the same Int may be equal (but may not be)
1344 -- Two expressions that hash to the different Ints are definitely unequal
1346 -- But "unequal" here means "not identical"; two alpha-equivalent
1347 -- expressions may hash to the different Ints
1349 -- The emphasis is on a crude, fast hash, rather than on high precision
1351 -- We must be careful that \x.x and \y.y map to the same hash code,
1352 -- (at least if we want the above invariant to be true)
1354 hashExpr e | hash < 0 = 77 -- Just in case we hit -maxInt
1357 hash = abs (hash_expr (1,emptyVarEnv) e) -- Negative numbers kill UniqFM
1359 type HashEnv = (Int, VarEnv Int) -- Hash code for bound variables
1361 hash_expr :: HashEnv -> CoreExpr -> Int
1362 hash_expr env (Note _ e) = hash_expr env e
1363 hash_expr env (Cast e co) = hash_expr env e
1364 hash_expr env (Var v) = hashVar env v
1365 hash_expr env (Lit lit) = hashLiteral lit
1366 hash_expr env (App f e) = hash_expr env f * fast_hash_expr env e
1367 hash_expr env (Let (NonRec b r) e) = hash_expr (extend_env env b) e * fast_hash_expr env r
1368 hash_expr env (Let (Rec ((b,r):_)) e) = hash_expr (extend_env env b) e
1369 hash_expr env (Case e _ _ _) = hash_expr env e
1370 hash_expr env (Lam b e) = hash_expr (extend_env env b) e
1371 hash_expr env (Type t) = fast_hash_type env t
1373 fast_hash_expr env (Var v) = hashVar env v
1374 fast_hash_expr env (Type t) = fast_hash_type env t
1375 fast_hash_expr env (Lit lit) = hashLiteral lit
1376 fast_hash_expr env (Cast e co) = fast_hash_expr env e
1377 fast_hash_expr env (Note n e) = fast_hash_expr env e
1378 fast_hash_expr env (App f a) = fast_hash_expr env a -- A bit idiosyncratic ('a' not 'f')!
1379 fast_hash_expr env other = 1
1381 fast_hash_type :: HashEnv -> Type -> Int
1382 fast_hash_type env ty
1383 | Just tv <- getTyVar_maybe ty = hashVar env tv
1384 | Just (tc,_) <- splitTyConApp_maybe ty = hashName (tyConName tc)
1387 extend_env :: HashEnv -> Var -> (Int, VarEnv Int)
1388 extend_env (n,env) b = (n+1, extendVarEnv env b n)
1390 hashVar :: HashEnv -> Var -> Int
1391 hashVar (_,env) v = lookupVarEnv env v `orElse` hashName (idName v)
1394 %************************************************************************
1396 \subsection{Determining non-updatable right-hand-sides}
1398 %************************************************************************
1400 Top-level constructor applications can usually be allocated
1401 statically, but they can't if the constructor, or any of the
1402 arguments, come from another DLL (because we can't refer to static
1403 labels in other DLLs).
1405 If this happens we simply make the RHS into an updatable thunk,
1406 and 'exectute' it rather than allocating it statically.
1409 rhsIsStatic :: PackageId -> CoreExpr -> Bool
1410 -- This function is called only on *top-level* right-hand sides
1411 -- Returns True if the RHS can be allocated statically, with
1412 -- no thunks involved at all.
1414 -- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or
1415 -- refers to, CAFs; and (ii) in CoreToStg to decide whether to put an
1416 -- update flag on it.
1418 -- The basic idea is that rhsIsStatic returns True only if the RHS is
1419 -- (a) a value lambda
1420 -- (b) a saturated constructor application with static args
1422 -- BUT watch out for
1423 -- (i) Any cross-DLL references kill static-ness completely
1424 -- because they must be 'executed' not statically allocated
1425 -- ("DLL" here really only refers to Windows DLLs, on other platforms,
1426 -- this is not necessary)
1428 -- (ii) We treat partial applications as redexes, because in fact we
1429 -- make a thunk for them that runs and builds a PAP
1430 -- at run-time. The only appliations that are treated as
1431 -- static are *saturated* applications of constructors.
1433 -- We used to try to be clever with nested structures like this:
1434 -- ys = (:) w ((:) w [])
1435 -- on the grounds that CorePrep will flatten ANF-ise it later.
1436 -- But supporting this special case made the function much more
1437 -- complicated, because the special case only applies if there are no
1438 -- enclosing type lambdas:
1439 -- ys = /\ a -> Foo (Baz ([] a))
1440 -- Here the nested (Baz []) won't float out to top level in CorePrep.
1442 -- But in fact, even without -O, nested structures at top level are
1443 -- flattened by the simplifier, so we don't need to be super-clever here.
1447 -- f = \x::Int. x+7 TRUE
1448 -- p = (True,False) TRUE
1450 -- d = (fst p, False) FALSE because there's a redex inside
1451 -- (this particular one doesn't happen but...)
1453 -- h = D# (1.0## /## 2.0##) FALSE (redex again)
1454 -- n = /\a. Nil a TRUE
1456 -- t = /\a. (:) (case w a of ...) (Nil a) FALSE (redex)
1459 -- This is a bit like CoreUtils.exprIsHNF, with the following differences:
1460 -- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
1462 -- b) (C x xs), where C is a contructors is updatable if the application is
1465 -- c) don't look through unfolding of f in (f x).
1467 -- When opt_RuntimeTypes is on, we keep type lambdas and treat
1468 -- them as making the RHS re-entrant (non-updatable).
1470 rhsIsStatic this_pkg rhs = is_static False rhs
1472 is_static :: Bool -- True <=> in a constructor argument; must be atomic
1475 is_static False (Lam b e) = isRuntimeVar b || is_static False e
1477 is_static in_arg (Note (SCC _) e) = False
1478 is_static in_arg (Note _ e) = is_static in_arg e
1479 is_static in_arg (Cast e co) = is_static in_arg e
1481 is_static in_arg (Lit lit)
1483 MachLabel _ _ -> False
1485 -- A MachLabel (foreign import "&foo") in an argument
1486 -- prevents a constructor application from being static. The
1487 -- reason is that it might give rise to unresolvable symbols
1488 -- in the object file: under Linux, references to "weak"
1489 -- symbols from the data segment give rise to "unresolvable
1490 -- relocation" errors at link time This might be due to a bug
1491 -- in the linker, but we'll work around it here anyway.
1494 is_static in_arg other_expr = go other_expr 0
1496 go (Var f) n_val_args
1497 #if mingw32_TARGET_OS
1498 | not (isDllName this_pkg (idName f))
1500 = saturated_data_con f n_val_args
1501 || (in_arg && n_val_args == 0)
1502 -- A naked un-applied variable is *not* deemed a static RHS
1504 -- Reason: better to update so that the indirection gets shorted
1505 -- out, and the true value will be seen
1506 -- NB: if you change this, you'll break the invariant that THUNK_STATICs
1507 -- are always updatable. If you do so, make sure that non-updatable
1508 -- ones have enough space for their static link field!
1510 go (App f a) n_val_args
1511 | isTypeArg a = go f n_val_args
1512 | not in_arg && is_static True a = go f (n_val_args + 1)
1513 -- The (not in_arg) checks that we aren't in a constructor argument;
1514 -- if we are, we don't allow (value) applications of any sort
1516 -- NB. In case you wonder, args are sometimes not atomic. eg.
1517 -- x = D# (1.0## /## 2.0##)
1518 -- can't float because /## can fail.
1520 go (Note (SCC _) f) n_val_args = False
1521 go (Note _ f) n_val_args = go f n_val_args
1522 go (Cast e co) n_val_args = go e n_val_args
1524 go other n_val_args = False
1526 saturated_data_con f n_val_args
1527 = case isDataConWorkId_maybe f of
1528 Just dc -> n_val_args == dataConRepArity dc