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 )
50 import qualified LazyUniqFM as L
52 import Control.Monad ( zipWithM )
54 #if __GLASGOW_HASKELL__ > 609
55 import Data.Data ( Data, Typeable )
57 import Data.Generics ( Data, Typeable )
61 -----------------------------------------------------
63 -----------------------------------------------------
68 drop n (x:xs) = drop (n-1) xs
70 After the first time round, we could pass n unboxed. This happens in
71 numerical code too. Here's what it looks like in Core:
73 drop n xs = case xs of
78 _ -> drop (I# (n# -# 1#)) xs
80 Notice that the recursive call has an explicit constructor as argument.
81 Noticing this, we can make a specialised version of drop
83 RULE: drop (I# n#) xs ==> drop' n# xs
85 drop' n# xs = let n = I# n# in ...orig RHS...
87 Now the simplifier will apply the specialisation in the rhs of drop', giving
89 drop' n# xs = case xs of
93 _ -> drop (n# -# 1#) xs
97 We'd also like to catch cases where a parameter is carried along unchanged,
98 but evaluated each time round the loop:
100 f i n = if i>0 || i>n then i else f (i*2) n
102 Here f isn't strict in n, but we'd like to avoid evaluating it each iteration.
103 In Core, by the time we've w/wd (f is strict in i) we get
105 f i# n = case i# ># 0 of
107 True -> case n of n' { I# n# ->
110 True -> f (i# *# 2#) n'
112 At the call to f, we see that the argument, n is know to be (I# n#),
113 and n is evaluated elsewhere in the body of f, so we can play the same
119 We must be careful not to allocate the same constructor twice. Consider
120 f p = (...(case p of (a,b) -> e)...p...,
121 ...let t = (r,s) in ...t...(f t)...)
122 At the recursive call to f, we can see that t is a pair. But we do NOT want
123 to make a specialised copy:
124 f' a b = let p = (a,b) in (..., ...)
125 because now t is allocated by the caller, then r and s are passed to the
126 recursive call, which allocates the (r,s) pair again.
129 (a) the argument p is used in other than a case-scrutinsation way.
130 (b) the argument to the call is not a 'fresh' tuple; you have to
131 look into its unfolding to see that it's a tuple
133 Hence the "OR" part of Note [Good arguments] below.
135 ALTERNATIVE 2: pass both boxed and unboxed versions. This no longer saves
136 allocation, but does perhaps save evals. In the RULE we'd have
139 f (I# x#) = f' (I# x#) x#
141 If at the call site the (I# x) was an unfolding, then we'd have to
142 rely on CSE to eliminate the duplicate allocation.... This alternative
143 doesn't look attractive enough to pursue.
145 ALTERNATIVE 3: ignore the reboxing problem. The trouble is that
146 the conservative reboxing story prevents many useful functions from being
147 specialised. Example:
148 foo :: Maybe Int -> Int -> Int
150 foo x@(Just m) n = foo x (n-m)
151 Here the use of 'x' will clearly not require boxing in the specialised function.
153 The strictness analyser has the same problem, in fact. Example:
155 If we pass just 'a' and 'b' to the worker, it might need to rebox the
156 pair to create (a,b). A more sophisticated analysis might figure out
157 precisely the cases in which this could happen, but the strictness
158 analyser does no such analysis; it just passes 'a' and 'b', and hopes
161 So my current choice is to make SpecConstr similarly aggressive, and
162 ignore the bad potential of reboxing.
165 Note [Good arguments]
166 ~~~~~~~~~~~~~~~~~~~~~
169 * A self-recursive function. Ignore mutual recursion for now,
170 because it's less common, and the code is simpler for self-recursion.
174 a) At a recursive call, one or more parameters is an explicit
175 constructor application
177 That same parameter is scrutinised by a case somewhere in
178 the RHS of the function
182 b) At a recursive call, one or more parameters has an unfolding
183 that is an explicit constructor application
185 That same parameter is scrutinised by a case somewhere in
186 the RHS of the function
188 Those are the only uses of the parameter (see Note [Reboxing])
191 What to abstract over
192 ~~~~~~~~~~~~~~~~~~~~~
193 There's a bit of a complication with type arguments. If the call
196 f p = ...f ((:) [a] x xs)...
198 then our specialised function look like
200 f_spec x xs = let p = (:) [a] x xs in ....as before....
202 This only makes sense if either
203 a) the type variable 'a' is in scope at the top of f, or
204 b) the type variable 'a' is an argument to f (and hence fs)
206 Actually, (a) may hold for value arguments too, in which case
207 we may not want to pass them. Supose 'x' is in scope at f's
208 defn, but xs is not. Then we'd like
210 f_spec xs = let p = (:) [a] x xs in ....as before....
212 Similarly (b) may hold too. If x is already an argument at the
213 call, no need to pass it again.
215 Finally, if 'a' is not in scope at the call site, we could abstract
216 it as we do the term variables:
218 f_spec a x xs = let p = (:) [a] x xs in ...as before...
220 So the grand plan is:
222 * abstract the call site to a constructor-only pattern
223 e.g. C x (D (f p) (g q)) ==> C s1 (D s2 s3)
225 * Find the free variables of the abstracted pattern
227 * Pass these variables, less any that are in scope at
228 the fn defn. But see Note [Shadowing] below.
231 NOTICE that we only abstract over variables that are not in scope,
232 so we're in no danger of shadowing variables used in "higher up"
238 In this pass we gather up usage information that may mention variables
239 that are bound between the usage site and the definition site; or (more
240 seriously) may be bound to something different at the definition site.
243 f x = letrec g y v = let x = ...
246 Since 'x' is in scope at the call site, we may make a rewrite rule that
248 RULE forall a,b. g (a,b) x = ...
249 But this rule will never match, because it's really a different 'x' at
250 the call site -- and that difference will be manifest by the time the
251 simplifier gets to it. [A worry: the simplifier doesn't *guarantee*
252 no-shadowing, so perhaps it may not be distinct?]
254 Anyway, the rule isn't actually wrong, it's just not useful. One possibility
255 is to run deShadowBinds before running SpecConstr, but instead we run the
256 simplifier. That gives the simplest possible program for SpecConstr to
257 chew on; and it virtually guarantees no shadowing.
259 Note [Specialising for constant parameters]
260 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
261 This one is about specialising on a *constant* (but not necessarily
262 constructor) argument
264 foo :: Int -> (Int -> Int) -> Int
266 foo m f = foo (f m) (+1)
270 lvl_rmV :: GHC.Base.Int -> GHC.Base.Int
272 \ (ds_dlk :: GHC.Base.Int) ->
273 case ds_dlk of wild_alH { GHC.Base.I# x_alG ->
274 GHC.Base.I# (GHC.Prim.+# x_alG 1)
276 T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
279 \ (ww_sme :: GHC.Prim.Int#) (w_smg :: GHC.Base.Int -> GHC.Base.Int) ->
280 case ww_sme of ds_Xlw {
282 case w_smg (GHC.Base.I# ds_Xlw) of w1_Xmo { GHC.Base.I# ww1_Xmz ->
283 T.$wfoo ww1_Xmz lvl_rmV
288 The recursive call has lvl_rmV as its argument, so we could create a specialised copy
289 with that argument baked in; that is, not passed at all. Now it can perhaps be inlined.
291 When is this worth it? Call the constant 'lvl'
292 - If 'lvl' has an unfolding that is a constructor, see if the corresponding
293 parameter is scrutinised anywhere in the body.
295 - If 'lvl' has an unfolding that is a inlinable function, see if the corresponding
296 parameter is applied (...to enough arguments...?)
298 Also do this is if the function has RULES?
302 Note [Specialising for lambda parameters]
303 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
304 foo :: Int -> (Int -> Int) -> Int
306 foo m f = foo (f m) (\n -> n-m)
308 This is subtly different from the previous one in that we get an
309 explicit lambda as the argument:
311 T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
314 \ (ww_sm8 :: GHC.Prim.Int#) (w_sma :: GHC.Base.Int -> GHC.Base.Int) ->
315 case ww_sm8 of ds_Xlr {
317 case w_sma (GHC.Base.I# ds_Xlr) of w1_Xmf { GHC.Base.I# ww1_Xmq ->
320 (\ (n_ad3 :: GHC.Base.Int) ->
321 case n_ad3 of wild_alB { GHC.Base.I# x_alA ->
322 GHC.Base.I# (GHC.Prim.-# x_alA ds_Xlr)
328 I wonder if SpecConstr couldn't be extended to handle this? After all,
329 lambda is a sort of constructor for functions and perhaps it already
330 has most of the necessary machinery?
332 Furthermore, there's an immediate win, because you don't need to allocate the lamda
333 at the call site; and if perchance it's called in the recursive call, then you
334 may avoid allocating it altogether. Just like for constructors.
336 Looks cool, but probably rare...but it might be easy to implement.
339 Note [SpecConstr for casts]
340 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
343 data instance T Int = T Int
348 go (T n) = go (T (n-1))
350 The recursive call ends up looking like
351 go (T (I# ...) `cast` g)
352 So we want to spot the construtor application inside the cast.
353 That's why we have the Cast case in argToPat
355 Note [Local recursive groups]
356 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
357 For a *local* recursive group, we can see all the calls to the
358 function, so we seed the specialisation loop from the calls in the
359 body, not from the calls in the RHS. Consider:
361 bar m n = foo n (n,n) (n,n) (n,n) (n,n)
365 | n > 3000 = case p of { (p1,p2) -> foo (n-1) (p2,p1) q r s }
366 | n > 2000 = case q of { (q1,q2) -> foo (n-1) p (q2,q1) r s }
367 | n > 1000 = case r of { (r1,r2) -> foo (n-1) p q (r2,r1) s }
368 | otherwise = case s of { (s1,s2) -> foo (n-1) p q r (s2,s1) }
370 If we start with the RHSs of 'foo', we get lots and lots of specialisations,
371 most of which are not needed. But if we start with the (single) call
372 in the rhs of 'bar' we get exactly one fully-specialised copy, and all
373 the recursive calls go to this fully-specialised copy. Indeed, the original
374 function is later collected as dead code. This is very important in
375 specialising the loops arising from stream fusion, for example in NDP where
376 we were getting literally hundreds of (mostly unused) specialisations of
379 Note [Do not specialise diverging functions]
380 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
381 Specialising a function that just diverges is a waste of code.
382 Furthermore, it broke GHC (simpl014) thus:
384 f = \x. case x of (a,b) -> f x
385 If we specialise f we get
386 f = \x. case x of (a,b) -> fspec a b
387 But fspec doesn't have decent strictnes info. As it happened,
388 (f x) :: IO t, so the state hack applied and we eta expanded fspec,
389 and hence f. But now f's strictness is less than its arity, which
392 Note [Forcing specialisation]
393 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
394 With stream fusion and in other similar cases, we want to fully specialise
395 some (but not necessarily all!) loops regardless of their size and the
396 number of specialisations. We allow a library to specify this by annotating
397 a type with ForceSpecConstr and then adding a parameter of that type to the
398 loop. Here is a (simplified) example from the vector library:
400 data SPEC = SPEC | SPEC2
401 {-# ANN type SPEC ForceSpecConstr #-}
403 foldl :: (a -> b -> a) -> a -> Stream b -> a
405 foldl f z (Stream step s _) = foldl_loop SPEC z s
407 foldl_loop SPEC z s = case step s of
408 Yield x s' -> foldl_loop SPEC (f z x) s'
409 Skip -> foldl_loop SPEC z s'
412 SpecConstr will spot the SPEC parameter and always fully specialise
413 foldl_loop. Note that we can't just annotate foldl_loop since it isn't a
414 top-level function but even if we could, inlining etc. could easily drop the
415 annotation. We also have to prevent the SPEC argument from being removed by
416 w/w which is why SPEC is a sum type. This is all quite ugly; we ought to come
417 up with a better design.
419 ForceSpecConstr arguments are spotted in scExpr' and scTopBinds which then set
420 force_spec to True when calling specLoop. This flag makes specLoop and
421 specialise ignore specConstrCount and specConstrThreshold when deciding
422 whether to specialise a function.
424 -----------------------------------------------------
425 Stuff not yet handled
426 -----------------------------------------------------
428 Here are notes arising from Roman's work that I don't want to lose.
434 foo :: Int -> T Int -> Int
436 foo x t | even x = case t of { T n -> foo (x-n) t }
437 | otherwise = foo (x-1) t
439 SpecConstr does no specialisation, because the second recursive call
440 looks like a boxed use of the argument. A pity.
442 $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
444 \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) ->
445 case ww_sFo of ds_Xw6 [Just L] {
447 case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] {
448 __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq;
450 case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] ->
451 case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] ->
452 $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy
458 data a :*: b = !a :*: !b
461 foo :: (Int :*: T Int) -> Int
463 foo (x :*: t) | even x = case t of { T n -> foo ((x-n) :*: t) }
464 | otherwise = foo ((x-1) :*: t)
466 Very similar to the previous one, except that the parameters are now in
467 a strict tuple. Before SpecConstr, we have
469 $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
471 \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T
473 case ww_sFU of ds_Xws [Just L] {
475 case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] {
477 case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] ->
478 $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2 -- $wfoo1
481 case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] ->
482 case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] ->
483 $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB -- $wfoo2
487 We get two specialisations:
488 "SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#}
489 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB)
490 = Foo.$s$wfoo1 a_sFB sc_sGC ;
491 "SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#}
492 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp))
493 = Foo.$s$wfoo y_aFp sc_sGC ;
495 But perhaps the first one isn't good. After all, we know that tpl_B2 is
496 a T (I# x) really, because T is strict and Int has one constructor. (We can't
497 unbox the strict fields, becuase T is polymorphic!)
499 %************************************************************************
501 \subsection{Annotations}
503 %************************************************************************
505 Annotating a type with NoSpecConstr will make SpecConstr not specialise
506 for arguments of that type.
509 data SpecConstrAnnotation = NoSpecConstr | ForceSpecConstr
510 deriving( Data, Typeable, Eq )
513 %************************************************************************
515 \subsection{Top level wrapper stuff}
517 %************************************************************************
520 specConstrProgram :: ModGuts -> CoreM ModGuts
521 specConstrProgram guts
523 dflags <- getDynFlags
524 us <- getUniqueSupplyM
525 annos <- getFirstAnnotations deserializeWithData guts
526 let binds' = fst $ initUs us (go (initScEnv dflags annos) (mg_binds guts))
527 return (guts { mg_binds = binds' })
530 go env (bind:binds) = do (env', bind') <- scTopBind env bind
531 binds' <- go env' binds
532 return (bind' : binds')
536 %************************************************************************
538 \subsection{Environment: goes downwards}
540 %************************************************************************
543 data ScEnv = SCE { sc_size :: Maybe Int, -- Size threshold
544 sc_count :: Maybe Int, -- Max # of specialisations for any one fn
545 -- See Note [Avoiding exponential blowup]
547 sc_subst :: Subst, -- Current substitution
548 -- Maps InIds to OutExprs
550 sc_how_bound :: HowBoundEnv,
551 -- Binds interesting non-top-level variables
552 -- Domain is OutVars (*after* applying the substitution)
555 -- Domain is OutIds (*after* applying the substitution)
556 -- Used even for top-level bindings (but not imported ones)
558 sc_annotations :: L.UniqFM SpecConstrAnnotation
561 ---------------------
562 -- As we go, we apply a substitution (sc_subst) to the current term
563 type InExpr = CoreExpr -- _Before_ applying the subst
566 type OutExpr = CoreExpr -- _After_ applying the subst
570 ---------------------
571 type HowBoundEnv = VarEnv HowBound -- Domain is OutVars
573 ---------------------
574 type ValueEnv = IdEnv Value -- Domain is OutIds
575 data Value = ConVal AltCon [CoreArg] -- _Saturated_ constructors
576 | LambdaVal -- Inlinable lambdas or PAPs
578 instance Outputable Value where
579 ppr (ConVal con args) = ppr con <+> interpp'SP args
580 ppr LambdaVal = ptext (sLit "<Lambda>")
582 ---------------------
583 initScEnv :: DynFlags -> L.UniqFM SpecConstrAnnotation -> ScEnv
584 initScEnv dflags anns
585 = SCE { sc_size = specConstrThreshold dflags,
586 sc_count = specConstrCount dflags,
587 sc_subst = emptySubst,
588 sc_how_bound = emptyVarEnv,
589 sc_vals = emptyVarEnv,
590 sc_annotations = anns }
592 data HowBound = RecFun -- These are the recursive functions for which
593 -- we seek interesting call patterns
595 | RecArg -- These are those functions' arguments, or their sub-components;
596 -- we gather occurrence information for these
598 instance Outputable HowBound where
599 ppr RecFun = text "RecFun"
600 ppr RecArg = text "RecArg"
602 lookupHowBound :: ScEnv -> Id -> Maybe HowBound
603 lookupHowBound env id = lookupVarEnv (sc_how_bound env) id
605 scSubstId :: ScEnv -> Id -> CoreExpr
606 scSubstId env v = lookupIdSubst (text "scSubstId") (sc_subst env) v
608 scSubstTy :: ScEnv -> Type -> Type
609 scSubstTy env ty = substTy (sc_subst env) ty
611 zapScSubst :: ScEnv -> ScEnv
612 zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) }
614 extendScInScope :: ScEnv -> [Var] -> ScEnv
615 -- Bring the quantified variables into scope
616 extendScInScope env qvars = env { sc_subst = extendInScopeList (sc_subst env) qvars }
618 -- Extend the substitution
619 extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv
620 extendScSubst env var expr = env { sc_subst = extendSubst (sc_subst env) var expr }
622 extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv
623 extendScSubstList env prs = env { sc_subst = extendSubstList (sc_subst env) prs }
625 extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv
626 extendHowBound env bndrs how_bound
627 = env { sc_how_bound = extendVarEnvList (sc_how_bound env)
628 [(bndr,how_bound) | bndr <- bndrs] }
630 extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var])
631 extendBndrsWith how_bound env bndrs
632 = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndrs')
634 (subst', bndrs') = substBndrs (sc_subst env) bndrs
635 hb_env' = sc_how_bound env `extendVarEnvList`
636 [(bndr,how_bound) | bndr <- bndrs']
638 extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var)
639 extendBndrWith how_bound env bndr
640 = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndr')
642 (subst', bndr') = substBndr (sc_subst env) bndr
643 hb_env' = extendVarEnv (sc_how_bound env) bndr' how_bound
645 extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var])
646 extendRecBndrs env bndrs = (env { sc_subst = subst' }, bndrs')
648 (subst', bndrs') = substRecBndrs (sc_subst env) bndrs
650 extendBndr :: ScEnv -> Var -> (ScEnv, Var)
651 extendBndr env bndr = (env { sc_subst = subst' }, bndr')
653 (subst', bndr') = substBndr (sc_subst env) bndr
655 extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv
656 extendValEnv env _ Nothing = env
657 extendValEnv env id (Just cv) = env { sc_vals = extendVarEnv (sc_vals env) id cv }
659 extendCaseBndrs :: ScEnv -> Id -> AltCon -> [Var] -> (ScEnv, [Var])
663 -- we want to bind b, to (C x y)
664 -- NB1: Extends only the sc_vals part of the envt
665 -- NB2: Kill the dead-ness info on the pattern binders x,y, since
666 -- they are potentially made alive by the [b -> C x y] binding
667 extendCaseBndrs env case_bndr con alt_bndrs
668 | isDeadBinder case_bndr
671 = (env1, map zap alt_bndrs)
672 -- NB: We used to bind v too, if scrut = (Var v); but
673 -- the simplifer has already done this so it seems
674 -- redundant to do so here
676 -- Var v -> extendValEnv env1 v cval
679 zap v | isTyVar v = v -- See NB2 above
680 | otherwise = zapIdOccInfo v
681 env1 = extendValEnv env case_bndr cval
684 LitAlt {} -> Just (ConVal con [])
685 DataAlt {} -> Just (ConVal con vanilla_args)
687 vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
688 varsToCoreExprs alt_bndrs
690 ignoreTyCon :: ScEnv -> TyCon -> Bool
691 ignoreTyCon env tycon
692 = L.lookupUFM (sc_annotations env) tycon == Just NoSpecConstr
694 ignoreType :: ScEnv -> Type -> Bool
696 = case splitTyConApp_maybe ty of
697 Just (tycon, _) -> ignoreTyCon env tycon
700 ignoreAltCon :: ScEnv -> AltCon -> Bool
701 ignoreAltCon env (DataAlt dc) = ignoreTyCon env (dataConTyCon dc)
702 ignoreAltCon env (LitAlt lit) = ignoreType env (literalType lit)
703 ignoreAltCon _ DEFAULT = True
705 forceSpecBndr :: ScEnv -> Var -> Bool
706 forceSpecBndr env var = forceSpecFunTy env . snd . splitForAllTys . varType $ var
708 forceSpecFunTy :: ScEnv -> Type -> Bool
709 forceSpecFunTy env = any (forceSpecArgTy env) . fst . splitFunTys
711 forceSpecArgTy :: ScEnv -> Type -> Bool
712 forceSpecArgTy env ty
713 | Just ty' <- coreView ty = forceSpecArgTy env ty'
715 forceSpecArgTy env ty
716 | Just (tycon, tys) <- splitTyConApp_maybe ty
718 = L.lookupUFM (sc_annotations env) tycon == Just ForceSpecConstr
719 || any (forceSpecArgTy env) tys
721 forceSpecArgTy _ _ = False
723 decreaseSpecCount :: ScEnv -> Int -> ScEnv
724 -- See Note [Avoiding exponential blowup]
725 decreaseSpecCount env n_specs
726 = env { sc_count = case sc_count env of
728 Just n -> Just (n `div` (n_specs + 1)) }
729 -- The "+1" takes account of the original function;
730 -- See Note [Avoiding exponential blowup]
733 Note [Avoiding exponential blowup]
734 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
735 The sc_count field of the ScEnv says how many times we are prepared to
736 duplicate a single function. But we must take care with recursive
737 specialiations. Consider
739 let $j1 = let $j2 = let $j3 = ...
747 If we specialise $j1 then in each specialisation (as well as the original)
748 we can specialise $j2, and similarly $j3. Even if we make just *one*
749 specialisation of each, becuase we also have the original we'll get 2^n
750 copies of $j3, which is not good.
752 So when recursively specialising we divide the sc_count by the number of
753 copies we are making at this level, including the original.
756 %************************************************************************
758 \subsection{Usage information: flows upwards}
760 %************************************************************************
765 scu_calls :: CallEnv, -- Calls
766 -- The functions are a subset of the
767 -- RecFuns in the ScEnv
769 scu_occs :: !(IdEnv ArgOcc) -- Information on argument occurrences
770 } -- The domain is OutIds
772 type CallEnv = IdEnv [Call]
773 type Call = (ValueEnv, [CoreArg])
774 -- The arguments of the call, together with the
775 -- env giving the constructor bindings at the call site
778 nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv }
780 combineCalls :: CallEnv -> CallEnv -> CallEnv
781 combineCalls = plusVarEnv_C (++)
783 combineUsage :: ScUsage -> ScUsage -> ScUsage
784 combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2),
785 scu_occs = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) }
787 combineUsages :: [ScUsage] -> ScUsage
788 combineUsages [] = nullUsage
789 combineUsages us = foldr1 combineUsage us
791 lookupOcc :: ScUsage -> OutVar -> (ScUsage, ArgOcc)
792 lookupOcc (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndr
793 = (SCU {scu_calls = sc_calls, scu_occs = delVarEnv sc_occs bndr},
794 lookupVarEnv sc_occs bndr `orElse` NoOcc)
796 lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc])
797 lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs
798 = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs},
799 [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs])
801 data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument
802 | UnkOcc -- Used in some unknown way
804 | ScrutOcc (UniqFM [ArgOcc]) -- See Note [ScrutOcc]
806 | BothOcc -- Definitely taken apart, *and* perhaps used in some other way
810 An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing,
811 is *only* taken apart or applied.
813 Functions, literal: ScrutOcc emptyUFM
814 Data constructors: ScrutOcc subs,
816 where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components,
817 The domain of the UniqFM is the Unique of the data constructor
819 The [ArgOcc] is the occurrences of the *pattern-bound* components
820 of the data structure. E.g.
821 data T a = forall b. MkT a b (b->a)
822 A pattern binds b, x::a, y::b, z::b->a, but not 'a'!
826 instance Outputable ArgOcc where
827 ppr (ScrutOcc xs) = ptext (sLit "scrut-occ") <> ppr xs
828 ppr UnkOcc = ptext (sLit "unk-occ")
829 ppr BothOcc = ptext (sLit "both-occ")
830 ppr NoOcc = ptext (sLit "no-occ")
832 -- Experimentally, this vesion of combineOcc makes ScrutOcc "win", so
833 -- that if the thing is scrutinised anywhere then we get to see that
834 -- in the overall result, even if it's also used in a boxed way
835 -- This might be too agressive; see Note [Reboxing] Alternative 3
836 combineOcc :: ArgOcc -> ArgOcc -> ArgOcc
837 combineOcc NoOcc occ = occ
838 combineOcc occ NoOcc = occ
839 combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys)
840 combineOcc _occ (ScrutOcc ys) = ScrutOcc ys
841 combineOcc (ScrutOcc xs) _occ = ScrutOcc xs
842 combineOcc UnkOcc UnkOcc = UnkOcc
843 combineOcc _ _ = BothOcc
845 combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]
846 combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys
848 setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage
849 -- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee
850 -- is a variable, and an interesting variable
851 setScrutOcc env usg (Cast e _) occ = setScrutOcc env usg e occ
852 setScrutOcc env usg (Note _ e) occ = setScrutOcc env usg e occ
853 setScrutOcc env usg (Var v) occ
854 | Just RecArg <- lookupHowBound env v = usg { scu_occs = extendVarEnv (scu_occs usg) v occ }
856 setScrutOcc _env usg _other _occ -- Catch-all
859 conArgOccs :: ArgOcc -> AltCon -> [ArgOcc]
860 -- Find usage of components of data con; returns [UnkOcc...] if unknown
861 -- See Note [ScrutOcc] for the extra UnkOccs in the vanilla datacon case
863 conArgOccs (ScrutOcc fm) (DataAlt dc)
864 | Just pat_arg_occs <- lookupUFM fm dc
865 = [UnkOcc | _ <- dataConUnivTyVars dc] ++ pat_arg_occs
867 conArgOccs _other _con = repeat UnkOcc
870 %************************************************************************
872 \subsection{The main recursive function}
874 %************************************************************************
876 The main recursive function gathers up usage information, and
877 creates specialised versions of functions.
880 scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
881 -- The unique supply is needed when we invent
882 -- a new name for the specialised function and its args
884 scExpr env e = scExpr' env e
887 scExpr' env (Var v) = case scSubstId env v of
888 Var v' -> return (varUsage env v' UnkOcc, Var v')
889 e' -> scExpr (zapScSubst env) e'
891 scExpr' env (Type t) = return (nullUsage, Type (scSubstTy env t))
892 scExpr' _ e@(Lit {}) = return (nullUsage, e)
893 scExpr' env (Note n e) = do (usg,e') <- scExpr env e
894 return (usg, Note n e')
895 scExpr' env (Cast e co) = do (usg, e') <- scExpr env e
896 return (usg, Cast e' (scSubstTy env co))
897 scExpr' env e@(App _ _) = scApp env (collectArgs e)
898 scExpr' env (Lam b e) = do let (env', b') = extendBndr env b
899 (usg, e') <- scExpr env' e
900 return (usg, Lam b' e')
902 scExpr' env (Case scrut b ty alts)
903 = do { (scrut_usg, scrut') <- scExpr env scrut
904 ; case isValue (sc_vals env) scrut' of
905 Just (ConVal con args) -> sc_con_app con args scrut'
906 _other -> sc_vanilla scrut_usg scrut'
909 sc_con_app con args scrut' -- Known constructor; simplify
910 = do { let (_, bs, rhs) = findAlt con alts
911 `orElse` (DEFAULT, [], mkImpossibleExpr (coreAltsType alts))
912 alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)
913 ; scExpr alt_env' rhs }
915 sc_vanilla scrut_usg scrut' -- Normal case
916 = do { let (alt_env,b') = extendBndrWith RecArg env b
917 -- Record RecArg for the components
919 ; (alt_usgs, alt_occs, alts')
920 <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts
922 ; let (alt_usg, b_occ) = lookupOcc (combineUsages alt_usgs) b'
923 scrut_occ = foldr combineOcc b_occ alt_occs
924 scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ
925 -- The combined usage of the scrutinee is given
926 -- by scrut_occ, which is passed to scScrut, which
927 -- in turn treats a bare-variable scrutinee specially
929 ; return (alt_usg `combineUsage` scrut_usg',
930 Case scrut' b' (scSubstTy env ty) alts') }
932 sc_alt env _scrut' b' (con,bs,rhs)
933 = do { let (env1, bs1) = extendBndrsWith RecArg env bs
934 (env2, bs2) = extendCaseBndrs env1 b' con bs1
935 ; (usg,rhs') <- scExpr env2 rhs
936 ; let (usg', arg_occs) = lookupOccs usg bs2
937 scrut_occ = case con of
938 DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)
939 _ -> ScrutOcc emptyUFM
940 ; return (usg', scrut_occ, (con, bs2, rhs')) }
942 scExpr' env (Let (NonRec bndr rhs) body)
943 | isTyVar bndr -- Type-lets may be created by doBeta
944 = scExpr' (extendScSubst env bndr rhs) body
946 | otherwise -- Note [Local let bindings]
947 = do { let (body_env, bndr') = extendBndr env bndr
948 body_env2 = extendHowBound body_env [bndr'] RecFun
949 ; (body_usg, body') <- scExpr body_env2 body
951 ; (rhs_usg, rhs_info) <- scRecRhs env (bndr',rhs)
953 -- NB: We don't use the ForceSpecConstr mechanism (see
954 -- Note [Forcing specialisation]) for non-recursive bindings
955 -- at the moment. I'm not sure if this is the right thing to do.
956 ; let force_spec = False
957 ; (spec_usg, specs) <- specialise env force_spec
960 (SI [] 0 (Just rhs_usg))
962 ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' }
963 `combineUsage` spec_usg,
964 mkLets [NonRec b r | (b,r) <- specInfoBinds rhs_info specs] body')
968 -- A *local* recursive group: see Note [Local recursive groups]
969 scExpr' env (Let (Rec prs) body)
970 = do { let (bndrs,rhss) = unzip prs
971 (rhs_env1,bndrs') = extendRecBndrs env bndrs
972 rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
973 force_spec = any (forceSpecBndr env) bndrs'
974 -- Note [Forcing specialisation]
976 ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
977 ; (body_usg, body') <- scExpr rhs_env2 body
979 -- NB: start specLoop from body_usg
980 ; (spec_usg, specs) <- specLoop rhs_env2 force_spec
981 (scu_calls body_usg) rhs_infos nullUsage
982 [SI [] 0 (Just usg) | usg <- rhs_usgs]
983 -- Do not unconditionally use rhs_usgs.
984 -- Instead use them only if we find an unspecialised call
985 -- See Note [Local recursive groups]
987 ; let all_usg = spec_usg `combineUsage` body_usg
988 bind' = Rec (concat (zipWith specInfoBinds rhs_infos specs))
990 ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' },
994 Note [Local let bindings]
995 ~~~~~~~~~~~~~~~~~~~~~~~~~
996 It is not uncommon to find this
998 let $j = \x. <blah> in ...$j True...$j True...
1000 Here $j is an arbitrary let-bound function, but it often comes up for
1001 join points. We might like to specialise $j for its call patterns.
1002 Notice the difference from a letrec, where we look for call patterns
1003 in the *RHS* of the function. Here we look for call patterns in the
1006 At one point I predicated this on the RHS mentioning the outer
1007 recursive function, but that's not essential and might even be
1008 harmful. I'm not sure.
1012 scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)
1014 scApp env (Var fn, args) -- Function is a variable
1015 = ASSERT( not (null args) )
1016 do { args_w_usgs <- mapM (scExpr env) args
1017 ; let (arg_usgs, args') = unzip args_w_usgs
1018 arg_usg = combineUsages arg_usgs
1019 ; case scSubstId env fn of
1020 fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args')
1021 -- Do beta-reduction and try again
1023 Var fn' -> return (arg_usg `combineUsage` fn_usg, mkApps (Var fn') args')
1025 fn_usg = case lookupHowBound env fn' of
1026 Just RecFun -> SCU { scu_calls = unitVarEnv fn' [(sc_vals env, args')],
1027 scu_occs = emptyVarEnv }
1028 Just RecArg -> SCU { scu_calls = emptyVarEnv,
1029 scu_occs = unitVarEnv fn' (ScrutOcc emptyUFM) }
1030 Nothing -> nullUsage
1033 other_fn' -> return (arg_usg, mkApps other_fn' args') }
1034 -- NB: doing this ignores any usage info from the substituted
1035 -- function, but I don't think that matters. If it does
1038 doBeta :: OutExpr -> [OutExpr] -> OutExpr
1039 -- ToDo: adjust for System IF
1040 doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args)
1041 doBeta fn args = mkApps fn args
1043 -- The function is almost always a variable, but not always.
1044 -- In particular, if this pass follows float-in,
1045 -- which it may, we can get
1046 -- (let f = ...f... in f) arg1 arg2
1047 scApp env (other_fn, args)
1048 = do { (fn_usg, fn') <- scExpr env other_fn
1049 ; (arg_usgs, args') <- mapAndUnzipM (scExpr env) args
1050 ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') }
1052 ----------------------
1053 scTopBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind)
1054 scTopBind env (Rec prs)
1055 | Just threshold <- sc_size env
1057 , not (all (couldBeSmallEnoughToInline threshold) rhss)
1058 -- No specialisation
1059 = do { let (rhs_env,bndrs') = extendRecBndrs env bndrs
1060 ; (_, rhss') <- mapAndUnzipM (scExpr rhs_env) rhss
1061 ; return (rhs_env, Rec (bndrs' `zip` rhss')) }
1062 | otherwise -- Do specialisation
1063 = do { let (rhs_env1,bndrs') = extendRecBndrs env bndrs
1064 rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
1066 ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
1067 ; let rhs_usg = combineUsages rhs_usgs
1069 ; (_, specs) <- specLoop rhs_env2 force_spec
1070 (scu_calls rhs_usg) rhs_infos nullUsage
1071 [SI [] 0 Nothing | _ <- bndrs]
1073 ; return (rhs_env1, -- For the body of the letrec, delete the RecFun business
1074 Rec (concat (zipWith specInfoBinds rhs_infos specs))) }
1076 (bndrs,rhss) = unzip prs
1077 force_spec = any (forceSpecBndr env) bndrs
1078 -- Note [Forcing specialisation]
1080 scTopBind env (NonRec bndr rhs)
1081 = do { (_, rhs') <- scExpr env rhs
1082 ; let (env1, bndr') = extendBndr env bndr
1083 env2 = extendValEnv env1 bndr' (isValue (sc_vals env) rhs')
1084 ; return (env2, NonRec bndr' rhs') }
1086 ----------------------
1087 scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM (ScUsage, RhsInfo)
1088 scRecRhs env (bndr,rhs)
1089 = do { let (arg_bndrs,body) = collectBinders rhs
1090 (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs
1091 ; (body_usg, body') <- scExpr body_env body
1092 ; let (rhs_usg, arg_occs) = lookupOccs body_usg arg_bndrs'
1093 ; return (rhs_usg, RI bndr (mkLams arg_bndrs' body')
1094 arg_bndrs body arg_occs) }
1095 -- The arg_occs says how the visible,
1096 -- lambda-bound binders of the RHS are used
1097 -- (including the TyVar binders)
1098 -- Two pats are the same if they match both ways
1100 ----------------------
1101 specInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)]
1102 specInfoBinds (RI fn new_rhs _ _ _) (SI specs _ _)
1103 = [(id,rhs) | OS _ _ id rhs <- specs] ++
1104 [(fn `addIdSpecialisations` rules, new_rhs)]
1106 rules = [r | OS _ r _ _ <- specs]
1108 ----------------------
1109 varUsage :: ScEnv -> OutVar -> ArgOcc -> ScUsage
1111 | Just RecArg <- lookupHowBound env v = SCU { scu_calls = emptyVarEnv
1112 , scu_occs = unitVarEnv v use }
1113 | otherwise = nullUsage
1117 %************************************************************************
1119 The specialiser itself
1121 %************************************************************************
1124 data RhsInfo = RI OutId -- The binder
1125 OutExpr -- The new RHS
1126 [InVar] InExpr -- The *original* RHS (\xs.body)
1127 -- Note [Specialise original body]
1128 [ArgOcc] -- Info on how the xs occur in body
1130 data SpecInfo = SI [OneSpec] -- The specialisations we have generated
1132 Int -- Length of specs; used for numbering them
1134 (Maybe ScUsage) -- Nothing => we have generated specialisations
1135 -- from calls in the *original* RHS
1136 -- Just cs => we haven't, and this is the usage
1137 -- of the original RHS
1138 -- See Note [Local recursive groups]
1140 -- One specialisation: Rule plus definition
1141 data OneSpec = OS CallPat -- Call pattern that generated this specialisation
1142 CoreRule -- Rule connecting original id with the specialisation
1143 OutId OutExpr -- Spec id + its rhs
1147 -> Bool -- force specialisation?
1148 -- Note [Forcing specialisation]
1151 -> ScUsage -> [SpecInfo] -- One per binder; acccumulating parameter
1152 -> UniqSM (ScUsage, [SpecInfo]) -- ...ditto...
1153 specLoop env force_spec all_calls rhs_infos usg_so_far specs_so_far
1154 = do { specs_w_usg <- zipWithM (specialise env force_spec all_calls) rhs_infos specs_so_far
1155 ; let (new_usg_s, all_specs) = unzip specs_w_usg
1156 new_usg = combineUsages new_usg_s
1157 new_calls = scu_calls new_usg
1158 all_usg = usg_so_far `combineUsage` new_usg
1159 ; if isEmptyVarEnv new_calls then
1160 return (all_usg, all_specs)
1162 specLoop env force_spec new_calls rhs_infos all_usg all_specs }
1166 -> Bool -- force specialisation?
1167 -- Note [Forcing specialisation]
1168 -> CallEnv -- Info on calls
1170 -> SpecInfo -- Original RHS plus patterns dealt with
1171 -> UniqSM (ScUsage, SpecInfo) -- New specialised versions and their usage
1173 -- Note: the rhs here is the optimised version of the original rhs
1174 -- So when we make a specialised copy of the RHS, we're starting
1175 -- from an RHS whose nested functions have been optimised already.
1177 specialise env force_spec bind_calls (RI fn _ arg_bndrs body arg_occs)
1178 spec_info@(SI specs spec_count mb_unspec)
1179 | not (isBottomingId fn) -- Note [Do not specialise diverging functions]
1180 , notNull arg_bndrs -- Only specialise functions
1181 , Just all_calls <- lookupVarEnv bind_calls fn
1182 = do { (boring_call, pats) <- callsToPats env specs arg_occs all_calls
1183 -- ; pprTrace "specialise" (vcat [ ppr fn <+> text "with" <+> int (length pats) <+> text "good patterns"
1184 -- , text "arg_occs" <+> ppr arg_occs
1185 -- , text "calls" <+> ppr all_calls
1186 -- , text "good pats" <+> ppr pats]) $
1189 -- Bale out if too many specialisations
1190 ; let n_pats = length pats
1191 spec_count' = n_pats + spec_count
1192 ; case sc_count env of
1193 Just max | not force_spec && spec_count' > max
1194 -> pprTrace "SpecConstr" msg $
1195 return (nullUsage, spec_info)
1197 msg = vcat [ sep [ ptext (sLit "Function") <+> quotes (ppr fn)
1198 , nest 2 (ptext (sLit "has") <+>
1199 speakNOf spec_count' (ptext (sLit "call pattern")) <> comma <+>
1200 ptext (sLit "but the limit is") <+> int max) ]
1201 , ptext (sLit "Use -fspec-constr-count=n to set the bound")
1203 extra | not opt_PprStyle_Debug = ptext (sLit "Use -dppr-debug to see specialisations")
1204 | otherwise = ptext (sLit "Specialisations:") <+> ppr (pats ++ [p | OS p _ _ _ <- specs])
1206 _normal_case -> do {
1208 let spec_env = decreaseSpecCount env n_pats
1209 ; (spec_usgs, new_specs) <- mapAndUnzipM (spec_one spec_env fn arg_bndrs body)
1210 (pats `zip` [spec_count..])
1211 -- See Note [Specialise original body]
1213 ; let spec_usg = combineUsages spec_usgs
1214 (new_usg, mb_unspec')
1216 Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing)
1217 _ -> (spec_usg, mb_unspec)
1219 ; return (new_usg, SI (new_specs ++ specs) spec_count' mb_unspec') } }
1221 = return (nullUsage, spec_info) -- The boring case
1224 ---------------------
1226 -> OutId -- Function
1227 -> [InVar] -- Lambda-binders of RHS; should match patterns
1228 -> InExpr -- Body of the original function
1230 -> UniqSM (ScUsage, OneSpec) -- Rule and binding
1232 -- spec_one creates a specialised copy of the function, together
1233 -- with a rule for using it. I'm very proud of how short this
1234 -- function is, considering what it does :-).
1240 f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
1241 [c::*, v::(b,c) are presumably bound by the (...) part]
1243 f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
1244 (...entire body of f...) [b -> (b,c),
1245 y -> ((:) (a,(b,c)) (x,v) hw)]
1247 RULE: forall b::* c::*, -- Note, *not* forall a, x
1251 f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
1254 spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)
1255 = do { spec_uniq <- getUniqueUs
1256 ; let spec_env = extendScSubstList (extendScInScope env qvars)
1257 (arg_bndrs `zip` pats)
1259 fn_loc = nameSrcSpan fn_name
1260 spec_occ = mkSpecOcc (nameOccName fn_name)
1261 rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number))
1262 spec_name = mkInternalName spec_uniq spec_occ fn_loc
1263 -- ; pprTrace "{spec_one" (ppr (sc_count env) <+> ppr fn <+> ppr pats <+> text "-->" <+> ppr spec_name) $
1266 -- Specialise the body
1267 ; (spec_usg, spec_body) <- scExpr spec_env body
1269 -- ; pprTrace "done spec_one}" (ppr fn) $
1272 -- And build the results
1273 ; let spec_id = mkLocalId spec_name (mkPiTypes spec_lam_args body_ty)
1274 `setIdStrictness` spec_str -- See Note [Transfer strictness]
1275 `setIdArity` count isId spec_lam_args
1276 spec_str = calcSpecStrictness fn spec_lam_args pats
1277 (spec_lam_args, spec_call_args) = mkWorkerArgs qvars body_ty
1278 -- Usual w/w hack to avoid generating
1279 -- a spec_rhs of unlifted type and no args
1281 spec_rhs = mkLams spec_lam_args spec_body
1282 body_ty = exprType spec_body
1283 rule_rhs = mkVarApps (Var spec_id) spec_call_args
1284 inline_act = idInlineActivation fn
1285 rule = mkLocalRule rule_name inline_act fn_name qvars pats rule_rhs
1286 ; return (spec_usg, OS call_pat rule spec_id spec_rhs) }
1288 calcSpecStrictness :: Id -- The original function
1289 -> [Var] -> [CoreExpr] -- Call pattern
1290 -> StrictSig -- Strictness of specialised thing
1291 -- See Note [Transfer strictness]
1292 calcSpecStrictness fn qvars pats
1293 = StrictSig (mkTopDmdType spec_dmds TopRes)
1295 spec_dmds = [ lookupVarEnv dmd_env qv `orElse` lazyDmd | qv <- qvars, isId qv ]
1296 StrictSig (DmdType _ dmds _) = idStrictness fn
1298 dmd_env = go emptyVarEnv dmds pats
1300 go env ds (Type {} : pats) = go env ds pats
1301 go env (d:ds) (pat : pats) = go (go_one env d pat) ds pats
1304 go_one env d (Var v) = extendVarEnv_C both env v d
1305 go_one env (Box d) e = go_one env d e
1306 go_one env (Eval (Prod ds)) e
1307 | (Var _, args) <- collectArgs e = go env ds args
1308 go_one env _ _ = env
1312 Note [Specialise original body]
1313 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1314 The RhsInfo for a binding keeps the *original* body of the binding. We
1315 must specialise that, *not* the result of applying specExpr to the RHS
1316 (which is also kept in RhsInfo). Otherwise we end up specialising a
1317 specialised RHS, and that can lead directly to exponential behaviour.
1319 Note [Transfer activation]
1320 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1321 In which phase should the specialise-constructor rules be active?
1322 Originally I made them always-active, but Manuel found that this
1323 defeated some clever user-written rules. Then I made them active only
1324 in Phase 0; after all, currently, the specConstr transformation is
1325 only run after the simplifier has reached Phase 0, but that meant
1326 that specialisations didn't fire inside wrappers; see test
1327 simplCore/should_compile/spec-inline.
1329 So now I just use the inline-activation of the parent Id, as the
1330 activation for the specialiation RULE, just like the main specialiser;
1331 see Note [Auto-specialisation and RULES] in Specialise.
1334 Note [Transfer strictness]
1335 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1336 We must transfer strictness information from the original function to
1337 the specialised one. Suppose, for example
1340 and a RULE f (a:as) b = f_spec a as b
1342 Now we want f_spec to have strictess LLS, otherwise we'll use call-by-need
1343 when calling f_spec instead of call-by-value. And that can result in
1344 unbounded worsening in space (cf the classic foldl vs foldl')
1346 See Trac #3437 for a good example.
1348 The function calcSpecStrictness performs the calculation.
1351 %************************************************************************
1353 \subsection{Argument analysis}
1355 %************************************************************************
1357 This code deals with analysing call-site arguments to see whether
1358 they are constructor applications.
1362 type CallPat = ([Var], [CoreExpr]) -- Quantified variables and arguments
1365 callsToPats :: ScEnv -> [OneSpec] -> [ArgOcc] -> [Call] -> UniqSM (Bool, [CallPat])
1366 -- Result has no duplicate patterns,
1367 -- nor ones mentioned in done_pats
1368 -- Bool indicates that there was at least one boring pattern
1369 callsToPats env done_specs bndr_occs calls
1370 = do { mb_pats <- mapM (callToPats env bndr_occs) calls
1372 ; let good_pats :: [([Var], [CoreArg])]
1373 good_pats = catMaybes mb_pats
1374 done_pats = [p | OS p _ _ _ <- done_specs]
1375 is_done p = any (samePat p) done_pats
1377 ; return (any isNothing mb_pats,
1378 filterOut is_done (nubBy samePat good_pats)) }
1380 callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
1381 -- The [Var] is the variables to quantify over in the rule
1382 -- Type variables come first, since they may scope
1383 -- over the following term variables
1384 -- The [CoreExpr] are the argument patterns for the rule
1385 callToPats env bndr_occs (con_env, args)
1386 | length args < length bndr_occs -- Check saturated
1389 = do { let in_scope = substInScope (sc_subst env)
1390 ; prs <- argsToPats env in_scope con_env (args `zip` bndr_occs)
1391 ; let (interesting_s, pats) = unzip prs
1392 pat_fvs = varSetElems (exprsFreeVars pats)
1393 qvars = filterOut (`elemInScopeSet` in_scope) pat_fvs
1394 -- Quantify over variables that are not in sccpe
1396 -- See Note [Shadowing] at the top
1398 (tvs, ids) = partition isTyVar qvars
1400 -- Put the type variables first; the type of a term
1401 -- variable may mention a type variable
1403 ; -- pprTrace "callToPats" (ppr args $$ ppr prs $$ ppr bndr_occs) $
1405 then return (Just (qvars', pats))
1406 else return Nothing }
1408 -- argToPat takes an actual argument, and returns an abstracted
1409 -- version, consisting of just the "constructor skeleton" of the
1410 -- argument, with non-constructor sub-expression replaced by new
1411 -- placeholder variables. For example:
1412 -- C a (D (f x) (g y)) ==> C p1 (D p2 p3)
1415 -> InScopeSet -- What's in scope at the fn defn site
1416 -> ValueEnv -- ValueEnv at the call site
1417 -> CoreArg -- A call arg (or component thereof)
1419 -> UniqSM (Bool, CoreArg)
1420 -- Returns (interesting, pat),
1421 -- where pat is the pattern derived from the argument
1422 -- intersting=True if the pattern is non-trivial (not a variable or type)
1423 -- E.g. x:xs --> (True, x:xs)
1424 -- f xs --> (False, w) where w is a fresh wildcard
1425 -- (f xs, 'c') --> (True, (w, 'c')) where w is a fresh wildcard
1426 -- \x. x+y --> (True, \x. x+y)
1427 -- lvl7 --> (True, lvl7) if lvl7 is bound
1428 -- somewhere further out
1430 argToPat _env _in_scope _val_env arg@(Type {}) _arg_occ
1431 = return (False, arg)
1433 argToPat env in_scope val_env (Note _ arg) arg_occ
1434 = argToPat env in_scope val_env arg arg_occ
1435 -- Note [Notes in call patterns]
1436 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1437 -- Ignore Notes. In particular, we want to ignore any InlineMe notes
1438 -- Perhaps we should not ignore profiling notes, but I'm going to
1439 -- ride roughshod over them all for now.
1440 --- See Note [Notes in RULE matching] in Rules
1442 argToPat env in_scope val_env (Let _ arg) arg_occ
1443 = argToPat env in_scope val_env arg arg_occ
1444 -- Look through let expressions
1445 -- e.g. f (let v = rhs in \y -> ...v...)
1446 -- Here we can specialise for f (\y -> ...)
1447 -- because the rule-matcher will look through the let.
1449 argToPat env in_scope val_env (Cast arg co) arg_occ
1450 | not (ignoreType env ty2)
1451 = do { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ
1452 ; if not interesting then
1455 { -- Make a wild-card pattern for the coercion
1457 ; let co_name = mkSysTvName uniq (fsLit "sg")
1458 co_var = mkCoVar co_name (mkCoKind ty1 ty2)
1459 ; return (interesting, Cast arg' (mkTyVarTy co_var)) } }
1461 (ty1, ty2) = coercionKind co
1465 {- Disabling lambda specialisation for now
1466 It's fragile, and the spec_loop can be infinite
1467 argToPat in_scope val_env arg arg_occ
1469 = return (True, arg)
1471 is_value_lam (Lam v e) -- Spot a value lambda, even if
1472 | isId v = True -- it is inside a type lambda
1473 | otherwise = is_value_lam e
1474 is_value_lam other = False
1477 -- Check for a constructor application
1478 -- NB: this *precedes* the Var case, so that we catch nullary constrs
1479 argToPat env in_scope val_env arg arg_occ
1480 | Just (ConVal dc args) <- isValue val_env arg
1481 , not (ignoreAltCon env dc)
1483 ScrutOcc _ -> True -- Used only by case scrutinee
1484 BothOcc -> case arg of -- Used elsewhere
1485 App {} -> True -- see Note [Reboxing]
1487 _other -> False -- No point; the arg is not decomposed
1488 = do { args' <- argsToPats env in_scope val_env (args `zip` conArgOccs arg_occ dc)
1489 ; return (True, mk_con_app dc (map snd args')) }
1491 -- Check if the argument is a variable that
1492 -- is in scope at the function definition site
1493 -- It's worth specialising on this if
1494 -- (a) it's used in an interesting way in the body
1495 -- (b) we know what its value is
1496 argToPat env in_scope val_env (Var v) arg_occ
1497 | case arg_occ of { UnkOcc -> False; _other -> True }, -- (a)
1499 not (ignoreType env (varType v))
1500 = return (True, Var v)
1503 | isLocalId v = v `elemInScopeSet` in_scope
1504 && isJust (lookupVarEnv val_env v)
1505 -- Local variables have values in val_env
1506 | otherwise = isValueUnfolding (idUnfolding v)
1507 -- Imports have unfoldings
1509 -- I'm really not sure what this comment means
1510 -- And by not wild-carding we tend to get forall'd
1511 -- variables that are in soope, which in turn can
1512 -- expose the weakness in let-matching
1513 -- See Note [Matching lets] in Rules
1515 -- Check for a variable bound inside the function.
1516 -- Don't make a wild-card, because we may usefully share
1517 -- e.g. f a = let x = ... in f (x,x)
1518 -- NB: this case follows the lambda and con-app cases!!
1519 -- argToPat _in_scope _val_env (Var v) _arg_occ
1520 -- = return (False, Var v)
1521 -- SLPJ : disabling this to avoid proliferation of versions
1522 -- also works badly when thinking about seeding the loop
1523 -- from the body of the let
1524 -- f x y = letrec g z = ... in g (x,y)
1525 -- We don't want to specialise for that *particular* x,y
1527 -- The default case: make a wild-card
1528 argToPat _env _in_scope _val_env arg _arg_occ
1529 = wildCardPat (exprType arg)
1531 wildCardPat :: Type -> UniqSM (Bool, CoreArg)
1532 wildCardPat ty = do { uniq <- getUniqueUs
1533 ; let id = mkSysLocal (fsLit "sc") uniq ty
1534 ; return (False, Var id) }
1536 argsToPats :: ScEnv -> InScopeSet -> ValueEnv
1537 -> [(CoreArg, ArgOcc)]
1538 -> UniqSM [(Bool, CoreArg)]
1539 argsToPats env in_scope val_env args
1542 do_one (arg,occ) = argToPat env in_scope val_env arg occ
1547 isValue :: ValueEnv -> CoreExpr -> Maybe Value
1548 isValue _env (Lit lit)
1549 = Just (ConVal (LitAlt lit) [])
1552 | Just stuff <- lookupVarEnv env v
1553 = Just stuff -- You might think we could look in the idUnfolding here
1554 -- but that doesn't take account of which branch of a
1555 -- case we are in, which is the whole point
1557 | not (isLocalId v) && isCheapUnfolding unf
1558 = isValue env (unfoldingTemplate unf)
1561 -- However we do want to consult the unfolding
1562 -- as well, for let-bound constructors!
1564 isValue env (Lam b e)
1565 | isTyVar b = case isValue env e of
1566 Just _ -> Just LambdaVal
1568 | otherwise = Just LambdaVal
1570 isValue _env expr -- Maybe it's a constructor application
1571 | (Var fun, args) <- collectArgs expr
1572 = case isDataConWorkId_maybe fun of
1574 Just con | args `lengthAtLeast` dataConRepArity con
1575 -- Check saturated; might be > because the
1576 -- arity excludes type args
1577 -> Just (ConVal (DataAlt con) args)
1579 _other | valArgCount args < idArity fun
1580 -- Under-applied function
1581 -> Just LambdaVal -- Partial application
1585 isValue _env _expr = Nothing
1587 mk_con_app :: AltCon -> [CoreArg] -> CoreExpr
1588 mk_con_app (LitAlt lit) [] = Lit lit
1589 mk_con_app (DataAlt con) args = mkConApp con args
1590 mk_con_app _other _args = panic "SpecConstr.mk_con_app"
1592 samePat :: CallPat -> CallPat -> Bool
1593 samePat (vs1, as1) (vs2, as2)
1596 same (Var v1) (Var v2)
1597 | v1 `elem` vs1 = v2 `elem` vs2
1598 | v2 `elem` vs2 = False
1599 | otherwise = v1 == v2
1601 same (Lit l1) (Lit l2) = l1==l2
1602 same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2
1604 same (Type {}) (Type {}) = True -- Note [Ignore type differences]
1605 same (Note _ e1) e2 = same e1 e2 -- Ignore casts and notes
1606 same (Cast e1 _) e2 = same e1 e2
1607 same e1 (Note _ e2) = same e1 e2
1608 same e1 (Cast e2 _) = same e1 e2
1610 same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2)
1611 False -- Let, lambda, case should not occur
1612 bad (Case {}) = True
1618 Note [Ignore type differences]
1619 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1620 We do not want to generate specialisations where the call patterns
1621 differ only in their type arguments! Not only is it utterly useless,
1622 but it also means that (with polymorphic recursion) we can generate
1623 an infinite number of specialisations. Example is Data.Sequence.adjustTree,