SpecConstr.lhs 48.5 KB
Newer Older
1
2
3
4
5
6
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[SpecConstr]{Specialise over constructors}

\begin{code}
7
8
9
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
Ian Lynagh's avatar
Ian Lynagh committed
10
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
11
12
-- for details

13
14
15
16
17
18
19
module SpecConstr(
	specConstrProgram	
    ) where

#include "HsVersions.h"

import CoreSyn
20
21
22
import CoreSubst
import CoreUtils
import CoreUnfold	( couldBeSmallEnoughToInline )
23
24
import CoreLint		( showPass, endPass )
import CoreFVs 		( exprsFreeVars )
25
import WwLib		( mkWorkerArgs )
26
import DataCon		( dataConRepArity, dataConUnivTyVars )
27
import Coercion	
28
import Rules
29
import Type		hiding( substTy )
30
import Id		( Id, idName, idType, isDataConWorkId_maybe, idArity,
31
			  mkUserLocal, mkSysLocal, idUnfolding, isLocalId )
32
import Var
33
34
import VarEnv
import VarSet
35
import Name
36
37
import OccName		( mkSpecOcc )
import ErrUtils		( dumpIfSet_dyn )
38
import DynFlags		( DynFlags(..), DynFlag(..) )
39
import StaticFlags	( opt_PprStyle_Debug )
40
import StaticFlags	( opt_SpecInlineJoinPoints )
41
import BasicTypes	( Activation(..) )
42
import Maybes		( orElse, catMaybes, isJust, isNothing )
43
import Util
44
45
46
import List		( nubBy, partition )
import UniqSupply
import Outputable
47
import FastString
48
import UniqFM
Ian Lynagh's avatar
Ian Lynagh committed
49
import MonadUtils
50
import Control.Monad	( zipWithM )
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
\end{code}

-----------------------------------------------------
			Game plan
-----------------------------------------------------

Consider
	drop n []     = []
	drop 0 xs     = []
	drop n (x:xs) = drop (n-1) xs

