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 CoreFVs ( exprsFreeVars )
24 import WwLib ( mkWorkerArgs )
25 import DataCon ( dataConRepArity, dataConUnivTyVars )
28 import Type hiding( substTy )
34 import OccName ( mkSpecOcc )
35 import DynFlags ( DynFlags(..) )
36 import StaticFlags ( opt_PprStyle_Debug )
37 import StaticFlags ( opt_SpecInlineJoinPoints )
38 import BasicTypes ( Activation(..) )
39 import Maybes ( orElse, catMaybes, isJust, isNothing )
41 import List ( nubBy, partition )
47 import Control.Monad ( zipWithM )
50 -----------------------------------------------------
52 -----------------------------------------------------
57 drop n (x:xs) = drop (n-1) xs
59 After the first time round, we could pass n unboxed. This happens in
60 numerical code too. Here's what it looks like in Core:
62 drop n xs = case xs of
67 _ -> drop (I# (n# -# 1#)) xs
69 Notice that the recursive call has an explicit constructor as argument.
70 Noticing this, we can make a specialised version of drop
72 RULE: drop (I# n#) xs ==> drop' n# xs
74 drop' n# xs = let n = I# n# in ...orig RHS...
76 Now the simplifier will apply the specialisation in the rhs of drop', giving
78 drop' n# xs = case xs of
82 _ -> drop (n# -# 1#) xs
86 We'd also like to catch cases where a parameter is carried along unchanged,
87 but evaluated each time round the loop:
89 f i n = if i>0 || i>n then i else f (i*2) n
91 Here f isn't strict in n, but we'd like to avoid evaluating it each iteration.
92 In Core, by the time we've w/wd (f is strict in i) we get
94 f i# n = case i# ># 0 of
96 True -> case n of n' { I# n# ->
99 True -> f (i# *# 2#) n'
101 At the call to f, we see that the argument, n is know to be (I# n#),
102 and n is evaluated elsewhere in the body of f, so we can play the same
108 We must be careful not to allocate the same constructor twice. Consider
109 f p = (...(case p of (a,b) -> e)...p...,
110 ...let t = (r,s) in ...t...(f t)...)
111 At the recursive call to f, we can see that t is a pair. But we do NOT want
112 to make a specialised copy:
113 f' a b = let p = (a,b) in (..., ...)
114 because now t is allocated by the caller, then r and s are passed to the
115 recursive call, which allocates the (r,s) pair again.
118 (a) the argument p is used in other than a case-scrutinsation way.
119 (b) the argument to the call is not a 'fresh' tuple; you have to
120 look into its unfolding to see that it's a tuple
122 Hence the "OR" part of Note [Good arguments] below.
124 ALTERNATIVE 2: pass both boxed and unboxed versions. This no longer saves
125 allocation, but does perhaps save evals. In the RULE we'd have
128 f (I# x#) = f' (I# x#) x#
130 If at the call site the (I# x) was an unfolding, then we'd have to
131 rely on CSE to eliminate the duplicate allocation.... This alternative
132 doesn't look attractive enough to pursue.
134 ALTERNATIVE 3: ignore the reboxing problem. The trouble is that
135 the conservative reboxing story prevents many useful functions from being
136 specialised. Example:
137 foo :: Maybe Int -> Int -> Int
139 foo x@(Just m) n = foo x (n-m)
140 Here the use of 'x' will clearly not require boxing in the specialised function.
142 The strictness analyser has the same problem, in fact. Example:
144 If we pass just 'a' and 'b' to the worker, it might need to rebox the
145 pair to create (a,b). A more sophisticated analysis might figure out
146 precisely the cases in which this could happen, but the strictness
147 analyser does no such analysis; it just passes 'a' and 'b', and hopes
150 So my current choice is to make SpecConstr similarly aggressive, and
151 ignore the bad potential of reboxing.
154 Note [Good arguments]
155 ~~~~~~~~~~~~~~~~~~~~~
158 * A self-recursive function. Ignore mutual recursion for now,
159 because it's less common, and the code is simpler for self-recursion.
163 a) At a recursive call, one or more parameters is an explicit
164 constructor application
166 That same parameter is scrutinised by a case somewhere in
167 the RHS of the function
171 b) At a recursive call, one or more parameters has an unfolding
172 that is an explicit constructor application
174 That same parameter is scrutinised by a case somewhere in
175 the RHS of the function
177 Those are the only uses of the parameter (see Note [Reboxing])
180 What to abstract over
181 ~~~~~~~~~~~~~~~~~~~~~
182 There's a bit of a complication with type arguments. If the call
185 f p = ...f ((:) [a] x xs)...
187 then our specialised function look like
189 f_spec x xs = let p = (:) [a] x xs in ....as before....
191 This only makes sense if either
192 a) the type variable 'a' is in scope at the top of f, or
193 b) the type variable 'a' is an argument to f (and hence fs)
195 Actually, (a) may hold for value arguments too, in which case
196 we may not want to pass them. Supose 'x' is in scope at f's
197 defn, but xs is not. Then we'd like
199 f_spec xs = let p = (:) [a] x xs in ....as before....
201 Similarly (b) may hold too. If x is already an argument at the
202 call, no need to pass it again.
204 Finally, if 'a' is not in scope at the call site, we could abstract
205 it as we do the term variables:
207 f_spec a x xs = let p = (:) [a] x xs in ...as before...
209 So the grand plan is:
211 * abstract the call site to a constructor-only pattern
212 e.g. C x (D (f p) (g q)) ==> C s1 (D s2 s3)
214 * Find the free variables of the abstracted pattern
216 * Pass these variables, less any that are in scope at
217 the fn defn. But see Note [Shadowing] below.
220 NOTICE that we only abstract over variables that are not in scope,
221 so we're in no danger of shadowing variables used in "higher up"
227 In this pass we gather up usage information that may mention variables
228 that are bound between the usage site and the definition site; or (more
229 seriously) may be bound to something different at the definition site.
232 f x = letrec g y v = let x = ...
235 Since 'x' is in scope at the call site, we may make a rewrite rule that
237 RULE forall a,b. g (a,b) x = ...
238 But this rule will never match, because it's really a different 'x' at
239 the call site -- and that difference will be manifest by the time the
240 simplifier gets to it. [A worry: the simplifier doesn't *guarantee*
241 no-shadowing, so perhaps it may not be distinct?]
243 Anyway, the rule isn't actually wrong, it's just not useful. One possibility
244 is to run deShadowBinds before running SpecConstr, but instead we run the
245 simplifier. That gives the simplest possible program for SpecConstr to
246 chew on; and it virtually guarantees no shadowing.
248 Note [Specialising for constant parameters]
249 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
250 This one is about specialising on a *constant* (but not necessarily
251 constructor) argument
253 foo :: Int -> (Int -> Int) -> Int
255 foo m f = foo (f m) (+1)
259 lvl_rmV :: GHC.Base.Int -> GHC.Base.Int
261 \ (ds_dlk :: GHC.Base.Int) ->
262 case ds_dlk of wild_alH { GHC.Base.I# x_alG ->
263 GHC.Base.I# (GHC.Prim.+# x_alG 1)
265 T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
268 \ (ww_sme :: GHC.Prim.Int#) (w_smg :: GHC.Base.Int -> GHC.Base.Int) ->
269 case ww_sme of ds_Xlw {
271 case w_smg (GHC.Base.I# ds_Xlw) of w1_Xmo { GHC.Base.I# ww1_Xmz ->
272 T.$wfoo ww1_Xmz lvl_rmV
277 The recursive call has lvl_rmV as its argument, so we could create a specialised copy
278 with that argument baked in; that is, not passed at all. Now it can perhaps be inlined.
280 When is this worth it? Call the constant 'lvl'
281 - If 'lvl' has an unfolding that is a constructor, see if the corresponding
282 parameter is scrutinised anywhere in the body.
284 - If 'lvl' has an unfolding that is a inlinable function, see if the corresponding
285 parameter is applied (...to enough arguments...?)
287 Also do this is if the function has RULES?
291 Note [Specialising for lambda parameters]
292 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
293 foo :: Int -> (Int -> Int) -> Int
295 foo m f = foo (f m) (\n -> n-m)
297 This is subtly different from the previous one in that we get an
298 explicit lambda as the argument:
300 T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
303 \ (ww_sm8 :: GHC.Prim.Int#) (w_sma :: GHC.Base.Int -> GHC.Base.Int) ->
304 case ww_sm8 of ds_Xlr {
306 case w_sma (GHC.Base.I# ds_Xlr) of w1_Xmf { GHC.Base.I# ww1_Xmq ->
309 (\ (n_ad3 :: GHC.Base.Int) ->
310 case n_ad3 of wild_alB { GHC.Base.I# x_alA ->
311 GHC.Base.I# (GHC.Prim.-# x_alA ds_Xlr)
317 I wonder if SpecConstr couldn't be extended to handle this? After all,
318 lambda is a sort of constructor for functions and perhaps it already
319 has most of the necessary machinery?
321 Furthermore, there's an immediate win, because you don't need to allocate the lamda
322 at the call site; and if perchance it's called in the recursive call, then you
323 may avoid allocating it altogether. Just like for constructors.
325 Looks cool, but probably rare...but it might be easy to implement.
328 Note [SpecConstr for casts]
329 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
332 data instance T Int = T Int
337 go (T n) = go (T (n-1))
339 The recursive call ends up looking like
340 go (T (I# ...) `cast` g)
341 So we want to spot the construtor application inside the cast.
342 That's why we have the Cast case in argToPat
344 Note [Local recursive groups]
345 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
346 For a *local* recursive group, we can see all the calls to the
347 function, so we seed the specialisation loop from the calls in the
348 body, not from the calls in the RHS. Consider:
350 bar m n = foo n (n,n) (n,n) (n,n) (n,n)
354 | n > 3000 = case p of { (p1,p2) -> foo (n-1) (p2,p1) q r s }
355 | n > 2000 = case q of { (q1,q2) -> foo (n-1) p (q2,q1) r s }
356 | n > 1000 = case r of { (r1,r2) -> foo (n-1) p q (r2,r1) s }
357 | otherwise = case s of { (s1,s2) -> foo (n-1) p q r (s2,s1) }
359 If we start with the RHSs of 'foo', we get lots and lots of specialisations,
360 most of which are not needed. But if we start with the (single) call
361 in the rhs of 'bar' we get exactly one fully-specialised copy, and all
362 the recursive calls go to this fully-specialised copy. Indeed, the original
363 function is later collected as dead code. This is very important in
364 specialising the loops arising from stream fusion, for example in NDP where
365 we were getting literally hundreds of (mostly unused) specialisations of
368 -----------------------------------------------------
369 Stuff not yet handled
370 -----------------------------------------------------
372 Here are notes arising from Roman's work that I don't want to lose.
378 foo :: Int -> T Int -> Int
380 foo x t | even x = case t of { T n -> foo (x-n) t }
381 | otherwise = foo (x-1) t
383 SpecConstr does no specialisation, because the second recursive call
384 looks like a boxed use of the argument. A pity.
386 $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
388 \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) ->
389 case ww_sFo of ds_Xw6 [Just L] {
391 case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] {
392 __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq;
394 case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] ->
395 case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] ->
396 $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy
402 data a :*: b = !a :*: !b
405 foo :: (Int :*: T Int) -> Int
407 foo (x :*: t) | even x = case t of { T n -> foo ((x-n) :*: t) }
408 | otherwise = foo ((x-1) :*: t)
410 Very similar to the previous one, except that the parameters are now in
411 a strict tuple. Before SpecConstr, we have
413 $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
415 \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T
417 case ww_sFU of ds_Xws [Just L] {
419 case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] {
421 case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] ->
422 $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2 -- $wfoo1
425 case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] ->
426 case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] ->
427 $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB -- $wfoo2
431 We get two specialisations:
432 "SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#}
433 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB)
434 = Foo.$s$wfoo1 a_sFB sc_sGC ;
435 "SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#}
436 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp))
437 = Foo.$s$wfoo y_aFp sc_sGC ;
439 But perhaps the first one isn't good. After all, we know that tpl_B2 is
440 a T (I# x) really, because T is strict and Int has one constructor. (We can't
441 unbox the strict fields, becuase T is polymorphic!)
445 %************************************************************************
447 \subsection{Top level wrapper stuff}
449 %************************************************************************
452 specConstrProgram :: DynFlags -> UniqSupply -> [CoreBind] -> [CoreBind]
453 specConstrProgram dflags us binds = fst $ initUs us (go (initScEnv dflags) binds)
456 go env (bind:binds) = do (env', bind') <- scTopBind env bind
457 binds' <- go env' binds
458 return (bind' : binds')
462 %************************************************************************
464 \subsection{Environment: goes downwards}
466 %************************************************************************
469 data ScEnv = SCE { sc_size :: Maybe Int, -- Size threshold
470 sc_count :: Maybe Int, -- Max # of specialisations for any one fn
472 sc_subst :: Subst, -- Current substitution
473 -- Maps InIds to OutExprs
475 sc_how_bound :: HowBoundEnv,
476 -- Binds interesting non-top-level variables
477 -- Domain is OutVars (*after* applying the substitution)
480 -- Domain is OutIds (*after* applying the substitution)
481 -- Used even for top-level bindings (but not imported ones)
484 ---------------------
485 -- As we go, we apply a substitution (sc_subst) to the current term
486 type InExpr = CoreExpr -- _Before_ applying the subst
488 type OutExpr = CoreExpr -- _After_ applying the subst
492 ---------------------
493 type HowBoundEnv = VarEnv HowBound -- Domain is OutVars
495 ---------------------
496 type ValueEnv = IdEnv Value -- Domain is OutIds
497 data Value = ConVal AltCon [CoreArg] -- _Saturated_ constructors
498 | LambdaVal -- Inlinable lambdas or PAPs
500 instance Outputable Value where
501 ppr (ConVal con args) = ppr con <+> interpp'SP args
502 ppr LambdaVal = ptext (sLit "<Lambda>")
504 ---------------------
505 initScEnv :: DynFlags -> ScEnv
507 = SCE { sc_size = specConstrThreshold dflags,
508 sc_count = specConstrCount dflags,
509 sc_subst = emptySubst,
510 sc_how_bound = emptyVarEnv,
511 sc_vals = emptyVarEnv }
513 data HowBound = RecFun -- These are the recursive functions for which
514 -- we seek interesting call patterns
516 | RecArg -- These are those functions' arguments, or their sub-components;
517 -- we gather occurrence information for these
519 instance Outputable HowBound where
520 ppr RecFun = text "RecFun"
521 ppr RecArg = text "RecArg"
523 lookupHowBound :: ScEnv -> Id -> Maybe HowBound
524 lookupHowBound env id = lookupVarEnv (sc_how_bound env) id
526 scSubstId :: ScEnv -> Id -> CoreExpr
527 scSubstId env v = lookupIdSubst (sc_subst env) v
529 scSubstTy :: ScEnv -> Type -> Type
530 scSubstTy env ty = substTy (sc_subst env) ty
532 zapScSubst :: ScEnv -> ScEnv
533 zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) }
535 extendScInScope :: ScEnv -> [Var] -> ScEnv
536 -- Bring the quantified variables into scope
537 extendScInScope env qvars = env { sc_subst = extendInScopeList (sc_subst env) qvars }
539 -- Extend the substitution
540 extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv
541 extendScSubst env var expr = env { sc_subst = extendSubst (sc_subst env) var expr }
543 extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv
544 extendScSubstList env prs = env { sc_subst = extendSubstList (sc_subst env) prs }
546 extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv
547 extendHowBound env bndrs how_bound
548 = env { sc_how_bound = extendVarEnvList (sc_how_bound env)
549 [(bndr,how_bound) | bndr <- bndrs] }
551 extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var])
552 extendBndrsWith how_bound env bndrs
553 = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndrs')
555 (subst', bndrs') = substBndrs (sc_subst env) bndrs
556 hb_env' = sc_how_bound env `extendVarEnvList`
557 [(bndr,how_bound) | bndr <- bndrs']
559 extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var)
560 extendBndrWith how_bound env bndr
561 = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndr')
563 (subst', bndr') = substBndr (sc_subst env) bndr
564 hb_env' = extendVarEnv (sc_how_bound env) bndr' how_bound
566 extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var])
567 extendRecBndrs env bndrs = (env { sc_subst = subst' }, bndrs')
569 (subst', bndrs') = substRecBndrs (sc_subst env) bndrs
571 extendBndr :: ScEnv -> Var -> (ScEnv, Var)
572 extendBndr env bndr = (env { sc_subst = subst' }, bndr')
574 (subst', bndr') = substBndr (sc_subst env) bndr
576 extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv
577 extendValEnv env _ Nothing = env
578 extendValEnv env id (Just cv) = env { sc_vals = extendVarEnv (sc_vals env) id cv }
580 extendCaseBndrs :: ScEnv -> Id -> AltCon -> [Var] -> (ScEnv, [Var])
584 -- we want to bind b, to (C x y)
585 -- NB1: Extends only the sc_vals part of the envt
586 -- NB2: Kill the dead-ness info on the pattern binders x,y, since
587 -- they are potentially made alive by the [b -> C x y] binding
588 extendCaseBndrs env case_bndr con alt_bndrs
589 | isDeadBinder case_bndr
592 = (env1, map zap alt_bndrs)
593 -- NB: We used to bind v too, if scrut = (Var v); but
594 -- the simplifer has already done this so it seems
595 -- redundant to do so here
597 -- Var v -> extendValEnv env1 v cval
600 zap v | isTyVar v = v -- See NB2 above
601 | otherwise = zapIdOccInfo v
602 env1 = extendValEnv env case_bndr cval
605 LitAlt {} -> Just (ConVal con [])
606 DataAlt {} -> Just (ConVal con vanilla_args)
608 vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
609 varsToCoreExprs alt_bndrs
613 %************************************************************************
615 \subsection{Usage information: flows upwards}
617 %************************************************************************
622 scu_calls :: CallEnv, -- Calls
623 -- The functions are a subset of the
624 -- RecFuns in the ScEnv
626 scu_occs :: !(IdEnv ArgOcc) -- Information on argument occurrences
627 } -- The domain is OutIds
629 type CallEnv = IdEnv [Call]
630 type Call = (ValueEnv, [CoreArg])
631 -- The arguments of the call, together with the
632 -- env giving the constructor bindings at the call site
635 nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv }
637 combineCalls :: CallEnv -> CallEnv -> CallEnv
638 combineCalls = plusVarEnv_C (++)
640 combineUsage :: ScUsage -> ScUsage -> ScUsage
641 combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2),
642 scu_occs = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) }
644 combineUsages :: [ScUsage] -> ScUsage
645 combineUsages [] = nullUsage
646 combineUsages us = foldr1 combineUsage us
648 lookupOcc :: ScUsage -> OutVar -> (ScUsage, ArgOcc)
649 lookupOcc (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndr
650 = (SCU {scu_calls = sc_calls, scu_occs = delVarEnv sc_occs bndr},
651 lookupVarEnv sc_occs bndr `orElse` NoOcc)
653 lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc])
654 lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs
655 = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs},
656 [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs])
658 data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument
659 | UnkOcc -- Used in some unknown way
661 | ScrutOcc (UniqFM [ArgOcc]) -- See Note [ScrutOcc]
663 | BothOcc -- Definitely taken apart, *and* perhaps used in some other way
667 An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing,
668 is *only* taken apart or applied.
670 Functions, literal: ScrutOcc emptyUFM
671 Data constructors: ScrutOcc subs,
673 where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components,
674 The domain of the UniqFM is the Unique of the data constructor
676 The [ArgOcc] is the occurrences of the *pattern-bound* components
677 of the data structure. E.g.
678 data T a = forall b. MkT a b (b->a)
679 A pattern binds b, x::a, y::b, z::b->a, but not 'a'!
683 instance Outputable ArgOcc where
684 ppr (ScrutOcc xs) = ptext (sLit "scrut-occ") <> ppr xs
685 ppr UnkOcc = ptext (sLit "unk-occ")
686 ppr BothOcc = ptext (sLit "both-occ")
687 ppr NoOcc = ptext (sLit "no-occ")
689 -- Experimentally, this vesion of combineOcc makes ScrutOcc "win", so
690 -- that if the thing is scrutinised anywhere then we get to see that
691 -- in the overall result, even if it's also used in a boxed way
692 -- This might be too agressive; see Note [Reboxing] Alternative 3
693 combineOcc :: ArgOcc -> ArgOcc -> ArgOcc
694 combineOcc NoOcc occ = occ
695 combineOcc occ NoOcc = occ
696 combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys)
697 combineOcc _occ (ScrutOcc ys) = ScrutOcc ys
698 combineOcc (ScrutOcc xs) _occ = ScrutOcc xs
699 combineOcc UnkOcc UnkOcc = UnkOcc
700 combineOcc _ _ = BothOcc
702 combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]
703 combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys
705 setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage
706 -- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee
707 -- is a variable, and an interesting variable
708 setScrutOcc env usg (Cast e _) occ = setScrutOcc env usg e occ
709 setScrutOcc env usg (Note _ e) occ = setScrutOcc env usg e occ
710 setScrutOcc env usg (Var v) occ
711 | Just RecArg <- lookupHowBound env v = usg { scu_occs = extendVarEnv (scu_occs usg) v occ }
713 setScrutOcc _env usg _other _occ -- Catch-all
716 conArgOccs :: ArgOcc -> AltCon -> [ArgOcc]
717 -- Find usage of components of data con; returns [UnkOcc...] if unknown
718 -- See Note [ScrutOcc] for the extra UnkOccs in the vanilla datacon case
720 conArgOccs (ScrutOcc fm) (DataAlt dc)
721 | Just pat_arg_occs <- lookupUFM fm dc
722 = [UnkOcc | _ <- dataConUnivTyVars dc] ++ pat_arg_occs
724 conArgOccs _other _con = repeat UnkOcc
727 %************************************************************************
729 \subsection{The main recursive function}
731 %************************************************************************
733 The main recursive function gathers up usage information, and
734 creates specialised versions of functions.
737 scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
738 -- The unique supply is needed when we invent
739 -- a new name for the specialised function and its args
741 scExpr env e = scExpr' env e
744 scExpr' env (Var v) = case scSubstId env v of
745 Var v' -> return (varUsage env v' UnkOcc, Var v')
746 e' -> scExpr (zapScSubst env) e'
748 scExpr' env (Type t) = return (nullUsage, Type (scSubstTy env t))
749 scExpr' _ e@(Lit {}) = return (nullUsage, e)
750 scExpr' env (Note n e) = do (usg,e') <- scExpr env e
751 return (usg, Note n e')
752 scExpr' env (Cast e co) = do (usg, e') <- scExpr env e
753 return (usg, Cast e' (scSubstTy env co))
754 scExpr' env e@(App _ _) = scApp env (collectArgs e)
755 scExpr' env (Lam b e) = do let (env', b') = extendBndr env b
756 (usg, e') <- scExpr env' e
757 return (usg, Lam b' e')
759 scExpr' env (Case scrut b ty alts)
760 = do { (scrut_usg, scrut') <- scExpr env scrut
761 ; case isValue (sc_vals env) scrut' of
762 Just (ConVal con args) -> sc_con_app con args scrut'
763 _other -> sc_vanilla scrut_usg scrut'
766 sc_con_app con args scrut' -- Known constructor; simplify
767 = do { let (_, bs, rhs) = findAlt con alts
768 alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)
769 ; scExpr alt_env' rhs }
771 sc_vanilla scrut_usg scrut' -- Normal case
772 = do { let (alt_env,b') = extendBndrWith RecArg env b
773 -- Record RecArg for the components
775 ; (alt_usgs, alt_occs, alts')
776 <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts
778 ; let (alt_usg, b_occ) = lookupOcc (combineUsages alt_usgs) b'
779 scrut_occ = foldr combineOcc b_occ alt_occs
780 scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ
781 -- The combined usage of the scrutinee is given
782 -- by scrut_occ, which is passed to scScrut, which
783 -- in turn treats a bare-variable scrutinee specially
785 ; return (alt_usg `combineUsage` scrut_usg',
786 Case scrut' b' (scSubstTy env ty) alts') }
788 sc_alt env _scrut' b' (con,bs,rhs)
789 = do { let (env1, bs1) = extendBndrsWith RecArg env bs
790 (env2, bs2) = extendCaseBndrs env1 b' con bs1
791 ; (usg,rhs') <- scExpr env2 rhs
792 ; let (usg', arg_occs) = lookupOccs usg bs2
793 scrut_occ = case con of
794 DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)
795 _ -> ScrutOcc emptyUFM
796 ; return (usg', scrut_occ, (con, bs2, rhs')) }
798 scExpr' env (Let (NonRec bndr rhs) body)
799 | isTyVar bndr -- Type-lets may be created by doBeta
800 = scExpr' (extendScSubst env bndr rhs) body
802 = do { let (body_env, bndr') = extendBndr env bndr
803 ; (rhs_usg, (_, args', rhs_body', _)) <- scRecRhs env (bndr',rhs)
804 ; let rhs' = mkLams args' rhs_body'
806 ; if not opt_SpecInlineJoinPoints || null args' || isEmptyVarEnv (scu_calls rhs_usg) then do
808 let body_env2 = extendValEnv body_env bndr' (isValue (sc_vals env) rhs')
809 -- Record if the RHS is a value
810 ; (body_usg, body') <- scExpr body_env2 body
811 ; return (body_usg `combineUsage` rhs_usg, Let (NonRec bndr' rhs') body') }
812 else -- For now, just brutally inline the join point
813 do { let body_env2 = extendScSubst env bndr rhs'
814 ; scExpr body_env2 body } }
818 do { -- Join-point case
819 let body_env2 = extendHowBound body_env [bndr'] RecFun
820 -- If the RHS of this 'let' contains calls
821 -- to recursive functions that we're trying
822 -- to specialise, then treat this let too
823 -- as one to specialise
824 ; (body_usg, body') <- scExpr body_env2 body
826 ; (spec_usg, _, specs) <- specialise env (scu_calls body_usg) ([], rhs_info)
828 ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' }
829 `combineUsage` rhs_usg `combineUsage` spec_usg,
830 mkLets [NonRec b r | (b,r) <- specInfoBinds rhs_info specs] body')
834 -- A *local* recursive group: see Note [Local recursive groups]
835 scExpr' env (Let (Rec prs) body)
836 = do { let (bndrs,rhss) = unzip prs
837 (rhs_env1,bndrs') = extendRecBndrs env bndrs
838 rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
840 ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
841 ; (body_usg, body') <- scExpr rhs_env2 body
843 -- NB: start specLoop from body_usg
844 ; (spec_usg, specs) <- specLoop rhs_env2 (scu_calls body_usg) rhs_infos nullUsage
845 [SI [] 0 (Just usg) | usg <- rhs_usgs]
847 ; let all_usg = spec_usg `combineUsage` body_usg
848 bind' = Rec (concat (zipWith specInfoBinds rhs_infos specs))
850 ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' },
853 -----------------------------------
854 scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)
856 scApp env (Var fn, args) -- Function is a variable
857 = ASSERT( not (null args) )
858 do { args_w_usgs <- mapM (scExpr env) args
859 ; let (arg_usgs, args') = unzip args_w_usgs
860 arg_usg = combineUsages arg_usgs
861 ; case scSubstId env fn of
862 fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args')
863 -- Do beta-reduction and try again
865 Var fn' -> return (arg_usg `combineUsage` fn_usg, mkApps (Var fn') args')
867 fn_usg = case lookupHowBound env fn' of
868 Just RecFun -> SCU { scu_calls = unitVarEnv fn' [(sc_vals env, args')],
869 scu_occs = emptyVarEnv }
870 Just RecArg -> SCU { scu_calls = emptyVarEnv,
871 scu_occs = unitVarEnv fn' (ScrutOcc emptyUFM) }
875 other_fn' -> return (arg_usg, mkApps other_fn' args') }
876 -- NB: doing this ignores any usage info from the substituted
877 -- function, but I don't think that matters. If it does
880 doBeta :: OutExpr -> [OutExpr] -> OutExpr
881 -- ToDo: adjust for System IF
882 doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args)
883 doBeta fn args = mkApps fn args
885 -- The function is almost always a variable, but not always.
886 -- In particular, if this pass follows float-in,
887 -- which it may, we can get
888 -- (let f = ...f... in f) arg1 arg2
889 scApp env (other_fn, args)
890 = do { (fn_usg, fn') <- scExpr env other_fn
891 ; (arg_usgs, args') <- mapAndUnzipM (scExpr env) args
892 ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') }
894 ----------------------
895 scTopBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind)
896 scTopBind env (Rec prs)
897 | Just threshold <- sc_size env
898 , not (all (couldBeSmallEnoughToInline threshold) rhss)
900 = do { let (rhs_env,bndrs') = extendRecBndrs env bndrs
901 ; (_, rhss') <- mapAndUnzipM (scExpr rhs_env) rhss
902 ; return (rhs_env, Rec (bndrs' `zip` rhss')) }
903 | otherwise -- Do specialisation
904 = do { let (rhs_env1,bndrs') = extendRecBndrs env bndrs
905 rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
907 ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
908 ; let rhs_usg = combineUsages rhs_usgs
910 ; (_, specs) <- specLoop rhs_env2 (scu_calls rhs_usg) rhs_infos nullUsage
911 [SI [] 0 Nothing | _ <- bndrs]
913 ; return (rhs_env1, -- For the body of the letrec, delete the RecFun business
914 Rec (concat (zipWith specInfoBinds rhs_infos specs))) }
916 (bndrs,rhss) = unzip prs
918 scTopBind env (NonRec bndr rhs)
919 = do { (_, rhs') <- scExpr env rhs
920 ; let (env1, bndr') = extendBndr env bndr
921 env2 = extendValEnv env1 bndr' (isValue (sc_vals env) rhs')
922 ; return (env2, NonRec bndr' rhs') }
924 ----------------------
925 scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM (ScUsage, RhsInfo)
926 scRecRhs env (bndr,rhs)
927 = do { let (arg_bndrs,body) = collectBinders rhs
928 (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs
929 ; (body_usg, body') <- scExpr body_env body
930 ; let (rhs_usg, arg_occs) = lookupOccs body_usg arg_bndrs'
931 ; return (rhs_usg, (bndr, arg_bndrs', body', arg_occs)) }
933 -- The arg_occs says how the visible,
934 -- lambda-bound binders of the RHS are used
935 -- (including the TyVar binders)
936 -- Two pats are the same if they match both ways
938 ----------------------
939 specInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)]
940 specInfoBinds (fn, args, body, _) (SI specs _ _)
941 = [(id,rhs) | OS _ _ id rhs <- specs] ++
942 [(fn `addIdSpecialisations` rules, mkLams args body)]
944 rules = [r | OS _ r _ _ <- specs]
946 ----------------------
947 varUsage :: ScEnv -> OutVar -> ArgOcc -> ScUsage
949 | Just RecArg <- lookupHowBound env v = SCU { scu_calls = emptyVarEnv
950 , scu_occs = unitVarEnv v use }
951 | otherwise = nullUsage
955 %************************************************************************
957 The specialiser itself
959 %************************************************************************
962 type RhsInfo = (OutId, [OutVar], OutExpr, [ArgOcc])
963 -- Info about the *original* RHS of a binding we are specialising
964 -- Original binding f = \xs.body
965 -- Plus info about usage of arguments
967 data SpecInfo = SI [OneSpec] -- The specialisations we have generated
968 Int -- Length of specs; used for numbering them
969 (Maybe ScUsage) -- Nothing => we have generated specialisations
970 -- from calls in the *original* RHS
971 -- Just cs => we haven't, and this is the usage
972 -- of the original RHS
974 -- One specialisation: Rule plus definition
975 data OneSpec = OS CallPat -- Call pattern that generated this specialisation
976 CoreRule -- Rule connecting original id with the specialisation
977 OutId OutExpr -- Spec id + its rhs
983 -> ScUsage -> [SpecInfo] -- One per binder; acccumulating parameter
984 -> UniqSM (ScUsage, [SpecInfo]) -- ...ditto...
985 specLoop env all_calls rhs_infos usg_so_far specs_so_far
986 = do { specs_w_usg <- zipWithM (specialise env all_calls) rhs_infos specs_so_far
987 ; let (new_usg_s, all_specs) = unzip specs_w_usg
988 new_usg = combineUsages new_usg_s
989 new_calls = scu_calls new_usg
990 all_usg = usg_so_far `combineUsage` new_usg
991 ; if isEmptyVarEnv new_calls then
992 return (all_usg, all_specs)
994 specLoop env new_calls rhs_infos all_usg all_specs }
998 -> CallEnv -- Info on calls
1000 -> SpecInfo -- Original RHS plus patterns dealt with
1001 -> UniqSM (ScUsage, SpecInfo) -- New specialised versions and their usage
1003 -- Note: the rhs here is the optimised version of the original rhs
1004 -- So when we make a specialised copy of the RHS, we're starting
1005 -- from an RHS whose nested functions have been optimised already.
1007 specialise env bind_calls (fn, arg_bndrs, body, arg_occs)
1008 spec_info@(SI specs spec_count mb_unspec)
1009 | notNull arg_bndrs, -- Only specialise functions
1010 Just all_calls <- lookupVarEnv bind_calls fn
1011 = do { (boring_call, pats) <- callsToPats env specs arg_occs all_calls
1012 -- ; pprTrace "specialise" (vcat [ppr fn <+> ppr arg_occs,
1013 -- text "calls" <+> ppr all_calls,
1014 -- text "good pats" <+> ppr pats]) $
1017 -- Bale out if too many specialisations
1018 -- Rather a hacky way to do so, but it'll do for now
1019 ; let spec_count' = length pats + spec_count
1020 ; case sc_count env of
1021 Just max | spec_count' > max
1022 -> WARN( True, msg ) return (nullUsage, spec_info)
1024 msg = vcat [ sep [ ptext (sLit "SpecConstr: specialisation of") <+> quotes (ppr fn)
1025 , nest 2 (ptext (sLit "limited by bound of")) <+> int max ]
1026 , ptext (sLit "Use -fspec-constr-count=n to set the bound")
1028 extra | not opt_PprStyle_Debug = ptext (sLit "Use -dppr-debug to see specialisations")
1029 | otherwise = ptext (sLit "Specialisations:") <+> ppr (pats ++ [p | OS p _ _ _ <- specs])
1031 _normal_case -> do {
1033 (spec_usgs, new_specs) <- mapAndUnzipM (spec_one env fn arg_bndrs body)
1034 (pats `zip` [spec_count..])
1036 ; let spec_usg = combineUsages spec_usgs
1037 (new_usg, mb_unspec')
1039 Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing)
1040 _ -> (spec_usg, mb_unspec)
1042 ; return (new_usg, SI (new_specs ++ specs) spec_count' mb_unspec') } }
1044 = return (nullUsage, spec_info) -- The boring case
1047 ---------------------
1049 -> OutId -- Function
1050 -> [Var] -- Lambda-binders of RHS; should match patterns
1051 -> CoreExpr -- Body of the original function
1053 -> UniqSM (ScUsage, OneSpec) -- Rule and binding
1055 -- spec_one creates a specialised copy of the function, together
1056 -- with a rule for using it. I'm very proud of how short this
1057 -- function is, considering what it does :-).
1063 f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
1064 [c::*, v::(b,c) are presumably bound by the (...) part]
1066 f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
1067 (...entire body of f...) [b -> (b,c),
1068 y -> ((:) (a,(b,c)) (x,v) hw)]
1070 RULE: forall b::* c::*, -- Note, *not* forall a, x
1074 f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
1077 spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)
1078 = do { -- Specialise the body
1079 let spec_env = extendScSubstList (extendScInScope env qvars)
1080 (arg_bndrs `zip` pats)
1081 ; (spec_usg, spec_body) <- scExpr spec_env body
1083 -- ; pprTrace "spec_one" (ppr fn <+> vcat [text "pats" <+> ppr pats,
1084 -- text "calls" <+> (ppr (scu_calls spec_usg))])
1087 -- And build the results
1088 ; spec_uniq <- getUniqueUs
1089 ; let (spec_lam_args, spec_call_args) = mkWorkerArgs qvars body_ty
1090 -- Usual w/w hack to avoid generating
1091 -- a spec_rhs of unlifted type and no args
1094 fn_loc = nameSrcSpan fn_name
1095 spec_occ = mkSpecOcc (nameOccName fn_name)
1096 rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number))
1097 spec_rhs = mkLams spec_lam_args spec_body
1098 spec_id = mkUserLocal spec_occ spec_uniq (mkPiTypes spec_lam_args body_ty) fn_loc
1099 body_ty = exprType spec_body
1100 rule_rhs = mkVarApps (Var spec_id) spec_call_args
1101 rule = mkLocalRule rule_name specConstrActivation fn_name qvars pats rule_rhs
1102 ; return (spec_usg, OS call_pat rule spec_id spec_rhs) }
1104 -- In which phase should the specialise-constructor rules be active?
1105 -- Originally I made them always-active, but Manuel found that
1106 -- this defeated some clever user-written rules. So Plan B
1107 -- is to make them active only in Phase 0; after all, currently,
1108 -- the specConstr transformation is only run after the simplifier
1109 -- has reached Phase 0. In general one would want it to be
1110 -- flag-controllable, but for now I'm leaving it baked in
1112 specConstrActivation :: Activation
1113 specConstrActivation = ActiveAfter 0 -- Baked in; see comments above
1116 %************************************************************************
1118 \subsection{Argument analysis}
1120 %************************************************************************
1122 This code deals with analysing call-site arguments to see whether
1123 they are constructor applications.
1127 type CallPat = ([Var], [CoreExpr]) -- Quantified variables and arguments
1130 callsToPats :: ScEnv -> [OneSpec] -> [ArgOcc] -> [Call] -> UniqSM (Bool, [CallPat])
1131 -- Result has no duplicate patterns,
1132 -- nor ones mentioned in done_pats
1133 -- Bool indicates that there was at least one boring pattern
1134 callsToPats env done_specs bndr_occs calls
1135 = do { mb_pats <- mapM (callToPats env bndr_occs) calls
1137 ; let good_pats :: [([Var], [CoreArg])]
1138 good_pats = catMaybes mb_pats
1139 done_pats = [p | OS p _ _ _ <- done_specs]
1140 is_done p = any (samePat p) done_pats
1142 ; return (any isNothing mb_pats,
1143 filterOut is_done (nubBy samePat good_pats)) }
1145 callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
1146 -- The [Var] is the variables to quantify over in the rule
1147 -- Type variables come first, since they may scope
1148 -- over the following term variables
1149 -- The [CoreExpr] are the argument patterns for the rule
1150 callToPats env bndr_occs (con_env, args)
1151 | length args < length bndr_occs -- Check saturated
1154 = do { let in_scope = substInScope (sc_subst env)
1155 ; prs <- argsToPats in_scope con_env (args `zip` bndr_occs)
1156 ; let (interesting_s, pats) = unzip prs
1157 pat_fvs = varSetElems (exprsFreeVars pats)
1158 qvars = filterOut (`elemInScopeSet` in_scope) pat_fvs
1159 -- Quantify over variables that are not in sccpe
1161 -- See Note [Shadowing] at the top
1163 (tvs, ids) = partition isTyVar qvars
1165 -- Put the type variables first; the type of a term
1166 -- variable may mention a type variable
1168 ; -- pprTrace "callToPats" (ppr args $$ ppr prs $$ ppr bndr_occs) $
1170 then return (Just (qvars', pats))
1171 else return Nothing }
1173 -- argToPat takes an actual argument, and returns an abstracted
1174 -- version, consisting of just the "constructor skeleton" of the
1175 -- argument, with non-constructor sub-expression replaced by new
1176 -- placeholder variables. For example:
1177 -- C a (D (f x) (g y)) ==> C p1 (D p2 p3)
1179 argToPat :: InScopeSet -- What's in scope at the fn defn site
1180 -> ValueEnv -- ValueEnv at the call site
1181 -> CoreArg -- A call arg (or component thereof)
1183 -> UniqSM (Bool, CoreArg)
1184 -- Returns (interesting, pat),
1185 -- where pat is the pattern derived from the argument
1186 -- intersting=True if the pattern is non-trivial (not a variable or type)
1187 -- E.g. x:xs --> (True, x:xs)
1188 -- f xs --> (False, w) where w is a fresh wildcard
1189 -- (f xs, 'c') --> (True, (w, 'c')) where w is a fresh wildcard
1190 -- \x. x+y --> (True, \x. x+y)
1191 -- lvl7 --> (True, lvl7) if lvl7 is bound
1192 -- somewhere further out
1194 argToPat _in_scope _val_env arg@(Type {}) _arg_occ
1195 = return (False, arg)
1197 argToPat in_scope val_env (Note _ arg) arg_occ
1198 = argToPat in_scope val_env arg arg_occ
1199 -- Note [Notes in call patterns]
1200 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1201 -- Ignore Notes. In particular, we want to ignore any InlineMe notes
1202 -- Perhaps we should not ignore profiling notes, but I'm going to
1203 -- ride roughshod over them all for now.
1204 --- See Note [Notes in RULE matching] in Rules
1206 argToPat in_scope val_env (Let _ arg) arg_occ
1207 = argToPat in_scope val_env arg arg_occ
1208 -- Look through let expressions
1209 -- e.g. f (let v = rhs in \y -> ...v...)
1210 -- Here we can specialise for f (\y -> ...)
1211 -- because the rule-matcher will look through the let.
1213 argToPat in_scope val_env (Cast arg co) arg_occ
1214 = do { (interesting, arg') <- argToPat in_scope val_env arg arg_occ
1215 ; let (ty1,ty2) = coercionKind co
1216 ; if not interesting then
1219 { -- Make a wild-card pattern for the coercion
1221 ; let co_name = mkSysTvName uniq (fsLit "sg")
1222 co_var = mkCoVar co_name (mkCoKind ty1 ty2)
1223 ; return (interesting, Cast arg' (mkTyVarTy co_var)) } }
1225 {- Disabling lambda specialisation for now
1226 It's fragile, and the spec_loop can be infinite
1227 argToPat in_scope val_env arg arg_occ
1229 = return (True, arg)
1231 is_value_lam (Lam v e) -- Spot a value lambda, even if
1232 | isId v = True -- it is inside a type lambda
1233 | otherwise = is_value_lam e
1234 is_value_lam other = False
1237 -- Check for a constructor application
1238 -- NB: this *precedes* the Var case, so that we catch nullary constrs
1239 argToPat in_scope val_env arg arg_occ
1240 | Just (ConVal dc args) <- isValue val_env arg
1242 ScrutOcc _ -> True -- Used only by case scrutinee
1243 BothOcc -> case arg of -- Used elsewhere
1244 App {} -> True -- see Note [Reboxing]
1246 _other -> False -- No point; the arg is not decomposed
1247 = do { args' <- argsToPats in_scope val_env (args `zip` conArgOccs arg_occ dc)
1248 ; return (True, mk_con_app dc (map snd args')) }
1250 -- Check if the argument is a variable that
1251 -- is in scope at the function definition site
1252 -- It's worth specialising on this if
1253 -- (a) it's used in an interesting way in the body
1254 -- (b) we know what its value is
1255 argToPat in_scope val_env (Var v) arg_occ
1256 | case arg_occ of { UnkOcc -> False; _other -> True }, -- (a)
1258 = return (True, Var v)
1261 | isLocalId v = v `elemInScopeSet` in_scope
1262 && isJust (lookupVarEnv val_env v)
1263 -- Local variables have values in val_env
1264 | otherwise = isValueUnfolding (idUnfolding v)
1265 -- Imports have unfoldings
1267 -- I'm really not sure what this comment means
1268 -- And by not wild-carding we tend to get forall'd
1269 -- variables that are in soope, which in turn can
1270 -- expose the weakness in let-matching
1271 -- See Note [Matching lets] in Rules
1273 -- Check for a variable bound inside the function.
1274 -- Don't make a wild-card, because we may usefully share
1275 -- e.g. f a = let x = ... in f (x,x)
1276 -- NB: this case follows the lambda and con-app cases!!
1277 -- argToPat _in_scope _val_env (Var v) _arg_occ
1278 -- = return (False, Var v)
1279 -- SLPJ : disabling this to avoid proliferation of versions
1280 -- also works badly when thinking about seeding the loop
1281 -- from the body of the let
1282 -- f x y = letrec g z = ... in g (x,y)
1283 -- We don't want to specialise for that *particular* x,y
1285 -- The default case: make a wild-card
1286 argToPat _in_scope _val_env arg _arg_occ
1287 = wildCardPat (exprType arg)
1289 wildCardPat :: Type -> UniqSM (Bool, CoreArg)
1290 wildCardPat ty = do { uniq <- getUniqueUs
1291 ; let id = mkSysLocal (fsLit "sc") uniq ty
1292 ; return (False, Var id) }
1294 argsToPats :: InScopeSet -> ValueEnv
1295 -> [(CoreArg, ArgOcc)]
1296 -> UniqSM [(Bool, CoreArg)]
1297 argsToPats in_scope val_env args
1300 do_one (arg,occ) = argToPat in_scope val_env arg occ
1305 isValue :: ValueEnv -> CoreExpr -> Maybe Value
1306 isValue _env (Lit lit)
1307 = Just (ConVal (LitAlt lit) [])
1310 | Just stuff <- lookupVarEnv env v
1311 = Just stuff -- You might think we could look in the idUnfolding here
1312 -- but that doesn't take account of which branch of a
1313 -- case we are in, which is the whole point
1315 | not (isLocalId v) && isCheapUnfolding unf
1316 = isValue env (unfoldingTemplate unf)
1319 -- However we do want to consult the unfolding
1320 -- as well, for let-bound constructors!
1322 isValue env (Lam b e)
1323 | isTyVar b = case isValue env e of
1324 Just _ -> Just LambdaVal
1326 | otherwise = Just LambdaVal
1328 isValue _env expr -- Maybe it's a constructor application
1329 | (Var fun, args) <- collectArgs expr
1330 = case isDataConWorkId_maybe fun of
1332 Just con | args `lengthAtLeast` dataConRepArity con
1333 -- Check saturated; might be > because the
1334 -- arity excludes type args
1335 -> Just (ConVal (DataAlt con) args)
1337 _other | valArgCount args < idArity fun
1338 -- Under-applied function
1339 -> Just LambdaVal -- Partial application
1343 isValue _env _expr = Nothing
1345 mk_con_app :: AltCon -> [CoreArg] -> CoreExpr
1346 mk_con_app (LitAlt lit) [] = Lit lit
1347 mk_con_app (DataAlt con) args = mkConApp con args
1348 mk_con_app _other _args = panic "SpecConstr.mk_con_app"
1350 samePat :: CallPat -> CallPat -> Bool
1351 samePat (vs1, as1) (vs2, as2)
1354 same (Var v1) (Var v2)
1355 | v1 `elem` vs1 = v2 `elem` vs2
1356 | v2 `elem` vs2 = False
1357 | otherwise = v1 == v2
1359 same (Lit l1) (Lit l2) = l1==l2
1360 same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2
1362 same (Type {}) (Type {}) = True -- Note [Ignore type differences]
1363 same (Note _ e1) e2 = same e1 e2 -- Ignore casts and notes
1364 same (Cast e1 _) e2 = same e1 e2
1365 same e1 (Note _ e2) = same e1 e2
1366 same e1 (Cast e2 _) = same e1 e2
1368 same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2)
1369 False -- Let, lambda, case should not occur
1370 bad (Case {}) = True
1376 Note [Ignore type differences]
1377 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1378 We do not want to generate specialisations where the call patterns
1379 differ only in their type arguments! Not only is it utterly useless,
1380 but it also means that (with polymorphic recursion) we can generate
1381 an infinite number of specialisations. Example is Data.Sequence.adjustTree,