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, isNothing )
45 import List ( nubBy, partition )
51 import Control.Monad ( zipWithM )
54 -----------------------------------------------------
56 -----------------------------------------------------
61 drop n (x:xs) = drop (n-1) xs
63 After the first time round, we could pass n unboxed. This happens in
64 numerical code too. Here's what it looks like in Core:
66 drop n xs = case xs of
71 _ -> drop (I# (n# -# 1#)) xs
73 Notice that the recursive call has an explicit constructor as argument.
74 Noticing this, we can make a specialised version of drop
76 RULE: drop (I# n#) xs ==> drop' n# xs
78 drop' n# xs = let n = I# n# in ...orig RHS...
80 Now the simplifier will apply the specialisation in the rhs of drop', giving
82 drop' n# xs = case xs of
86 _ -> drop (n# -# 1#) xs
90 We'd also like to catch cases where a parameter is carried along unchanged,
91 but evaluated each time round the loop:
93 f i n = if i>0 || i>n then i else f (i*2) n
95 Here f isn't strict in n, but we'd like to avoid evaluating it each iteration.
96 In Core, by the time we've w/wd (f is strict in i) we get
98 f i# n = case i# ># 0 of
100 True -> case n of n' { I# n# ->
103 True -> f (i# *# 2#) n'
105 At the call to f, we see that the argument, n is know to be (I# n#),
106 and n is evaluated elsewhere in the body of f, so we can play the same
112 We must be careful not to allocate the same constructor twice. Consider
113 f p = (...(case p of (a,b) -> e)...p...,
114 ...let t = (r,s) in ...t...(f t)...)
115 At the recursive call to f, we can see that t is a pair. But we do NOT want
116 to make a specialised copy:
117 f' a b = let p = (a,b) in (..., ...)
118 because now t is allocated by the caller, then r and s are passed to the
119 recursive call, which allocates the (r,s) pair again.
122 (a) the argument p is used in other than a case-scrutinsation way.
123 (b) the argument to the call is not a 'fresh' tuple; you have to
124 look into its unfolding to see that it's a tuple
126 Hence the "OR" part of Note [Good arguments] below.
128 ALTERNATIVE 2: pass both boxed and unboxed versions. This no longer saves
129 allocation, but does perhaps save evals. In the RULE we'd have
132 f (I# x#) = f' (I# x#) x#
134 If at the call site the (I# x) was an unfolding, then we'd have to
135 rely on CSE to eliminate the duplicate allocation.... This alternative
136 doesn't look attractive enough to pursue.
138 ALTERNATIVE 3: ignore the reboxing problem. The trouble is that
139 the conservative reboxing story prevents many useful functions from being
140 specialised. Example:
141 foo :: Maybe Int -> Int -> Int
143 foo x@(Just m) n = foo x (n-m)
144 Here the use of 'x' will clearly not require boxing in the specialised function.
146 The strictness analyser has the same problem, in fact. Example:
148 If we pass just 'a' and 'b' to the worker, it might need to rebox the
149 pair to create (a,b). A more sophisticated analysis might figure out
150 precisely the cases in which this could happen, but the strictness
151 analyser does no such analysis; it just passes 'a' and 'b', and hopes
154 So my current choice is to make SpecConstr similarly aggressive, and
155 ignore the bad potential of reboxing.
158 Note [Good arguments]
159 ~~~~~~~~~~~~~~~~~~~~~
162 * A self-recursive function. Ignore mutual recursion for now,
163 because it's less common, and the code is simpler for self-recursion.
167 a) At a recursive call, one or more parameters is an explicit
168 constructor application
170 That same parameter is scrutinised by a case somewhere in
171 the RHS of the function
175 b) At a recursive call, one or more parameters has an unfolding
176 that is an explicit constructor application
178 That same parameter is scrutinised by a case somewhere in
179 the RHS of the function
181 Those are the only uses of the parameter (see Note [Reboxing])
184 What to abstract over
185 ~~~~~~~~~~~~~~~~~~~~~
186 There's a bit of a complication with type arguments. If the call
189 f p = ...f ((:) [a] x xs)...
191 then our specialised function look like
193 f_spec x xs = let p = (:) [a] x xs in ....as before....
195 This only makes sense if either
196 a) the type variable 'a' is in scope at the top of f, or
197 b) the type variable 'a' is an argument to f (and hence fs)
199 Actually, (a) may hold for value arguments too, in which case
200 we may not want to pass them. Supose 'x' is in scope at f's
201 defn, but xs is not. Then we'd like
203 f_spec xs = let p = (:) [a] x xs in ....as before....
205 Similarly (b) may hold too. If x is already an argument at the
206 call, no need to pass it again.
208 Finally, if 'a' is not in scope at the call site, we could abstract
209 it as we do the term variables:
211 f_spec a x xs = let p = (:) [a] x xs in ...as before...
213 So the grand plan is:
215 * abstract the call site to a constructor-only pattern
216 e.g. C x (D (f p) (g q)) ==> C s1 (D s2 s3)
218 * Find the free variables of the abstracted pattern
220 * Pass these variables, less any that are in scope at
221 the fn defn. But see Note [Shadowing] below.
224 NOTICE that we only abstract over variables that are not in scope,
225 so we're in no danger of shadowing variables used in "higher up"
231 In this pass we gather up usage information that may mention variables
232 that are bound between the usage site and the definition site; or (more
233 seriously) may be bound to something different at the definition site.
236 f x = letrec g y v = let x = ...
239 Since 'x' is in scope at the call site, we may make a rewrite rule that
241 RULE forall a,b. g (a,b) x = ...
242 But this rule will never match, because it's really a different 'x' at
243 the call site -- and that difference will be manifest by the time the
244 simplifier gets to it. [A worry: the simplifier doesn't *guarantee*
245 no-shadowing, so perhaps it may not be distinct?]
247 Anyway, the rule isn't actually wrong, it's just not useful. One possibility
248 is to run deShadowBinds before running SpecConstr, but instead we run the
249 simplifier. That gives the simplest possible program for SpecConstr to
250 chew on; and it virtually guarantees no shadowing.
252 Note [Specialising for constant parameters]
253 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
254 This one is about specialising on a *constant* (but not necessarily
255 constructor) argument
257 foo :: Int -> (Int -> Int) -> Int
259 foo m f = foo (f m) (+1)
263 lvl_rmV :: GHC.Base.Int -> GHC.Base.Int
265 \ (ds_dlk :: GHC.Base.Int) ->
266 case ds_dlk of wild_alH { GHC.Base.I# x_alG ->
267 GHC.Base.I# (GHC.Prim.+# x_alG 1)
269 T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
272 \ (ww_sme :: GHC.Prim.Int#) (w_smg :: GHC.Base.Int -> GHC.Base.Int) ->
273 case ww_sme of ds_Xlw {
275 case w_smg (GHC.Base.I# ds_Xlw) of w1_Xmo { GHC.Base.I# ww1_Xmz ->
276 T.$wfoo ww1_Xmz lvl_rmV
281 The recursive call has lvl_rmV as its argument, so we could create a specialised copy
282 with that argument baked in; that is, not passed at all. Now it can perhaps be inlined.
284 When is this worth it? Call the constant 'lvl'
285 - If 'lvl' has an unfolding that is a constructor, see if the corresponding
286 parameter is scrutinised anywhere in the body.
288 - If 'lvl' has an unfolding that is a inlinable function, see if the corresponding
289 parameter is applied (...to enough arguments...?)
291 Also do this is if the function has RULES?
295 Note [Specialising for lambda parameters]
296 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
297 foo :: Int -> (Int -> Int) -> Int
299 foo m f = foo (f m) (\n -> n-m)
301 This is subtly different from the previous one in that we get an
302 explicit lambda as the argument:
304 T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
307 \ (ww_sm8 :: GHC.Prim.Int#) (w_sma :: GHC.Base.Int -> GHC.Base.Int) ->
308 case ww_sm8 of ds_Xlr {
310 case w_sma (GHC.Base.I# ds_Xlr) of w1_Xmf { GHC.Base.I# ww1_Xmq ->
313 (\ (n_ad3 :: GHC.Base.Int) ->
314 case n_ad3 of wild_alB { GHC.Base.I# x_alA ->
315 GHC.Base.I# (GHC.Prim.-# x_alA ds_Xlr)
321 I wonder if SpecConstr couldn't be extended to handle this? After all,
322 lambda is a sort of constructor for functions and perhaps it already
323 has most of the necessary machinery?
325 Furthermore, there's an immediate win, because you don't need to allocate the lamda
326 at the call site; and if perchance it's called in the recursive call, then you
327 may avoid allocating it altogether. Just like for constructors.
329 Looks cool, but probably rare...but it might be easy to implement.
332 Note [SpecConstr for casts]
333 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
336 data instance T Int = T Int
341 go (T n) = go (T (n-1))
343 The recursive call ends up looking like
344 go (T (I# ...) `cast` g)
345 So we want to spot the construtor application inside the cast.
346 That's why we have the Cast case in argToPat
348 Note [Local recursive groups]
349 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
350 For a *local* recursive group, we can see all the calls to the
351 function, so we seed the specialisation loop from the calls in the
352 body, not from the calls in the RHS. Consider:
354 bar m n = foo n (n,n) (n,n) (n,n) (n,n)
358 | n > 3000 = case p of { (p1,p2) -> foo (n-1) (p2,p1) q r s }
359 | n > 2000 = case q of { (q1,q2) -> foo (n-1) p (q2,q1) r s }
360 | n > 1000 = case r of { (r1,r2) -> foo (n-1) p q (r2,r1) s }
361 | otherwise = case s of { (s1,s2) -> foo (n-1) p q r (s2,s1) }
363 If we start with the RHSs of 'foo', we get lots and lots of specialisations,
364 most of which are not needed. But if we start with the (single) call
365 in the rhs of 'bar' we get exactly one fully-specialised copy, and all
366 the recursive calls go to this fully-specialised copy. Indeed, the original
367 function is later collected as dead code. This is very important in
368 specialising the loops arising from stream fusion, for example in NDP where
369 we were getting literally hundreds of (mostly unused) specialisations of
372 -----------------------------------------------------
373 Stuff not yet handled
374 -----------------------------------------------------
376 Here are notes arising from Roman's work that I don't want to lose.
382 foo :: Int -> T Int -> Int
384 foo x t | even x = case t of { T n -> foo (x-n) t }
385 | otherwise = foo (x-1) t
387 SpecConstr does no specialisation, because the second recursive call
388 looks like a boxed use of the argument. A pity.
390 $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
392 \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) ->
393 case ww_sFo of ds_Xw6 [Just L] {
395 case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] {
396 __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq;
398 case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] ->
399 case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] ->
400 $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy
406 data a :*: b = !a :*: !b
409 foo :: (Int :*: T Int) -> Int
411 foo (x :*: t) | even x = case t of { T n -> foo ((x-n) :*: t) }
412 | otherwise = foo ((x-1) :*: t)
414 Very similar to the previous one, except that the parameters are now in
415 a strict tuple. Before SpecConstr, we have
417 $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
419 \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T
421 case ww_sFU of ds_Xws [Just L] {
423 case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] {
425 case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] ->
426 $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2 -- $wfoo1
429 case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] ->
430 case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] ->
431 $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB -- $wfoo2
435 We get two specialisations:
436 "SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#}
437 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB)
438 = Foo.$s$wfoo1 a_sFB sc_sGC ;
439 "SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#}
440 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp))
441 = Foo.$s$wfoo y_aFp sc_sGC ;
443 But perhaps the first one isn't good. After all, we know that tpl_B2 is
444 a T (I# x) really, because T is strict and Int has one constructor. (We can't
445 unbox the strict fields, becuase T is polymorphic!)
449 %************************************************************************
451 \subsection{Top level wrapper stuff}
453 %************************************************************************
456 specConstrProgram :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]
457 specConstrProgram dflags us binds
459 showPass dflags "SpecConstr"
461 let (binds', _) = initUs us (go (initScEnv dflags) binds)
463 endPass dflags "SpecConstr" Opt_D_dump_spec binds'
465 dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
466 (withPprStyle defaultUserStyle $
467 pprRules (tidyRules emptyTidyEnv (rulesOfBinds binds')))
472 go env (bind:binds) = do (env', bind') <- scTopBind env bind
473 binds' <- go env' binds
474 return (bind' : binds')
478 %************************************************************************
480 \subsection{Environment: goes downwards}
482 %************************************************************************
485 data ScEnv = SCE { sc_size :: Maybe Int, -- Size threshold
486 sc_count :: Maybe Int, -- Max # of specialisations for any one fn
488 sc_subst :: Subst, -- Current substitution
489 -- Maps InIds to OutExprs
491 sc_how_bound :: HowBoundEnv,
492 -- Binds interesting non-top-level variables
493 -- Domain is OutVars (*after* applying the substitution)
496 -- Domain is OutIds (*after* applying the substitution)
497 -- Used even for top-level bindings (but not imported ones)
500 ---------------------
501 -- As we go, we apply a substitution (sc_subst) to the current term
502 type InExpr = CoreExpr -- _Before_ applying the subst
504 type OutExpr = CoreExpr -- _After_ applying the subst
508 ---------------------
509 type HowBoundEnv = VarEnv HowBound -- Domain is OutVars
511 ---------------------
512 type ValueEnv = IdEnv Value -- Domain is OutIds
513 data Value = ConVal AltCon [CoreArg] -- _Saturated_ constructors
514 | LambdaVal -- Inlinable lambdas or PAPs
516 instance Outputable Value where
517 ppr (ConVal con args) = ppr con <+> interpp'SP args
518 ppr LambdaVal = ptext (sLit "<Lambda>")
520 ---------------------
521 initScEnv :: DynFlags -> ScEnv
523 = SCE { sc_size = specConstrThreshold dflags,
524 sc_count = specConstrCount dflags,
525 sc_subst = emptySubst,
526 sc_how_bound = emptyVarEnv,
527 sc_vals = emptyVarEnv }
529 data HowBound = RecFun -- These are the recursive functions for which
530 -- we seek interesting call patterns
532 | RecArg -- These are those functions' arguments, or their sub-components;
533 -- we gather occurrence information for these
535 instance Outputable HowBound where
536 ppr RecFun = text "RecFun"
537 ppr RecArg = text "RecArg"
539 lookupHowBound :: ScEnv -> Id -> Maybe HowBound
540 lookupHowBound env id = lookupVarEnv (sc_how_bound env) id
542 scSubstId :: ScEnv -> Id -> CoreExpr
543 scSubstId env v = lookupIdSubst (sc_subst env) v
545 scSubstTy :: ScEnv -> Type -> Type
546 scSubstTy env ty = substTy (sc_subst env) ty
548 zapScSubst :: ScEnv -> ScEnv
549 zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) }
551 extendScInScope :: ScEnv -> [Var] -> ScEnv
552 -- Bring the quantified variables into scope
553 extendScInScope env qvars = env { sc_subst = extendInScopeList (sc_subst env) qvars }
555 -- Extend the substitution
556 extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv
557 extendScSubst env var expr = env { sc_subst = extendSubst (sc_subst env) var expr }
559 extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv
560 extendScSubstList env prs = env { sc_subst = extendSubstList (sc_subst env) prs }
562 extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv
563 extendHowBound env bndrs how_bound
564 = env { sc_how_bound = extendVarEnvList (sc_how_bound env)
565 [(bndr,how_bound) | bndr <- bndrs] }
567 extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var])
568 extendBndrsWith how_bound env bndrs
569 = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndrs')
571 (subst', bndrs') = substBndrs (sc_subst env) bndrs
572 hb_env' = sc_how_bound env `extendVarEnvList`
573 [(bndr,how_bound) | bndr <- bndrs']
575 extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var)
576 extendBndrWith how_bound env bndr
577 = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndr')
579 (subst', bndr') = substBndr (sc_subst env) bndr
580 hb_env' = extendVarEnv (sc_how_bound env) bndr' how_bound
582 extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var])
583 extendRecBndrs env bndrs = (env { sc_subst = subst' }, bndrs')
585 (subst', bndrs') = substRecBndrs (sc_subst env) bndrs
587 extendBndr :: ScEnv -> Var -> (ScEnv, Var)
588 extendBndr env bndr = (env { sc_subst = subst' }, bndr')
590 (subst', bndr') = substBndr (sc_subst env) bndr
592 extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv
593 extendValEnv env _ Nothing = env
594 extendValEnv env id (Just cv) = env { sc_vals = extendVarEnv (sc_vals env) id cv }
596 extendCaseBndrs :: ScEnv -> CoreExpr -> Id -> AltCon -> [Var] -> ScEnv
600 -- we want to bind b, and perhaps scrut too, to (C x y)
601 -- NB: Extends only the sc_vals part of the envt
602 extendCaseBndrs env scrut case_bndr con alt_bndrs
604 Var v -> extendValEnv env1 v cval
607 env1 = extendValEnv env case_bndr cval
610 LitAlt {} -> Just (ConVal con [])
611 DataAlt {} -> Just (ConVal con vanilla_args)
613 vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
614 varsToCoreExprs alt_bndrs
618 %************************************************************************
620 \subsection{Usage information: flows upwards}
622 %************************************************************************
627 scu_calls :: CallEnv, -- Calls
628 -- The functions are a subset of the
629 -- RecFuns in the ScEnv
631 scu_occs :: !(IdEnv ArgOcc) -- Information on argument occurrences
632 } -- The domain is OutIds
634 type CallEnv = IdEnv [Call]
635 type Call = (ValueEnv, [CoreArg])
636 -- The arguments of the call, together with the
637 -- env giving the constructor bindings at the call site
640 nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv }
642 combineCalls :: CallEnv -> CallEnv -> CallEnv
643 combineCalls = plusVarEnv_C (++)
645 combineUsage :: ScUsage -> ScUsage -> ScUsage
646 combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2),
647 scu_occs = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) }
649 combineUsages :: [ScUsage] -> ScUsage
650 combineUsages [] = nullUsage
651 combineUsages us = foldr1 combineUsage us
653 lookupOcc :: ScUsage -> OutVar -> (ScUsage, ArgOcc)
654 lookupOcc (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndr
655 = (SCU {scu_calls = sc_calls, scu_occs = delVarEnv sc_occs bndr},
656 lookupVarEnv sc_occs bndr `orElse` NoOcc)
658 lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc])
659 lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs
660 = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs},
661 [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs])
663 data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument
664 | UnkOcc -- Used in some unknown way
666 | ScrutOcc (UniqFM [ArgOcc]) -- See Note [ScrutOcc]
668 | BothOcc -- Definitely taken apart, *and* perhaps used in some other way
672 An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing,
673 is *only* taken apart or applied.
675 Functions, literal: ScrutOcc emptyUFM
676 Data constructors: ScrutOcc subs,
678 where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components,
679 The domain of the UniqFM is the Unique of the data constructor
681 The [ArgOcc] is the occurrences of the *pattern-bound* components
682 of the data structure. E.g.
683 data T a = forall b. MkT a b (b->a)
684 A pattern binds b, x::a, y::b, z::b->a, but not 'a'!
688 instance Outputable ArgOcc where
689 ppr (ScrutOcc xs) = ptext (sLit "scrut-occ") <> ppr xs
690 ppr UnkOcc = ptext (sLit "unk-occ")
691 ppr BothOcc = ptext (sLit "both-occ")
692 ppr NoOcc = ptext (sLit "no-occ")
694 -- Experimentally, this vesion of combineOcc makes ScrutOcc "win", so
695 -- that if the thing is scrutinised anywhere then we get to see that
696 -- in the overall result, even if it's also used in a boxed way
697 -- This might be too agressive; see Note [Reboxing] Alternative 3
698 combineOcc :: ArgOcc -> ArgOcc -> ArgOcc
699 combineOcc NoOcc occ = occ
700 combineOcc occ NoOcc = occ
701 combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys)
702 combineOcc _occ (ScrutOcc ys) = ScrutOcc ys
703 combineOcc (ScrutOcc xs) _occ = ScrutOcc xs
704 combineOcc UnkOcc UnkOcc = UnkOcc
705 combineOcc _ _ = BothOcc
707 combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]
708 combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys
710 setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage
711 -- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee
712 -- is a variable, and an interesting variable
713 setScrutOcc env usg (Cast e _) occ = setScrutOcc env usg e occ
714 setScrutOcc env usg (Note _ e) occ = setScrutOcc env usg e occ
715 setScrutOcc env usg (Var v) occ
716 | Just RecArg <- lookupHowBound env v = usg { scu_occs = extendVarEnv (scu_occs usg) v occ }
718 setScrutOcc _env usg _other _occ -- Catch-all
721 conArgOccs :: ArgOcc -> AltCon -> [ArgOcc]
722 -- Find usage of components of data con; returns [UnkOcc...] if unknown
723 -- See Note [ScrutOcc] for the extra UnkOccs in the vanilla datacon case
725 conArgOccs (ScrutOcc fm) (DataAlt dc)
726 | Just pat_arg_occs <- lookupUFM fm dc
727 = [UnkOcc | _ <- dataConUnivTyVars dc] ++ pat_arg_occs
729 conArgOccs _other _con = repeat UnkOcc
732 %************************************************************************
734 \subsection{The main recursive function}
736 %************************************************************************
738 The main recursive function gathers up usage information, and
739 creates specialised versions of functions.
742 scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
743 -- The unique supply is needed when we invent
744 -- a new name for the specialised function and its args
746 scExpr env e = scExpr' env e
749 scExpr' env (Var v) = case scSubstId env v of
750 Var v' -> return (varUsage env v' UnkOcc, Var v')
751 e' -> scExpr (zapScSubst env) e'
753 scExpr' env (Type t) = return (nullUsage, Type (scSubstTy env t))
754 scExpr' _ e@(Lit {}) = return (nullUsage, e)
755 scExpr' env (Note n e) = do (usg,e') <- scExpr env e
756 return (usg, Note n e')
757 scExpr' env (Cast e co) = do (usg, e') <- scExpr env e
758 return (usg, Cast e' (scSubstTy env co))
759 scExpr' env e@(App _ _) = scApp env (collectArgs e)
760 scExpr' env (Lam b e) = do let (env', b') = extendBndr env b
761 (usg, e') <- scExpr env' e
762 return (usg, Lam b' e')
764 scExpr' env (Case scrut b ty alts)
765 = do { (scrut_usg, scrut') <- scExpr env scrut
766 ; case isValue (sc_vals env) scrut' of
767 Just (ConVal con args) -> sc_con_app con args scrut'
768 _other -> sc_vanilla scrut_usg scrut'
771 sc_con_app con args scrut' -- Known constructor; simplify
772 = do { let (_, bs, rhs) = findAlt con alts
773 alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)
774 ; scExpr alt_env' rhs }
776 sc_vanilla scrut_usg scrut' -- Normal case
777 = do { let (alt_env,b') = extendBndrWith RecArg env b
778 -- Record RecArg for the components
780 ; (alt_usgs, alt_occs, alts')
781 <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts
783 ; let (alt_usg, b_occ) = lookupOcc (combineUsages alt_usgs) b'
784 scrut_occ = foldr combineOcc b_occ alt_occs
785 scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ
786 -- The combined usage of the scrutinee is given
787 -- by scrut_occ, which is passed to scScrut, which
788 -- in turn treats a bare-variable scrutinee specially
790 ; return (alt_usg `combineUsage` scrut_usg',
791 Case scrut' b' (scSubstTy env ty) alts') }
793 sc_alt env scrut' b' (con,bs,rhs)
794 = do { let (env1, bs') = extendBndrsWith RecArg env bs
795 env2 = extendCaseBndrs env1 scrut' b' con bs'
796 ; (usg,rhs') <- scExpr env2 rhs
797 ; let (usg', arg_occs) = lookupOccs usg bs'
798 scrut_occ = case con of
799 DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)
800 _ -> ScrutOcc emptyUFM
801 ; return (usg', scrut_occ, (con,bs',rhs')) }
803 scExpr' env (Let (NonRec bndr rhs) body)
804 | isTyVar bndr -- Type-lets may be created by doBeta
805 = scExpr' (extendScSubst env bndr rhs) body
807 = do { let (body_env, bndr') = extendBndr env bndr
808 ; (rhs_usg, (_, args', rhs_body', _)) <- scRecRhs env (bndr',rhs)
809 ; let rhs' = mkLams args' rhs_body'
811 ; if not opt_SpecInlineJoinPoints || null args' || isEmptyVarEnv (scu_calls rhs_usg) then do
813 let body_env2 = extendValEnv body_env bndr' (isValue (sc_vals env) rhs')
814 -- Record if the RHS is a value
815 ; (body_usg, body') <- scExpr body_env2 body
816 ; return (body_usg `combineUsage` rhs_usg, Let (NonRec bndr' rhs') body') }
817 else -- For now, just brutally inline the join point
818 do { let body_env2 = extendScSubst env bndr rhs'
819 ; scExpr body_env2 body } }
823 do { -- Join-point case
824 let body_env2 = extendHowBound body_env [bndr'] RecFun
825 -- If the RHS of this 'let' contains calls
826 -- to recursive functions that we're trying
827 -- to specialise, then treat this let too
828 -- as one to specialise
829 ; (body_usg, body') <- scExpr body_env2 body
831 ; (spec_usg, _, specs) <- specialise env (scu_calls body_usg) ([], rhs_info)
833 ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' }
834 `combineUsage` rhs_usg `combineUsage` spec_usg,
835 mkLets [NonRec b r | (b,r) <- specInfoBinds rhs_info specs] body')
839 -- A *local* recursive group: see Note [Local recursive groups]
840 scExpr' env (Let (Rec prs) body)
841 = do { let (bndrs,rhss) = unzip prs
842 (rhs_env1,bndrs') = extendRecBndrs env bndrs
843 rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
845 ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
846 ; (body_usg, body') <- scExpr rhs_env2 body
848 -- NB: start specLoop from body_usg
849 ; (spec_usg, specs) <- specLoop rhs_env2 (scu_calls body_usg) rhs_infos nullUsage
850 [SI [] 0 (Just usg) | usg <- rhs_usgs]
852 ; let all_usg = spec_usg `combineUsage` body_usg
853 bind' = Rec (concat (zipWith specInfoBinds rhs_infos specs))
855 ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' },
858 -----------------------------------
859 scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)
861 scApp env (Var fn, args) -- Function is a variable
862 = ASSERT( not (null args) )
863 do { args_w_usgs <- mapM (scExpr env) args
864 ; let (arg_usgs, args') = unzip args_w_usgs
865 arg_usg = combineUsages arg_usgs
866 ; case scSubstId env fn of
867 fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args')
868 -- Do beta-reduction and try again
870 Var fn' -> return (arg_usg `combineUsage` fn_usg, mkApps (Var fn') args')
872 fn_usg = case lookupHowBound env fn' of
873 Just RecFun -> SCU { scu_calls = unitVarEnv fn' [(sc_vals env, args')],
874 scu_occs = emptyVarEnv }
875 Just RecArg -> SCU { scu_calls = emptyVarEnv,
876 scu_occs = unitVarEnv fn' (ScrutOcc emptyUFM) }
880 other_fn' -> return (arg_usg, mkApps other_fn' args') }
881 -- NB: doing this ignores any usage info from the substituted
882 -- function, but I don't think that matters. If it does
885 doBeta :: OutExpr -> [OutExpr] -> OutExpr
886 -- ToDo: adjust for System IF
887 doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args)
888 doBeta fn args = mkApps fn args
890 -- The function is almost always a variable, but not always.
891 -- In particular, if this pass follows float-in,
892 -- which it may, we can get
893 -- (let f = ...f... in f) arg1 arg2
894 scApp env (other_fn, args)
895 = do { (fn_usg, fn') <- scExpr env other_fn
896 ; (arg_usgs, args') <- mapAndUnzipM (scExpr env) args
897 ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') }
899 ----------------------
900 scTopBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind)
901 scTopBind env (Rec prs)
902 | Just threshold <- sc_size env
903 , not (all (couldBeSmallEnoughToInline threshold) rhss)
905 = do { let (rhs_env,bndrs') = extendRecBndrs env bndrs
906 ; (_, rhss') <- mapAndUnzipM (scExpr rhs_env) rhss
907 ; return (rhs_env, Rec (bndrs' `zip` rhss')) }
908 | otherwise -- Do specialisation
909 = do { let (rhs_env1,bndrs') = extendRecBndrs env bndrs
910 rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
912 ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
913 ; let rhs_usg = combineUsages rhs_usgs
915 ; (_, specs) <- specLoop rhs_env2 (scu_calls rhs_usg) rhs_infos nullUsage
916 [SI [] 0 Nothing | _ <- bndrs]
918 ; return (rhs_env1, -- For the body of the letrec, delete the RecFun business
919 Rec (concat (zipWith specInfoBinds rhs_infos specs))) }
921 (bndrs,rhss) = unzip prs
923 scTopBind env (NonRec bndr rhs)
924 = do { (_, rhs') <- scExpr env rhs
925 ; let (env1, bndr') = extendBndr env bndr
926 env2 = extendValEnv env1 bndr' (isValue (sc_vals env) rhs')
927 ; return (env2, NonRec bndr' rhs') }
929 ----------------------
930 scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM (ScUsage, RhsInfo)
931 scRecRhs env (bndr,rhs)
932 = do { let (arg_bndrs,body) = collectBinders rhs
933 (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs
934 ; (body_usg, body') <- scExpr body_env body
935 ; let (rhs_usg, arg_occs) = lookupOccs body_usg arg_bndrs'
936 ; return (rhs_usg, (bndr, arg_bndrs', body', arg_occs)) }
938 -- The arg_occs says how the visible,
939 -- lambda-bound binders of the RHS are used
940 -- (including the TyVar binders)
941 -- Two pats are the same if they match both ways
943 ----------------------
944 specInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)]
945 specInfoBinds (fn, args, body, _) (SI specs _ _)
946 = [(id,rhs) | OS _ _ id rhs <- specs] ++
947 [(fn `addIdSpecialisations` rules, mkLams args body)]
949 rules = [r | OS _ r _ _ <- specs]
951 ----------------------
952 varUsage :: ScEnv -> OutVar -> ArgOcc -> ScUsage
954 | Just RecArg <- lookupHowBound env v = SCU { scu_calls = emptyVarEnv
955 , scu_occs = unitVarEnv v use }
956 | otherwise = nullUsage
960 %************************************************************************
962 The specialiser itself
964 %************************************************************************
967 type RhsInfo = (OutId, [OutVar], OutExpr, [ArgOcc])
968 -- Info about the *original* RHS of a binding we are specialising
969 -- Original binding f = \xs.body
970 -- Plus info about usage of arguments
972 data SpecInfo = SI [OneSpec] -- The specialisations we have generated
973 Int -- Length of specs; used for numbering them
974 (Maybe ScUsage) -- Nothing => we have generated specialisations
975 -- from calls in the *original* RHS
976 -- Just cs => we haven't, and this is the usage
977 -- of the original RHS
979 -- One specialisation: Rule plus definition
980 data OneSpec = OS CallPat -- Call pattern that generated this specialisation
981 CoreRule -- Rule connecting original id with the specialisation
982 OutId OutExpr -- Spec id + its rhs
988 -> ScUsage -> [SpecInfo] -- One per binder; acccumulating parameter
989 -> UniqSM (ScUsage, [SpecInfo]) -- ...ditto...
990 specLoop env all_calls rhs_infos usg_so_far specs_so_far
991 = do { specs_w_usg <- zipWithM (specialise env all_calls) rhs_infos specs_so_far
992 ; let (new_usg_s, all_specs) = unzip specs_w_usg
993 new_usg = combineUsages new_usg_s
994 new_calls = scu_calls new_usg
995 all_usg = usg_so_far `combineUsage` new_usg
996 ; if isEmptyVarEnv new_calls then
997 return (all_usg, all_specs)
999 specLoop env new_calls rhs_infos all_usg all_specs }
1003 -> CallEnv -- Info on calls
1005 -> SpecInfo -- Original RHS plus patterns dealt with
1006 -> UniqSM (ScUsage, SpecInfo) -- New specialised versions and their usage
1008 -- Note: the rhs here is the optimised version of the original rhs
1009 -- So when we make a specialised copy of the RHS, we're starting
1010 -- from an RHS whose nested functions have been optimised already.
1012 specialise env bind_calls (fn, arg_bndrs, body, arg_occs)
1013 spec_info@(SI specs spec_count mb_unspec)
1014 | notNull arg_bndrs, -- Only specialise functions
1015 Just all_calls <- lookupVarEnv bind_calls fn
1016 = do { (boring_call, pats) <- callsToPats env specs arg_occs all_calls
1017 -- ; pprTrace "specialise" (vcat [ppr fn <+> ppr arg_occs,
1018 -- text "calls" <+> ppr all_calls,
1019 -- text "good pats" <+> ppr pats]) $
1022 -- Bale out if too many specialisations
1023 -- Rather a hacky way to do so, but it'll do for now
1024 ; let spec_count' = length pats + spec_count
1025 ; case sc_count env of
1026 Just max | spec_count' > max
1027 -> pprTrace "SpecConstr: too many specialisations for one function (see -fspec-constr-count):"
1028 (vcat [ptext (sLit "Function:") <+> ppr fn,
1029 ptext (sLit "Specialisations:") <+> ppr (pats ++ [p | OS p _ _ _ <- specs])])
1030 return (nullUsage, spec_info)
1032 _normal_case -> do {
1034 (spec_usgs, new_specs) <- mapAndUnzipM (spec_one env fn arg_bndrs body)
1035 (pats `zip` [spec_count..])
1037 ; let spec_usg = combineUsages spec_usgs
1038 (new_usg, mb_unspec')
1040 Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing)
1041 _ -> (spec_usg, mb_unspec)
1043 ; return (new_usg, SI (new_specs ++ specs) spec_count' mb_unspec') } }
1045 = return (nullUsage, spec_info) -- The boring case
1048 ---------------------
1050 -> OutId -- Function
1051 -> [Var] -- Lambda-binders of RHS; should match patterns
1052 -> CoreExpr -- Body of the original function
1054 -> UniqSM (ScUsage, OneSpec) -- Rule and binding
1056 -- spec_one creates a specialised copy of the function, together
1057 -- with a rule for using it. I'm very proud of how short this
1058 -- function is, considering what it does :-).
1064 f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
1065 [c::*, v::(b,c) are presumably bound by the (...) part]
1067 f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
1068 (...entire body of f...) [b -> (b,c),
1069 y -> ((:) (a,(b,c)) (x,v) hw)]
1071 RULE: forall b::* c::*, -- Note, *not* forall a, x
1075 f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
1078 spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)
1079 = do { -- Specialise the body
1080 let spec_env = extendScSubstList (extendScInScope env qvars)
1081 (arg_bndrs `zip` pats)
1082 ; (spec_usg, spec_body) <- scExpr spec_env body
1084 -- ; pprTrace "spec_one" (ppr fn <+> vcat [text "pats" <+> ppr pats,
1085 -- text "calls" <+> (ppr (scu_calls spec_usg))])
1088 -- And build the results
1089 ; spec_uniq <- getUniqueUs
1090 ; let (spec_lam_args, spec_call_args) = mkWorkerArgs qvars body_ty
1091 -- Usual w/w hack to avoid generating
1092 -- a spec_rhs of unlifted type and no args
1095 fn_loc = nameSrcSpan fn_name
1096 spec_occ = mkSpecOcc (nameOccName fn_name)
1097 rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number))
1098 spec_rhs = mkLams spec_lam_args spec_body
1099 spec_id = mkUserLocal spec_occ spec_uniq (mkPiTypes spec_lam_args body_ty) fn_loc
1100 body_ty = exprType spec_body
1101 rule_rhs = mkVarApps (Var spec_id) spec_call_args
1102 rule = mkLocalRule rule_name specConstrActivation fn_name qvars pats rule_rhs
1103 ; return (spec_usg, OS call_pat rule spec_id spec_rhs) }
1105 -- In which phase should the specialise-constructor rules be active?
1106 -- Originally I made them always-active, but Manuel found that
1107 -- this defeated some clever user-written rules. So Plan B
1108 -- is to make them active only in Phase 0; after all, currently,
1109 -- the specConstr transformation is only run after the simplifier
1110 -- has reached Phase 0. In general one would want it to be
1111 -- flag-controllable, but for now I'm leaving it baked in
1113 specConstrActivation :: Activation
1114 specConstrActivation = ActiveAfter 0 -- Baked in; see comments above
1117 %************************************************************************
1119 \subsection{Argument analysis}
1121 %************************************************************************
1123 This code deals with analysing call-site arguments to see whether
1124 they are constructor applications.
1128 type CallPat = ([Var], [CoreExpr]) -- Quantified variables and arguments
1131 callsToPats :: ScEnv -> [OneSpec] -> [ArgOcc] -> [Call] -> UniqSM (Bool, [CallPat])
1132 -- Result has no duplicate patterns,
1133 -- nor ones mentioned in done_pats
1134 -- Bool indicates that there was at least one boring pattern
1135 callsToPats env done_specs bndr_occs calls
1136 = do { mb_pats <- mapM (callToPats env bndr_occs) calls
1138 ; let good_pats :: [([Var], [CoreArg])]
1139 good_pats = catMaybes mb_pats
1140 done_pats = [p | OS p _ _ _ <- done_specs]
1141 is_done p = any (samePat p) done_pats
1143 ; return (any isNothing mb_pats,
1144 filterOut is_done (nubBy samePat good_pats)) }
1146 callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
1147 -- The [Var] is the variables to quantify over in the rule
1148 -- Type variables come first, since they may scope
1149 -- over the following term variables
1150 -- The [CoreExpr] are the argument patterns for the rule
1151 callToPats env bndr_occs (con_env, args)
1152 | length args < length bndr_occs -- Check saturated
1155 = do { let in_scope = substInScope (sc_subst env)
1156 ; prs <- argsToPats in_scope con_env (args `zip` bndr_occs)
1157 ; let (interesting_s, pats) = unzip prs
1158 pat_fvs = varSetElems (exprsFreeVars pats)
1159 qvars = filterOut (`elemInScopeSet` in_scope) pat_fvs
1160 -- Quantify over variables that are not in sccpe
1162 -- See Note [Shadowing] at the top
1164 (tvs, ids) = partition isTyVar qvars
1166 -- Put the type variables first; the type of a term
1167 -- variable may mention a type variable
1169 ; -- pprTrace "callToPats" (ppr args $$ ppr prs $$ ppr bndr_occs) $
1171 then return (Just (qvars', pats))
1172 else return Nothing }
1174 -- argToPat takes an actual argument, and returns an abstracted
1175 -- version, consisting of just the "constructor skeleton" of the
1176 -- argument, with non-constructor sub-expression replaced by new
1177 -- placeholder variables. For example:
1178 -- C a (D (f x) (g y)) ==> C p1 (D p2 p3)
1180 argToPat :: InScopeSet -- What's in scope at the fn defn site
1181 -> ValueEnv -- ValueEnv at the call site
1182 -> CoreArg -- A call arg (or component thereof)
1184 -> UniqSM (Bool, CoreArg)
1185 -- Returns (interesting, pat),
1186 -- where pat is the pattern derived from the argument
1187 -- intersting=True if the pattern is non-trivial (not a variable or type)
1188 -- E.g. x:xs --> (True, x:xs)
1189 -- f xs --> (False, w) where w is a fresh wildcard
1190 -- (f xs, 'c') --> (True, (w, 'c')) where w is a fresh wildcard
1191 -- \x. x+y --> (True, \x. x+y)
1192 -- lvl7 --> (True, lvl7) if lvl7 is bound
1193 -- somewhere further out
1195 argToPat _in_scope _val_env arg@(Type {}) _arg_occ
1196 = return (False, arg)
1198 argToPat in_scope val_env (Note _ arg) arg_occ
1199 = argToPat in_scope val_env arg arg_occ
1200 -- Note [Notes in call patterns]
1201 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1202 -- Ignore Notes. In particular, we want to ignore any InlineMe notes
1203 -- Perhaps we should not ignore profiling notes, but I'm going to
1204 -- ride roughshod over them all for now.
1205 --- See Note [Notes in RULE matching] in Rules
1207 argToPat in_scope val_env (Let _ arg) arg_occ
1208 = argToPat in_scope val_env arg arg_occ
1209 -- Look through let expressions
1210 -- e.g. f (let v = rhs in \y -> ...v...)
1211 -- Here we can specialise for f (\y -> ...)
1212 -- because the rule-matcher will look through the let.
1214 argToPat in_scope val_env (Cast arg co) arg_occ
1215 = do { (interesting, arg') <- argToPat in_scope val_env arg arg_occ
1216 ; let (ty1,ty2) = coercionKind co
1217 ; if not interesting then
1220 { -- Make a wild-card pattern for the coercion
1222 ; let co_name = mkSysTvName uniq (fsLit "sg")
1223 co_var = mkCoVar co_name (mkCoKind ty1 ty2)
1224 ; return (interesting, Cast arg' (mkTyVarTy co_var)) } }
1226 {- Disabling lambda specialisation for now
1227 It's fragile, and the spec_loop can be infinite
1228 argToPat in_scope val_env arg arg_occ
1230 = return (True, arg)
1232 is_value_lam (Lam v e) -- Spot a value lambda, even if
1233 | isId v = True -- it is inside a type lambda
1234 | otherwise = is_value_lam e
1235 is_value_lam other = False
1238 -- Check for a constructor application
1239 -- NB: this *precedes* the Var case, so that we catch nullary constrs
1240 argToPat in_scope val_env arg arg_occ
1241 | Just (ConVal dc args) <- isValue val_env arg
1243 ScrutOcc _ -> True -- Used only by case scrutinee
1244 BothOcc -> case arg of -- Used elsewhere
1245 App {} -> True -- see Note [Reboxing]
1247 _other -> False -- No point; the arg is not decomposed
1248 = do { args' <- argsToPats in_scope val_env (args `zip` conArgOccs arg_occ dc)
1249 ; return (True, mk_con_app dc (map snd args')) }
1251 -- Check if the argument is a variable that
1252 -- is in scope at the function definition site
1253 -- It's worth specialising on this if
1254 -- (a) it's used in an interesting way in the body
1255 -- (b) we know what its value is
1256 argToPat in_scope val_env (Var v) arg_occ
1257 | case arg_occ of { UnkOcc -> False; _other -> True }, -- (a)
1259 = return (True, Var v)
1262 | isLocalId v = v `elemInScopeSet` in_scope
1263 && isJust (lookupVarEnv val_env v)
1264 -- Local variables have values in val_env
1265 | otherwise = isValueUnfolding (idUnfolding v)
1266 -- Imports have unfoldings
1268 -- I'm really not sure what this comment means
1269 -- And by not wild-carding we tend to get forall'd
1270 -- variables that are in soope, which in turn can
1271 -- expose the weakness in let-matching
1272 -- See Note [Matching lets] in Rules
1274 -- Check for a variable bound inside the function.
1275 -- Don't make a wild-card, because we may usefully share
1276 -- e.g. f a = let x = ... in f (x,x)
1277 -- NB: this case follows the lambda and con-app cases!!
1278 -- argToPat _in_scope _val_env (Var v) _arg_occ
1279 -- = return (False, Var v)
1280 -- SLPJ : disabling this to avoid proliferation of versions
1281 -- also works badly when thinking about seeding the loop
1282 -- from the body of the let
1283 -- f x y = letrec g z = ... in g (x,y)
1284 -- We don't want to specialise for that *particular* x,y
1286 -- The default case: make a wild-card
1287 argToPat _in_scope _val_env arg _arg_occ
1288 = wildCardPat (exprType arg)
1290 wildCardPat :: Type -> UniqSM (Bool, CoreArg)
1291 wildCardPat ty = do { uniq <- getUniqueUs
1292 ; let id = mkSysLocal (fsLit "sc") uniq ty
1293 ; return (False, Var id) }
1295 argsToPats :: InScopeSet -> ValueEnv
1296 -> [(CoreArg, ArgOcc)]
1297 -> UniqSM [(Bool, CoreArg)]
1298 argsToPats in_scope val_env args
1301 do_one (arg,occ) = argToPat in_scope val_env arg occ
1306 isValue :: ValueEnv -> CoreExpr -> Maybe Value
1307 isValue _env (Lit lit)
1308 = Just (ConVal (LitAlt lit) [])
1311 | Just stuff <- lookupVarEnv env v
1312 = Just stuff -- You might think we could look in the idUnfolding here
1313 -- but that doesn't take account of which branch of a
1314 -- case we are in, which is the whole point
1316 | not (isLocalId v) && isCheapUnfolding unf
1317 = isValue env (unfoldingTemplate unf)
1320 -- However we do want to consult the unfolding
1321 -- as well, for let-bound constructors!
1323 isValue env (Lam b e)
1324 | isTyVar b = case isValue env e of
1325 Just _ -> Just LambdaVal
1327 | otherwise = Just LambdaVal
1329 isValue _env expr -- Maybe it's a constructor application
1330 | (Var fun, args) <- collectArgs expr
1331 = case isDataConWorkId_maybe fun of
1333 Just con | args `lengthAtLeast` dataConRepArity con
1334 -- Check saturated; might be > because the
1335 -- arity excludes type args
1336 -> Just (ConVal (DataAlt con) args)
1338 _other | valArgCount args < idArity fun
1339 -- Under-applied function
1340 -> Just LambdaVal -- Partial application
1344 isValue _env _expr = Nothing
1346 mk_con_app :: AltCon -> [CoreArg] -> CoreExpr
1347 mk_con_app (LitAlt lit) [] = Lit lit
1348 mk_con_app (DataAlt con) args = mkConApp con args
1349 mk_con_app _other _args = panic "SpecConstr.mk_con_app"
1351 samePat :: CallPat -> CallPat -> Bool
1352 samePat (vs1, as1) (vs2, as2)
1355 same (Var v1) (Var v2)
1356 | v1 `elem` vs1 = v2 `elem` vs2
1357 | v2 `elem` vs2 = False
1358 | otherwise = v1 == v2
1360 same (Lit l1) (Lit l2) = l1==l2
1361 same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2
1363 same (Type {}) (Type {}) = True -- Note [Ignore type differences]
1364 same (Note _ e1) e2 = same e1 e2 -- Ignore casts and notes
1365 same (Cast e1 _) e2 = same e1 e2
1366 same e1 (Note _ e2) = same e1 e2
1367 same e1 (Cast e2 _) = same e1 e2
1369 same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2)
1370 False -- Let, lambda, case should not occur
1371 bad (Case {}) = True
1377 Note [Ignore type differences]
1378 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1379 We do not want to generate specialisations where the call patterns
1380 differ only in their type arguments! Not only is it utterly useless,
1381 but it also means that (with polymorphic recursion) we can generate
1382 an infinite number of specialisations. Example is Data.Sequence.adjustTree,