SpecConstr.lhs 32.9 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[SpecConstr]{Specialise over constructors}

\begin{code}
module SpecConstr(
	specConstrProgram	
    ) where

#include "HsVersions.h"

import CoreSyn
import CoreLint		( showPass, endPass )
15
import CoreUtils	( exprType, mkPiTypes )
16
import CoreFVs 		( exprsFreeVars )
17
import CoreSubst	( Subst, mkSubst, substExpr )
18
19
import CoreTidy		( tidyRules )
import PprCore		( pprRules )
20
import WwLib		( mkWorkerArgs )
21
import DataCon		( dataConRepArity, isVanillaDataCon, dataConTyVars )
22
import Type		( tyConAppArgs, tyVarsOfTypes )
23
import Rules		( matchN )
24
import Unify		( coreRefineTys )
25
import Id		( Id, idName, idType, isDataConWorkId_maybe, 
26
			  mkUserLocal, mkSysLocal, idUnfolding, isLocalId )
27
28
29
30
import Var		( Var )
import VarEnv
import VarSet
import Name		( nameOccName, nameSrcLoc )
31
import Rules		( addIdSpecialisations, mkLocalRule, rulesOfBinds )
32
33
import OccName		( mkSpecOcc )
import ErrUtils		( dumpIfSet_dyn )
34
import DynFlags		( DynFlags, DynFlag(..) )
35
import BasicTypes	( Activation(..) )
36
37
import Maybes		( orElse, catMaybes, isJust )
import Util		( zipWithEqual, lengthAtLeast, notNull )
38
39
40
import List		( nubBy, partition )
import UniqSupply
import Outputable
41
import FastString
42
import UniqFM
43
44
45
46
47
48
49
50
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
\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
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
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.

ALTERNATIVE: pass both boxed and unboxed versions.  This no longer saves
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.
128
129


130
131
Note [Good arguments]
~~~~~~~~~~~~~~~~~~~~~
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
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
153
      Those are the only uses of the parameter (see Note [Reboxing])
154
155


156
157
What to abstract over
~~~~~~~~~~~~~~~~~~~~~
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
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
193
	  the fn defn.  But see Note [Shadowing] below.
194
195
196
197
198
199
200


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.


201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
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.

224
225
Note [Specialising for constant parameters]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
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 	

267
268
Note [Specialising for lambda parameters]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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
294
295
296
297
298
299
300
301
302
    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.

303
304
305
306
307
308
-----------------------------------------------------
		Stuff not yet handled
-----------------------------------------------------

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

309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
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
375
376
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!)
377
378


379

