2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[SpecConstr]{Specialise over constructors}
7 -- The above warning supression flag is a temporary kludge.
8 -- While working on this module you are encouraged to remove it and fix
9 -- any warnings in the module. See
10 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
17 #include "HsVersions.h"
22 import CoreUnfold ( couldBeSmallEnoughToInline )
23 import CoreLint ( showPass, endPass )
24 import CoreFVs ( exprsFreeVars )
25 import CoreTidy ( tidyRules )
26 import PprCore ( pprRules )
27 import WwLib ( mkWorkerArgs )
28 import DataCon ( dataConRepArity, dataConUnivTyVars )
30 import Type hiding( substTy )
31 import Id ( Id, idName, idType, isDataConWorkId_maybe, idArity,
32 mkUserLocal, mkSysLocal, idUnfolding, isLocalId )
37 import Rules ( addIdSpecialisations, mkLocalRule, rulesOfBinds )
38 import OccName ( mkSpecOcc )
39 import ErrUtils ( dumpIfSet_dyn )
40 import DynFlags ( DynFlags(..), DynFlag(..) )
41 import StaticFlags ( opt_SpecInlineJoinPoints )
42 import BasicTypes ( Activation(..) )
43 import Maybes ( orElse, catMaybes, isJust )
45 import List ( nubBy, partition )
53 -----------------------------------------------------
55 -----------------------------------------------------
60 drop n (x:xs) = drop (n-1) xs
62 After the first time round, we could pass n unboxed. This happens in
63 numerical code too. Here's what it looks like in Core:
65 drop n xs = case xs of
70 _ -> drop (I# (n# -# 1#)) xs
72 Notice that the recursive call has an explicit constructor as argument.
73 Noticing this, we can make a specialised version of drop
75 RULE: drop (I# n#) xs ==> drop' n# xs
77 drop' n# xs = let n = I# n# in ...orig RHS...
79 Now the simplifier will apply the specialisation in the rhs of drop', giving
81 drop' n# xs = case xs of
85 _ -> drop (n# -# 1#) xs
89 We'd also like to catch cases where a parameter is carried along unchanged,
90 but evaluated each time round the loop:
92 f i n = if i>0 || i>n then i else f (i*2) n
94 Here f isn't strict in n, but we'd like to avoid evaluating it each iteration.
95 In Core, by the time we've w/wd (f is strict in i) we get
97 f i# n = case i# ># 0 of
99 True -> case n of n' { I# n# ->
102 True -> f (i# *# 2#) n'
104 At the call to f, we see that the argument, n is know to be (I# n#),
105 and n is evaluated elsewhere in the body of f, so we can play the same
111 We must be careful not to allocate the same constructor twice. Consider
112 f p = (...(case p of (a,b) -> e)...p...,
113 ...let t = (r,s) in ...t...(f t)...)
114 At the recursive call to f, we can see that t is a pair. But we do NOT want
115 to make a specialised copy:
116 f' a b = let p = (a,b) in (..., ...)
117 because now t is allocated by the caller, then r and s are passed to the
118 recursive call, which allocates the (r,s) pair again.
121 (a) the argument p is used in other than a case-scrutinsation way.
122 (b) the argument to the call is not a 'fresh' tuple; you have to
123 look into its unfolding to see that it's a tuple
125 Hence the "OR" part of Note [Good arguments] below.
127 ALTERNATIVE 2: pass both boxed and unboxed versions. This no longer saves
128 allocation, but does perhaps save evals. In the RULE we'd have
131 f (I# x#) = f' (I# x#) x#
133 If at the call site the (I# x) was an unfolding, then we'd have to
134 rely on CSE to eliminate the duplicate allocation.... This alternative
135 doesn't look attractive enough to pursue.
137 ALTERNATIVE 3: ignore the reboxing problem. The trouble is that
138 the conservative reboxing story prevents many useful functions from being
139 specialised. Example:
140 foo :: Maybe Int -> Int -> Int
142 foo x@(Just m) n = foo x (n-m)
143 Here the use of 'x' will clearly not require boxing in the specialised function.
145 The strictness analyser has the same problem, in fact. Example:
147 If we pass just 'a' and 'b' to the worker, it might need to rebox the
148 pair to create (a,b). A more sophisticated analysis might figure out
149 precisely the cases in which this could happen, but the strictness
150 analyser does no such analysis; it just passes 'a' and 'b', and hopes
153 So my current choice is to make SpecConstr similarly aggressive, and
154 ignore the bad potential of reboxing.
157 Note [Good arguments]
158 ~~~~~~~~~~~~~~~~~~~~~
161 * A self-recursive function. Ignore mutual recursion for now,
162 because it's less common, and the code is simpler for self-recursion.
166 a) At a recursive call, one or more parameters is an explicit
167 constructor application
169 That same parameter is scrutinised by a case somewhere in
170 the RHS of the function
174 b) At a recursive call, one or more parameters has an unfolding
175 that is an explicit constructor application
177 That same parameter is scrutinised by a case somewhere in
178 the RHS of the function
180 Those are the only uses of the parameter (see Note [Reboxing])
183 What to abstract over
184 ~~~~~~~~~~~~~~~~~~~~~
185 There's a bit of a complication with type arguments. If the call
188 f p = ...f ((:) [a] x xs)...
190 then our specialised function look like
192 f_spec x xs = let p = (:) [a] x xs in ....as before....
194 This only makes sense if either
195 a) the type variable 'a' is in scope at the top of f, or
196 b) the type variable 'a' is an argument to f (and hence fs)
198 Actually, (a) may hold for value arguments too, in which case
199 we may not want to pass them. Supose 'x' is in scope at f's
200 defn, but xs is not. Then we'd like
202 f_spec xs = let p = (:) [a] x xs in ....as before....
204 Similarly (b) may hold too. If x is already an argument at the
205 call, no need to pass it again.
207 Finally, if 'a' is not in scope at the call site, we could abstract
208 it as we do the term variables:
210 f_spec a x xs = let p = (:) [a] x xs in ...as before...
212 So the grand plan is:
214 * abstract the call site to a constructor-only pattern
215 e.g. C x (D (f p) (g q)) ==> C s1 (D s2 s3)
217 * Find the free variables of the abstracted pattern
219 * Pass these variables, less any that are in scope at
220 the fn defn. But see Note [Shadowing] below.
223 NOTICE that we only abstract over variables that are not in scope,
224 so we're in no danger of shadowing variables used in "higher up"
230 In this pass we gather up usage information that may mention variables
231 that are bound between the usage site and the definition site; or (more
232 seriously) may be bound to something different at the definition site.
235 f x = letrec g y v = let x = ...
238 Since 'x' is in scope at the call site, we may make a rewrite rule that
240 RULE forall a,b. g (a,b) x = ...
241 But this rule will never match, because it's really a different 'x' at
242 the call site -- and that difference will be manifest by the time the
243 simplifier gets to it. [A worry: the simplifier doesn't *guarantee*
244 no-shadowing, so perhaps it may not be distinct?]
246 Anyway, the rule isn't actually wrong, it's just not useful. One possibility
247 is to run deShadowBinds before running SpecConstr, but instead we run the
248 simplifier. That gives the simplest possible program for SpecConstr to
249 chew on; and it virtually guarantees no shadowing.
251 Note [Specialising for constant parameters]
252 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
253 This one is about specialising on a *constant* (but not necessarily
254 constructor) argument
256 foo :: Int -> (Int -> Int) -> Int
258 foo m f = foo (f m) (+1)
262 lvl_rmV :: GHC.Base.Int -> GHC.Base.Int
264 \ (ds_dlk :: GHC.Base.Int) ->
265 case ds_dlk of wild_alH { GHC.Base.I# x_alG ->
266 GHC.Base.I# (GHC.Prim.+# x_alG 1)
268 T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
271 \ (ww_sme :: GHC.Prim.Int#) (w_smg :: GHC.Base.Int -> GHC.Base.Int) ->
272 case ww_sme of ds_Xlw {
274 case w_smg (GHC.Base.I# ds_Xlw) of w1_Xmo { GHC.Base.I# ww1_Xmz ->
275 T.$wfoo ww1_Xmz lvl_rmV
280 The recursive call has lvl_rmV as its argument, so we could create a specialised copy
281 with that argument baked in; that is, not passed at all. Now it can perhaps be inlined.
283 When is this worth it? Call the constant 'lvl'
284 - If 'lvl' has an unfolding that is a constructor, see if the corresponding
285 parameter is scrutinised anywhere in the body.
287 - If 'lvl' has an unfolding that is a inlinable function, see if the corresponding
288 parameter is applied (...to enough arguments...?)
290 Also do this is if the function has RULES?
294 Note [Specialising for lambda parameters]
295 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
296 foo :: Int -> (Int -> Int) -> Int
298 foo m f = foo (f m) (\n -> n-m)
300 This is subtly different from the previous one in that we get an
301 explicit lambda as the argument:
303 T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
306 \ (ww_sm8 :: GHC.Prim.Int#) (w_sma :: GHC.Base.Int -> GHC.Base.Int) ->
307 case ww_sm8 of ds_Xlr {
309 case w_sma (GHC.Base.I# ds_Xlr) of w1_Xmf { GHC.Base.I# ww1_Xmq ->
312 (\ (n_ad3 :: GHC.Base.Int) ->
313 case n_ad3 of wild_alB { GHC.Base.I# x_alA ->
314 GHC.Base.I# (GHC.Prim.-# x_alA ds_Xlr)
320 I wonder if SpecConstr couldn't be extended to handle this? After all,
321 lambda is a sort of constructor for functions and perhaps it already
322 has most of the necessary machinery?
324 Furthermore, there's an immediate win, because you don't need to allocate the lamda
325 at the call site; and if perchance it's called in the recursive call, then you
326 may avoid allocating it altogether. Just like for constructors.
328 Looks cool, but probably rare...but it might be easy to implement.
331 Note [SpecConstr for casts]
332 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
335 data instance T Int = T Int
340 go (T n) = go (T (n-1))
342 The recursive call ends up looking like
343 go (T (I# ...) `cast` g)
344 So we want to spot the construtor application inside the cast.
345 That's why we have the Cast case in argToPat
348 -----------------------------------------------------
349 Stuff not yet handled
350 -----------------------------------------------------
352 Here are notes arising from Roman's work that I don't want to lose.
358 foo :: Int -> T Int -> Int
360 foo x t | even x = case t of { T n -> foo (x-n) t }
361 | otherwise = foo (x-1) t
363 SpecConstr does no specialisation, because the second recursive call
364 looks like a boxed use of the argument. A pity.
366 $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
368 \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) ->
369 case ww_sFo of ds_Xw6 [Just L] {
371 case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] {
372 __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq;
374 case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] ->
375 case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] ->
376 $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy
382 data a :*: b = !a :*: !b
385 foo :: (Int :*: T Int) -> Int
387 foo (x :*: t) | even x = case t of { T n -> foo ((x-n) :*: t) }
388 | otherwise = foo ((x-1) :*: t)
390 Very similar to the previous one, except that the parameters are now in
391 a strict tuple. Before SpecConstr, we have
393 $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
395 \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T
397 case ww_sFU of ds_Xws [Just L] {
399 case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] {
401 case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] ->
402 $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2 -- $wfoo1
405 case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] ->
406 case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] ->
407 $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB -- $wfoo2
411 We get two specialisations:
412 "SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#}
413 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB)
414 = Foo.$s$wfoo1 a_sFB sc_sGC ;
415 "SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#}
416 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp))
417 = Foo.$s$wfoo y_aFp sc_sGC ;
419 But perhaps the first one isn't good. After all, we know that tpl_B2 is
420 a T (I# x) really, because T is strict and Int has one constructor. (We can't
421 unbox the strict fields, becuase T is polymorphic!)
425 %************************************************************************
427 \subsection{Top level wrapper stuff}
429 %************************************************************************
432 specConstrProgram :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]
433 specConstrProgram dflags us binds
435 showPass dflags "SpecConstr"
437 let (binds', _) = initUs us (go (initScEnv dflags) binds)
439 endPass dflags "SpecConstr" Opt_D_dump_spec binds'
441 dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
442 (pprRules (tidyRules emptyTidyEnv (rulesOfBinds binds')))
447 go env (bind:binds) = do (env', _, bind') <- scBind env bind
448 binds' <- go env' binds
449 return (bind' : binds')
453 %************************************************************************
455 \subsection{Environment: goes downwards}
457 %************************************************************************
460 data ScEnv = SCE { sc_size :: Maybe Int, -- Size threshold
462 sc_subst :: Subst, -- Current substitution
463 -- Maps InIds to OutExprs
465 sc_how_bound :: HowBoundEnv,
466 -- Binds interesting non-top-level variables
467 -- Domain is OutVars (*after* applying the substitution)
470 -- Domain is OutIds (*after* applying the substitution)
471 -- Used even for top-level bindings (but not imported ones)
474 ---------------------
475 -- As we go, we apply a substitution (sc_subst) to the current term
476 type InExpr = CoreExpr -- *Before* applying the subst
478 type OutExpr = CoreExpr -- *After* applying the subst
482 ---------------------
483 type HowBoundEnv = VarEnv HowBound -- Domain is OutVars
485 ---------------------
486 type ValueEnv = IdEnv Value -- Domain is OutIds
487 data Value = ConVal AltCon [CoreArg] -- *Saturated* constructors
488 | LambdaVal -- Inlinable lambdas or PAPs
490 instance Outputable Value where
491 ppr (ConVal con args) = ppr con <+> interpp'SP args
492 ppr LambdaVal = ptext SLIT("<Lambda>")
494 ---------------------
495 initScEnv :: DynFlags -> ScEnv
497 = SCE { sc_size = specConstrThreshold dflags,
498 sc_subst = emptySubst,
499 sc_how_bound = emptyVarEnv,
500 sc_vals = emptyVarEnv }
502 data HowBound = RecFun -- These are the recursive functions for which
503 -- we seek interesting call patterns
505 | RecArg -- These are those functions' arguments, or their sub-components;
506 -- we gather occurrence information for these
508 instance Outputable HowBound where
509 ppr RecFun = text "RecFun"
510 ppr RecArg = text "RecArg"
512 lookupHowBound :: ScEnv -> Id -> Maybe HowBound
513 lookupHowBound env id = lookupVarEnv (sc_how_bound env) id
515 scSubstId :: ScEnv -> Id -> CoreExpr
516 scSubstId env v = lookupIdSubst (sc_subst env) v
518 scSubstTy :: ScEnv -> Type -> Type
519 scSubstTy env ty = substTy (sc_subst env) ty
521 zapScSubst :: ScEnv -> ScEnv
522 zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) }
524 extendScInScope :: ScEnv -> [Var] -> ScEnv
525 -- Bring the quantified variables into scope
526 extendScInScope env qvars = env { sc_subst = extendInScopeList (sc_subst env) qvars }
528 -- Extend the substitution
529 extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv
530 extendScSubst env var expr = env { sc_subst = extendSubst (sc_subst env) var expr }
532 extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv
533 extendScSubstList env prs = env { sc_subst = extendSubstList (sc_subst env) prs }
535 extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv
536 extendHowBound env bndrs how_bound
537 = env { sc_how_bound = extendVarEnvList (sc_how_bound env)
538 [(bndr,how_bound) | bndr <- bndrs] }
540 extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var])
541 extendBndrsWith how_bound env bndrs
542 = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndrs')
544 (subst', bndrs') = substBndrs (sc_subst env) bndrs
545 hb_env' = sc_how_bound env `extendVarEnvList`
546 [(bndr,how_bound) | bndr <- bndrs']
548 extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var)
549 extendBndrWith how_bound env bndr
550 = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndr')
552 (subst', bndr') = substBndr (sc_subst env) bndr
553 hb_env' = extendVarEnv (sc_how_bound env) bndr' how_bound
555 extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var])
556 extendRecBndrs env bndrs = (env { sc_subst = subst' }, bndrs')
558 (subst', bndrs') = substRecBndrs (sc_subst env) bndrs
560 extendBndr :: ScEnv -> Var -> (ScEnv, Var)
561 extendBndr env bndr = (env { sc_subst = subst' }, bndr')
563 (subst', bndr') = substBndr (sc_subst env) bndr
565 extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv
566 extendValEnv env _ Nothing = env
567 extendValEnv env id (Just cv) = env { sc_vals = extendVarEnv (sc_vals env) id cv }
569 extendCaseBndrs :: ScEnv -> CoreExpr -> Id -> AltCon -> [Var] -> ScEnv
573 -- we want to bind b, and perhaps scrut too, to (C x y)
574 -- NB: Extends only the sc_vals part of the envt
575 extendCaseBndrs env scrut case_bndr con alt_bndrs
577 Var v -> extendValEnv env1 v cval
580 env1 = extendValEnv env case_bndr cval
583 LitAlt {} -> Just (ConVal con [])
584 DataAlt {} -> Just (ConVal con vanilla_args)
586 vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
587 varsToCoreExprs alt_bndrs
591 %************************************************************************
593 \subsection{Usage information: flows upwards}
595 %************************************************************************
600 scu_calls :: CallEnv, -- Calls
601 -- The functions are a subset of the
602 -- RecFuns in the ScEnv
604 scu_occs :: !(IdEnv ArgOcc) -- Information on argument occurrences
605 } -- The domain is OutIds
607 type CallEnv = IdEnv [Call]
608 type Call = (ValueEnv, [CoreArg])
609 -- The arguments of the call, together with the
610 -- env giving the constructor bindings at the call site
613 nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv }
615 combineCalls :: CallEnv -> CallEnv -> CallEnv
616 combineCalls = plusVarEnv_C (++)
618 combineUsage :: ScUsage -> ScUsage -> ScUsage
619 combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2),
620 scu_occs = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) }
622 combineUsages :: [ScUsage] -> ScUsage
623 combineUsages [] = nullUsage
624 combineUsages us = foldr1 combineUsage us
626 lookupOcc :: ScUsage -> OutVar -> (ScUsage, ArgOcc)
627 lookupOcc (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndr
628 = (SCU {scu_calls = sc_calls, scu_occs = delVarEnv sc_occs bndr},
629 lookupVarEnv sc_occs bndr `orElse` NoOcc)
631 lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc])
632 lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs
633 = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs},
634 [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs])
636 data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument
637 | UnkOcc -- Used in some unknown way
639 | ScrutOcc (UniqFM [ArgOcc]) -- See Note [ScrutOcc]
641 | BothOcc -- Definitely taken apart, *and* perhaps used in some other way
645 An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing,
646 is *only* taken apart or applied.
648 Functions, literal: ScrutOcc emptyUFM
649 Data constructors: ScrutOcc subs,
651 where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components,
652 The domain of the UniqFM is the Unique of the data constructor
654 The [ArgOcc] is the occurrences of the *pattern-bound* components
655 of the data structure. E.g.
656 data T a = forall b. MkT a b (b->a)
657 A pattern binds b, x::a, y::b, z::b->a, but not 'a'!
661 instance Outputable ArgOcc where
662 ppr (ScrutOcc xs) = ptext SLIT("scrut-occ") <> ppr xs
663 ppr UnkOcc = ptext SLIT("unk-occ")
664 ppr BothOcc = ptext SLIT("both-occ")
665 ppr NoOcc = ptext SLIT("no-occ")
667 -- Experimentally, this vesion of combineOcc makes ScrutOcc "win", so
668 -- that if the thing is scrutinised anywhere then we get to see that
669 -- in the overall result, even if it's also used in a boxed way
670 -- This might be too agressive; see Note [Reboxing] Alternative 3
671 combineOcc :: ArgOcc -> ArgOcc -> ArgOcc
672 combineOcc NoOcc occ = occ
673 combineOcc occ NoOcc = occ
674 combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys)
675 combineOcc _occ (ScrutOcc ys) = ScrutOcc ys
676 combineOcc (ScrutOcc xs) _occ = ScrutOcc xs
677 combineOcc UnkOcc UnkOcc = UnkOcc
678 combineOcc _ _ = BothOcc
680 combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]
681 combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys
683 setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage
684 -- *Overwrite* the occurrence info for the scrutinee, if the scrutinee
685 -- is a variable, and an interesting variable
686 setScrutOcc env usg (Cast e _) occ = setScrutOcc env usg e occ
687 setScrutOcc env usg (Note _ e) occ = setScrutOcc env usg e occ
688 setScrutOcc env usg (Var v) occ
689 | Just RecArg <- lookupHowBound env v = usg { scu_occs = extendVarEnv (scu_occs usg) v occ }
691 setScrutOcc _env usg _other _occ -- Catch-all
694 conArgOccs :: ArgOcc -> AltCon -> [ArgOcc]
695 -- Find usage of components of data con; returns [UnkOcc...] if unknown
696 -- See Note [ScrutOcc] for the extra UnkOccs in the vanilla datacon case
698 conArgOccs (ScrutOcc fm) (DataAlt dc)
699 | Just pat_arg_occs <- lookupUFM fm dc
700 = [UnkOcc | _ <- dataConUnivTyVars dc] ++ pat_arg_occs
702 conArgOccs _other _con = repeat UnkOcc
705 %************************************************************************
707 \subsection{The main recursive function}
709 %************************************************************************
711 The main recursive function gathers up usage information, and
712 creates specialised versions of functions.
715 scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
716 -- The unique supply is needed when we invent
717 -- a new name for the specialised function and its args
719 scExpr env e = scExpr' env e
722 scExpr' env (Var v) = case scSubstId env v of
723 Var v' -> return (varUsage env v' UnkOcc, Var v')
724 e' -> scExpr (zapScSubst env) e'
726 scExpr' env (Type t) = return (nullUsage, Type (scSubstTy env t))
727 scExpr' _ e@(Lit {}) = return (nullUsage, e)
728 scExpr' env (Note n e) = do (usg,e') <- scExpr env e
729 return (usg, Note n e')
730 scExpr' env (Cast e co) = do (usg, e') <- scExpr env e
731 return (usg, Cast e' (scSubstTy env co))
732 scExpr' env e@(App _ _) = scApp env (collectArgs e)
733 scExpr' env (Lam b e) = do let (env', b') = extendBndr env b
734 (usg, e') <- scExpr env' e
735 return (usg, Lam b' e')
737 scExpr' env (Case scrut b ty alts)
738 = do { (scrut_usg, scrut') <- scExpr env scrut
739 ; case isValue (sc_vals env) scrut' of
740 Just (ConVal con args) -> sc_con_app con args scrut'
741 _other -> sc_vanilla scrut_usg scrut'
744 sc_con_app con args scrut' -- Known constructor; simplify
745 = do { let (_, bs, rhs) = findAlt con alts
746 alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)
747 ; scExpr alt_env' rhs }
749 sc_vanilla scrut_usg scrut' -- Normal case
750 = do { let (alt_env,b') = extendBndrWith RecArg env b
751 -- Record RecArg for the components
753 ; (alt_usgs, alt_occs, alts')
754 <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts
756 ; let (alt_usg, b_occ) = lookupOcc (combineUsages alt_usgs) b'
757 scrut_occ = foldr combineOcc b_occ alt_occs
758 scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ
759 -- The combined usage of the scrutinee is given
760 -- by scrut_occ, which is passed to scScrut, which
761 -- in turn treats a bare-variable scrutinee specially
763 ; return (alt_usg `combineUsage` scrut_usg',
764 Case scrut' b' (scSubstTy env ty) alts') }
766 sc_alt env scrut' b' (con,bs,rhs)
767 = do { let (env1, bs') = extendBndrsWith RecArg env bs
768 env2 = extendCaseBndrs env1 scrut' b' con bs'
769 ; (usg,rhs') <- scExpr env2 rhs
770 ; let (usg', arg_occs) = lookupOccs usg bs'
771 scrut_occ = case con of
772 DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)
773 _ofther -> ScrutOcc emptyUFM
774 ; return (usg', scrut_occ, (con,bs',rhs')) }
776 scExpr' env (Let (NonRec bndr rhs) body)
777 | isTyVar bndr -- Type-lets may be created by doBeta
778 = scExpr' (extendScSubst env bndr rhs) body
780 = do { let (body_env, bndr') = extendBndr env bndr
781 ; (rhs_usg, (_, args', rhs_body', _)) <- scRecRhs env (bndr',rhs)
782 ; let rhs' = mkLams args' rhs_body'
784 ; if not opt_SpecInlineJoinPoints || null args' || isEmptyVarEnv (scu_calls rhs_usg) then do
786 let body_env2 = extendValEnv body_env bndr' (isValue (sc_vals env) rhs')
787 -- Record if the RHS is a value
788 ; (body_usg, body') <- scExpr body_env2 body
789 ; return (body_usg `combineUsage` rhs_usg, Let (NonRec bndr' rhs') body') }
790 else -- For now, just brutally inline the join point
791 do { let body_env2 = extendScSubst env bndr rhs'
792 ; scExpr body_env2 body } }
796 do { -- Join-point case
797 let body_env2 = extendHowBound body_env [bndr'] RecFun
798 -- If the RHS of this 'let' contains calls
799 -- to recursive functions that we're trying
800 -- to specialise, then treat this let too
801 -- as one to specialise
802 ; (body_usg, body') <- scExpr body_env2 body
804 ; (spec_usg, _, specs) <- specialise env (scu_calls body_usg) ([], rhs_info)
806 ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' }
807 `combineUsage` rhs_usg `combineUsage` spec_usg,
808 mkLets [NonRec b r | (b,r) <- addRules rhs_info specs] body')
812 scExpr' env (Let (Rec prs) body)
813 = do { (env', bind_usg, bind') <- scBind env (Rec prs)
814 ; (body_usg, body') <- scExpr env' body
815 ; return (bind_usg `combineUsage` body_usg, Let bind' body') }
818 -----------------------------------
819 scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)
821 scApp env (Var fn, args) -- Function is a variable
822 = ASSERT( not (null args) )
823 do { args_w_usgs <- mapM (scExpr env) args
824 ; let (arg_usgs, args') = unzip args_w_usgs
825 arg_usg = combineUsages arg_usgs
826 ; case scSubstId env fn of
827 fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args')
828 -- Do beta-reduction and try again
830 Var fn' -> return (arg_usg `combineUsage` fn_usg, mkApps (Var fn') args')
832 fn_usg = case lookupHowBound env fn' of
833 Just RecFun -> SCU { scu_calls = unitVarEnv fn' [(sc_vals env, args')],
834 scu_occs = emptyVarEnv }
835 Just RecArg -> SCU { scu_calls = emptyVarEnv,
836 scu_occs = unitVarEnv fn' (ScrutOcc emptyUFM) }
840 other_fn' -> return (arg_usg, mkApps other_fn' args') }
841 -- NB: doing this ignores any usage info from the substituted
842 -- function, but I don't think that matters. If it does
845 doBeta :: OutExpr -> [OutExpr] -> OutExpr
846 -- ToDo: adjust for System IF
847 doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args)
848 doBeta fn args = mkApps fn args
850 -- The function is almost always a variable, but not always.
851 -- In particular, if this pass follows float-in,
852 -- which it may, we can get
853 -- (let f = ...f... in f) arg1 arg2
854 scApp env (other_fn, args)
855 = do { (fn_usg, fn') <- scExpr env other_fn
856 ; (arg_usgs, args') <- mapAndUnzipM (scExpr env) args
857 ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') }
859 ----------------------
860 scBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, ScUsage, CoreBind)
862 | Just threshold <- sc_size env
863 , not (all (couldBeSmallEnoughToInline threshold) rhss)
865 = do { let (rhs_env,bndrs') = extendRecBndrs env bndrs
866 ; (rhs_usgs, rhss') <- mapAndUnzipM (scExpr rhs_env) rhss
867 ; return (rhs_env, combineUsages rhs_usgs, Rec (bndrs' `zip` rhss')) }
868 | otherwise -- Do specialisation
869 = do { let (rhs_env1,bndrs') = extendRecBndrs env bndrs
870 rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
872 ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
873 ; let rhs_usg = combineUsages rhs_usgs
875 ; (spec_usg, specs) <- spec_loop rhs_env2 (scu_calls rhs_usg)
876 (repeat [] `zip` rhs_infos)
878 ; let all_usg = rhs_usg `combineUsage` spec_usg
880 ; return (rhs_env1, -- For the body of the letrec, delete the RecFun business
881 all_usg { scu_calls = scu_calls rhs_usg `delVarEnvList` bndrs' },
882 Rec (concat (zipWith addRules rhs_infos specs))) }
884 (bndrs,rhss) = unzip prs
888 -> [([CallPat], RhsInfo)] -- One per binder
889 -> UniqSM (ScUsage, [[SpecInfo]]) -- One list per binder
890 spec_loop env all_calls rhs_stuff
891 = do { (spec_usg_s, new_pats_s, specs) <- mapAndUnzip3M (specialise env all_calls) rhs_stuff
892 ; let spec_usg = combineUsages spec_usg_s
893 ; if all null new_pats_s then
894 return (spec_usg, specs) else do
895 { (spec_usg1, specs1) <- spec_loop env (scu_calls spec_usg)
896 (zipWith add_pats new_pats_s rhs_stuff)
897 ; return (spec_usg `combineUsage` spec_usg1, zipWith (++) specs specs1) } }
899 add_pats :: [CallPat] -> ([CallPat], RhsInfo) -> ([CallPat], RhsInfo)
900 add_pats new_pats (done_pats, rhs_info) = (done_pats ++ new_pats, rhs_info)
902 scBind env (NonRec bndr rhs)
903 = do { (usg, rhs') <- scExpr env rhs
904 ; let (env1, bndr') = extendBndr env bndr
905 env2 = extendValEnv env1 bndr' (isValue (sc_vals env) rhs')
906 ; return (env2, usg, NonRec bndr' rhs') }
908 ----------------------
909 scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM (ScUsage, RhsInfo)
910 scRecRhs env (bndr,rhs)
911 = do { let (arg_bndrs,body) = collectBinders rhs
912 (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs
913 ; (body_usg, body') <- scExpr body_env body
914 ; let (rhs_usg, arg_occs) = lookupOccs body_usg arg_bndrs'
915 ; return (rhs_usg, (bndr, arg_bndrs', body', arg_occs)) }
917 -- The arg_occs says how the visible,
918 -- lambda-bound binders of the RHS are used
919 -- (including the TyVar binders)
920 -- Two pats are the same if they match both ways
922 ----------------------
923 addRules :: RhsInfo -> [SpecInfo] -> [(Id,CoreExpr)]
924 addRules (fn, args, body, _) specs
925 = [(id,rhs) | (_,id,rhs) <- specs] ++
926 [(fn `addIdSpecialisations` rules, mkLams args body)]
928 rules = [r | (r,_,_) <- specs]
930 ----------------------
931 varUsage :: ScEnv -> OutVar -> ArgOcc -> ScUsage
933 | Just RecArg <- lookupHowBound env v = SCU { scu_calls = emptyVarEnv
934 , scu_occs = unitVarEnv v use }
935 | otherwise = nullUsage
939 %************************************************************************
941 The specialiser itself
943 %************************************************************************
946 type RhsInfo = (OutId, [OutVar], OutExpr, [ArgOcc])
947 -- Info about the *original* RHS of a binding we are specialising
948 -- Original binding f = \xs.body
949 -- Plus info about usage of arguments
951 type SpecInfo = (CoreRule, OutId, OutExpr)
952 -- One specialisation: Rule plus definition
957 -> CallEnv -- Info on calls
958 -> ([CallPat], RhsInfo) -- Original RHS plus patterns dealt with
959 -> UniqSM (ScUsage, [CallPat], [SpecInfo]) -- Specialised calls
961 -- Note: the rhs here is the optimised version of the original rhs
962 -- So when we make a specialised copy of the RHS, we're starting
963 -- from an RHS whose nested functions have been optimised already.
965 specialise env bind_calls (done_pats, (fn, arg_bndrs, body, arg_occs))
966 | notNull arg_bndrs, -- Only specialise functions
967 Just all_calls <- lookupVarEnv bind_calls fn
968 = do { pats <- callsToPats env done_pats arg_occs all_calls
969 -- ; pprTrace "specialise" (vcat [ppr fn <+> ppr arg_occs,
970 -- text "calls" <+> ppr all_calls,
971 -- text "good pats" <+> ppr pats]) $
974 ; (spec_usgs, specs) <- mapAndUnzipM (spec_one env fn arg_bndrs body)
975 (pats `zip` [length done_pats..])
977 ; return (combineUsages spec_usgs, pats, specs) }
979 = return (nullUsage, [], []) -- The boring case
982 ---------------------
985 -> [Var] -- Lambda-binders of RHS; should match patterns
986 -> CoreExpr -- Body of the original function
987 -> (([Var], [CoreArg]), Int)
988 -> UniqSM (ScUsage, SpecInfo) -- Rule and binding
990 -- spec_one creates a specialised copy of the function, together
991 -- with a rule for using it. I'm very proud of how short this
992 -- function is, considering what it does :-).
998 f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
999 [c::*, v::(b,c) are presumably bound by the (...) part]
1001 f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
1002 (...entire body of f...) [b -> (b,c),
1003 y -> ((:) (a,(b,c)) (x,v) hw)]
1005 RULE: forall b::* c::*, -- Note, *not* forall a, x
1009 f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
1012 spec_one env fn arg_bndrs body ((qvars, pats), rule_number)
1013 = do { -- Specialise the body
1014 let spec_env = extendScSubstList (extendScInScope env qvars)
1015 (arg_bndrs `zip` pats)
1016 ; (spec_usg, spec_body) <- scExpr spec_env body
1018 -- ; pprTrace "spec_one" (ppr fn <+> vcat [text "pats" <+> ppr pats,
1019 -- text "calls" <+> (ppr (scu_calls spec_usg))])
1022 -- And build the results
1023 ; spec_uniq <- getUniqueUs
1024 ; let (spec_lam_args, spec_call_args) = mkWorkerArgs qvars body_ty
1025 -- Usual w/w hack to avoid generating
1026 -- a spec_rhs of unlifted type and no args
1029 fn_loc = nameSrcSpan fn_name
1030 spec_occ = mkSpecOcc (nameOccName fn_name)
1031 rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number))
1032 spec_rhs = mkLams spec_lam_args spec_body
1033 spec_id = mkUserLocal spec_occ spec_uniq (mkPiTypes spec_lam_args body_ty) fn_loc
1034 body_ty = exprType spec_body
1035 rule_rhs = mkVarApps (Var spec_id) spec_call_args
1036 rule = mkLocalRule rule_name specConstrActivation fn_name qvars pats rule_rhs
1037 ; return (spec_usg, (rule, spec_id, spec_rhs)) }
1039 -- In which phase should the specialise-constructor rules be active?
1040 -- Originally I made them always-active, but Manuel found that
1041 -- this defeated some clever user-written rules. So Plan B
1042 -- is to make them active only in Phase 0; after all, currently,
1043 -- the specConstr transformation is only run after the simplifier
1044 -- has reached Phase 0. In general one would want it to be
1045 -- flag-controllable, but for now I'm leaving it baked in
1047 specConstrActivation :: Activation
1048 specConstrActivation = ActiveAfter 0 -- Baked in; see comments above
1051 %************************************************************************
1053 \subsection{Argument analysis}
1055 %************************************************************************
1057 This code deals with analysing call-site arguments to see whether
1058 they are constructor applications.
1062 type CallPat = ([Var], [CoreExpr]) -- Quantified variables and arguments
1065 callsToPats :: ScEnv -> [CallPat] -> [ArgOcc] -> [Call] -> UniqSM [CallPat]
1066 -- Result has no duplicate patterns,
1067 -- nor ones mentioned in done_pats
1068 callsToPats env done_pats bndr_occs calls
1069 = do { mb_pats <- mapM (callToPats env bndr_occs) calls
1071 ; let good_pats :: [([Var], [CoreArg])]
1072 good_pats = catMaybes mb_pats
1073 is_done p = any (samePat p) done_pats
1075 ; return (filterOut is_done (nubBy samePat good_pats)) }
1077 callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
1078 -- The [Var] is the variables to quantify over in the rule
1079 -- Type variables come first, since they may scope
1080 -- over the following term variables
1081 -- The [CoreExpr] are the argument patterns for the rule
1082 callToPats env bndr_occs (con_env, args)
1083 | length args < length bndr_occs -- Check saturated
1086 = do { let in_scope = substInScope (sc_subst env)
1087 ; prs <- argsToPats in_scope con_env (args `zip` bndr_occs)
1088 ; let (good_pats, pats) = unzip prs
1089 pat_fvs = varSetElems (exprsFreeVars pats)
1090 qvars = filterOut (`elemInScopeSet` in_scope) pat_fvs
1091 -- Quantify over variables that are not in sccpe
1093 -- See Note [Shadowing] at the top
1095 (tvs, ids) = partition isTyVar qvars
1097 -- Put the type variables first; the type of a term
1098 -- variable may mention a type variable
1100 ; -- pprTrace "callToPats" (ppr args $$ ppr prs $$ ppr bndr_occs) $
1102 then return (Just (qvars', pats))
1103 else return Nothing }
1105 -- argToPat takes an actual argument, and returns an abstracted
1106 -- version, consisting of just the "constructor skeleton" of the
1107 -- argument, with non-constructor sub-expression replaced by new
1108 -- placeholder variables. For example:
1109 -- C a (D (f x) (g y)) ==> C p1 (D p2 p3)
1111 argToPat :: InScopeSet -- What's in scope at the fn defn site
1112 -> ValueEnv -- ValueEnv at the call site
1113 -> CoreArg -- A call arg (or component thereof)
1115 -> UniqSM (Bool, CoreArg)
1116 -- Returns (interesting, pat),
1117 -- where pat is the pattern derived from the argument
1118 -- intersting=True if the pattern is non-trivial (not a variable or type)
1119 -- E.g. x:xs --> (True, x:xs)
1120 -- f xs --> (False, w) where w is a fresh wildcard
1121 -- (f xs, 'c') --> (True, (w, 'c')) where w is a fresh wildcard
1122 -- \x. x+y --> (True, \x. x+y)
1123 -- lvl7 --> (True, lvl7) if lvl7 is bound
1124 -- somewhere further out
1126 argToPat _in_scope _val_env arg@(Type {}) _arg_occ
1127 = return (False, arg)
1129 argToPat in_scope val_env (Note _ arg) arg_occ
1130 = argToPat in_scope val_env arg arg_occ
1131 -- Note [Notes in call patterns]
1132 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1133 -- Ignore Notes. In particular, we want to ignore any InlineMe notes
1134 -- Perhaps we should not ignore profiling notes, but I'm going to
1135 -- ride roughshod over them all for now.
1136 --- See Note [Notes in RULE matching] in Rules
1138 argToPat in_scope val_env (Let _ arg) arg_occ
1139 = argToPat in_scope val_env arg arg_occ
1140 -- Look through let expressions
1141 -- e.g. f (let v = rhs in \y -> ...v...)
1142 -- Here we can specialise for f (\y -> ...)
1143 -- because the rule-matcher will look through the let.
1145 argToPat in_scope val_env (Cast arg co) arg_occ
1146 = do { (interesting, arg') <- argToPat in_scope val_env arg arg_occ
1147 ; let (ty1,ty2) = coercionKind co
1148 ; if not interesting then
1151 { -- Make a wild-card pattern for the coercion
1153 ; let co_name = mkSysTvName uniq FSLIT("sg")
1154 co_var = mkCoVar co_name (mkCoKind ty1 ty2)
1155 ; return (interesting, Cast arg' (mkTyVarTy co_var)) } }
1157 {- Disabling lambda specialisation for now
1158 It's fragile, and the spec_loop can be infinite
1159 argToPat in_scope val_env arg arg_occ
1161 = return (True, arg)
1163 is_value_lam (Lam v e) -- Spot a value lambda, even if
1164 | isId v = True -- it is inside a type lambda
1165 | otherwise = is_value_lam e
1166 is_value_lam other = False
1169 -- Check for a constructor application
1170 -- NB: this *precedes* the Var case, so that we catch nullary constrs
1171 argToPat in_scope val_env arg arg_occ
1172 | Just (ConVal dc args) <- isValue val_env arg
1174 ScrutOcc _ -> True -- Used only by case scrutinee
1175 BothOcc -> case arg of -- Used elsewhere
1176 App {} -> True -- see Note [Reboxing]
1178 _other -> False -- No point; the arg is not decomposed
1179 = do { args' <- argsToPats in_scope val_env (args `zip` conArgOccs arg_occ dc)
1180 ; return (True, mk_con_app dc (map snd args')) }
1182 -- Check if the argument is a variable that
1183 -- is in scope at the function definition site
1184 -- It's worth specialising on this if
1185 -- (a) it's used in an interesting way in the body
1186 -- (b) we know what its value is
1187 argToPat in_scope val_env (Var v) arg_occ
1188 | case arg_occ of { UnkOcc -> False; _other -> True }, -- (a)
1190 = return (True, Var v)
1193 | isLocalId v = v `elemInScopeSet` in_scope
1194 && isJust (lookupVarEnv val_env v)
1195 -- Local variables have values in val_env
1196 | otherwise = isValueUnfolding (idUnfolding v)
1197 -- Imports have unfoldings
1199 -- I'm really not sure what this comment means
1200 -- And by not wild-carding we tend to get forall'd
1201 -- variables that are in soope, which in turn can
1202 -- expose the weakness in let-matching
1203 -- See Note [Matching lets] in Rules
1204 -- Check for a variable bound inside the function.
1205 -- Don't make a wild-card, because we may usefully share
1206 -- e.g. f a = let x = ... in f (x,x)
1207 -- NB: this case follows the lambda and con-app cases!!
1208 argToPat _in_scope _val_env (Var v) _arg_occ
1209 = return (False, Var v)
1211 -- The default case: make a wild-card
1212 argToPat _in_scope _val_env arg _arg_occ
1213 = wildCardPat (exprType arg)
1215 wildCardPat :: Type -> UniqSM (Bool, CoreArg)
1216 wildCardPat ty = do { uniq <- getUniqueUs
1217 ; let id = mkSysLocal FSLIT("sc") uniq ty
1218 ; return (False, Var id) }
1220 argsToPats :: InScopeSet -> ValueEnv
1221 -> [(CoreArg, ArgOcc)]
1222 -> UniqSM [(Bool, CoreArg)]
1223 argsToPats in_scope val_env args
1226 do_one (arg,occ) = argToPat in_scope val_env arg occ
1231 isValue :: ValueEnv -> CoreExpr -> Maybe Value
1232 isValue _env (Lit lit)
1233 = Just (ConVal (LitAlt lit) [])
1236 | Just stuff <- lookupVarEnv env v
1237 = Just stuff -- You might think we could look in the idUnfolding here
1238 -- but that doesn't take account of which branch of a
1239 -- case we are in, which is the whole point
1241 | not (isLocalId v) && isCheapUnfolding unf
1242 = isValue env (unfoldingTemplate unf)
1245 -- However we do want to consult the unfolding
1246 -- as well, for let-bound constructors!
1248 isValue env (Lam b e)
1249 | isTyVar b = isValue env e
1250 | otherwise = Just LambdaVal
1252 isValue _env expr -- Maybe it's a constructor application
1253 | (Var fun, args) <- collectArgs expr
1254 = case isDataConWorkId_maybe fun of
1256 Just con | args `lengthAtLeast` dataConRepArity con
1257 -- Check saturated; might be > because the
1258 -- arity excludes type args
1259 -> Just (ConVal (DataAlt con) args)
1261 _other | valArgCount args < idArity fun
1262 -- Under-applied function
1263 -> Just LambdaVal -- Partial application
1267 isValue _env _expr = Nothing
1269 mk_con_app :: AltCon -> [CoreArg] -> CoreExpr
1270 mk_con_app (LitAlt lit) [] = Lit lit
1271 mk_con_app (DataAlt con) args = mkConApp con args
1272 mk_con_app _other _args = panic "SpecConstr.mk_con_app"
1274 samePat :: CallPat -> CallPat -> Bool
1275 samePat (vs1, as1) (vs2, as2)
1278 same (Var v1) (Var v2)
1279 | v1 `elem` vs1 = v2 `elem` vs2
1280 | v2 `elem` vs2 = False
1281 | otherwise = v1 == v2
1283 same (Lit l1) (Lit l2) = l1==l2
1284 same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2
1286 same (Type {}) (Type {}) = True -- Note [Ignore type differences]
1287 same (Note _ e1) e2 = same e1 e2 -- Ignore casts and notes
1288 same (Cast e1 _) e2 = same e1 e2
1289 same e1 (Note _ e2) = same e1 e2
1290 same e1 (Cast e2 _) = same e1 e2
1292 same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2)
1293 False -- Let, lambda, case should not occur
1294 bad (Case {}) = True
1300 Note [Ignore type differences]
1301 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1302 We do not want to generate specialisations where the call patterns
1303 differ only in their type arguments! Not only is it utterly useless,
1304 but it also means that (with polymorphic recursion) we can generate
1305 an infinite number of specialisations. Example is Data.Sequence.adjustTree,