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 WwLib ( mkWorkerArgs )
26 import DataCon ( dataConRepArity, dataConUnivTyVars )
29 import Type hiding( substTy )
30 import Id ( Id, idName, idType, isDataConWorkId_maybe, idArity,
31 mkUserLocal, mkSysLocal, idUnfolding, isLocalId )
36 import OccName ( mkSpecOcc )
37 import ErrUtils ( dumpIfSet_dyn )
38 import DynFlags ( DynFlags(..), DynFlag(..) )
39 import StaticFlags ( opt_PprStyle_Debug )
40 import StaticFlags ( opt_SpecInlineJoinPoints )
41 import BasicTypes ( Activation(..) )
42 import Maybes ( orElse, catMaybes, isJust, isNothing )
44 import List ( nubBy, partition )
50 import Control.Monad ( zipWithM )
53 -----------------------------------------------------
55 -----------------------------------------------------
60 drop n (x:xs) = drop (n-1) xs
62 After the first time round, we could pass n unboxed. This happens in
63 numerical code too. Here's what it looks like in Core:
65 drop n xs = case xs of
70 _ -> drop (I# (n# -# 1#)) xs
72 Notice that the recursive call has an explicit constructor as argument.
73 Noticing this, we can make a specialised version of drop
75 RULE: drop (I# n#) xs ==> drop' n# xs
77 drop' n# xs = let n = I# n# in ...orig RHS...
79 Now the simplifier will apply the specialisation in the rhs of drop', giving
81 drop' n# xs = case xs of
85 _ -> drop (n# -# 1#) xs
89 We'd also like to catch cases where a parameter is carried along unchanged,
90 but evaluated each time round the loop:
92 f i n = if i>0 || i>n then i else f (i*2) n
94 Here f isn't strict in n, but we'd like to avoid evaluating it each iteration.
95 In Core, by the time we've w/wd (f is strict in i) we get
97 f i# n = case i# ># 0 of
99 True -> case n of n' { I# n# ->
102 True -> f (i# *# 2#) n'
104 At the call to f, we see that the argument, n is know to be (I# n#),
105 and n is evaluated elsewhere in the body of f, so we can play the same
111 We must be careful not to allocate the same constructor twice. Consider
112 f p = (...(case p of (a,b) -> e)...p...,
113 ...let t = (r,s) in ...t...(f t)...)
114 At the recursive call to f, we can see that t is a pair. But we do NOT want
115 to make a specialised copy:
116 f' a b = let p = (a,b) in (..., ...)
117 because now t is allocated by the caller, then r and s are passed to the
118 recursive call, which allocates the (r,s) pair again.
121 (a) the argument p is used in other than a case-scrutinsation way.
122 (b) the argument to the call is not a 'fresh' tuple; you have to
123 look into its unfolding to see that it's a tuple
125 Hence the "OR" part of Note [Good arguments] below.
127 ALTERNATIVE 2: pass both boxed and unboxed versions. This no longer saves
128 allocation, but does perhaps save evals. In the RULE we'd have
131 f (I# x#) = f' (I# x#) x#
133 If at the call site the (I# x) was an unfolding, then we'd have to
134 rely on CSE to eliminate the duplicate allocation.... This alternative
135 doesn't look attractive enough to pursue.
137 ALTERNATIVE 3: ignore the reboxing problem. The trouble is that
138 the conservative reboxing story prevents many useful functions from being
139 specialised. Example:
140 foo :: Maybe Int -> Int -> Int
142 foo x@(Just m) n = foo x (n-m)
143 Here the use of 'x' will clearly not require boxing in the specialised function.
145 The strictness analyser has the same problem, in fact. Example:
147 If we pass just 'a' and 'b' to the worker, it might need to rebox the
148 pair to create (a,b). A more sophisticated analysis might figure out
149 precisely the cases in which this could happen, but the strictness
150 analyser does no such analysis; it just passes 'a' and 'b', and hopes
153 So my current choice is to make SpecConstr similarly aggressive, and
154 ignore the bad potential of reboxing.
157 Note [Good arguments]
158 ~~~~~~~~~~~~~~~~~~~~~
161 * A self-recursive function. Ignore mutual recursion for now,
162 because it's less common, and the code is simpler for self-recursion.
166 a) At a recursive call, one or more parameters is an explicit
167 constructor application
169 That same parameter is scrutinised by a case somewhere in
170 the RHS of the function
174 b) At a recursive call, one or more parameters has an unfolding
175 that is an explicit constructor application
177 That same parameter is scrutinised by a case somewhere in
178 the RHS of the function
180 Those are the only uses of the parameter (see Note [Reboxing])
183 What to abstract over
184 ~~~~~~~~~~~~~~~~~~~~~
185 There's a bit of a complication with type arguments. If the call
188 f p = ...f ((:) [a] x xs)...
190 then our specialised function look like
192 f_spec x xs = let p = (:) [a] x xs in ....as before....
194 This only makes sense if either
195 a) the type variable 'a' is in scope at the top of f, or
196 b) the type variable 'a' is an argument to f (and hence fs)
198 Actually, (a) may hold for value arguments too, in which case
199 we may not want to pass them. Supose 'x' is in scope at f's
200 defn, but xs is not. Then we'd like
202 f_spec xs = let p = (:) [a] x xs in ....as before....
204 Similarly (b) may hold too. If x is already an argument at the
205 call, no need to pass it again.
207 Finally, if 'a' is not in scope at the call site, we could abstract
208 it as we do the term variables:
210 f_spec a x xs = let p = (:) [a] x xs in ...as before...
212 So the grand plan is:
214 * abstract the call site to a constructor-only pattern
215 e.g. C x (D (f p) (g q)) ==> C s1 (D s2 s3)
217 * Find the free variables of the abstracted pattern
219 * Pass these variables, less any that are in scope at
220 the fn defn. But see Note [Shadowing] below.
223 NOTICE that we only abstract over variables that are not in scope,
224 so we're in no danger of shadowing variables used in "higher up"
230 In this pass we gather up usage information that may mention variables
231 that are bound between the usage site and the definition site; or (more
232 seriously) may be bound to something different at the definition site.
235 f x = letrec g y v = let x = ...
238 Since 'x' is in scope at the call site, we may make a rewrite rule that
240 RULE forall a,b. g (a,b) x = ...
241 But this rule will never match, because it's really a different 'x' at
242 the call site -- and that difference will be manifest by the time the
243 simplifier gets to it. [A worry: the simplifier doesn't *guarantee*
244 no-shadowing, so perhaps it may not be distinct?]
246 Anyway, the rule isn't actually wrong, it's just not useful. One possibility
247 is to run deShadowBinds before running SpecConstr, but instead we run the
248 simplifier. That gives the simplest possible program for SpecConstr to
249 chew on; and it virtually guarantees no shadowing.
251 Note [Specialising for constant parameters]
252 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
253 This one is about specialising on a *constant* (but not necessarily
254 constructor) argument
256 foo :: Int -> (Int -> Int) -> Int
258 foo m f = foo (f m) (+1)
262 lvl_rmV :: GHC.Base.Int -> GHC.Base.Int
264 \ (ds_dlk :: GHC.Base.Int) ->
265 case ds_dlk of wild_alH { GHC.Base.I# x_alG ->
266 GHC.Base.I# (GHC.Prim.+# x_alG 1)
268 T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
271 \ (ww_sme :: GHC.Prim.Int#) (w_smg :: GHC.Base.Int -> GHC.Base.Int) ->
272 case ww_sme of ds_Xlw {
274 case w_smg (GHC.Base.I# ds_Xlw) of w1_Xmo { GHC.Base.I# ww1_Xmz ->
275 T.$wfoo ww1_Xmz lvl_rmV
280 The recursive call has lvl_rmV as its argument, so we could create a specialised copy
281 with that argument baked in; that is, not passed at all. Now it can perhaps be inlined.
283 When is this worth it? Call the constant 'lvl'
284 - If 'lvl' has an unfolding that is a constructor, see if the corresponding
285 parameter is scrutinised anywhere in the body.
287 - If 'lvl' has an unfolding that is a inlinable function, see if the corresponding
288 parameter is applied (...to enough arguments...?)
290 Also do this is if the function has RULES?
294 Note [Specialising for lambda parameters]
295 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
296 foo :: Int -> (Int -> Int) -> Int
298 foo m f = foo (f m) (\n -> n-m)
300 This is subtly different from the previous one in that we get an
301 explicit lambda as the argument:
303 T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
306 \ (ww_sm8 :: GHC.Prim.Int#) (w_sma :: GHC.Base.Int -> GHC.Base.Int) ->
307 case ww_sm8 of ds_Xlr {
309 case w_sma (GHC.Base.I# ds_Xlr) of w1_Xmf { GHC.Base.I# ww1_Xmq ->
312 (\ (n_ad3 :: GHC.Base.Int) ->
313 case n_ad3 of wild_alB { GHC.Base.I# x_alA ->
314 GHC.Base.I# (GHC.Prim.-# x_alA ds_Xlr)
320 I wonder if SpecConstr couldn't be extended to handle this? After all,
321 lambda is a sort of constructor for functions and perhaps it already
322 has most of the necessary machinery?
324 Furthermore, there's an immediate win, because you don't need to allocate the lamda
325 at the call site; and if perchance it's called in the recursive call, then you
326 may avoid allocating it altogether. Just like for constructors.
328 Looks cool, but probably rare...but it might be easy to implement.
331 Note [SpecConstr for casts]
332 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
335 data instance T Int = T Int
340 go (T n) = go (T (n-1))
342 The recursive call ends up looking like
343 go (T (I# ...) `cast` g)
344 So we want to spot the construtor application inside the cast.
345 That's why we have the Cast case in argToPat
347 Note [Local recursive groups]
348 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
349 For a *local* recursive group, we can see all the calls to the
350 function, so we seed the specialisation loop from the calls in the
351 body, not from the calls in the RHS. Consider:
353 bar m n = foo n (n,n) (n,n) (n,n) (n,n)
357 | n > 3000 = case p of { (p1,p2) -> foo (n-1) (p2,p1) q r s }
358 | n > 2000 = case q of { (q1,q2) -> foo (n-1) p (q2,q1) r s }
359 | n > 1000 = case r of { (r1,r2) -> foo (n-1) p q (r2,r1) s }
360 | otherwise = case s of { (s1,s2) -> foo (n-1) p q r (s2,s1) }
362 If we start with the RHSs of 'foo', we get lots and lots of specialisations,
363 most of which are not needed. But if we start with the (single) call
364 in the rhs of 'bar' we get exactly one fully-specialised copy, and all
365 the recursive calls go to this fully-specialised copy. Indeed, the original
366 function is later collected as dead code. This is very important in
367 specialising the loops arising from stream fusion, for example in NDP where
368 we were getting literally hundreds of (mostly unused) specialisations of
371 -----------------------------------------------------
372 Stuff not yet handled
373 -----------------------------------------------------
375 Here are notes arising from Roman's work that I don't want to lose.
381 foo :: Int -> T Int -> Int
383 foo x t | even x = case t of { T n -> foo (x-n) t }
384 | otherwise = foo (x-1) t
386 SpecConstr does no specialisation, because the second recursive call
387 looks like a boxed use of the argument. A pity.
389 $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
391 \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) ->
392 case ww_sFo of ds_Xw6 [Just L] {
394 case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] {
395 __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq;
397 case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] ->
398 case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] ->
399 $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy
405 data a :*: b = !a :*: !b
408 foo :: (Int :*: T Int) -> Int
410 foo (x :*: t) | even x = case t of { T n -> foo ((x-n) :*: t) }
411 | otherwise = foo ((x-1) :*: t)
413 Very similar to the previous one, except that the parameters are now in
414 a strict tuple. Before SpecConstr, we have
416 $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
418 \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T
420 case ww_sFU of ds_Xws [Just L] {
422 case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] {
424 case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] ->
425 $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2 -- $wfoo1
428 case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] ->
429 case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] ->
430 $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB -- $wfoo2
434 We get two specialisations:
435 "SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#}
436 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB)
437 = Foo.$s$wfoo1 a_sFB sc_sGC ;
438 "SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#}
439 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp))
440 = Foo.$s$wfoo y_aFp sc_sGC ;
442 But perhaps the first one isn't good. After all, we know that tpl_B2 is
443 a T (I# x) really, because T is strict and Int has one constructor. (We can't
444 unbox the strict fields, becuase T is polymorphic!)
448 %************************************************************************
450 \subsection{Top level wrapper stuff}
452 %************************************************************************
455 specConstrProgram :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]
456 specConstrProgram dflags us binds
458 showPass dflags "SpecConstr"
460 let (binds', _) = initUs us (go (initScEnv dflags) binds)
462 endPass dflags "SpecConstr" Opt_D_dump_spec binds'
464 dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
465 (pprRulesForUser (rulesOfBinds binds'))
470 go env (bind:binds) = do (env', bind') <- scTopBind env bind
471 binds' <- go env' binds
472 return (bind' : binds')
476 %************************************************************************
478 \subsection{Environment: goes downwards}
480 %************************************************************************
483 data ScEnv = SCE { sc_size :: Maybe Int, -- Size threshold
484 sc_count :: Maybe Int, -- Max # of specialisations for any one fn
486 sc_subst :: Subst, -- Current substitution
487 -- Maps InIds to OutExprs
489 sc_how_bound :: HowBoundEnv,
490 -- Binds interesting non-top-level variables
491 -- Domain is OutVars (*after* applying the substitution)
494 -- Domain is OutIds (*after* applying the substitution)
495 -- Used even for top-level bindings (but not imported ones)
498 ---------------------
499 -- As we go, we apply a substitution (sc_subst) to the current term
500 type InExpr = CoreExpr -- _Before_ applying the subst
502 type OutExpr = CoreExpr -- _After_ applying the subst
506 ---------------------
507 type HowBoundEnv = VarEnv HowBound -- Domain is OutVars
509 ---------------------
510 type ValueEnv = IdEnv Value -- Domain is OutIds
511 data Value = ConVal AltCon [CoreArg] -- _Saturated_ constructors
512 | LambdaVal -- Inlinable lambdas or PAPs
514 instance Outputable Value where
515 ppr (ConVal con args) = ppr con <+> interpp'SP args
516 ppr LambdaVal = ptext (sLit "<Lambda>")
518 ---------------------
519 initScEnv :: DynFlags -> ScEnv
521 = SCE { sc_size = specConstrThreshold dflags,
522 sc_count = specConstrCount dflags,
523 sc_subst = emptySubst,
524 sc_how_bound = emptyVarEnv,
525 sc_vals = emptyVarEnv }
527 data HowBound = RecFun -- These are the recursive functions for which
528 -- we seek interesting call patterns
530 | RecArg -- These are those functions' arguments, or their sub-components;
531 -- we gather occurrence information for these
533 instance Outputable HowBound where
534 ppr RecFun = text "RecFun"
535 ppr RecArg = text "RecArg"
537 lookupHowBound :: ScEnv -> Id -> Maybe HowBound
538 lookupHowBound env id = lookupVarEnv (sc_how_bound env) id
540 scSubstId :: ScEnv -> Id -> CoreExpr
541 scSubstId env v = lookupIdSubst (sc_subst env) v
543 scSubstTy :: ScEnv -> Type -> Type
544 scSubstTy env ty = substTy (sc_subst env) ty
546 zapScSubst :: ScEnv -> ScEnv
547 zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) }
549 extendScInScope :: ScEnv -> [Var] -> ScEnv
550 -- Bring the quantified variables into scope
551 extendScInScope env qvars = env { sc_subst = extendInScopeList (sc_subst env) qvars }
553 -- Extend the substitution
554 extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv
555 extendScSubst env var expr = env { sc_subst = extendSubst (sc_subst env) var expr }
557 extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv
558 extendScSubstList env prs = env { sc_subst = extendSubstList (sc_subst env) prs }
560 extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv
561 extendHowBound env bndrs how_bound
562 = env { sc_how_bound = extendVarEnvList (sc_how_bound env)
563 [(bndr,how_bound) | bndr <- bndrs] }
565 extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var])
566 extendBndrsWith how_bound env bndrs
567 = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndrs')
569 (subst', bndrs') = substBndrs (sc_subst env) bndrs
570 hb_env' = sc_how_bound env `extendVarEnvList`
571 [(bndr,how_bound) | bndr <- bndrs']
573 extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var)
574 extendBndrWith how_bound env bndr
575 = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndr')
577 (subst', bndr') = substBndr (sc_subst env) bndr
578 hb_env' = extendVarEnv (sc_how_bound env) bndr' how_bound
580 extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var])
581 extendRecBndrs env bndrs = (env { sc_subst = subst' }, bndrs')
583 (subst', bndrs') = substRecBndrs (sc_subst env) bndrs
585 extendBndr :: ScEnv -> Var -> (ScEnv, Var)
586 extendBndr env bndr = (env { sc_subst = subst' }, bndr')
588 (subst', bndr') = substBndr (sc_subst env) bndr
590 extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv
591 extendValEnv env _ Nothing = env
592 extendValEnv env id (Just cv) = env { sc_vals = extendVarEnv (sc_vals env) id cv }
594 extendCaseBndrs :: ScEnv -> CoreExpr -> Id -> AltCon -> [Var] -> ScEnv
598 -- we want to bind b, and perhaps scrut too, to (C x y)
599 -- NB: Extends only the sc_vals part of the envt
600 extendCaseBndrs env scrut case_bndr con alt_bndrs
602 Var v -> extendValEnv env1 v cval
605 env1 = extendValEnv env case_bndr cval
608 LitAlt {} -> Just (ConVal con [])
609 DataAlt {} -> Just (ConVal con vanilla_args)
611 vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
612 varsToCoreExprs alt_bndrs
616 %************************************************************************
618 \subsection{Usage information: flows upwards}
620 %************************************************************************
625 scu_calls :: CallEnv, -- Calls
626 -- The functions are a subset of the
627 -- RecFuns in the ScEnv
629 scu_occs :: !(IdEnv ArgOcc) -- Information on argument occurrences
630 } -- The domain is OutIds
632 type CallEnv = IdEnv [Call]
633 type Call = (ValueEnv, [CoreArg])
634 -- The arguments of the call, together with the
635 -- env giving the constructor bindings at the call site
638 nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv }
640 combineCalls :: CallEnv -> CallEnv -> CallEnv
641 combineCalls = plusVarEnv_C (++)
643 combineUsage :: ScUsage -> ScUsage -> ScUsage
644 combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2),
645 scu_occs = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) }
647 combineUsages :: [ScUsage] -> ScUsage
648 combineUsages [] = nullUsage
649 combineUsages us = foldr1 combineUsage us
651 lookupOcc :: ScUsage -> OutVar -> (ScUsage, ArgOcc)
652 lookupOcc (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndr
653 = (SCU {scu_calls = sc_calls, scu_occs = delVarEnv sc_occs bndr},
654 lookupVarEnv sc_occs bndr `orElse` NoOcc)
656 lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc])
657 lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs
658 = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs},
659 [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs])
661 data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument
662 | UnkOcc -- Used in some unknown way
664 | ScrutOcc (UniqFM [ArgOcc]) -- See Note [ScrutOcc]
666 | BothOcc -- Definitely taken apart, *and* perhaps used in some other way
670 An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing,
671 is *only* taken apart or applied.
673 Functions, literal: ScrutOcc emptyUFM
674 Data constructors: ScrutOcc subs,
676 where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components,
677 The domain of the UniqFM is the Unique of the data constructor
679 The [ArgOcc] is the occurrences of the *pattern-bound* components
680 of the data structure. E.g.
681 data T a = forall b. MkT a b (b->a)
682 A pattern binds b, x::a, y::b, z::b->a, but not 'a'!
686 instance Outputable ArgOcc where
687 ppr (ScrutOcc xs) = ptext (sLit "scrut-occ") <> ppr xs
688 ppr UnkOcc = ptext (sLit "unk-occ")
689 ppr BothOcc = ptext (sLit "both-occ")
690 ppr NoOcc = ptext (sLit "no-occ")
692 -- Experimentally, this vesion of combineOcc makes ScrutOcc "win", so
693 -- that if the thing is scrutinised anywhere then we get to see that
694 -- in the overall result, even if it's also used in a boxed way
695 -- This might be too agressive; see Note [Reboxing] Alternative 3
696 combineOcc :: ArgOcc -> ArgOcc -> ArgOcc
697 combineOcc NoOcc occ = occ
698 combineOcc occ NoOcc = occ
699 combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys)
700 combineOcc _occ (ScrutOcc ys) = ScrutOcc ys
701 combineOcc (ScrutOcc xs) _occ = ScrutOcc xs
702 combineOcc UnkOcc UnkOcc = UnkOcc
703 combineOcc _ _ = BothOcc
705 combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]
706 combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys
708 setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage
709 -- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee
710 -- is a variable, and an interesting variable
711 setScrutOcc env usg (Cast e _) occ = setScrutOcc env usg e occ
712 setScrutOcc env usg (Note _ e) occ = setScrutOcc env usg e occ
713 setScrutOcc env usg (Var v) occ
714 | Just RecArg <- lookupHowBound env v = usg { scu_occs = extendVarEnv (scu_occs usg) v occ }
716 setScrutOcc _env usg _other _occ -- Catch-all
719 conArgOccs :: ArgOcc -> AltCon -> [ArgOcc]
720 -- Find usage of components of data con; returns [UnkOcc...] if unknown
721 -- See Note [ScrutOcc] for the extra UnkOccs in the vanilla datacon case
723 conArgOccs (ScrutOcc fm) (DataAlt dc)
724 | Just pat_arg_occs <- lookupUFM fm dc
725 = [UnkOcc | _ <- dataConUnivTyVars dc] ++ pat_arg_occs
727 conArgOccs _other _con = repeat UnkOcc
730 %************************************************************************
732 \subsection{The main recursive function}
734 %************************************************************************
736 The main recursive function gathers up usage information, and
737 creates specialised versions of functions.
740 scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
741 -- The unique supply is needed when we invent
742 -- a new name for the specialised function and its args
744 scExpr env e = scExpr' env e
747 scExpr' env (Var v) = case scSubstId env v of
748 Var v' -> return (varUsage env v' UnkOcc, Var v')
749 e' -> scExpr (zapScSubst env) e'
751 scExpr' env (Type t) = return (nullUsage, Type (scSubstTy env t))
752 scExpr' _ e@(Lit {}) = return (nullUsage, e)
753 scExpr' env (Note n e) = do (usg,e') <- scExpr env e
754 return (usg, Note n e')
755 scExpr' env (Cast e co) = do (usg, e') <- scExpr env e
756 return (usg, Cast e' (scSubstTy env co))
757 scExpr' env e@(App _ _) = scApp env (collectArgs e)
758 scExpr' env (Lam b e) = do let (env', b') = extendBndr env b
759 (usg, e') <- scExpr env' e
760 return (usg, Lam b' e')
762 scExpr' env (Case scrut b ty alts)
763 = do { (scrut_usg, scrut') <- scExpr env scrut
764 ; case isValue (sc_vals env) scrut' of
765 Just (ConVal con args) -> sc_con_app con args scrut'
766 _other -> sc_vanilla scrut_usg scrut'
769 sc_con_app con args scrut' -- Known constructor; simplify
770 = do { let (_, bs, rhs) = findAlt con alts
771 alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)
772 ; scExpr alt_env' rhs }
774 sc_vanilla scrut_usg scrut' -- Normal case
775 = do { let (alt_env,b') = extendBndrWith RecArg env b
776 -- Record RecArg for the components
778 ; (alt_usgs, alt_occs, alts')
779 <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts
781 ; let (alt_usg, b_occ) = lookupOcc (combineUsages alt_usgs) b'
782 scrut_occ = foldr combineOcc b_occ alt_occs
783 scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ
784 -- The combined usage of the scrutinee is given
785 -- by scrut_occ, which is passed to scScrut, which
786 -- in turn treats a bare-variable scrutinee specially
788 ; return (alt_usg `combineUsage` scrut_usg',
789 Case scrut' b' (scSubstTy env ty) alts') }
791 sc_alt env scrut' b' (con,bs,rhs)
792 = do { let (env1, bs') = extendBndrsWith RecArg env bs
793 env2 = extendCaseBndrs env1 scrut' b' con bs'
794 ; (usg,rhs') <- scExpr env2 rhs
795 ; let (usg', arg_occs) = lookupOccs usg bs'
796 scrut_occ = case con of
797 DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)
798 _ -> ScrutOcc emptyUFM
799 ; return (usg', scrut_occ, (con,bs',rhs')) }
801 scExpr' env (Let (NonRec bndr rhs) body)
802 | isTyVar bndr -- Type-lets may be created by doBeta
803 = scExpr' (extendScSubst env bndr rhs) body
805 = do { let (body_env, bndr') = extendBndr env bndr
806 ; (rhs_usg, (_, args', rhs_body', _)) <- scRecRhs env (bndr',rhs)
807 ; let rhs' = mkLams args' rhs_body'
809 ; if not opt_SpecInlineJoinPoints || null args' || isEmptyVarEnv (scu_calls rhs_usg) then do
811 let body_env2 = extendValEnv body_env bndr' (isValue (sc_vals env) rhs')
812 -- Record if the RHS is a value
813 ; (body_usg, body') <- scExpr body_env2 body
814 ; return (body_usg `combineUsage` rhs_usg, Let (NonRec bndr' rhs') body') }
815 else -- For now, just brutally inline the join point
816 do { let body_env2 = extendScSubst env bndr rhs'
817 ; scExpr body_env2 body } }
821 do { -- Join-point case
822 let body_env2 = extendHowBound body_env [bndr'] RecFun
823 -- If the RHS of this 'let' contains calls
824 -- to recursive functions that we're trying
825 -- to specialise, then treat this let too
826 -- as one to specialise
827 ; (body_usg, body') <- scExpr body_env2 body
829 ; (spec_usg, _, specs) <- specialise env (scu_calls body_usg) ([], rhs_info)
831 ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' }
832 `combineUsage` rhs_usg `combineUsage` spec_usg,
833 mkLets [NonRec b r | (b,r) <- specInfoBinds rhs_info specs] body')
837 -- A *local* recursive group: see Note [Local recursive groups]
838 scExpr' env (Let (Rec prs) body)
839 = do { let (bndrs,rhss) = unzip prs
840 (rhs_env1,bndrs') = extendRecBndrs env bndrs
841 rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
843 ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
844 ; (body_usg, body') <- scExpr rhs_env2 body
846 -- NB: start specLoop from body_usg
847 ; (spec_usg, specs) <- specLoop rhs_env2 (scu_calls body_usg) rhs_infos nullUsage
848 [SI [] 0 (Just usg) | usg <- rhs_usgs]
850 ; let all_usg = spec_usg `combineUsage` body_usg
851 bind' = Rec (concat (zipWith specInfoBinds rhs_infos specs))
853 ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' },
856 -----------------------------------
857 scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)
859 scApp env (Var fn, args) -- Function is a variable
860 = ASSERT( not (null args) )
861 do { args_w_usgs <- mapM (scExpr env) args
862 ; let (arg_usgs, args') = unzip args_w_usgs
863 arg_usg = combineUsages arg_usgs
864 ; case scSubstId env fn of
865 fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args')
866 -- Do beta-reduction and try again
868 Var fn' -> return (arg_usg `combineUsage` fn_usg, mkApps (Var fn') args')
870 fn_usg = case lookupHowBound env fn' of
871 Just RecFun -> SCU { scu_calls = unitVarEnv fn' [(sc_vals env, args')],
872 scu_occs = emptyVarEnv }
873 Just RecArg -> SCU { scu_calls = emptyVarEnv,
874 scu_occs = unitVarEnv fn' (ScrutOcc emptyUFM) }
878 other_fn' -> return (arg_usg, mkApps other_fn' args') }
879 -- NB: doing this ignores any usage info from the substituted
880 -- function, but I don't think that matters. If it does
883 doBeta :: OutExpr -> [OutExpr] -> OutExpr
884 -- ToDo: adjust for System IF
885 doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args)
886 doBeta fn args = mkApps fn args
888 -- The function is almost always a variable, but not always.
889 -- In particular, if this pass follows float-in,
890 -- which it may, we can get
891 -- (let f = ...f... in f) arg1 arg2
892 scApp env (other_fn, args)
893 = do { (fn_usg, fn') <- scExpr env other_fn
894 ; (arg_usgs, args') <- mapAndUnzipM (scExpr env) args
895 ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') }
897 ----------------------
898 scTopBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind)
899 scTopBind env (Rec prs)
900 | Just threshold <- sc_size env
901 , not (all (couldBeSmallEnoughToInline threshold) rhss)
903 = do { let (rhs_env,bndrs') = extendRecBndrs env bndrs
904 ; (_, rhss') <- mapAndUnzipM (scExpr rhs_env) rhss
905 ; return (rhs_env, Rec (bndrs' `zip` rhss')) }
906 | otherwise -- Do specialisation
907 = do { let (rhs_env1,bndrs') = extendRecBndrs env bndrs
908 rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
910 ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
911 ; let rhs_usg = combineUsages rhs_usgs
913 ; (_, specs) <- specLoop rhs_env2 (scu_calls rhs_usg) rhs_infos nullUsage
914 [SI [] 0 Nothing | _ <- bndrs]
916 ; return (rhs_env1, -- For the body of the letrec, delete the RecFun business
917 Rec (concat (zipWith specInfoBinds rhs_infos specs))) }
919 (bndrs,rhss) = unzip prs
921 scTopBind env (NonRec bndr rhs)
922 = do { (_, rhs') <- scExpr env rhs
923 ; let (env1, bndr') = extendBndr env bndr
924 env2 = extendValEnv env1 bndr' (isValue (sc_vals env) rhs')
925 ; return (env2, NonRec bndr' rhs') }
927 ----------------------
928 scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM (ScUsage, RhsInfo)
929 scRecRhs env (bndr,rhs)
930 = do { let (arg_bndrs,body) = collectBinders rhs
931 (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs
932 ; (body_usg, body') <- scExpr body_env body
933 ; let (rhs_usg, arg_occs) = lookupOccs body_usg arg_bndrs'
934 ; return (rhs_usg, (bndr, arg_bndrs', body', arg_occs)) }
936 -- The arg_occs says how the visible,
937 -- lambda-bound binders of the RHS are used
938 -- (including the TyVar binders)
939 -- Two pats are the same if they match both ways
941 ----------------------
942 specInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)]
943 specInfoBinds (fn, args, body, _) (SI specs _ _)
944 = [(id,rhs) | OS _ _ id rhs <- specs] ++
945 [(fn `addIdSpecialisations` rules, mkLams args body)]
947 rules = [r | OS _ r _ _ <- specs]
949 ----------------------
950 varUsage :: ScEnv -> OutVar -> ArgOcc -> ScUsage
952 | Just RecArg <- lookupHowBound env v = SCU { scu_calls = emptyVarEnv
953 , scu_occs = unitVarEnv v use }
954 | otherwise = nullUsage
958 %************************************************************************
960 The specialiser itself
962 %************************************************************************
965 type RhsInfo = (OutId, [OutVar], OutExpr, [ArgOcc])
966 -- Info about the *original* RHS of a binding we are specialising
967 -- Original binding f = \xs.body
968 -- Plus info about usage of arguments
970 data SpecInfo = SI [OneSpec] -- The specialisations we have generated
971 Int -- Length of specs; used for numbering them
972 (Maybe ScUsage) -- Nothing => we have generated specialisations
973 -- from calls in the *original* RHS
974 -- Just cs => we haven't, and this is the usage
975 -- of the original RHS
977 -- One specialisation: Rule plus definition
978 data OneSpec = OS CallPat -- Call pattern that generated this specialisation
979 CoreRule -- Rule connecting original id with the specialisation
980 OutId OutExpr -- Spec id + its rhs
986 -> ScUsage -> [SpecInfo] -- One per binder; acccumulating parameter
987 -> UniqSM (ScUsage, [SpecInfo]) -- ...ditto...
988 specLoop env all_calls rhs_infos usg_so_far specs_so_far
989 = do { specs_w_usg <- zipWithM (specialise env all_calls) rhs_infos specs_so_far
990 ; let (new_usg_s, all_specs) = unzip specs_w_usg
991 new_usg = combineUsages new_usg_s
992 new_calls = scu_calls new_usg
993 all_usg = usg_so_far `combineUsage` new_usg
994 ; if isEmptyVarEnv new_calls then
995 return (all_usg, all_specs)
997 specLoop env new_calls rhs_infos all_usg all_specs }
1001 -> CallEnv -- Info on calls
1003 -> SpecInfo -- Original RHS plus patterns dealt with
1004 -> UniqSM (ScUsage, SpecInfo) -- New specialised versions and their usage
1006 -- Note: the rhs here is the optimised version of the original rhs
1007 -- So when we make a specialised copy of the RHS, we're starting
1008 -- from an RHS whose nested functions have been optimised already.
1010 specialise env bind_calls (fn, arg_bndrs, body, arg_occs)
1011 spec_info@(SI specs spec_count mb_unspec)
1012 | notNull arg_bndrs, -- Only specialise functions
1013 Just all_calls <- lookupVarEnv bind_calls fn
1014 = do { (boring_call, pats) <- callsToPats env specs arg_occs all_calls
1015 -- ; pprTrace "specialise" (vcat [ppr fn <+> ppr arg_occs,
1016 -- text "calls" <+> ppr all_calls,
1017 -- text "good pats" <+> ppr pats]) $
1020 -- Bale out if too many specialisations
1021 -- Rather a hacky way to do so, but it'll do for now
1022 ; let spec_count' = length pats + spec_count
1023 ; case sc_count env of
1024 Just max | spec_count' > max
1025 -> WARN( True, msg ) return (nullUsage, spec_info)
1027 msg = vcat [ sep [ ptext (sLit "SpecConstr: specialisation of") <+> quotes (ppr fn)
1028 , nest 2 (ptext (sLit "limited by bound of")) <+> int max ]
1029 , ptext (sLit "Use -fspec-constr-count=n to set the bound")
1031 extra | not opt_PprStyle_Debug = ptext (sLit "Use -dppr-debug to see specialisations")
1032 | otherwise = ptext (sLit "Specialisations:") <+> ppr (pats ++ [p | OS p _ _ _ <- specs])
1034 _normal_case -> do {
1036 (spec_usgs, new_specs) <- mapAndUnzipM (spec_one env fn arg_bndrs body)
1037 (pats `zip` [spec_count..])
1039 ; let spec_usg = combineUsages spec_usgs
1040 (new_usg, mb_unspec')
1042 Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing)
1043 _ -> (spec_usg, mb_unspec)
1045 ; return (new_usg, SI (new_specs ++ specs) spec_count' mb_unspec') } }
1047 = return (nullUsage, spec_info) -- The boring case
1050 ---------------------
1052 -> OutId -- Function
1053 -> [Var] -- Lambda-binders of RHS; should match patterns
1054 -> CoreExpr -- Body of the original function
1056 -> UniqSM (ScUsage, OneSpec) -- Rule and binding
1058 -- spec_one creates a specialised copy of the function, together
1059 -- with a rule for using it. I'm very proud of how short this
1060 -- function is, considering what it does :-).
1066 f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
1067 [c::*, v::(b,c) are presumably bound by the (...) part]
1069 f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
1070 (...entire body of f...) [b -> (b,c),
1071 y -> ((:) (a,(b,c)) (x,v) hw)]
1073 RULE: forall b::* c::*, -- Note, *not* forall a, x
1077 f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
1080 spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)
1081 = do { -- Specialise the body
1082 let spec_env = extendScSubstList (extendScInScope env qvars)
1083 (arg_bndrs `zip` pats)
1084 ; (spec_usg, spec_body) <- scExpr spec_env body
1086 -- ; pprTrace "spec_one" (ppr fn <+> vcat [text "pats" <+> ppr pats,
1087 -- text "calls" <+> (ppr (scu_calls spec_usg))])
1090 -- And build the results
1091 ; spec_uniq <- getUniqueUs
1092 ; let (spec_lam_args, spec_call_args) = mkWorkerArgs qvars body_ty
1093 -- Usual w/w hack to avoid generating
1094 -- a spec_rhs of unlifted type and no args
1097 fn_loc = nameSrcSpan fn_name
1098 spec_occ = mkSpecOcc (nameOccName fn_name)
1099 rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number))
1100 spec_rhs = mkLams spec_lam_args spec_body
1101 spec_id = mkUserLocal spec_occ spec_uniq (mkPiTypes spec_lam_args body_ty) fn_loc
1102 body_ty = exprType spec_body
1103 rule_rhs = mkVarApps (Var spec_id) spec_call_args
1104 rule = mkLocalRule rule_name specConstrActivation fn_name qvars pats rule_rhs
1105 ; return (spec_usg, OS call_pat rule spec_id spec_rhs) }
1107 -- In which phase should the specialise-constructor rules be active?
1108 -- Originally I made them always-active, but Manuel found that
1109 -- this defeated some clever user-written rules. So Plan B
1110 -- is to make them active only in Phase 0; after all, currently,
1111 -- the specConstr transformation is only run after the simplifier
1112 -- has reached Phase 0. In general one would want it to be
1113 -- flag-controllable, but for now I'm leaving it baked in
1115 specConstrActivation :: Activation
1116 specConstrActivation = ActiveAfter 0 -- Baked in; see comments above
1119 %************************************************************************
1121 \subsection{Argument analysis}
1123 %************************************************************************
1125 This code deals with analysing call-site arguments to see whether
1126 they are constructor applications.
1130 type CallPat = ([Var], [CoreExpr]) -- Quantified variables and arguments
1133 callsToPats :: ScEnv -> [OneSpec] -> [ArgOcc] -> [Call] -> UniqSM (Bool, [CallPat])
1134 -- Result has no duplicate patterns,
1135 -- nor ones mentioned in done_pats
1136 -- Bool indicates that there was at least one boring pattern
1137 callsToPats env done_specs bndr_occs calls
1138 = do { mb_pats <- mapM (callToPats env bndr_occs) calls
1140 ; let good_pats :: [([Var], [CoreArg])]
1141 good_pats = catMaybes mb_pats
1142 done_pats = [p | OS p _ _ _ <- done_specs]
1143 is_done p = any (samePat p) done_pats
1145 ; return (any isNothing mb_pats,
1146 filterOut is_done (nubBy samePat good_pats)) }
1148 callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
1149 -- The [Var] is the variables to quantify over in the rule
1150 -- Type variables come first, since they may scope
1151 -- over the following term variables
1152 -- The [CoreExpr] are the argument patterns for the rule
1153 callToPats env bndr_occs (con_env, args)
1154 | length args < length bndr_occs -- Check saturated
1157 = do { let in_scope = substInScope (sc_subst env)
1158 ; prs <- argsToPats in_scope con_env (args `zip` bndr_occs)
1159 ; let (interesting_s, pats) = unzip prs
1160 pat_fvs = varSetElems (exprsFreeVars pats)
1161 qvars = filterOut (`elemInScopeSet` in_scope) pat_fvs
1162 -- Quantify over variables that are not in sccpe
1164 -- See Note [Shadowing] at the top
1166 (tvs, ids) = partition isTyVar qvars
1168 -- Put the type variables first; the type of a term
1169 -- variable may mention a type variable
1171 ; -- pprTrace "callToPats" (ppr args $$ ppr prs $$ ppr bndr_occs) $
1173 then return (Just (qvars', pats))
1174 else return Nothing }
1176 -- argToPat takes an actual argument, and returns an abstracted
1177 -- version, consisting of just the "constructor skeleton" of the
1178 -- argument, with non-constructor sub-expression replaced by new
1179 -- placeholder variables. For example:
1180 -- C a (D (f x) (g y)) ==> C p1 (D p2 p3)
1182 argToPat :: InScopeSet -- What's in scope at the fn defn site
1183 -> ValueEnv -- ValueEnv at the call site
1184 -> CoreArg -- A call arg (or component thereof)
1186 -> UniqSM (Bool, CoreArg)
1187 -- Returns (interesting, pat),
1188 -- where pat is the pattern derived from the argument
1189 -- intersting=True if the pattern is non-trivial (not a variable or type)
1190 -- E.g. x:xs --> (True, x:xs)
1191 -- f xs --> (False, w) where w is a fresh wildcard
1192 -- (f xs, 'c') --> (True, (w, 'c')) where w is a fresh wildcard
1193 -- \x. x+y --> (True, \x. x+y)
1194 -- lvl7 --> (True, lvl7) if lvl7 is bound
1195 -- somewhere further out
1197 argToPat _in_scope _val_env arg@(Type {}) _arg_occ
1198 = return (False, arg)
1200 argToPat in_scope val_env (Note _ arg) arg_occ
1201 = argToPat in_scope val_env arg arg_occ
1202 -- Note [Notes in call patterns]
1203 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1204 -- Ignore Notes. In particular, we want to ignore any InlineMe notes
1205 -- Perhaps we should not ignore profiling notes, but I'm going to
1206 -- ride roughshod over them all for now.
1207 --- See Note [Notes in RULE matching] in Rules
1209 argToPat in_scope val_env (Let _ arg) arg_occ
1210 = argToPat in_scope val_env arg arg_occ
1211 -- Look through let expressions
1212 -- e.g. f (let v = rhs in \y -> ...v...)
1213 -- Here we can specialise for f (\y -> ...)
1214 -- because the rule-matcher will look through the let.
1216 argToPat in_scope val_env (Cast arg co) arg_occ
1217 = do { (interesting, arg') <- argToPat in_scope val_env arg arg_occ
1218 ; let (ty1,ty2) = coercionKind co
1219 ; if not interesting then
1222 { -- Make a wild-card pattern for the coercion
1224 ; let co_name = mkSysTvName uniq (fsLit "sg")
1225 co_var = mkCoVar co_name (mkCoKind ty1 ty2)
1226 ; return (interesting, Cast arg' (mkTyVarTy co_var)) } }
1228 {- Disabling lambda specialisation for now
1229 It's fragile, and the spec_loop can be infinite
1230 argToPat in_scope val_env arg arg_occ
1232 = return (True, arg)
1234 is_value_lam (Lam v e) -- Spot a value lambda, even if
1235 | isId v = True -- it is inside a type lambda
1236 | otherwise = is_value_lam e
1237 is_value_lam other = False
1240 -- Check for a constructor application
1241 -- NB: this *precedes* the Var case, so that we catch nullary constrs
1242 argToPat in_scope val_env arg arg_occ
1243 | Just (ConVal dc args) <- isValue val_env arg
1245 ScrutOcc _ -> True -- Used only by case scrutinee
1246 BothOcc -> case arg of -- Used elsewhere
1247 App {} -> True -- see Note [Reboxing]
1249 _other -> False -- No point; the arg is not decomposed
1250 = do { args' <- argsToPats in_scope val_env (args `zip` conArgOccs arg_occ dc)
1251 ; return (True, mk_con_app dc (map snd args')) }
1253 -- Check if the argument is a variable that
1254 -- is in scope at the function definition site
1255 -- It's worth specialising on this if
1256 -- (a) it's used in an interesting way in the body
1257 -- (b) we know what its value is
1258 argToPat in_scope val_env (Var v) arg_occ
1259 | case arg_occ of { UnkOcc -> False; _other -> True }, -- (a)
1261 = return (True, Var v)
1264 | isLocalId v = v `elemInScopeSet` in_scope
1265 && isJust (lookupVarEnv val_env v)
1266 -- Local variables have values in val_env
1267 | otherwise = isValueUnfolding (idUnfolding v)
1268 -- Imports have unfoldings
1270 -- I'm really not sure what this comment means
1271 -- And by not wild-carding we tend to get forall'd
1272 -- variables that are in soope, which in turn can
1273 -- expose the weakness in let-matching
1274 -- See Note [Matching lets] in Rules
1276 -- Check for a variable bound inside the function.
1277 -- Don't make a wild-card, because we may usefully share
1278 -- e.g. f a = let x = ... in f (x,x)
1279 -- NB: this case follows the lambda and con-app cases!!
1280 -- argToPat _in_scope _val_env (Var v) _arg_occ
1281 -- = return (False, Var v)
1282 -- SLPJ : disabling this to avoid proliferation of versions
1283 -- also works badly when thinking about seeding the loop
1284 -- from the body of the let
1285 -- f x y = letrec g z = ... in g (x,y)
1286 -- We don't want to specialise for that *particular* x,y
1288 -- The default case: make a wild-card
1289 argToPat _in_scope _val_env arg _arg_occ
1290 = wildCardPat (exprType arg)
1292 wildCardPat :: Type -> UniqSM (Bool, CoreArg)
1293 wildCardPat ty = do { uniq <- getUniqueUs
1294 ; let id = mkSysLocal (fsLit "sc") uniq ty
1295 ; return (False, Var id) }
1297 argsToPats :: InScopeSet -> ValueEnv
1298 -> [(CoreArg, ArgOcc)]
1299 -> UniqSM [(Bool, CoreArg)]
1300 argsToPats in_scope val_env args
1303 do_one (arg,occ) = argToPat in_scope val_env arg occ
1308 isValue :: ValueEnv -> CoreExpr -> Maybe Value
1309 isValue _env (Lit lit)
1310 = Just (ConVal (LitAlt lit) [])
1313 | Just stuff <- lookupVarEnv env v
1314 = Just stuff -- You might think we could look in the idUnfolding here
1315 -- but that doesn't take account of which branch of a
1316 -- case we are in, which is the whole point
1318 | not (isLocalId v) && isCheapUnfolding unf
1319 = isValue env (unfoldingTemplate unf)
1322 -- However we do want to consult the unfolding
1323 -- as well, for let-bound constructors!
1325 isValue env (Lam b e)
1326 | isTyVar b = case isValue env e of
1327 Just _ -> Just LambdaVal
1329 | otherwise = Just LambdaVal
1331 isValue _env expr -- Maybe it's a constructor application
1332 | (Var fun, args) <- collectArgs expr
1333 = case isDataConWorkId_maybe fun of
1335 Just con | args `lengthAtLeast` dataConRepArity con
1336 -- Check saturated; might be > because the
1337 -- arity excludes type args
1338 -> Just (ConVal (DataAlt con) args)
1340 _other | valArgCount args < idArity fun
1341 -- Under-applied function
1342 -> Just LambdaVal -- Partial application
1346 isValue _env _expr = Nothing
1348 mk_con_app :: AltCon -> [CoreArg] -> CoreExpr
1349 mk_con_app (LitAlt lit) [] = Lit lit
1350 mk_con_app (DataAlt con) args = mkConApp con args
1351 mk_con_app _other _args = panic "SpecConstr.mk_con_app"
1353 samePat :: CallPat -> CallPat -> Bool
1354 samePat (vs1, as1) (vs2, as2)
1357 same (Var v1) (Var v2)
1358 | v1 `elem` vs1 = v2 `elem` vs2
1359 | v2 `elem` vs2 = False
1360 | otherwise = v1 == v2
1362 same (Lit l1) (Lit l2) = l1==l2
1363 same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2
1365 same (Type {}) (Type {}) = True -- Note [Ignore type differences]
1366 same (Note _ e1) e2 = same e1 e2 -- Ignore casts and notes
1367 same (Cast e1 _) e2 = same e1 e2
1368 same e1 (Note _ e2) = same e1 e2
1369 same e1 (Cast e2 _) = same e1 e2
1371 same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2)
1372 False -- Let, lambda, case should not occur
1373 bad (Case {}) = True
1379 Note [Ignore type differences]
1380 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1381 We do not want to generate specialisations where the call patterns
1382 differ only in their type arguments! Not only is it utterly useless,
1383 but it also means that (with polymorphic recursion) we can generate
1384 an infinite number of specialisations. Example is Data.Sequence.adjustTree,