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
14 specConstrProgram, SpecConstrAnnotation(..)
17 #include "HsVersions.h"
22 import CoreUnfold ( couldBeSmallEnoughToInline )
23 import CoreFVs ( exprsFreeVars )
25 import HscTypes ( ModGuts(..) )
26 import WwLib ( mkWorkerArgs )
27 import DataCon ( dataConTyCon, dataConRepArity, dataConUnivTyVars )
28 import TyCon ( TyCon )
29 import Literal ( literalType )
32 import Type hiding( substTy )
34 import MkId ( mkImpossibleExpr )
39 import DynFlags ( DynFlags(..) )
40 import StaticFlags ( opt_PprStyle_Debug )
41 import Maybes ( orElse, catMaybes, isJust, isNothing )
43 import DmdAnal ( both )
44 import Serialized ( deserializeWithData )
51 import Control.Monad ( zipWithM )
53 #if __GLASGOW_HASKELL__ > 609
54 import Data.Data ( Data, Typeable )
56 import Data.Generics ( Data, Typeable )
60 -----------------------------------------------------
62 -----------------------------------------------------
67 drop n (x:xs) = drop (n-1) xs
69 After the first time round, we could pass n unboxed. This happens in
70 numerical code too. Here's what it looks like in Core:
72 drop n xs = case xs of
77 _ -> drop (I# (n# -# 1#)) xs
79 Notice that the recursive call has an explicit constructor as argument.
80 Noticing this, we can make a specialised version of drop
82 RULE: drop (I# n#) xs ==> drop' n# xs
84 drop' n# xs = let n = I# n# in ...orig RHS...
86 Now the simplifier will apply the specialisation in the rhs of drop', giving
88 drop' n# xs = case xs of
92 _ -> drop (n# -# 1#) xs
96 We'd also like to catch cases where a parameter is carried along unchanged,
97 but evaluated each time round the loop:
99 f i n = if i>0 || i>n then i else f (i*2) n
101 Here f isn't strict in n, but we'd like to avoid evaluating it each iteration.
102 In Core, by the time we've w/wd (f is strict in i) we get
104 f i# n = case i# ># 0 of
106 True -> case n of n' { I# n# ->
109 True -> f (i# *# 2#) n'
111 At the call to f, we see that the argument, n is know to be (I# n#),
112 and n is evaluated elsewhere in the body of f, so we can play the same
118 We must be careful not to allocate the same constructor twice. Consider
119 f p = (...(case p of (a,b) -> e)...p...,
120 ...let t = (r,s) in ...t...(f t)...)
121 At the recursive call to f, we can see that t is a pair. But we do NOT want
122 to make a specialised copy:
123 f' a b = let p = (a,b) in (..., ...)
124 because now t is allocated by the caller, then r and s are passed to the
125 recursive call, which allocates the (r,s) pair again.
128 (a) the argument p is used in other than a case-scrutinsation way.
129 (b) the argument to the call is not a 'fresh' tuple; you have to
130 look into its unfolding to see that it's a tuple
132 Hence the "OR" part of Note [Good arguments] below.
134 ALTERNATIVE 2: pass both boxed and unboxed versions. This no longer saves
135 allocation, but does perhaps save evals. In the RULE we'd have
138 f (I# x#) = f' (I# x#) x#
140 If at the call site the (I# x) was an unfolding, then we'd have to
141 rely on CSE to eliminate the duplicate allocation.... This alternative
142 doesn't look attractive enough to pursue.
144 ALTERNATIVE 3: ignore the reboxing problem. The trouble is that
145 the conservative reboxing story prevents many useful functions from being
146 specialised. Example:
147 foo :: Maybe Int -> Int -> Int
149 foo x@(Just m) n = foo x (n-m)
150 Here the use of 'x' will clearly not require boxing in the specialised function.
152 The strictness analyser has the same problem, in fact. Example:
154 If we pass just 'a' and 'b' to the worker, it might need to rebox the
155 pair to create (a,b). A more sophisticated analysis might figure out
156 precisely the cases in which this could happen, but the strictness
157 analyser does no such analysis; it just passes 'a' and 'b', and hopes
160 So my current choice is to make SpecConstr similarly aggressive, and
161 ignore the bad potential of reboxing.
164 Note [Good arguments]
165 ~~~~~~~~~~~~~~~~~~~~~
168 * A self-recursive function. Ignore mutual recursion for now,
169 because it's less common, and the code is simpler for self-recursion.
173 a) At a recursive call, one or more parameters is an explicit
174 constructor application
176 That same parameter is scrutinised by a case somewhere in
177 the RHS of the function
181 b) At a recursive call, one or more parameters has an unfolding
182 that is an explicit constructor application
184 That same parameter is scrutinised by a case somewhere in
185 the RHS of the function
187 Those are the only uses of the parameter (see Note [Reboxing])
190 What to abstract over
191 ~~~~~~~~~~~~~~~~~~~~~
192 There's a bit of a complication with type arguments. If the call
195 f p = ...f ((:) [a] x xs)...
197 then our specialised function look like
199 f_spec x xs = let p = (:) [a] x xs in ....as before....
201 This only makes sense if either
202 a) the type variable 'a' is in scope at the top of f, or
203 b) the type variable 'a' is an argument to f (and hence fs)
205 Actually, (a) may hold for value arguments too, in which case
206 we may not want to pass them. Supose 'x' is in scope at f's
207 defn, but xs is not. Then we'd like
209 f_spec xs = let p = (:) [a] x xs in ....as before....
211 Similarly (b) may hold too. If x is already an argument at the
212 call, no need to pass it again.
214 Finally, if 'a' is not in scope at the call site, we could abstract
215 it as we do the term variables:
217 f_spec a x xs = let p = (:) [a] x xs in ...as before...
219 So the grand plan is:
221 * abstract the call site to a constructor-only pattern
222 e.g. C x (D (f p) (g q)) ==> C s1 (D s2 s3)
224 * Find the free variables of the abstracted pattern
226 * Pass these variables, less any that are in scope at
227 the fn defn. But see Note [Shadowing] below.
230 NOTICE that we only abstract over variables that are not in scope,
231 so we're in no danger of shadowing variables used in "higher up"
237 In this pass we gather up usage information that may mention variables
238 that are bound between the usage site and the definition site; or (more
239 seriously) may be bound to something different at the definition site.
242 f x = letrec g y v = let x = ...
245 Since 'x' is in scope at the call site, we may make a rewrite rule that
247 RULE forall a,b. g (a,b) x = ...
248 But this rule will never match, because it's really a different 'x' at
249 the call site -- and that difference will be manifest by the time the
250 simplifier gets to it. [A worry: the simplifier doesn't *guarantee*
251 no-shadowing, so perhaps it may not be distinct?]
253 Anyway, the rule isn't actually wrong, it's just not useful. One possibility
254 is to run deShadowBinds before running SpecConstr, but instead we run the
255 simplifier. That gives the simplest possible program for SpecConstr to
256 chew on; and it virtually guarantees no shadowing.
258 Note [Specialising for constant parameters]
259 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
260 This one is about specialising on a *constant* (but not necessarily
261 constructor) argument
263 foo :: Int -> (Int -> Int) -> Int
265 foo m f = foo (f m) (+1)
269 lvl_rmV :: GHC.Base.Int -> GHC.Base.Int
271 \ (ds_dlk :: GHC.Base.Int) ->
272 case ds_dlk of wild_alH { GHC.Base.I# x_alG ->
273 GHC.Base.I# (GHC.Prim.+# x_alG 1)
275 T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
278 \ (ww_sme :: GHC.Prim.Int#) (w_smg :: GHC.Base.Int -> GHC.Base.Int) ->
279 case ww_sme of ds_Xlw {
281 case w_smg (GHC.Base.I# ds_Xlw) of w1_Xmo { GHC.Base.I# ww1_Xmz ->
282 T.$wfoo ww1_Xmz lvl_rmV
287 The recursive call has lvl_rmV as its argument, so we could create a specialised copy
288 with that argument baked in; that is, not passed at all. Now it can perhaps be inlined.
290 When is this worth it? Call the constant 'lvl'
291 - If 'lvl' has an unfolding that is a constructor, see if the corresponding
292 parameter is scrutinised anywhere in the body.
294 - If 'lvl' has an unfolding that is a inlinable function, see if the corresponding
295 parameter is applied (...to enough arguments...?)
297 Also do this is if the function has RULES?
301 Note [Specialising for lambda parameters]
302 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
303 foo :: Int -> (Int -> Int) -> Int
305 foo m f = foo (f m) (\n -> n-m)
307 This is subtly different from the previous one in that we get an
308 explicit lambda as the argument:
310 T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
313 \ (ww_sm8 :: GHC.Prim.Int#) (w_sma :: GHC.Base.Int -> GHC.Base.Int) ->
314 case ww_sm8 of ds_Xlr {
316 case w_sma (GHC.Base.I# ds_Xlr) of w1_Xmf { GHC.Base.I# ww1_Xmq ->
319 (\ (n_ad3 :: GHC.Base.Int) ->
320 case n_ad3 of wild_alB { GHC.Base.I# x_alA ->
321 GHC.Base.I# (GHC.Prim.-# x_alA ds_Xlr)
327 I wonder if SpecConstr couldn't be extended to handle this? After all,
328 lambda is a sort of constructor for functions and perhaps it already
329 has most of the necessary machinery?
331 Furthermore, there's an immediate win, because you don't need to allocate the lamda
332 at the call site; and if perchance it's called in the recursive call, then you
333 may avoid allocating it altogether. Just like for constructors.
335 Looks cool, but probably rare...but it might be easy to implement.
338 Note [SpecConstr for casts]
339 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
342 data instance T Int = T Int
347 go (T n) = go (T (n-1))
349 The recursive call ends up looking like
350 go (T (I# ...) `cast` g)
351 So we want to spot the construtor application inside the cast.
352 That's why we have the Cast case in argToPat
354 Note [Local recursive groups]
355 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
356 For a *local* recursive group, we can see all the calls to the
357 function, so we seed the specialisation loop from the calls in the
358 body, not from the calls in the RHS. Consider:
360 bar m n = foo n (n,n) (n,n) (n,n) (n,n)
364 | n > 3000 = case p of { (p1,p2) -> foo (n-1) (p2,p1) q r s }
365 | n > 2000 = case q of { (q1,q2) -> foo (n-1) p (q2,q1) r s }
366 | n > 1000 = case r of { (r1,r2) -> foo (n-1) p q (r2,r1) s }
367 | otherwise = case s of { (s1,s2) -> foo (n-1) p q r (s2,s1) }
369 If we start with the RHSs of 'foo', we get lots and lots of specialisations,
370 most of which are not needed. But if we start with the (single) call
371 in the rhs of 'bar' we get exactly one fully-specialised copy, and all
372 the recursive calls go to this fully-specialised copy. Indeed, the original
373 function is later collected as dead code. This is very important in
374 specialising the loops arising from stream fusion, for example in NDP where
375 we were getting literally hundreds of (mostly unused) specialisations of
378 Note [Do not specialise diverging functions]
379 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
380 Specialising a function that just diverges is a waste of code.
381 Furthermore, it broke GHC (simpl014) thus:
383 f = \x. case x of (a,b) -> f x
384 If we specialise f we get
385 f = \x. case x of (a,b) -> fspec a b
386 But fspec doesn't have decent strictnes info. As it happened,
387 (f x) :: IO t, so the state hack applied and we eta expanded fspec,
388 and hence f. But now f's strictness is less than its arity, which
391 Note [Forcing specialisation]
392 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
393 With stream fusion and in other similar cases, we want to fully specialise
394 some (but not necessarily all!) loops regardless of their size and the
395 number of specialisations. We allow a library to specify this by annotating
396 a type with ForceSpecConstr and then adding a parameter of that type to the
397 loop. Here is a (simplified) example from the vector library:
399 data SPEC = SPEC | SPEC2
400 {-# ANN type SPEC ForceSpecConstr #-}
402 foldl :: (a -> b -> a) -> a -> Stream b -> a
404 foldl f z (Stream step s _) = foldl_loop SPEC z s
406 foldl_loop SPEC z s = case step s of
407 Yield x s' -> foldl_loop SPEC (f z x) s'
408 Skip -> foldl_loop SPEC z s'
411 SpecConstr will spot the SPEC parameter and always fully specialise
412 foldl_loop. Note that we can't just annotate foldl_loop since it isn't a
413 top-level function but even if we could, inlining etc. could easily drop the
414 annotation. We also have to prevent the SPEC argument from being removed by
415 w/w which is why SPEC is a sum type. This is all quite ugly; we ought to come
416 up with a better design.
418 ForceSpecConstr arguments are spotted in scExpr' and scTopBinds which then set
419 force_spec to True when calling specLoop. This flag makes specLoop and
420 specialise ignore specConstrCount and specConstrThreshold when deciding
421 whether to specialise a function.
423 -----------------------------------------------------
424 Stuff not yet handled
425 -----------------------------------------------------
427 Here are notes arising from Roman's work that I don't want to lose.
433 foo :: Int -> T Int -> Int
435 foo x t | even x = case t of { T n -> foo (x-n) t }
436 | otherwise = foo (x-1) t
438 SpecConstr does no specialisation, because the second recursive call
439 looks like a boxed use of the argument. A pity.
441 $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
443 \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) ->
444 case ww_sFo of ds_Xw6 [Just L] {
446 case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] {
447 __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq;
449 case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] ->
450 case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] ->
451 $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy
457 data a :*: b = !a :*: !b
460 foo :: (Int :*: T Int) -> Int
462 foo (x :*: t) | even x = case t of { T n -> foo ((x-n) :*: t) }
463 | otherwise = foo ((x-1) :*: t)
465 Very similar to the previous one, except that the parameters are now in
466 a strict tuple. Before SpecConstr, we have
468 $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
470 \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T
472 case ww_sFU of ds_Xws [Just L] {
474 case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] {
476 case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] ->
477 $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2 -- $wfoo1
480 case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] ->
481 case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] ->
482 $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB -- $wfoo2
486 We get two specialisations:
487 "SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#}
488 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB)
489 = Foo.$s$wfoo1 a_sFB sc_sGC ;
490 "SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#}
491 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp))
492 = Foo.$s$wfoo y_aFp sc_sGC ;
494 But perhaps the first one isn't good. After all, we know that tpl_B2 is
495 a T (I# x) really, because T is strict and Int has one constructor. (We can't
496 unbox the strict fields, becuase T is polymorphic!)
498 %************************************************************************
500 \subsection{Annotations}
502 %************************************************************************
504 Annotating a type with NoSpecConstr will make SpecConstr not specialise
505 for arguments of that type.
508 data SpecConstrAnnotation = NoSpecConstr | ForceSpecConstr
509 deriving( Data, Typeable, Eq )
512 %************************************************************************
514 \subsection{Top level wrapper stuff}
516 %************************************************************************
519 specConstrProgram :: ModGuts -> CoreM ModGuts
520 specConstrProgram guts
522 dflags <- getDynFlags
523 us <- getUniqueSupplyM
524 annos <- getFirstAnnotations deserializeWithData guts
525 let binds' = fst $ initUs us (go (initScEnv dflags annos) (mg_binds guts))
526 return (guts { mg_binds = binds' })
529 go env (bind:binds) = do (env', bind') <- scTopBind env bind
530 binds' <- go env' binds
531 return (bind' : binds')
535 %************************************************************************
537 \subsection{Environment: goes downwards}
539 %************************************************************************
542 data ScEnv = SCE { sc_size :: Maybe Int, -- Size threshold
543 sc_count :: Maybe Int, -- Max # of specialisations for any one fn
544 -- See Note [Avoiding exponential blowup]
546 sc_subst :: Subst, -- Current substitution
547 -- Maps InIds to OutExprs
549 sc_how_bound :: HowBoundEnv,
550 -- Binds interesting non-top-level variables
551 -- Domain is OutVars (*after* applying the substitution)
554 -- Domain is OutIds (*after* applying the substitution)
555 -- Used even for top-level bindings (but not imported ones)
557 sc_annotations :: UniqFM SpecConstrAnnotation
560 ---------------------
561 -- As we go, we apply a substitution (sc_subst) to the current term
562 type InExpr = CoreExpr -- _Before_ applying the subst
565 type OutExpr = CoreExpr -- _After_ applying the subst
569 ---------------------
570 type HowBoundEnv = VarEnv HowBound -- Domain is OutVars
572 ---------------------
573 type ValueEnv = IdEnv Value -- Domain is OutIds
574 data Value = ConVal AltCon [CoreArg] -- _Saturated_ constructors
575 | LambdaVal -- Inlinable lambdas or PAPs
577 instance Outputable Value where
578 ppr (ConVal con args) = ppr con <+> interpp'SP args
579 ppr LambdaVal = ptext (sLit "<Lambda>")
581 ---------------------
582 initScEnv :: DynFlags -> UniqFM SpecConstrAnnotation -> ScEnv
583 initScEnv dflags anns
584 = SCE { sc_size = specConstrThreshold dflags,
585 sc_count = specConstrCount dflags,
586 sc_subst = emptySubst,
587 sc_how_bound = emptyVarEnv,
588 sc_vals = emptyVarEnv,
589 sc_annotations = anns }
591 data HowBound = RecFun -- These are the recursive functions for which
592 -- we seek interesting call patterns
594 | RecArg -- These are those functions' arguments, or their sub-components;
595 -- we gather occurrence information for these
597 instance Outputable HowBound where
598 ppr RecFun = text "RecFun"
599 ppr RecArg = text "RecArg"
601 lookupHowBound :: ScEnv -> Id -> Maybe HowBound
602 lookupHowBound env id = lookupVarEnv (sc_how_bound env) id
604 scSubstId :: ScEnv -> Id -> CoreExpr
605 scSubstId env v = lookupIdSubst (text "scSubstId") (sc_subst env) v
607 scSubstTy :: ScEnv -> Type -> Type
608 scSubstTy env ty = substTy (sc_subst env) ty
610 zapScSubst :: ScEnv -> ScEnv
611 zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) }
613 extendScInScope :: ScEnv -> [Var] -> ScEnv
614 -- Bring the quantified variables into scope
615 extendScInScope env qvars = env { sc_subst = extendInScopeList (sc_subst env) qvars }
617 -- Extend the substitution
618 extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv
619 extendScSubst env var expr = env { sc_subst = extendSubst (sc_subst env) var expr }
621 extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv
622 extendScSubstList env prs = env { sc_subst = extendSubstList (sc_subst env) prs }
624 extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv
625 extendHowBound env bndrs how_bound
626 = env { sc_how_bound = extendVarEnvList (sc_how_bound env)
627 [(bndr,how_bound) | bndr <- bndrs] }
629 extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var])
630 extendBndrsWith how_bound env bndrs
631 = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndrs')
633 (subst', bndrs') = substBndrs (sc_subst env) bndrs
634 hb_env' = sc_how_bound env `extendVarEnvList`
635 [(bndr,how_bound) | bndr <- bndrs']
637 extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var)
638 extendBndrWith how_bound env bndr
639 = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndr')
641 (subst', bndr') = substBndr (sc_subst env) bndr
642 hb_env' = extendVarEnv (sc_how_bound env) bndr' how_bound
644 extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var])
645 extendRecBndrs env bndrs = (env { sc_subst = subst' }, bndrs')
647 (subst', bndrs') = substRecBndrs (sc_subst env) bndrs
649 extendBndr :: ScEnv -> Var -> (ScEnv, Var)
650 extendBndr env bndr = (env { sc_subst = subst' }, bndr')
652 (subst', bndr') = substBndr (sc_subst env) bndr
654 extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv
655 extendValEnv env _ Nothing = env
656 extendValEnv env id (Just cv) = env { sc_vals = extendVarEnv (sc_vals env) id cv }
658 extendCaseBndrs :: ScEnv -> Id -> AltCon -> [Var] -> (ScEnv, [Var])
662 -- we want to bind b, to (C x y)
663 -- NB1: Extends only the sc_vals part of the envt
664 -- NB2: Kill the dead-ness info on the pattern binders x,y, since
665 -- they are potentially made alive by the [b -> C x y] binding
666 extendCaseBndrs env case_bndr con alt_bndrs
667 | isDeadBinder case_bndr
670 = (env1, map zap alt_bndrs)
671 -- NB: We used to bind v too, if scrut = (Var v); but
672 -- the simplifer has already done this so it seems
673 -- redundant to do so here
675 -- Var v -> extendValEnv env1 v cval
678 zap v | isTyVar v = v -- See NB2 above
679 | otherwise = zapIdOccInfo v
680 env1 = extendValEnv env case_bndr cval
683 LitAlt {} -> Just (ConVal con [])
684 DataAlt {} -> Just (ConVal con vanilla_args)
686 vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
687 varsToCoreExprs alt_bndrs
689 ignoreTyCon :: ScEnv -> TyCon -> Bool
690 ignoreTyCon env tycon
691 = lookupUFM (sc_annotations env) tycon == Just NoSpecConstr
693 ignoreType :: ScEnv -> Type -> Bool
695 = case splitTyConApp_maybe ty of
696 Just (tycon, _) -> ignoreTyCon env tycon
699 ignoreAltCon :: ScEnv -> AltCon -> Bool
700 ignoreAltCon env (DataAlt dc) = ignoreTyCon env (dataConTyCon dc)
701 ignoreAltCon env (LitAlt lit) = ignoreType env (literalType lit)
702 ignoreAltCon _ DEFAULT = True
704 forceSpecBndr :: ScEnv -> Var -> Bool
705 forceSpecBndr env var = forceSpecFunTy env . snd . splitForAllTys . varType $ var
707 forceSpecFunTy :: ScEnv -> Type -> Bool
708 forceSpecFunTy env = any (forceSpecArgTy env) . fst . splitFunTys
710 forceSpecArgTy :: ScEnv -> Type -> Bool
711 forceSpecArgTy env ty
712 | Just ty' <- coreView ty = forceSpecArgTy env ty'
714 forceSpecArgTy env ty
715 | Just (tycon, tys) <- splitTyConApp_maybe ty
717 = lookupUFM (sc_annotations env) tycon == Just ForceSpecConstr
718 || any (forceSpecArgTy env) tys
720 forceSpecArgTy _ _ = False
722 decreaseSpecCount :: ScEnv -> Int -> ScEnv
723 -- See Note [Avoiding exponential blowup]
724 decreaseSpecCount env n_specs
725 = env { sc_count = case sc_count env of
727 Just n -> Just (n `div` (n_specs + 1)) }
728 -- The "+1" takes account of the original function;
729 -- See Note [Avoiding exponential blowup]
732 Note [Avoiding exponential blowup]
733 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
734 The sc_count field of the ScEnv says how many times we are prepared to
735 duplicate a single function. But we must take care with recursive
736 specialiations. Consider
738 let $j1 = let $j2 = let $j3 = ...
746 If we specialise $j1 then in each specialisation (as well as the original)
747 we can specialise $j2, and similarly $j3. Even if we make just *one*
748 specialisation of each, becuase we also have the original we'll get 2^n
749 copies of $j3, which is not good.
751 So when recursively specialising we divide the sc_count by the number of
752 copies we are making at this level, including the original.
755 %************************************************************************
757 \subsection{Usage information: flows upwards}
759 %************************************************************************
764 scu_calls :: CallEnv, -- Calls
765 -- The functions are a subset of the
766 -- RecFuns in the ScEnv
768 scu_occs :: !(IdEnv ArgOcc) -- Information on argument occurrences
769 } -- The domain is OutIds
771 type CallEnv = IdEnv [Call]
772 type Call = (ValueEnv, [CoreArg])
773 -- The arguments of the call, together with the
774 -- env giving the constructor bindings at the call site
777 nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv }
779 combineCalls :: CallEnv -> CallEnv -> CallEnv
780 combineCalls = plusVarEnv_C (++)
782 combineUsage :: ScUsage -> ScUsage -> ScUsage
783 combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2),
784 scu_occs = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) }
786 combineUsages :: [ScUsage] -> ScUsage
787 combineUsages [] = nullUsage
788 combineUsages us = foldr1 combineUsage us
790 lookupOcc :: ScUsage -> OutVar -> (ScUsage, ArgOcc)
791 lookupOcc (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndr
792 = (SCU {scu_calls = sc_calls, scu_occs = delVarEnv sc_occs bndr},
793 lookupVarEnv sc_occs bndr `orElse` NoOcc)
795 lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc])
796 lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs
797 = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs},
798 [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs])
800 data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument
801 | UnkOcc -- Used in some unknown way
803 | ScrutOcc (UniqFM [ArgOcc]) -- See Note [ScrutOcc]
805 | BothOcc -- Definitely taken apart, *and* perhaps used in some other way
809 An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing,
810 is *only* taken apart or applied.
812 Functions, literal: ScrutOcc emptyUFM
813 Data constructors: ScrutOcc subs,
815 where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components,
816 The domain of the UniqFM is the Unique of the data constructor
818 The [ArgOcc] is the occurrences of the *pattern-bound* components
819 of the data structure. E.g.
820 data T a = forall b. MkT a b (b->a)
821 A pattern binds b, x::a, y::b, z::b->a, but not 'a'!
825 instance Outputable ArgOcc where
826 ppr (ScrutOcc xs) = ptext (sLit "scrut-occ") <> ppr xs
827 ppr UnkOcc = ptext (sLit "unk-occ")
828 ppr BothOcc = ptext (sLit "both-occ")
829 ppr NoOcc = ptext (sLit "no-occ")
831 -- Experimentally, this vesion of combineOcc makes ScrutOcc "win", so
832 -- that if the thing is scrutinised anywhere then we get to see that
833 -- in the overall result, even if it's also used in a boxed way
834 -- This might be too agressive; see Note [Reboxing] Alternative 3
835 combineOcc :: ArgOcc -> ArgOcc -> ArgOcc
836 combineOcc NoOcc occ = occ
837 combineOcc occ NoOcc = occ
838 combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys)
839 combineOcc _occ (ScrutOcc ys) = ScrutOcc ys
840 combineOcc (ScrutOcc xs) _occ = ScrutOcc xs
841 combineOcc UnkOcc UnkOcc = UnkOcc
842 combineOcc _ _ = BothOcc
844 combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]
845 combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys
847 setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage
848 -- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee
849 -- is a variable, and an interesting variable
850 setScrutOcc env usg (Cast e _) occ = setScrutOcc env usg e occ
851 setScrutOcc env usg (Note _ e) occ = setScrutOcc env usg e occ
852 setScrutOcc env usg (Var v) occ
853 | Just RecArg <- lookupHowBound env v = usg { scu_occs = extendVarEnv (scu_occs usg) v occ }
855 setScrutOcc _env usg _other _occ -- Catch-all
858 conArgOccs :: ArgOcc -> AltCon -> [ArgOcc]
859 -- Find usage of components of data con; returns [UnkOcc...] if unknown
860 -- See Note [ScrutOcc] for the extra UnkOccs in the vanilla datacon case
862 conArgOccs (ScrutOcc fm) (DataAlt dc)
863 | Just pat_arg_occs <- lookupUFM fm dc
864 = [UnkOcc | _ <- dataConUnivTyVars dc] ++ pat_arg_occs
866 conArgOccs _other _con = repeat UnkOcc
869 %************************************************************************
871 \subsection{The main recursive function}
873 %************************************************************************
875 The main recursive function gathers up usage information, and
876 creates specialised versions of functions.
879 scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
880 -- The unique supply is needed when we invent
881 -- a new name for the specialised function and its args
883 scExpr env e = scExpr' env e
886 scExpr' env (Var v) = case scSubstId env v of
887 Var v' -> return (varUsage env v' UnkOcc, Var v')
888 e' -> scExpr (zapScSubst env) e'
890 scExpr' env (Type t) = return (nullUsage, Type (scSubstTy env t))
891 scExpr' _ e@(Lit {}) = return (nullUsage, e)
892 scExpr' env (Note n e) = do (usg,e') <- scExpr env e
893 return (usg, Note n e')
894 scExpr' env (Cast e co) = do (usg, e') <- scExpr env e
895 return (usg, Cast e' (scSubstTy env co))
896 scExpr' env e@(App _ _) = scApp env (collectArgs e)
897 scExpr' env (Lam b e) = do let (env', b') = extendBndr env b
898 (usg, e') <- scExpr env' e
899 return (usg, Lam b' e')
901 scExpr' env (Case scrut b ty alts)
902 = do { (scrut_usg, scrut') <- scExpr env scrut
903 ; case isValue (sc_vals env) scrut' of
904 Just (ConVal con args) -> sc_con_app con args scrut'
905 _other -> sc_vanilla scrut_usg scrut'
908 sc_con_app con args scrut' -- Known constructor; simplify
909 = do { let (_, bs, rhs) = findAlt con alts
910 `orElse` (DEFAULT, [], mkImpossibleExpr (coreAltsType alts))
911 alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)
912 ; scExpr alt_env' rhs }
914 sc_vanilla scrut_usg scrut' -- Normal case
915 = do { let (alt_env,b') = extendBndrWith RecArg env b
916 -- Record RecArg for the components
918 ; (alt_usgs, alt_occs, alts')
919 <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts
921 ; let (alt_usg, b_occ) = lookupOcc (combineUsages alt_usgs) b'
922 scrut_occ = foldr combineOcc b_occ alt_occs
923 scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ
924 -- The combined usage of the scrutinee is given
925 -- by scrut_occ, which is passed to scScrut, which
926 -- in turn treats a bare-variable scrutinee specially
928 ; return (alt_usg `combineUsage` scrut_usg',
929 Case scrut' b' (scSubstTy env ty) alts') }
931 sc_alt env _scrut' b' (con,bs,rhs)
932 = do { let (env1, bs1) = extendBndrsWith RecArg env bs
933 (env2, bs2) = extendCaseBndrs env1 b' con bs1
934 ; (usg,rhs') <- scExpr env2 rhs
935 ; let (usg', arg_occs) = lookupOccs usg bs2
936 scrut_occ = case con of
937 DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)
938 _ -> ScrutOcc emptyUFM
939 ; return (usg', scrut_occ, (con, bs2, rhs')) }
941 scExpr' env (Let (NonRec bndr rhs) body)
942 | isTyVar bndr -- Type-lets may be created by doBeta
943 = scExpr' (extendScSubst env bndr rhs) body
945 | otherwise -- Note [Local let bindings]
946 = do { let (body_env, bndr') = extendBndr env bndr
947 body_env2 = extendHowBound body_env [bndr'] RecFun
948 ; (body_usg, body') <- scExpr body_env2 body
950 ; (rhs_usg, rhs_info) <- scRecRhs env (bndr',rhs)
952 -- NB: We don't use the ForceSpecConstr mechanism (see
953 -- Note [Forcing specialisation]) for non-recursive bindings
954 -- at the moment. I'm not sure if this is the right thing to do.
955 ; let force_spec = False
956 ; (spec_usg, specs) <- specialise env force_spec
959 (SI [] 0 (Just rhs_usg))
961 ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' }
962 `combineUsage` spec_usg,
963 mkLets [NonRec b r | (b,r) <- specInfoBinds rhs_info specs] body')
967 -- A *local* recursive group: see Note [Local recursive groups]
968 scExpr' env (Let (Rec prs) body)
969 = do { let (bndrs,rhss) = unzip prs
970 (rhs_env1,bndrs') = extendRecBndrs env bndrs
971 rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
972 force_spec = any (forceSpecBndr env) bndrs'
973 -- Note [Forcing specialisation]
975 ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
976 ; (body_usg, body') <- scExpr rhs_env2 body
978 -- NB: start specLoop from body_usg
979 ; (spec_usg, specs) <- specLoop rhs_env2 force_spec
980 (scu_calls body_usg) rhs_infos nullUsage
981 [SI [] 0 (Just usg) | usg <- rhs_usgs]
982 -- Do not unconditionally use rhs_usgs.
983 -- Instead use them only if we find an unspecialised call
984 -- See Note [Local recursive groups]
986 ; let all_usg = spec_usg `combineUsage` body_usg
987 bind' = Rec (concat (zipWith specInfoBinds rhs_infos specs))
989 ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' },
993 Note [Local let bindings]
994 ~~~~~~~~~~~~~~~~~~~~~~~~~
995 It is not uncommon to find this
997 let $j = \x. <blah> in ...$j True...$j True...
999 Here $j is an arbitrary let-bound function, but it often comes up for
1000 join points. We might like to specialise $j for its call patterns.
1001 Notice the difference from a letrec, where we look for call patterns
1002 in the *RHS* of the function. Here we look for call patterns in the
1005 At one point I predicated this on the RHS mentioning the outer
1006 recursive function, but that's not essential and might even be
1007 harmful. I'm not sure.
1011 scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)
1013 scApp env (Var fn, args) -- Function is a variable
1014 = ASSERT( not (null args) )
1015 do { args_w_usgs <- mapM (scExpr env) args
1016 ; let (arg_usgs, args') = unzip args_w_usgs
1017 arg_usg = combineUsages arg_usgs
1018 ; case scSubstId env fn of
1019 fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args')
1020 -- Do beta-reduction and try again
1022 Var fn' -> return (arg_usg `combineUsage` fn_usg, mkApps (Var fn') args')
1024 fn_usg = case lookupHowBound env fn' of
1025 Just RecFun -> SCU { scu_calls = unitVarEnv fn' [(sc_vals env, args')],
1026 scu_occs = emptyVarEnv }
1027 Just RecArg -> SCU { scu_calls = emptyVarEnv,
1028 scu_occs = unitVarEnv fn' (ScrutOcc emptyUFM) }
1029 Nothing -> nullUsage
1032 other_fn' -> return (arg_usg, mkApps other_fn' args') }
1033 -- NB: doing this ignores any usage info from the substituted
1034 -- function, but I don't think that matters. If it does
1037 doBeta :: OutExpr -> [OutExpr] -> OutExpr
1038 -- ToDo: adjust for System IF
1039 doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args)
1040 doBeta fn args = mkApps fn args
1042 -- The function is almost always a variable, but not always.
1043 -- In particular, if this pass follows float-in,
1044 -- which it may, we can get
1045 -- (let f = ...f... in f) arg1 arg2
1046 scApp env (other_fn, args)
1047 = do { (fn_usg, fn') <- scExpr env other_fn
1048 ; (arg_usgs, args') <- mapAndUnzipM (scExpr env) args
1049 ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') }
1051 ----------------------
1052 scTopBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind)
1053 scTopBind env (Rec prs)
1054 | Just threshold <- sc_size env
1056 , not (all (couldBeSmallEnoughToInline threshold) rhss)
1057 -- No specialisation
1058 = do { let (rhs_env,bndrs') = extendRecBndrs env bndrs
1059 ; (_, rhss') <- mapAndUnzipM (scExpr rhs_env) rhss
1060 ; return (rhs_env, Rec (bndrs' `zip` rhss')) }
1061 | otherwise -- Do specialisation
1062 = do { let (rhs_env1,bndrs') = extendRecBndrs env bndrs
1063 rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
1065 ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
1066 ; let rhs_usg = combineUsages rhs_usgs
1068 ; (_, specs) <- specLoop rhs_env2 force_spec
1069 (scu_calls rhs_usg) rhs_infos nullUsage
1070 [SI [] 0 Nothing | _ <- bndrs]
1072 ; return (rhs_env1, -- For the body of the letrec, delete the RecFun business
1073 Rec (concat (zipWith specInfoBinds rhs_infos specs))) }
1075 (bndrs,rhss) = unzip prs
1076 force_spec = any (forceSpecBndr env) bndrs
1077 -- Note [Forcing specialisation]
1079 scTopBind env (NonRec bndr rhs)
1080 = do { (_, rhs') <- scExpr env rhs
1081 ; let (env1, bndr') = extendBndr env bndr
1082 env2 = extendValEnv env1 bndr' (isValue (sc_vals env) rhs')
1083 ; return (env2, NonRec bndr' rhs') }
1085 ----------------------
1086 scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM (ScUsage, RhsInfo)
1087 scRecRhs env (bndr,rhs)
1088 = do { let (arg_bndrs,body) = collectBinders rhs
1089 (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs
1090 ; (body_usg, body') <- scExpr body_env body
1091 ; let (rhs_usg, arg_occs) = lookupOccs body_usg arg_bndrs'
1092 ; return (rhs_usg, RI bndr (mkLams arg_bndrs' body')
1093 arg_bndrs body arg_occs) }
1094 -- The arg_occs says how the visible,
1095 -- lambda-bound binders of the RHS are used
1096 -- (including the TyVar binders)
1097 -- Two pats are the same if they match both ways
1099 ----------------------
1100 specInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)]
1101 specInfoBinds (RI fn new_rhs _ _ _) (SI specs _ _)
1102 = [(id,rhs) | OS _ _ id rhs <- specs] ++
1103 [(fn `addIdSpecialisations` rules, new_rhs)]
1105 rules = [r | OS _ r _ _ <- specs]
1107 ----------------------
1108 varUsage :: ScEnv -> OutVar -> ArgOcc -> ScUsage
1110 | Just RecArg <- lookupHowBound env v = SCU { scu_calls = emptyVarEnv
1111 , scu_occs = unitVarEnv v use }
1112 | otherwise = nullUsage
1116 %************************************************************************
1118 The specialiser itself
1120 %************************************************************************
1123 data RhsInfo = RI OutId -- The binder
1124 OutExpr -- The new RHS
1125 [InVar] InExpr -- The *original* RHS (\xs.body)
1126 -- Note [Specialise original body]
1127 [ArgOcc] -- Info on how the xs occur in body
1129 data SpecInfo = SI [OneSpec] -- The specialisations we have generated
1131 Int -- Length of specs; used for numbering them
1133 (Maybe ScUsage) -- Nothing => we have generated specialisations
1134 -- from calls in the *original* RHS
1135 -- Just cs => we haven't, and this is the usage
1136 -- of the original RHS
1137 -- See Note [Local recursive groups]
1139 -- One specialisation: Rule plus definition
1140 data OneSpec = OS CallPat -- Call pattern that generated this specialisation
1141 CoreRule -- Rule connecting original id with the specialisation
1142 OutId OutExpr -- Spec id + its rhs
1146 -> Bool -- force specialisation?
1147 -- Note [Forcing specialisation]
1150 -> ScUsage -> [SpecInfo] -- One per binder; acccumulating parameter
1151 -> UniqSM (ScUsage, [SpecInfo]) -- ...ditto...
1152 specLoop env force_spec all_calls rhs_infos usg_so_far specs_so_far
1153 = do { specs_w_usg <- zipWithM (specialise env force_spec all_calls) rhs_infos specs_so_far
1154 ; let (new_usg_s, all_specs) = unzip specs_w_usg
1155 new_usg = combineUsages new_usg_s
1156 new_calls = scu_calls new_usg
1157 all_usg = usg_so_far `combineUsage` new_usg
1158 ; if isEmptyVarEnv new_calls then
1159 return (all_usg, all_specs)
1161 specLoop env force_spec new_calls rhs_infos all_usg all_specs }
1165 -> Bool -- force specialisation?
1166 -- Note [Forcing specialisation]
1167 -> CallEnv -- Info on calls
1169 -> SpecInfo -- Original RHS plus patterns dealt with
1170 -> UniqSM (ScUsage, SpecInfo) -- New specialised versions and their usage
1172 -- Note: the rhs here is the optimised version of the original rhs
1173 -- So when we make a specialised copy of the RHS, we're starting
1174 -- from an RHS whose nested functions have been optimised already.
1176 specialise env force_spec bind_calls (RI fn _ arg_bndrs body arg_occs)
1177 spec_info@(SI specs spec_count mb_unspec)
1178 | not (isBottomingId fn) -- Note [Do not specialise diverging functions]
1179 , notNull arg_bndrs -- Only specialise functions
1180 , Just all_calls <- lookupVarEnv bind_calls fn
1181 = do { (boring_call, pats) <- callsToPats env specs arg_occs all_calls
1182 -- ; pprTrace "specialise" (vcat [ ppr fn <+> text "with" <+> int (length pats) <+> text "good patterns"
1183 -- , text "arg_occs" <+> ppr arg_occs
1184 -- , text "calls" <+> ppr all_calls
1185 -- , text "good pats" <+> ppr pats]) $
1188 -- Bale out if too many specialisations
1189 ; let n_pats = length pats
1190 spec_count' = n_pats + spec_count
1191 ; case sc_count env of
1192 Just max | not force_spec && spec_count' > max
1193 -> pprTrace "SpecConstr" msg $
1194 return (nullUsage, spec_info)
1196 msg = vcat [ sep [ ptext (sLit "Function") <+> quotes (ppr fn)
1197 , nest 2 (ptext (sLit "has") <+>
1198 speakNOf spec_count' (ptext (sLit "call pattern")) <> comma <+>
1199 ptext (sLit "but the limit is") <+> int max) ]
1200 , ptext (sLit "Use -fspec-constr-count=n to set the bound")
1202 extra | not opt_PprStyle_Debug = ptext (sLit "Use -dppr-debug to see specialisations")
1203 | otherwise = ptext (sLit "Specialisations:") <+> ppr (pats ++ [p | OS p _ _ _ <- specs])
1205 _normal_case -> do {
1207 let spec_env = decreaseSpecCount env n_pats
1208 ; (spec_usgs, new_specs) <- mapAndUnzipM (spec_one spec_env fn arg_bndrs body)
1209 (pats `zip` [spec_count..])
1210 -- See Note [Specialise original body]
1212 ; let spec_usg = combineUsages spec_usgs
1213 (new_usg, mb_unspec')
1215 Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing)
1216 _ -> (spec_usg, mb_unspec)
1218 ; return (new_usg, SI (new_specs ++ specs) spec_count' mb_unspec') } }
1220 = return (nullUsage, spec_info) -- The boring case
1223 ---------------------
1225 -> OutId -- Function
1226 -> [InVar] -- Lambda-binders of RHS; should match patterns
1227 -> InExpr -- Body of the original function
1229 -> UniqSM (ScUsage, OneSpec) -- Rule and binding
1231 -- spec_one creates a specialised copy of the function, together
1232 -- with a rule for using it. I'm very proud of how short this
1233 -- function is, considering what it does :-).
1239 f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
1240 [c::*, v::(b,c) are presumably bound by the (...) part]
1242 f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
1243 (...entire body of f...) [b -> (b,c),
1244 y -> ((:) (a,(b,c)) (x,v) hw)]
1246 RULE: forall b::* c::*, -- Note, *not* forall a, x
1250 f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
1253 spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)
1254 = do { spec_uniq <- getUniqueUs
1255 ; let spec_env = extendScSubstList (extendScInScope env qvars)
1256 (arg_bndrs `zip` pats)
1258 fn_loc = nameSrcSpan fn_name
1259 spec_occ = mkSpecOcc (nameOccName fn_name)
1260 rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number))
1261 spec_name = mkInternalName spec_uniq spec_occ fn_loc
1262 -- ; pprTrace "{spec_one" (ppr (sc_count env) <+> ppr fn <+> ppr pats <+> text "-->" <+> ppr spec_name) $
1265 -- Specialise the body
1266 ; (spec_usg, spec_body) <- scExpr spec_env body
1268 -- ; pprTrace "done spec_one}" (ppr fn) $
1271 -- And build the results
1272 ; let spec_id = mkLocalId spec_name (mkPiTypes spec_lam_args body_ty)
1273 `setIdStrictness` spec_str -- See Note [Transfer strictness]
1274 `setIdArity` count isId spec_lam_args
1275 spec_str = calcSpecStrictness fn spec_lam_args pats
1276 (spec_lam_args, spec_call_args) = mkWorkerArgs qvars body_ty
1277 -- Usual w/w hack to avoid generating
1278 -- a spec_rhs of unlifted type and no args
1280 spec_rhs = mkLams spec_lam_args spec_body
1281 body_ty = exprType spec_body
1282 rule_rhs = mkVarApps (Var spec_id) spec_call_args
1283 inline_act = idInlineActivation fn
1284 rule = mkLocalRule rule_name inline_act fn_name qvars pats rule_rhs
1285 ; return (spec_usg, OS call_pat rule spec_id spec_rhs) }
1287 calcSpecStrictness :: Id -- The original function
1288 -> [Var] -> [CoreExpr] -- Call pattern
1289 -> StrictSig -- Strictness of specialised thing
1290 -- See Note [Transfer strictness]
1291 calcSpecStrictness fn qvars pats
1292 = StrictSig (mkTopDmdType spec_dmds TopRes)
1294 spec_dmds = [ lookupVarEnv dmd_env qv `orElse` lazyDmd | qv <- qvars, isId qv ]
1295 StrictSig (DmdType _ dmds _) = idStrictness fn
1297 dmd_env = go emptyVarEnv dmds pats
1299 go env ds (Type {} : pats) = go env ds pats
1300 go env (d:ds) (pat : pats) = go (go_one env d pat) ds pats
1303 go_one env d (Var v) = extendVarEnv_C both env v d
1304 go_one env (Box d) e = go_one env d e
1305 go_one env (Eval (Prod ds)) e
1306 | (Var _, args) <- collectArgs e = go env ds args
1307 go_one env _ _ = env
1311 Note [Specialise original body]
1312 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1313 The RhsInfo for a binding keeps the *original* body of the binding. We
1314 must specialise that, *not* the result of applying specExpr to the RHS
1315 (which is also kept in RhsInfo). Otherwise we end up specialising a
1316 specialised RHS, and that can lead directly to exponential behaviour.
1318 Note [Transfer activation]
1319 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1320 In which phase should the specialise-constructor rules be active?
1321 Originally I made them always-active, but Manuel found that this
1322 defeated some clever user-written rules. Then I made them active only
1323 in Phase 0; after all, currently, the specConstr transformation is
1324 only run after the simplifier has reached Phase 0, but that meant
1325 that specialisations didn't fire inside wrappers; see test
1326 simplCore/should_compile/spec-inline.
1328 So now I just use the inline-activation of the parent Id, as the
1329 activation for the specialiation RULE, just like the main specialiser;
1330 see Note [Auto-specialisation and RULES] in Specialise.
1333 Note [Transfer strictness]
1334 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1335 We must transfer strictness information from the original function to
1336 the specialised one. Suppose, for example
1339 and a RULE f (a:as) b = f_spec a as b
1341 Now we want f_spec to have strictess LLS, otherwise we'll use call-by-need
1342 when calling f_spec instead of call-by-value. And that can result in
1343 unbounded worsening in space (cf the classic foldl vs foldl')
1345 See Trac #3437 for a good example.
1347 The function calcSpecStrictness performs the calculation.
1350 %************************************************************************
1352 \subsection{Argument analysis}
1354 %************************************************************************
1356 This code deals with analysing call-site arguments to see whether
1357 they are constructor applications.
1361 type CallPat = ([Var], [CoreExpr]) -- Quantified variables and arguments
1364 callsToPats :: ScEnv -> [OneSpec] -> [ArgOcc] -> [Call] -> UniqSM (Bool, [CallPat])
1365 -- Result has no duplicate patterns,
1366 -- nor ones mentioned in done_pats
1367 -- Bool indicates that there was at least one boring pattern
1368 callsToPats env done_specs bndr_occs calls
1369 = do { mb_pats <- mapM (callToPats env bndr_occs) calls
1371 ; let good_pats :: [([Var], [CoreArg])]
1372 good_pats = catMaybes mb_pats
1373 done_pats = [p | OS p _ _ _ <- done_specs]
1374 is_done p = any (samePat p) done_pats
1376 ; return (any isNothing mb_pats,
1377 filterOut is_done (nubBy samePat good_pats)) }
1379 callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
1380 -- The [Var] is the variables to quantify over in the rule
1381 -- Type variables come first, since they may scope
1382 -- over the following term variables
1383 -- The [CoreExpr] are the argument patterns for the rule
1384 callToPats env bndr_occs (con_env, args)
1385 | length args < length bndr_occs -- Check saturated
1388 = do { let in_scope = substInScope (sc_subst env)
1389 ; prs <- argsToPats env in_scope con_env (args `zip` bndr_occs)
1390 ; let (interesting_s, pats) = unzip prs
1391 pat_fvs = varSetElems (exprsFreeVars pats)
1392 qvars = filterOut (`elemInScopeSet` in_scope) pat_fvs
1393 -- Quantify over variables that are not in sccpe
1395 -- See Note [Shadowing] at the top
1397 (tvs, ids) = partition isTyVar qvars
1399 -- Put the type variables first; the type of a term
1400 -- variable may mention a type variable
1402 ; -- pprTrace "callToPats" (ppr args $$ ppr prs $$ ppr bndr_occs) $
1404 then return (Just (qvars', pats))
1405 else return Nothing }
1407 -- argToPat takes an actual argument, and returns an abstracted
1408 -- version, consisting of just the "constructor skeleton" of the
1409 -- argument, with non-constructor sub-expression replaced by new
1410 -- placeholder variables. For example:
1411 -- C a (D (f x) (g y)) ==> C p1 (D p2 p3)
1414 -> InScopeSet -- What's in scope at the fn defn site
1415 -> ValueEnv -- ValueEnv at the call site
1416 -> CoreArg -- A call arg (or component thereof)
1418 -> UniqSM (Bool, CoreArg)
1419 -- Returns (interesting, pat),
1420 -- where pat is the pattern derived from the argument
1421 -- intersting=True if the pattern is non-trivial (not a variable or type)
1422 -- E.g. x:xs --> (True, x:xs)
1423 -- f xs --> (False, w) where w is a fresh wildcard
1424 -- (f xs, 'c') --> (True, (w, 'c')) where w is a fresh wildcard
1425 -- \x. x+y --> (True, \x. x+y)
1426 -- lvl7 --> (True, lvl7) if lvl7 is bound
1427 -- somewhere further out
1429 argToPat _env _in_scope _val_env arg@(Type {}) _arg_occ
1430 = return (False, arg)
1432 argToPat env in_scope val_env (Note _ arg) arg_occ
1433 = argToPat env in_scope val_env arg arg_occ
1434 -- Note [Notes in call patterns]
1435 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1436 -- Ignore Notes. In particular, we want to ignore any InlineMe notes
1437 -- Perhaps we should not ignore profiling notes, but I'm going to
1438 -- ride roughshod over them all for now.
1439 --- See Note [Notes in RULE matching] in Rules
1441 argToPat env in_scope val_env (Let _ arg) arg_occ
1442 = argToPat env in_scope val_env arg arg_occ
1443 -- Look through let expressions
1444 -- e.g. f (let v = rhs in \y -> ...v...)
1445 -- Here we can specialise for f (\y -> ...)
1446 -- because the rule-matcher will look through the let.
1448 argToPat env in_scope val_env (Cast arg co) arg_occ
1449 | not (ignoreType env ty2)
1450 = do { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ
1451 ; if not interesting then
1454 { -- Make a wild-card pattern for the coercion
1456 ; let co_name = mkSysTvName uniq (fsLit "sg")
1457 co_var = mkCoVar co_name (mkCoKind ty1 ty2)
1458 ; return (interesting, Cast arg' (mkTyVarTy co_var)) } }
1460 (ty1, ty2) = coercionKind co
1464 {- Disabling lambda specialisation for now
1465 It's fragile, and the spec_loop can be infinite
1466 argToPat in_scope val_env arg arg_occ
1468 = return (True, arg)
1470 is_value_lam (Lam v e) -- Spot a value lambda, even if
1471 | isId v = True -- it is inside a type lambda
1472 | otherwise = is_value_lam e
1473 is_value_lam other = False
1476 -- Check for a constructor application
1477 -- NB: this *precedes* the Var case, so that we catch nullary constrs
1478 argToPat env in_scope val_env arg arg_occ
1479 | Just (ConVal dc args) <- isValue val_env arg
1480 , not (ignoreAltCon env dc)
1482 ScrutOcc _ -> True -- Used only by case scrutinee
1483 BothOcc -> case arg of -- Used elsewhere
1484 App {} -> True -- see Note [Reboxing]
1486 _other -> False -- No point; the arg is not decomposed
1487 = do { args' <- argsToPats env in_scope val_env (args `zip` conArgOccs arg_occ dc)
1488 ; return (True, mk_con_app dc (map snd args')) }
1490 -- Check if the argument is a variable that
1491 -- is in scope at the function definition site
1492 -- It's worth specialising on this if
1493 -- (a) it's used in an interesting way in the body
1494 -- (b) we know what its value is
1495 argToPat env in_scope val_env (Var v) arg_occ
1496 | case arg_occ of { UnkOcc -> False; _other -> True }, -- (a)
1498 not (ignoreType env (varType v))
1499 = return (True, Var v)
1502 | isLocalId v = v `elemInScopeSet` in_scope
1503 && isJust (lookupVarEnv val_env v)
1504 -- Local variables have values in val_env
1505 | otherwise = isValueUnfolding (idUnfolding v)
1506 -- Imports have unfoldings
1508 -- I'm really not sure what this comment means
1509 -- And by not wild-carding we tend to get forall'd
1510 -- variables that are in soope, which in turn can
1511 -- expose the weakness in let-matching
1512 -- See Note [Matching lets] in Rules
1514 -- Check for a variable bound inside the function.
1515 -- Don't make a wild-card, because we may usefully share
1516 -- e.g. f a = let x = ... in f (x,x)
1517 -- NB: this case follows the lambda and con-app cases!!
1518 -- argToPat _in_scope _val_env (Var v) _arg_occ
1519 -- = return (False, Var v)
1520 -- SLPJ : disabling this to avoid proliferation of versions
1521 -- also works badly when thinking about seeding the loop
1522 -- from the body of the let
1523 -- f x y = letrec g z = ... in g (x,y)
1524 -- We don't want to specialise for that *particular* x,y
1526 -- The default case: make a wild-card
1527 argToPat _env _in_scope _val_env arg _arg_occ
1528 = wildCardPat (exprType arg)
1530 wildCardPat :: Type -> UniqSM (Bool, CoreArg)
1531 wildCardPat ty = do { uniq <- getUniqueUs
1532 ; let id = mkSysLocal (fsLit "sc") uniq ty
1533 ; return (False, Var id) }
1535 argsToPats :: ScEnv -> InScopeSet -> ValueEnv
1536 -> [(CoreArg, ArgOcc)]
1537 -> UniqSM [(Bool, CoreArg)]
1538 argsToPats env in_scope val_env args
1541 do_one (arg,occ) = argToPat env in_scope val_env arg occ
1546 isValue :: ValueEnv -> CoreExpr -> Maybe Value
1547 isValue _env (Lit lit)
1548 = Just (ConVal (LitAlt lit) [])
1551 | Just stuff <- lookupVarEnv env v
1552 = Just stuff -- You might think we could look in the idUnfolding here
1553 -- but that doesn't take account of which branch of a
1554 -- case we are in, which is the whole point
1556 | not (isLocalId v) && isCheapUnfolding unf
1557 = isValue env (unfoldingTemplate unf)
1560 -- However we do want to consult the unfolding
1561 -- as well, for let-bound constructors!
1563 isValue env (Lam b e)
1564 | isTyVar b = case isValue env e of
1565 Just _ -> Just LambdaVal
1567 | otherwise = Just LambdaVal
1569 isValue _env expr -- Maybe it's a constructor application
1570 | (Var fun, args) <- collectArgs expr
1571 = case isDataConWorkId_maybe fun of
1573 Just con | args `lengthAtLeast` dataConRepArity con
1574 -- Check saturated; might be > because the
1575 -- arity excludes type args
1576 -> Just (ConVal (DataAlt con) args)
1578 _other | valArgCount args < idArity fun
1579 -- Under-applied function
1580 -> Just LambdaVal -- Partial application
1584 isValue _env _expr = Nothing
1586 mk_con_app :: AltCon -> [CoreArg] -> CoreExpr
1587 mk_con_app (LitAlt lit) [] = Lit lit
1588 mk_con_app (DataAlt con) args = mkConApp con args
1589 mk_con_app _other _args = panic "SpecConstr.mk_con_app"
1591 samePat :: CallPat -> CallPat -> Bool
1592 samePat (vs1, as1) (vs2, as2)
1595 same (Var v1) (Var v2)
1596 | v1 `elem` vs1 = v2 `elem` vs2
1597 | v2 `elem` vs2 = False
1598 | otherwise = v1 == v2
1600 same (Lit l1) (Lit l2) = l1==l2
1601 same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2
1603 same (Type {}) (Type {}) = True -- Note [Ignore type differences]
1604 same (Note _ e1) e2 = same e1 e2 -- Ignore casts and notes
1605 same (Cast e1 _) e2 = same e1 e2
1606 same e1 (Note _ e2) = same e1 e2
1607 same e1 (Cast e2 _) = same e1 e2
1609 same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2)
1610 False -- Let, lambda, case should not occur
1611 bad (Case {}) = True
1617 Note [Ignore type differences]
1618 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1619 We do not want to generate specialisations where the call patterns
1620 differ only in their type arguments! Not only is it utterly useless,
1621 but it also means that (with polymorphic recursion) we can generate
1622 an infinite number of specialisations. Example is Data.Sequence.adjustTree,