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 )
52 -----------------------------------------------------
54 -----------------------------------------------------
59 drop n (x:xs) = drop (n-1) xs
61 After the first time round, we could pass n unboxed. This happens in
62 numerical code too. Here's what it looks like in Core:
64 drop n xs = case xs of
69 _ -> drop (I# (n# -# 1#)) xs
71 Notice that the recursive call has an explicit constructor as argument.
72 Noticing this, we can make a specialised version of drop
74 RULE: drop (I# n#) xs ==> drop' n# xs
76 drop' n# xs = let n = I# n# in ...orig RHS...
78 Now the simplifier will apply the specialisation in the rhs of drop', giving
80 drop' n# xs = case xs of
84 _ -> drop (n# -# 1#) xs
88 We'd also like to catch cases where a parameter is carried along unchanged,
89 but evaluated each time round the loop:
91 f i n = if i>0 || i>n then i else f (i*2) n
93 Here f isn't strict in n, but we'd like to avoid evaluating it each iteration.
94 In Core, by the time we've w/wd (f is strict in i) we get
96 f i# n = case i# ># 0 of
98 True -> case n of n' { I# n# ->
101 True -> f (i# *# 2#) n'
103 At the call to f, we see that the argument, n is know to be (I# n#),
104 and n is evaluated elsewhere in the body of f, so we can play the same
110 We must be careful not to allocate the same constructor twice. Consider
111 f p = (...(case p of (a,b) -> e)...p...,
112 ...let t = (r,s) in ...t...(f t)...)
113 At the recursive call to f, we can see that t is a pair. But we do NOT want
114 to make a specialised copy:
115 f' a b = let p = (a,b) in (..., ...)
116 because now t is allocated by the caller, then r and s are passed to the
117 recursive call, which allocates the (r,s) pair again.
120 (a) the argument p is used in other than a case-scrutinsation way.
121 (b) the argument to the call is not a 'fresh' tuple; you have to
122 look into its unfolding to see that it's a tuple
124 Hence the "OR" part of Note [Good arguments] below.
126 ALTERNATIVE 2: pass both boxed and unboxed versions. This no longer saves
127 allocation, but does perhaps save evals. In the RULE we'd have
130 f (I# x#) = f' (I# x#) x#
132 If at the call site the (I# x) was an unfolding, then we'd have to
133 rely on CSE to eliminate the duplicate allocation.... This alternative
134 doesn't look attractive enough to pursue.
136 ALTERNATIVE 3: ignore the reboxing problem. The trouble is that
137 the conservative reboxing story prevents many useful functions from being
138 specialised. Example:
139 foo :: Maybe Int -> Int -> Int
141 foo x@(Just m) n = foo x (n-m)
142 Here the use of 'x' will clearly not require boxing in the specialised function.
144 The strictness analyser has the same problem, in fact. Example:
146 If we pass just 'a' and 'b' to the worker, it might need to rebox the
147 pair to create (a,b). A more sophisticated analysis might figure out
148 precisely the cases in which this could happen, but the strictness
149 analyser does no such analysis; it just passes 'a' and 'b', and hopes
152 So my current choice is to make SpecConstr similarly aggressive, and
153 ignore the bad potential of reboxing.
156 Note [Good arguments]
157 ~~~~~~~~~~~~~~~~~~~~~
160 * A self-recursive function. Ignore mutual recursion for now,
161 because it's less common, and the code is simpler for self-recursion.
165 a) At a recursive call, one or more parameters is an explicit
166 constructor application
168 That same parameter is scrutinised by a case somewhere in
169 the RHS of the function
173 b) At a recursive call, one or more parameters has an unfolding
174 that is an explicit constructor application
176 That same parameter is scrutinised by a case somewhere in
177 the RHS of the function
179 Those are the only uses of the parameter (see Note [Reboxing])
182 What to abstract over
183 ~~~~~~~~~~~~~~~~~~~~~
184 There's a bit of a complication with type arguments. If the call
187 f p = ...f ((:) [a] x xs)...
189 then our specialised function look like
191 f_spec x xs = let p = (:) [a] x xs in ....as before....
193 This only makes sense if either
194 a) the type variable 'a' is in scope at the top of f, or
195 b) the type variable 'a' is an argument to f (and hence fs)
197 Actually, (a) may hold for value arguments too, in which case
198 we may not want to pass them. Supose 'x' is in scope at f's
199 defn, but xs is not. Then we'd like
201 f_spec xs = let p = (:) [a] x xs in ....as before....
203 Similarly (b) may hold too. If x is already an argument at the
204 call, no need to pass it again.
206 Finally, if 'a' is not in scope at the call site, we could abstract
207 it as we do the term variables:
209 f_spec a x xs = let p = (:) [a] x xs in ...as before...
211 So the grand plan is:
213 * abstract the call site to a constructor-only pattern
214 e.g. C x (D (f p) (g q)) ==> C s1 (D s2 s3)
216 * Find the free variables of the abstracted pattern
218 * Pass these variables, less any that are in scope at
219 the fn defn. But see Note [Shadowing] below.
222 NOTICE that we only abstract over variables that are not in scope,
223 so we're in no danger of shadowing variables used in "higher up"
229 In this pass we gather up usage information that may mention variables
230 that are bound between the usage site and the definition site; or (more
231 seriously) may be bound to something different at the definition site.
234 f x = letrec g y v = let x = ...
237 Since 'x' is in scope at the call site, we may make a rewrite rule that
239 RULE forall a,b. g (a,b) x = ...
240 But this rule will never match, because it's really a different 'x' at
241 the call site -- and that difference will be manifest by the time the
242 simplifier gets to it. [A worry: the simplifier doesn't *guarantee*
243 no-shadowing, so perhaps it may not be distinct?]
245 Anyway, the rule isn't actually wrong, it's just not useful. One possibility
246 is to run deShadowBinds before running SpecConstr, but instead we run the
247 simplifier. That gives the simplest possible program for SpecConstr to
248 chew on; and it virtually guarantees no shadowing.
250 Note [Specialising for constant parameters]
251 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
252 This one is about specialising on a *constant* (but not necessarily
253 constructor) argument
255 foo :: Int -> (Int -> Int) -> Int
257 foo m f = foo (f m) (+1)
261 lvl_rmV :: GHC.Base.Int -> GHC.Base.Int
263 \ (ds_dlk :: GHC.Base.Int) ->
264 case ds_dlk of wild_alH { GHC.Base.I# x_alG ->
265 GHC.Base.I# (GHC.Prim.+# x_alG 1)
267 T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
270 \ (ww_sme :: GHC.Prim.Int#) (w_smg :: GHC.Base.Int -> GHC.Base.Int) ->
271 case ww_sme of ds_Xlw {
273 case w_smg (GHC.Base.I# ds_Xlw) of w1_Xmo { GHC.Base.I# ww1_Xmz ->
274 T.$wfoo ww1_Xmz lvl_rmV
279 The recursive call has lvl_rmV as its argument, so we could create a specialised copy
280 with that argument baked in; that is, not passed at all. Now it can perhaps be inlined.
282 When is this worth it? Call the constant 'lvl'
283 - If 'lvl' has an unfolding that is a constructor, see if the corresponding
284 parameter is scrutinised anywhere in the body.
286 - If 'lvl' has an unfolding that is a inlinable function, see if the corresponding
287 parameter is applied (...to enough arguments...?)
289 Also do this is if the function has RULES?
293 Note [Specialising for lambda parameters]
294 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
295 foo :: Int -> (Int -> Int) -> Int
297 foo m f = foo (f m) (\n -> n-m)
299 This is subtly different from the previous one in that we get an
300 explicit lambda as the argument:
302 T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
305 \ (ww_sm8 :: GHC.Prim.Int#) (w_sma :: GHC.Base.Int -> GHC.Base.Int) ->
306 case ww_sm8 of ds_Xlr {
308 case w_sma (GHC.Base.I# ds_Xlr) of w1_Xmf { GHC.Base.I# ww1_Xmq ->
311 (\ (n_ad3 :: GHC.Base.Int) ->
312 case n_ad3 of wild_alB { GHC.Base.I# x_alA ->
313 GHC.Base.I# (GHC.Prim.-# x_alA ds_Xlr)
319 I wonder if SpecConstr couldn't be extended to handle this? After all,
320 lambda is a sort of constructor for functions and perhaps it already
321 has most of the necessary machinery?
323 Furthermore, there's an immediate win, because you don't need to allocate the lamda
324 at the call site; and if perchance it's called in the recursive call, then you
325 may avoid allocating it altogether. Just like for constructors.
327 Looks cool, but probably rare...but it might be easy to implement.
330 Note [SpecConstr for casts]
331 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
334 data instance T Int = T Int
339 go (T n) = go (T (n-1))
341 The recursive call ends up looking like
342 go (T (I# ...) `cast` g)
343 So we want to spot the construtor application inside the cast.
344 That's why we have the Cast case in argToPat
347 -----------------------------------------------------
348 Stuff not yet handled
349 -----------------------------------------------------
351 Here are notes arising from Roman's work that I don't want to lose.
357 foo :: Int -> T Int -> Int
359 foo x t | even x = case t of { T n -> foo (x-n) t }
360 | otherwise = foo (x-1) t
362 SpecConstr does no specialisation, because the second recursive call
363 looks like a boxed use of the argument. A pity.
365 $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
367 \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) ->
368 case ww_sFo of ds_Xw6 [Just L] {
370 case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] {
371 __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq;
373 case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] ->
374 case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] ->
375 $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy
381 data a :*: b = !a :*: !b
384 foo :: (Int :*: T Int) -> Int
386 foo (x :*: t) | even x = case t of { T n -> foo ((x-n) :*: t) }
387 | otherwise = foo ((x-1) :*: t)
389 Very similar to the previous one, except that the parameters are now in
390 a strict tuple. Before SpecConstr, we have
392 $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
394 \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T
396 case ww_sFU of ds_Xws [Just L] {
398 case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] {
400 case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] ->
401 $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2 -- $wfoo1
404 case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] ->
405 case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] ->
406 $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB -- $wfoo2
410 We get two specialisations:
411 "SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#}
412 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB)
413 = Foo.$s$wfoo1 a_sFB sc_sGC ;
414 "SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#}
415 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp))
416 = Foo.$s$wfoo y_aFp sc_sGC ;
418 But perhaps the first one isn't good. After all, we know that tpl_B2 is
419 a T (I# x) really, because T is strict and Int has one constructor. (We can't
420 unbox the strict fields, becuase T is polymorphic!)
424 %************************************************************************
426 \subsection{Top level wrapper stuff}
428 %************************************************************************
431 specConstrProgram :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]
432 specConstrProgram dflags us binds
434 showPass dflags "SpecConstr"
436 let (binds', _) = initUs us (go (initScEnv dflags) binds)
438 endPass dflags "SpecConstr" Opt_D_dump_spec binds'
440 dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
441 (pprRules (tidyRules emptyTidyEnv (rulesOfBinds binds')))
446 go env (bind:binds) = do (env', _, bind') <- scBind env bind
447 binds' <- go env' binds
448 return (bind' : binds')
452 %************************************************************************
454 \subsection{Environment: goes downwards}
456 %************************************************************************
459 data ScEnv = SCE { sc_size :: Maybe Int, -- Size threshold
461 sc_subst :: Subst, -- Current substitution
462 -- Maps InIds to OutExprs
464 sc_how_bound :: HowBoundEnv,
465 -- Binds interesting non-top-level variables
466 -- Domain is OutVars (*after* applying the substitution)
469 -- Domain is OutIds (*after* applying the substitution)
470 -- Used even for top-level bindings (but not imported ones)
473 ---------------------
474 -- As we go, we apply a substitution (sc_subst) to the current term
475 type InExpr = CoreExpr -- *Before* applying the subst
477 type OutExpr = CoreExpr -- *After* applying the subst
481 ---------------------
482 type HowBoundEnv = VarEnv HowBound -- Domain is OutVars
484 ---------------------
485 type ValueEnv = IdEnv Value -- Domain is OutIds
486 data Value = ConVal AltCon [CoreArg] -- *Saturated* constructors
487 | LambdaVal -- Inlinable lambdas or PAPs
489 instance Outputable Value where
490 ppr (ConVal con args) = ppr con <+> interpp'SP args
491 ppr LambdaVal = ptext SLIT("<Lambda>")
493 ---------------------
494 initScEnv :: DynFlags -> ScEnv
496 = SCE { sc_size = specConstrThreshold dflags,
497 sc_subst = emptySubst,
498 sc_how_bound = emptyVarEnv,
499 sc_vals = emptyVarEnv }
501 data HowBound = RecFun -- These are the recursive functions for which
502 -- we seek interesting call patterns
504 | RecArg -- These are those functions' arguments, or their sub-components;
505 -- we gather occurrence information for these
507 instance Outputable HowBound where
508 ppr RecFun = text "RecFun"
509 ppr RecArg = text "RecArg"
511 lookupHowBound :: ScEnv -> Id -> Maybe HowBound
512 lookupHowBound env id = lookupVarEnv (sc_how_bound env) id
514 scSubstId :: ScEnv -> Id -> CoreExpr
515 scSubstId env v = lookupIdSubst (sc_subst env) v
517 scSubstTy :: ScEnv -> Type -> Type
518 scSubstTy env ty = substTy (sc_subst env) ty
520 zapScSubst :: ScEnv -> ScEnv
521 zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) }
523 extendScInScope :: ScEnv -> [Var] -> ScEnv
524 -- Bring the quantified variables into scope
525 extendScInScope env qvars = env { sc_subst = extendInScopeList (sc_subst env) qvars }
527 -- Extend the substitution
528 extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv
529 extendScSubst env var expr = env { sc_subst = extendSubst (sc_subst env) var expr }
531 extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv
532 extendScSubstList env prs = env { sc_subst = extendSubstList (sc_subst env) prs }
534 extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv
535 extendHowBound env bndrs how_bound
536 = env { sc_how_bound = extendVarEnvList (sc_how_bound env)
537 [(bndr,how_bound) | bndr <- bndrs] }
539 extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var])
540 extendBndrsWith how_bound env bndrs
541 = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndrs')
543 (subst', bndrs') = substBndrs (sc_subst env) bndrs
544 hb_env' = sc_how_bound env `extendVarEnvList`
545 [(bndr,how_bound) | bndr <- bndrs']
547 extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var)
548 extendBndrWith how_bound env bndr
549 = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndr')
551 (subst', bndr') = substBndr (sc_subst env) bndr
552 hb_env' = extendVarEnv (sc_how_bound env) bndr' how_bound
554 extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var])
555 extendRecBndrs env bndrs = (env { sc_subst = subst' }, bndrs')
557 (subst', bndrs') = substRecBndrs (sc_subst env) bndrs
559 extendBndr :: ScEnv -> Var -> (ScEnv, Var)
560 extendBndr env bndr = (env { sc_subst = subst' }, bndr')
562 (subst', bndr') = substBndr (sc_subst env) bndr
564 extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv
565 extendValEnv env _ Nothing = env
566 extendValEnv env id (Just cv) = env { sc_vals = extendVarEnv (sc_vals env) id cv }
568 extendCaseBndrs :: ScEnv -> CoreExpr -> Id -> AltCon -> [Var] -> ScEnv
572 -- we want to bind b, and perhaps scrut too, to (C x y)
573 -- NB: Extends only the sc_vals part of the envt
574 extendCaseBndrs env scrut case_bndr con alt_bndrs
576 Var v -> extendValEnv env1 v cval
579 env1 = extendValEnv env case_bndr cval
582 LitAlt {} -> Just (ConVal con [])
583 DataAlt {} -> Just (ConVal con vanilla_args)
585 vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
586 varsToCoreExprs alt_bndrs
590 %************************************************************************
592 \subsection{Usage information: flows upwards}
594 %************************************************************************
599 scu_calls :: CallEnv, -- Calls
600 -- The functions are a subset of the
601 -- RecFuns in the ScEnv
603 scu_occs :: !(IdEnv ArgOcc) -- Information on argument occurrences
604 } -- The domain is OutIds
606 type CallEnv = IdEnv [Call]
607 type Call = (ValueEnv, [CoreArg])
608 -- The arguments of the call, together with the
609 -- env giving the constructor bindings at the call site
612 nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv }
614 combineCalls :: CallEnv -> CallEnv -> CallEnv
615 combineCalls = plusVarEnv_C (++)
617 combineUsage :: ScUsage -> ScUsage -> ScUsage
618 combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2),
619 scu_occs = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) }
621 combineUsages :: [ScUsage] -> ScUsage
622 combineUsages [] = nullUsage
623 combineUsages us = foldr1 combineUsage us
625 lookupOcc :: ScUsage -> OutVar -> (ScUsage, ArgOcc)
626 lookupOcc (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndr
627 = (SCU {scu_calls = sc_calls, scu_occs = delVarEnv sc_occs bndr},
628 lookupVarEnv sc_occs bndr `orElse` NoOcc)
630 lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc])
631 lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs
632 = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs},
633 [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs])
635 data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument
636 | UnkOcc -- Used in some unknown way
638 | ScrutOcc (UniqFM [ArgOcc]) -- See Note [ScrutOcc]
640 | BothOcc -- Definitely taken apart, *and* perhaps used in some other way
644 An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing,
645 is *only* taken apart or applied.
647 Functions, literal: ScrutOcc emptyUFM
648 Data constructors: ScrutOcc subs,
650 where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components,
651 The domain of the UniqFM is the Unique of the data constructor
653 The [ArgOcc] is the occurrences of the *pattern-bound* components
654 of the data structure. E.g.
655 data T a = forall b. MkT a b (b->a)
656 A pattern binds b, x::a, y::b, z::b->a, but not 'a'!
660 instance Outputable ArgOcc where
661 ppr (ScrutOcc xs) = ptext SLIT("scrut-occ") <> ppr xs
662 ppr UnkOcc = ptext SLIT("unk-occ")
663 ppr BothOcc = ptext SLIT("both-occ")
664 ppr NoOcc = ptext SLIT("no-occ")
666 -- Experimentally, this vesion of combineOcc makes ScrutOcc "win", so
667 -- that if the thing is scrutinised anywhere then we get to see that
668 -- in the overall result, even if it's also used in a boxed way
669 -- This might be too agressive; see Note [Reboxing] Alternative 3
670 combineOcc :: ArgOcc -> ArgOcc -> ArgOcc
671 combineOcc NoOcc occ = occ
672 combineOcc occ NoOcc = occ
673 combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys)
674 combineOcc _occ (ScrutOcc ys) = ScrutOcc ys
675 combineOcc (ScrutOcc xs) _occ = ScrutOcc xs
676 combineOcc UnkOcc UnkOcc = UnkOcc
677 combineOcc _ _ = BothOcc
679 combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]
680 combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys
682 setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage
683 -- *Overwrite* the occurrence info for the scrutinee, if the scrutinee
684 -- is a variable, and an interesting variable
685 setScrutOcc env usg (Cast e _) occ = setScrutOcc env usg e occ
686 setScrutOcc env usg (Note _ e) occ = setScrutOcc env usg e occ
687 setScrutOcc env usg (Var v) occ
688 | Just RecArg <- lookupHowBound env v = usg { scu_occs = extendVarEnv (scu_occs usg) v occ }
690 setScrutOcc _env usg _other _occ -- Catch-all
693 conArgOccs :: ArgOcc -> AltCon -> [ArgOcc]
694 -- Find usage of components of data con; returns [UnkOcc...] if unknown
695 -- See Note [ScrutOcc] for the extra UnkOccs in the vanilla datacon case
697 conArgOccs (ScrutOcc fm) (DataAlt dc)
698 | Just pat_arg_occs <- lookupUFM fm dc
699 = [UnkOcc | _ <- dataConUnivTyVars dc] ++ pat_arg_occs
701 conArgOccs _other _con = repeat UnkOcc
704 %************************************************************************
706 \subsection{The main recursive function}
708 %************************************************************************
710 The main recursive function gathers up usage information, and
711 creates specialised versions of functions.
714 scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
715 -- The unique supply is needed when we invent
716 -- a new name for the specialised function and its args
718 scExpr env e = scExpr' env e
721 scExpr' env (Var v) = case scSubstId env v of
722 Var v' -> return (varUsage env v' UnkOcc, Var v')
723 e' -> scExpr (zapScSubst env) e'
725 scExpr' env (Type t) = return (nullUsage, Type (scSubstTy env t))
726 scExpr' _ e@(Lit {}) = return (nullUsage, e)
727 scExpr' env (Note n e) = do (usg,e') <- scExpr env e
728 return (usg, Note n e')
729 scExpr' env (Cast e co) = do (usg, e') <- scExpr env e
730 return (usg, Cast e' (scSubstTy env co))
731 scExpr' env e@(App _ _) = scApp env (collectArgs e)
732 scExpr' env (Lam b e) = do let (env', b') = extendBndr env b
733 (usg, e') <- scExpr env' e
734 return (usg, Lam b' e')
736 scExpr' env (Case scrut b ty alts)
737 = do { (scrut_usg, scrut') <- scExpr env scrut
738 ; case isValue (sc_vals env) scrut' of
739 Just (ConVal con args) -> sc_con_app con args scrut'
740 _other -> sc_vanilla scrut_usg scrut'
743 sc_con_app con args scrut' -- Known constructor; simplify
744 = do { let (_, bs, rhs) = findAlt con alts
745 alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)
746 ; scExpr alt_env' rhs }
748 sc_vanilla scrut_usg scrut' -- Normal case
749 = do { let (alt_env,b') = extendBndrWith RecArg env b
750 -- Record RecArg for the components
752 ; (alt_usgs, alt_occs, alts')
753 <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts
755 ; let (alt_usg, b_occ) = lookupOcc (combineUsages alt_usgs) b'
756 scrut_occ = foldr combineOcc b_occ alt_occs
757 scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ
758 -- The combined usage of the scrutinee is given
759 -- by scrut_occ, which is passed to scScrut, which
760 -- in turn treats a bare-variable scrutinee specially
762 ; return (alt_usg `combineUsage` scrut_usg',
763 Case scrut' b' (scSubstTy env ty) alts') }
765 sc_alt env scrut' b' (con,bs,rhs)
766 = do { let (env1, bs') = extendBndrsWith RecArg env bs
767 env2 = extendCaseBndrs env1 scrut' b' con bs'
768 ; (usg,rhs') <- scExpr env2 rhs
769 ; let (usg', arg_occs) = lookupOccs usg bs'
770 scrut_occ = case con of
771 DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)
772 _ofther -> ScrutOcc emptyUFM
773 ; return (usg', scrut_occ, (con,bs',rhs')) }
775 scExpr' env (Let (NonRec bndr rhs) body)
776 | isTyVar bndr -- Type-lets may be created by doBeta
777 = scExpr' (extendScSubst env bndr rhs) body
779 = do { let (body_env, bndr') = extendBndr env bndr
780 ; (rhs_usg, (_, args', rhs_body', _)) <- scRecRhs env (bndr',rhs)
781 ; let rhs' = mkLams args' rhs_body'
783 ; if not opt_SpecInlineJoinPoints || null args' || isEmptyVarEnv (scu_calls rhs_usg) then do
785 let body_env2 = extendValEnv body_env bndr' (isValue (sc_vals env) rhs')
786 -- Record if the RHS is a value
787 ; (body_usg, body') <- scExpr body_env2 body
788 ; return (body_usg `combineUsage` rhs_usg, Let (NonRec bndr' rhs') body') }
789 else -- For now, just brutally inline the join point
790 do { let body_env2 = extendScSubst env bndr rhs'
791 ; scExpr body_env2 body } }
795 do { -- Join-point case
796 let body_env2 = extendHowBound body_env [bndr'] RecFun
797 -- If the RHS of this 'let' contains calls
798 -- to recursive functions that we're trying
799 -- to specialise, then treat this let too
800 -- as one to specialise
801 ; (body_usg, body') <- scExpr body_env2 body
803 ; (spec_usg, _, specs) <- specialise env (scu_calls body_usg) ([], rhs_info)
805 ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' }
806 `combineUsage` rhs_usg `combineUsage` spec_usg,
807 mkLets [NonRec b r | (b,r) <- addRules rhs_info specs] body')
811 scExpr' env (Let (Rec prs) body)
812 = do { (env', bind_usg, bind') <- scBind env (Rec prs)
813 ; (body_usg, body') <- scExpr env' body
814 ; return (bind_usg `combineUsage` body_usg, Let bind' body') }
817 -----------------------------------
818 scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)
820 scApp env (Var fn, args) -- Function is a variable
821 = ASSERT( not (null args) )
822 do { args_w_usgs <- mapM (scExpr env) args
823 ; let (arg_usgs, args') = unzip args_w_usgs
824 arg_usg = combineUsages arg_usgs
825 ; case scSubstId env fn of
826 fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args')
827 -- Do beta-reduction and try again
829 Var fn' -> return (arg_usg `combineUsage` fn_usg, mkApps (Var fn') args')
831 fn_usg = case lookupHowBound env fn' of
832 Just RecFun -> SCU { scu_calls = unitVarEnv fn' [(sc_vals env, args')],
833 scu_occs = emptyVarEnv }
834 Just RecArg -> SCU { scu_calls = emptyVarEnv,
835 scu_occs = unitVarEnv fn' (ScrutOcc emptyUFM) }
839 other_fn' -> return (arg_usg, mkApps other_fn' args') }
840 -- NB: doing this ignores any usage info from the substituted
841 -- function, but I don't think that matters. If it does
844 doBeta :: OutExpr -> [OutExpr] -> OutExpr
845 -- ToDo: adjust for System IF
846 doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args)
847 doBeta fn args = mkApps fn args
849 -- The function is almost always a variable, but not always.
850 -- In particular, if this pass follows float-in,
851 -- which it may, we can get
852 -- (let f = ...f... in f) arg1 arg2
853 scApp env (other_fn, args)
854 = do { (fn_usg, fn') <- scExpr env other_fn
855 ; (arg_usgs, args') <- mapAndUnzipM (scExpr env) args
856 ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') }
858 ----------------------
859 scBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, ScUsage, CoreBind)
861 | Just threshold <- sc_size env
862 , not (all (couldBeSmallEnoughToInline threshold) rhss)
864 = do { let (rhs_env,bndrs') = extendRecBndrs env bndrs
865 ; (rhs_usgs, rhss') <- mapAndUnzipM (scExpr rhs_env) rhss
866 ; return (rhs_env, combineUsages rhs_usgs, Rec (bndrs' `zip` rhss')) }
867 | otherwise -- Do specialisation
868 = do { let (rhs_env1,bndrs') = extendRecBndrs env bndrs
869 rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
871 ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
872 ; let rhs_usg = combineUsages rhs_usgs
874 ; (spec_usg, specs) <- spec_loop rhs_env2 (scu_calls rhs_usg)
875 (repeat [] `zip` rhs_infos)
877 ; let all_usg = rhs_usg `combineUsage` spec_usg
879 ; return (rhs_env1, -- For the body of the letrec, delete the RecFun business
880 all_usg { scu_calls = scu_calls rhs_usg `delVarEnvList` bndrs' },
881 Rec (concat (zipWith addRules rhs_infos specs))) }
883 (bndrs,rhss) = unzip prs
887 -> [([CallPat], RhsInfo)] -- One per binder
888 -> UniqSM (ScUsage, [[SpecInfo]]) -- One list per binder
889 spec_loop env all_calls rhs_stuff
890 = do { (spec_usg_s, new_pats_s, specs) <- mapAndUnzip3M (specialise env all_calls) rhs_stuff
891 ; let spec_usg = combineUsages spec_usg_s
892 ; if all null new_pats_s then
893 return (spec_usg, specs) else do
894 { (spec_usg1, specs1) <- spec_loop env (scu_calls spec_usg)
895 (zipWith add_pats new_pats_s rhs_stuff)
896 ; return (spec_usg `combineUsage` spec_usg1, zipWith (++) specs specs1) } }
898 add_pats :: [CallPat] -> ([CallPat], RhsInfo) -> ([CallPat], RhsInfo)
899 add_pats new_pats (done_pats, rhs_info) = (done_pats ++ new_pats, rhs_info)
901 scBind env (NonRec bndr rhs)
902 = do { (usg, rhs') <- scExpr env rhs
903 ; let (env1, bndr') = extendBndr env bndr
904 env2 = extendValEnv env1 bndr' (isValue (sc_vals env) rhs')
905 ; return (env2, usg, NonRec bndr' rhs') }
907 ----------------------
908 scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM (ScUsage, RhsInfo)
909 scRecRhs env (bndr,rhs)
910 = do { let (arg_bndrs,body) = collectBinders rhs
911 (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs
912 ; (body_usg, body') <- scExpr body_env body
913 ; let (rhs_usg, arg_occs) = lookupOccs body_usg arg_bndrs'
914 ; return (rhs_usg, (bndr, arg_bndrs', body', arg_occs)) }
916 -- The arg_occs says how the visible,
917 -- lambda-bound binders of the RHS are used
918 -- (including the TyVar binders)
919 -- Two pats are the same if they match both ways
921 ----------------------
922 addRules :: RhsInfo -> [SpecInfo] -> [(Id,CoreExpr)]
923 addRules (fn, args, body, _) specs
924 = [(id,rhs) | (_,id,rhs) <- specs] ++
925 [(fn `addIdSpecialisations` rules, mkLams args body)]
927 rules = [r | (r,_,_) <- specs]
929 ----------------------
930 varUsage :: ScEnv -> OutVar -> ArgOcc -> ScUsage
932 | Just RecArg <- lookupHowBound env v = SCU { scu_calls = emptyVarEnv
933 , scu_occs = unitVarEnv v use }
934 | otherwise = nullUsage
938 %************************************************************************
940 The specialiser itself
942 %************************************************************************
945 type RhsInfo = (OutId, [OutVar], OutExpr, [ArgOcc])
946 -- Info about the *original* RHS of a binding we are specialising
947 -- Original binding f = \xs.body
948 -- Plus info about usage of arguments
950 type SpecInfo = (CoreRule, OutId, OutExpr)
951 -- One specialisation: Rule plus definition
956 -> CallEnv -- Info on calls
957 -> ([CallPat], RhsInfo) -- Original RHS plus patterns dealt with
958 -> UniqSM (ScUsage, [CallPat], [SpecInfo]) -- Specialised calls
960 -- Note: the rhs here is the optimised version of the original rhs
961 -- So when we make a specialised copy of the RHS, we're starting
962 -- from an RHS whose nested functions have been optimised already.
964 specialise env bind_calls (done_pats, (fn, arg_bndrs, body, arg_occs))
965 | notNull arg_bndrs, -- Only specialise functions
966 Just all_calls <- lookupVarEnv bind_calls fn
967 = do { pats <- callsToPats env done_pats arg_occs all_calls
968 -- ; pprTrace "specialise" (vcat [ppr fn <+> ppr arg_occs,
969 -- text "calls" <+> ppr all_calls,
970 -- text "good pats" <+> ppr pats]) $
973 ; (spec_usgs, specs) <- mapAndUnzipM (spec_one env fn arg_bndrs body)
974 (pats `zip` [length done_pats..])
976 ; return (combineUsages spec_usgs, pats, specs) }
978 = return (nullUsage, [], []) -- The boring case
981 ---------------------
984 -> [Var] -- Lambda-binders of RHS; should match patterns
985 -> CoreExpr -- Body of the original function
986 -> (([Var], [CoreArg]), Int)
987 -> UniqSM (ScUsage, SpecInfo) -- Rule and binding
989 -- spec_one creates a specialised copy of the function, together
990 -- with a rule for using it. I'm very proud of how short this
991 -- function is, considering what it does :-).
997 f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
998 [c::*, v::(b,c) are presumably bound by the (...) part]
1000 f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
1001 (...entire body of f...) [b -> (b,c),
1002 y -> ((:) (a,(b,c)) (x,v) hw)]
1004 RULE: forall b::* c::*, -- Note, *not* forall a, x
1008 f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
1011 spec_one env fn arg_bndrs body ((qvars, pats), rule_number)
1012 = do { -- Specialise the body
1013 let spec_env = extendScSubstList (extendScInScope env qvars)
1014 (arg_bndrs `zip` pats)
1015 ; (spec_usg, spec_body) <- scExpr spec_env body
1017 -- ; pprTrace "spec_one" (ppr fn <+> vcat [text "pats" <+> ppr pats,
1018 -- text "calls" <+> (ppr (scu_calls spec_usg))])
1021 -- And build the results
1022 ; spec_uniq <- getUniqueUs
1023 ; let (spec_lam_args, spec_call_args) = mkWorkerArgs qvars body_ty
1024 -- Usual w/w hack to avoid generating
1025 -- a spec_rhs of unlifted type and no args
1028 fn_loc = nameSrcSpan fn_name
1029 spec_occ = mkSpecOcc (nameOccName fn_name)
1030 rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number))
1031 spec_rhs = mkLams spec_lam_args spec_body
1032 spec_id = mkUserLocal spec_occ spec_uniq (mkPiTypes spec_lam_args body_ty) fn_loc
1033 body_ty = exprType spec_body
1034 rule_rhs = mkVarApps (Var spec_id) spec_call_args
1035 rule = mkLocalRule rule_name specConstrActivation fn_name qvars pats rule_rhs
1036 ; return (spec_usg, (rule, spec_id, spec_rhs)) }
1038 -- In which phase should the specialise-constructor rules be active?
1039 -- Originally I made them always-active, but Manuel found that
1040 -- this defeated some clever user-written rules. So Plan B
1041 -- is to make them active only in Phase 0; after all, currently,
1042 -- the specConstr transformation is only run after the simplifier
1043 -- has reached Phase 0. In general one would want it to be
1044 -- flag-controllable, but for now I'm leaving it baked in
1046 specConstrActivation :: Activation
1047 specConstrActivation = ActiveAfter 0 -- Baked in; see comments above
1050 %************************************************************************
1052 \subsection{Argument analysis}
1054 %************************************************************************
1056 This code deals with analysing call-site arguments to see whether
1057 they are constructor applications.
1061 type CallPat = ([Var], [CoreExpr]) -- Quantified variables and arguments
1064 callsToPats :: ScEnv -> [CallPat] -> [ArgOcc] -> [Call] -> UniqSM [CallPat]
1065 -- Result has no duplicate patterns,
1066 -- nor ones mentioned in done_pats
1067 callsToPats env done_pats bndr_occs calls
1068 = do { mb_pats <- mapM (callToPats env bndr_occs) calls
1070 ; let good_pats :: [([Var], [CoreArg])]
1071 good_pats = catMaybes mb_pats
1072 is_done p = any (samePat p) done_pats
1074 ; return (filterOut is_done (nubBy samePat good_pats)) }
1076 callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
1077 -- The [Var] is the variables to quantify over in the rule
1078 -- Type variables come first, since they may scope
1079 -- over the following term variables
1080 -- The [CoreExpr] are the argument patterns for the rule
1081 callToPats env bndr_occs (con_env, args)
1082 | length args < length bndr_occs -- Check saturated
1085 = do { let in_scope = substInScope (sc_subst env)
1086 ; prs <- argsToPats in_scope con_env (args `zip` bndr_occs)
1087 ; let (good_pats, pats) = unzip prs
1088 pat_fvs = varSetElems (exprsFreeVars pats)
1089 qvars = filterOut (`elemInScopeSet` in_scope) pat_fvs
1090 -- Quantify over variables that are not in sccpe
1092 -- See Note [Shadowing] at the top
1094 (tvs, ids) = partition isTyVar qvars
1096 -- Put the type variables first; the type of a term
1097 -- variable may mention a type variable
1099 ; -- pprTrace "callToPats" (ppr args $$ ppr prs $$ ppr bndr_occs) $
1101 then return (Just (qvars', pats))
1102 else return Nothing }
1104 -- argToPat takes an actual argument, and returns an abstracted
1105 -- version, consisting of just the "constructor skeleton" of the
1106 -- argument, with non-constructor sub-expression replaced by new
1107 -- placeholder variables. For example:
1108 -- C a (D (f x) (g y)) ==> C p1 (D p2 p3)
1110 argToPat :: InScopeSet -- What's in scope at the fn defn site
1111 -> ValueEnv -- ValueEnv at the call site
1112 -> CoreArg -- A call arg (or component thereof)
1114 -> UniqSM (Bool, CoreArg)
1115 -- Returns (interesting, pat),
1116 -- where pat is the pattern derived from the argument
1117 -- intersting=True if the pattern is non-trivial (not a variable or type)
1118 -- E.g. x:xs --> (True, x:xs)
1119 -- f xs --> (False, w) where w is a fresh wildcard
1120 -- (f xs, 'c') --> (True, (w, 'c')) where w is a fresh wildcard
1121 -- \x. x+y --> (True, \x. x+y)
1122 -- lvl7 --> (True, lvl7) if lvl7 is bound
1123 -- somewhere further out
1125 argToPat _in_scope _val_env arg@(Type {}) _arg_occ
1126 = return (False, arg)
1128 argToPat in_scope val_env (Note _ arg) arg_occ
1129 = argToPat in_scope val_env arg arg_occ
1130 -- Note [Notes in call patterns]
1131 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1132 -- Ignore Notes. In particular, we want to ignore any InlineMe notes
1133 -- Perhaps we should not ignore profiling notes, but I'm going to
1134 -- ride roughshod over them all for now.
1135 --- See Note [Notes in RULE matching] in Rules
1137 argToPat in_scope val_env (Let _ arg) arg_occ
1138 = argToPat in_scope val_env arg arg_occ
1139 -- Look through let expressions
1140 -- e.g. f (let v = rhs in \y -> ...v...)
1141 -- Here we can specialise for f (\y -> ...)
1142 -- because the rule-matcher will look through the let.
1144 argToPat in_scope val_env (Cast arg co) arg_occ
1145 = do { (interesting, arg') <- argToPat in_scope val_env arg arg_occ
1146 ; let (ty1,ty2) = coercionKind co
1147 ; if not interesting then
1150 { -- Make a wild-card pattern for the coercion
1152 ; let co_name = mkSysTvName uniq FSLIT("sg")
1153 co_var = mkCoVar co_name (mkCoKind ty1 ty2)
1154 ; return (interesting, Cast arg' (mkTyVarTy co_var)) } }
1156 {- Disabling lambda specialisation for now
1157 It's fragile, and the spec_loop can be infinite
1158 argToPat in_scope val_env arg arg_occ
1160 = return (True, arg)
1162 is_value_lam (Lam v e) -- Spot a value lambda, even if
1163 | isId v = True -- it is inside a type lambda
1164 | otherwise = is_value_lam e
1165 is_value_lam other = False
1168 -- Check for a constructor application
1169 -- NB: this *precedes* the Var case, so that we catch nullary constrs
1170 argToPat in_scope val_env arg arg_occ
1171 | Just (ConVal dc args) <- isValue val_env arg
1173 ScrutOcc _ -> True -- Used only by case scrutinee
1174 BothOcc -> case arg of -- Used elsewhere
1175 App {} -> True -- see Note [Reboxing]
1177 _other -> False -- No point; the arg is not decomposed
1178 = do { args' <- argsToPats in_scope val_env (args `zip` conArgOccs arg_occ dc)
1179 ; return (True, mk_con_app dc (map snd args')) }
1181 -- Check if the argument is a variable that
1182 -- is in scope at the function definition site
1183 -- It's worth specialising on this if
1184 -- (a) it's used in an interesting way in the body
1185 -- (b) we know what its value is
1186 argToPat in_scope val_env (Var v) arg_occ
1187 | case arg_occ of { UnkOcc -> False; _other -> True }, -- (a)
1189 = return (True, Var v)
1192 | isLocalId v = v `elemInScopeSet` in_scope
1193 && isJust (lookupVarEnv val_env v)
1194 -- Local variables have values in val_env
1195 | otherwise = isValueUnfolding (idUnfolding v)
1196 -- Imports have unfoldings
1198 -- I'm really not sure what this comment means
1199 -- And by not wild-carding we tend to get forall'd
1200 -- variables that are in soope, which in turn can
1201 -- expose the weakness in let-matching
1202 -- See Note [Matching lets] in Rules
1203 -- Check for a variable bound inside the function.
1204 -- Don't make a wild-card, because we may usefully share
1205 -- e.g. f a = let x = ... in f (x,x)
1206 -- NB: this case follows the lambda and con-app cases!!
1207 argToPat _in_scope _val_env (Var v) _arg_occ
1208 = return (False, Var v)
1210 -- The default case: make a wild-card
1211 argToPat _in_scope _val_env arg _arg_occ
1212 = wildCardPat (exprType arg)
1214 wildCardPat :: Type -> UniqSM (Bool, CoreArg)
1215 wildCardPat ty = do { uniq <- getUniqueUs
1216 ; let id = mkSysLocal FSLIT("sc") uniq ty
1217 ; return (False, Var id) }
1219 argsToPats :: InScopeSet -> ValueEnv
1220 -> [(CoreArg, ArgOcc)]
1221 -> UniqSM [(Bool, CoreArg)]
1222 argsToPats in_scope val_env args
1225 do_one (arg,occ) = argToPat in_scope val_env arg occ
1230 isValue :: ValueEnv -> CoreExpr -> Maybe Value
1231 isValue _env (Lit lit)
1232 = Just (ConVal (LitAlt lit) [])
1235 | Just stuff <- lookupVarEnv env v
1236 = Just stuff -- You might think we could look in the idUnfolding here
1237 -- but that doesn't take account of which branch of a
1238 -- case we are in, which is the whole point
1240 | not (isLocalId v) && isCheapUnfolding unf
1241 = isValue env (unfoldingTemplate unf)
1244 -- However we do want to consult the unfolding
1245 -- as well, for let-bound constructors!
1247 isValue env (Lam b e)
1248 | isTyVar b = isValue env e
1249 | otherwise = Just LambdaVal
1251 isValue _env expr -- Maybe it's a constructor application
1252 | (Var fun, args) <- collectArgs expr
1253 = case isDataConWorkId_maybe fun of
1255 Just con | args `lengthAtLeast` dataConRepArity con
1256 -- Check saturated; might be > because the
1257 -- arity excludes type args
1258 -> Just (ConVal (DataAlt con) args)
1260 _other | valArgCount args < idArity fun
1261 -- Under-applied function
1262 -> Just LambdaVal -- Partial application
1266 isValue _env _expr = Nothing
1268 mk_con_app :: AltCon -> [CoreArg] -> CoreExpr
1269 mk_con_app (LitAlt lit) [] = Lit lit
1270 mk_con_app (DataAlt con) args = mkConApp con args
1271 mk_con_app _other _args = panic "SpecConstr.mk_con_app"
1273 samePat :: CallPat -> CallPat -> Bool
1274 samePat (vs1, as1) (vs2, as2)
1277 same (Var v1) (Var v2)
1278 | v1 `elem` vs1 = v2 `elem` vs2
1279 | v2 `elem` vs2 = False
1280 | otherwise = v1 == v2
1282 same (Lit l1) (Lit l2) = l1==l2
1283 same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2
1285 same (Type {}) (Type {}) = True -- Note [Ignore type differences]
1286 same (Note _ e1) e2 = same e1 e2 -- Ignore casts and notes
1287 same (Cast e1 _) e2 = same e1 e2
1288 same e1 (Note _ e2) = same e1 e2
1289 same e1 (Cast e2 _) = same e1 e2
1291 same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2)
1292 False -- Let, lambda, case should not occur
1293 bad (Case {}) = True
1299 Note [Ignore type differences]
1300 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1301 We do not want to generate specialisations where the call patterns
1302 differ only in their type arguments! Not only is it utterly useless,
1303 but it also means that (with polymorphic recursion) we can generate
1304 an infinite number of specialisations. Example is Data.Sequence.adjustTree,