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 import Data.Data ( Data, Typeable )
59 -----------------------------------------------------
61 -----------------------------------------------------
66 drop n (x:xs) = drop (n-1) xs
68 After the first time round, we could pass n unboxed. This happens in
69 numerical code too. Here's what it looks like in Core:
71 drop n xs = case xs of
76 _ -> drop (I# (n# -# 1#)) xs
78 Notice that the recursive call has an explicit constructor as argument.
79 Noticing this, we can make a specialised version of drop
81 RULE: drop (I# n#) xs ==> drop' n# xs
83 drop' n# xs = let n = I# n# in ...orig RHS...
85 Now the simplifier will apply the specialisation in the rhs of drop', giving
87 drop' n# xs = case xs of
91 _ -> drop (n# -# 1#) xs
95 We'd also like to catch cases where a parameter is carried along unchanged,
96 but evaluated each time round the loop:
98 f i n = if i>0 || i>n then i else f (i*2) n
100 Here f isn't strict in n, but we'd like to avoid evaluating it each iteration.
101 In Core, by the time we've w/wd (f is strict in i) we get
103 f i# n = case i# ># 0 of
105 True -> case n of n' { I# n# ->
108 True -> f (i# *# 2#) n'
110 At the call to f, we see that the argument, n is know to be (I# n#),
111 and n is evaluated elsewhere in the body of f, so we can play the same
117 We must be careful not to allocate the same constructor twice. Consider
118 f p = (...(case p of (a,b) -> e)...p...,
119 ...let t = (r,s) in ...t...(f t)...)
120 At the recursive call to f, we can see that t is a pair. But we do NOT want
121 to make a specialised copy:
122 f' a b = let p = (a,b) in (..., ...)
123 because now t is allocated by the caller, then r and s are passed to the
124 recursive call, which allocates the (r,s) pair again.
127 (a) the argument p is used in other than a case-scrutinsation way.
128 (b) the argument to the call is not a 'fresh' tuple; you have to
129 look into its unfolding to see that it's a tuple
131 Hence the "OR" part of Note [Good arguments] below.
133 ALTERNATIVE 2: pass both boxed and unboxed versions. This no longer saves
134 allocation, but does perhaps save evals. In the RULE we'd have
137 f (I# x#) = f' (I# x#) x#
139 If at the call site the (I# x) was an unfolding, then we'd have to
140 rely on CSE to eliminate the duplicate allocation.... This alternative
141 doesn't look attractive enough to pursue.
143 ALTERNATIVE 3: ignore the reboxing problem. The trouble is that
144 the conservative reboxing story prevents many useful functions from being
145 specialised. Example:
146 foo :: Maybe Int -> Int -> Int
148 foo x@(Just m) n = foo x (n-m)
149 Here the use of 'x' will clearly not require boxing in the specialised function.
151 The strictness analyser has the same problem, in fact. Example:
153 If we pass just 'a' and 'b' to the worker, it might need to rebox the
154 pair to create (a,b). A more sophisticated analysis might figure out
155 precisely the cases in which this could happen, but the strictness
156 analyser does no such analysis; it just passes 'a' and 'b', and hopes
159 So my current choice is to make SpecConstr similarly aggressive, and
160 ignore the bad potential of reboxing.
163 Note [Good arguments]
164 ~~~~~~~~~~~~~~~~~~~~~
167 * A self-recursive function. Ignore mutual recursion for now,
168 because it's less common, and the code is simpler for self-recursion.
172 a) At a recursive call, one or more parameters is an explicit
173 constructor application
175 That same parameter is scrutinised by a case somewhere in
176 the RHS of the function
180 b) At a recursive call, one or more parameters has an unfolding
181 that is an explicit constructor application
183 That same parameter is scrutinised by a case somewhere in
184 the RHS of the function
186 Those are the only uses of the parameter (see Note [Reboxing])
189 What to abstract over
190 ~~~~~~~~~~~~~~~~~~~~~
191 There's a bit of a complication with type arguments. If the call
194 f p = ...f ((:) [a] x xs)...
196 then our specialised function look like
198 f_spec x xs = let p = (:) [a] x xs in ....as before....
200 This only makes sense if either
201 a) the type variable 'a' is in scope at the top of f, or
202 b) the type variable 'a' is an argument to f (and hence fs)
204 Actually, (a) may hold for value arguments too, in which case
205 we may not want to pass them. Supose 'x' is in scope at f's
206 defn, but xs is not. Then we'd like
208 f_spec xs = let p = (:) [a] x xs in ....as before....
210 Similarly (b) may hold too. If x is already an argument at the
211 call, no need to pass it again.
213 Finally, if 'a' is not in scope at the call site, we could abstract
214 it as we do the term variables:
216 f_spec a x xs = let p = (:) [a] x xs in ...as before...
218 So the grand plan is:
220 * abstract the call site to a constructor-only pattern
221 e.g. C x (D (f p) (g q)) ==> C s1 (D s2 s3)
223 * Find the free variables of the abstracted pattern
225 * Pass these variables, less any that are in scope at
226 the fn defn. But see Note [Shadowing] below.
229 NOTICE that we only abstract over variables that are not in scope,
230 so we're in no danger of shadowing variables used in "higher up"
236 In this pass we gather up usage information that may mention variables
237 that are bound between the usage site and the definition site; or (more
238 seriously) may be bound to something different at the definition site.
241 f x = letrec g y v = let x = ...
244 Since 'x' is in scope at the call site, we may make a rewrite rule that
246 RULE forall a,b. g (a,b) x = ...
247 But this rule will never match, because it's really a different 'x' at
248 the call site -- and that difference will be manifest by the time the
249 simplifier gets to it. [A worry: the simplifier doesn't *guarantee*
250 no-shadowing, so perhaps it may not be distinct?]
252 Anyway, the rule isn't actually wrong, it's just not useful. One possibility
253 is to run deShadowBinds before running SpecConstr, but instead we run the
254 simplifier. That gives the simplest possible program for SpecConstr to
255 chew on; and it virtually guarantees no shadowing.
257 Note [Specialising for constant parameters]
258 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
259 This one is about specialising on a *constant* (but not necessarily
260 constructor) argument
262 foo :: Int -> (Int -> Int) -> Int
264 foo m f = foo (f m) (+1)
268 lvl_rmV :: GHC.Base.Int -> GHC.Base.Int
270 \ (ds_dlk :: GHC.Base.Int) ->
271 case ds_dlk of wild_alH { GHC.Base.I# x_alG ->
272 GHC.Base.I# (GHC.Prim.+# x_alG 1)
274 T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
277 \ (ww_sme :: GHC.Prim.Int#) (w_smg :: GHC.Base.Int -> GHC.Base.Int) ->
278 case ww_sme of ds_Xlw {
280 case w_smg (GHC.Base.I# ds_Xlw) of w1_Xmo { GHC.Base.I# ww1_Xmz ->
281 T.$wfoo ww1_Xmz lvl_rmV
286 The recursive call has lvl_rmV as its argument, so we could create a specialised copy
287 with that argument baked in; that is, not passed at all. Now it can perhaps be inlined.
289 When is this worth it? Call the constant 'lvl'
290 - If 'lvl' has an unfolding that is a constructor, see if the corresponding
291 parameter is scrutinised anywhere in the body.
293 - If 'lvl' has an unfolding that is a inlinable function, see if the corresponding
294 parameter is applied (...to enough arguments...?)
296 Also do this is if the function has RULES?
300 Note [Specialising for lambda parameters]
301 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
302 foo :: Int -> (Int -> Int) -> Int
304 foo m f = foo (f m) (\n -> n-m)
306 This is subtly different from the previous one in that we get an
307 explicit lambda as the argument:
309 T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
312 \ (ww_sm8 :: GHC.Prim.Int#) (w_sma :: GHC.Base.Int -> GHC.Base.Int) ->
313 case ww_sm8 of ds_Xlr {
315 case w_sma (GHC.Base.I# ds_Xlr) of w1_Xmf { GHC.Base.I# ww1_Xmq ->
318 (\ (n_ad3 :: GHC.Base.Int) ->
319 case n_ad3 of wild_alB { GHC.Base.I# x_alA ->
320 GHC.Base.I# (GHC.Prim.-# x_alA ds_Xlr)
326 I wonder if SpecConstr couldn't be extended to handle this? After all,
327 lambda is a sort of constructor for functions and perhaps it already
328 has most of the necessary machinery?
330 Furthermore, there's an immediate win, because you don't need to allocate the lamda
331 at the call site; and if perchance it's called in the recursive call, then you
332 may avoid allocating it altogether. Just like for constructors.
334 Looks cool, but probably rare...but it might be easy to implement.
337 Note [SpecConstr for casts]
338 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
341 data instance T Int = T Int
346 go (T n) = go (T (n-1))
348 The recursive call ends up looking like
349 go (T (I# ...) `cast` g)
350 So we want to spot the construtor application inside the cast.
351 That's why we have the Cast case in argToPat
353 Note [Local recursive groups]
354 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
355 For a *local* recursive group, we can see all the calls to the
356 function, so we seed the specialisation loop from the calls in the
357 body, not from the calls in the RHS. Consider:
359 bar m n = foo n (n,n) (n,n) (n,n) (n,n)
363 | n > 3000 = case p of { (p1,p2) -> foo (n-1) (p2,p1) q r s }
364 | n > 2000 = case q of { (q1,q2) -> foo (n-1) p (q2,q1) r s }
365 | n > 1000 = case r of { (r1,r2) -> foo (n-1) p q (r2,r1) s }
366 | otherwise = case s of { (s1,s2) -> foo (n-1) p q r (s2,s1) }
368 If we start with the RHSs of 'foo', we get lots and lots of specialisations,
369 most of which are not needed. But if we start with the (single) call
370 in the rhs of 'bar' we get exactly one fully-specialised copy, and all
371 the recursive calls go to this fully-specialised copy. Indeed, the original
372 function is later collected as dead code. This is very important in
373 specialising the loops arising from stream fusion, for example in NDP where
374 we were getting literally hundreds of (mostly unused) specialisations of
377 Note [Do not specialise diverging functions]
378 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
379 Specialising a function that just diverges is a waste of code.
380 Furthermore, it broke GHC (simpl014) thus:
382 f = \x. case x of (a,b) -> f x
383 If we specialise f we get
384 f = \x. case x of (a,b) -> fspec a b
385 But fspec doesn't have decent strictnes info. As it happened,
386 (f x) :: IO t, so the state hack applied and we eta expanded fspec,
387 and hence f. But now f's strictness is less than its arity, which
390 -----------------------------------------------------
391 Stuff not yet handled
392 -----------------------------------------------------
394 Here are notes arising from Roman's work that I don't want to lose.
400 foo :: Int -> T Int -> Int
402 foo x t | even x = case t of { T n -> foo (x-n) t }
403 | otherwise = foo (x-1) t
405 SpecConstr does no specialisation, because the second recursive call
406 looks like a boxed use of the argument. A pity.
408 $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
410 \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) ->
411 case ww_sFo of ds_Xw6 [Just L] {
413 case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] {
414 __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq;
416 case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] ->
417 case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] ->
418 $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy
424 data a :*: b = !a :*: !b
427 foo :: (Int :*: T Int) -> Int
429 foo (x :*: t) | even x = case t of { T n -> foo ((x-n) :*: t) }
430 | otherwise = foo ((x-1) :*: t)
432 Very similar to the previous one, except that the parameters are now in
433 a strict tuple. Before SpecConstr, we have
435 $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
437 \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T
439 case ww_sFU of ds_Xws [Just L] {
441 case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] {
443 case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] ->
444 $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2 -- $wfoo1
447 case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] ->
448 case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] ->
449 $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB -- $wfoo2
453 We get two specialisations:
454 "SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#}
455 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB)
456 = Foo.$s$wfoo1 a_sFB sc_sGC ;
457 "SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#}
458 Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp))
459 = Foo.$s$wfoo y_aFp sc_sGC ;
461 But perhaps the first one isn't good. After all, we know that tpl_B2 is
462 a T (I# x) really, because T is strict and Int has one constructor. (We can't
463 unbox the strict fields, becuase T is polymorphic!)
465 %************************************************************************
467 \subsection{Annotations}
469 %************************************************************************
471 Annotating a type with NoSpecConstr will make SpecConstr not specialise
472 for arguments of that type.
475 data SpecConstrAnnotation = NoSpecConstr deriving( Data, Typeable )
478 %************************************************************************
480 \subsection{Top level wrapper stuff}
482 %************************************************************************
485 specConstrProgram :: ModGuts -> CoreM ModGuts
486 specConstrProgram guts
488 dflags <- getDynFlags
489 us <- getUniqueSupplyM
490 annos <- deserializeAnnotations deserializeWithData
491 let binds' = fst $ initUs us (go (initScEnv dflags annos) (mg_binds guts))
492 return (guts { mg_binds = binds' })
495 go env (bind:binds) = do (env', bind') <- scTopBind env bind
496 binds' <- go env' binds
497 return (bind' : binds')
501 %************************************************************************
503 \subsection{Environment: goes downwards}
505 %************************************************************************
508 data ScEnv = SCE { sc_size :: Maybe Int, -- Size threshold
509 sc_count :: Maybe Int, -- Max # of specialisations for any one fn
511 sc_subst :: Subst, -- Current substitution
512 -- Maps InIds to OutExprs
514 sc_how_bound :: HowBoundEnv,
515 -- Binds interesting non-top-level variables
516 -- Domain is OutVars (*after* applying the substitution)
519 -- Domain is OutIds (*after* applying the substitution)
520 -- Used even for top-level bindings (but not imported ones)
522 sc_annotations :: L.UniqFM SpecConstrAnnotation
525 ---------------------
526 -- As we go, we apply a substitution (sc_subst) to the current term
527 type InExpr = CoreExpr -- _Before_ applying the subst
529 type OutExpr = CoreExpr -- _After_ applying the subst
533 ---------------------
534 type HowBoundEnv = VarEnv HowBound -- Domain is OutVars
536 ---------------------
537 type ValueEnv = IdEnv Value -- Domain is OutIds
538 data Value = ConVal AltCon [CoreArg] -- _Saturated_ constructors
539 | LambdaVal -- Inlinable lambdas or PAPs
541 instance Outputable Value where
542 ppr (ConVal con args) = ppr con <+> interpp'SP args
543 ppr LambdaVal = ptext (sLit "<Lambda>")
545 ---------------------
546 initScEnv :: DynFlags -> L.UniqFM [SpecConstrAnnotation] -> ScEnv
547 initScEnv dflags annos
548 = SCE { sc_size = specConstrThreshold dflags,
549 sc_count = specConstrCount dflags,
550 sc_subst = emptySubst,
551 sc_how_bound = emptyVarEnv,
552 sc_vals = emptyVarEnv,
553 sc_annotations = L.mapUFM head $ L.filterUFM (not . null) annos }
555 data HowBound = RecFun -- These are the recursive functions for which
556 -- we seek interesting call patterns
558 | RecArg -- These are those functions' arguments, or their sub-components;
559 -- we gather occurrence information for these
561 instance Outputable HowBound where
562 ppr RecFun = text "RecFun"
563 ppr RecArg = text "RecArg"
565 lookupHowBound :: ScEnv -> Id -> Maybe HowBound
566 lookupHowBound env id = lookupVarEnv (sc_how_bound env) id
568 scSubstId :: ScEnv -> Id -> CoreExpr
569 scSubstId env v = lookupIdSubst (sc_subst env) v
571 scSubstTy :: ScEnv -> Type -> Type
572 scSubstTy env ty = substTy (sc_subst env) ty
574 zapScSubst :: ScEnv -> ScEnv
575 zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) }
577 extendScInScope :: ScEnv -> [Var] -> ScEnv
578 -- Bring the quantified variables into scope
579 extendScInScope env qvars = env { sc_subst = extendInScopeList (sc_subst env) qvars }
581 -- Extend the substitution
582 extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv
583 extendScSubst env var expr = env { sc_subst = extendSubst (sc_subst env) var expr }
585 extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv
586 extendScSubstList env prs = env { sc_subst = extendSubstList (sc_subst env) prs }
588 extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv
589 extendHowBound env bndrs how_bound
590 = env { sc_how_bound = extendVarEnvList (sc_how_bound env)
591 [(bndr,how_bound) | bndr <- bndrs] }
593 extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var])
594 extendBndrsWith how_bound env bndrs
595 = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndrs')
597 (subst', bndrs') = substBndrs (sc_subst env) bndrs
598 hb_env' = sc_how_bound env `extendVarEnvList`
599 [(bndr,how_bound) | bndr <- bndrs']
601 extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var)
602 extendBndrWith how_bound env bndr
603 = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndr')
605 (subst', bndr') = substBndr (sc_subst env) bndr
606 hb_env' = extendVarEnv (sc_how_bound env) bndr' how_bound
608 extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var])
609 extendRecBndrs env bndrs = (env { sc_subst = subst' }, bndrs')
611 (subst', bndrs') = substRecBndrs (sc_subst env) bndrs
613 extendBndr :: ScEnv -> Var -> (ScEnv, Var)
614 extendBndr env bndr = (env { sc_subst = subst' }, bndr')
616 (subst', bndr') = substBndr (sc_subst env) bndr
618 extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv
619 extendValEnv env _ Nothing = env
620 extendValEnv env id (Just cv) = env { sc_vals = extendVarEnv (sc_vals env) id cv }
622 extendCaseBndrs :: ScEnv -> Id -> AltCon -> [Var] -> (ScEnv, [Var])
626 -- we want to bind b, to (C x y)
627 -- NB1: Extends only the sc_vals part of the envt
628 -- NB2: Kill the dead-ness info on the pattern binders x,y, since
629 -- they are potentially made alive by the [b -> C x y] binding
630 extendCaseBndrs env case_bndr con alt_bndrs
631 | isDeadBinder case_bndr
634 = (env1, map zap alt_bndrs)
635 -- NB: We used to bind v too, if scrut = (Var v); but
636 -- the simplifer has already done this so it seems
637 -- redundant to do so here
639 -- Var v -> extendValEnv env1 v cval
642 zap v | isTyVar v = v -- See NB2 above
643 | otherwise = zapIdOccInfo v
644 env1 = extendValEnv env case_bndr cval
647 LitAlt {} -> Just (ConVal con [])
648 DataAlt {} -> Just (ConVal con vanilla_args)
650 vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
651 varsToCoreExprs alt_bndrs
653 ignoreTyCon :: ScEnv -> TyCon -> Bool
654 ignoreTyCon env tycon
655 = case L.lookupUFM (sc_annotations env) tycon of
656 Just NoSpecConstr -> True
659 ignoreType :: ScEnv -> Type -> Bool
661 = case splitTyConApp_maybe ty of
662 Just (tycon, _) -> ignoreTyCon env tycon
665 ignoreAltCon :: ScEnv -> AltCon -> Bool
666 ignoreAltCon env (DataAlt dc) = ignoreTyCon env (dataConTyCon dc)
667 ignoreAltCon env (LitAlt lit) = ignoreType env (literalType lit)
668 ignoreAltCon _ DEFAULT = True
672 %************************************************************************
674 \subsection{Usage information: flows upwards}
676 %************************************************************************
681 scu_calls :: CallEnv, -- Calls
682 -- The functions are a subset of the
683 -- RecFuns in the ScEnv
685 scu_occs :: !(IdEnv ArgOcc) -- Information on argument occurrences
686 } -- The domain is OutIds
688 type CallEnv = IdEnv [Call]
689 type Call = (ValueEnv, [CoreArg])
690 -- The arguments of the call, together with the
691 -- env giving the constructor bindings at the call site
694 nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv }
696 combineCalls :: CallEnv -> CallEnv -> CallEnv
697 combineCalls = plusVarEnv_C (++)
699 combineUsage :: ScUsage -> ScUsage -> ScUsage
700 combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2),
701 scu_occs = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) }
703 combineUsages :: [ScUsage] -> ScUsage
704 combineUsages [] = nullUsage
705 combineUsages us = foldr1 combineUsage us
707 lookupOcc :: ScUsage -> OutVar -> (ScUsage, ArgOcc)
708 lookupOcc (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndr
709 = (SCU {scu_calls = sc_calls, scu_occs = delVarEnv sc_occs bndr},
710 lookupVarEnv sc_occs bndr `orElse` NoOcc)
712 lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc])
713 lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs
714 = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs},
715 [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs])
717 data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument
718 | UnkOcc -- Used in some unknown way
720 | ScrutOcc (UniqFM [ArgOcc]) -- See Note [ScrutOcc]
722 | BothOcc -- Definitely taken apart, *and* perhaps used in some other way
726 An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing,
727 is *only* taken apart or applied.
729 Functions, literal: ScrutOcc emptyUFM
730 Data constructors: ScrutOcc subs,
732 where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components,
733 The domain of the UniqFM is the Unique of the data constructor
735 The [ArgOcc] is the occurrences of the *pattern-bound* components
736 of the data structure. E.g.
737 data T a = forall b. MkT a b (b->a)
738 A pattern binds b, x::a, y::b, z::b->a, but not 'a'!
742 instance Outputable ArgOcc where
743 ppr (ScrutOcc xs) = ptext (sLit "scrut-occ") <> ppr xs
744 ppr UnkOcc = ptext (sLit "unk-occ")
745 ppr BothOcc = ptext (sLit "both-occ")
746 ppr NoOcc = ptext (sLit "no-occ")
748 -- Experimentally, this vesion of combineOcc makes ScrutOcc "win", so
749 -- that if the thing is scrutinised anywhere then we get to see that
750 -- in the overall result, even if it's also used in a boxed way
751 -- This might be too agressive; see Note [Reboxing] Alternative 3
752 combineOcc :: ArgOcc -> ArgOcc -> ArgOcc
753 combineOcc NoOcc occ = occ
754 combineOcc occ NoOcc = occ
755 combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys)
756 combineOcc _occ (ScrutOcc ys) = ScrutOcc ys
757 combineOcc (ScrutOcc xs) _occ = ScrutOcc xs
758 combineOcc UnkOcc UnkOcc = UnkOcc
759 combineOcc _ _ = BothOcc
761 combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]
762 combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys
764 setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage
765 -- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee
766 -- is a variable, and an interesting variable
767 setScrutOcc env usg (Cast e _) occ = setScrutOcc env usg e occ
768 setScrutOcc env usg (Note _ e) occ = setScrutOcc env usg e occ
769 setScrutOcc env usg (Var v) occ
770 | Just RecArg <- lookupHowBound env v = usg { scu_occs = extendVarEnv (scu_occs usg) v occ }
772 setScrutOcc _env usg _other _occ -- Catch-all
775 conArgOccs :: ArgOcc -> AltCon -> [ArgOcc]
776 -- Find usage of components of data con; returns [UnkOcc...] if unknown
777 -- See Note [ScrutOcc] for the extra UnkOccs in the vanilla datacon case
779 conArgOccs (ScrutOcc fm) (DataAlt dc)
780 | Just pat_arg_occs <- lookupUFM fm dc
781 = [UnkOcc | _ <- dataConUnivTyVars dc] ++ pat_arg_occs
783 conArgOccs _other _con = repeat UnkOcc
786 %************************************************************************
788 \subsection{The main recursive function}
790 %************************************************************************
792 The main recursive function gathers up usage information, and
793 creates specialised versions of functions.
796 scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
797 -- The unique supply is needed when we invent
798 -- a new name for the specialised function and its args
800 scExpr env e = scExpr' env e
803 scExpr' env (Var v) = case scSubstId env v of
804 Var v' -> return (varUsage env v' UnkOcc, Var v')
805 e' -> scExpr (zapScSubst env) e'
807 scExpr' env (Type t) = return (nullUsage, Type (scSubstTy env t))
808 scExpr' _ e@(Lit {}) = return (nullUsage, e)
809 scExpr' env (Note n e) = do (usg,e') <- scExpr env e
810 return (usg, Note n e')
811 scExpr' env (Cast e co) = do (usg, e') <- scExpr env e
812 return (usg, Cast e' (scSubstTy env co))
813 scExpr' env e@(App _ _) = scApp env (collectArgs e)
814 scExpr' env (Lam b e) = do let (env', b') = extendBndr env b
815 (usg, e') <- scExpr env' e
816 return (usg, Lam b' e')
818 scExpr' env (Case scrut b ty alts)
819 = do { (scrut_usg, scrut') <- scExpr env scrut
820 ; case isValue (sc_vals env) scrut' of
821 Just (ConVal con args) -> sc_con_app con args scrut'
822 _other -> sc_vanilla scrut_usg scrut'
825 sc_con_app con args scrut' -- Known constructor; simplify
826 = do { let (_, bs, rhs) = findAlt con alts
827 `orElse` (DEFAULT, [], mkImpossibleExpr (coreAltsType alts))
828 alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)
829 ; scExpr alt_env' rhs }
831 sc_vanilla scrut_usg scrut' -- Normal case
832 = do { let (alt_env,b') = extendBndrWith RecArg env b
833 -- Record RecArg for the components
835 ; (alt_usgs, alt_occs, alts')
836 <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts
838 ; let (alt_usg, b_occ) = lookupOcc (combineUsages alt_usgs) b'
839 scrut_occ = foldr combineOcc b_occ alt_occs
840 scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ
841 -- The combined usage of the scrutinee is given
842 -- by scrut_occ, which is passed to scScrut, which
843 -- in turn treats a bare-variable scrutinee specially
845 ; return (alt_usg `combineUsage` scrut_usg',
846 Case scrut' b' (scSubstTy env ty) alts') }
848 sc_alt env _scrut' b' (con,bs,rhs)
849 = do { let (env1, bs1) = extendBndrsWith RecArg env bs
850 (env2, bs2) = extendCaseBndrs env1 b' con bs1
851 ; (usg,rhs') <- scExpr env2 rhs
852 ; let (usg', arg_occs) = lookupOccs usg bs2
853 scrut_occ = case con of
854 DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)
855 _ -> ScrutOcc emptyUFM
856 ; return (usg', scrut_occ, (con, bs2, rhs')) }
858 scExpr' env (Let (NonRec bndr rhs) body)
859 | isTyVar bndr -- Type-lets may be created by doBeta
860 = scExpr' (extendScSubst env bndr rhs) body
862 = do { let (body_env, bndr') = extendBndr env bndr
863 ; (rhs_usg, (_, args', rhs_body', _)) <- scRecRhs env (bndr',rhs)
864 ; let rhs' = mkLams args' rhs_body'
866 ; if not opt_SpecInlineJoinPoints || null args' || isEmptyVarEnv (scu_calls rhs_usg) then do
868 let body_env2 = extendValEnv body_env bndr' (isValue (sc_vals env) rhs')
869 -- Record if the RHS is a value
870 ; (body_usg, body') <- scExpr body_env2 body
871 ; return (body_usg `combineUsage` rhs_usg, Let (NonRec bndr' rhs') body') }
872 else -- For now, just brutally inline the join point
873 do { let body_env2 = extendScSubst env bndr rhs'
874 ; scExpr body_env2 body } }
878 do { -- Join-point case
879 let body_env2 = extendHowBound body_env [bndr'] RecFun
880 -- If the RHS of this 'let' contains calls
881 -- to recursive functions that we're trying
882 -- to specialise, then treat this let too
883 -- as one to specialise
884 ; (body_usg, body') <- scExpr body_env2 body
886 ; (spec_usg, _, specs) <- specialise env (scu_calls body_usg) ([], rhs_info)
888 ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' }
889 `combineUsage` rhs_usg `combineUsage` spec_usg,
890 mkLets [NonRec b r | (b,r) <- specInfoBinds rhs_info specs] body')
894 -- A *local* recursive group: see Note [Local recursive groups]
895 scExpr' env (Let (Rec prs) body)
896 = do { let (bndrs,rhss) = unzip prs
897 (rhs_env1,bndrs') = extendRecBndrs env bndrs
898 rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
900 ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
901 ; (body_usg, body') <- scExpr rhs_env2 body
903 -- NB: start specLoop from body_usg
904 ; (spec_usg, specs) <- specLoop rhs_env2 (scu_calls body_usg) rhs_infos nullUsage
905 [SI [] 0 (Just usg) | usg <- rhs_usgs]
907 ; let all_usg = spec_usg `combineUsage` body_usg
908 bind' = Rec (concat (zipWith specInfoBinds rhs_infos specs))
910 ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' },
913 -----------------------------------
914 scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)
916 scApp env (Var fn, args) -- Function is a variable
917 = ASSERT( not (null args) )
918 do { args_w_usgs <- mapM (scExpr env) args
919 ; let (arg_usgs, args') = unzip args_w_usgs
920 arg_usg = combineUsages arg_usgs
921 ; case scSubstId env fn of
922 fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args')
923 -- Do beta-reduction and try again
925 Var fn' -> return (arg_usg `combineUsage` fn_usg, mkApps (Var fn') args')
927 fn_usg = case lookupHowBound env fn' of
928 Just RecFun -> SCU { scu_calls = unitVarEnv fn' [(sc_vals env, args')],
929 scu_occs = emptyVarEnv }
930 Just RecArg -> SCU { scu_calls = emptyVarEnv,
931 scu_occs = unitVarEnv fn' (ScrutOcc emptyUFM) }
935 other_fn' -> return (arg_usg, mkApps other_fn' args') }
936 -- NB: doing this ignores any usage info from the substituted
937 -- function, but I don't think that matters. If it does
940 doBeta :: OutExpr -> [OutExpr] -> OutExpr
941 -- ToDo: adjust for System IF
942 doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args)
943 doBeta fn args = mkApps fn args
945 -- The function is almost always a variable, but not always.
946 -- In particular, if this pass follows float-in,
947 -- which it may, we can get
948 -- (let f = ...f... in f) arg1 arg2
949 scApp env (other_fn, args)
950 = do { (fn_usg, fn') <- scExpr env other_fn
951 ; (arg_usgs, args') <- mapAndUnzipM (scExpr env) args
952 ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') }
954 ----------------------
955 scTopBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind)
956 scTopBind env (Rec prs)
957 | Just threshold <- sc_size env
958 , not (all (couldBeSmallEnoughToInline threshold) rhss)
960 = do { let (rhs_env,bndrs') = extendRecBndrs env bndrs
961 ; (_, rhss') <- mapAndUnzipM (scExpr rhs_env) rhss
962 ; return (rhs_env, Rec (bndrs' `zip` rhss')) }
963 | otherwise -- Do specialisation
964 = do { let (rhs_env1,bndrs') = extendRecBndrs env bndrs
965 rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
967 ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
968 ; let rhs_usg = combineUsages rhs_usgs
970 ; (_, specs) <- specLoop rhs_env2 (scu_calls rhs_usg) rhs_infos nullUsage
971 [SI [] 0 Nothing | _ <- bndrs]
973 ; return (rhs_env1, -- For the body of the letrec, delete the RecFun business
974 Rec (concat (zipWith specInfoBinds rhs_infos specs))) }
976 (bndrs,rhss) = unzip prs
978 scTopBind env (NonRec bndr rhs)
979 = do { (_, rhs') <- scExpr env rhs
980 ; let (env1, bndr') = extendBndr env bndr
981 env2 = extendValEnv env1 bndr' (isValue (sc_vals env) rhs')
982 ; return (env2, NonRec bndr' rhs') }
984 ----------------------
985 scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM (ScUsage, RhsInfo)
986 scRecRhs env (bndr,rhs)
987 = do { let (arg_bndrs,body) = collectBinders rhs
988 (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs
989 ; (body_usg, body') <- scExpr body_env body
990 ; let (rhs_usg, arg_occs) = lookupOccs body_usg arg_bndrs'
991 ; return (rhs_usg, (bndr, arg_bndrs', body', arg_occs)) }
993 -- The arg_occs says how the visible,
994 -- lambda-bound binders of the RHS are used
995 -- (including the TyVar binders)
996 -- Two pats are the same if they match both ways
998 ----------------------
999 specInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)]
1000 specInfoBinds (fn, args, body, _) (SI specs _ _)
1001 = [(id,rhs) | OS _ _ id rhs <- specs] ++
1002 [(fn `addIdSpecialisations` rules, mkLams args body)]
1004 rules = [r | OS _ r _ _ <- specs]
1006 ----------------------
1007 varUsage :: ScEnv -> OutVar -> ArgOcc -> ScUsage
1009 | Just RecArg <- lookupHowBound env v = SCU { scu_calls = emptyVarEnv
1010 , scu_occs = unitVarEnv v use }
1011 | otherwise = nullUsage
1015 %************************************************************************
1017 The specialiser itself
1019 %************************************************************************
1022 type RhsInfo = (OutId, [OutVar], OutExpr, [ArgOcc])
1023 -- Info about the *original* RHS of a binding we are specialising
1024 -- Original binding f = \xs.body
1025 -- Plus info about usage of arguments
1027 data SpecInfo = SI [OneSpec] -- The specialisations we have generated
1028 Int -- Length of specs; used for numbering them
1029 (Maybe ScUsage) -- Nothing => we have generated specialisations
1030 -- from calls in the *original* RHS
1031 -- Just cs => we haven't, and this is the usage
1032 -- of the original RHS
1034 -- One specialisation: Rule plus definition
1035 data OneSpec = OS CallPat -- Call pattern that generated this specialisation
1036 CoreRule -- Rule connecting original id with the specialisation
1037 OutId OutExpr -- Spec id + its rhs
1043 -> ScUsage -> [SpecInfo] -- One per binder; acccumulating parameter
1044 -> UniqSM (ScUsage, [SpecInfo]) -- ...ditto...
1045 specLoop env all_calls rhs_infos usg_so_far specs_so_far
1046 = do { specs_w_usg <- zipWithM (specialise env all_calls) rhs_infos specs_so_far
1047 ; let (new_usg_s, all_specs) = unzip specs_w_usg
1048 new_usg = combineUsages new_usg_s
1049 new_calls = scu_calls new_usg
1050 all_usg = usg_so_far `combineUsage` new_usg
1051 ; if isEmptyVarEnv new_calls then
1052 return (all_usg, all_specs)
1054 specLoop env new_calls rhs_infos all_usg all_specs }
1058 -> CallEnv -- Info on calls
1060 -> SpecInfo -- Original RHS plus patterns dealt with
1061 -> UniqSM (ScUsage, SpecInfo) -- New specialised versions and their usage
1063 -- Note: the rhs here is the optimised version of the original rhs
1064 -- So when we make a specialised copy of the RHS, we're starting
1065 -- from an RHS whose nested functions have been optimised already.
1067 specialise env bind_calls (fn, arg_bndrs, body, arg_occs)
1068 spec_info@(SI specs spec_count mb_unspec)
1069 | not (isBottomingId fn) -- Note [Do not specialise diverging functions]
1070 , notNull arg_bndrs -- Only specialise functions
1071 , Just all_calls <- lookupVarEnv bind_calls fn
1072 = do { (boring_call, pats) <- callsToPats env specs arg_occs all_calls
1073 -- ; pprTrace "specialise" (vcat [ppr fn <+> ppr arg_occs,
1074 -- text "calls" <+> ppr all_calls,
1075 -- text "good pats" <+> ppr pats]) $
1078 -- Bale out if too many specialisations
1079 -- Rather a hacky way to do so, but it'll do for now
1080 ; let spec_count' = length pats + spec_count
1081 ; case sc_count env of
1082 Just max | spec_count' > max
1083 -> WARN( True, msg ) return (nullUsage, spec_info)
1085 msg = vcat [ sep [ ptext (sLit "SpecConstr: specialisation of") <+> quotes (ppr fn)
1086 , nest 2 (ptext (sLit "limited by bound of")) <+> int max ]
1087 , ptext (sLit "Use -fspec-constr-count=n to set the bound")
1089 extra | not opt_PprStyle_Debug = ptext (sLit "Use -dppr-debug to see specialisations")
1090 | otherwise = ptext (sLit "Specialisations:") <+> ppr (pats ++ [p | OS p _ _ _ <- specs])
1092 _normal_case -> do {
1094 (spec_usgs, new_specs) <- mapAndUnzipM (spec_one env fn arg_bndrs body)
1095 (pats `zip` [spec_count..])
1097 ; let spec_usg = combineUsages spec_usgs
1098 (new_usg, mb_unspec')
1100 Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing)
1101 _ -> (spec_usg, mb_unspec)
1103 ; return (new_usg, SI (new_specs ++ specs) spec_count' mb_unspec') } }
1105 = return (nullUsage, spec_info) -- The boring case
1108 ---------------------
1110 -> OutId -- Function
1111 -> [Var] -- Lambda-binders of RHS; should match patterns
1112 -> CoreExpr -- Body of the original function
1114 -> UniqSM (ScUsage, OneSpec) -- Rule and binding
1116 -- spec_one creates a specialised copy of the function, together
1117 -- with a rule for using it. I'm very proud of how short this
1118 -- function is, considering what it does :-).
1124 f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
1125 [c::*, v::(b,c) are presumably bound by the (...) part]
1127 f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
1128 (...entire body of f...) [b -> (b,c),
1129 y -> ((:) (a,(b,c)) (x,v) hw)]
1131 RULE: forall b::* c::*, -- Note, *not* forall a, x
1135 f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
1138 spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)
1139 = do { -- Specialise the body
1140 let spec_env = extendScSubstList (extendScInScope env qvars)
1141 (arg_bndrs `zip` pats)
1142 ; (spec_usg, spec_body) <- scExpr spec_env body
1144 -- ; pprTrace "spec_one" (ppr fn <+> vcat [text "pats" <+> ppr pats,
1145 -- text "calls" <+> (ppr (scu_calls spec_usg))])
1148 -- And build the results
1149 ; spec_uniq <- getUniqueUs
1150 ; let (spec_lam_args, spec_call_args) = mkWorkerArgs qvars body_ty
1151 -- Usual w/w hack to avoid generating
1152 -- a spec_rhs of unlifted type and no args
1155 fn_loc = nameSrcSpan fn_name
1156 spec_occ = mkSpecOcc (nameOccName fn_name)
1157 rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number))
1158 spec_rhs = mkLams spec_lam_args spec_body
1159 spec_str = calcSpecStrictness fn spec_lam_args pats
1160 spec_id = mkUserLocal spec_occ spec_uniq (mkPiTypes spec_lam_args body_ty) fn_loc
1161 `setIdNewStrictness` spec_str -- See Note [Transfer strictness]
1162 `setIdArity` count isId spec_lam_args
1163 body_ty = exprType spec_body
1164 rule_rhs = mkVarApps (Var spec_id) spec_call_args
1165 rule = mkLocalRule rule_name specConstrActivation fn_name qvars pats rule_rhs
1166 ; return (spec_usg, OS call_pat rule spec_id spec_rhs) }
1168 calcSpecStrictness :: Id -- The original function
1169 -> [Var] -> [CoreExpr] -- Call pattern
1170 -> StrictSig -- Strictness of specialised thing
1171 -- See Note [Transfer strictness]
1172 calcSpecStrictness fn qvars pats
1173 = StrictSig (mkTopDmdType spec_dmds TopRes)
1175 spec_dmds = [ lookupVarEnv dmd_env qv `orElse` lazyDmd | qv <- qvars, isId qv ]
1176 StrictSig (DmdType _ dmds _) = idNewStrictness fn
1178 dmd_env = go emptyVarEnv dmds pats
1180 go env ds (Type {} : pats) = go env ds pats
1181 go env (d:ds) (pat : pats) = go (go_one env d pat) ds pats
1184 go_one env d (Var v) = extendVarEnv_C both env v d
1185 go_one env (Box d) e = go_one env d e
1186 go_one env (Eval (Prod ds)) e
1187 | (Var _, args) <- collectArgs e = go env ds args
1188 go_one env _ _ = env
1190 -- In which phase should the specialise-constructor rules be active?
1191 -- Originally I made them always-active, but Manuel found that
1192 -- this defeated some clever user-written rules. So Plan B
1193 -- is to make them active only in Phase 0; after all, currently,
1194 -- the specConstr transformation is only run after the simplifier
1195 -- has reached Phase 0. In general one would want it to be
1196 -- flag-controllable, but for now I'm leaving it baked in
1198 specConstrActivation :: Activation
1199 specConstrActivation = ActiveAfter 0 -- Baked in; see comments above
1202 Note [Transfer strictness]
1203 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1204 We must transfer strictness information from the original function to
1205 the specialised one. Suppose, for example
1208 and a RULE f (a:as) b = f_spec a as b
1210 Now we want f_spec to have strictess LLS, otherwise we'll use call-by-need
1211 when calling f_spec instead of call-by-value. And that can result in
1212 unbounded worsening in space (cf the classic foldl vs foldl')
1214 See Trac #3437 for a good example.
1216 The function calcSpecStrictness performs the calculation.
1219 %************************************************************************
1221 \subsection{Argument analysis}
1223 %************************************************************************
1225 This code deals with analysing call-site arguments to see whether
1226 they are constructor applications.
1230 type CallPat = ([Var], [CoreExpr]) -- Quantified variables and arguments
1233 callsToPats :: ScEnv -> [OneSpec] -> [ArgOcc] -> [Call] -> UniqSM (Bool, [CallPat])
1234 -- Result has no duplicate patterns,
1235 -- nor ones mentioned in done_pats
1236 -- Bool indicates that there was at least one boring pattern
1237 callsToPats env done_specs bndr_occs calls
1238 = do { mb_pats <- mapM (callToPats env bndr_occs) calls
1240 ; let good_pats :: [([Var], [CoreArg])]
1241 good_pats = catMaybes mb_pats
1242 done_pats = [p | OS p _ _ _ <- done_specs]
1243 is_done p = any (samePat p) done_pats
1245 ; return (any isNothing mb_pats,
1246 filterOut is_done (nubBy samePat good_pats)) }
1248 callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
1249 -- The [Var] is the variables to quantify over in the rule
1250 -- Type variables come first, since they may scope
1251 -- over the following term variables
1252 -- The [CoreExpr] are the argument patterns for the rule
1253 callToPats env bndr_occs (con_env, args)
1254 | length args < length bndr_occs -- Check saturated
1257 = do { let in_scope = substInScope (sc_subst env)
1258 ; prs <- argsToPats env in_scope con_env (args `zip` bndr_occs)
1259 ; let (interesting_s, pats) = unzip prs
1260 pat_fvs = varSetElems (exprsFreeVars pats)
1261 qvars = filterOut (`elemInScopeSet` in_scope) pat_fvs
1262 -- Quantify over variables that are not in sccpe
1264 -- See Note [Shadowing] at the top
1266 (tvs, ids) = partition isTyVar qvars
1268 -- Put the type variables first; the type of a term
1269 -- variable may mention a type variable
1271 ; -- pprTrace "callToPats" (ppr args $$ ppr prs $$ ppr bndr_occs) $
1273 then return (Just (qvars', pats))
1274 else return Nothing }
1276 -- argToPat takes an actual argument, and returns an abstracted
1277 -- version, consisting of just the "constructor skeleton" of the
1278 -- argument, with non-constructor sub-expression replaced by new
1279 -- placeholder variables. For example:
1280 -- C a (D (f x) (g y)) ==> C p1 (D p2 p3)
1283 -> InScopeSet -- What's in scope at the fn defn site
1284 -> ValueEnv -- ValueEnv at the call site
1285 -> CoreArg -- A call arg (or component thereof)
1287 -> UniqSM (Bool, CoreArg)
1288 -- Returns (interesting, pat),
1289 -- where pat is the pattern derived from the argument
1290 -- intersting=True if the pattern is non-trivial (not a variable or type)
1291 -- E.g. x:xs --> (True, x:xs)
1292 -- f xs --> (False, w) where w is a fresh wildcard
1293 -- (f xs, 'c') --> (True, (w, 'c')) where w is a fresh wildcard
1294 -- \x. x+y --> (True, \x. x+y)
1295 -- lvl7 --> (True, lvl7) if lvl7 is bound
1296 -- somewhere further out
1298 argToPat _env _in_scope _val_env arg@(Type {}) _arg_occ
1299 = return (False, arg)
1301 argToPat env in_scope val_env (Note _ arg) arg_occ
1302 = argToPat env in_scope val_env arg arg_occ
1303 -- Note [Notes in call patterns]
1304 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1305 -- Ignore Notes. In particular, we want to ignore any InlineMe notes
1306 -- Perhaps we should not ignore profiling notes, but I'm going to
1307 -- ride roughshod over them all for now.
1308 --- See Note [Notes in RULE matching] in Rules
1310 argToPat env in_scope val_env (Let _ arg) arg_occ
1311 = argToPat env in_scope val_env arg arg_occ
1312 -- Look through let expressions
1313 -- e.g. f (let v = rhs in \y -> ...v...)
1314 -- Here we can specialise for f (\y -> ...)
1315 -- because the rule-matcher will look through the let.
1317 argToPat env in_scope val_env (Cast arg co) arg_occ
1318 | not (ignoreType env ty2)
1319 = do { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ
1320 ; if not interesting then
1323 { -- Make a wild-card pattern for the coercion
1325 ; let co_name = mkSysTvName uniq (fsLit "sg")
1326 co_var = mkCoVar co_name (mkCoKind ty1 ty2)
1327 ; return (interesting, Cast arg' (mkTyVarTy co_var)) } }
1329 (ty1, ty2) = coercionKind co
1333 {- Disabling lambda specialisation for now
1334 It's fragile, and the spec_loop can be infinite
1335 argToPat in_scope val_env arg arg_occ
1337 = return (True, arg)
1339 is_value_lam (Lam v e) -- Spot a value lambda, even if
1340 | isId v = True -- it is inside a type lambda
1341 | otherwise = is_value_lam e
1342 is_value_lam other = False
1345 -- Check for a constructor application
1346 -- NB: this *precedes* the Var case, so that we catch nullary constrs
1347 argToPat env in_scope val_env arg arg_occ
1348 | Just (ConVal dc args) <- isValue val_env arg
1349 , not (ignoreAltCon env dc)
1351 ScrutOcc _ -> True -- Used only by case scrutinee
1352 BothOcc -> case arg of -- Used elsewhere
1353 App {} -> True -- see Note [Reboxing]
1355 _other -> False -- No point; the arg is not decomposed
1356 = do { args' <- argsToPats env in_scope val_env (args `zip` conArgOccs arg_occ dc)
1357 ; return (True, mk_con_app dc (map snd args')) }
1359 -- Check if the argument is a variable that
1360 -- is in scope at the function definition site
1361 -- It's worth specialising on this if
1362 -- (a) it's used in an interesting way in the body
1363 -- (b) we know what its value is
1364 argToPat env in_scope val_env (Var v) arg_occ
1365 | case arg_occ of { UnkOcc -> False; _other -> True }, -- (a)
1367 not (ignoreType env (varType v))
1368 = return (True, Var v)
1371 | isLocalId v = v `elemInScopeSet` in_scope
1372 && isJust (lookupVarEnv val_env v)
1373 -- Local variables have values in val_env
1374 | otherwise = isValueUnfolding (idUnfolding v)
1375 -- Imports have unfoldings
1377 -- I'm really not sure what this comment means
1378 -- And by not wild-carding we tend to get forall'd
1379 -- variables that are in soope, which in turn can
1380 -- expose the weakness in let-matching
1381 -- See Note [Matching lets] in Rules
1383 -- Check for a variable bound inside the function.
1384 -- Don't make a wild-card, because we may usefully share
1385 -- e.g. f a = let x = ... in f (x,x)
1386 -- NB: this case follows the lambda and con-app cases!!
1387 -- argToPat _in_scope _val_env (Var v) _arg_occ
1388 -- = return (False, Var v)
1389 -- SLPJ : disabling this to avoid proliferation of versions
1390 -- also works badly when thinking about seeding the loop
1391 -- from the body of the let
1392 -- f x y = letrec g z = ... in g (x,y)
1393 -- We don't want to specialise for that *particular* x,y
1395 -- The default case: make a wild-card
1396 argToPat _env _in_scope _val_env arg _arg_occ
1397 = wildCardPat (exprType arg)
1399 wildCardPat :: Type -> UniqSM (Bool, CoreArg)
1400 wildCardPat ty = do { uniq <- getUniqueUs
1401 ; let id = mkSysLocal (fsLit "sc") uniq ty
1402 ; return (False, Var id) }
1404 argsToPats :: ScEnv -> InScopeSet -> ValueEnv
1405 -> [(CoreArg, ArgOcc)]
1406 -> UniqSM [(Bool, CoreArg)]
1407 argsToPats env in_scope val_env args
1410 do_one (arg,occ) = argToPat env in_scope val_env arg occ
1415 isValue :: ValueEnv -> CoreExpr -> Maybe Value
1416 isValue _env (Lit lit)
1417 = Just (ConVal (LitAlt lit) [])
1420 | Just stuff <- lookupVarEnv env v
1421 = Just stuff -- You might think we could look in the idUnfolding here
1422 -- but that doesn't take account of which branch of a
1423 -- case we are in, which is the whole point
1425 | not (isLocalId v) && isCheapUnfolding unf
1426 = isValue env (unfoldingTemplate unf)
1429 -- However we do want to consult the unfolding
1430 -- as well, for let-bound constructors!
1432 isValue env (Lam b e)
1433 | isTyVar b = case isValue env e of
1434 Just _ -> Just LambdaVal
1436 | otherwise = Just LambdaVal
1438 isValue _env expr -- Maybe it's a constructor application
1439 | (Var fun, args) <- collectArgs expr
1440 = case isDataConWorkId_maybe fun of
1442 Just con | args `lengthAtLeast` dataConRepArity con
1443 -- Check saturated; might be > because the
1444 -- arity excludes type args
1445 -> Just (ConVal (DataAlt con) args)
1447 _other | valArgCount args < idArity fun
1448 -- Under-applied function
1449 -> Just LambdaVal -- Partial application
1453 isValue _env _expr = Nothing
1455 mk_con_app :: AltCon -> [CoreArg] -> CoreExpr
1456 mk_con_app (LitAlt lit) [] = Lit lit
1457 mk_con_app (DataAlt con) args = mkConApp con args
1458 mk_con_app _other _args = panic "SpecConstr.mk_con_app"
1460 samePat :: CallPat -> CallPat -> Bool
1461 samePat (vs1, as1) (vs2, as2)
1464 same (Var v1) (Var v2)
1465 | v1 `elem` vs1 = v2 `elem` vs2
1466 | v2 `elem` vs2 = False
1467 | otherwise = v1 == v2
1469 same (Lit l1) (Lit l2) = l1==l2
1470 same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2
1472 same (Type {}) (Type {}) = True -- Note [Ignore type differences]
1473 same (Note _ e1) e2 = same e1 e2 -- Ignore casts and notes
1474 same (Cast e1 _) e2 = same e1 e2
1475 same e1 (Note _ e2) = same e1 e2
1476 same e1 (Cast e2 _) = same e1 e2
1478 same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2)
1479 False -- Let, lambda, case should not occur
1480 bad (Case {}) = True
1486 Note [Ignore type differences]
1487 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1488 We do not want to generate specialisations where the call patterns
1489 differ only in their type arguments! Not only is it utterly useless,
1490 but it also means that (with polymorphic recursion) we can generate
1491 an infinite number of specialisations. Example is Data.Sequence.adjustTree,