380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
%************************************************************************
%*									*
\subsection{Top level wrapper stuff}
%*									*
%************************************************************************

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

	let (binds', _) = initUs us (go emptyScEnv binds)

	endPass dflags "SpecConstr" Opt_D_dump_spec binds'

	dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
397
		  (pprRules (tidyRules emptyTidyEnv (rulesOfBinds binds')))
398
399
400
401
402
403
404
405
406
407
408
409

	return binds'
  where
    go env []	        = returnUs []
    go env (bind:binds) = scBind env bind 	`thenUs` \ (env', _, bind') ->
			  go env' binds 	`thenUs` \ binds' ->
			  returnUs (bind' : binds')
\end{code}


%************************************************************************
%*									*
410
\subsection{Environment: goes downwards}
411
412
413
414
%*									*
%************************************************************************

\begin{code}
415
data ScEnv = SCE { scope :: InScopeEnv,
416
			-- Binds all non-top-level variables in scope
417

418
419
420
		   cons  :: ConstrEnv
	     }

421
422
type InScopeEnv = VarEnv HowBound

423
424
type ConstrEnv = IdEnv ConValue
data ConValue  = CV AltCon [CoreArg]
425
426
427
	-- Variables known to be bound to a constructor
	-- in a particular case alternative

428
429
430
431

instance Outputable ConValue where
   ppr (CV con args) = ppr con <+> interpp'SP args

432
433
434
435
436
437
refineConstrEnv :: Subst -> ConstrEnv -> ConstrEnv
-- The substitution is a type substitution only
refineConstrEnv subst env = mapVarEnv refine_con_value env
  where
    refine_con_value (CV con args) = CV con (map (substExpr subst) args)

438
emptyScEnv = SCE { scope = emptyVarEnv, cons = emptyVarEnv }
439
440
441

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

443
444
	      | RecArg		-- These are those functions' arguments; we are
				-- interested to see if those arguments are scrutinised
445

446
	      | Other		-- We track all others so we know what's in scope
447
448
449
				-- This is used in spec_one to check what needs to be
				-- passed as a parameter and what is in scope at the 
				-- function definition site
450

451
452
453
454
455
instance Outputable HowBound where
  ppr RecFun = text "RecFun"
  ppr RecArg = text "RecArg"
  ppr Other = text "Other"

456
457
458
459
460
461
462
463
464
lookupScopeEnv env v = lookupVarEnv (scope env) v

extendBndrs env bndrs = env { scope = extendVarEnvList (scope env) [(b,Other) | b <- bndrs] }
extendBndr  env bndr  = env { scope = extendVarEnv (scope env) bndr Other }

    -- When we encounter
    --	case scrut of b
    --	    C x y -> ...
    -- we want to bind b, and perhaps scrut too, to (C x y)
465
466
467
468
extendCaseBndrs :: ScEnv -> Id -> CoreExpr -> AltCon -> [Var] -> ScEnv
extendCaseBndrs env case_bndr scrut DEFAULT alt_bndrs
  = extendBndrs env (case_bndr : alt_bndrs)

469
470
471
472
473
474
475
476
477
478
479
480
481
482
extendCaseBndrs env case_bndr scrut con@(LitAlt lit) alt_bndrs
  = ASSERT( null alt_bndrs ) extendAlt env case_bndr scrut (CV con []) []

extendCaseBndrs env case_bndr scrut con@(DataAlt data_con) alt_bndrs
  | isVanillaDataCon data_con
  = extendAlt env case_bndr scrut (CV con vanilla_args) alt_bndrs
    
  | otherwise	-- GADT
  = extendAlt env1 case_bndr scrut (CV con gadt_args) alt_bndrs
  where
    vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
		   map varToCoreExpr alt_bndrs

    gadt_args = map (substExpr subst . varToCoreExpr) alt_bndrs
483
484
485
	-- This call generates some bogus warnings from substExpr,
	-- because it's inconvenient to put all the Ids in scope
	-- Will be fixed when we move to FC
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502

    (alt_tvs, _) = span isTyVar alt_bndrs
    Just (tv_subst, is_local) = coreRefineTys data_con alt_tvs (idType case_bndr)
    subst = mkSubst in_scope tv_subst emptyVarEnv	-- No Id substitition
    in_scope = mkInScopeSet (tyVarsOfTypes (varEnvElts tv_subst))

    env1 | is_local  = env
	 | otherwise = env { cons = refineConstrEnv subst (cons env) }


extendAlt :: ScEnv -> Id -> CoreExpr -> ConValue -> [Var] -> ScEnv
extendAlt env case_bndr scrut val alt_bndrs
  = let 
       env1 = SCE { scope = extendVarEnvList (scope env) [(b,Other) | b <- case_bndr : alt_bndrs],
		    cons  = extendVarEnv     (cons  env) case_bndr val }
    in
    case scrut of
503
504
505
506
507
508
	Var v ->   -- Bind the scrutinee in the ConstrEnv if it's a variable
		   -- Also forget if the scrutinee is a RecArg, because we're
		   -- now in the branch of a case, and we don't want to
		   -- record a non-scrutinee use of v if we have
		   --	case v of { (a,b) -> ...(f v)... }
		 SCE { scope = extendVarEnv (scope env1) v Other,
509
		       cons  = extendVarEnv (cons env1)  v val }
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
	other -> env1

    -- When we encounter a recursive function binding
    --	f = \x y -> ...
    -- we want to extend the scope env with bindings 
    -- that record that f is a RecFn and x,y are RecArgs
extendRecBndr env fn bndrs
  =  env { scope = scope env `extendVarEnvList` 
		   ((fn,RecFun): [(bndr,RecArg) | bndr <- bndrs]) }
\end{code}


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

528
\begin{code}
529
530
data ScUsage
   = SCU {
531
532
533
	calls :: !(IdEnv ([Call])),	-- Calls
					-- The functions are a subset of the 
					-- 	RecFuns in the ScEnv
534
535
536
537
538

	occs :: !(IdEnv ArgOcc)		-- Information on argument occurrences
     }					-- The variables are a subset of the 
					--	RecArg in the ScEnv

539
540
541
542
type Call = (ConstrEnv, [CoreArg])
	-- The arguments of the call, together with the
	-- env giving the constructor bindings at the call site

543
544
545
546
547
548
549
550
nullUsage = SCU { calls = emptyVarEnv, occs = emptyVarEnv }

combineUsage u1 u2 = SCU { calls = plusVarEnv_C (++) (calls u1) (calls u2),
			   occs  = plusVarEnv_C combineOcc (occs u1) (occs u2) }

combineUsages [] = nullUsage
combineUsages us = foldr1 combineUsage us

551
552
553
554
lookupOcc :: ScUsage -> Var -> (ScUsage, ArgOcc)
lookupOcc (SCU { calls = sc_calls, occs = sc_occs }) bndr
  = (SCU {calls = sc_calls, occs = delVarEnv sc_occs bndr},
     lookupVarEnv sc_occs bndr `orElse` NoOcc)
555

556
557
558
559
560
561
562
563
lookupOccs :: ScUsage -> [Var] -> (ScUsage, [ArgOcc])
lookupOccs (SCU { calls = sc_calls, occs = sc_occs }) bndrs
  = (SCU {calls = sc_calls, occs = delVarEnvList sc_occs bndrs},
     [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

564
	    | ScrutOcc (UniqFM [ArgOcc])	-- See Note [ScrutOcc]
565
566

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

568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
{-	Note  [ScrutOcc]

An occurrence of ScrutOcc indicates that the thing is *only* taken apart or applied.

  Functions, litersl: ScrutOcc emptyUFM
  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'!

-}
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599

instance Outputable ArgOcc where
  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")

combineOcc NoOcc	 occ 	       = occ
combineOcc occ 		 NoOcc	       = occ
combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys)
combineOcc UnkOcc        UnkOcc        = UnkOcc
combineOcc _	    _	     	       = BothOcc

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

600
conArgOccs :: ArgOcc -> AltCon -> [ArgOcc]
601
-- Find usage of components of data con; returns [UnkOcc...] if unknown
602
603
604
605
606
607
608
609
610
611
-- See Note [ScrutOcc] for the extra UnkOccs in the vanilla datacon case

conArgOccs (ScrutOcc fm) (DataAlt dc) 
  | Just pat_arg_occs <- lookupUFM fm dc
  = tyvar_unks ++ pat_arg_occs
  where
    tyvar_unks | isVanillaDataCon dc = [UnkOcc | tv <- dataConTyVars dc]
	       | otherwise	     = []

conArgOccs other con = repeat UnkOcc
612
613
614
615
616
617
618
619
620
\end{code}


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

621
622
623
The main recursive function gathers up usage information, and
creates specialised versions of functions.

624
625
626
627
628
629
630
\begin{code}
scExpr :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
	-- The unique supply is needed when we invent
	-- a new name for the specialised function and its args

scExpr env e@(Type t) = returnUs (nullUsage, e)
scExpr env e@(Lit l)  = returnUs (nullUsage, e)
631
scExpr env e@(Var v)  = returnUs (varUsage env v UnkOcc, e)
632
633
634
635
636
scExpr env (Note n e) = scExpr env e	`thenUs` \ (usg,e') ->
			returnUs (usg, Note n e')
scExpr env (Lam b e)  = scExpr (extendBndr env b) e	`thenUs` \ (usg,e') ->
			returnUs (usg, Lam b e')

637
scExpr env (Case scrut b ty alts) 
638
639
640
641
642
643
644
645
646
  = do	{ (alt_usgs, alt_occs, alts') <- mapAndUnzip3Us sc_alt alts
	; let (alt_usg, b_occ) = lookupOcc (combineUsages alt_usgs) b
	      scrut_occ = foldr combineOcc b_occ alt_occs
		-- 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
	; (scrut_usg, scrut') <- scScrut env scrut scrut_occ
	; return (alt_usg `combineUsage` scrut_usg,
		  Case scrut' b ty alts') }
647
  where
648
649
650
651
652
653
654
655
    sc_alt (con,bs,rhs)
      = do { let env1 = extendCaseBndrs env b scrut con bs
	   ; (usg,rhs') <- scExpr env1 rhs
	   ; let (usg', arg_occs) = lookupOccs usg bs
		 scrut_occ = case con of
				DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)
				other	   -> ScrutOcc emptyUFM
	   ; return (usg', scrut_occ, (con,bs,rhs')) }
656
657
658
659
660
661
662

scExpr env (Let bind body)
  = scBind env bind	`thenUs` \ (env', bind_usg, bind') ->
    scExpr env' body	`thenUs` \ (body_usg, body') ->
    returnUs (bind_usg `combineUsage` body_usg, Let bind' body')

scExpr env e@(App _ _) 
663
664
  = do	{ let (fn, args) = collectArgs e
	; (fn_usg, fn') <- scScrut env fn (ScrutOcc emptyUFM)
665
666
667
668
	-- Process the function too.   It's 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
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
	-- We use scScrut to record the fact that the function is called
	-- Perhpas we should check that it has at least one value arg, 
	-- but currently we don't bother

	; (arg_usgs, args') <- mapAndUnzipUs (scExpr env) args
	; let call_usg = case fn of
		 	   Var f | Just RecFun <- lookupScopeEnv env f
			         -> SCU { calls = unitVarEnv f [(cons env, args)], 
				          occs  = emptyVarEnv }
			   other -> nullUsage
	; return (combineUsages arg_usgs `combineUsage` fn_usg 
				         `combineUsage` call_usg,
	          mkApps fn' args') }


----------------------
scScrut :: ScEnv -> CoreExpr -> ArgOcc -> UniqSM (ScUsage, CoreExpr)
-- Used for the scrutinee of a case, 
-- or the function of an application
scScrut env e@(Var v) occ = returnUs (varUsage env v occ, e)
scScrut env e	      occ = scExpr env e
690

691
692
693
694

----------------------
scBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, ScUsage, CoreBind)
scBind env (Rec [(fn,rhs)])
sof's avatar
sof committed
695
  | notNull val_bndrs
696
  = scExpr env_fn_body body		`thenUs` \ (usg, body') ->
697
698
699
700
    specialise env fn bndrs body' usg	`thenUs` \ (rules, spec_prs) ->
	-- Note body': the specialised copies should be based on the 
	-- 	       optimised version of the body, in case there were
	--	       nested functions inside.
701
702
703
    let
	SCU { calls = calls, occs = occs } = usg
    in
704
705
706
    returnUs (extendBndr env fn,	-- For the body of the letrec, just
					-- extend the env with Other to record 
					-- that it's in scope; no funny RecFun business
707
708
709
710
711
	      SCU { calls = calls `delVarEnv` fn, occs = occs `delVarEnvList` val_bndrs},
	      Rec ((fn `addIdSpecialisations` rules, mkLams bndrs body') : spec_prs))
  where
    (bndrs,body) = collectBinders rhs
    val_bndrs    = filter isId bndrs
712
    env_fn_body	 = extendRecBndr env fn bndrs
713
714
715
716
717
718
719
720
721
722
723
724
725
726

scBind env (Rec prs)
  = mapAndUnzipUs do_one prs	`thenUs` \ (usgs, prs') ->
    returnUs (extendBndrs env (map fst prs), combineUsages usgs, Rec prs')
  where
    do_one (bndr,rhs) = scExpr env rhs	`thenUs` \ (usg, rhs') ->
		        returnUs (usg, (bndr,rhs'))

scBind env (NonRec bndr rhs)
  = scExpr env rhs	`thenUs` \ (usg, rhs') ->
    returnUs (extendBndr env bndr, usg, NonRec bndr rhs')

----------------------
varUsage env v use 
727
728
729
  | Just RecArg <- lookupScopeEnv env v = SCU { calls = emptyVarEnv, 
						occs = unitVarEnv v use }
  | otherwise		   	        = nullUsage
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
\end{code}


%************************************************************************
%*									*
\subsection{The specialiser}
%*									*
%************************************************************************

\begin{code}
specialise :: ScEnv
	   -> Id 			-- Functionn
	   -> [CoreBndr] -> CoreExpr	-- Its RHS
	   -> ScUsage			-- Info on usage
	   -> UniqSM ([CoreRule], 	-- Rules
		      [(Id,CoreExpr)])	-- Bindings

747
748
749
750
751
752
753
754
755
756
757
758
specialise env fn bndrs body body_usg
  = do	{ let (_, bndr_occs) = lookupOccs body_usg bndrs

	; mb_calls <- mapM (callToPats (scope env) bndr_occs)
		   	   (lookupVarEnv (calls body_usg) fn `orElse` [])

	; let good_calls :: [([Var], [CoreArg])]
	      good_calls = catMaybes mb_calls
	      in_scope = mkInScopeSet $ unionVarSets $
			 [ exprsFreeVars pats `delVarSetList` vs 
			 | (vs,pats) <- good_calls ]
	      uniq_calls = nubBy (same_call in_scope) good_calls
759
760
    in
    mapAndUnzipUs (spec_one env fn (mkLams bndrs body)) 
761
		  (uniq_calls `zip` [1..]) }
762
  where
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
	-- Two calls are the same if they match both ways
    same_call in_scope (vs1,as1)(vs2,as2)
	 =  isJust (matchN in_scope vs1 as1 as2)
 	 && isJust (matchN in_scope vs2 as2 as1)

callToPats :: InScopeEnv -> [ArgOcc] -> Call
	   -> UniqSM (Maybe ([Var], [CoreExpr]))
	-- The VarSet is the variables to quantify over in the rule
	-- The [CoreExpr] are the argument patterns for the rule
callToPats in_scope bndr_occs (con_env, args)
  | length args < length bndr_occs	-- Check saturated
  = return Nothing
  | otherwise
  = do	{ prs <- argsToPats in_scope con_env (args `zip` bndr_occs)
	; let (good_pats, pats) = unzip prs
	      pat_fvs = varSetElems (exprsFreeVars pats)
	      qvars   = filter (not . (`elemVarEnv` in_scope)) pat_fvs
		-- Quantify over variables that are not in sccpe
		-- See Note [Shadowing] at the top
		
	; if or good_pats 
	  then return (Just (qvars, pats))
	  else return Nothing }
786
787
788
789
790

---------------------
spec_one :: ScEnv
	 -> Id					-- Function
	 -> CoreExpr				-- Rhs of the original function
791
	 -> (([Var], [CoreArg]), Int)
792
793
	 -> UniqSM (CoreRule, (Id,CoreExpr))	-- Rule and binding

794
795
796
797
-- 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 :-).

798
799
800
801
{- 
  Example
  
     In-scope: a, x::a   
802
803
     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]
804
  ==>
805
806
     f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
		  (...entire RHS of f...) (b,c) ((:) (a,(b,c)) (x,v) hw)
807
  
808
809
810
     RULE:  forall b::* c::*,		-- Note, *not* forall a, x
		   v::(b,c),
		   hw::[(a,(b,c))] .
811
  
812
	    f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
813
814
-}

815
spec_one env fn rhs ((vars_to_bind, pats), rule_number)
816
  = getUniqueUs 		`thenUs` \ spec_uniq ->
817
818
819
820
    let 
	fn_name      = idName fn
	fn_loc       = nameSrcLoc fn_name
	spec_occ     = mkSpecOcc (nameOccName fn_name)
821

822
823
		-- Put the type variables first; the type of a term
		-- variable may mention a type variable
824
825
	(tvs, ids)   = partition isTyVar vars_to_bind
	bndrs  	     = tvs ++ ids
826
827
	spec_body    = mkApps rhs pats
	body_ty	     = exprType spec_body
828
	
829
830
831
832
	(spec_lam_args, spec_call_args) = mkWorkerArgs bndrs body_ty
		-- Usual w/w hack to avoid generating 
		-- a spec_rhs of unlifted type and no args
	
833
	rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number))
834
835
	spec_rhs  = mkLams spec_lam_args spec_body
	spec_id   = mkUserLocal spec_occ spec_uniq (mkPiTypes spec_lam_args body_ty) fn_loc
836
837
	rule_rhs  = mkVarApps (Var spec_id) spec_call_args
	rule      = mkLocalRule rule_name specConstrActivation fn_name bndrs pats rule_rhs
838
839
    in
    returnUs (rule, (spec_id, spec_rhs))
840
841
842
843
844
845
846
847
848
849
850

-- 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
851
\end{code}
852
853
854
855
856
857
858
859
860
861

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

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

862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
---------------------
good_arg :: ConstrEnv -> IdEnv ArgOcc -> (CoreBndr, CoreArg) -> Bool
-- See Note [Good arguments] above
good_arg con_env arg_occs (bndr, arg)
  = case is_con_app_maybe con_env arg of	
	Just _ ->  bndr_usg_ok arg_occs bndr arg
	other   -> False

bndr_usg_ok :: IdEnv ArgOcc -> Var -> CoreArg -> Bool
bndr_usg_ok arg_occs bndr arg
  = case lookupVarEnv arg_occs bndr of
	Just ScrutOcc -> True			-- Used only by case scrutiny
	Just Both     -> case arg of		-- Used by case and elsewhere
			    App _ _ -> True	-- so the arg should be an explicit con app
			    other   -> False
	other -> False				-- Not used, or used wonkily
    

880
881
882
883
884
885
886
\begin{code}
    -- 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)

887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
argToPat :: InScopeEnv			-- What's in scope at the fn defn site
	 -> ConstrEnv			-- ConstrEnv at the call site
	 -> 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

argToPat in_scope con_env arg@(Type ty) arg_occ
  = return (False, arg)

argToPat in_scope con_env (Var v) arg_occ	-- Don't uniqify existing vars,
  = return (interesting, Var v)	-- so that we can spot when we pass them twice
907
  where
908
    interesting = not (isLocalId v) || v `elemVarEnv` in_scope
909

910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
argToPat in_scope con_env arg arg_occ
  | 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

argToPat in_scope con_env arg arg_occ
  | Just (CV dc args) <- is_con_app_maybe con_env arg
  , case arg_occ of
	ScrutOcc _ -> True		-- Used only by case scrutinee
	BothOcc    -> case arg of	-- Used by case scrut
			App {} -> True	-- ...and elsewhere...
			other  -> False
	other	   -> False	-- No point; the arg is not decomposed
927
  = do	{ args' <- argsToPats in_scope con_env (args `zip` conArgOccs arg_occ dc)
928
929
930
931
932
933
934
935
936
937
938
939
940
941
	; return (True, mk_con_app dc (map snd args')) }

argToPat in_scope con_env arg arg_occ
  = do	{ uniq <- getUniqueUs
	; let id = mkSysLocal FSLIT("sc") uniq (exprType arg)
	; return (False, Var id) }

argsToPats :: InScopeEnv -> ConstrEnv
	   -> [(CoreArg, ArgOcc)]
	   -> UniqSM [(Bool, CoreArg)]
argsToPats in_scope con_env args
  = mapUs do_one args
  where
    do_one (arg,occ) = argToPat in_scope con_env arg occ
942
943
944
945
\end{code}


\begin{code}
946
is_con_app_maybe :: ConstrEnv -> CoreExpr -> Maybe ConValue
947
is_con_app_maybe env (Var v)
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
948
949
950
951
952
953
954
955
956
957
  = case lookupVarEnv env v of
	Just stuff -> Just stuff
		-- You might think we could look in the idUnfolding here
		-- but that doesn't take account of which branch of a 
		-- case we are in, which is the whole point

	Nothing | isCheapUnfolding unf
		-> is_con_app_maybe env (unfoldingTemplate unf)
		where
		  unf = idUnfolding v
958
959
		-- However we do want to consult the unfolding 
		-- as well, for let-bound constructors!
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
960
961

	other  -> Nothing
962
963

is_con_app_maybe env (Lit lit)
964
  = Just (CV (LitAlt lit) [])
965
966
967

is_con_app_maybe env expr
  = case collectArgs expr of
968
	(Var fun, args) | Just con <- isDataConWorkId_maybe fun,
sof's avatar
sof committed
969
			  args `lengthAtLeast` dataConRepArity con
970
		-- Might be > because the arity excludes type args
971
		        -> Just (CV (DataAlt con) args)
972
973
974
975
976
977
978

	other -> Nothing

mk_con_app :: AltCon -> [CoreArg] -> CoreExpr
mk_con_app (LitAlt lit)  []   = Lit lit
mk_con_app (DataAlt con) args = mkConApp con args
\end{code}