After the first time round, we could pass n unboxed.  This happens in
numerical code too.  Here's what it looks like in Core:

	drop n xs = case xs of
		      []     -> []
		      (y:ys) -> case n of 
				  I# n# -> case n# of
					     0 -> []
					     _ -> drop (I# (n# -# 1#)) xs

Notice that the recursive call has an explicit constructor as argument.
Noticing this, we can make a specialised version of drop
	
	RULE: drop (I# n#) xs ==> drop' n# xs

	drop' n# xs = let n = I# n# in ...orig RHS...

Now the simplifier will apply the specialisation in the rhs of drop', giving

	drop' n# xs = case xs of
		      []     -> []
		      (y:ys) -> case n# of
				  0 -> []
				  _ -> drop (n# -# 1#) xs

Much better!  

We'd also like to catch cases where a parameter is carried along unchanged,
but evaluated each time round the loop:

	f i n = if i>0 || i>n then i else f (i*2) n

Here f isn't strict in n, but we'd like to avoid evaluating it each iteration.
In Core, by the time we've w/wd (f is strict in i) we get

	f i# n = case i# ># 0 of
		   False -> I# i#
		   True  -> case n of n' { I# n# ->
			    case i# ># n# of
				False -> I# i#
				True  -> f (i# *# 2#) n'

At the call to f, we see that the argument, n is know to be (I# n#),
and n is evaluated elsewhere in the body of f, so we can play the same
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
trick as above.  


Note [Reboxing]
~~~~~~~~~~~~~~~
We must be careful not to allocate the same constructor twice.  Consider
	f p = (...(case p of (a,b) -> e)...p...,
	       ...let t = (r,s) in ...t...(f t)...)
At the recursive call to f, we can see that t is a pair.  But we do NOT want
to make a specialised copy:
	f' a b = let p = (a,b) in (..., ...)
because now t is allocated by the caller, then r and s are passed to the
recursive call, which allocates the (r,s) pair again.

This happens if
  (a) the argument p is used in other than a case-scrutinsation way.
  (b) the argument to the call is not a 'fresh' tuple; you have to
	look into its unfolding to see that it's a tuple

Hence the "OR" part of Note [Good arguments] below.

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
127
ALTERNATIVE 2: pass both boxed and unboxed versions.  This no longer saves
128
129
130
131
132
133
134
135
allocation, but does perhaps save evals. In the RULE we'd have
something like

  f (I# x#) = f' (I# x#) x#

If at the call site the (I# x) was an unfolding, then we'd have to
rely on CSE to eliminate the duplicate allocation.... This alternative
doesn't look attractive enough to pursue.
136

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
ALTERNATIVE 3: ignore the reboxing problem.  The trouble is that 
the conservative reboxing story prevents many useful functions from being
specialised.  Example:
	foo :: Maybe Int -> Int -> Int
	foo   (Just m) 0 = 0
	foo x@(Just m) n = foo x (n-m)
Here the use of 'x' will clearly not require boxing in the specialised function.

The strictness analyser has the same problem, in fact.  Example:
	f p@(a,b) = ...
If we pass just 'a' and 'b' to the worker, it might need to rebox the
pair to create (a,b).  A more sophisticated analysis might figure out
precisely the cases in which this could happen, but the strictness
analyser does no such analysis; it just passes 'a' and 'b', and hopes
for the best.

So my current choice is to make SpecConstr similarly aggressive, and
ignore the bad potential of reboxing.

156

157
158
Note [Good arguments]
~~~~~~~~~~~~~~~~~~~~~
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
So we look for

* A self-recursive function.  Ignore mutual recursion for now, 
  because it's less common, and the code is simpler for self-recursion.

* EITHER

   a) At a recursive call, one or more parameters is an explicit 
      constructor application
	AND
      That same parameter is scrutinised by a case somewhere in 
      the RHS of the function

  OR

    b) At a recursive call, one or more parameters has an unfolding
       that is an explicit constructor application
	AND
      That same parameter is scrutinised by a case somewhere in 
      the RHS of the function
	AND
180
      Those are the only uses of the parameter (see Note [Reboxing])
181
182


183
184
What to abstract over
~~~~~~~~~~~~~~~~~~~~~
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
There's a bit of a complication with type arguments.  If the call
site looks like

	f p = ...f ((:) [a] x xs)...

then our specialised function look like

	f_spec x xs = let p = (:) [a] x xs in ....as before....

This only makes sense if either
  a) the type variable 'a' is in scope at the top of f, or
  b) the type variable 'a' is an argument to f (and hence fs)

Actually, (a) may hold for value arguments too, in which case
we may not want to pass them.  Supose 'x' is in scope at f's
defn, but xs is not.  Then we'd like

	f_spec xs = let p = (:) [a] x xs in ....as before....

Similarly (b) may hold too.  If x is already an argument at the
call, no need to pass it again.

Finally, if 'a' is not in scope at the call site, we could abstract
it as we do the term variables:

	f_spec a x xs = let p = (:) [a] x xs in ...as before...

So the grand plan is:

	* abstract the call site to a constructor-only pattern
	  e.g.  C x (D (f p) (g q))  ==>  C s1 (D s2 s3)

	* Find the free variables of the abstracted pattern

	* Pass these variables, less any that are in scope at
220
	  the fn defn.  But see Note [Shadowing] below.
221
222
223
224
225
226
227


NOTICE that we only abstract over variables that are not in scope,
so we're in no danger of shadowing variables used in "higher up"
in f_spec's RHS.


228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
Note [Shadowing]
~~~~~~~~~~~~~~~~
In this pass we gather up usage information that may mention variables
that are bound between the usage site and the definition site; or (more
seriously) may be bound to something different at the definition site.
For example:

	f x = letrec g y v = let x = ... 
			     in ...(g (a,b) x)...

Since 'x' is in scope at the call site, we may make a rewrite rule that 
looks like
	RULE forall a,b. g (a,b) x = ...
But this rule will never match, because it's really a different 'x' at 
the call site -- and that difference will be manifest by the time the
simplifier gets to it.  [A worry: the simplifier doesn't *guarantee*
no-shadowing, so perhaps it may not be distinct?]

Anyway, the rule isn't actually wrong, it's just not useful.  One possibility
is to run deShadowBinds before running SpecConstr, but instead we run the
simplifier.  That gives the simplest possible program for SpecConstr to
chew on; and it virtually guarantees no shadowing.

251
252
Note [Specialising for constant parameters]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
This one is about specialising on a *constant* (but not necessarily
constructor) argument

    foo :: Int -> (Int -> Int) -> Int
    foo 0 f = 0
    foo m f = foo (f m) (+1)

It produces

    lvl_rmV :: GHC.Base.Int -> GHC.Base.Int
    lvl_rmV =
      \ (ds_dlk :: GHC.Base.Int) ->
        case ds_dlk of wild_alH { GHC.Base.I# x_alG ->
        GHC.Base.I# (GHC.Prim.+# x_alG 1)

    T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
    GHC.Prim.Int#
    T.$wfoo =
      \ (ww_sme :: GHC.Prim.Int#) (w_smg :: GHC.Base.Int -> GHC.Base.Int) ->
        case ww_sme of ds_Xlw {
          __DEFAULT ->
    	case w_smg (GHC.Base.I# ds_Xlw) of w1_Xmo { GHC.Base.I# ww1_Xmz ->
    	T.$wfoo ww1_Xmz lvl_rmV
    	};
          0 -> 0
        }

The recursive call has lvl_rmV as its argument, so we could create a specialised copy
with that argument baked in; that is, not passed at all.   Now it can perhaps be inlined.

When is this worth it?  Call the constant 'lvl'
- If 'lvl' has an unfolding that is a constructor, see if the corresponding
  parameter is scrutinised anywhere in the body.

- If 'lvl' has an unfolding that is a inlinable function, see if the corresponding
  parameter is applied (...to enough arguments...?)

  Also do this is if the function has RULES?

Also 	

294
295
Note [Specialising for lambda parameters]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
    foo :: Int -> (Int -> Int) -> Int
    foo 0 f = 0
    foo m f = foo (f m) (\n -> n-m)

This is subtly different from the previous one in that we get an
explicit lambda as the argument:

    T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
    GHC.Prim.Int#
    T.$wfoo =
      \ (ww_sm8 :: GHC.Prim.Int#) (w_sma :: GHC.Base.Int -> GHC.Base.Int) ->
        case ww_sm8 of ds_Xlr {
          __DEFAULT ->
    	case w_sma (GHC.Base.I# ds_Xlr) of w1_Xmf { GHC.Base.I# ww1_Xmq ->
    	T.$wfoo
    	  ww1_Xmq
    	  (\ (n_ad3 :: GHC.Base.Int) ->
    	     case n_ad3 of wild_alB { GHC.Base.I# x_alA ->
    	     GHC.Base.I# (GHC.Prim.-# x_alA ds_Xlr)
    	     })
    	};
          0 -> 0
        }

I wonder if SpecConstr couldn't be extended to handle this? After all,
lambda is a sort of constructor for functions and perhaps it already
has most of the necessary machinery?

Furthermore, there's an immediate win, because you don't need to allocate the lamda
at the call site; and if perchance it's called in the recursive call, then you
may avoid allocating it altogether.  Just like for constructors.

Looks cool, but probably rare...but it might be easy to implement.

330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346

Note [SpecConstr for casts]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider 
    data family T a :: *
    data instance T Int = T Int

    foo n = ...
       where
         go (T 0) = 0
         go (T n) = go (T (n-1))

The recursive call ends up looking like 
	go (T (I# ...) `cast` g)
So we want to spot the construtor application inside the cast.
That's why we have the Cast case in argToPat

347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
Note [Local recursive groups]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For a *local* recursive group, we can see all the calls to the
function, so we seed the specialisation loop from the calls in the
body, not from the calls in the RHS.  Consider:

  bar m n = foo n (n,n) (n,n) (n,n) (n,n)
   where
     foo n p q r s
       | n == 0    = m
       | n > 3000  = case p of { (p1,p2) -> foo (n-1) (p2,p1) q r s }
       | n > 2000  = case q of { (q1,q2) -> foo (n-1) p (q2,q1) r s }
       | n > 1000  = case r of { (r1,r2) -> foo (n-1) p q (r2,r1) s }
       | otherwise = case s of { (s1,s2) -> foo (n-1) p q r (s2,s1) }

If we start with the RHSs of 'foo', we get lots and lots of specialisations,
most of which are not needed.  But if we start with the (single) call
in the rhs of 'bar' we get exactly one fully-specialised copy, and all
the recursive calls go to this fully-specialised copy. Indeed, the original
function is later collected as dead code.  This is very important in 
specialising the loops arising from stream fusion, for example in NDP where
we were getting literally hundreds of (mostly unused) specialisations of
a local function.
370

371
372
373
374
375
376
-----------------------------------------------------
		Stuff not yet handled
-----------------------------------------------------

Here are notes arising from Roman's work that I don't want to lose.

377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
Example 1
~~~~~~~~~
    data T a = T !a

    foo :: Int -> T Int -> Int
    foo 0 t = 0
    foo x t | even x    = case t of { T n -> foo (x-n) t }
            | otherwise = foo (x-1) t

SpecConstr does no specialisation, because the second recursive call
looks like a boxed use of the argument.  A pity.

    $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
    $wfoo_sFw =
      \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) ->
    	 case ww_sFo of ds_Xw6 [Just L] {
    	   __DEFAULT ->
    		case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] {
    		  __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq;
    		  0 ->
    		    case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] ->
    		    case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] ->
    		    $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy
    		    } } };
    	   0 -> 0

Example 2
~~~~~~~~~
    data a :*: b = !a :*: !b
    data T a = T !a

    foo :: (Int :*: T Int) -> Int
    foo (0 :*: t) = 0
    foo (x :*: t) | even x    = case t of { T n -> foo ((x-n) :*: t) }
                  | otherwise = foo ((x-1) :*: t)

Very similar to the previous one, except that the parameters are now in
a strict tuple. Before SpecConstr, we have

    $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
    $wfoo_sG3 =
      \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T
    GHC.Base.Int) ->
        case ww_sFU of ds_Xws [Just L] {
          __DEFAULT ->
    	case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] {
    	  __DEFAULT ->
    	    case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] ->
    	    $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2		-- $wfoo1
    	    };
    	  0 ->
    	    case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] ->
    	    case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] ->
    	    $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB	-- $wfoo2
    	    } } };
          0 -> 0 }

