4c0d92756a7dd03a3d55e6c87b05cb69757da5ec
[ghc.git] / compiler / specialise / SpecConstr.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 %
4 \section[SpecConstr]{Specialise over constructors}
5
6 \begin{code}
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
11 -- for details
12
13 module SpecConstr(
14         specConstrProgram, SpecConstrAnnotation(..)
15     ) where
16
17 #include "HsVersions.h"
18
19 import CoreSyn
20 import CoreSubst
21 import CoreUtils
22 import CoreUnfold       ( couldBeSmallEnoughToInline )
23 import CoreFVs          ( exprsFreeVars )
24 import CoreMonad
25 import HscTypes         ( ModGuts(..) )
26 import WwLib            ( mkWorkerArgs )
27 import DataCon          ( dataConTyCon, dataConRepArity, dataConUnivTyVars )
28 import TyCon            ( TyCon )
29 import Literal          ( literalType )
30 import Coercion 
31 import Rules
32 import Type             hiding( substTy )
33 import Id
34 import MkId             ( mkImpossibleExpr )
35 import Var
36 import VarEnv
37 import VarSet
38 import Name
39 import DynFlags         ( DynFlags(..) )
40 import StaticFlags      ( opt_PprStyle_Debug )
41 import Maybes           ( orElse, catMaybes, isJust, isNothing )
42 import Demand
43 import DmdAnal          ( both )
44 import Serialized       ( deserializeWithData )
45 import Util
46 import UniqSupply
47 import Outputable
48 import FastString
49 import UniqFM
50 import MonadUtils
51 import Control.Monad    ( zipWithM )
52 import Data.List
53 import Data.Data        ( Data, Typeable )
54 \end{code}
55
56 -----------------------------------------------------
57                         Game plan
58 -----------------------------------------------------
59
60 Consider
61         drop n []     = []
62         drop 0 xs     = []
63         drop n (x:xs) = drop (n-1) xs
64
65 After the first time round, we could pass n unboxed.  This happens in
66 numerical code too.  Here's what it looks like in Core:
67
68         drop n xs = case xs of
69                       []     -> []
70                       (y:ys) -> case n of 
71                                   I# n# -> case n# of
72                                              0 -> []
73                                              _ -> drop (I# (n# -# 1#)) xs
74
75 Notice that the recursive call has an explicit constructor as argument.
76 Noticing this, we can make a specialised version of drop
77         
78         RULE: drop (I# n#) xs ==> drop' n# xs
79
80         drop' n# xs = let n = I# n# in ...orig RHS...
81
82 Now the simplifier will apply the specialisation in the rhs of drop', giving
83
84         drop' n# xs = case xs of
85                       []     -> []
86                       (y:ys) -> case n# of
87                                   0 -> []
88                                   _ -> drop (n# -# 1#) xs
89
90 Much better!  
91
92 We'd also like to catch cases where a parameter is carried along unchanged,
93 but evaluated each time round the loop:
94
95         f i n = if i>0 || i>n then i else f (i*2) n
96
97 Here f isn't strict in n, but we'd like to avoid evaluating it each iteration.
98 In Core, by the time we've w/wd (f is strict in i) we get
99
100         f i# n = case i# ># 0 of
101                    False -> I# i#
102                    True  -> case n of n' { I# n# ->
103                             case i# ># n# of
104                                 False -> I# i#
105                                 True  -> f (i# *# 2#) n'
106
107 At the call to f, we see that the argument, n is know to be (I# n#),
108 and n is evaluated elsewhere in the body of f, so we can play the same
109 trick as above.  
110
111
112 Note [Reboxing]
113 ~~~~~~~~~~~~~~~
114 We must be careful not to allocate the same constructor twice.  Consider
115         f p = (...(case p of (a,b) -> e)...p...,
116                ...let t = (r,s) in ...t...(f t)...)
117 At the recursive call to f, we can see that t is a pair.  But we do NOT want
118 to make a specialised copy:
119         f' a b = let p = (a,b) in (..., ...)
120 because now t is allocated by the caller, then r and s are passed to the
121 recursive call, which allocates the (r,s) pair again.
122
123 This happens if
124   (a) the argument p is used in other than a case-scrutinsation way.
125   (b) the argument to the call is not a 'fresh' tuple; you have to
126         look into its unfolding to see that it's a tuple
127
128 Hence the "OR" part of Note [Good arguments] below.
129
130 ALTERNATIVE 2: pass both boxed and unboxed versions.  This no longer saves
131 allocation, but does perhaps save evals. In the RULE we'd have
132 something like
133
134   f (I# x#) = f' (I# x#) x#
135
136 If at the call site the (I# x) was an unfolding, then we'd have to
137 rely on CSE to eliminate the duplicate allocation.... This alternative
138 doesn't look attractive enough to pursue.
139
140 ALTERNATIVE 3: ignore the reboxing problem.  The trouble is that 
141 the conservative reboxing story prevents many useful functions from being
142 specialised.  Example:
143         foo :: Maybe Int -> Int -> Int
144         foo   (Just m) 0 = 0
145         foo x@(Just m) n = foo x (n-m)
146 Here the use of 'x' will clearly not require boxing in the specialised function.
147
148 The strictness analyser has the same problem, in fact.  Example:
149         f p@(a,b) = ...
150 If we pass just 'a' and 'b' to the worker, it might need to rebox the
151 pair to create (a,b).  A more sophisticated analysis might figure out
152 precisely the cases in which this could happen, but the strictness
153 analyser does no such analysis; it just passes 'a' and 'b', and hopes
154 for the best.
155
156 So my current choice is to make SpecConstr similarly aggressive, and
157 ignore the bad potential of reboxing.
158
159
160 Note [Good arguments]
161 ~~~~~~~~~~~~~~~~~~~~~
162 So we look for
163
164 * A self-recursive function.  Ignore mutual recursion for now, 
165   because it's less common, and the code is simpler for self-recursion.
166
167 * EITHER
168
169    a) At a recursive call, one or more parameters is an explicit 
170       constructor application
171         AND
172       That same parameter is scrutinised by a case somewhere in 
173       the RHS of the function
174
175   OR
176
177     b) At a recursive call, one or more parameters has an unfolding
178        that is an explicit constructor application
179         AND
180       That same parameter is scrutinised by a case somewhere in 
181       the RHS of the function
182         AND
183       Those are the only uses of the parameter (see Note [Reboxing])
184
185
186 What to abstract over
187 ~~~~~~~~~~~~~~~~~~~~~
188 There's a bit of a complication with type arguments.  If the call
189 site looks like
190
191         f p = ...f ((:) [a] x xs)...
192
193 then our specialised function look like
194
195         f_spec x xs = let p = (:) [a] x xs in ....as before....
196
197 This only makes sense if either
198   a) the type variable 'a' is in scope at the top of f, or
199   b) the type variable 'a' is an argument to f (and hence fs)
200
201 Actually, (a) may hold for value arguments too, in which case
202 we may not want to pass them.  Supose 'x' is in scope at f's
203 defn, but xs is not.  Then we'd like
204
205         f_spec xs = let p = (:) [a] x xs in ....as before....
206
207 Similarly (b) may hold too.  If x is already an argument at the
208 call, no need to pass it again.
209
210 Finally, if 'a' is not in scope at the call site, we could abstract
211 it as we do the term variables:
212
213         f_spec a x xs = let p = (:) [a] x xs in ...as before...
214
215 So the grand plan is:
216
217         * abstract the call site to a constructor-only pattern
218           e.g.  C x (D (f p) (g q))  ==>  C s1 (D s2 s3)
219
220         * Find the free variables of the abstracted pattern
221
222         * Pass these variables, less any that are in scope at
223           the fn defn.  But see Note [Shadowing] below.
224
225
226 NOTICE that we only abstract over variables that are not in scope,
227 so we're in no danger of shadowing variables used in "higher up"
228 in f_spec's RHS.
229
230
231 Note [Shadowing]
232 ~~~~~~~~~~~~~~~~
233 In this pass we gather up usage information that may mention variables
234 that are bound between the usage site and the definition site; or (more
235 seriously) may be bound to something different at the definition site.
236 For example:
237
238         f x = letrec g y v = let x = ... 
239                              in ...(g (a,b) x)...
240
241 Since 'x' is in scope at the call site, we may make a rewrite rule that 
242 looks like
243         RULE forall a,b. g (a,b) x = ...
244 But this rule will never match, because it's really a different 'x' at 
245 the call site -- and that difference will be manifest by the time the
246 simplifier gets to it.  [A worry: the simplifier doesn't *guarantee*
247 no-shadowing, so perhaps it may not be distinct?]
248
249 Anyway, the rule isn't actually wrong, it's just not useful.  One possibility
250 is to run deShadowBinds before running SpecConstr, but instead we run the
251 simplifier.  That gives the simplest possible program for SpecConstr to
252 chew on; and it virtually guarantees no shadowing.
253
254 Note [Specialising for constant parameters]
255 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
256 This one is about specialising on a *constant* (but not necessarily
257 constructor) argument
258
259     foo :: Int -> (Int -> Int) -> Int
260     foo 0 f = 0
261     foo m f = foo (f m) (+1)
262
263 It produces
264
265     lvl_rmV :: GHC.Base.Int -> GHC.Base.Int
266     lvl_rmV =
267       \ (ds_dlk :: GHC.Base.Int) ->
268         case ds_dlk of wild_alH { GHC.Base.I# x_alG ->
269         GHC.Base.I# (GHC.Prim.+# x_alG 1)
270
271     T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
272     GHC.Prim.Int#
273     T.$wfoo =
274       \ (ww_sme :: GHC.Prim.Int#) (w_smg :: GHC.Base.Int -> GHC.Base.Int) ->
275         case ww_sme of ds_Xlw {
276           __DEFAULT ->
277         case w_smg (GHC.Base.I# ds_Xlw) of w1_Xmo { GHC.Base.I# ww1_Xmz ->
278         T.$wfoo ww1_Xmz lvl_rmV
279         };
280           0 -> 0
281         }
282
283 The recursive call has lvl_rmV as its argument, so we could create a specialised copy
284 with that argument baked in; that is, not passed at all.   Now it can perhaps be inlined.
285
286 When is this worth it?  Call the constant 'lvl'
287 - If 'lvl' has an unfolding that is a constructor, see if the corresponding
288   parameter is scrutinised anywhere in the body.
289
290 - If 'lvl' has an unfolding that is a inlinable function, see if the corresponding
291   parameter is applied (...to enough arguments...?)
292
293   Also do this is if the function has RULES?
294
295 Also    
296
297 Note [Specialising for lambda parameters]
298 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
299     foo :: Int -> (Int -> Int) -> Int
300     foo 0 f = 0
301     foo m f = foo (f m) (\n -> n-m)
302
303 This is subtly different from the previous one in that we get an
304 explicit lambda as the argument:
305
306     T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
307     GHC.Prim.Int#
308     T.$wfoo =
309       \ (ww_sm8 :: GHC.Prim.Int#) (w_sma :: GHC.Base.Int -> GHC.Base.Int) ->
310         case ww_sm8 of ds_Xlr {
311           __DEFAULT ->
312         case w_sma (GHC.Base.I# ds_Xlr) of w1_Xmf { GHC.Base.I# ww1_Xmq ->
313         T.$wfoo
314           ww1_Xmq
315           (\ (n_ad3 :: GHC.Base.Int) ->
316              case n_ad3 of wild_alB { GHC.Base.I# x_alA ->
317              GHC.Base.I# (GHC.Prim.-# x_alA ds_Xlr)
318              })
319         };
320           0 -> 0
321         }
322
323 I wonder if SpecConstr couldn't be extended to handle this? After all,
324 lambda is a sort of constructor for functions and perhaps it already
325 has most of the necessary machinery?
326
327 Furthermore, there's an immediate win, because you don't need to allocate the lamda
328 at the call site; and if perchance it's called in the recursive call, then you
329 may avoid allocating it altogether.  Just like for constructors.
330
331 Looks cool, but probably rare...but it might be easy to implement.
332
333
334 Note [SpecConstr for casts]
335 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
336 Consider 
337     data family T a :: *
338     data instance T Int = T Int
339
340     foo n = ...
341        where
342          go (T 0) = 0
343          go (T n) = go (T (n-1))
344
345 The recursive call ends up looking like 
346         go (T (I# ...) `cast` g)
347 So we want to spot the construtor application inside the cast.
348 That's why we have the Cast case in argToPat
349
350 Note [Local recursive groups]
351 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
352 For a *local* recursive group, we can see all the calls to the
353 function, so we seed the specialisation loop from the calls in the
354 body, not from the calls in the RHS.  Consider:
355
356   bar m n = foo n (n,n) (n,n) (n,n) (n,n)
357    where
358      foo n p q r s
359        | n == 0    = m
360        | n > 3000  = case p of { (p1,p2) -> foo (n-1) (p2,p1) q r s }
361        | n > 2000  = case q of { (q1,q2) -> foo (n-1) p (q2,q1) r s }
362        | n > 1000  = case r of { (r1,r2) -> foo (n-1) p q (r2,r1) s }
363        | otherwise = case s of { (s1,s2) -> foo (n-1) p q r (s2,s1) }
364
365 If we start with the RHSs of 'foo', we get lots and lots of specialisations,
366 most of which are not needed.  But if we start with the (single) call
367 in the rhs of 'bar' we get exactly one fully-specialised copy, and all
368 the recursive calls go to this fully-specialised copy. Indeed, the original
369 function is later collected as dead code.  This is very important in 
370 specialising the loops arising from stream fusion, for example in NDP where
371 we were getting literally hundreds of (mostly unused) specialisations of
372 a local function.
373
374 Note [Do not specialise diverging functions]
375 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
376 Specialising a function that just diverges is a waste of code.
377 Furthermore, it broke GHC (simpl014) thus:
378    {-# STR Sb #-}
379    f = \x. case x of (a,b) -> f x
380 If we specialise f we get
381    f = \x. case x of (a,b) -> fspec a b
382 But fspec doesn't have decent strictnes info.  As it happened,
383 (f x) :: IO t, so the state hack applied and we eta expanded fspec,
384 and hence f.  But now f's strictness is less than its arity, which
385 breaks an invariant.
386
387 Note [Forcing specialisation]
388 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
389 With stream fusion and in other similar cases, we want to fully specialise
390 some (but not necessarily all!) loops regardless of their size and the
391 number of specialisations. We allow a library to specify this by annotating
392 a type with ForceSpecConstr and then adding a parameter of that type to the
393 loop. Here is a (simplified) example from the vector library:
394
395   data SPEC = SPEC | SPEC2
396   {-# ANN type SPEC ForceSpecConstr #-}
397
398   foldl :: (a -> b -> a) -> a -> Stream b -> a
399   {-# INLINE foldl #-}
400   foldl f z (Stream step s _) = foldl_loop SPEC z s
401     where
402       foldl_loop SPEC z s = case step s of
403                               Yield x s' -> foldl_loop SPEC (f z x) s'
404                               Skip       -> foldl_loop SPEC z s'
405                               Done       -> z
406
407 SpecConstr will spot the SPEC parameter and always fully specialise
408 foldl_loop. Note that we can't just annotate foldl_loop since it isn't a
409 top-level function but even if we could, inlining etc. could easily drop the
410 annotation. We also have to prevent the SPEC argument from being removed by
411 w/w which is why SPEC is a sum type. This is all quite ugly; we ought to come
412 up with a better design.
413
414 ForceSpecConstr arguments are spotted in scExpr' and scTopBinds which then set
415 force_spec to True when calling specLoop. This flag makes specLoop and
416 specialise ignore specConstrCount and specConstrThreshold when deciding
417 whether to specialise a function.
418
419 -----------------------------------------------------
420                 Stuff not yet handled
421 -----------------------------------------------------
422
423 Here are notes arising from Roman's work that I don't want to lose.
424
425 Example 1
426 ~~~~~~~~~
427     data T a = T !a
428
429     foo :: Int -> T Int -> Int
430     foo 0 t = 0
431     foo x t | even x    = case t of { T n -> foo (x-n) t }
432             | otherwise = foo (x-1) t
433
434 SpecConstr does no specialisation, because the second recursive call
435 looks like a boxed use of the argument.  A pity.
436
437     $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
438     $wfoo_sFw =
439       \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) ->
440          case ww_sFo of ds_Xw6 [Just L] {
441            __DEFAULT ->
442                 case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] {
443                   __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq;
444                   0 ->
445                     case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] ->
446                     case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] ->
447                     $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy
448                     } } };
449            0 -> 0
450
451 Example 2
452 ~~~~~~~~~
453     data a :*: b = !a :*: !b
454     data T a = T !a
455
456     foo :: (Int :*: T Int) -> Int
457     foo (0 :*: t) = 0
458     foo (x :*: t) | even x    = case t of { T n -> foo ((x-n) :*: t) }
459                   | otherwise = foo ((x-1) :*: t)
460
461 Very similar to the previous one, except that the parameters are now in
462 a strict tuple. Before SpecConstr, we have
463
464     $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
465     $wfoo_sG3 =
466       \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T
467     GHC.Base.Int) ->
468         case ww_sFU of ds_Xws [Just L] {
469           __DEFAULT ->
470         case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] {
471           __DEFAULT ->
472             case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] ->
473             $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2             -- $wfoo1
474             };
475           0 ->
476             case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] ->
477             case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] ->
478             $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB        -- $wfoo2
479             } } };
480           0 -> 0 }
481
482 We get two specialisations:
483 "SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#}
484                   Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB)
485                   = Foo.$s$wfoo1 a_sFB sc_sGC ;
486 "SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#}
487                   Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp))
488                   = Foo.$s$wfoo y_aFp sc_sGC ;
489
490 But perhaps the first one isn't good.  After all, we know that tpl_B2 is
491 a T (I# x) really, because T is strict and Int has one constructor.  (We can't
492 unbox the strict fields, becuase T is polymorphic!)
493
494 %************************************************************************
495 %*                                                                      *
496 \subsection{Annotations}
497 %*                                                                      *
498 %************************************************************************
499
500 Annotating a type with NoSpecConstr will make SpecConstr not specialise
501 for arguments of that type.
502
503 \begin{code}
504 data SpecConstrAnnotation = NoSpecConstr | ForceSpecConstr
505                 deriving( Data, Typeable, Eq )
506 \end{code}
507
508 %************************************************************************
509 %*                                                                      *
510 \subsection{Top level wrapper stuff}
511 %*                                                                      *
512 %************************************************************************
513
514 \begin{code}
515 specConstrProgram :: ModGuts -> CoreM ModGuts
516 specConstrProgram guts
517   = do
518       dflags <- getDynFlags
519       us     <- getUniqueSupplyM
520       annos  <- getFirstAnnotations deserializeWithData guts
521       let binds' = fst $ initUs us (go (initScEnv dflags annos) (mg_binds guts))
522       return (guts { mg_binds = binds' })
523   where
524     go _   []           = return []
525     go env (bind:binds) = do (env', bind') <- scTopBind env bind
526                              binds' <- go env' binds
527                              return (bind' : binds')
528 \end{code}
529
530
531 %************************************************************************
532 %*                                                                      *
533 \subsection{Environment: goes downwards}
534 %*                                                                      *
535 %************************************************************************
536
537 \begin{code}
538 data ScEnv = SCE { sc_size  :: Maybe Int,       -- Size threshold
539                    sc_count :: Maybe Int,       -- Max # of specialisations for any one fn
540                                                 -- See Note [Avoiding exponential blowup]
541
542                    sc_subst :: Subst,           -- Current substitution
543                                                 -- Maps InIds to OutExprs
544
545                    sc_how_bound :: HowBoundEnv,
546                         -- Binds interesting non-top-level variables
547                         -- Domain is OutVars (*after* applying the substitution)
548
549                    sc_vals  :: ValueEnv,
550                         -- Domain is OutIds (*after* applying the substitution)
551                         -- Used even for top-level bindings (but not imported ones)
552
553                    sc_annotations :: UniqFM SpecConstrAnnotation
554              }
555
556 ---------------------
557 -- As we go, we apply a substitution (sc_subst) to the current term
558 type InExpr = CoreExpr          -- _Before_ applying the subst
559 type InVar  = Var
560
561 type OutExpr = CoreExpr         -- _After_ applying the subst
562 type OutId   = Id
563 type OutVar  = Var
564
565 ---------------------
566 type HowBoundEnv = VarEnv HowBound      -- Domain is OutVars
567
568 ---------------------
569 type ValueEnv = IdEnv Value             -- Domain is OutIds
570 data Value    = ConVal AltCon [CoreArg] -- _Saturated_ constructors
571               | LambdaVal               -- Inlinable lambdas or PAPs
572
573 instance Outputable Value where
574    ppr (ConVal con args) = ppr con <+> interpp'SP args
575    ppr LambdaVal         = ptext (sLit "<Lambda>")
576
577 ---------------------
578 initScEnv :: DynFlags -> UniqFM SpecConstrAnnotation -> ScEnv
579 initScEnv dflags anns
580   = SCE { sc_size = specConstrThreshold dflags,
581           sc_count = specConstrCount dflags,
582           sc_subst = emptySubst, 
583           sc_how_bound = emptyVarEnv, 
584           sc_vals = emptyVarEnv,
585           sc_annotations = anns }
586
587 data HowBound = RecFun  -- These are the recursive functions for which 
588                         -- we seek interesting call patterns
589
590               | RecArg  -- These are those functions' arguments, or their sub-components; 
591                         -- we gather occurrence information for these
592
593 instance Outputable HowBound where
594   ppr RecFun = text "RecFun"
595   ppr RecArg = text "RecArg"
596
597 lookupHowBound :: ScEnv -> Id -> Maybe HowBound
598 lookupHowBound env id = lookupVarEnv (sc_how_bound env) id
599
600 scSubstId :: ScEnv -> Id -> CoreExpr
601 scSubstId env v = lookupIdSubst (text "scSubstId") (sc_subst env) v
602
603 scSubstTy :: ScEnv -> Type -> Type
604 scSubstTy env ty = substTy (sc_subst env) ty
605
606 zapScSubst :: ScEnv -> ScEnv
607 zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) }
608
609 extendScInScope :: ScEnv -> [Var] -> ScEnv
610         -- Bring the quantified variables into scope
611 extendScInScope env qvars = env { sc_subst = extendInScopeList (sc_subst env) qvars }
612
613         -- Extend the substitution
614 extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv
615 extendScSubst env var expr = env { sc_subst = extendSubst (sc_subst env) var expr }
616
617 extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv
618 extendScSubstList env prs = env { sc_subst = extendSubstList (sc_subst env) prs }
619
620 extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv
621 extendHowBound env bndrs how_bound
622   = env { sc_how_bound = extendVarEnvList (sc_how_bound env)
623                             [(bndr,how_bound) | bndr <- bndrs] }
624
625 extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var])
626 extendBndrsWith how_bound env bndrs 
627   = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndrs')
628   where
629     (subst', bndrs') = substBndrs (sc_subst env) bndrs
630     hb_env' = sc_how_bound env `extendVarEnvList` 
631                     [(bndr,how_bound) | bndr <- bndrs']
632
633 extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var)
634 extendBndrWith how_bound env bndr 
635   = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndr')
636   where
637     (subst', bndr') = substBndr (sc_subst env) bndr
638     hb_env' = extendVarEnv (sc_how_bound env) bndr' how_bound
639
640 extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var])
641 extendRecBndrs env bndrs  = (env { sc_subst = subst' }, bndrs')
642                       where
643                         (subst', bndrs') = substRecBndrs (sc_subst env) bndrs
644
645 extendBndr :: ScEnv -> Var -> (ScEnv, Var)
646 extendBndr  env bndr  = (env { sc_subst = subst' }, bndr')
647                       where
648                         (subst', bndr') = substBndr (sc_subst env) bndr
649
650 extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv
651 extendValEnv env _  Nothing   = env
652 extendValEnv env id (Just cv) = env { sc_vals = extendVarEnv (sc_vals env) id cv }
653
654 extendCaseBndrs :: ScEnv -> Id -> AltCon -> [Var] -> (ScEnv, [Var])
655 -- When we encounter
656 --      case scrut of b
657 --          C x y -> ...
658 -- we want to bind b, to (C x y)
659 -- NB1: Extends only the sc_vals part of the envt
660 -- NB2: Kill the dead-ness info on the pattern binders x,y, since
661 --      they are potentially made alive by the [b -> C x y] binding
662 extendCaseBndrs env case_bndr con alt_bndrs
663   | isDeadBinder case_bndr
664   = (env, alt_bndrs)
665   | otherwise
666   = (env1, map zap alt_bndrs)
667         -- NB: We used to bind v too, if scrut = (Var v); but
668         --     the simplifer has already done this so it seems
669         --     redundant to do so here
670         -- case scrut of
671         --      Var v  -> extendValEnv env1 v cval
672         --      _other -> env1
673  where
674    zap v | isTyVar v = v                -- See NB2 above
675          | otherwise = zapIdOccInfo v
676    env1 = extendValEnv env case_bndr cval
677    cval = case con of
678                 DEFAULT    -> Nothing
679                 LitAlt {}  -> Just (ConVal con [])
680                 DataAlt {} -> Just (ConVal con vanilla_args)
681                       where
682                         vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
683                                        varsToCoreExprs alt_bndrs
684
685 ignoreTyCon :: ScEnv -> TyCon -> Bool
686 ignoreTyCon env tycon
687   = lookupUFM (sc_annotations env) tycon == Just NoSpecConstr
688
689 ignoreType :: ScEnv -> Type -> Bool
690 ignoreType env ty
691   = case splitTyConApp_maybe ty of
692       Just (tycon, _) -> ignoreTyCon env tycon
693       _               -> False
694
695 ignoreAltCon :: ScEnv -> AltCon -> Bool
696 ignoreAltCon env (DataAlt dc) = ignoreTyCon env (dataConTyCon dc)
697 ignoreAltCon env (LitAlt lit) = ignoreType env (literalType lit)
698 ignoreAltCon _   DEFAULT      = True
699
700 forceSpecBndr :: ScEnv -> Var -> Bool
701 forceSpecBndr env var = forceSpecFunTy env . snd . splitForAllTys . varType $ var
702
703 forceSpecFunTy :: ScEnv -> Type -> Bool
704 forceSpecFunTy env = any (forceSpecArgTy env) . fst . splitFunTys
705
706 forceSpecArgTy :: ScEnv -> Type -> Bool
707 forceSpecArgTy env ty
708   | Just ty' <- coreView ty = forceSpecArgTy env ty'
709
710 forceSpecArgTy env ty
711   | Just (tycon, tys) <- splitTyConApp_maybe ty
712   , tycon /= funTyCon
713       = lookupUFM (sc_annotations env) tycon == Just ForceSpecConstr
714         || any (forceSpecArgTy env) tys
715
716 forceSpecArgTy _ _ = False
717
718 decreaseSpecCount :: ScEnv -> Int -> ScEnv
719 -- See Note [Avoiding exponential blowup]
720 decreaseSpecCount env n_specs 
721   = env { sc_count = case sc_count env of
722                        Nothing -> Nothing
723                        Just n  -> Just (n `div` (n_specs + 1)) }
724         -- The "+1" takes account of the original function; 
725         -- See Note [Avoiding exponential blowup]
726 \end{code}
727
728 Note [Avoiding exponential blowup]
729 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
730 The sc_count field of the ScEnv says how many times we are prepared to
731 duplicate a single function.  But we must take care with recursive
732 specialiations.  Consider
733
734         let $j1 = let $j2 = let $j3 = ...
735                             in 
736                             ...$j3...
737                   in 
738                   ...$j2...
739         in 
740         ...$j1...
741
742 If we specialise $j1 then in each specialisation (as well as the original)
743 we can specialise $j2, and similarly $j3.  Even if we make just *one*
744 specialisation of each, becuase we also have the original we'll get 2^n
745 copies of $j3, which is not good.
746
747 So when recursively specialising we divide the sc_count by the number of
748 copies we are making at this level, including the original.
749
750
751 %************************************************************************
752 %*                                                                      *
753 \subsection{Usage information: flows upwards}
754 %*                                                                      *
755 %************************************************************************
756
757 \begin{code}
758 data ScUsage
759    = SCU {
760         scu_calls :: CallEnv,           -- Calls
761                                         -- The functions are a subset of the 
762                                         --      RecFuns in the ScEnv
763
764         scu_occs :: !(IdEnv ArgOcc)     -- Information on argument occurrences
765      }                                  -- The domain is OutIds
766
767 type CallEnv = IdEnv [Call]
768 type Call = (ValueEnv, [CoreArg])
769         -- The arguments of the call, together with the
770         -- env giving the constructor bindings at the call site
771
772 nullUsage :: ScUsage
773 nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv }
774
775 combineCalls :: CallEnv -> CallEnv -> CallEnv
776 combineCalls = plusVarEnv_C (++)
777
778 combineUsage :: ScUsage -> ScUsage -> ScUsage
779 combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2),
780                            scu_occs  = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) }
781
782 combineUsages :: [ScUsage] -> ScUsage
783 combineUsages [] = nullUsage
784 combineUsages us = foldr1 combineUsage us
785
786 lookupOcc :: ScUsage -> OutVar -> (ScUsage, ArgOcc)
787 lookupOcc (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndr
788   = (SCU {scu_calls = sc_calls, scu_occs = delVarEnv sc_occs bndr},
789      lookupVarEnv sc_occs bndr `orElse` NoOcc)
790
791 lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc])
792 lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs
793   = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs},
794      [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs])
795
796 data ArgOcc = NoOcc     -- Doesn't occur at all; or a type argument
797             | UnkOcc    -- Used in some unknown way
798
799             | ScrutOcc (UniqFM [ArgOcc])        -- See Note [ScrutOcc]
800
801             | BothOcc   -- Definitely taken apart, *and* perhaps used in some other way
802
803 {-      Note  [ScrutOcc]
804
805 An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing,
806 is *only* taken apart or applied.
807
808   Functions, literal: ScrutOcc emptyUFM
809   Data constructors:  ScrutOcc subs,
810
811 where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components,
812 The domain of the UniqFM is the Unique of the data constructor
813
814 The [ArgOcc] is the occurrences of the *pattern-bound* components 
815 of the data structure.  E.g.
816         data T a = forall b. MkT a b (b->a)
817 A pattern binds b, x::a, y::b, z::b->a, but not 'a'!
818
819 -}
820
821 instance Outputable ArgOcc where
822   ppr (ScrutOcc xs) = ptext (sLit "scrut-occ") <> ppr xs
823   ppr UnkOcc        = ptext (sLit "unk-occ")
824   ppr BothOcc       = ptext (sLit "both-occ")
825   ppr NoOcc         = ptext (sLit "no-occ")
826
827 -- Experimentally, this vesion of combineOcc makes ScrutOcc "win", so
828 -- that if the thing is scrutinised anywhere then we get to see that
829 -- in the overall result, even if it's also used in a boxed way
830 -- This might be too agressive; see Note [Reboxing] Alternative 3
831 combineOcc :: ArgOcc -> ArgOcc -> ArgOcc
832 combineOcc NoOcc         occ           = occ
833 combineOcc occ           NoOcc         = occ
834 combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys)
835 combineOcc _occ          (ScrutOcc ys) = ScrutOcc ys
836 combineOcc (ScrutOcc xs) _occ          = ScrutOcc xs
837 combineOcc UnkOcc        UnkOcc        = UnkOcc
838 combineOcc _        _                  = BothOcc
839
840 combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]
841 combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys
842
843 setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage
844 -- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee
845 -- is a variable, and an interesting variable
846 setScrutOcc env usg (Cast e _) occ = setScrutOcc env usg e occ
847 setScrutOcc env usg (Note _ e) occ = setScrutOcc env usg e occ
848 setScrutOcc env usg (Var v)    occ
849   | Just RecArg <- lookupHowBound env v = usg { scu_occs = extendVarEnv (scu_occs usg) v occ }
850   | otherwise                           = usg
851 setScrutOcc _env usg _other _occ        -- Catch-all
852   = usg 
853
854 conArgOccs :: ArgOcc -> AltCon -> [ArgOcc]
855 -- Find usage of components of data con; returns [UnkOcc...] if unknown
856 -- See Note [ScrutOcc] for the extra UnkOccs in the vanilla datacon case
857
858 conArgOccs (ScrutOcc fm) (DataAlt dc) 
859   | Just pat_arg_occs <- lookupUFM fm dc
860   = [UnkOcc | _ <- dataConUnivTyVars dc] ++ pat_arg_occs
861
862 conArgOccs _other _con = repeat UnkOcc
863 \end{code}
864
865 %************************************************************************
866 %*                                                                      *
867 \subsection{The main recursive function}
868 %*                                                                      *
869 %************************************************************************
870
871 The main recursive function gathers up usage information, and
872 creates specialised versions of functions.
873
874 \begin{code}
875 scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
876         -- The unique supply is needed when we invent
877         -- a new name for the specialised function and its args
878
879 scExpr env e = scExpr' env e
880
881
882 scExpr' env (Var v)     = case scSubstId env v of
883                             Var v' -> return (varUsage env v' UnkOcc, Var v')
884                             e'     -> scExpr (zapScSubst env) e'
885
886 scExpr' env (Type t)    = return (nullUsage, Type (scSubstTy env t))
887 scExpr' _   e@(Lit {})  = return (nullUsage, e)
888 scExpr' env (Note n e)  = do (usg,e') <- scExpr env e
889                              return (usg, Note n e')
890 scExpr' env (Cast e co) = do (usg, e') <- scExpr env e
891                              return (usg, Cast e' (scSubstTy env co))
892 scExpr' env e@(App _ _) = scApp env (collectArgs e)
893 scExpr' env (Lam b e)   = do let (env', b') = extendBndr env b
894                              (usg, e') <- scExpr env' e
895                              return (usg, Lam b' e')
896
897 scExpr' env (Case scrut b ty alts) 
898   = do  { (scrut_usg, scrut') <- scExpr env scrut
899         ; case isValue (sc_vals env) scrut' of
900                 Just (ConVal con args) -> sc_con_app con args scrut'
901                 _other                 -> sc_vanilla scrut_usg scrut'
902         }
903   where
904     sc_con_app con args scrut'  -- Known constructor; simplify
905         = do { let (_, bs, rhs) = findAlt con alts
906                                   `orElse` (DEFAULT, [], mkImpossibleExpr (coreAltsType alts))
907                    alt_env'  = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)
908              ; scExpr alt_env' rhs }
909                                 
910     sc_vanilla scrut_usg scrut' -- Normal case
911      = do { let (alt_env,b') = extendBndrWith RecArg env b
912                         -- Record RecArg for the components
913
914           ; (alt_usgs, alt_occs, alts')
915                 <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts
916
917           ; let (alt_usg, b_occ) = lookupOcc (combineUsages alt_usgs) b'
918                 scrut_occ        = foldr combineOcc b_occ alt_occs
919                 scrut_usg'       = setScrutOcc env scrut_usg scrut' scrut_occ
920                 -- The combined usage of the scrutinee is given
921                 -- by scrut_occ, which is passed to scScrut, which
922                 -- in turn treats a bare-variable scrutinee specially
923
924           ; return (alt_usg `combineUsage` scrut_usg',
925                     Case scrut' b' (scSubstTy env ty) alts') }
926
927     sc_alt env _scrut' b' (con,bs,rhs)
928       = do { let (env1, bs1)  = extendBndrsWith RecArg env bs
929                  (env2, bs2) = extendCaseBndrs env1 b' con bs1
930            ; (usg,rhs') <- scExpr env2 rhs
931            ; let (usg', arg_occs) = lookupOccs usg bs2
932                  scrut_occ = case con of
933                                 DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)
934                                 _          -> ScrutOcc emptyUFM
935            ; return (usg', scrut_occ, (con, bs2, rhs')) }
936
937 scExpr' env (Let (NonRec bndr rhs) body)
938   | isTyVar bndr        -- Type-lets may be created by doBeta
939   = scExpr' (extendScSubst env bndr rhs) body
940
941   | otherwise              -- Note [Local let bindings]
942   = do  { let (body_env, bndr') = extendBndr env bndr
943               body_env2 = extendHowBound body_env [bndr'] RecFun
944         ; (body_usg, body') <- scExpr body_env2 body
945
946         ; (rhs_usg, rhs_info) <- scRecRhs env (bndr',rhs)
947
948           -- NB: We don't use the ForceSpecConstr mechanism (see
949           -- Note [Forcing specialisation]) for non-recursive bindings
950           -- at the moment. I'm not sure if this is the right thing to do.
951         ; let force_spec = False
952         ; (spec_usg, specs) <- specialise env force_spec 
953                                           (scu_calls body_usg) 
954                                           rhs_info
955                                           (SI [] 0 (Just rhs_usg))
956
957         ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' } 
958                     `combineUsage` spec_usg,
959                   mkLets [NonRec b r | (b,r) <- specInfoBinds rhs_info specs] body')
960         }
961
962
963 -- A *local* recursive group: see Note [Local recursive groups]
964 scExpr' env (Let (Rec prs) body)
965   = do  { let (bndrs,rhss) = unzip prs
966               (rhs_env1,bndrs') = extendRecBndrs env bndrs
967               rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
968               force_spec = any (forceSpecBndr env) bndrs'
969                 -- Note [Forcing specialisation]
970
971         ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
972         ; (body_usg, body')     <- scExpr rhs_env2 body
973
974         -- NB: start specLoop from body_usg
975         ; (spec_usg, specs) <- specLoop rhs_env2 force_spec
976                                         (scu_calls body_usg) rhs_infos nullUsage
977                                         [SI [] 0 (Just usg) | usg <- rhs_usgs]
978                 -- Do not unconditionally use rhs_usgs. 
979                 -- Instead use them only if we find an unspecialised call
980                 -- See Note [Local recursive groups]
981
982         ; let all_usg = spec_usg `combineUsage` body_usg
983               bind'   = Rec (concat (zipWith specInfoBinds rhs_infos specs))
984
985         ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' },
986                   Let bind' body') }
987 \end{code}
988
989 Note [Local let bindings]
990 ~~~~~~~~~~~~~~~~~~~~~~~~~
991 It is not uncommon to find this
992
993    let $j = \x. <blah> in ...$j True...$j True...
994
995 Here $j is an arbitrary let-bound function, but it often comes up for
996 join points.  We might like to specialise $j for its call patterns.
997 Notice the difference from a letrec, where we look for call patterns
998 in the *RHS* of the function.  Here we look for call patterns in the
999 *body* of the let.
1000
1001 At one point I predicated this on the RHS mentioning the outer
1002 recursive function, but that's not essential and might even be
1003 harmful.  I'm not sure.
1004
1005
1006 \begin{code}
1007 scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)
1008
1009 scApp env (Var fn, args)        -- Function is a variable
1010   = ASSERT( not (null args) )
1011     do  { args_w_usgs <- mapM (scExpr env) args
1012         ; let (arg_usgs, args') = unzip args_w_usgs
1013               arg_usg = combineUsages arg_usgs
1014         ; case scSubstId env fn of
1015             fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args')
1016                         -- Do beta-reduction and try again
1017
1018             Var fn' -> return (arg_usg `combineUsage` fn_usg, mkApps (Var fn') args')
1019                 where
1020                   fn_usg = case lookupHowBound env fn' of
1021                                 Just RecFun -> SCU { scu_calls = unitVarEnv fn' [(sc_vals env, args')], 
1022                                                      scu_occs  = emptyVarEnv }
1023                                 Just RecArg -> SCU { scu_calls = emptyVarEnv,
1024                                                      scu_occs  = unitVarEnv fn' (ScrutOcc emptyUFM) }
1025                                 Nothing     -> nullUsage
1026
1027
1028             other_fn' -> return (arg_usg, mkApps other_fn' args') }
1029                 -- NB: doing this ignores any usage info from the substituted
1030                 --     function, but I don't think that matters.  If it does
1031                 --     we can fix it.
1032   where
1033     doBeta :: OutExpr -> [OutExpr] -> OutExpr
1034     -- ToDo: adjust for System IF
1035     doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args)
1036     doBeta fn              args         = mkApps fn args
1037
1038 -- The function is almost always a variable, but not always.  
1039 -- In particular, if this pass follows float-in,
1040 -- which it may, we can get 
1041 --      (let f = ...f... in f) arg1 arg2
1042 scApp env (other_fn, args)
1043   = do  { (fn_usg,   fn')   <- scExpr env other_fn
1044         ; (arg_usgs, args') <- mapAndUnzipM (scExpr env) args
1045         ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') }
1046
1047 ----------------------
1048 scTopBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind)
1049 scTopBind env (Rec prs)
1050   | Just threshold <- sc_size env
1051   , not force_spec
1052   , not (all (couldBeSmallEnoughToInline threshold) rhss)
1053                 -- No specialisation
1054   = do  { let (rhs_env,bndrs') = extendRecBndrs env bndrs
1055         ; (_, rhss') <- mapAndUnzipM (scExpr rhs_env) rhss
1056         ; return (rhs_env, Rec (bndrs' `zip` rhss')) }
1057   | otherwise   -- Do specialisation
1058   = do  { let (rhs_env1,bndrs') = extendRecBndrs env bndrs
1059               rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
1060
1061         ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
1062         ; let rhs_usg = combineUsages rhs_usgs
1063
1064         ; (_, specs) <- specLoop rhs_env2 force_spec
1065                                  (scu_calls rhs_usg) rhs_infos nullUsage
1066                                  [SI [] 0 Nothing | _ <- bndrs]
1067
1068         ; return (rhs_env1,  -- For the body of the letrec, delete the RecFun business
1069                   Rec (concat (zipWith specInfoBinds rhs_infos specs))) }
1070   where
1071     (bndrs,rhss) = unzip prs
1072     force_spec = any (forceSpecBndr env) bndrs
1073       -- Note [Forcing specialisation]
1074
1075 scTopBind env (NonRec bndr rhs)
1076   = do  { (_, rhs') <- scExpr env rhs
1077         ; let (env1, bndr') = extendBndr env bndr
1078               env2 = extendValEnv env1 bndr' (isValue (sc_vals env) rhs')
1079         ; return (env2, NonRec bndr' rhs') }
1080
1081 ----------------------
1082 scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM (ScUsage, RhsInfo)
1083 scRecRhs env (bndr,rhs)
1084   = do  { let (arg_bndrs,body) = collectBinders rhs
1085               (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs
1086         ; (body_usg, body') <- scExpr body_env body
1087         ; let (rhs_usg, arg_occs) = lookupOccs body_usg arg_bndrs'
1088         ; return (rhs_usg, RI bndr (mkLams arg_bndrs' body')
1089                                    arg_bndrs body arg_occs) }
1090                 -- The arg_occs says how the visible,
1091                 -- lambda-bound binders of the RHS are used
1092                 -- (including the TyVar binders)
1093                 -- Two pats are the same if they match both ways
1094
1095 ----------------------
1096 specInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)]
1097 specInfoBinds (RI fn new_rhs _ _ _) (SI specs _ _)
1098   = [(id,rhs) | OS _ _ id rhs <- specs] ++ 
1099     [(fn `addIdSpecialisations` rules, new_rhs)]
1100   where
1101     rules = [r | OS _ r _ _ <- specs]
1102
1103 ----------------------
1104 varUsage :: ScEnv -> OutVar -> ArgOcc -> ScUsage
1105 varUsage env v use 
1106   | Just RecArg <- lookupHowBound env v = SCU { scu_calls = emptyVarEnv 
1107                                               , scu_occs = unitVarEnv v use }
1108   | otherwise                           = nullUsage
1109 \end{code}
1110
1111
1112 %************************************************************************
1113 %*                                                                      *
1114                 The specialiser itself
1115 %*                                                                      *
1116 %************************************************************************
1117
1118 \begin{code}
1119 data RhsInfo = RI OutId                 -- The binder
1120                   OutExpr               -- The new RHS
1121                   [InVar] InExpr        -- The *original* RHS (\xs.body)
1122                                         --   Note [Specialise original body]
1123                   [ArgOcc]              -- Info on how the xs occur in body
1124
1125 data SpecInfo = SI [OneSpec]            -- The specialisations we have generated
1126
1127                    Int                  -- Length of specs; used for numbering them
1128
1129                    (Maybe ScUsage)      -- Nothing => we have generated specialisations
1130                                         --            from calls in the *original* RHS
1131                                         -- Just cs => we haven't, and this is the usage
1132                                         --            of the original RHS
1133                                         -- See Note [Local recursive groups]
1134
1135         -- One specialisation: Rule plus definition
1136 data OneSpec  = OS CallPat              -- Call pattern that generated this specialisation
1137                    CoreRule             -- Rule connecting original id with the specialisation
1138                    OutId OutExpr        -- Spec id + its rhs
1139
1140
1141 specLoop :: ScEnv
1142          -> Bool                                -- force specialisation?
1143                                                 -- Note [Forcing specialisation]
1144          -> CallEnv
1145          -> [RhsInfo]
1146          -> ScUsage -> [SpecInfo]               -- One per binder; acccumulating parameter
1147          -> UniqSM (ScUsage, [SpecInfo])        -- ...ditto...
1148 specLoop env force_spec all_calls rhs_infos usg_so_far specs_so_far
1149   = do  { specs_w_usg <- zipWithM (specialise env force_spec all_calls) rhs_infos specs_so_far
1150         ; let (new_usg_s, all_specs) = unzip specs_w_usg
1151               new_usg   = combineUsages new_usg_s
1152               new_calls = scu_calls new_usg
1153               all_usg   = usg_so_far `combineUsage` new_usg
1154         ; if isEmptyVarEnv new_calls then
1155                 return (all_usg, all_specs) 
1156           else 
1157                 specLoop env force_spec new_calls rhs_infos all_usg all_specs }
1158
1159 specialise 
1160    :: ScEnv
1161    -> Bool                              -- force specialisation?
1162                                         --   Note [Forcing specialisation]
1163    -> CallEnv                           -- Info on calls
1164    -> RhsInfo
1165    -> SpecInfo                          -- Original RHS plus patterns dealt with
1166    -> UniqSM (ScUsage, SpecInfo)        -- New specialised versions and their usage
1167
1168 -- Note: the rhs here is the optimised version of the original rhs
1169 -- So when we make a specialised copy of the RHS, we're starting
1170 -- from an RHS whose nested functions have been optimised already.
1171
1172 specialise env force_spec bind_calls (RI fn _ arg_bndrs body arg_occs) 
1173                           spec_info@(SI specs spec_count mb_unspec)
1174   | not (isBottomingId fn)      -- Note [Do not specialise diverging functions]
1175   , notNull arg_bndrs           -- Only specialise functions
1176   , Just all_calls <- lookupVarEnv bind_calls fn
1177   = do  { (boring_call, pats) <- callsToPats env specs arg_occs all_calls
1178 --      ; pprTrace "specialise" (vcat [ ppr fn <+> text "with" <+> int (length pats) <+> text "good patterns"
1179 --                                      , text "arg_occs" <+> ppr arg_occs
1180 --                                    , text "calls" <+> ppr all_calls
1181 --                                    , text "good pats" <+> ppr pats])  $
1182 --        return ()
1183
1184                 -- Bale out if too many specialisations
1185         ; let n_pats      = length pats
1186               spec_count' = n_pats + spec_count
1187         ; case sc_count env of
1188             Just max | not force_spec && spec_count' > max
1189                 -> pprTrace "SpecConstr" msg $  
1190                    return (nullUsage, spec_info)
1191                 where
1192                    msg = vcat [ sep [ ptext (sLit "Function") <+> quotes (ppr fn)
1193                                     , nest 2 (ptext (sLit "has") <+> 
1194                                               speakNOf spec_count' (ptext (sLit "call pattern")) <> comma <+>
1195                                               ptext (sLit "but the limit is") <+> int max) ]
1196                               , ptext (sLit "Use -fspec-constr-count=n to set the bound")
1197                               , extra ]
1198                    extra | not opt_PprStyle_Debug = ptext (sLit "Use -dppr-debug to see specialisations")
1199                          | otherwise = ptext (sLit "Specialisations:") <+> ppr (pats ++ [p | OS p _ _ _ <- specs])
1200
1201             _normal_case -> do {
1202
1203           let spec_env = decreaseSpecCount env n_pats
1204         ; (spec_usgs, new_specs) <- mapAndUnzipM (spec_one spec_env fn arg_bndrs body)
1205                                                  (pats `zip` [spec_count..])
1206                 -- See Note [Specialise original body]
1207
1208         ; let spec_usg = combineUsages spec_usgs
1209               (new_usg, mb_unspec')
1210                   = case mb_unspec of
1211                       Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing)
1212                       _                          -> (spec_usg,                      mb_unspec)
1213             
1214         ; return (new_usg, SI (new_specs ++ specs) spec_count' mb_unspec') } }
1215   | otherwise
1216   = return (nullUsage, spec_info)               -- The boring case
1217
1218
1219 ---------------------
1220 spec_one :: ScEnv
1221          -> OutId       -- Function
1222          -> [InVar]     -- Lambda-binders of RHS; should match patterns
1223          -> InExpr      -- Body of the original function
1224          -> (CallPat, Int)
1225          -> UniqSM (ScUsage, OneSpec)   -- Rule and binding
1226
1227 -- spec_one creates a specialised copy of the function, together
1228 -- with a rule for using it.  I'm very proud of how short this
1229 -- function is, considering what it does :-).
1230
1231 {- 
1232   Example
1233   
1234      In-scope: a, x::a   
1235      f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
1236           [c::*, v::(b,c) are presumably bound by the (...) part]
1237   ==>
1238      f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
1239                   (...entire body of f...) [b -> (b,c), 
1240                                             y -> ((:) (a,(b,c)) (x,v) hw)]
1241   
1242      RULE:  forall b::* c::*,           -- Note, *not* forall a, x
1243                    v::(b,c),
1244                    hw::[(a,(b,c))] .
1245   
1246             f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
1247 -}
1248
1249 spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)
1250   = do  { spec_uniq <- getUniqueUs
1251         ; let spec_env = extendScSubstList (extendScInScope env qvars)
1252                                            (arg_bndrs `zip` pats)
1253               fn_name    = idName fn
1254               fn_loc     = nameSrcSpan fn_name
1255               spec_occ   = mkSpecOcc (nameOccName fn_name)
1256               rule_name  = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number))
1257               spec_name  = mkInternalName spec_uniq spec_occ fn_loc
1258 --      ; pprTrace "{spec_one" (ppr (sc_count env) <+> ppr fn <+> ppr pats <+> text "-->" <+> ppr spec_name) $ 
1259 --        return ()
1260
1261         -- Specialise the body
1262         ; (spec_usg, spec_body) <- scExpr spec_env body
1263
1264 --      ; pprTrace "done spec_one}" (ppr fn) $ 
1265 --        return ()
1266
1267                 -- And build the results
1268         ; let spec_id = mkLocalId spec_name (mkPiTypes spec_lam_args body_ty) 
1269                              `setIdStrictness` spec_str         -- See Note [Transfer strictness]
1270                              `setIdArity` count isId spec_lam_args
1271               spec_str   = calcSpecStrictness fn spec_lam_args pats
1272               (spec_lam_args, spec_call_args) = mkWorkerArgs qvars body_ty
1273                 -- Usual w/w hack to avoid generating 
1274                 -- a spec_rhs of unlifted type and no args
1275
1276               spec_rhs   = mkLams spec_lam_args spec_body
1277               body_ty    = exprType spec_body
1278               rule_rhs   = mkVarApps (Var spec_id) spec_call_args
1279               inline_act = idInlineActivation fn
1280               rule       = mkLocalRule rule_name inline_act fn_name qvars pats rule_rhs
1281         ; return (spec_usg, OS call_pat rule spec_id spec_rhs) }
1282
1283 calcSpecStrictness :: Id                     -- The original function
1284                    -> [Var] -> [CoreExpr]    -- Call pattern
1285                    -> StrictSig              -- Strictness of specialised thing
1286 -- See Note [Transfer strictness]
1287 calcSpecStrictness fn qvars pats
1288   = StrictSig (mkTopDmdType spec_dmds TopRes)
1289   where
1290     spec_dmds = [ lookupVarEnv dmd_env qv `orElse` lazyDmd | qv <- qvars, isId qv ]
1291     StrictSig (DmdType _ dmds _) = idStrictness fn
1292
1293     dmd_env = go emptyVarEnv dmds pats
1294
1295     go env ds (Type {} : pats) = go env ds pats
1296     go env (d:ds) (pat : pats) = go (go_one env d pat) ds pats
1297     go env _      _            = env
1298
1299     go_one env d   (Var v) = extendVarEnv_C both env v d
1300     go_one env (Box d)   e = go_one env d e
1301     go_one env (Eval (Prod ds)) e 
1302            | (Var _, args) <- collectArgs e = go env ds args
1303     go_one env _         _ = env
1304
1305 \end{code}
1306
1307 Note [Specialise original body]
1308 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1309 The RhsInfo for a binding keeps the *original* body of the binding.  We
1310 must specialise that, *not* the result of applying specExpr to the RHS
1311 (which is also kept in RhsInfo). Otherwise we end up specialising a
1312 specialised RHS, and that can lead directly to exponential behaviour.
1313
1314 Note [Transfer activation]
1315 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1316 In which phase should the specialise-constructor rules be active?
1317 Originally I made them always-active, but Manuel found that this
1318 defeated some clever user-written rules.  Then I made them active only
1319 in Phase 0; after all, currently, the specConstr transformation is
1320 only run after the simplifier has reached Phase 0, but that meant
1321 that specialisations didn't fire inside wrappers; see test
1322 simplCore/should_compile/spec-inline.
1323
1324 So now I just use the inline-activation of the parent Id, as the
1325 activation for the specialiation RULE, just like the main specialiser;
1326 see Note [Auto-specialisation and RULES] in Specialise.
1327
1328
1329 Note [Transfer strictness]
1330 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1331 We must transfer strictness information from the original function to
1332 the specialised one.  Suppose, for example
1333
1334   f has strictness     SS
1335         and a RULE     f (a:as) b = f_spec a as b
1336
1337 Now we want f_spec to have strictess  LLS, otherwise we'll use call-by-need
1338 when calling f_spec instead of call-by-value.  And that can result in 
1339 unbounded worsening in space (cf the classic foldl vs foldl')
1340
1341 See Trac #3437 for a good example.
1342
1343 The function calcSpecStrictness performs the calculation.
1344
1345
1346 %************************************************************************
1347 %*                                                                      *
1348 \subsection{Argument analysis}
1349 %*                                                                      *
1350 %************************************************************************
1351
1352 This code deals with analysing call-site arguments to see whether
1353 they are constructor applications.
1354
1355
1356 \begin{code}
1357 type CallPat = ([Var], [CoreExpr])      -- Quantified variables and arguments
1358
1359
1360 callsToPats :: ScEnv -> [OneSpec] -> [ArgOcc] -> [Call] -> UniqSM (Bool, [CallPat])
1361         -- Result has no duplicate patterns, 
1362         -- nor ones mentioned in done_pats
1363         -- Bool indicates that there was at least one boring pattern
1364 callsToPats env done_specs bndr_occs calls
1365   = do  { mb_pats <- mapM (callToPats env bndr_occs) calls
1366
1367         ; let good_pats :: [([Var], [CoreArg])]
1368               good_pats = catMaybes mb_pats
1369               done_pats = [p | OS p _ _ _ <- done_specs] 
1370               is_done p = any (samePat p) done_pats
1371
1372         ; return (any isNothing mb_pats, 
1373                   filterOut is_done (nubBy samePat good_pats)) }
1374
1375 callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
1376         -- The [Var] is the variables to quantify over in the rule
1377         --      Type variables come first, since they may scope 
1378         --      over the following term variables
1379         -- The [CoreExpr] are the argument patterns for the rule
1380 callToPats env bndr_occs (con_env, args)
1381   | length args < length bndr_occs      -- Check saturated
1382   = return Nothing
1383   | otherwise
1384   = do  { let in_scope = substInScope (sc_subst env)
1385         ; prs <- argsToPats env in_scope con_env (args `zip` bndr_occs)
1386         ; let (interesting_s, pats) = unzip prs
1387               pat_fvs = varSetElems (exprsFreeVars pats)
1388               qvars   = filterOut (`elemInScopeSet` in_scope) pat_fvs
1389                 -- Quantify over variables that are not in sccpe
1390                 -- at the call site
1391                 -- See Note [Shadowing] at the top
1392                 
1393               (tvs, ids) = partition isTyVar qvars
1394               qvars'     = tvs ++ ids
1395                 -- Put the type variables first; the type of a term
1396                 -- variable may mention a type variable
1397
1398         ; -- pprTrace "callToPats"  (ppr args $$ ppr prs $$ ppr bndr_occs) $
1399           if or interesting_s
1400           then return (Just (qvars', pats))
1401           else return Nothing }
1402
1403     -- argToPat takes an actual argument, and returns an abstracted
1404     -- version, consisting of just the "constructor skeleton" of the
1405     -- argument, with non-constructor sub-expression replaced by new
1406     -- placeholder variables.  For example:
1407     --    C a (D (f x) (g y))  ==>  C p1 (D p2 p3)
1408
1409 argToPat :: ScEnv
1410          -> InScopeSet                  -- What's in scope at the fn defn site
1411          -> ValueEnv                    -- ValueEnv at the call site
1412          -> CoreArg                     -- A call arg (or component thereof)
1413          -> ArgOcc
1414          -> UniqSM (Bool, CoreArg)
1415 -- Returns (interesting, pat), 
1416 -- where pat is the pattern derived from the argument
1417 --            intersting=True if the pattern is non-trivial (not a variable or type)
1418 -- E.g.         x:xs         --> (True, x:xs)
1419 --              f xs         --> (False, w)        where w is a fresh wildcard
1420 --              (f xs, 'c')  --> (True, (w, 'c'))  where w is a fresh wildcard
1421 --              \x. x+y      --> (True, \x. x+y)
1422 --              lvl7         --> (True, lvl7)      if lvl7 is bound 
1423 --                                                 somewhere further out
1424
1425 argToPat _env _in_scope _val_env arg@(Type {}) _arg_occ
1426   = return (False, arg)
1427
1428 argToPat env in_scope val_env (Note _ arg) arg_occ
1429   = argToPat env in_scope val_env arg arg_occ
1430         -- Note [Notes in call patterns]
1431         -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1432         -- Ignore Notes.  In particular, we want to ignore any InlineMe notes
1433         -- Perhaps we should not ignore profiling notes, but I'm going to
1434         -- ride roughshod over them all for now.
1435         --- See Note [Notes in RULE matching] in Rules
1436
1437 argToPat env in_scope val_env (Let _ arg) arg_occ
1438   = argToPat env in_scope val_env arg arg_occ
1439         -- See Note [Matching lets] in Rule.lhs
1440         -- Look through let expressions
1441         -- e.g.         f (let v = rhs in (v,w))
1442         -- Here we can specialise for f (v,w)
1443         -- because the rule-matcher will look through the let.
1444
1445 {- Disabled; see Note [Matching cases] in Rule.lhs
1446 argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ
1447   | exprOkForSpeculation scrut  -- See Note [Matching cases] in Rule.hhs
1448   = argToPat env in_scope val_env rhs arg_occ
1449 -}
1450
1451 argToPat env in_scope val_env (Cast arg co) arg_occ
1452   | not (ignoreType env ty2)
1453   = do  { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ
1454         ; if not interesting then 
1455                 wildCardPat ty2
1456           else do
1457         { -- Make a wild-card pattern for the coercion
1458           uniq <- getUniqueUs
1459         ; let co_name = mkSysTvName uniq (fsLit "sg")
1460               co_var = mkCoVar co_name (mkCoKind ty1 ty2)
1461         ; return (interesting, Cast arg' (mkTyVarTy co_var)) } }
1462   where
1463     (ty1, ty2) = coercionKind co
1464
1465     
1466
1467 {-      Disabling lambda specialisation for now
1468         It's fragile, and the spec_loop can be infinite
1469 argToPat in_scope val_env arg arg_occ
1470   | is_value_lam arg
1471   = return (True, arg)
1472   where
1473     is_value_lam (Lam v e)      -- Spot a value lambda, even if 
1474         | isId v = True         -- it is inside a type lambda
1475         | otherwise = is_value_lam e
1476     is_value_lam other = False
1477 -}
1478
1479   -- Check for a constructor application
1480   -- NB: this *precedes* the Var case, so that we catch nullary constrs
1481 argToPat env in_scope val_env arg arg_occ
1482   | Just (ConVal dc args) <- isValue val_env arg
1483   , not (ignoreAltCon env dc)
1484   , case arg_occ of
1485         ScrutOcc _ -> True              -- Used only by case scrutinee
1486         BothOcc    -> case arg of       -- Used elsewhere
1487                         App {} -> True  --     see Note [Reboxing]
1488                         _other -> False
1489         _other     -> False     -- No point; the arg is not decomposed
1490   = do  { args' <- argsToPats env in_scope val_env (args `zip` conArgOccs arg_occ dc)
1491         ; return (True, mk_con_app dc (map snd args')) }
1492
1493   -- Check if the argument is a variable that 
1494   -- is in scope at the function definition site
1495   -- It's worth specialising on this if
1496   --    (a) it's used in an interesting way in the body
1497   --    (b) we know what its value is
1498 argToPat env in_scope val_env (Var v) arg_occ
1499   | case arg_occ of { UnkOcc -> False; _other -> True },        -- (a)
1500     is_value,                                                   -- (b)
1501     not (ignoreType env (varType v))
1502   = return (True, Var v)
1503   where
1504     is_value 
1505         | isLocalId v = v `elemInScopeSet` in_scope 
1506                         && isJust (lookupVarEnv val_env v)
1507                 -- Local variables have values in val_env
1508         | otherwise   = isValueUnfolding (idUnfolding v)
1509                 -- Imports have unfoldings
1510
1511 --      I'm really not sure what this comment means
1512 --      And by not wild-carding we tend to get forall'd 
1513 --      variables that are in soope, which in turn can
1514 --      expose the weakness in let-matching
1515 --      See Note [Matching lets] in Rules
1516
1517   -- Check for a variable bound inside the function. 
1518   -- Don't make a wild-card, because we may usefully share
1519   --    e.g.  f a = let x = ... in f (x,x)
1520   -- NB: this case follows the lambda and con-app cases!!
1521 -- argToPat _in_scope _val_env (Var v) _arg_occ
1522 --   = return (False, Var v)
1523         -- SLPJ : disabling this to avoid proliferation of versions
1524         -- also works badly when thinking about seeding the loop
1525         -- from the body of the let
1526         --       f x y = letrec g z = ... in g (x,y)
1527         -- We don't want to specialise for that *particular* x,y
1528
1529   -- The default case: make a wild-card
1530 argToPat _env _in_scope _val_env arg _arg_occ
1531   = wildCardPat (exprType arg)
1532
1533 wildCardPat :: Type -> UniqSM (Bool, CoreArg)
1534 wildCardPat ty = do { uniq <- getUniqueUs
1535                     ; let id = mkSysLocal (fsLit "sc") uniq ty
1536                     ; return (False, Var id) }
1537
1538 argsToPats :: ScEnv -> InScopeSet -> ValueEnv
1539            -> [(CoreArg, ArgOcc)]
1540            -> UniqSM [(Bool, CoreArg)]
1541 argsToPats env in_scope val_env args
1542   = mapM do_one args
1543   where
1544     do_one (arg,occ) = argToPat env in_scope val_env arg occ
1545 \end{code}
1546
1547
1548 \begin{code}
1549 isValue :: ValueEnv -> CoreExpr -> Maybe Value
1550 isValue _env (Lit lit)
1551   = Just (ConVal (LitAlt lit) [])
1552
1553 isValue env (Var v)
1554   | Just stuff <- lookupVarEnv env v
1555   = Just stuff  -- You might think we could look in the idUnfolding here
1556                 -- but that doesn't take account of which branch of a 
1557                 -- case we are in, which is the whole point
1558
1559   | not (isLocalId v) && isCheapUnfolding unf
1560   = isValue env (unfoldingTemplate unf)
1561   where
1562     unf = idUnfolding v
1563         -- However we do want to consult the unfolding 
1564         -- as well, for let-bound constructors!
1565
1566 isValue env (Lam b e)
1567   | isTyVar b = case isValue env e of
1568                   Just _  -> Just LambdaVal
1569                   Nothing -> Nothing
1570   | otherwise = Just LambdaVal
1571
1572 isValue _env expr       -- Maybe it's a constructor application
1573   | (Var fun, args) <- collectArgs expr
1574   = case isDataConWorkId_maybe fun of
1575
1576         Just con | args `lengthAtLeast` dataConRepArity con 
1577                 -- Check saturated; might be > because the 
1578                 --                  arity excludes type args
1579                 -> Just (ConVal (DataAlt con) args)
1580
1581         _other | valArgCount args < idArity fun
1582                 -- Under-applied function
1583                -> Just LambdaVal        -- Partial application
1584
1585         _other -> Nothing
1586
1587 isValue _env _expr = Nothing
1588
1589 mk_con_app :: AltCon -> [CoreArg] -> CoreExpr
1590 mk_con_app (LitAlt lit)  []   = Lit lit
1591 mk_con_app (DataAlt con) args = mkConApp con args
1592 mk_con_app _other _args = panic "SpecConstr.mk_con_app"
1593
1594 samePat :: CallPat -> CallPat -> Bool
1595 samePat (vs1, as1) (vs2, as2)
1596   = all2 same as1 as2
1597   where
1598     same (Var v1) (Var v2) 
1599         | v1 `elem` vs1 = v2 `elem` vs2
1600         | v2 `elem` vs2 = False
1601         | otherwise     = v1 == v2
1602
1603     same (Lit l1)    (Lit l2)    = l1==l2
1604     same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2
1605
1606     same (Type {}) (Type {}) = True     -- Note [Ignore type differences]
1607     same (Note _ e1) e2 = same e1 e2    -- Ignore casts and notes
1608     same (Cast e1 _) e2 = same e1 e2
1609     same e1 (Note _ e2) = same e1 e2
1610     same e1 (Cast e2 _) = same e1 e2
1611
1612     same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2) 
1613                  False  -- Let, lambda, case should not occur
1614     bad (Case {}) = True
1615     bad (Let {})  = True
1616     bad (Lam {})  = True
1617     bad _other    = False
1618 \end{code}
1619
1620 Note [Ignore type differences]
1621 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1622 We do not want to generate specialisations where the call patterns
1623 differ only in their type arguments!  Not only is it utterly useless,
1624 but it also means that (with polymorphic recursion) we can generate
1625 an infinite number of specialisations. Example is Data.Sequence.adjustTree, 
1626 I think.
1627