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 -----------------------------------------------------
393 Stuff not yet handled
394 -----------------------------------------------------
396 Here are notes arising from Roman's work that I don't want to lose.
402 foo :: Int -> T Int -> Int
404 foo x t | even x = case t of { T n -> foo (x-n) t }
405 | otherwise = foo (x-1) t
407 SpecConstr does no specialisation, because the second recursive call
408 looks like a boxed use of the argument. A pity.
410 $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
412 \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) ->
413 case ww_sFo of ds_Xw6 [Just L] {
415 case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] {
416 __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq;
418 case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] ->
419 case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] ->
420 $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy
426 data a :*: b = !a :*: !b
429 foo :: (Int :*: T Int) -> Int
431 foo (x :*: t) | even x = case t of { T n -> foo ((x-n) :*: t) }
432 | otherwise = foo ((x-1) :*: t)
434 Very similar to the previous one, except that the parameters are now in
435 a strict tuple. Before SpecConstr, we have
437 $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
439 \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T
441 case ww_sFU of ds_Xws [Just L] {
443 case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] {
445 case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] ->
446 $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2 -- $wfoo1
449 case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] ->
450 case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] ->
451 $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB -- $wfoo2
455 We get two specialisations:
456 "SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#}
457 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB)
458 = Foo.$s$wfoo1 a_sFB sc_sGC ;
459 "SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#}
460 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp))
461 = Foo.$s$wfoo y_aFp sc_sGC ;
463 But perhaps the first one isn't good. After all, we know that tpl_B2 is
464 a T (I# x) really, because T is strict and Int has one constructor. (We can't
465 unbox the strict fields, becuase T is polymorphic!)
467 %************************************************************************
469 \subsection{Annotations}
471 %************************************************************************
473 Annotating a type with NoSpecConstr will make SpecConstr not specialise
474 for arguments of that type.
477 data SpecConstrAnnotation = NoSpecConstr | ForceSpecConstr
478 deriving( Data, Typeable, Eq )
481 %************************************************************************
483 \subsection{Top level wrapper stuff}
485 %************************************************************************
488 specConstrProgram :: ModGuts -> CoreM ModGuts
489 specConstrProgram guts
491 dflags <- getDynFlags
492 us <- getUniqueSupplyM
493 annos <- getFirstAnnotations deserializeWithData guts
494 let binds' = fst $ initUs us (go (initScEnv dflags annos) (mg_binds guts))
495 return (guts { mg_binds = binds' })
498 go env (bind:binds) = do (env', bind') <- scTopBind env bind
499 binds' <- go env' binds
500 return (bind' : binds')
504 %************************************************************************
506 \subsection{Environment: goes downwards}
508 %************************************************************************
511 data ScEnv = SCE { sc_size :: Maybe Int, -- Size threshold
512 sc_count :: Maybe Int, -- Max # of specialisations for any one fn
514 sc_subst :: Subst, -- Current substitution
515 -- Maps InIds to OutExprs
517 sc_how_bound :: HowBoundEnv,
518 -- Binds interesting non-top-level variables
519 -- Domain is OutVars (*after* applying the substitution)
522 -- Domain is OutIds (*after* applying the substitution)
523 -- Used even for top-level bindings (but not imported ones)
525 sc_annotations :: L.UniqFM SpecConstrAnnotation
528 ---------------------
529 -- As we go, we apply a substitution (sc_subst) to the current term
530 type InExpr = CoreExpr -- _Before_ applying the subst
532 type OutExpr = CoreExpr -- _After_ applying the subst
536 ---------------------
537 type HowBoundEnv = VarEnv HowBound -- Domain is OutVars
539 ---------------------
540 type ValueEnv = IdEnv Value -- Domain is OutIds
541 data Value = ConVal AltCon [CoreArg] -- _Saturated_ constructors
542 | LambdaVal -- Inlinable lambdas or PAPs
544 instance Outputable Value where
545 ppr (ConVal con args) = ppr con <+> interpp'SP args
546 ppr LambdaVal = ptext (sLit "<Lambda>")
548 ---------------------
549 initScEnv :: DynFlags -> L.UniqFM SpecConstrAnnotation -> ScEnv
550 initScEnv dflags anns
551 = SCE { sc_size = specConstrThreshold dflags,
552 sc_count = specConstrCount dflags,
553 sc_subst = emptySubst,
554 sc_how_bound = emptyVarEnv,
555 sc_vals = emptyVarEnv,
556 sc_annotations = anns }
558 data HowBound = RecFun -- These are the recursive functions for which
559 -- we seek interesting call patterns
561 | RecArg -- These are those functions' arguments, or their sub-components;
562 -- we gather occurrence information for these
564 instance Outputable HowBound where
565 ppr RecFun = text "RecFun"
566 ppr RecArg = text "RecArg"
568 lookupHowBound :: ScEnv -> Id -> Maybe HowBound
569 lookupHowBound env id = lookupVarEnv (sc_how_bound env) id
571 scSubstId :: ScEnv -> Id -> CoreExpr
572 scSubstId env v = lookupIdSubst (text "scSubstId") (sc_subst env) v
574 scSubstTy :: ScEnv -> Type -> Type
575 scSubstTy env ty = substTy (sc_subst env) ty
577 zapScSubst :: ScEnv -> ScEnv
578 zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) }
580 extendScInScope :: ScEnv -> [Var] -> ScEnv
581 -- Bring the quantified variables into scope
582 extendScInScope env qvars = env { sc_subst = extendInScopeList (sc_subst env) qvars }
584 -- Extend the substitution
585 extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv
586 extendScSubst env var expr = env { sc_subst = extendSubst (sc_subst env) var expr }
588 extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv
589 extendScSubstList env prs = env { sc_subst = extendSubstList (sc_subst env) prs }
591 extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv
592 extendHowBound env bndrs how_bound
593 = env { sc_how_bound = extendVarEnvList (sc_how_bound env)
594 [(bndr,how_bound) | bndr <- bndrs] }
596 extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var])
597 extendBndrsWith how_bound env bndrs
598 = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndrs')
600 (subst', bndrs') = substBndrs (sc_subst env) bndrs
601 hb_env' = sc_how_bound env `extendVarEnvList`
602 [(bndr,how_bound) | bndr <- bndrs']
604 extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var)
605 extendBndrWith how_bound env bndr
606 = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndr')
608 (subst', bndr') = substBndr (sc_subst env) bndr
609 hb_env' = extendVarEnv (sc_how_bound env) bndr' how_bound
611 extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var])
612 extendRecBndrs env bndrs = (env { sc_subst = subst' }, bndrs')
614 (subst', bndrs') = substRecBndrs (sc_subst env) bndrs
616 extendBndr :: ScEnv -> Var -> (ScEnv, Var)
617 extendBndr env bndr = (env { sc_subst = subst' }, bndr')
619 (subst', bndr') = substBndr (sc_subst env) bndr
621 extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv
622 extendValEnv env _ Nothing = env
623 extendValEnv env id (Just cv) = env { sc_vals = extendVarEnv (sc_vals env) id cv }
625 extendCaseBndrs :: ScEnv -> Id -> AltCon -> [Var] -> (ScEnv, [Var])
629 -- we want to bind b, to (C x y)
630 -- NB1: Extends only the sc_vals part of the envt
631 -- NB2: Kill the dead-ness info on the pattern binders x,y, since
632 -- they are potentially made alive by the [b -> C x y] binding
633 extendCaseBndrs env case_bndr con alt_bndrs
634 | isDeadBinder case_bndr
637 = (env1, map zap alt_bndrs)
638 -- NB: We used to bind v too, if scrut = (Var v); but
639 -- the simplifer has already done this so it seems
640 -- redundant to do so here
642 -- Var v -> extendValEnv env1 v cval
645 zap v | isTyVar v = v -- See NB2 above
646 | otherwise = zapIdOccInfo v
647 env1 = extendValEnv env case_bndr cval
650 LitAlt {} -> Just (ConVal con [])
651 DataAlt {} -> Just (ConVal con vanilla_args)
653 vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
654 varsToCoreExprs alt_bndrs
656 ignoreTyCon :: ScEnv -> TyCon -> Bool
657 ignoreTyCon env tycon
658 = L.lookupUFM (sc_annotations env) tycon == Just NoSpecConstr
660 ignoreType :: ScEnv -> Type -> Bool
662 = case splitTyConApp_maybe ty of
663 Just (tycon, _) -> ignoreTyCon env tycon
666 ignoreAltCon :: ScEnv -> AltCon -> Bool
667 ignoreAltCon env (DataAlt dc) = ignoreTyCon env (dataConTyCon dc)
668 ignoreAltCon env (LitAlt lit) = ignoreType env (literalType lit)
669 ignoreAltCon _ DEFAULT = True
671 forceSpecBndr :: ScEnv -> Var -> Bool
672 forceSpecBndr env var = forceSpecFunTy env . varType $ var
674 forceSpecFunTy :: ScEnv -> Type -> Bool
675 forceSpecFunTy env = any (forceSpecArgTy env) . fst . splitFunTys
677 forceSpecArgTy :: ScEnv -> Type -> Bool
678 forceSpecArgTy env ty
679 | Just ty' <- coreView ty = forceSpecArgTy env ty'
681 forceSpecArgTy env ty
682 | Just (tycon, tys) <- splitTyConApp_maybe ty
684 = L.lookupUFM (sc_annotations env) tycon == Just ForceSpecConstr
685 || any (forceSpecArgTy env) tys
687 forceSpecArgTy _ _ = False
691 %************************************************************************
693 \subsection{Usage information: flows upwards}
695 %************************************************************************
700 scu_calls :: CallEnv, -- Calls
701 -- The functions are a subset of the
702 -- RecFuns in the ScEnv
704 scu_occs :: !(IdEnv ArgOcc) -- Information on argument occurrences
705 } -- The domain is OutIds
707 type CallEnv = IdEnv [Call]
708 type Call = (ValueEnv, [CoreArg])
709 -- The arguments of the call, together with the
710 -- env giving the constructor bindings at the call site
713 nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv }
715 combineCalls :: CallEnv -> CallEnv -> CallEnv
716 combineCalls = plusVarEnv_C (++)
718 combineUsage :: ScUsage -> ScUsage -> ScUsage
719 combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2),
720 scu_occs = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) }
722 combineUsages :: [ScUsage] -> ScUsage
723 combineUsages [] = nullUsage
724 combineUsages us = foldr1 combineUsage us
726 lookupOcc :: ScUsage -> OutVar -> (ScUsage, ArgOcc)
727 lookupOcc (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndr
728 = (SCU {scu_calls = sc_calls, scu_occs = delVarEnv sc_occs bndr},
729 lookupVarEnv sc_occs bndr `orElse` NoOcc)
731 lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc])
732 lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs
733 = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs},
734 [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs])
736 data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument
737 | UnkOcc -- Used in some unknown way
739 | ScrutOcc (UniqFM [ArgOcc]) -- See Note [ScrutOcc]
741 | BothOcc -- Definitely taken apart, *and* perhaps used in some other way
745 An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing,
746 is *only* taken apart or applied.
748 Functions, literal: ScrutOcc emptyUFM
749 Data constructors: ScrutOcc subs,
751 where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components,
752 The domain of the UniqFM is the Unique of the data constructor
754 The [ArgOcc] is the occurrences of the *pattern-bound* components
755 of the data structure. E.g.
756 data T a = forall b. MkT a b (b->a)
757 A pattern binds b, x::a, y::b, z::b->a, but not 'a'!
761 instance Outputable ArgOcc where
762 ppr (ScrutOcc xs) = ptext (sLit "scrut-occ") <> ppr xs
763 ppr UnkOcc = ptext (sLit "unk-occ")
764 ppr BothOcc = ptext (sLit "both-occ")
765 ppr NoOcc = ptext (sLit "no-occ")
767 -- Experimentally, this vesion of combineOcc makes ScrutOcc "win", so
768 -- that if the thing is scrutinised anywhere then we get to see that
769 -- in the overall result, even if it's also used in a boxed way
770 -- This might be too agressive; see Note [Reboxing] Alternative 3
771 combineOcc :: ArgOcc -> ArgOcc -> ArgOcc
772 combineOcc NoOcc occ = occ
773 combineOcc occ NoOcc = occ
774 combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys)
775 combineOcc _occ (ScrutOcc ys) = ScrutOcc ys
776 combineOcc (ScrutOcc xs) _occ = ScrutOcc xs
777 combineOcc UnkOcc UnkOcc = UnkOcc
778 combineOcc _ _ = BothOcc
780 combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]
781 combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys
783 setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage
784 -- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee
785 -- is a variable, and an interesting variable
786 setScrutOcc env usg (Cast e _) occ = setScrutOcc env usg e occ
787 setScrutOcc env usg (Note _ e) occ = setScrutOcc env usg e occ
788 setScrutOcc env usg (Var v) occ
789 | Just RecArg <- lookupHowBound env v = usg { scu_occs = extendVarEnv (scu_occs usg) v occ }
791 setScrutOcc _env usg _other _occ -- Catch-all
794 conArgOccs :: ArgOcc -> AltCon -> [ArgOcc]
795 -- Find usage of components of data con; returns [UnkOcc...] if unknown
796 -- See Note [ScrutOcc] for the extra UnkOccs in the vanilla datacon case
798 conArgOccs (ScrutOcc fm) (DataAlt dc)
799 | Just pat_arg_occs <- lookupUFM fm dc
800 = [UnkOcc | _ <- dataConUnivTyVars dc] ++ pat_arg_occs
802 conArgOccs _other _con = repeat UnkOcc
805 %************************************************************************
807 \subsection{The main recursive function}
809 %************************************************************************
811 The main recursive function gathers up usage information, and
812 creates specialised versions of functions.
815 scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
816 -- The unique supply is needed when we invent
817 -- a new name for the specialised function and its args
819 scExpr env e = scExpr' env e
822 scExpr' env (Var v) = case scSubstId env v of
823 Var v' -> return (varUsage env v' UnkOcc, Var v')
824 e' -> scExpr (zapScSubst env) e'
826 scExpr' env (Type t) = return (nullUsage, Type (scSubstTy env t))
827 scExpr' _ e@(Lit {}) = return (nullUsage, e)
828 scExpr' env (Note n e) = do (usg,e') <- scExpr env e
829 return (usg, Note n e')
830 scExpr' env (Cast e co) = do (usg, e') <- scExpr env e
831 return (usg, Cast e' (scSubstTy env co))
832 scExpr' env e@(App _ _) = scApp env (collectArgs e)
833 scExpr' env (Lam b e) = do let (env', b') = extendBndr env b
834 (usg, e') <- scExpr env' e
835 return (usg, Lam b' e')
837 scExpr' env (Case scrut b ty alts)
838 = do { (scrut_usg, scrut') <- scExpr env scrut
839 ; case isValue (sc_vals env) scrut' of
840 Just (ConVal con args) -> sc_con_app con args scrut'
841 _other -> sc_vanilla scrut_usg scrut'
844 sc_con_app con args scrut' -- Known constructor; simplify
845 = do { let (_, bs, rhs) = findAlt con alts
846 `orElse` (DEFAULT, [], mkImpossibleExpr (coreAltsType alts))
847 alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)
848 ; scExpr alt_env' rhs }
850 sc_vanilla scrut_usg scrut' -- Normal case
851 = do { let (alt_env,b') = extendBndrWith RecArg env b
852 -- Record RecArg for the components
854 ; (alt_usgs, alt_occs, alts')
855 <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts
857 ; let (alt_usg, b_occ) = lookupOcc (combineUsages alt_usgs) b'
858 scrut_occ = foldr combineOcc b_occ alt_occs
859 scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ
860 -- The combined usage of the scrutinee is given
861 -- by scrut_occ, which is passed to scScrut, which
862 -- in turn treats a bare-variable scrutinee specially
864 ; return (alt_usg `combineUsage` scrut_usg',
865 Case scrut' b' (scSubstTy env ty) alts') }
867 sc_alt env _scrut' b' (con,bs,rhs)
868 = do { let (env1, bs1) = extendBndrsWith RecArg env bs
869 (env2, bs2) = extendCaseBndrs env1 b' con bs1
870 ; (usg,rhs') <- scExpr env2 rhs
871 ; let (usg', arg_occs) = lookupOccs usg bs2
872 scrut_occ = case con of
873 DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)
874 _ -> ScrutOcc emptyUFM
875 ; return (usg', scrut_occ, (con, bs2, rhs')) }
877 scExpr' env (Let (NonRec bndr rhs) body)
878 | isTyVar bndr -- Type-lets may be created by doBeta
879 = scExpr' (extendScSubst env bndr rhs) body
881 | otherwise -- Note [Local let bindings]
882 = do { let (body_env, bndr') = extendBndr env bndr
883 ; (rhs_usg, rhs_info) <- scRecRhs env (bndr',rhs)
884 ; let force_spec = False
885 ; let body_env2 = extendHowBound body_env [bndr'] RecFun
886 ; (body_usg, body') <- scExpr body_env2 body
887 ; (spec_usg, specs) <- specialise env force_spec
892 ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' }
893 `combineUsage` rhs_usg `combineUsage` spec_usg,
894 mkLets [NonRec b r | (b,r) <- specInfoBinds rhs_info specs] body')
898 -- A *local* recursive group: see Note [Local recursive groups]
899 scExpr' env (Let (Rec prs) body)
900 = do { let (bndrs,rhss) = unzip prs
901 (rhs_env1,bndrs') = extendRecBndrs env bndrs
902 rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
903 force_spec = any (forceSpecBndr env) bndrs'
905 ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
906 ; (body_usg, body') <- scExpr rhs_env2 body
908 -- NB: start specLoop from body_usg
909 ; (spec_usg, specs) <- specLoop rhs_env2 force_spec
910 (scu_calls body_usg) rhs_infos nullUsage
911 [SI [] 0 (Just usg) | usg <- rhs_usgs]
913 ; let all_usg = spec_usg `combineUsage` body_usg
914 bind' = Rec (concat (zipWith specInfoBinds rhs_infos specs))
916 ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' },
920 Note [Local let bindings]
921 ~~~~~~~~~~~~~~~~~~~~~~~~~
922 It is not uncommon to find this
924 let $j = \x. <blah> in ...$j True...$j True...
926 Here $j is an arbitrary let-bound function, but it often comes up for
927 join points. We might like to specialise $j for its call patterns.
928 Notice the difference from a letrec, where we look for call patterns
929 in the *RHS* of the function. Here we look for call patterns in the
932 At one point I predicated this on the RHS mentioning the outer
933 recursive function, but that's not essential and might even be
934 harmful. I'm not sure.
938 scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)
940 scApp env (Var fn, args) -- Function is a variable
941 = ASSERT( not (null args) )
942 do { args_w_usgs <- mapM (scExpr env) args
943 ; let (arg_usgs, args') = unzip args_w_usgs
944 arg_usg = combineUsages arg_usgs
945 ; case scSubstId env fn of
946 fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args')
947 -- Do beta-reduction and try again
949 Var fn' -> return (arg_usg `combineUsage` fn_usg, mkApps (Var fn') args')
951 fn_usg = case lookupHowBound env fn' of
952 Just RecFun -> SCU { scu_calls = unitVarEnv fn' [(sc_vals env, args')],
953 scu_occs = emptyVarEnv }
954 Just RecArg -> SCU { scu_calls = emptyVarEnv,
955 scu_occs = unitVarEnv fn' (ScrutOcc emptyUFM) }
959 other_fn' -> return (arg_usg, mkApps other_fn' args') }
960 -- NB: doing this ignores any usage info from the substituted
961 -- function, but I don't think that matters. If it does
964 doBeta :: OutExpr -> [OutExpr] -> OutExpr
965 -- ToDo: adjust for System IF
966 doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args)
967 doBeta fn args = mkApps fn args
969 -- The function is almost always a variable, but not always.
970 -- In particular, if this pass follows float-in,
971 -- which it may, we can get
972 -- (let f = ...f... in f) arg1 arg2
973 scApp env (other_fn, args)
974 = do { (fn_usg, fn') <- scExpr env other_fn
975 ; (arg_usgs, args') <- mapAndUnzipM (scExpr env) args
976 ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') }
978 ----------------------
979 scTopBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind)
980 scTopBind env (Rec prs)
981 | Just threshold <- sc_size env
983 , not (all (couldBeSmallEnoughToInline threshold) rhss)
985 = do { let (rhs_env,bndrs') = extendRecBndrs env bndrs
986 ; (_, rhss') <- mapAndUnzipM (scExpr rhs_env) rhss
987 ; return (rhs_env, Rec (bndrs' `zip` rhss')) }
988 | otherwise -- Do specialisation
989 = do { let (rhs_env1,bndrs') = extendRecBndrs env bndrs
990 rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
992 ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
993 ; let rhs_usg = combineUsages rhs_usgs
995 ; (_, specs) <- specLoop rhs_env2 force_spec
996 (scu_calls rhs_usg) rhs_infos nullUsage
997 [SI [] 0 Nothing | _ <- bndrs]
999 ; return (rhs_env1, -- For the body of the letrec, delete the RecFun business
1000 Rec (concat (zipWith specInfoBinds rhs_infos specs))) }
1002 (bndrs,rhss) = unzip prs
1003 force_spec = any (forceSpecBndr env) bndrs
1005 scTopBind env (NonRec bndr rhs)
1006 = do { (_, rhs') <- scExpr env rhs
1007 ; let (env1, bndr') = extendBndr env bndr
1008 env2 = extendValEnv env1 bndr' (isValue (sc_vals env) rhs')
1009 ; return (env2, NonRec bndr' rhs') }
1011 ----------------------
1012 scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM (ScUsage, RhsInfo)
1013 scRecRhs env (bndr,rhs)
1014 = do { let (arg_bndrs,body) = collectBinders rhs
1015 (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs
1016 ; (body_usg, body') <- scExpr body_env body
1017 ; let (rhs_usg, arg_occs) = lookupOccs body_usg arg_bndrs'
1018 ; return (rhs_usg, (bndr, arg_bndrs', body', arg_occs)) }
1020 -- The arg_occs says how the visible,
1021 -- lambda-bound binders of the RHS are used
1022 -- (including the TyVar binders)
1023 -- Two pats are the same if they match both ways
1025 ----------------------
1026 specInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)]
1027 specInfoBinds (fn, args, body, _) (SI specs _ _)
1028 = [(id,rhs) | OS _ _ id rhs <- specs] ++
1029 [(fn `addIdSpecialisations` rules, mkLams args body)]
1031 rules = [r | OS _ r _ _ <- specs]
1033 ----------------------
1034 varUsage :: ScEnv -> OutVar -> ArgOcc -> ScUsage
1036 | Just RecArg <- lookupHowBound env v = SCU { scu_calls = emptyVarEnv
1037 , scu_occs = unitVarEnv v use }
1038 | otherwise = nullUsage
1042 %************************************************************************
1044 The specialiser itself
1046 %************************************************************************
1049 type RhsInfo = (OutId, [OutVar], OutExpr, [ArgOcc])
1050 -- Info about the *original* RHS of a binding we are specialising
1051 -- Original binding f = \xs.body
1052 -- Plus info about usage of arguments
1054 data SpecInfo = SI [OneSpec] -- The specialisations we have generated
1055 Int -- Length of specs; used for numbering them
1056 (Maybe ScUsage) -- Nothing => we have generated specialisations
1057 -- from calls in the *original* RHS
1058 -- Just cs => we haven't, and this is the usage
1059 -- of the original RHS
1061 -- One specialisation: Rule plus definition
1062 data OneSpec = OS CallPat -- Call pattern that generated this specialisation
1063 CoreRule -- Rule connecting original id with the specialisation
1064 OutId OutExpr -- Spec id + its rhs
1068 -> Bool -- force specialisation?
1071 -> ScUsage -> [SpecInfo] -- One per binder; acccumulating parameter
1072 -> UniqSM (ScUsage, [SpecInfo]) -- ...ditto...
1073 specLoop env force_spec all_calls rhs_infos usg_so_far specs_so_far
1074 = do { specs_w_usg <- zipWithM (specialise env force_spec all_calls) rhs_infos specs_so_far
1075 ; let (new_usg_s, all_specs) = unzip specs_w_usg
1076 new_usg = combineUsages new_usg_s
1077 new_calls = scu_calls new_usg
1078 all_usg = usg_so_far `combineUsage` new_usg
1079 ; if isEmptyVarEnv new_calls then
1080 return (all_usg, all_specs)
1082 specLoop env force_spec new_calls rhs_infos all_usg all_specs }
1086 -> Bool -- force specialisation?
1087 -> CallEnv -- Info on calls
1089 -> SpecInfo -- Original RHS plus patterns dealt with
1090 -> UniqSM (ScUsage, SpecInfo) -- New specialised versions and their usage
1092 -- Note: the rhs here is the optimised version of the original rhs
1093 -- So when we make a specialised copy of the RHS, we're starting
1094 -- from an RHS whose nested functions have been optimised already.
1096 specialise env force_spec bind_calls (fn, arg_bndrs, body, arg_occs)
1097 spec_info@(SI specs spec_count mb_unspec)
1098 | not (isBottomingId fn) -- Note [Do not specialise diverging functions]
1099 , notNull arg_bndrs -- Only specialise functions
1100 , Just all_calls <- lookupVarEnv bind_calls fn
1101 = do { (boring_call, pats) <- callsToPats env specs arg_occs all_calls
1102 -- ; pprTrace "specialise" (vcat [ ppr fn <+> text "with" <+> int (length pats) <+> text "good patterns"
1103 -- , text "arg_occs" <+> ppr arg_occs,
1104 -- , text "calls" <+> ppr all_calls,
1105 -- , text "good pats" <+> ppr pats]) $
1108 -- Bale out if too many specialisations
1109 -- Rather a hacky way to do so, but it'll do for now
1110 ; let n_pats = length pats
1111 spec_count' = length pats + spec_count
1112 ; case sc_count env of
1113 Just max | not force_spec && spec_count' > max
1114 -> pprTrace "SpecConstr" msg $
1115 return (nullUsage, spec_info)
1117 msg = vcat [ sep [ ptext (sLit "Function") <+> quotes (ppr fn)
1118 , nest 2 (ptext (sLit "has") <+> int n_pats <+>
1119 ptext (sLit "call pattterns, but the limit is") <+> int max) ]
1120 , ptext (sLit "Use -fspec-constr-count=n to set the bound")
1122 extra | not opt_PprStyle_Debug = ptext (sLit "Use -dppr-debug to see specialisations")
1123 | otherwise = ptext (sLit "Specialisations:") <+> ppr (pats ++ [p | OS p _ _ _ <- specs])
1125 _normal_case -> do {
1127 (spec_usgs, new_specs) <- mapAndUnzipM (spec_one env fn arg_bndrs body)
1128 (pats `zip` [spec_count..])
1130 ; let spec_usg = combineUsages spec_usgs
1131 (new_usg, mb_unspec')
1133 Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing)
1134 _ -> (spec_usg, mb_unspec)
1136 ; return (new_usg, SI (new_specs ++ specs) spec_count' mb_unspec') } }
1138 = return (nullUsage, spec_info) -- The boring case
1141 ---------------------
1143 -> OutId -- Function
1144 -> [Var] -- Lambda-binders of RHS; should match patterns
1145 -> CoreExpr -- Body of the original function
1147 -> UniqSM (ScUsage, OneSpec) -- Rule and binding
1149 -- spec_one creates a specialised copy of the function, together
1150 -- with a rule for using it. I'm very proud of how short this
1151 -- function is, considering what it does :-).
1157 f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
1158 [c::*, v::(b,c) are presumably bound by the (...) part]
1160 f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
1161 (...entire body of f...) [b -> (b,c),
1162 y -> ((:) (a,(b,c)) (x,v) hw)]
1164 RULE: forall b::* c::*, -- Note, *not* forall a, x
1168 f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
1171 spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)
1172 = do { -- Specialise the body
1173 let spec_env = extendScSubstList (extendScInScope env qvars)
1174 (arg_bndrs `zip` pats)
1175 ; (spec_usg, spec_body) <- scExpr spec_env body
1177 -- ; pprTrace "spec_one" (ppr fn <+> vcat [text "pats" <+> ppr pats,
1178 -- text "calls" <+> (ppr (scu_calls spec_usg))])
1181 -- And build the results
1182 ; spec_uniq <- getUniqueUs
1183 ; let (spec_lam_args, spec_call_args) = mkWorkerArgs qvars body_ty
1184 -- Usual w/w hack to avoid generating
1185 -- a spec_rhs of unlifted type and no args
1188 fn_loc = nameSrcSpan fn_name
1189 spec_occ = mkSpecOcc (nameOccName fn_name)
1190 rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number))
1191 spec_rhs = mkLams spec_lam_args spec_body
1192 spec_str = calcSpecStrictness fn spec_lam_args pats
1193 spec_id = mkUserLocal spec_occ spec_uniq (mkPiTypes spec_lam_args body_ty) fn_loc
1194 `setIdStrictness` spec_str -- See Note [Transfer strictness]
1195 `setIdArity` count isId spec_lam_args
1196 body_ty = exprType spec_body
1197 rule_rhs = mkVarApps (Var spec_id) spec_call_args
1198 inline_act = idInlineActivation fn
1199 rule = mkLocalRule rule_name inline_act fn_name qvars pats rule_rhs
1200 ; return (spec_usg, OS call_pat rule spec_id spec_rhs) }
1202 calcSpecStrictness :: Id -- The original function
1203 -> [Var] -> [CoreExpr] -- Call pattern
1204 -> StrictSig -- Strictness of specialised thing
1205 -- See Note [Transfer strictness]
1206 calcSpecStrictness fn qvars pats
1207 = StrictSig (mkTopDmdType spec_dmds TopRes)
1209 spec_dmds = [ lookupVarEnv dmd_env qv `orElse` lazyDmd | qv <- qvars, isId qv ]
1210 StrictSig (DmdType _ dmds _) = idStrictness fn
1212 dmd_env = go emptyVarEnv dmds pats
1214 go env ds (Type {} : pats) = go env ds pats
1215 go env (d:ds) (pat : pats) = go (go_one env d pat) ds pats
1218 go_one env d (Var v) = extendVarEnv_C both env v d
1219 go_one env (Box d) e = go_one env d e
1220 go_one env (Eval (Prod ds)) e
1221 | (Var _, args) <- collectArgs e = go env ds args
1222 go_one env _ _ = env
1226 Note [Transfer activation]
1227 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1228 In which phase should the specialise-constructor rules be active?
1229 Originally I made them always-active, but Manuel found that this
1230 defeated some clever user-written rules. Then I made them active only
1231 in Phase 0; after all, currently, the specConstr transformation is
1232 only run after the simplifier has reached Phase 0, but that meant
1233 that specialisations didn't fire inside wrappers; see test
1234 simplCore/should_compile/spec-inline.
1236 So now I just use the inline-activation of the parent Id, as the
1237 activation for the specialiation RULE, just like the main specialiser;
1238 see Note [Auto-specialisation and RULES] in Specialise.
1241 Note [Transfer strictness]
1242 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1243 We must transfer strictness information from the original function to
1244 the specialised one. Suppose, for example
1247 and a RULE f (a:as) b = f_spec a as b
1249 Now we want f_spec to have strictess LLS, otherwise we'll use call-by-need
1250 when calling f_spec instead of call-by-value. And that can result in
1251 unbounded worsening in space (cf the classic foldl vs foldl')
1253 See Trac #3437 for a good example.
1255 The function calcSpecStrictness performs the calculation.
1258 %************************************************************************
1260 \subsection{Argument analysis}
1262 %************************************************************************
1264 This code deals with analysing call-site arguments to see whether
1265 they are constructor applications.
1269 type CallPat = ([Var], [CoreExpr]) -- Quantified variables and arguments
1272 callsToPats :: ScEnv -> [OneSpec] -> [ArgOcc] -> [Call] -> UniqSM (Bool, [CallPat])
1273 -- Result has no duplicate patterns,
1274 -- nor ones mentioned in done_pats
1275 -- Bool indicates that there was at least one boring pattern
1276 callsToPats env done_specs bndr_occs calls
1277 = do { mb_pats <- mapM (callToPats env bndr_occs) calls
1279 ; let good_pats :: [([Var], [CoreArg])]
1280 good_pats = catMaybes mb_pats
1281 done_pats = [p | OS p _ _ _ <- done_specs]
1282 is_done p = any (samePat p) done_pats
1284 ; return (any isNothing mb_pats,
1285 filterOut is_done (nubBy samePat good_pats)) }
1287 callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
1288 -- The [Var] is the variables to quantify over in the rule
1289 -- Type variables come first, since they may scope
1290 -- over the following term variables
1291 -- The [CoreExpr] are the argument patterns for the rule
1292 callToPats env bndr_occs (con_env, args)
1293 | length args < length bndr_occs -- Check saturated
1296 = do { let in_scope = substInScope (sc_subst env)
1297 ; prs <- argsToPats env in_scope con_env (args `zip` bndr_occs)
1298 ; let (interesting_s, pats) = unzip prs
1299 pat_fvs = varSetElems (exprsFreeVars pats)
1300 qvars = filterOut (`elemInScopeSet` in_scope) pat_fvs
1301 -- Quantify over variables that are not in sccpe
1303 -- See Note [Shadowing] at the top
1305 (tvs, ids) = partition isTyVar qvars
1307 -- Put the type variables first; the type of a term
1308 -- variable may mention a type variable
1310 ; -- pprTrace "callToPats" (ppr args $$ ppr prs $$ ppr bndr_occs) $
1312 then return (Just (qvars', pats))
1313 else return Nothing }
1315 -- argToPat takes an actual argument, and returns an abstracted
1316 -- version, consisting of just the "constructor skeleton" of the
1317 -- argument, with non-constructor sub-expression replaced by new
1318 -- placeholder variables. For example:
1319 -- C a (D (f x) (g y)) ==> C p1 (D p2 p3)
1322 -> InScopeSet -- What's in scope at the fn defn site
1323 -> ValueEnv -- ValueEnv at the call site
1324 -> CoreArg -- A call arg (or component thereof)
1326 -> UniqSM (Bool, CoreArg)
1327 -- Returns (interesting, pat),
1328 -- where pat is the pattern derived from the argument
1329 -- intersting=True if the pattern is non-trivial (not a variable or type)
1330 -- E.g. x:xs --> (True, x:xs)
1331 -- f xs --> (False, w) where w is a fresh wildcard
1332 -- (f xs, 'c') --> (True, (w, 'c')) where w is a fresh wildcard
1333 -- \x. x+y --> (True, \x. x+y)
1334 -- lvl7 --> (True, lvl7) if lvl7 is bound
1335 -- somewhere further out
1337 argToPat _env _in_scope _val_env arg@(Type {}) _arg_occ
1338 = return (False, arg)
1340 argToPat env in_scope val_env (Note _ arg) arg_occ
1341 = argToPat env in_scope val_env arg arg_occ
1342 -- Note [Notes in call patterns]
1343 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1344 -- Ignore Notes. In particular, we want to ignore any InlineMe notes
1345 -- Perhaps we should not ignore profiling notes, but I'm going to
1346 -- ride roughshod over them all for now.
1347 --- See Note [Notes in RULE matching] in Rules
1349 argToPat env in_scope val_env (Let _ arg) arg_occ
1350 = argToPat env in_scope val_env arg arg_occ
1351 -- Look through let expressions
1352 -- e.g. f (let v = rhs in \y -> ...v...)
1353 -- Here we can specialise for f (\y -> ...)
1354 -- because the rule-matcher will look through the let.
1356 argToPat env in_scope val_env (Cast arg co) arg_occ
1357 | not (ignoreType env ty2)
1358 = do { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ
1359 ; if not interesting then
1362 { -- Make a wild-card pattern for the coercion
1364 ; let co_name = mkSysTvName uniq (fsLit "sg")
1365 co_var = mkCoVar co_name (mkCoKind ty1 ty2)
1366 ; return (interesting, Cast arg' (mkTyVarTy co_var)) } }
1368 (ty1, ty2) = coercionKind co
1372 {- Disabling lambda specialisation for now
1373 It's fragile, and the spec_loop can be infinite
1374 argToPat in_scope val_env arg arg_occ
1376 = return (True, arg)
1378 is_value_lam (Lam v e) -- Spot a value lambda, even if
1379 | isId v = True -- it is inside a type lambda
1380 | otherwise = is_value_lam e
1381 is_value_lam other = False
1384 -- Check for a constructor application
1385 -- NB: this *precedes* the Var case, so that we catch nullary constrs
1386 argToPat env in_scope val_env arg arg_occ
1387 | Just (ConVal dc args) <- isValue val_env arg
1388 , not (ignoreAltCon env dc)
1390 ScrutOcc _ -> True -- Used only by case scrutinee
1391 BothOcc -> case arg of -- Used elsewhere
1392 App {} -> True -- see Note [Reboxing]
1394 _other -> False -- No point; the arg is not decomposed
1395 = do { args' <- argsToPats env in_scope val_env (args `zip` conArgOccs arg_occ dc)
1396 ; return (True, mk_con_app dc (map snd args')) }
1398 -- Check if the argument is a variable that
1399 -- is in scope at the function definition site
1400 -- It's worth specialising on this if
1401 -- (a) it's used in an interesting way in the body
1402 -- (b) we know what its value is
1403 argToPat env in_scope val_env (Var v) arg_occ
1404 | case arg_occ of { UnkOcc -> False; _other -> True }, -- (a)
1406 not (ignoreType env (varType v))
1407 = return (True, Var v)
1410 | isLocalId v = v `elemInScopeSet` in_scope
1411 && isJust (lookupVarEnv val_env v)
1412 -- Local variables have values in val_env
1413 | otherwise = isValueUnfolding (idUnfolding v)
1414 -- Imports have unfoldings
1416 -- I'm really not sure what this comment means
1417 -- And by not wild-carding we tend to get forall'd
1418 -- variables that are in soope, which in turn can
1419 -- expose the weakness in let-matching
1420 -- See Note [Matching lets] in Rules
1422 -- Check for a variable bound inside the function.
1423 -- Don't make a wild-card, because we may usefully share
1424 -- e.g. f a = let x = ... in f (x,x)
1425 -- NB: this case follows the lambda and con-app cases!!
1426 -- argToPat _in_scope _val_env (Var v) _arg_occ
1427 -- = return (False, Var v)
1428 -- SLPJ : disabling this to avoid proliferation of versions
1429 -- also works badly when thinking about seeding the loop
1430 -- from the body of the let
1431 -- f x y = letrec g z = ... in g (x,y)
1432 -- We don't want to specialise for that *particular* x,y
1434 -- The default case: make a wild-card
1435 argToPat _env _in_scope _val_env arg _arg_occ
1436 = wildCardPat (exprType arg)
1438 wildCardPat :: Type -> UniqSM (Bool, CoreArg)
1439 wildCardPat ty = do { uniq <- getUniqueUs
1440 ; let id = mkSysLocal (fsLit "sc") uniq ty
1441 ; return (False, Var id) }
1443 argsToPats :: ScEnv -> InScopeSet -> ValueEnv
1444 -> [(CoreArg, ArgOcc)]
1445 -> UniqSM [(Bool, CoreArg)]
1446 argsToPats env in_scope val_env args
1449 do_one (arg,occ) = argToPat env in_scope val_env arg occ
1454 isValue :: ValueEnv -> CoreExpr -> Maybe Value
1455 isValue _env (Lit lit)
1456 = Just (ConVal (LitAlt lit) [])
1459 | Just stuff <- lookupVarEnv env v
1460 = Just stuff -- You might think we could look in the idUnfolding here
1461 -- but that doesn't take account of which branch of a
1462 -- case we are in, which is the whole point
1464 | not (isLocalId v) && isCheapUnfolding unf
1465 = isValue env (unfoldingTemplate unf)
1468 -- However we do want to consult the unfolding
1469 -- as well, for let-bound constructors!
1471 isValue env (Lam b e)
1472 | isTyVar b = case isValue env e of
1473 Just _ -> Just LambdaVal
1475 | otherwise = Just LambdaVal
1477 isValue _env expr -- Maybe it's a constructor application
1478 | (Var fun, args) <- collectArgs expr
1479 = case isDataConWorkId_maybe fun of
1481 Just con | args `lengthAtLeast` dataConRepArity con
1482 -- Check saturated; might be > because the
1483 -- arity excludes type args
1484 -> Just (ConVal (DataAlt con) args)
1486 _other | valArgCount args < idArity fun
1487 -- Under-applied function
1488 -> Just LambdaVal -- Partial application
1492 isValue _env _expr = Nothing
1494 mk_con_app :: AltCon -> [CoreArg] -> CoreExpr
1495 mk_con_app (LitAlt lit) [] = Lit lit
1496 mk_con_app (DataAlt con) args = mkConApp con args
1497 mk_con_app _other _args = panic "SpecConstr.mk_con_app"
1499 samePat :: CallPat -> CallPat -> Bool
1500 samePat (vs1, as1) (vs2, as2)
1503 same (Var v1) (Var v2)
1504 | v1 `elem` vs1 = v2 `elem` vs2
1505 | v2 `elem` vs2 = False
1506 | otherwise = v1 == v2
1508 same (Lit l1) (Lit l2) = l1==l2
1509 same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2
1511 same (Type {}) (Type {}) = True -- Note [Ignore type differences]
1512 same (Note _ e1) e2 = same e1 e2 -- Ignore casts and notes
1513 same (Cast e1 _) e2 = same e1 e2
1514 same e1 (Note _ e2) = same e1 e2
1515 same e1 (Cast e2 _) = same e1 e2
1517 same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2)
1518 False -- Let, lambda, case should not occur
1519 bad (Case {}) = True
1525 Note [Ignore type differences]
1526 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1527 We do not want to generate specialisations where the call patterns
1528 differ only in their type arguments! Not only is it utterly useless,
1529 but it also means that (with polymorphic recursion) we can generate
1530 an infinite number of specialisations. Example is Data.Sequence.adjustTree,