We get two specialisations:
"SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#}
		  Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB)
		  = Foo.$s$wfoo1 a_sFB sc_sGC ;
"SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#}
		  Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp))
		  = Foo.$s$wfoo y_aFp sc_sGC ;

But perhaps the first one isn't good.  After all, we know that tpl_B2 is
443
444
a T (I# x) really, because T is strict and Int has one constructor.  (We can't
unbox the strict fields, becuase T is polymorphic!)
445
446


447

448
449
450
451
452
453
454
455
456
457
458
459
%************************************************************************
%*									*
\subsection{Top level wrapper stuff}
%*									*
%************************************************************************

\begin{code}
specConstrProgram :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]
specConstrProgram dflags us binds
  = do
	showPass dflags "SpecConstr"

460
	let (binds', _) = initUs us (go (initScEnv dflags) binds)
461
462
463
464

	endPass dflags "SpecConstr" Opt_D_dump_spec binds'

	dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
465
		      (pprRulesForUser (rulesOfBinds binds'))
466
467
468

	return binds'
  where
469
    go _   []	        = return []
470
    go env (bind:binds) = do (env', bind') <- scTopBind env bind
471
472
                             binds' <- go env' binds
                             return (bind' : binds')
473
474
475
476
477
\end{code}


%************************************************************************
%*									*
478
\subsection{Environment: goes downwards}
479
480
481
482
%*									*
%************************************************************************

\begin{code}
483
484
data ScEnv = SCE { sc_size  :: Maybe Int,	-- Size threshold
		   sc_count :: Maybe Int,	-- Max # of specialisations for any one fn
485

486
		   sc_subst :: Subst,   	-- Current substitution
487
						-- Maps InIds to OutExprs
488
489
490

		   sc_how_bound :: HowBoundEnv,
			-- Binds interesting non-top-level variables
491
			-- Domain is OutVars (*after* applying the substitution)
492

493
		   sc_vals  :: ValueEnv
494
			-- Domain is OutIds (*after* applying the substitution)
495
			-- Used even for top-level bindings (but not imported ones)
496
497
	     }

498
499
---------------------
-- As we go, we apply a substitution (sc_subst) to the current term
Thomas Schilling's avatar
Thomas Schilling committed
500
type InExpr = CoreExpr		-- _Before_ applying the subst
501

Thomas Schilling's avatar
Thomas Schilling committed
502
type OutExpr = CoreExpr		-- _After_ applying the subst
503
504
505
506
507
type OutId   = Id
type OutVar  = Var

---------------------
type HowBoundEnv = VarEnv HowBound	-- Domain is OutVars
508

509
---------------------
510
type ValueEnv = IdEnv Value		-- Domain is OutIds
Thomas Schilling's avatar
Thomas Schilling committed
511
data Value    = ConVal AltCon [CoreArg]	-- _Saturated_ constructors
512
	      | LambdaVal		-- Inlinable lambdas or PAPs
513

514
515
instance Outputable Value where
   ppr (ConVal con args) = ppr con <+> interpp'SP args
Ian Lynagh's avatar
Ian Lynagh committed
516
   ppr LambdaVal	 = ptext (sLit "<Lambda>")
517

518
---------------------
519
initScEnv :: DynFlags -> ScEnv
520
initScEnv dflags
521
  = SCE { sc_size = specConstrThreshold dflags,
522
	  sc_count = specConstrCount dflags,
523
524
	  sc_subst = emptySubst, 
	  sc_how_bound = emptyVarEnv, 
525
	  sc_vals = emptyVarEnv }
526

527
528
data HowBound = RecFun	-- These are the recursive functions for which 
			-- we seek interesting call patterns
529

530
531
	      | RecArg	-- These are those functions' arguments, or their sub-components; 
			-- we gather occurrence information for these
532

533
534
535
536
instance Outputable HowBound where
  ppr RecFun = text "RecFun"
  ppr RecArg = text "RecArg"

537
538
539
540
541
542
543
544
545
546
547
lookupHowBound :: ScEnv -> Id -> Maybe HowBound
lookupHowBound env id = lookupVarEnv (sc_how_bound env) id

scSubstId :: ScEnv -> Id -> CoreExpr
scSubstId env v = lookupIdSubst (sc_subst env) v

scSubstTy :: ScEnv -> Type -> Type
scSubstTy env ty = substTy (sc_subst env) ty

zapScSubst :: ScEnv -> ScEnv
zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) }
548

549
550
551
extendScInScope :: ScEnv -> [Var] -> ScEnv
	-- Bring the quantified variables into scope
extendScInScope env qvars = env { sc_subst = extendInScopeList (sc_subst env) qvars }
552

553
	-- Extend the substitution
554
555
556
557
558
extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv
extendScSubst env var expr = env { sc_subst = extendSubst (sc_subst env) var expr }

extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv
extendScSubstList env prs = env { sc_subst = extendSubstList (sc_subst env) prs }
559
560
561
562
563
564
565

extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv
extendHowBound env bndrs how_bound
  = env { sc_how_bound = extendVarEnvList (sc_how_bound env)
			    [(bndr,how_bound) | bndr <- bndrs] }

extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var])
566
extendBndrsWith how_bound env bndrs 
567
  = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndrs')
568
  where
569
570
571
572
573
574
575
    (subst', bndrs') = substBndrs (sc_subst env) bndrs
    hb_env' = sc_how_bound env `extendVarEnvList` 
		    [(bndr,how_bound) | bndr <- bndrs']

extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var)
extendBndrWith how_bound env bndr 
  = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndr')
576
  where
577
578
579
580
581
582
583
584
585
586
587
588
589
    (subst', bndr') = substBndr (sc_subst env) bndr
    hb_env' = extendVarEnv (sc_how_bound env) bndr' how_bound

extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var])
extendRecBndrs env bndrs  = (env { sc_subst = subst' }, bndrs')
		      where
			(subst', bndrs') = substRecBndrs (sc_subst env) bndrs

extendBndr :: ScEnv -> Var -> (ScEnv, Var)
extendBndr  env bndr  = (env { sc_subst = subst' }, bndr')
		      where
			(subst', bndr') = substBndr (sc_subst env) bndr

590
extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv
591
extendValEnv env _  Nothing   = env
592
extendValEnv env id (Just cv) = env { sc_vals = extendVarEnv (sc_vals env) id cv }
593
594
595
596
597
598

extendCaseBndrs :: ScEnv -> CoreExpr -> Id -> AltCon -> [Var] -> ScEnv
-- When we encounter
--	case scrut of b
--	    C x y -> ...
-- we want to bind b, and perhaps scrut too, to (C x y)
599
-- NB: Extends only the sc_vals part of the envt
600
601
extendCaseBndrs env scrut case_bndr con alt_bndrs
  = case scrut of
602
603
	Var v  -> extendValEnv env1 v cval
	_other -> env1
604
 where
605
   env1 = extendValEnv env case_bndr cval
606
607
   cval = case con of
		DEFAULT    -> Nothing
608
609
		LitAlt {}  -> Just (ConVal con [])
		DataAlt {} -> Just (ConVal con vanilla_args)
610
611
612
		      where
		       	vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
				       varsToCoreExprs alt_bndrs
613
614
615
616
617
618
619
620
\end{code}


%************************************************************************
%*									*
\subsection{Usage information: flows upwards}
%*									*
%************************************************************************
621

622
\begin{code}
623
624
data ScUsage
   = SCU {
625
	scu_calls :: CallEnv,		-- Calls
626
627
					-- The functions are a subset of the 
					-- 	RecFuns in the ScEnv
628

629
630
	scu_occs :: !(IdEnv ArgOcc)	-- Information on argument occurrences
     }					-- The domain is OutIds
631

632
type CallEnv = IdEnv [Call]
633
type Call = (ValueEnv, [CoreArg])
634
635
636
	-- The arguments of the call, together with the
	-- env giving the constructor bindings at the call site

637
638
nullUsage :: ScUsage
nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv }
639

640
641
642
combineCalls :: CallEnv -> CallEnv -> CallEnv
combineCalls = plusVarEnv_C (++)

643
644
645
combineUsage :: ScUsage -> ScUsage -> ScUsage
combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2),
			   scu_occs  = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) }
