2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[SpecConstr]{Specialise over constructors}
7 -- The above warning supression flag is a temporary kludge.
8 -- While working on this module you are encouraged to remove it and fix
9 -- any warnings in the module. See
10 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
17 #include "HsVersions.h"
22 import CoreUnfold ( couldBeSmallEnoughToInline )
23 import CoreLint ( showPass, endPass )
24 import CoreFVs ( exprsFreeVars )
25 import WwLib ( mkWorkerArgs )
26 import DataCon ( dataConRepArity, dataConUnivTyVars )
29 import Type hiding( substTy )
30 import Id ( Id, idName, idType, isDataConWorkId_maybe, idArity,
31 mkUserLocal, mkSysLocal, idUnfolding, isLocalId )
36 import OccName ( mkSpecOcc )
37 import ErrUtils ( dumpIfSet_dyn )
38 import DynFlags ( DynFlags(..), DynFlag(..) )
39 import StaticFlags ( opt_SpecInlineJoinPoints )
40 import BasicTypes ( Activation(..) )
41 import Maybes ( orElse, catMaybes, isJust, isNothing )
43 import List ( nubBy, partition )
49 import Control.Monad ( zipWithM )
52 -----------------------------------------------------
54 -----------------------------------------------------
59 drop n (x:xs) = drop (n-1) xs
61 After the first time round, we could pass n unboxed. This happens in
62 numerical code too. Here's what it looks like in Core:
64 drop n xs = case xs of
69 _ -> drop (I# (n# -# 1#)) xs
71 Notice that the recursive call has an explicit constructor as argument.
72 Noticing this, we can make a specialised version of drop
74 RULE: drop (I# n#) xs ==> drop' n# xs
76 drop' n# xs = let n = I# n# in ...orig RHS...
78 Now the simplifier will apply the specialisation in the rhs of drop', giving
80 drop' n# xs = case xs of
84 _ -> drop (n# -# 1#) xs
88 We'd also like to catch cases where a parameter is carried along unchanged,
89 but evaluated each time round the loop:
91 f i n = if i>0 || i>n then i else f (i*2) n
93 Here f isn't strict in n, but we'd like to avoid evaluating it each iteration.
94 In Core, by the time we've w/wd (f is strict in i) we get
96 f i# n = case i# ># 0 of
98 True -> case n of n' { I# n# ->
101 True -> f (i# *# 2#) n'
103 At the call to f, we see that the argument, n is know to be (I# n#),
104 and n is evaluated elsewhere in the body of f, so we can play the same
110 We must be careful not to allocate the same constructor twice. Consider
111 f p = (...(case p of (a,b) -> e)...p...,
112 ...let t = (r,s) in ...t...(f t)...)
113 At the recursive call to f, we can see that t is a pair. But we do NOT want
114 to make a specialised copy:
115 f' a b = let p = (a,b) in (..., ...)
116 because now t is allocated by the caller, then r and s are passed to the
117 recursive call, which allocates the (r,s) pair again.
120 (a) the argument p is used in other than a case-scrutinsation way.
121 (b) the argument to the call is not a 'fresh' tuple; you have to
122 look into its unfolding to see that it's a tuple
124 Hence the "OR" part of Note [Good arguments] below.
126 ALTERNATIVE 2: pass both boxed and unboxed versions. This no longer saves
127 allocation, but does perhaps save evals. In the RULE we'd have
130 f (I# x#) = f' (I# x#) x#
132 If at the call site the (I# x) was an unfolding, then we'd have to
133 rely on CSE to eliminate the duplicate allocation.... This alternative
134 doesn't look attractive enough to pursue.
136 ALTERNATIVE 3: ignore the reboxing problem. The trouble is that
137 the conservative reboxing story prevents many useful functions from being
138 specialised. Example:
139 foo :: Maybe Int -> Int -> Int
141 foo x@(Just m) n = foo x (n-m)
142 Here the use of 'x' will clearly not require boxing in the specialised function.
144 The strictness analyser has the same problem, in fact. Example:
146 If we pass just 'a' and 'b' to the worker, it might need to rebox the
147 pair to create (a,b). A more sophisticated analysis might figure out
148 precisely the cases in which this could happen, but the strictness
149 analyser does no such analysis; it just passes 'a' and 'b', and hopes
152 So my current choice is to make SpecConstr similarly aggressive, and
153 ignore the bad potential of reboxing.
156 Note [Good arguments]
157 ~~~~~~~~~~~~~~~~~~~~~
160 * A self-recursive function. Ignore mutual recursion for now,
161 because it's less common, and the code is simpler for self-recursion.
165 a) At a recursive call, one or more parameters is an explicit
166 constructor application
168 That same parameter is scrutinised by a case somewhere in
169 the RHS of the function
173 b) At a recursive call, one or more parameters has an unfolding
174 that is an explicit constructor application
176 That same parameter is scrutinised by a case somewhere in
177 the RHS of the function
179 Those are the only uses of the parameter (see Note [Reboxing])
182 What to abstract over
183 ~~~~~~~~~~~~~~~~~~~~~
184 There's a bit of a complication with type arguments. If the call
187 f p = ...f ((:) [a] x xs)...
189 then our specialised function look like
191 f_spec x xs = let p = (:) [a] x xs in ....as before....
193 This only makes sense if either
194 a) the type variable 'a' is in scope at the top of f, or
195 b) the type variable 'a' is an argument to f (and hence fs)
197 Actually, (a) may hold for value arguments too, in which case
198 we may not want to pass them. Supose 'x' is in scope at f's
199 defn, but xs is not. Then we'd like
201 f_spec xs = let p = (:) [a] x xs in ....as before....
203 Similarly (b) may hold too. If x is already an argument at the
204 call, no need to pass it again.
206 Finally, if 'a' is not in scope at the call site, we could abstract
207 it as we do the term variables:
209 f_spec a x xs = let p = (:) [a] x xs in ...as before...
211 So the grand plan is:
213 * abstract the call site to a constructor-only pattern
214 e.g. C x (D (f p) (g q)) ==> C s1 (D s2 s3)
216 * Find the free variables of the abstracted pattern
218 * Pass these variables, less any that are in scope at
219 the fn defn. But see Note [Shadowing] below.
222 NOTICE that we only abstract over variables that are not in scope,
223 so we're in no danger of shadowing variables used in "higher up"
229 In this pass we gather up usage information that may mention variables
230 that are bound between the usage site and the definition site; or (more
231 seriously) may be bound to something different at the definition site.
234 f x = letrec g y v = let x = ...
237 Since 'x' is in scope at the call site, we may make a rewrite rule that
239 RULE forall a,b. g (a,b) x = ...
240 But this rule will never match, because it's really a different 'x' at
241 the call site -- and that difference will be manifest by the time the
242 simplifier gets to it. [A worry: the simplifier doesn't *guarantee*
243 no-shadowing, so perhaps it may not be distinct?]
245 Anyway, the rule isn't actually wrong, it's just not useful. One possibility
246 is to run deShadowBinds before running SpecConstr, but instead we run the
247 simplifier. That gives the simplest possible program for SpecConstr to
248 chew on; and it virtually guarantees no shadowing.
250 Note [Specialising for constant parameters]
251 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
252 This one is about specialising on a *constant* (but not necessarily
253 constructor) argument
255 foo :: Int -> (Int -> Int) -> Int
257 foo m f = foo (f m) (+1)
261 lvl_rmV :: GHC.Base.Int -> GHC.Base.Int
263 \ (ds_dlk :: GHC.Base.Int) ->
264 case ds_dlk of wild_alH { GHC.Base.I# x_alG ->
265 GHC.Base.I# (GHC.Prim.+# x_alG 1)
267 T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
270 \ (ww_sme :: GHC.Prim.Int#) (w_smg :: GHC.Base.Int -> GHC.Base.Int) ->
271 case ww_sme of ds_Xlw {
273 case w_smg (GHC.Base.I# ds_Xlw) of w1_Xmo { GHC.Base.I# ww1_Xmz ->
274 T.$wfoo ww1_Xmz lvl_rmV
279 The recursive call has lvl_rmV as its argument, so we could create a specialised copy
280 with that argument baked in; that is, not passed at all. Now it can perhaps be inlined.
282 When is this worth it? Call the constant 'lvl'
283 - If 'lvl' has an unfolding that is a constructor, see if the corresponding
284 parameter is scrutinised anywhere in the body.
286 - If 'lvl' has an unfolding that is a inlinable function, see if the corresponding
287 parameter is applied (...to enough arguments...?)
289 Also do this is if the function has RULES?
293 Note [Specialising for lambda parameters]
294 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
295 foo :: Int -> (Int -> Int) -> Int
297 foo m f = foo (f m) (\n -> n-m)
299 This is subtly different from the previous one in that we get an
300 explicit lambda as the argument:
302 T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
305 \ (ww_sm8 :: GHC.Prim.Int#) (w_sma :: GHC.Base.Int -> GHC.Base.Int) ->
306 case ww_sm8 of ds_Xlr {
308 case w_sma (GHC.Base.I# ds_Xlr) of w1_Xmf { GHC.Base.I# ww1_Xmq ->
311 (\ (n_ad3 :: GHC.Base.Int) ->
312 case n_ad3 of wild_alB { GHC.Base.I# x_alA ->
313 GHC.Base.I# (GHC.Prim.-# x_alA ds_Xlr)
319 I wonder if SpecConstr couldn't be extended to handle this? After all,
320 lambda is a sort of constructor for functions and perhaps it already
321 has most of the necessary machinery?
323 Furthermore, there's an immediate win, because you don't need to allocate the lamda
324 at the call site; and if perchance it's called in the recursive call, then you
325 may avoid allocating it altogether. Just like for constructors.
327 Looks cool, but probably rare...but it might be easy to implement.
330 Note [SpecConstr for casts]
331 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
334 data instance T Int = T Int
339 go (T n) = go (T (n-1))
341 The recursive call ends up looking like
342 go (T (I# ...) `cast` g)
343 So we want to spot the construtor application inside the cast.
344 That's why we have the Cast case in argToPat
346 Note [Local recursive groups]
347 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
348 For a *local* recursive group, we can see all the calls to the
349 function, so we seed the specialisation loop from the calls in the
350 body, not from the calls in the RHS. Consider:
352 bar m n = foo n (n,n) (n,n) (n,n) (n,n)
356 | n > 3000 = case p of { (p1,p2) -> foo (n-1) (p2,p1) q r s }
357 | n > 2000 = case q of { (q1,q2) -> foo (n-1) p (q2,q1) r s }
358 | n > 1000 = case r of { (r1,r2) -> foo (n-1) p q (r2,r1) s }
359 | otherwise = case s of { (s1,s2) -> foo (n-1) p q r (s2,s1) }
361 If we start with the RHSs of 'foo', we get lots and lots of specialisations,
362 most of which are not needed. But if we start with the (single) call
363 in the rhs of 'bar' we get exactly one fully-specialised copy, and all
364 the recursive calls go to this fully-specialised copy. Indeed, the original
365 function is later collected as dead code. This is very important in
366 specialising the loops arising from stream fusion, for example in NDP where
367 we were getting literally hundreds of (mostly unused) specialisations of
370 -----------------------------------------------------
371 Stuff not yet handled
372 -----------------------------------------------------
374 Here are notes arising from Roman's work that I don't want to lose.
380 foo :: Int -> T Int -> Int
382 foo x t | even x = case t of { T n -> foo (x-n) t }
383 | otherwise = foo (x-1) t
385 SpecConstr does no specialisation, because the second recursive call
386 looks like a boxed use of the argument. A pity.
388 $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
390 \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) ->
391 case ww_sFo of ds_Xw6 [Just L] {
393 case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] {
394 __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq;
396 case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] ->
397 case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] ->
398 $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy
404 data a :*: b = !a :*: !b
407 foo :: (Int :*: T Int) -> Int
409 foo (x :*: t) | even x = case t of { T n -> foo ((x-n) :*: t) }
410 | otherwise = foo ((x-1) :*: t)
412 Very similar to the previous one, except that the parameters are now in
413 a strict tuple. Before SpecConstr, we have
415 $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
417 \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T
419 case ww_sFU of ds_Xws [Just L] {
421 case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] {
423 case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] ->
424 $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2 -- $wfoo1
427 case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] ->
428 case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] ->
429 $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB -- $wfoo2
433 We get two specialisations:
434 "SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#}
435 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB)
436 = Foo.$s$wfoo1 a_sFB sc_sGC ;
437 "SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#}
438 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp))
439 = Foo.$s$wfoo y_aFp sc_sGC ;
441 But perhaps the first one isn't good. After all, we know that tpl_B2 is
442 a T (I# x) really, because T is strict and Int has one constructor. (We can't
443 unbox the strict fields, becuase T is polymorphic!)
447 %************************************************************************
449 \subsection{Top level wrapper stuff}
451 %************************************************************************
454 specConstrProgram :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]
455 specConstrProgram dflags us binds
457 showPass dflags "SpecConstr"
459 let (binds', _) = initUs us (go (initScEnv dflags) binds)
461 endPass dflags "SpecConstr" Opt_D_dump_spec binds'
463 dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
464 (pprRulesForUser (rulesOfBinds binds'))
469 go env (bind:binds) = do (env', bind') <- scTopBind env bind
470 binds' <- go env' binds
471 return (bind' : binds')
475 %************************************************************************
477 \subsection{Environment: goes downwards}
479 %************************************************************************
482 data ScEnv = SCE { sc_size :: Maybe Int, -- Size threshold
483 sc_count :: Maybe Int, -- Max # of specialisations for any one fn
485 sc_subst :: Subst, -- Current substitution
486 -- Maps InIds to OutExprs
488 sc_how_bound :: HowBoundEnv,
489 -- Binds interesting non-top-level variables
490 -- Domain is OutVars (*after* applying the substitution)
493 -- Domain is OutIds (*after* applying the substitution)
494 -- Used even for top-level bindings (but not imported ones)
497 ---------------------
498 -- As we go, we apply a substitution (sc_subst) to the current term
499 type InExpr = CoreExpr -- _Before_ applying the subst
501 type OutExpr = CoreExpr -- _After_ applying the subst
505 ---------------------
506 type HowBoundEnv = VarEnv HowBound -- Domain is OutVars
508 ---------------------
509 type ValueEnv = IdEnv Value -- Domain is OutIds
510 data Value = ConVal AltCon [CoreArg] -- _Saturated_ constructors
511 | LambdaVal -- Inlinable lambdas or PAPs
513 instance Outputable Value where
514 ppr (ConVal con args) = ppr con <+> interpp'SP args
515 ppr LambdaVal = ptext (sLit "<Lambda>")
517 ---------------------
518 initScEnv :: DynFlags -> ScEnv
520 = SCE { sc_size = specConstrThreshold dflags,
521 sc_count = specConstrCount dflags,
522 sc_subst = emptySubst,
523 sc_how_bound = emptyVarEnv,
524 sc_vals = emptyVarEnv }
526 data HowBound = RecFun -- These are the recursive functions for which
527 -- we seek interesting call patterns
529 | RecArg -- These are those functions' arguments, or their sub-components;
530 -- we gather occurrence information for these
532 instance Outputable HowBound where
533 ppr RecFun = text "RecFun"
534 ppr RecArg = text "RecArg"
536 lookupHowBound :: ScEnv -> Id -> Maybe HowBound
537 lookupHowBound env id = lookupVarEnv (sc_how_bound env) id
539 scSubstId :: ScEnv -> Id -> CoreExpr
540 scSubstId env v = lookupIdSubst (sc_subst env) v
542 scSubstTy :: ScEnv -> Type -> Type
543 scSubstTy env ty = substTy (sc_subst env) ty
545 zapScSubst :: ScEnv -> ScEnv
546 zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) }
548 extendScInScope :: ScEnv -> [Var] -> ScEnv
549 -- Bring the quantified variables into scope
550 extendScInScope env qvars = env { sc_subst = extendInScopeList (sc_subst env) qvars }
552 -- Extend the substitution
553 extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv
554 extendScSubst env var expr = env { sc_subst = extendSubst (sc_subst env) var expr }
556 extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv
557 extendScSubstList env prs = env { sc_subst = extendSubstList (sc_subst env) prs }
559 extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv
560 extendHowBound env bndrs how_bound
561 = env { sc_how_bound = extendVarEnvList (sc_how_bound env)
562 [(bndr,how_bound) | bndr <- bndrs] }
564 extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var])
565 extendBndrsWith how_bound env bndrs
566 = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndrs')
568 (subst', bndrs') = substBndrs (sc_subst env) bndrs
569 hb_env' = sc_how_bound env `extendVarEnvList`
570 [(bndr,how_bound) | bndr <- bndrs']
572 extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var)
573 extendBndrWith how_bound env bndr
574 = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndr')
576 (subst', bndr') = substBndr (sc_subst env) bndr
577 hb_env' = extendVarEnv (sc_how_bound env) bndr' how_bound
579 extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var])
580 extendRecBndrs env bndrs = (env { sc_subst = subst' }, bndrs')
582 (subst', bndrs') = substRecBndrs (sc_subst env) bndrs
584 extendBndr :: ScEnv -> Var -> (ScEnv, Var)
585 extendBndr env bndr = (env { sc_subst = subst' }, bndr')
587 (subst', bndr') = substBndr (sc_subst env) bndr
589 extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv
590 extendValEnv env _ Nothing = env
591 extendValEnv env id (Just cv) = env { sc_vals = extendVarEnv (sc_vals env) id cv }
593 extendCaseBndrs :: ScEnv -> CoreExpr -> Id -> AltCon -> [Var] -> ScEnv
597 -- we want to bind b, and perhaps scrut too, to (C x y)
598 -- NB: Extends only the sc_vals part of the envt
599 extendCaseBndrs env scrut case_bndr con alt_bndrs
601 Var v -> extendValEnv env1 v cval
604 env1 = extendValEnv env case_bndr cval
607 LitAlt {} -> Just (ConVal con [])
608 DataAlt {} -> Just (ConVal con vanilla_args)
610 vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
611 varsToCoreExprs alt_bndrs
615 %************************************************************************
617 \subsection{Usage information: flows upwards}
619 %************************************************************************
624 scu_calls :: CallEnv, -- Calls
625 -- The functions are a subset of the
626 -- RecFuns in the ScEnv
628 scu_occs :: !(IdEnv ArgOcc) -- Information on argument occurrences
629 } -- The domain is OutIds
631 type CallEnv = IdEnv [Call]
632 type Call = (ValueEnv, [CoreArg])
633 -- The arguments of the call, together with the
634 -- env giving the constructor bindings at the call site
637 nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv }
639 combineCalls :: CallEnv -> CallEnv -> CallEnv
640 combineCalls = plusVarEnv_C (++)
642 combineUsage :: ScUsage -> ScUsage -> ScUsage
643 combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2),
644 scu_occs = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) }
646 combineUsages :: [ScUsage] -> ScUsage
647 combineUsages [] = nullUsage
648 combineUsages us = foldr1 combineUsage us
650 lookupOcc :: ScUsage -> OutVar -> (ScUsage, ArgOcc)
651 lookupOcc (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndr
652 = (SCU {scu_calls = sc_calls, scu_occs = delVarEnv sc_occs bndr},
653 lookupVarEnv sc_occs bndr `orElse` NoOcc)
655 lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc])
656 lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs
657 = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs},
658 [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs])
660 data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument
661 | UnkOcc -- Used in some unknown way
663 | ScrutOcc (UniqFM [ArgOcc]) -- See Note [ScrutOcc]
665 | BothOcc -- Definitely taken apart, *and* perhaps used in some other way
669 An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing,
670 is *only* taken apart or applied.
672 Functions, literal: ScrutOcc emptyUFM
673 Data constructors: ScrutOcc subs,
675 where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components,
676 The domain of the UniqFM is the Unique of the data constructor
678 The [ArgOcc] is the occurrences of the *pattern-bound* components
679 of the data structure. E.g.
680 data T a = forall b. MkT a b (b->a)
681 A pattern binds b, x::a, y::b, z::b->a, but not 'a'!
685 instance Outputable ArgOcc where
686 ppr (ScrutOcc xs) = ptext (sLit "scrut-occ") <> ppr xs
687 ppr UnkOcc = ptext (sLit "unk-occ")
688 ppr BothOcc = ptext (sLit "both-occ")
689 ppr NoOcc = ptext (sLit "no-occ")
691 -- Experimentally, this vesion of combineOcc makes ScrutOcc "win", so
692 -- that if the thing is scrutinised anywhere then we get to see that
693 -- in the overall result, even if it's also used in a boxed way
694 -- This might be too agressive; see Note [Reboxing] Alternative 3
695 combineOcc :: ArgOcc -> ArgOcc -> ArgOcc
696 combineOcc NoOcc occ = occ
697 combineOcc occ NoOcc = occ
698 combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys)
699 combineOcc _occ (ScrutOcc ys) = ScrutOcc ys
700 combineOcc (ScrutOcc xs) _occ = ScrutOcc xs
701 combineOcc UnkOcc UnkOcc = UnkOcc
702 combineOcc _ _ = BothOcc
704 combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]
705 combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys
707 setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage
708 -- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee
709 -- is a variable, and an interesting variable
710 setScrutOcc env usg (Cast e _) occ = setScrutOcc env usg e occ
711 setScrutOcc env usg (Note _ e) occ = setScrutOcc env usg e occ
712 setScrutOcc env usg (Var v) occ
713 | Just RecArg <- lookupHowBound env v = usg { scu_occs = extendVarEnv (scu_occs usg) v occ }
715 setScrutOcc _env usg _other _occ -- Catch-all
718 conArgOccs :: ArgOcc -> AltCon -> [ArgOcc]
719 -- Find usage of components of data con; returns [UnkOcc...] if unknown
720 -- See Note [ScrutOcc] for the extra UnkOccs in the vanilla datacon case
722 conArgOccs (ScrutOcc fm) (DataAlt dc)
723 | Just pat_arg_occs <- lookupUFM fm dc
724 = [UnkOcc | _ <- dataConUnivTyVars dc] ++ pat_arg_occs
726 conArgOccs _other _con = repeat UnkOcc
729 %************************************************************************
731 \subsection{The main recursive function}
733 %************************************************************************
735 The main recursive function gathers up usage information, and
736 creates specialised versions of functions.
739 scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
740 -- The unique supply is needed when we invent
741 -- a new name for the specialised function and its args
743 scExpr env e = scExpr' env e
746 scExpr' env (Var v) = case scSubstId env v of
747 Var v' -> return (varUsage env v' UnkOcc, Var v')
748 e' -> scExpr (zapScSubst env) e'
750 scExpr' env (Type t) = return (nullUsage, Type (scSubstTy env t))
751 scExpr' _ e@(Lit {}) = return (nullUsage, e)
752 scExpr' env (Note n e) = do (usg,e') <- scExpr env e
753 return (usg, Note n e')
754 scExpr' env (Cast e co) = do (usg, e') <- scExpr env e
755 return (usg, Cast e' (scSubstTy env co))
756 scExpr' env e@(App _ _) = scApp env (collectArgs e)
757 scExpr' env (Lam b e) = do let (env', b') = extendBndr env b
758 (usg, e') <- scExpr env' e
759 return (usg, Lam b' e')
761 scExpr' env (Case scrut b ty alts)
762 = do { (scrut_usg, scrut') <- scExpr env scrut
763 ; case isValue (sc_vals env) scrut' of
764 Just (ConVal con args) -> sc_con_app con args scrut'
765 _other -> sc_vanilla scrut_usg scrut'
768 sc_con_app con args scrut' -- Known constructor; simplify
769 = do { let (_, bs, rhs) = findAlt con alts
770 alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)
771 ; scExpr alt_env' rhs }
773 sc_vanilla scrut_usg scrut' -- Normal case
774 = do { let (alt_env,b') = extendBndrWith RecArg env b
775 -- Record RecArg for the components
777 ; (alt_usgs, alt_occs, alts')
778 <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts
780 ; let (alt_usg, b_occ) = lookupOcc (combineUsages alt_usgs) b'
781 scrut_occ = foldr combineOcc b_occ alt_occs
782 scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ
783 -- The combined usage of the scrutinee is given
784 -- by scrut_occ, which is passed to scScrut, which
785 -- in turn treats a bare-variable scrutinee specially
787 ; return (alt_usg `combineUsage` scrut_usg',
788 Case scrut' b' (scSubstTy env ty) alts') }
790 sc_alt env scrut' b' (con,bs,rhs)
791 = do { let (env1, bs') = extendBndrsWith RecArg env bs
792 env2 = extendCaseBndrs env1 scrut' b' con bs'
793 ; (usg,rhs') <- scExpr env2 rhs
794 ; let (usg', arg_occs) = lookupOccs usg bs'
795 scrut_occ = case con of
796 DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)
797 _ -> ScrutOcc emptyUFM
798 ; return (usg', scrut_occ, (con,bs',rhs')) }
800 scExpr' env (Let (NonRec bndr rhs) body)
801 | isTyVar bndr -- Type-lets may be created by doBeta
802 = scExpr' (extendScSubst env bndr rhs) body
804 = do { let (body_env, bndr') = extendBndr env bndr
805 ; (rhs_usg, (_, args', rhs_body', _)) <- scRecRhs env (bndr',rhs)
806 ; let rhs' = mkLams args' rhs_body'
808 ; if not opt_SpecInlineJoinPoints || null args' || isEmptyVarEnv (scu_calls rhs_usg) then do
810 let body_env2 = extendValEnv body_env bndr' (isValue (sc_vals env) rhs')
811 -- Record if the RHS is a value
812 ; (body_usg, body') <- scExpr body_env2 body
813 ; return (body_usg `combineUsage` rhs_usg, Let (NonRec bndr' rhs') body') }
814 else -- For now, just brutally inline the join point
815 do { let body_env2 = extendScSubst env bndr rhs'
816 ; scExpr body_env2 body } }
820 do { -- Join-point case
821 let body_env2 = extendHowBound body_env [bndr'] RecFun
822 -- If the RHS of this 'let' contains calls
823 -- to recursive functions that we're trying
824 -- to specialise, then treat this let too
825 -- as one to specialise
826 ; (body_usg, body') <- scExpr body_env2 body
828 ; (spec_usg, _, specs) <- specialise env (scu_calls body_usg) ([], rhs_info)
830 ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' }
831 `combineUsage` rhs_usg `combineUsage` spec_usg,
832 mkLets [NonRec b r | (b,r) <- specInfoBinds rhs_info specs] body')
836 -- A *local* recursive group: see Note [Local recursive groups]
837 scExpr' env (Let (Rec prs) body)
838 = do { let (bndrs,rhss) = unzip prs
839 (rhs_env1,bndrs') = extendRecBndrs env bndrs
840 rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
842 ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
843 ; (body_usg, body') <- scExpr rhs_env2 body
845 -- NB: start specLoop from body_usg
846 ; (spec_usg, specs) <- specLoop rhs_env2 (scu_calls body_usg) rhs_infos nullUsage
847 [SI [] 0 (Just usg) | usg <- rhs_usgs]
849 ; let all_usg = spec_usg `combineUsage` body_usg
850 bind' = Rec (concat (zipWith specInfoBinds rhs_infos specs))
852 ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' },
855 -----------------------------------
856 scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)
858 scApp env (Var fn, args) -- Function is a variable
859 = ASSERT( not (null args) )
860 do { args_w_usgs <- mapM (scExpr env) args
861 ; let (arg_usgs, args') = unzip args_w_usgs
862 arg_usg = combineUsages arg_usgs
863 ; case scSubstId env fn of
864 fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args')
865 -- Do beta-reduction and try again
867 Var fn' -> return (arg_usg `combineUsage` fn_usg, mkApps (Var fn') args')
869 fn_usg = case lookupHowBound env fn' of
870 Just RecFun -> SCU { scu_calls = unitVarEnv fn' [(sc_vals env, args')],
871 scu_occs = emptyVarEnv }
872 Just RecArg -> SCU { scu_calls = emptyVarEnv,
873 scu_occs = unitVarEnv fn' (ScrutOcc emptyUFM) }
877 other_fn' -> return (arg_usg, mkApps other_fn' args') }
878 -- NB: doing this ignores any usage info from the substituted
879 -- function, but I don't think that matters. If it does
882 doBeta :: OutExpr -> [OutExpr] -> OutExpr
883 -- ToDo: adjust for System IF
884 doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args)
885 doBeta fn args = mkApps fn args
887 -- The function is almost always a variable, but not always.
888 -- In particular, if this pass follows float-in,
889 -- which it may, we can get
890 -- (let f = ...f... in f) arg1 arg2
891 scApp env (other_fn, args)
892 = do { (fn_usg, fn') <- scExpr env other_fn
893 ; (arg_usgs, args') <- mapAndUnzipM (scExpr env) args
894 ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') }
896 ----------------------
897 scTopBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind)
898 scTopBind env (Rec prs)
899 | Just threshold <- sc_size env
900 , not (all (couldBeSmallEnoughToInline threshold) rhss)
902 = do { let (rhs_env,bndrs') = extendRecBndrs env bndrs
903 ; (_, rhss') <- mapAndUnzipM (scExpr rhs_env) rhss
904 ; return (rhs_env, Rec (bndrs' `zip` rhss')) }
905 | otherwise -- Do specialisation
906 = do { let (rhs_env1,bndrs') = extendRecBndrs env bndrs
907 rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
909 ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
910 ; let rhs_usg = combineUsages rhs_usgs
912 ; (_, specs) <- specLoop rhs_env2 (scu_calls rhs_usg) rhs_infos nullUsage
913 [SI [] 0 Nothing | _ <- bndrs]
915 ; return (rhs_env1, -- For the body of the letrec, delete the RecFun business
916 Rec (concat (zipWith specInfoBinds rhs_infos specs))) }
918 (bndrs,rhss) = unzip prs
920 scTopBind env (NonRec bndr rhs)
921 = do { (_, rhs') <- scExpr env rhs
922 ; let (env1, bndr') = extendBndr env bndr
923 env2 = extendValEnv env1 bndr' (isValue (sc_vals env) rhs')
924 ; return (env2, NonRec bndr' rhs') }
926 ----------------------
927 scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM (ScUsage, RhsInfo)
928 scRecRhs env (bndr,rhs)
929 = do { let (arg_bndrs,body) = collectBinders rhs
930 (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs
931 ; (body_usg, body') <- scExpr body_env body
932 ; let (rhs_usg, arg_occs) = lookupOccs body_usg arg_bndrs'
933 ; return (rhs_usg, (bndr, arg_bndrs', body', arg_occs)) }
935 -- The arg_occs says how the visible,
936 -- lambda-bound binders of the RHS are used
937 -- (including the TyVar binders)
938 -- Two pats are the same if they match both ways
940 ----------------------
941 specInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)]
942 specInfoBinds (fn, args, body, _) (SI specs _ _)
943 = [(id,rhs) | OS _ _ id rhs <- specs] ++
944 [(fn `addIdSpecialisations` rules, mkLams args body)]
946 rules = [r | OS _ r _ _ <- specs]
948 ----------------------
949 varUsage :: ScEnv -> OutVar -> ArgOcc -> ScUsage
951 | Just RecArg <- lookupHowBound env v = SCU { scu_calls = emptyVarEnv
952 , scu_occs = unitVarEnv v use }
953 | otherwise = nullUsage
957 %************************************************************************
959 The specialiser itself
961 %************************************************************************
964 type RhsInfo = (OutId, [OutVar], OutExpr, [ArgOcc])
965 -- Info about the *original* RHS of a binding we are specialising
966 -- Original binding f = \xs.body
967 -- Plus info about usage of arguments
969 data SpecInfo = SI [OneSpec] -- The specialisations we have generated
970 Int -- Length of specs; used for numbering them
971 (Maybe ScUsage) -- Nothing => we have generated specialisations
972 -- from calls in the *original* RHS
973 -- Just cs => we haven't, and this is the usage
974 -- of the original RHS
976 -- One specialisation: Rule plus definition
977 data OneSpec = OS CallPat -- Call pattern that generated this specialisation
978 CoreRule -- Rule connecting original id with the specialisation
979 OutId OutExpr -- Spec id + its rhs
985 -> ScUsage -> [SpecInfo] -- One per binder; acccumulating parameter
986 -> UniqSM (ScUsage, [SpecInfo]) -- ...ditto...
987 specLoop env all_calls rhs_infos usg_so_far specs_so_far
988 = do { specs_w_usg <- zipWithM (specialise env all_calls) rhs_infos specs_so_far
989 ; let (new_usg_s, all_specs) = unzip specs_w_usg
990 new_usg = combineUsages new_usg_s
991 new_calls = scu_calls new_usg
992 all_usg = usg_so_far `combineUsage` new_usg
993 ; if isEmptyVarEnv new_calls then
994 return (all_usg, all_specs)
996 specLoop env new_calls rhs_infos all_usg all_specs }
1000 -> CallEnv -- Info on calls
1002 -> SpecInfo -- Original RHS plus patterns dealt with
1003 -> UniqSM (ScUsage, SpecInfo) -- New specialised versions and their usage
1005 -- Note: the rhs here is the optimised version of the original rhs
1006 -- So when we make a specialised copy of the RHS, we're starting
1007 -- from an RHS whose nested functions have been optimised already.
1009 specialise env bind_calls (fn, arg_bndrs, body, arg_occs)
1010 spec_info@(SI specs spec_count mb_unspec)
1011 | notNull arg_bndrs, -- Only specialise functions
1012 Just all_calls <- lookupVarEnv bind_calls fn
1013 = do { (boring_call, pats) <- callsToPats env specs arg_occs all_calls
1014 -- ; pprTrace "specialise" (vcat [ppr fn <+> ppr arg_occs,
1015 -- text "calls" <+> ppr all_calls,
1016 -- text "good pats" <+> ppr pats]) $
1019 -- Bale out if too many specialisations
1020 -- Rather a hacky way to do so, but it'll do for now
1021 ; let spec_count' = length pats + spec_count
1022 ; case sc_count env of
1023 Just max | spec_count' > max
1024 -> pprTrace "SpecConstr: too many specialisations for one function (see -fspec-constr-count):"
1025 (vcat [ptext (sLit "Function:") <+> ppr fn,
1026 ptext (sLit "Specialisations:") <+> ppr (pats ++ [p | OS p _ _ _ <- specs])])
1027 return (nullUsage, spec_info)
1029 _normal_case -> do {
1031 (spec_usgs, new_specs) <- mapAndUnzipM (spec_one env fn arg_bndrs body)
1032 (pats `zip` [spec_count..])
1034 ; let spec_usg = combineUsages spec_usgs
1035 (new_usg, mb_unspec')
1037 Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing)
1038 _ -> (spec_usg, mb_unspec)
1040 ; return (new_usg, SI (new_specs ++ specs) spec_count' mb_unspec') } }
1042 = return (nullUsage, spec_info) -- The boring case
1045 ---------------------
1047 -> OutId -- Function
1048 -> [Var] -- Lambda-binders of RHS; should match patterns
1049 -> CoreExpr -- Body of the original function
1051 -> UniqSM (ScUsage, OneSpec) -- Rule and binding
1053 -- spec_one creates a specialised copy of the function, together
1054 -- with a rule for using it. I'm very proud of how short this
1055 -- function is, considering what it does :-).
1061 f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
1062 [c::*, v::(b,c) are presumably bound by the (...) part]
1064 f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
1065 (...entire body of f...) [b -> (b,c),
1066 y -> ((:) (a,(b,c)) (x,v) hw)]
1068 RULE: forall b::* c::*, -- Note, *not* forall a, x
1072 f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
1075 spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)
1076 = do { -- Specialise the body
1077 let spec_env = extendScSubstList (extendScInScope env qvars)
1078 (arg_bndrs `zip` pats)
1079 ; (spec_usg, spec_body) <- scExpr spec_env body
1081 -- ; pprTrace "spec_one" (ppr fn <+> vcat [text "pats" <+> ppr pats,
1082 -- text "calls" <+> (ppr (scu_calls spec_usg))])
1085 -- And build the results
1086 ; spec_uniq <- getUniqueUs
1087 ; let (spec_lam_args, spec_call_args) = mkWorkerArgs qvars body_ty
1088 -- Usual w/w hack to avoid generating
1089 -- a spec_rhs of unlifted type and no args
1092 fn_loc = nameSrcSpan fn_name
1093 spec_occ = mkSpecOcc (nameOccName fn_name)
1094 rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number))
1095 spec_rhs = mkLams spec_lam_args spec_body
1096 spec_id = mkUserLocal spec_occ spec_uniq (mkPiTypes spec_lam_args body_ty) fn_loc
1097 body_ty = exprType spec_body
1098 rule_rhs = mkVarApps (Var spec_id) spec_call_args
1099 rule = mkLocalRule rule_name specConstrActivation fn_name qvars pats rule_rhs
1100 ; return (spec_usg, OS call_pat rule spec_id spec_rhs) }
1102 -- In which phase should the specialise-constructor rules be active?
1103 -- Originally I made them always-active, but Manuel found that
1104 -- this defeated some clever user-written rules. So Plan B
1105 -- is to make them active only in Phase 0; after all, currently,
1106 -- the specConstr transformation is only run after the simplifier
1107 -- has reached Phase 0. In general one would want it to be
1108 -- flag-controllable, but for now I'm leaving it baked in
1110 specConstrActivation :: Activation
1111 specConstrActivation = ActiveAfter 0 -- Baked in; see comments above
1114 %************************************************************************
1116 \subsection{Argument analysis}
1118 %************************************************************************
1120 This code deals with analysing call-site arguments to see whether
1121 they are constructor applications.
1125 type CallPat = ([Var], [CoreExpr]) -- Quantified variables and arguments
1128 callsToPats :: ScEnv -> [OneSpec] -> [ArgOcc] -> [Call] -> UniqSM (Bool, [CallPat])
1129 -- Result has no duplicate patterns,
1130 -- nor ones mentioned in done_pats
1131 -- Bool indicates that there was at least one boring pattern
1132 callsToPats env done_specs bndr_occs calls
1133 = do { mb_pats <- mapM (callToPats env bndr_occs) calls
1135 ; let good_pats :: [([Var], [CoreArg])]
1136 good_pats = catMaybes mb_pats
1137 done_pats = [p | OS p _ _ _ <- done_specs]
1138 is_done p = any (samePat p) done_pats
1140 ; return (any isNothing mb_pats,
1141 filterOut is_done (nubBy samePat good_pats)) }
1143 callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
1144 -- The [Var] is the variables to quantify over in the rule
1145 -- Type variables come first, since they may scope
1146 -- over the following term variables
1147 -- The [CoreExpr] are the argument patterns for the rule
1148 callToPats env bndr_occs (con_env, args)
1149 | length args < length bndr_occs -- Check saturated
1152 = do { let in_scope = substInScope (sc_subst env)
1153 ; prs <- argsToPats in_scope con_env (args `zip` bndr_occs)
1154 ; let (interesting_s, pats) = unzip prs
1155 pat_fvs = varSetElems (exprsFreeVars pats)
1156 qvars = filterOut (`elemInScopeSet` in_scope) pat_fvs
1157 -- Quantify over variables that are not in sccpe
1159 -- See Note [Shadowing] at the top
1161 (tvs, ids) = partition isTyVar qvars
1163 -- Put the type variables first; the type of a term
1164 -- variable may mention a type variable
1166 ; -- pprTrace "callToPats" (ppr args $$ ppr prs $$ ppr bndr_occs) $
1168 then return (Just (qvars', pats))
1169 else return Nothing }
1171 -- argToPat takes an actual argument, and returns an abstracted
1172 -- version, consisting of just the "constructor skeleton" of the
1173 -- argument, with non-constructor sub-expression replaced by new
1174 -- placeholder variables. For example:
1175 -- C a (D (f x) (g y)) ==> C p1 (D p2 p3)
1177 argToPat :: InScopeSet -- What's in scope at the fn defn site
1178 -> ValueEnv -- ValueEnv at the call site
1179 -> CoreArg -- A call arg (or component thereof)
1181 -> UniqSM (Bool, CoreArg)
1182 -- Returns (interesting, pat),
1183 -- where pat is the pattern derived from the argument
1184 -- intersting=True if the pattern is non-trivial (not a variable or type)
1185 -- E.g. x:xs --> (True, x:xs)
1186 -- f xs --> (False, w) where w is a fresh wildcard
1187 -- (f xs, 'c') --> (True, (w, 'c')) where w is a fresh wildcard
1188 -- \x. x+y --> (True, \x. x+y)
1189 -- lvl7 --> (True, lvl7) if lvl7 is bound
1190 -- somewhere further out
1192 argToPat _in_scope _val_env arg@(Type {}) _arg_occ
1193 = return (False, arg)
1195 argToPat in_scope val_env (Note _ arg) arg_occ
1196 = argToPat in_scope val_env arg arg_occ
1197 -- Note [Notes in call patterns]
1198 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1199 -- Ignore Notes. In particular, we want to ignore any InlineMe notes
1200 -- Perhaps we should not ignore profiling notes, but I'm going to
1201 -- ride roughshod over them all for now.
1202 --- See Note [Notes in RULE matching] in Rules
1204 argToPat in_scope val_env (Let _ arg) arg_occ
1205 = argToPat in_scope val_env arg arg_occ
1206 -- Look through let expressions
1207 -- e.g. f (let v = rhs in \y -> ...v...)
1208 -- Here we can specialise for f (\y -> ...)
1209 -- because the rule-matcher will look through the let.
1211 argToPat in_scope val_env (Cast arg co) arg_occ
1212 = do { (interesting, arg') <- argToPat in_scope val_env arg arg_occ
1213 ; let (ty1,ty2) = coercionKind co
1214 ; if not interesting then
1217 { -- Make a wild-card pattern for the coercion
1219 ; let co_name = mkSysTvName uniq (fsLit "sg")
1220 co_var = mkCoVar co_name (mkCoKind ty1 ty2)
1221 ; return (interesting, Cast arg' (mkTyVarTy co_var)) } }
1223 {- Disabling lambda specialisation for now
1224 It's fragile, and the spec_loop can be infinite
1225 argToPat in_scope val_env arg arg_occ
1227 = return (True, arg)
1229 is_value_lam (Lam v e) -- Spot a value lambda, even if
1230 | isId v = True -- it is inside a type lambda
1231 | otherwise = is_value_lam e
1232 is_value_lam other = False
1235 -- Check for a constructor application
1236 -- NB: this *precedes* the Var case, so that we catch nullary constrs
1237 argToPat in_scope val_env arg arg_occ
1238 | Just (ConVal dc args) <- isValue val_env arg
1240 ScrutOcc _ -> True -- Used only by case scrutinee
1241 BothOcc -> case arg of -- Used elsewhere
1242 App {} -> True -- see Note [Reboxing]
1244 _other -> False -- No point; the arg is not decomposed
1245 = do { args' <- argsToPats in_scope val_env (args `zip` conArgOccs arg_occ dc)
1246 ; return (True, mk_con_app dc (map snd args')) }
1248 -- Check if the argument is a variable that
1249 -- is in scope at the function definition site
1250 -- It's worth specialising on this if
1251 -- (a) it's used in an interesting way in the body
1252 -- (b) we know what its value is
1253 argToPat in_scope val_env (Var v) arg_occ
1254 | case arg_occ of { UnkOcc -> False; _other -> True }, -- (a)
1256 = return (True, Var v)
1259 | isLocalId v = v `elemInScopeSet` in_scope
1260 && isJust (lookupVarEnv val_env v)
1261 -- Local variables have values in val_env
1262 | otherwise = isValueUnfolding (idUnfolding v)
1263 -- Imports have unfoldings
1265 -- I'm really not sure what this comment means
1266 -- And by not wild-carding we tend to get forall'd
1267 -- variables that are in soope, which in turn can
1268 -- expose the weakness in let-matching
1269 -- See Note [Matching lets] in Rules
1271 -- Check for a variable bound inside the function.
1272 -- Don't make a wild-card, because we may usefully share
1273 -- e.g. f a = let x = ... in f (x,x)
1274 -- NB: this case follows the lambda and con-app cases!!
1275 -- argToPat _in_scope _val_env (Var v) _arg_occ
1276 -- = return (False, Var v)
1277 -- SLPJ : disabling this to avoid proliferation of versions
1278 -- also works badly when thinking about seeding the loop
1279 -- from the body of the let
1280 -- f x y = letrec g z = ... in g (x,y)
1281 -- We don't want to specialise for that *particular* x,y
1283 -- The default case: make a wild-card
1284 argToPat _in_scope _val_env arg _arg_occ
1285 = wildCardPat (exprType arg)
1287 wildCardPat :: Type -> UniqSM (Bool, CoreArg)
1288 wildCardPat ty = do { uniq <- getUniqueUs
1289 ; let id = mkSysLocal (fsLit "sc") uniq ty
1290 ; return (False, Var id) }
1292 argsToPats :: InScopeSet -> ValueEnv
1293 -> [(CoreArg, ArgOcc)]
1294 -> UniqSM [(Bool, CoreArg)]
1295 argsToPats in_scope val_env args
1298 do_one (arg,occ) = argToPat in_scope val_env arg occ
1303 isValue :: ValueEnv -> CoreExpr -> Maybe Value
1304 isValue _env (Lit lit)
1305 = Just (ConVal (LitAlt lit) [])
1308 | Just stuff <- lookupVarEnv env v
1309 = Just stuff -- You might think we could look in the idUnfolding here
1310 -- but that doesn't take account of which branch of a
1311 -- case we are in, which is the whole point
1313 | not (isLocalId v) && isCheapUnfolding unf
1314 = isValue env (unfoldingTemplate unf)
1317 -- However we do want to consult the unfolding
1318 -- as well, for let-bound constructors!
1320 isValue env (Lam b e)
1321 | isTyVar b = case isValue env e of
1322 Just _ -> Just LambdaVal
1324 | otherwise = Just LambdaVal
1326 isValue _env expr -- Maybe it's a constructor application
1327 | (Var fun, args) <- collectArgs expr
1328 = case isDataConWorkId_maybe fun of
1330 Just con | args `lengthAtLeast` dataConRepArity con
1331 -- Check saturated; might be > because the
1332 -- arity excludes type args
1333 -> Just (ConVal (DataAlt con) args)
1335 _other | valArgCount args < idArity fun
1336 -- Under-applied function
1337 -> Just LambdaVal -- Partial application
1341 isValue _env _expr = Nothing
1343 mk_con_app :: AltCon -> [CoreArg] -> CoreExpr
1344 mk_con_app (LitAlt lit) [] = Lit lit
1345 mk_con_app (DataAlt con) args = mkConApp con args
1346 mk_con_app _other _args = panic "SpecConstr.mk_con_app"
1348 samePat :: CallPat -> CallPat -> Bool
1349 samePat (vs1, as1) (vs2, as2)
1352 same (Var v1) (Var v2)
1353 | v1 `elem` vs1 = v2 `elem` vs2
1354 | v2 `elem` vs2 = False
1355 | otherwise = v1 == v2
1357 same (Lit l1) (Lit l2) = l1==l2
1358 same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2
1360 same (Type {}) (Type {}) = True -- Note [Ignore type differences]
1361 same (Note _ e1) e2 = same e1 e2 -- Ignore casts and notes
1362 same (Cast e1 _) e2 = same e1 e2
1363 same e1 (Note _ e2) = same e1 e2
1364 same e1 (Cast e2 _) = same e1 e2
1366 same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2)
1367 False -- Let, lambda, case should not occur
1368 bad (Case {}) = True
1374 Note [Ignore type differences]
1375 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1376 We do not want to generate specialisations where the call patterns
1377 differ only in their type arguments! Not only is it utterly useless,
1378 but it also means that (with polymorphic recursion) we can generate
1379 an infinite number of specialisations. Example is Data.Sequence.adjustTree,