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 StaticFlags ( opt_SpecInlineJoinPoints )
42 import BasicTypes ( Activation(..) )
43 import Maybes ( orElse, catMaybes, isJust, isNothing )
45 import DmdAnal ( both )
46 import Serialized ( deserializeWithData )
52 import qualified LazyUniqFM as L
54 import Control.Monad ( zipWithM )
56 #if __GLASGOW_HASKELL__ > 609
57 import Data.Data ( Data, Typeable )
59 import Data.Generics ( Data, Typeable )
63 -----------------------------------------------------
65 -----------------------------------------------------
70 drop n (x:xs) = drop (n-1) xs
72 After the first time round, we could pass n unboxed. This happens in
73 numerical code too. Here's what it looks like in Core:
75 drop n xs = case xs of
80 _ -> drop (I# (n# -# 1#)) xs
82 Notice that the recursive call has an explicit constructor as argument.
83 Noticing this, we can make a specialised version of drop
85 RULE: drop (I# n#) xs ==> drop' n# xs
87 drop' n# xs = let n = I# n# in ...orig RHS...
89 Now the simplifier will apply the specialisation in the rhs of drop', giving
91 drop' n# xs = case xs of
95 _ -> drop (n# -# 1#) xs
99 We'd also like to catch cases where a parameter is carried along unchanged,
100 but evaluated each time round the loop:
102 f i n = if i>0 || i>n then i else f (i*2) n
104 Here f isn't strict in n, but we'd like to avoid evaluating it each iteration.
105 In Core, by the time we've w/wd (f is strict in i) we get
107 f i# n = case i# ># 0 of
109 True -> case n of n' { I# n# ->
112 True -> f (i# *# 2#) n'
114 At the call to f, we see that the argument, n is know to be (I# n#),
115 and n is evaluated elsewhere in the body of f, so we can play the same
121 We must be careful not to allocate the same constructor twice. Consider
122 f p = (...(case p of (a,b) -> e)...p...,
123 ...let t = (r,s) in ...t...(f t)...)
124 At the recursive call to f, we can see that t is a pair. But we do NOT want
125 to make a specialised copy:
126 f' a b = let p = (a,b) in (..., ...)
127 because now t is allocated by the caller, then r and s are passed to the
128 recursive call, which allocates the (r,s) pair again.
131 (a) the argument p is used in other than a case-scrutinsation way.
132 (b) the argument to the call is not a 'fresh' tuple; you have to
133 look into its unfolding to see that it's a tuple
135 Hence the "OR" part of Note [Good arguments] below.
137 ALTERNATIVE 2: pass both boxed and unboxed versions. This no longer saves
138 allocation, but does perhaps save evals. In the RULE we'd have
141 f (I# x#) = f' (I# x#) x#
143 If at the call site the (I# x) was an unfolding, then we'd have to
144 rely on CSE to eliminate the duplicate allocation.... This alternative
145 doesn't look attractive enough to pursue.
147 ALTERNATIVE 3: ignore the reboxing problem. The trouble is that
148 the conservative reboxing story prevents many useful functions from being
149 specialised. Example:
150 foo :: Maybe Int -> Int -> Int
152 foo x@(Just m) n = foo x (n-m)
153 Here the use of 'x' will clearly not require boxing in the specialised function.
155 The strictness analyser has the same problem, in fact. Example:
157 If we pass just 'a' and 'b' to the worker, it might need to rebox the
158 pair to create (a,b). A more sophisticated analysis might figure out
159 precisely the cases in which this could happen, but the strictness
160 analyser does no such analysis; it just passes 'a' and 'b', and hopes
163 So my current choice is to make SpecConstr similarly aggressive, and
164 ignore the bad potential of reboxing.
167 Note [Good arguments]
168 ~~~~~~~~~~~~~~~~~~~~~
171 * A self-recursive function. Ignore mutual recursion for now,
172 because it's less common, and the code is simpler for self-recursion.
176 a) At a recursive call, one or more parameters is an explicit
177 constructor application
179 That same parameter is scrutinised by a case somewhere in
180 the RHS of the function
184 b) At a recursive call, one or more parameters has an unfolding
185 that is an explicit constructor application
187 That same parameter is scrutinised by a case somewhere in
188 the RHS of the function
190 Those are the only uses of the parameter (see Note [Reboxing])
193 What to abstract over
194 ~~~~~~~~~~~~~~~~~~~~~
195 There's a bit of a complication with type arguments. If the call
198 f p = ...f ((:) [a] x xs)...
200 then our specialised function look like
202 f_spec x xs = let p = (:) [a] x xs in ....as before....
204 This only makes sense if either
205 a) the type variable 'a' is in scope at the top of f, or
206 b) the type variable 'a' is an argument to f (and hence fs)
208 Actually, (a) may hold for value arguments too, in which case
209 we may not want to pass them. Supose 'x' is in scope at f's
210 defn, but xs is not. Then we'd like
212 f_spec xs = let p = (:) [a] x xs in ....as before....
214 Similarly (b) may hold too. If x is already an argument at the
215 call, no need to pass it again.
217 Finally, if 'a' is not in scope at the call site, we could abstract
218 it as we do the term variables:
220 f_spec a x xs = let p = (:) [a] x xs in ...as before...
222 So the grand plan is:
224 * abstract the call site to a constructor-only pattern
225 e.g. C x (D (f p) (g q)) ==> C s1 (D s2 s3)
227 * Find the free variables of the abstracted pattern
229 * Pass these variables, less any that are in scope at
230 the fn defn. But see Note [Shadowing] below.
233 NOTICE that we only abstract over variables that are not in scope,
234 so we're in no danger of shadowing variables used in "higher up"
240 In this pass we gather up usage information that may mention variables
241 that are bound between the usage site and the definition site; or (more
242 seriously) may be bound to something different at the definition site.
245 f x = letrec g y v = let x = ...
248 Since 'x' is in scope at the call site, we may make a rewrite rule that
250 RULE forall a,b. g (a,b) x = ...
251 But this rule will never match, because it's really a different 'x' at
252 the call site -- and that difference will be manifest by the time the
253 simplifier gets to it. [A worry: the simplifier doesn't *guarantee*
254 no-shadowing, so perhaps it may not be distinct?]
256 Anyway, the rule isn't actually wrong, it's just not useful. One possibility
257 is to run deShadowBinds before running SpecConstr, but instead we run the
258 simplifier. That gives the simplest possible program for SpecConstr to
259 chew on; and it virtually guarantees no shadowing.
261 Note [Specialising for constant parameters]
262 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
263 This one is about specialising on a *constant* (but not necessarily
264 constructor) argument
266 foo :: Int -> (Int -> Int) -> Int
268 foo m f = foo (f m) (+1)
272 lvl_rmV :: GHC.Base.Int -> GHC.Base.Int
274 \ (ds_dlk :: GHC.Base.Int) ->
275 case ds_dlk of wild_alH { GHC.Base.I# x_alG ->
276 GHC.Base.I# (GHC.Prim.+# x_alG 1)
278 T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
281 \ (ww_sme :: GHC.Prim.Int#) (w_smg :: GHC.Base.Int -> GHC.Base.Int) ->
282 case ww_sme of ds_Xlw {
284 case w_smg (GHC.Base.I# ds_Xlw) of w1_Xmo { GHC.Base.I# ww1_Xmz ->
285 T.$wfoo ww1_Xmz lvl_rmV
290 The recursive call has lvl_rmV as its argument, so we could create a specialised copy
291 with that argument baked in; that is, not passed at all. Now it can perhaps be inlined.
293 When is this worth it? Call the constant 'lvl'
294 - If 'lvl' has an unfolding that is a constructor, see if the corresponding
295 parameter is scrutinised anywhere in the body.
297 - If 'lvl' has an unfolding that is a inlinable function, see if the corresponding
298 parameter is applied (...to enough arguments...?)
300 Also do this is if the function has RULES?
304 Note [Specialising for lambda parameters]
305 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
306 foo :: Int -> (Int -> Int) -> Int
308 foo m f = foo (f m) (\n -> n-m)
310 This is subtly different from the previous one in that we get an
311 explicit lambda as the argument:
313 T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
316 \ (ww_sm8 :: GHC.Prim.Int#) (w_sma :: GHC.Base.Int -> GHC.Base.Int) ->
317 case ww_sm8 of ds_Xlr {
319 case w_sma (GHC.Base.I# ds_Xlr) of w1_Xmf { GHC.Base.I# ww1_Xmq ->
322 (\ (n_ad3 :: GHC.Base.Int) ->
323 case n_ad3 of wild_alB { GHC.Base.I# x_alA ->
324 GHC.Base.I# (GHC.Prim.-# x_alA ds_Xlr)
330 I wonder if SpecConstr couldn't be extended to handle this? After all,
331 lambda is a sort of constructor for functions and perhaps it already
332 has most of the necessary machinery?
334 Furthermore, there's an immediate win, because you don't need to allocate the lamda
335 at the call site; and if perchance it's called in the recursive call, then you
336 may avoid allocating it altogether. Just like for constructors.
338 Looks cool, but probably rare...but it might be easy to implement.
341 Note [SpecConstr for casts]
342 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
345 data instance T Int = T Int
350 go (T n) = go (T (n-1))
352 The recursive call ends up looking like
353 go (T (I# ...) `cast` g)
354 So we want to spot the construtor application inside the cast.
355 That's why we have the Cast case in argToPat
357 Note [Local recursive groups]
358 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
359 For a *local* recursive group, we can see all the calls to the
360 function, so we seed the specialisation loop from the calls in the
361 body, not from the calls in the RHS. Consider:
363 bar m n = foo n (n,n) (n,n) (n,n) (n,n)
367 | n > 3000 = case p of { (p1,p2) -> foo (n-1) (p2,p1) q r s }
368 | n > 2000 = case q of { (q1,q2) -> foo (n-1) p (q2,q1) r s }
369 | n > 1000 = case r of { (r1,r2) -> foo (n-1) p q (r2,r1) s }
370 | otherwise = case s of { (s1,s2) -> foo (n-1) p q r (s2,s1) }
372 If we start with the RHSs of 'foo', we get lots and lots of specialisations,
373 most of which are not needed. But if we start with the (single) call
374 in the rhs of 'bar' we get exactly one fully-specialised copy, and all
375 the recursive calls go to this fully-specialised copy. Indeed, the original
376 function is later collected as dead code. This is very important in
377 specialising the loops arising from stream fusion, for example in NDP where
378 we were getting literally hundreds of (mostly unused) specialisations of
381 Note [Do not specialise diverging functions]
382 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
383 Specialising a function that just diverges is a waste of code.
384 Furthermore, it broke GHC (simpl014) thus:
386 f = \x. case x of (a,b) -> f x
387 If we specialise f we get
388 f = \x. case x of (a,b) -> fspec a b
389 But fspec doesn't have decent strictnes info. As it happened,
390 (f x) :: IO t, so the state hack applied and we eta expanded fspec,
391 and hence f. But now f's strictness is less than its arity, which
394 -----------------------------------------------------
395 Stuff not yet handled
396 -----------------------------------------------------
398 Here are notes arising from Roman's work that I don't want to lose.
404 foo :: Int -> T Int -> Int
406 foo x t | even x = case t of { T n -> foo (x-n) t }
407 | otherwise = foo (x-1) t
409 SpecConstr does no specialisation, because the second recursive call
410 looks like a boxed use of the argument. A pity.
412 $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
414 \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) ->
415 case ww_sFo of ds_Xw6 [Just L] {
417 case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] {
418 __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq;
420 case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] ->
421 case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] ->
422 $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy
428 data a :*: b = !a :*: !b
431 foo :: (Int :*: T Int) -> Int
433 foo (x :*: t) | even x = case t of { T n -> foo ((x-n) :*: t) }
434 | otherwise = foo ((x-1) :*: t)
436 Very similar to the previous one, except that the parameters are now in
437 a strict tuple. Before SpecConstr, we have
439 $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
441 \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T
443 case ww_sFU of ds_Xws [Just L] {
445 case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] {
447 case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] ->
448 $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2 -- $wfoo1
451 case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] ->
452 case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] ->
453 $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB -- $wfoo2
457 We get two specialisations:
458 "SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#}
459 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB)
460 = Foo.$s$wfoo1 a_sFB sc_sGC ;
461 "SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#}
462 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp))
463 = Foo.$s$wfoo y_aFp sc_sGC ;
465 But perhaps the first one isn't good. After all, we know that tpl_B2 is
466 a T (I# x) really, because T is strict and Int has one constructor. (We can't
467 unbox the strict fields, becuase T is polymorphic!)
469 %************************************************************************
471 \subsection{Annotations}
473 %************************************************************************
475 Annotating a type with NoSpecConstr will make SpecConstr not specialise
476 for arguments of that type.
479 data SpecConstrAnnotation = NoSpecConstr | ForceSpecConstr
480 deriving( Data, Typeable, Eq )
483 %************************************************************************
485 \subsection{Top level wrapper stuff}
487 %************************************************************************
490 specConstrProgram :: ModGuts -> CoreM ModGuts
491 specConstrProgram guts
493 dflags <- getDynFlags
494 us <- getUniqueSupplyM
495 annos <- getFirstAnnotations deserializeWithData guts
496 let binds' = fst $ initUs us (go (initScEnv dflags annos) (mg_binds guts))
497 return (guts { mg_binds = binds' })
500 go env (bind:binds) = do (env', bind') <- scTopBind env bind
501 binds' <- go env' binds
502 return (bind' : binds')
506 %************************************************************************
508 \subsection{Environment: goes downwards}
510 %************************************************************************
513 data ScEnv = SCE { sc_size :: Maybe Int, -- Size threshold
514 sc_count :: Maybe Int, -- Max # of specialisations for any one fn
516 sc_subst :: Subst, -- Current substitution
517 -- Maps InIds to OutExprs
519 sc_how_bound :: HowBoundEnv,
520 -- Binds interesting non-top-level variables
521 -- Domain is OutVars (*after* applying the substitution)
524 -- Domain is OutIds (*after* applying the substitution)
525 -- Used even for top-level bindings (but not imported ones)
527 sc_annotations :: L.UniqFM SpecConstrAnnotation
530 ---------------------
531 -- As we go, we apply a substitution (sc_subst) to the current term
532 type InExpr = CoreExpr -- _Before_ applying the subst
534 type OutExpr = CoreExpr -- _After_ applying the subst
538 ---------------------
539 type HowBoundEnv = VarEnv HowBound -- Domain is OutVars
541 ---------------------
542 type ValueEnv = IdEnv Value -- Domain is OutIds
543 data Value = ConVal AltCon [CoreArg] -- _Saturated_ constructors
544 | LambdaVal -- Inlinable lambdas or PAPs
546 instance Outputable Value where
547 ppr (ConVal con args) = ppr con <+> interpp'SP args
548 ppr LambdaVal = ptext (sLit "<Lambda>")
550 ---------------------
551 initScEnv :: DynFlags -> L.UniqFM SpecConstrAnnotation -> ScEnv
552 initScEnv dflags anns
553 = SCE { sc_size = specConstrThreshold dflags,
554 sc_count = specConstrCount dflags,
555 sc_subst = emptySubst,
556 sc_how_bound = emptyVarEnv,
557 sc_vals = emptyVarEnv,
558 sc_annotations = anns }
560 data HowBound = RecFun -- These are the recursive functions for which
561 -- we seek interesting call patterns
563 | RecArg -- These are those functions' arguments, or their sub-components;
564 -- we gather occurrence information for these
566 instance Outputable HowBound where
567 ppr RecFun = text "RecFun"
568 ppr RecArg = text "RecArg"
570 lookupHowBound :: ScEnv -> Id -> Maybe HowBound
571 lookupHowBound env id = lookupVarEnv (sc_how_bound env) id
573 scSubstId :: ScEnv -> Id -> CoreExpr
574 scSubstId env v = lookupIdSubst (sc_subst env) v
576 scSubstTy :: ScEnv -> Type -> Type
577 scSubstTy env ty = substTy (sc_subst env) ty
579 zapScSubst :: ScEnv -> ScEnv
580 zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) }
582 extendScInScope :: ScEnv -> [Var] -> ScEnv
583 -- Bring the quantified variables into scope
584 extendScInScope env qvars = env { sc_subst = extendInScopeList (sc_subst env) qvars }
586 -- Extend the substitution
587 extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv
588 extendScSubst env var expr = env { sc_subst = extendSubst (sc_subst env) var expr }
590 extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv
591 extendScSubstList env prs = env { sc_subst = extendSubstList (sc_subst env) prs }
593 extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv
594 extendHowBound env bndrs how_bound
595 = env { sc_how_bound = extendVarEnvList (sc_how_bound env)
596 [(bndr,how_bound) | bndr <- bndrs] }
598 extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var])
599 extendBndrsWith how_bound env bndrs
600 = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndrs')
602 (subst', bndrs') = substBndrs (sc_subst env) bndrs
603 hb_env' = sc_how_bound env `extendVarEnvList`
604 [(bndr,how_bound) | bndr <- bndrs']
606 extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var)
607 extendBndrWith how_bound env bndr
608 = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndr')
610 (subst', bndr') = substBndr (sc_subst env) bndr
611 hb_env' = extendVarEnv (sc_how_bound env) bndr' how_bound
613 extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var])
614 extendRecBndrs env bndrs = (env { sc_subst = subst' }, bndrs')
616 (subst', bndrs') = substRecBndrs (sc_subst env) bndrs
618 extendBndr :: ScEnv -> Var -> (ScEnv, Var)
619 extendBndr env bndr = (env { sc_subst = subst' }, bndr')
621 (subst', bndr') = substBndr (sc_subst env) bndr
623 extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv
624 extendValEnv env _ Nothing = env
625 extendValEnv env id (Just cv) = env { sc_vals = extendVarEnv (sc_vals env) id cv }
627 extendCaseBndrs :: ScEnv -> Id -> AltCon -> [Var] -> (ScEnv, [Var])
631 -- we want to bind b, to (C x y)
632 -- NB1: Extends only the sc_vals part of the envt
633 -- NB2: Kill the dead-ness info on the pattern binders x,y, since
634 -- they are potentially made alive by the [b -> C x y] binding
635 extendCaseBndrs env case_bndr con alt_bndrs
636 | isDeadBinder case_bndr
639 = (env1, map zap alt_bndrs)
640 -- NB: We used to bind v too, if scrut = (Var v); but
641 -- the simplifer has already done this so it seems
642 -- redundant to do so here
644 -- Var v -> extendValEnv env1 v cval
647 zap v | isTyVar v = v -- See NB2 above
648 | otherwise = zapIdOccInfo v
649 env1 = extendValEnv env case_bndr cval
652 LitAlt {} -> Just (ConVal con [])
653 DataAlt {} -> Just (ConVal con vanilla_args)
655 vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
656 varsToCoreExprs alt_bndrs
658 ignoreTyCon :: ScEnv -> TyCon -> Bool
659 ignoreTyCon env tycon
660 = L.lookupUFM (sc_annotations env) tycon == Just NoSpecConstr
662 ignoreType :: ScEnv -> Type -> Bool
664 = case splitTyConApp_maybe ty of
665 Just (tycon, _) -> ignoreTyCon env tycon
668 ignoreAltCon :: ScEnv -> AltCon -> Bool
669 ignoreAltCon env (DataAlt dc) = ignoreTyCon env (dataConTyCon dc)
670 ignoreAltCon env (LitAlt lit) = ignoreType env (literalType lit)
671 ignoreAltCon _ DEFAULT = True
673 forceSpecBndr :: ScEnv -> Var -> Bool
674 forceSpecBndr env var = forceSpecFunTy env . varType $ var
676 forceSpecFunTy :: ScEnv -> Type -> Bool
677 forceSpecFunTy env = any (forceSpecArgTy env) . fst . splitFunTys
679 forceSpecArgTy :: ScEnv -> Type -> Bool
680 forceSpecArgTy env ty
681 | Just ty' <- coreView ty = forceSpecArgTy env ty'
683 forceSpecArgTy env ty
684 | Just (tycon, tys) <- splitTyConApp_maybe ty
686 = L.lookupUFM (sc_annotations env) tycon == Just ForceSpecConstr
687 || any (forceSpecArgTy env) tys
689 forceSpecArgTy _ _ = False
693 %************************************************************************
695 \subsection{Usage information: flows upwards}
697 %************************************************************************
702 scu_calls :: CallEnv, -- Calls
703 -- The functions are a subset of the
704 -- RecFuns in the ScEnv
706 scu_occs :: !(IdEnv ArgOcc) -- Information on argument occurrences
707 } -- The domain is OutIds
709 type CallEnv = IdEnv [Call]
710 type Call = (ValueEnv, [CoreArg])
711 -- The arguments of the call, together with the
712 -- env giving the constructor bindings at the call site
715 nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv }
717 combineCalls :: CallEnv -> CallEnv -> CallEnv
718 combineCalls = plusVarEnv_C (++)
720 combineUsage :: ScUsage -> ScUsage -> ScUsage
721 combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2),
722 scu_occs = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) }
724 combineUsages :: [ScUsage] -> ScUsage
725 combineUsages [] = nullUsage
726 combineUsages us = foldr1 combineUsage us
728 lookupOcc :: ScUsage -> OutVar -> (ScUsage, ArgOcc)
729 lookupOcc (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndr
730 = (SCU {scu_calls = sc_calls, scu_occs = delVarEnv sc_occs bndr},
731 lookupVarEnv sc_occs bndr `orElse` NoOcc)
733 lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc])
734 lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs
735 = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs},
736 [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs])
738 data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument
739 | UnkOcc -- Used in some unknown way
741 | ScrutOcc (UniqFM [ArgOcc]) -- See Note [ScrutOcc]
743 | BothOcc -- Definitely taken apart, *and* perhaps used in some other way
747 An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing,
748 is *only* taken apart or applied.
750 Functions, literal: ScrutOcc emptyUFM
751 Data constructors: ScrutOcc subs,
753 where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components,
754 The domain of the UniqFM is the Unique of the data constructor
756 The [ArgOcc] is the occurrences of the *pattern-bound* components
757 of the data structure. E.g.
758 data T a = forall b. MkT a b (b->a)
759 A pattern binds b, x::a, y::b, z::b->a, but not 'a'!
763 instance Outputable ArgOcc where
764 ppr (ScrutOcc xs) = ptext (sLit "scrut-occ") <> ppr xs
765 ppr UnkOcc = ptext (sLit "unk-occ")
766 ppr BothOcc = ptext (sLit "both-occ")
767 ppr NoOcc = ptext (sLit "no-occ")
769 -- Experimentally, this vesion of combineOcc makes ScrutOcc "win", so
770 -- that if the thing is scrutinised anywhere then we get to see that
771 -- in the overall result, even if it's also used in a boxed way
772 -- This might be too agressive; see Note [Reboxing] Alternative 3
773 combineOcc :: ArgOcc -> ArgOcc -> ArgOcc
774 combineOcc NoOcc occ = occ
775 combineOcc occ NoOcc = occ
776 combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys)
777 combineOcc _occ (ScrutOcc ys) = ScrutOcc ys
778 combineOcc (ScrutOcc xs) _occ = ScrutOcc xs
779 combineOcc UnkOcc UnkOcc = UnkOcc
780 combineOcc _ _ = BothOcc
782 combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]
783 combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys
785 setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage
786 -- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee
787 -- is a variable, and an interesting variable
788 setScrutOcc env usg (Cast e _) occ = setScrutOcc env usg e occ
789 setScrutOcc env usg (Note _ e) occ = setScrutOcc env usg e occ
790 setScrutOcc env usg (Var v) occ
791 | Just RecArg <- lookupHowBound env v = usg { scu_occs = extendVarEnv (scu_occs usg) v occ }
793 setScrutOcc _env usg _other _occ -- Catch-all
796 conArgOccs :: ArgOcc -> AltCon -> [ArgOcc]
797 -- Find usage of components of data con; returns [UnkOcc...] if unknown
798 -- See Note [ScrutOcc] for the extra UnkOccs in the vanilla datacon case
800 conArgOccs (ScrutOcc fm) (DataAlt dc)
801 | Just pat_arg_occs <- lookupUFM fm dc
802 = [UnkOcc | _ <- dataConUnivTyVars dc] ++ pat_arg_occs
804 conArgOccs _other _con = repeat UnkOcc
807 %************************************************************************
809 \subsection{The main recursive function}
811 %************************************************************************
813 The main recursive function gathers up usage information, and
814 creates specialised versions of functions.
817 scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
818 -- The unique supply is needed when we invent
819 -- a new name for the specialised function and its args
821 scExpr env e = scExpr' env e
824 scExpr' env (Var v) = case scSubstId env v of
825 Var v' -> return (varUsage env v' UnkOcc, Var v')
826 e' -> scExpr (zapScSubst env) e'
828 scExpr' env (Type t) = return (nullUsage, Type (scSubstTy env t))
829 scExpr' _ e@(Lit {}) = return (nullUsage, e)
830 scExpr' env (Note n e) = do (usg,e') <- scExpr env e
831 return (usg, Note n e')
832 scExpr' env (Cast e co) = do (usg, e') <- scExpr env e
833 return (usg, Cast e' (scSubstTy env co))
834 scExpr' env e@(App _ _) = scApp env (collectArgs e)
835 scExpr' env (Lam b e) = do let (env', b') = extendBndr env b
836 (usg, e') <- scExpr env' e
837 return (usg, Lam b' e')
839 scExpr' env (Case scrut b ty alts)
840 = do { (scrut_usg, scrut') <- scExpr env scrut
841 ; case isValue (sc_vals env) scrut' of
842 Just (ConVal con args) -> sc_con_app con args scrut'
843 _other -> sc_vanilla scrut_usg scrut'
846 sc_con_app con args scrut' -- Known constructor; simplify
847 = do { let (_, bs, rhs) = findAlt con alts
848 `orElse` (DEFAULT, [], mkImpossibleExpr (coreAltsType alts))
849 alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)
850 ; scExpr alt_env' rhs }
852 sc_vanilla scrut_usg scrut' -- Normal case
853 = do { let (alt_env,b') = extendBndrWith RecArg env b
854 -- Record RecArg for the components
856 ; (alt_usgs, alt_occs, alts')
857 <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts
859 ; let (alt_usg, b_occ) = lookupOcc (combineUsages alt_usgs) b'
860 scrut_occ = foldr combineOcc b_occ alt_occs
861 scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ
862 -- The combined usage of the scrutinee is given
863 -- by scrut_occ, which is passed to scScrut, which
864 -- in turn treats a bare-variable scrutinee specially
866 ; return (alt_usg `combineUsage` scrut_usg',
867 Case scrut' b' (scSubstTy env ty) alts') }
869 sc_alt env _scrut' b' (con,bs,rhs)
870 = do { let (env1, bs1) = extendBndrsWith RecArg env bs
871 (env2, bs2) = extendCaseBndrs env1 b' con bs1
872 ; (usg,rhs') <- scExpr env2 rhs
873 ; let (usg', arg_occs) = lookupOccs usg bs2
874 scrut_occ = case con of
875 DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)
876 _ -> ScrutOcc emptyUFM
877 ; return (usg', scrut_occ, (con, bs2, rhs')) }
879 scExpr' env (Let (NonRec bndr rhs) body)
880 | isTyVar bndr -- Type-lets may be created by doBeta
881 = scExpr' (extendScSubst env bndr rhs) body
883 = do { let (body_env, bndr') = extendBndr env bndr
884 ; (rhs_usg, (_, args', rhs_body', _)) <- scRecRhs env (bndr',rhs)
885 ; let rhs' = mkLams args' rhs_body'
887 ; if not opt_SpecInlineJoinPoints || null args' || isEmptyVarEnv (scu_calls rhs_usg) then do
889 let body_env2 = extendValEnv body_env bndr' (isValue (sc_vals env) rhs')
890 -- Record if the RHS is a value
891 ; (body_usg, body') <- scExpr body_env2 body
892 ; return (body_usg `combineUsage` rhs_usg, Let (NonRec bndr' rhs') body') }
893 else -- For now, just brutally inline the join point
894 do { let body_env2 = extendScSubst env bndr rhs'
895 ; scExpr body_env2 body } }
899 do { -- Join-point case
900 let body_env2 = extendHowBound body_env [bndr'] RecFun
901 -- If the RHS of this 'let' contains calls
902 -- to recursive functions that we're trying
903 -- to specialise, then treat this let too
904 -- as one to specialise
905 ; (body_usg, body') <- scExpr body_env2 body
907 ; (spec_usg, _, specs) <- specialise env (scu_calls body_usg) ([], rhs_info)
909 ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' }
910 `combineUsage` rhs_usg `combineUsage` spec_usg,
911 mkLets [NonRec b r | (b,r) <- specInfoBinds rhs_info specs] body')
915 -- A *local* recursive group: see Note [Local recursive groups]
916 scExpr' env (Let (Rec prs) body)
917 = do { let (bndrs,rhss) = unzip prs
918 (rhs_env1,bndrs') = extendRecBndrs env bndrs
919 rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
920 force_spec = any (forceSpecBndr env) bndrs'
922 ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
923 ; (body_usg, body') <- scExpr rhs_env2 body
925 -- NB: start specLoop from body_usg
926 ; (spec_usg, specs) <- specLoop rhs_env2 force_spec
927 (scu_calls body_usg) rhs_infos nullUsage
928 [SI [] 0 (Just usg) | usg <- rhs_usgs]
930 ; let all_usg = spec_usg `combineUsage` body_usg
931 bind' = Rec (concat (zipWith specInfoBinds rhs_infos specs))
933 ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' },
936 -----------------------------------
937 scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)
939 scApp env (Var fn, args) -- Function is a variable
940 = ASSERT( not (null args) )
941 do { args_w_usgs <- mapM (scExpr env) args
942 ; let (arg_usgs, args') = unzip args_w_usgs
943 arg_usg = combineUsages arg_usgs
944 ; case scSubstId env fn of
945 fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args')
946 -- Do beta-reduction and try again
948 Var fn' -> return (arg_usg `combineUsage` fn_usg, mkApps (Var fn') args')
950 fn_usg = case lookupHowBound env fn' of
951 Just RecFun -> SCU { scu_calls = unitVarEnv fn' [(sc_vals env, args')],
952 scu_occs = emptyVarEnv }
953 Just RecArg -> SCU { scu_calls = emptyVarEnv,
954 scu_occs = unitVarEnv fn' (ScrutOcc emptyUFM) }
958 other_fn' -> return (arg_usg, mkApps other_fn' args') }
959 -- NB: doing this ignores any usage info from the substituted
960 -- function, but I don't think that matters. If it does
963 doBeta :: OutExpr -> [OutExpr] -> OutExpr
964 -- ToDo: adjust for System IF
965 doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args)
966 doBeta fn args = mkApps fn args
968 -- The function is almost always a variable, but not always.
969 -- In particular, if this pass follows float-in,
970 -- which it may, we can get
971 -- (let f = ...f... in f) arg1 arg2
972 scApp env (other_fn, args)
973 = do { (fn_usg, fn') <- scExpr env other_fn
974 ; (arg_usgs, args') <- mapAndUnzipM (scExpr env) args
975 ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') }
977 ----------------------
978 scTopBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind)
979 scTopBind env (Rec prs)
980 | Just threshold <- sc_size env
982 , not (all (couldBeSmallEnoughToInline threshold) rhss)
984 = do { let (rhs_env,bndrs') = extendRecBndrs env bndrs
985 ; (_, rhss') <- mapAndUnzipM (scExpr rhs_env) rhss
986 ; return (rhs_env, Rec (bndrs' `zip` rhss')) }
987 | otherwise -- Do specialisation
988 = do { let (rhs_env1,bndrs') = extendRecBndrs env bndrs
989 rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
991 ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
992 ; let rhs_usg = combineUsages rhs_usgs
994 ; (_, specs) <- specLoop rhs_env2 force_spec
995 (scu_calls rhs_usg) rhs_infos nullUsage
996 [SI [] 0 Nothing | _ <- bndrs]
998 ; return (rhs_env1, -- For the body of the letrec, delete the RecFun business
999 Rec (concat (zipWith specInfoBinds rhs_infos specs))) }
1001 (bndrs,rhss) = unzip prs
1002 force_spec = any (forceSpecBndr env) bndrs
1004 scTopBind env (NonRec bndr rhs)
1005 = do { (_, rhs') <- scExpr env rhs
1006 ; let (env1, bndr') = extendBndr env bndr
1007 env2 = extendValEnv env1 bndr' (isValue (sc_vals env) rhs')
1008 ; return (env2, NonRec bndr' rhs') }
1010 ----------------------
1011 scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM (ScUsage, RhsInfo)
1012 scRecRhs env (bndr,rhs)
1013 = do { let (arg_bndrs,body) = collectBinders rhs
1014 (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs
1015 ; (body_usg, body') <- scExpr body_env body
1016 ; let (rhs_usg, arg_occs) = lookupOccs body_usg arg_bndrs'
1017 ; return (rhs_usg, (bndr, arg_bndrs', body', arg_occs)) }
1019 -- The arg_occs says how the visible,
1020 -- lambda-bound binders of the RHS are used
1021 -- (including the TyVar binders)
1022 -- Two pats are the same if they match both ways
1024 ----------------------
1025 specInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)]
1026 specInfoBinds (fn, args, body, _) (SI specs _ _)
1027 = [(id,rhs) | OS _ _ id rhs <- specs] ++
1028 [(fn `addIdSpecialisations` rules, mkLams args body)]
1030 rules = [r | OS _ r _ _ <- specs]
1032 ----------------------
1033 varUsage :: ScEnv -> OutVar -> ArgOcc -> ScUsage
1035 | Just RecArg <- lookupHowBound env v = SCU { scu_calls = emptyVarEnv
1036 , scu_occs = unitVarEnv v use }
1037 | otherwise = nullUsage
1041 %************************************************************************
1043 The specialiser itself
1045 %************************************************************************
1048 type RhsInfo = (OutId, [OutVar], OutExpr, [ArgOcc])
1049 -- Info about the *original* RHS of a binding we are specialising
1050 -- Original binding f = \xs.body
1051 -- Plus info about usage of arguments
1053 data SpecInfo = SI [OneSpec] -- The specialisations we have generated
1054 Int -- Length of specs; used for numbering them
1055 (Maybe ScUsage) -- Nothing => we have generated specialisations
1056 -- from calls in the *original* RHS
1057 -- Just cs => we haven't, and this is the usage
1058 -- of the original RHS
1060 -- One specialisation: Rule plus definition
1061 data OneSpec = OS CallPat -- Call pattern that generated this specialisation
1062 CoreRule -- Rule connecting original id with the specialisation
1063 OutId OutExpr -- Spec id + its rhs
1067 -> Bool -- force specialisation?
1070 -> ScUsage -> [SpecInfo] -- One per binder; acccumulating parameter
1071 -> UniqSM (ScUsage, [SpecInfo]) -- ...ditto...
1072 specLoop env force_spec all_calls rhs_infos usg_so_far specs_so_far
1073 = do { specs_w_usg <- zipWithM (specialise env force_spec all_calls) rhs_infos specs_so_far
1074 ; let (new_usg_s, all_specs) = unzip specs_w_usg
1075 new_usg = combineUsages new_usg_s
1076 new_calls = scu_calls new_usg
1077 all_usg = usg_so_far `combineUsage` new_usg
1078 ; if isEmptyVarEnv new_calls then
1079 return (all_usg, all_specs)
1081 specLoop env force_spec new_calls rhs_infos all_usg all_specs }
1085 -> Bool -- force specialisation?
1086 -> CallEnv -- Info on calls
1088 -> SpecInfo -- Original RHS plus patterns dealt with
1089 -> UniqSM (ScUsage, SpecInfo) -- New specialised versions and their usage
1091 -- Note: the rhs here is the optimised version of the original rhs
1092 -- So when we make a specialised copy of the RHS, we're starting
1093 -- from an RHS whose nested functions have been optimised already.
1095 specialise env force_spec bind_calls (fn, arg_bndrs, body, arg_occs)
1096 spec_info@(SI specs spec_count mb_unspec)
1097 | not (isBottomingId fn) -- Note [Do not specialise diverging functions]
1098 , notNull arg_bndrs -- Only specialise functions
1099 , Just all_calls <- lookupVarEnv bind_calls fn
1100 = do { (boring_call, pats) <- callsToPats env specs arg_occs all_calls
1101 -- ; pprTrace "specialise" (vcat [ppr fn <+> ppr arg_occs,
1102 -- text "calls" <+> ppr all_calls,
1103 -- text "good pats" <+> ppr pats]) $
1106 -- Bale out if too many specialisations
1107 -- Rather a hacky way to do so, but it'll do for now
1108 ; let spec_count' = length pats + spec_count
1109 ; case sc_count env of
1110 Just max | not force_spec && spec_count' > max
1111 -> WARN( True, msg ) return (nullUsage, spec_info)
1113 msg = vcat [ sep [ ptext (sLit "SpecConstr: specialisation of") <+> quotes (ppr fn)
1114 , nest 2 (ptext (sLit "limited by bound of")) <+> int max ]
1115 , ptext (sLit "Use -fspec-constr-count=n to set the bound")
1117 extra | not opt_PprStyle_Debug = ptext (sLit "Use -dppr-debug to see specialisations")
1118 | otherwise = ptext (sLit "Specialisations:") <+> ppr (pats ++ [p | OS p _ _ _ <- specs])
1120 _normal_case -> do {
1122 (spec_usgs, new_specs) <- mapAndUnzipM (spec_one env fn arg_bndrs body)
1123 (pats `zip` [spec_count..])
1125 ; let spec_usg = combineUsages spec_usgs
1126 (new_usg, mb_unspec')
1128 Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing)
1129 _ -> (spec_usg, mb_unspec)
1131 ; return (new_usg, SI (new_specs ++ specs) spec_count' mb_unspec') } }
1133 = return (nullUsage, spec_info) -- The boring case
1136 ---------------------
1138 -> OutId -- Function
1139 -> [Var] -- Lambda-binders of RHS; should match patterns
1140 -> CoreExpr -- Body of the original function
1142 -> UniqSM (ScUsage, OneSpec) -- Rule and binding
1144 -- spec_one creates a specialised copy of the function, together
1145 -- with a rule for using it. I'm very proud of how short this
1146 -- function is, considering what it does :-).
1152 f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
1153 [c::*, v::(b,c) are presumably bound by the (...) part]
1155 f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
1156 (...entire body of f...) [b -> (b,c),
1157 y -> ((:) (a,(b,c)) (x,v) hw)]
1159 RULE: forall b::* c::*, -- Note, *not* forall a, x
1163 f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
1166 spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)
1167 = do { -- Specialise the body
1168 let spec_env = extendScSubstList (extendScInScope env qvars)
1169 (arg_bndrs `zip` pats)
1170 ; (spec_usg, spec_body) <- scExpr spec_env body
1172 -- ; pprTrace "spec_one" (ppr fn <+> vcat [text "pats" <+> ppr pats,
1173 -- text "calls" <+> (ppr (scu_calls spec_usg))])
1176 -- And build the results
1177 ; spec_uniq <- getUniqueUs
1178 ; let (spec_lam_args, spec_call_args) = mkWorkerArgs qvars body_ty
1179 -- Usual w/w hack to avoid generating
1180 -- a spec_rhs of unlifted type and no args
1183 fn_loc = nameSrcSpan fn_name
1184 spec_occ = mkSpecOcc (nameOccName fn_name)
1185 rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number))
1186 spec_rhs = mkLams spec_lam_args spec_body
1187 spec_str = calcSpecStrictness fn spec_lam_args pats
1188 spec_id = mkUserLocal spec_occ spec_uniq (mkPiTypes spec_lam_args body_ty) fn_loc
1189 `setIdStrictness` spec_str -- See Note [Transfer strictness]
1190 `setIdArity` count isId spec_lam_args
1191 body_ty = exprType spec_body
1192 rule_rhs = mkVarApps (Var spec_id) spec_call_args
1193 rule = mkLocalRule rule_name specConstrActivation fn_name qvars pats rule_rhs
1194 ; return (spec_usg, OS call_pat rule spec_id spec_rhs) }
1196 calcSpecStrictness :: Id -- The original function
1197 -> [Var] -> [CoreExpr] -- Call pattern
1198 -> StrictSig -- Strictness of specialised thing
1199 -- See Note [Transfer strictness]
1200 calcSpecStrictness fn qvars pats
1201 = StrictSig (mkTopDmdType spec_dmds TopRes)
1203 spec_dmds = [ lookupVarEnv dmd_env qv `orElse` lazyDmd | qv <- qvars, isId qv ]
1204 StrictSig (DmdType _ dmds _) = idStrictness fn
1206 dmd_env = go emptyVarEnv dmds pats
1208 go env ds (Type {} : pats) = go env ds pats
1209 go env (d:ds) (pat : pats) = go (go_one env d pat) ds pats
1212 go_one env d (Var v) = extendVarEnv_C both env v d
1213 go_one env (Box d) e = go_one env d e
1214 go_one env (Eval (Prod ds)) e
1215 | (Var _, args) <- collectArgs e = go env ds args
1216 go_one env _ _ = env
1218 -- In which phase should the specialise-constructor rules be active?
1219 -- Originally I made them always-active, but Manuel found that
1220 -- this defeated some clever user-written rules. So Plan B
1221 -- is to make them active only in Phase 0; after all, currently,
1222 -- the specConstr transformation is only run after the simplifier
1223 -- has reached Phase 0. In general one would want it to be
1224 -- flag-controllable, but for now I'm leaving it baked in
1226 specConstrActivation :: Activation
1227 specConstrActivation = ActiveAfter 0 -- Baked in; see comments above
1230 Note [Transfer strictness]
1231 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1232 We must transfer strictness information from the original function to
1233 the specialised one. Suppose, for example
1236 and a RULE f (a:as) b = f_spec a as b
1238 Now we want f_spec to have strictess LLS, otherwise we'll use call-by-need
1239 when calling f_spec instead of call-by-value. And that can result in
1240 unbounded worsening in space (cf the classic foldl vs foldl')
1242 See Trac #3437 for a good example.
1244 The function calcSpecStrictness performs the calculation.
1247 %************************************************************************
1249 \subsection{Argument analysis}
1251 %************************************************************************
1253 This code deals with analysing call-site arguments to see whether
1254 they are constructor applications.
1258 type CallPat = ([Var], [CoreExpr]) -- Quantified variables and arguments
1261 callsToPats :: ScEnv -> [OneSpec] -> [ArgOcc] -> [Call] -> UniqSM (Bool, [CallPat])
1262 -- Result has no duplicate patterns,
1263 -- nor ones mentioned in done_pats
1264 -- Bool indicates that there was at least one boring pattern
1265 callsToPats env done_specs bndr_occs calls
1266 = do { mb_pats <- mapM (callToPats env bndr_occs) calls
1268 ; let good_pats :: [([Var], [CoreArg])]
1269 good_pats = catMaybes mb_pats
1270 done_pats = [p | OS p _ _ _ <- done_specs]
1271 is_done p = any (samePat p) done_pats
1273 ; return (any isNothing mb_pats,
1274 filterOut is_done (nubBy samePat good_pats)) }
1276 callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
1277 -- The [Var] is the variables to quantify over in the rule
1278 -- Type variables come first, since they may scope
1279 -- over the following term variables
1280 -- The [CoreExpr] are the argument patterns for the rule
1281 callToPats env bndr_occs (con_env, args)
1282 | length args < length bndr_occs -- Check saturated
1285 = do { let in_scope = substInScope (sc_subst env)
1286 ; prs <- argsToPats env in_scope con_env (args `zip` bndr_occs)
1287 ; let (interesting_s, pats) = unzip prs
1288 pat_fvs = varSetElems (exprsFreeVars pats)
1289 qvars = filterOut (`elemInScopeSet` in_scope) pat_fvs
1290 -- Quantify over variables that are not in sccpe
1292 -- See Note [Shadowing] at the top
1294 (tvs, ids) = partition isTyVar qvars
1296 -- Put the type variables first; the type of a term
1297 -- variable may mention a type variable
1299 ; -- pprTrace "callToPats" (ppr args $$ ppr prs $$ ppr bndr_occs) $
1301 then return (Just (qvars', pats))
1302 else return Nothing }
1304 -- argToPat takes an actual argument, and returns an abstracted
1305 -- version, consisting of just the "constructor skeleton" of the
1306 -- argument, with non-constructor sub-expression replaced by new
1307 -- placeholder variables. For example:
1308 -- C a (D (f x) (g y)) ==> C p1 (D p2 p3)
1311 -> InScopeSet -- What's in scope at the fn defn site
1312 -> ValueEnv -- ValueEnv at the call site
1313 -> CoreArg -- A call arg (or component thereof)
1315 -> UniqSM (Bool, CoreArg)
1316 -- Returns (interesting, pat),
1317 -- where pat is the pattern derived from the argument
1318 -- intersting=True if the pattern is non-trivial (not a variable or type)
1319 -- E.g. x:xs --> (True, x:xs)
1320 -- f xs --> (False, w) where w is a fresh wildcard
1321 -- (f xs, 'c') --> (True, (w, 'c')) where w is a fresh wildcard
1322 -- \x. x+y --> (True, \x. x+y)
1323 -- lvl7 --> (True, lvl7) if lvl7 is bound
1324 -- somewhere further out
1326 argToPat _env _in_scope _val_env arg@(Type {}) _arg_occ
1327 = return (False, arg)
1329 argToPat env in_scope val_env (Note _ arg) arg_occ
1330 = argToPat env in_scope val_env arg arg_occ
1331 -- Note [Notes in call patterns]
1332 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1333 -- Ignore Notes. In particular, we want to ignore any InlineMe notes
1334 -- Perhaps we should not ignore profiling notes, but I'm going to
1335 -- ride roughshod over them all for now.
1336 --- See Note [Notes in RULE matching] in Rules
1338 argToPat env in_scope val_env (Let _ arg) arg_occ
1339 = argToPat env in_scope val_env arg arg_occ
1340 -- Look through let expressions
1341 -- e.g. f (let v = rhs in \y -> ...v...)
1342 -- Here we can specialise for f (\y -> ...)
1343 -- because the rule-matcher will look through the let.
1345 argToPat env in_scope val_env (Cast arg co) arg_occ
1346 | not (ignoreType env ty2)
1347 = do { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ
1348 ; if not interesting then
1351 { -- Make a wild-card pattern for the coercion
1353 ; let co_name = mkSysTvName uniq (fsLit "sg")
1354 co_var = mkCoVar co_name (mkCoKind ty1 ty2)
1355 ; return (interesting, Cast arg' (mkTyVarTy co_var)) } }
1357 (ty1, ty2) = coercionKind co
1361 {- Disabling lambda specialisation for now
1362 It's fragile, and the spec_loop can be infinite
1363 argToPat in_scope val_env arg arg_occ
1365 = return (True, arg)
1367 is_value_lam (Lam v e) -- Spot a value lambda, even if
1368 | isId v = True -- it is inside a type lambda
1369 | otherwise = is_value_lam e
1370 is_value_lam other = False
1373 -- Check for a constructor application
1374 -- NB: this *precedes* the Var case, so that we catch nullary constrs
1375 argToPat env in_scope val_env arg arg_occ
1376 | Just (ConVal dc args) <- isValue val_env arg
1377 , not (ignoreAltCon env dc)
1379 ScrutOcc _ -> True -- Used only by case scrutinee
1380 BothOcc -> case arg of -- Used elsewhere
1381 App {} -> True -- see Note [Reboxing]
1383 _other -> False -- No point; the arg is not decomposed
1384 = do { args' <- argsToPats env in_scope val_env (args `zip` conArgOccs arg_occ dc)
1385 ; return (True, mk_con_app dc (map snd args')) }
1387 -- Check if the argument is a variable that
1388 -- is in scope at the function definition site
1389 -- It's worth specialising on this if
1390 -- (a) it's used in an interesting way in the body
1391 -- (b) we know what its value is
1392 argToPat env in_scope val_env (Var v) arg_occ
1393 | case arg_occ of { UnkOcc -> False; _other -> True }, -- (a)
1395 not (ignoreType env (varType v))
1396 = return (True, Var v)
1399 | isLocalId v = v `elemInScopeSet` in_scope
1400 && isJust (lookupVarEnv val_env v)
1401 -- Local variables have values in val_env
1402 | otherwise = isValueUnfolding (idUnfolding v)
1403 -- Imports have unfoldings
1405 -- I'm really not sure what this comment means
1406 -- And by not wild-carding we tend to get forall'd
1407 -- variables that are in soope, which in turn can
1408 -- expose the weakness in let-matching
1409 -- See Note [Matching lets] in Rules
1411 -- Check for a variable bound inside the function.
1412 -- Don't make a wild-card, because we may usefully share
1413 -- e.g. f a = let x = ... in f (x,x)
1414 -- NB: this case follows the lambda and con-app cases!!
1415 -- argToPat _in_scope _val_env (Var v) _arg_occ
1416 -- = return (False, Var v)
1417 -- SLPJ : disabling this to avoid proliferation of versions
1418 -- also works badly when thinking about seeding the loop
1419 -- from the body of the let
1420 -- f x y = letrec g z = ... in g (x,y)
1421 -- We don't want to specialise for that *particular* x,y
1423 -- The default case: make a wild-card
1424 argToPat _env _in_scope _val_env arg _arg_occ
1425 = wildCardPat (exprType arg)
1427 wildCardPat :: Type -> UniqSM (Bool, CoreArg)
1428 wildCardPat ty = do { uniq <- getUniqueUs
1429 ; let id = mkSysLocal (fsLit "sc") uniq ty
1430 ; return (False, Var id) }
1432 argsToPats :: ScEnv -> InScopeSet -> ValueEnv
1433 -> [(CoreArg, ArgOcc)]
1434 -> UniqSM [(Bool, CoreArg)]
1435 argsToPats env in_scope val_env args
1438 do_one (arg,occ) = argToPat env in_scope val_env arg occ
1443 isValue :: ValueEnv -> CoreExpr -> Maybe Value
1444 isValue _env (Lit lit)
1445 = Just (ConVal (LitAlt lit) [])
1448 | Just stuff <- lookupVarEnv env v
1449 = Just stuff -- You might think we could look in the idUnfolding here
1450 -- but that doesn't take account of which branch of a
1451 -- case we are in, which is the whole point
1453 | not (isLocalId v) && isCheapUnfolding unf
1454 = isValue env (unfoldingTemplate unf)
1457 -- However we do want to consult the unfolding
1458 -- as well, for let-bound constructors!
1460 isValue env (Lam b e)
1461 | isTyVar b = case isValue env e of
1462 Just _ -> Just LambdaVal
1464 | otherwise = Just LambdaVal
1466 isValue _env expr -- Maybe it's a constructor application
1467 | (Var fun, args) <- collectArgs expr
1468 = case isDataConWorkId_maybe fun of
1470 Just con | args `lengthAtLeast` dataConRepArity con
1471 -- Check saturated; might be > because the
1472 -- arity excludes type args
1473 -> Just (ConVal (DataAlt con) args)
1475 _other | valArgCount args < idArity fun
1476 -- Under-applied function
1477 -> Just LambdaVal -- Partial application
1481 isValue _env _expr = Nothing
1483 mk_con_app :: AltCon -> [CoreArg] -> CoreExpr
1484 mk_con_app (LitAlt lit) [] = Lit lit
1485 mk_con_app (DataAlt con) args = mkConApp con args
1486 mk_con_app _other _args = panic "SpecConstr.mk_con_app"
1488 samePat :: CallPat -> CallPat -> Bool
1489 samePat (vs1, as1) (vs2, as2)
1492 same (Var v1) (Var v2)
1493 | v1 `elem` vs1 = v2 `elem` vs2
1494 | v2 `elem` vs2 = False
1495 | otherwise = v1 == v2
1497 same (Lit l1) (Lit l2) = l1==l2
1498 same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2
1500 same (Type {}) (Type {}) = True -- Note [Ignore type differences]
1501 same (Note _ e1) e2 = same e1 e2 -- Ignore casts and notes
1502 same (Cast e1 _) e2 = same e1 e2
1503 same e1 (Note _ e2) = same e1 e2
1504 same e1 (Cast e2 _) = same e1 e2
1506 same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2)
1507 False -- Let, lambda, case should not occur
1508 bad (Case {}) = True
1514 Note [Ignore type differences]
1515 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1516 We do not want to generate specialisations where the call patterns
1517 differ only in their type arguments! Not only is it utterly useless,
1518 but it also means that (with polymorphic recursion) we can generate
1519 an infinite number of specialisations. Example is Data.Sequence.adjustTree,