646

647
combineUsages :: [ScUsage] -> ScUsage
648
649
650
combineUsages [] = nullUsage
combineUsages us = foldr1 combineUsage us

651
652
653
lookupOcc :: ScUsage -> OutVar -> (ScUsage, ArgOcc)
lookupOcc (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndr
  = (SCU {scu_calls = sc_calls, scu_occs = delVarEnv sc_occs bndr},
654
     lookupVarEnv sc_occs bndr `orElse` NoOcc)
655

656
657
658
lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc])
lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs
  = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs},
659
660
661
662
663
     [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs])

data ArgOcc = NoOcc	-- Doesn't occur at all; or a type argument
	    | UnkOcc	-- Used in some unknown way

664
	    | ScrutOcc (UniqFM [ArgOcc])	-- See Note [ScrutOcc]
665
666

	    | BothOcc	-- Definitely taken apart, *and* perhaps used in some other way
667

668
669
{-	Note  [ScrutOcc]

670
671
An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing,
is *only* taken apart or applied.
672

673
  Functions, literal: ScrutOcc emptyUFM
674
675
676
677
678
679
680
681
682
683
684
  Data constructors:  ScrutOcc subs,

where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components,
The domain of the UniqFM is the Unique of the data constructor

The [ArgOcc] is the occurrences of the *pattern-bound* components 
of the data structure.  E.g.
	data T a = forall b. MkT a b (b->a)
A pattern binds b, x::a, y::b, z::b->a, but not 'a'!

-}
685
686

instance Outputable ArgOcc where
Ian Lynagh's avatar
Ian Lynagh committed
687
688
689
690
  ppr (ScrutOcc xs) = ptext (sLit "scrut-occ") <> ppr xs
  ppr UnkOcc 	    = ptext (sLit "unk-occ")
  ppr BothOcc 	    = ptext (sLit "both-occ")
  ppr NoOcc    	    = ptext (sLit "no-occ")
691

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
692
-- Experimentally, this vesion of combineOcc makes ScrutOcc "win", so
693
694
-- that if the thing is scrutinised anywhere then we get to see that
-- in the overall result, even if it's also used in a boxed way
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
695
-- This might be too agressive; see Note [Reboxing] Alternative 3
696
combineOcc :: ArgOcc -> ArgOcc -> ArgOcc
697
698
699
combineOcc NoOcc	 occ 	       = occ
combineOcc occ 		 NoOcc	       = occ
combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys)
700
701
combineOcc _occ          (ScrutOcc ys) = ScrutOcc ys
combineOcc (ScrutOcc xs) _occ	       = ScrutOcc xs
702
703
704
705
706
707
combineOcc UnkOcc        UnkOcc        = UnkOcc
combineOcc _	    _	     	       = BothOcc

combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]
combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys

708
setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage
Thomas Schilling's avatar
Thomas Schilling committed
709
-- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee
710
711
712
713
-- is a variable, and an interesting variable
setScrutOcc env usg (Cast e _) occ = setScrutOcc env usg e occ
setScrutOcc env usg (Note _ e) occ = setScrutOcc env usg e occ
setScrutOcc env usg (Var v)    occ
714
  | Just RecArg <- lookupHowBound env v = usg { scu_occs = extendVarEnv (scu_occs usg) v occ }
715
  | otherwise				= usg
716
setScrutOcc _env usg _other _occ	-- Catch-all
717
718
  = usg	

719
conArgOccs :: ArgOcc -> AltCon -> [ArgOcc]
720
-- Find usage of components of data con; returns [UnkOcc...] if unknown
721
722
723
724
-- See Note [ScrutOcc] for the extra UnkOccs in the vanilla datacon case

conArgOccs (ScrutOcc fm) (DataAlt dc) 
  | Just pat_arg_occs <- lookupUFM fm dc
725
  = [UnkOcc | _ <- dataConUnivTyVars dc] ++ pat_arg_occs
726

727
conArgOccs _other _con = repeat UnkOcc
728
729
730
731
732
733
734
735
\end{code}

%************************************************************************
%*									*
\subsection{The main recursive function}
%*									*
%************************************************************************

736
737
738
The main recursive function gathers up usage information, and
creates specialised versions of functions.

739
\begin{code}
740
scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
741
742
743
	-- The unique supply is needed when we invent
	-- a new name for the specialised function and its args

744
745
746
747
scExpr env e = scExpr' env e


scExpr' env (Var v)     = case scSubstId env v of
748
		            Var v' -> return (varUsage env v' UnkOcc, Var v')
749
750
		            e'     -> scExpr (zapScSubst env) e'

751
752
753
754
755
756
scExpr' env (Type t)    = return (nullUsage, Type (scSubstTy env t))
scExpr' _   e@(Lit {})  = return (nullUsage, e)
scExpr' env (Note n e)  = do (usg,e') <- scExpr env e
                             return (usg, Note n e')
scExpr' env (Cast e co) = do (usg, e') <- scExpr env e
                             return (usg, Cast e' (scSubstTy env co))
757
scExpr' env e@(App _ _) = scApp env (collectArgs e)
758
759
760
scExpr' env (Lam b e)   = do let (env', b') = extendBndr env b
                             (usg, e') <- scExpr env' e
                             return (usg, Lam b' e')
761
762
763

scExpr' env (Case scrut b ty alts) 
  = do	{ (scrut_usg, scrut') <- scExpr env scrut
764
765
	; case isValue (sc_vals env) scrut' of
		Just (ConVal con args) -> sc_con_app con args scrut'
766
		_other		       -> sc_vanilla scrut_usg scrut'
767
	}
768
  where
769
    sc_con_app con args scrut' 	-- Known constructor; simplify
770
	= do { let (_, bs, rhs) = findAlt con alts
771
		   alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)
772
773
774
775
776
777
778
	     ; scExpr alt_env' rhs }
				
    sc_vanilla scrut_usg scrut'	-- Normal case
     = do { let (alt_env,b') = extendBndrWith RecArg env b
			-- Record RecArg for the components

	  ; (alt_usgs, alt_occs, alts')
779
		<- mapAndUnzip3M (sc_alt alt_env scrut' b') alts
780

781
	  ; let (alt_usg, b_occ) = lookupOcc (combineUsages alt_usgs) b'
782
783
784
785
786
787
788
789
790
791
792
793
794
		scrut_occ        = foldr combineOcc b_occ alt_occs
		scrut_usg'       = setScrutOcc env scrut_usg scrut' scrut_occ
	  	-- The combined usage of the scrutinee is given
	  	-- by scrut_occ, which is passed to scScrut, which
	  	-- in turn treats a bare-variable scrutinee specially

	  ; return (alt_usg `combineUsage` scrut_usg',
	  	    Case scrut' b' (scSubstTy env ty) alts') }

    sc_alt env scrut' b' (con,bs,rhs)
      = do { let (env1, bs') = extendBndrsWith RecArg env bs
		 env2        = extendCaseBndrs env1 scrut' b' con bs'
	   ; (usg,rhs') <- scExpr env2 rhs
795
	   ; let (usg', arg_occs) = lookupOccs usg bs'
796
797
		 scrut_occ = case con of
				DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)
Ian Lynagh's avatar
Ian Lynagh committed
798
				_      	   -> ScrutOcc emptyUFM
799
800
801
	   ; return (usg', scrut_occ, (con,bs',rhs')) }

scExpr' env (Let (NonRec bndr rhs) body)
802
803
804
  | isTyVar bndr	-- Type-lets may be created by doBeta
  = scExpr' (extendScSubst env bndr rhs) body
  | otherwise
805
  = do	{ let (body_env, bndr') = extendBndr env bndr
806
807
	; (rhs_usg, (_, args', rhs_body', _)) <- scRecRhs env (bndr',rhs)
	; let rhs' = mkLams args' rhs_body'
808

809
	; if not opt_SpecInlineJoinPoints || null args' || isEmptyVarEnv (scu_calls rhs_usg) then do
810
	    do	{ 	-- Vanilla case
811
		  let body_env2 = extendValEnv body_env bndr' (isValue (sc_vals env) rhs')
812
			-- Record if the RHS is a value
813
814
		; (body_usg, body') <- scExpr body_env2 body
		; return (body_usg `combineUsage` rhs_usg, Let (NonRec bndr' rhs') body') }
815
816
817
818
819
820
	  else 	-- For now, just brutally inline the join point
	    do { let body_env2 = extendScSubst env bndr rhs'
	       ; scExpr body_env2 body } }
	

{-  Old code
821
	    do	{ 	-- Join-point case
822
		  let body_env2 = extendHowBound body_env [bndr'] RecFun
823
824
825
826
			-- If the RHS of this 'let' contains calls
			-- to recursive functions that we're trying
			-- to specialise, then treat this let too
			-- as one to specialise
827
		; (body_usg, body') <- scExpr body_env2 body
828

829
		; (spec_usg, _, specs) <- specialise env (scu_calls body_usg) ([], rhs_info)
830

831
		; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' } 
832
			  `combineUsage` rhs_usg `combineUsage` spec_usg,
833
			  mkLets [NonRec b r | (b,r) <- specInfoBinds rhs_info specs] body')
834
835
	}
-}
836

837
-- A *local* recursive group: see Note [Local recursive groups]
838
scExpr' env (Let (Rec prs) body)
839
840
841
842
843
844
  = do	{ let (bndrs,rhss) = unzip prs
	      (rhs_env1,bndrs') = extendRecBndrs env bndrs
	      rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun

	; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
	; (body_usg, body')     <- scExpr rhs_env2 body
845

846
847
848
849
850
851
852
853
854
	-- NB: start specLoop from body_usg
	; (spec_usg, specs) <- specLoop rhs_env2 (scu_calls body_usg) rhs_infos nullUsage
					[SI [] 0 (Just usg) | usg <- rhs_usgs]

	; let all_usg = spec_usg `combineUsage` body_usg
	      bind'   = Rec (concat (zipWith specInfoBinds rhs_infos specs))

	; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' },
	          Let bind' body') }
855

856
857
858
859
860
-----------------------------------
scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)

scApp env (Var fn, args)	-- Function is a variable
  = ASSERT( not (null args) )
861
    do	{ args_w_usgs <- mapM (scExpr env) args
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
	; let (arg_usgs, args') = unzip args_w_usgs
	      arg_usg = combineUsages arg_usgs
	; case scSubstId env fn of
	    fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args')
			-- Do beta-reduction and try again

	    Var fn' -> return (arg_usg `combineUsage` fn_usg, mkApps (Var fn') args')
		where
		  fn_usg = case lookupHowBound env fn' of
				Just RecFun -> SCU { scu_calls = unitVarEnv fn' [(sc_vals env, args')], 
					             scu_occs  = emptyVarEnv }
				Just RecArg -> SCU { scu_calls = emptyVarEnv,
					             scu_occs  = unitVarEnv fn' (ScrutOcc emptyUFM) }
				Nothing     -> nullUsage


	    other_fn' -> return (arg_usg, mkApps other_fn' args') }
		-- NB: doing this ignores any usage info from the substituted
		--     function, but I don't think that matters.  If it does
		--     we can fix it.
  where
    doBeta :: OutExpr -> [OutExpr] -> OutExpr
    -- ToDo: adjust for System IF
    doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args)
    doBeta fn	           args	        = mkApps fn args

-- The function is almost always a variable, but not always.  
-- In particular, if this pass follows float-in,
-- which it may, we can get 
--	(let f = ...f... in f) arg1 arg2
scApp env (other_fn, args)
  = do 	{ (fn_usg,   fn')   <- scExpr env other_fn
894
	; (arg_usgs, args') <- mapAndUnzipM (scExpr env) args
895
	; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') }
896

897
----------------------
898
899
scTopBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind)
scTopBind env (Rec prs)
900
901
  | Just threshold <- sc_size env
  , not (all (couldBeSmallEnoughToInline threshold) rhss)
902
903
		-- No specialisation
  = do	{ let (rhs_env,bndrs') = extendRecBndrs env bndrs
904
905
	; (_, rhss') <- mapAndUnzipM (scExpr rhs_env) rhss
	; return (rhs_env, Rec (bndrs' `zip` rhss')) }
906
907
  | otherwise	-- Do specialisation
  = do	{ let (rhs_env1,bndrs') = extendRecBndrs env bndrs
908
	      rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
909

910
	; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
911
912
	; let rhs_usg = combineUsages rhs_usgs

913
914
	; (_, specs) <- specLoop rhs_env2 (scu_calls rhs_usg) rhs_infos nullUsage
				 [SI [] 0 Nothing | _ <- bndrs]
915
916

	; return (rhs_env1,  -- For the body of the letrec, delete the RecFun business
917
		  Rec (concat (zipWith specInfoBinds rhs_infos specs))) }
918
919
920
  where
    (bndrs,rhss) = unzip prs

921
922
scTopBind env (NonRec bndr rhs)
  = do	{ (_, rhs') <- scExpr env rhs
923
924
	; let (env1, bndr') = extendBndr env bndr
	      env2 = extendValEnv env1 bndr' (isValue (sc_vals env) rhs')
925
	; return (env2, NonRec bndr' rhs') }
926
927

----------------------
928
scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM (ScUsage, RhsInfo)
929
930
scRecRhs env (bndr,rhs)
  = do	{ let (arg_bndrs,body) = collectBinders rhs
931
	      (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs
932
	; (body_usg, body') <- scExpr body_env body
933
934
935
936
937
938
939
940
941
	; let (rhs_usg, arg_occs) = lookupOccs body_usg arg_bndrs'
	; return (rhs_usg, (bndr, arg_bndrs', body', arg_occs)) }

		-- The arg_occs says how the visible,
		-- lambda-bound binders of the RHS are used
		-- (including the TyVar binders)
	 	-- Two pats are the same if they match both ways

----------------------
942
943
944
specInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)]
specInfoBinds (fn, args, body, _) (SI specs _ _)
  = [(id,rhs) | OS _ _ id rhs <- specs] ++ 
945
946
    [(fn `addIdSpecialisations` rules, mkLams args body)]
  where
947
    rules = [r | OS _ r _ _ <- specs]
948
949

----------------------
950
varUsage :: ScEnv -> OutVar -> ArgOcc -> ScUsage
951
varUsage env v use 
952
953
  | Just RecArg <- lookupHowBound env v = SCU { scu_calls = emptyVarEnv 
					      , scu_occs = unitVarEnv v use }
954
  | otherwise		   	        = nullUsage
955
956
957
958
959
\end{code}


%************************************************************************
%*									*
960
		The specialiser itself
961
962
963
964
%*									*
%************************************************************************

\begin{code}
965
type RhsInfo = (OutId, [OutVar], OutExpr, [ArgOcc])
966
967
968
969
	-- Info about the *original* RHS of a binding we are specialising
 	-- Original binding f = \xs.body
	-- Plus info about usage of arguments

970
971
972
973
974
975
data SpecInfo = SI [OneSpec]		-- The specialisations we have generated
		   Int			-- Length of specs; used for numbering them
		   (Maybe ScUsage)	-- Nothing => we have generated specialisations
					--	      from calls in the *original* RHS
					-- Just cs => we haven't, and this is the usage
					--	      of the original RHS
976

977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
	-- One specialisation: Rule plus definition
data OneSpec  = OS CallPat 		-- Call pattern that generated this specialisation
		   CoreRule		-- Rule connecting original id with the specialisation
		   OutId OutExpr	-- Spec id + its rhs


specLoop :: ScEnv
	 -> CallEnv
	 -> [RhsInfo]
	 -> ScUsage -> [SpecInfo]		-- One per binder; acccumulating parameter
	 -> UniqSM (ScUsage, [SpecInfo])	-- ...ditto...
specLoop env all_calls rhs_infos usg_so_far specs_so_far
  = do	{ specs_w_usg <- zipWithM (specialise env all_calls) rhs_infos specs_so_far
	; let (new_usg_s, all_specs) = unzip specs_w_usg
	      new_usg   = combineUsages new_usg_s
	      new_calls = scu_calls new_usg
	      all_usg   = usg_so_far `combineUsage` new_usg
	; if isEmptyVarEnv new_calls then
		return (all_usg, all_specs) 
 	  else 
		specLoop env new_calls rhs_infos all_usg all_specs }
998

999
1000
specialise 
   :: ScEnv
1001
   -> CallEnv				-- Info on calls
1002
1003
1004
   -> RhsInfo
   -> SpecInfo				-- Original RHS plus patterns dealt with
   -> UniqSM (ScUsage, SpecInfo)	-- New specialised versions and their usage
1005
1006
1007
1008
1009

-- Note: the rhs here is the optimised version of the original rhs
-- So when we make a specialised copy of the RHS, we're starting
-- from an RHS whose nested functions have been optimised already.

1010
1011
specialise env bind_calls (fn, arg_bndrs, body, arg_occs) 
			  spec_info@(SI specs spec_count mb_unspec)
1012
1013
  | notNull arg_bndrs,	-- Only specialise functions
    Just all_calls <- lookupVarEnv bind_calls fn
1014
  = do	{ (boring_call, pats) <- callsToPats env specs arg_occs all_calls
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
1015
1016
--	; pprTrace "specialise" (vcat [ppr fn <+> ppr arg_occs,
--	  				text "calls" <+> ppr all_calls,
1017
--	  				text "good pats" <+> ppr pats])  $
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
1018
--	  return ()
1019

1020
1021
1022
1023
1024
		-- Bale out if too many specialisations
		-- Rather a hacky way to do so, but it'll do for now
	; let spec_count' = length pats + spec_count
	; case sc_count env of
	    Just max | spec_count' > max
1025
1026
1027
1028
1029
1030
1031
1032
		-> WARN( True, msg ) return (nullUsage, spec_info)
		where
		   msg = vcat [ sep [ ptext (sLit "SpecConstr: specialisation of") <+> quotes (ppr fn)
		       	            , nest 2 (ptext (sLit "limited by bound of")) <+> int max ]
			      , ptext (sLit "Use -fspec-constr-count=n to set the bound")
			      , extra ]
	           extra | not opt_PprStyle_Debug = ptext (sLit "Use -dppr-debug to see specialisations")
		   	 | otherwise = ptext (sLit "Specialisations:") <+> ppr (pats ++ [p | OS p _ _ _ <- specs])
1033

Thomas Schilling's avatar
Thomas Schilling committed
1034
1035
1036
	    _normal_case -> do {

	  (spec_usgs, new_specs) <- mapAndUnzipM (spec_one env fn arg_bndrs body)
1037
1038
1039
1040
1041
1042
1043
1044
1045
					         (pats `zip` [spec_count..])

	; let spec_usg = combineUsages spec_usgs
	      (new_usg, mb_unspec')
		  = case mb_unspec of
		      Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing)
		      _			         -> (spec_usg,                      mb_unspec)
	    
	; return (new_usg, SI (new_specs ++ specs) spec_count' mb_unspec') } }
1046
  | otherwise
1047
  = return (nullUsage, spec_info)		-- The boring case
1048

1049
1050

---------------------
1051
spec_one :: ScEnv
1052
	 -> OutId	-- Function
1053
1054
	 -> [Var]	-- Lambda-binders of RHS; should match patterns
	 -> CoreExpr	-- Body of the original function
1055
1056
	 -> (CallPat, Int)
	 -> UniqSM (ScUsage, OneSpec)	-- Rule and binding
1057

1058
1059
1060
1061
-- spec_one creates a specialised copy of the function, together
-- with a rule for using it.  I'm very proud of how short this
-- function is, considering what it does :-).

1062
1063
1064
1065
{- 
  Example
  
     In-scope: a, x::a   
1066
1067
     f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
	  [c::*, v::(b,c) are presumably bound by the (...) part]
1068
  ==>
1069
     f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
1070
1071
		  (...entire body of f...) [b -> (b,c), 
  					    y -> ((:) (a,(b,c)) (x,v) hw)]
1072
  
1073
1074
1075
     RULE:  forall b::* c::*,		-- Note, *not* forall a, x
		   v::(b,c),
		   hw::[(a,(b,c))] .
1076
  
1077
	    f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
1078
1079
-}

1080
spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)
1081
  = do	{ 	-- Specialise the body
1082
1083
	  let spec_env = extendScSubstList (extendScInScope env qvars)
				           (arg_bndrs `zip` pats)
1084
1085
1086
	; (spec_usg, spec_body) <- scExpr spec_env body

--	; pprTrace "spec_one" (ppr fn <+> vcat [text "pats" <+> ppr pats,
1087
--			text "calls" <+> (ppr (scu_calls spec_usg))])
1088
1089
1090
1091
1092
1093
1094
--	  (return ())

		-- And build the results
	; spec_uniq <- getUniqueUs
	; let (spec_lam_args, spec_call_args) = mkWorkerArgs qvars body_ty
	      	-- Usual w/w hack to avoid generating 
	      	-- a spec_rhs of unlifted type and no args
1095
	
1096
	      fn_name   = idName fn
1097
	      fn_loc    = nameSrcSpan fn_name
1098
1099
1100
1101
1102
1103
1104
	      spec_occ  = mkSpecOcc (nameOccName fn_name)
	      rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number))
	      spec_rhs  = mkLams spec_lam_args spec_body
	      spec_id   = mkUserLocal spec_occ spec_uniq (mkPiTypes spec_lam_args body_ty) fn_loc
	      body_ty   = exprType spec_body
	      rule_rhs  = mkVarApps (Var spec_id) spec_call_args
	      rule      = mkLocalRule rule_name specConstrActivation fn_name qvars pats rule_rhs
1105
	; return (spec_usg, OS call_pat rule spec_id spec_rhs) }
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116

-- In which phase should the specialise-constructor rules be active?
-- Originally I made them always-active, but Manuel found that
-- this defeated some clever user-written rules.  So Plan B
-- is to make them active only in Phase 0; after all, currently,
-- the specConstr transformation is only run after the simplifier
-- has reached Phase 0.  In general one would want it to be 
-- flag-controllable, but for now I'm leaving it baked in
--					[SLPJ Oct 01]
specConstrActivation :: Activation
specConstrActivation = ActiveAfter 0	-- Baked in; see comments above
1117
\end{code}
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127

%************************************************************************
%*									*
\subsection{Argument analysis}
%*									*
%************************************************************************

This code deals with analysing call-site arguments to see whether
they are constructor applications.

1128

1129
\begin{code}
1130
1131
1132
type CallPat = ([Var], [CoreExpr])	-- Quantified variables and arguments


1133
callsToPats :: ScEnv -> [OneSpec] -> [ArgOcc] -> [Call] -> UniqSM (Bool, [CallPat])
1134
1135
	-- Result has no duplicate patterns, 
	-- nor ones mentioned in done_pats
1136
1137
	-- Bool indicates that there was at least one boring pattern
callsToPats env done_specs bndr_occs calls
1138
1139
1140
1141
  = do	{ mb_pats <- mapM (callToPats env bndr_occs) calls

	; let good_pats :: [([Var], [CoreArg])]
	      good_pats = catMaybes mb_pats
1142
	      done_pats = [p | OS p _ _ _ <- done_specs] 
1143
1144
	      is_done p = any (samePat p) done_pats

1145
1146
	; return (any isNothing mb_pats, 
		  filterOut is_done (nubBy samePat good_pats)) }
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158

callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
	-- The [Var] is the variables to quantify over in the rule
	--	Type variables come first, since they may scope 
	--	over the following term variables
	-- The [CoreExpr] are the argument patterns for the rule
callToPats env bndr_occs (con_env, args)
  | length args < length bndr_occs	-- Check saturated
  = return Nothing
  | otherwise
  = do	{ let in_scope = substInScope (sc_subst env)
	; prs <- argsToPats in_scope con_env (args `zip` bndr_occs)
1159
	; let (interesting_s, pats) = unzip prs
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
	      pat_fvs = varSetElems (exprsFreeVars pats)
	      qvars   = filterOut (`elemInScopeSet` in_scope) pat_fvs
		-- Quantify over variables that are not in sccpe
		-- at the call site
		-- See Note [Shadowing] at the top
		
	      (tvs, ids) = partition isTyVar qvars
	      qvars'     = tvs ++ ids
		-- Put the type variables first; the type of a term
		-- variable may mention a type variable

	; -- pprTrace "callToPats"  (ppr args $$ ppr prs $$ ppr bndr_occs) $
1172
	  if or interesting_s
1173
1174
1175
	  then return (Just (qvars', pats))
	  else return Nothing }

1176
1177
1178
1179
1180
1181
    -- argToPat takes an actual argument, and returns an abstracted
    -- version, consisting of just the "constructor skeleton" of the
    -- argument, with non-constructor sub-expression replaced by new
    -- placeholder variables.  For example:
    --    C a (D (f x) (g y))  ==>  C p1 (D p2 p3)

1182
argToPat :: InScopeSet			-- What's in scope at the fn defn site
1183
	 -> ValueEnv			-- ValueEnv at the call site
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
	 -> CoreArg			-- A call arg (or component thereof)
	 -> ArgOcc
	 -> UniqSM (Bool, CoreArg)
-- Returns (interesting, pat), 
-- where pat is the pattern derived from the argument
--	      intersting=True if the pattern is non-trivial (not a variable or type)
-- E.g.		x:xs	     --> (True, x:xs)
--		f xs         --> (False, w)	   where w is a fresh wildcard
--		(f xs, 'c')  --> (True, (w, 'c'))  where w is a fresh wildcard
--		\x. x+y      --> (True, \x. x+y)
--		lvl7	     --> (True, lvl7)	   if lvl7 is bound 
--						   somewhere further out

1197
argToPat _in_scope _val_env arg@(Type {}) _arg_occ
1198
1199
  = return (False, arg)

1200
argToPat in_scope val_env (Note _ arg) arg_occ
1201
  = argToPat in_scope val_env arg arg_occ
1202
1203
1204
1205
1206
1207
1208
	-- Note [Notes in call patterns]
	-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
	-- Ignore Notes.  In particular, we want to ignore any InlineMe notes
	-- Perhaps we should not ignore profiling notes, but I'm going to
	-- ride roughshod over them all for now.
	--- See Note [Notes in RULE matching] in Rules

1209
1210
argToPat in_scope val_env (Let _ arg) arg_occ
  = argToPat in_scope val_env arg arg_occ
1211
1212
1213
1214
1215
	-- Look through let expressions
	-- e.g.		f (let v = rhs in \y -> ...v...)
	-- Here we can specialise for f (\y -> ...)
	-- because the rule-matcher will look through the let.

1216
1217
argToPat in_scope val_env (Cast arg co) arg_occ
  = do	{ (interesting, arg') <- argToPat in_scope val_env arg arg_occ
1218
1219
1220
1221
1222
1223
	; let (ty1,ty2) = coercionKind co
	; if not interesting then 
		wildCardPat ty2
	  else do
	{ -- Make a wild-card pattern for the coercion
	  uniq <- getUniqueUs
Ian Lynagh's avatar
Ian Lynagh committed
1224
	; let co_name = mkSysTvName uniq (fsLit "sg")
1225
1226
	      co_var = mkCoVar co_name (mkCoKind ty1 ty2)
	; return (interesting, Cast arg' (mkTyVarTy co_var)) } }
1227

1228
1229
{-	Disabling lambda specialisation for now
	It's fragile, and the spec_loop can be infinite
1230
argToPat in_scope val_env arg arg_occ
1231
1232
1233
1234
1235
1236
1237
  | is_value_lam arg
  = return (True, arg)
  where
    is_value_lam (Lam v e) 	-- Spot a value lambda, even if 
	| isId v = True		-- it is inside a type lambda
	| otherwise = is_value_lam e
    is_value_lam other = False
1238
-}
1239

1240
1241
  -- Check for a constructor application
  -- NB: this *precedes* the Var case, so that we catch nullary constrs
1242
1243
argToPat in_scope val_env arg arg_occ
  | Just (ConVal dc args) <- isValue val_env arg
1244
1245
  , case arg_occ of
	ScrutOcc _ -> True		-- Used only by case scrutinee
1246
1247
	BothOcc    -> case arg of	-- Used elsewhere
			App {} -> True	--     see Note [Reboxing]
1248
1249
			_other -> False
	_other	   -> False	-- No point; the arg is not decomposed
1250
  = do	{ args' <- argsToPats in_scope val_env (args `zip` conArgOccs arg_occ dc)
1251
1252
	; return (True, mk_con_app dc (map snd args')) }

1253
1254
1255
1256
1257
  -- Check if the argument is a variable that 
  -- is in scope at the function definition site
  -- It's worth specialising on this if
  --	(a) it's used in an interesting way in the body
  --	(b) we know what its value is
1258
argToPat in_scope val_env (Var v) arg_occ
1259
1260
  | case arg_occ of { UnkOcc -> False; _other -> True },	-- (a)
    is_value							-- (b)
1261
  = return (True, Var v)
1262
1263
1264
1265
1266
1267
1268
  where
    is_value 
	| isLocalId v = v `elemInScopeSet` in_scope 
			&& isJust (lookupVarEnv val_env v)
		-- Local variables have values in val_env
	| otherwise   = isValueUnfolding (idUnfolding v)
		-- Imports have unfoldings
1269

1270
1271
1272
1273
1274
--	I'm really not sure what this comment means
--	And by not wild-carding we tend to get forall'd 
--	variables that are in soope, which in turn can
--	expose the weakness in let-matching
--	See Note [Matching lets] in Rules
1275

1276
1277
1278
1279
  -- Check for a variable bound inside the function. 
  -- Don't make a wild-card, because we may usefully share
  --	e.g.  f a = let x = ... in f (x,x)
  -- NB: this case follows the lambda and con-app cases!!
1280
1281
1282
1283
1284
1285
1286
-- argToPat _in_scope _val_env (Var v) _arg_occ
--   = return (False, Var v)
	-- SLPJ : disabling this to avoid proliferation of versions
	-- also works badly when thinking about seeding the loop
	-- from the body of the let
	--	 f x y = letrec g z = ... in g (x,y)
	-- We don't want to specialise for that *particular* x,y
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
1287

1288
  -- The default case: make a wild-card
1289
argToPat _in_scope _val_env arg _arg_occ
1290
  = wildCardPat (exprType arg)
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
1291
1292
1293

wildCardPat :: Type -> UniqSM (Bool, CoreArg)
wildCardPat ty = do { uniq <- getUniqueUs
Ian Lynagh's avatar
Ian Lynagh committed
1294
		    ; let id = mkSysLocal (fsLit "sc") uniq ty
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
1295
		    ; return (False, Var id) }
1296

1297
argsToPats :: InScopeSet -> ValueEnv
1298
1299
	   -> [(CoreArg, ArgOcc)]
	   -> UniqSM [(Bool, CoreArg)]
1300
argsToPats in_scope val_env args
1301
  = mapM do_one args
1302
  where
1303
    do_one (arg,occ) = argToPat in_scope val_env arg occ
1304
1305
1306
1307
\end{code}


\begin{code}
1308
isValue :: ValueEnv -> CoreExpr -> Maybe Value
1309
isValue _env (Lit lit)
1310
1311
1312
  = Just (ConVal (LitAlt lit) [])

isValue env (Var v)
1313
1314
  | Just stuff <- lookupVarEnv env v
  = Just stuff	-- You might think we could look in the idUnfolding here
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
1315
1316
1317
		-- but that doesn't take account of which branch of a 
		-- case we are in, which is the whole point

1318
  | not (isLocalId v) && isCheapUnfolding unf
1319
  = isValue env (unfoldingTemplate unf)
1320
1321
1322
1323
  where
    unf = idUnfolding v
	-- However we do want to consult the unfolding 
	-- as well, for let-bound constructors!
1324

1325
isValue env (Lam b e)
1326
1327
1328
  | isTyVar b = case isValue env e of
		  Just _  -> Just LambdaVal
		  Nothing -> Nothing
1329
1330
  | otherwise = Just LambdaVal

1331
isValue _env expr	-- Maybe it's a constructor application
1332
1333
1334
1335
1336
1337
1338
1339
  | (Var fun, args) <- collectArgs expr
  = case isDataConWorkId_maybe fun of

	Just con | args `lengthAtLeast` dataConRepArity con 
		-- Check saturated; might be > because the 
		--		    arity excludes type args
		-> Just (ConVal (DataAlt con) args)

1340
	_other | valArgCount args < idArity fun
1341
		-- Under-applied function
1342
	       -> Just LambdaVal	-- Partial application
1343

1344
	_other -> Nothing
1345

1346
isValue _env _expr = Nothing
1347
1348
1349
1350

mk_con_app :: AltCon -> [CoreArg] -> CoreExpr
mk_con_app (LitAlt lit)  []   = Lit lit
mk_con_app (DataAlt con) args = mkConApp con args
1351
mk_con_app _other _args = panic "SpecConstr.mk_con_app"
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364

samePat :: CallPat -> CallPat -> Bool
samePat (vs1, as1) (vs2, as2)
  = all2 same as1 as2
  where
    same (Var v1) (Var v2) 
	| v1 `elem` vs1 = v2 `elem` vs2
	| v2 `elem` vs2 = False
	| otherwise     = v1 == v2

    same (Lit l1)    (Lit l2)    = l1==l2
    same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2

1365
    same (Type {}) (Type {}) = True	-- Note [Ignore type differences]
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
    same (Note _ e1) e2	= same e1 e2	-- Ignore casts and notes
    same (Cast e1 _) e2	= same e1 e2
    same e1 (Note _ e2) = same e1 e2
    same e1 (Cast e2 _) = same e1 e2

    same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2) 
		 False 	-- Let, lambda, case should not occur
    bad (Case {}) = True
    bad (Let {})  = True
    bad (Lam {})  = True
1376
    bad _other	  = False
1377
\end{code}
1378
1379
1380
1381
1382
1383
1384
1385
1386

Note [Ignore type differences]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We do not want to generate specialisations where the call patterns
differ only in their type arguments!  Not only is it utterly useless,
but it also means that (with polymorphic recursion) we can generate
an infinite number of specialisations. Example is Data.Sequence.adjustTree, 
I think.