DsBinds.lhs 27.6 KB
Newer Older
1
%
Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2006
3
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
%
Simon Marlow's avatar
Simon Marlow committed
5
6

Pattern-matching bindings (HsBinds and MonoBinds)
7

8
9
10
Handles @HsBinds@; those at the top level require different handling,
in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at
lower levels it is preserved with @let@/@letrec@s).
11
12

\begin{code}
13
module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
14
		 dsHsWrapper, dsTcEvBinds, dsEvBinds, wrapDsEvBinds, 
15
		 DsEvBind(..), AutoScc(..)
16
  ) where
17

18
19
#include "HsVersions.h"

20
import {-# SOURCE #-}	DsExpr( dsLExpr )
21
22
import {-# SOURCE #-}	Match( matchWrapper )

23
import DsMonad
Simon Marlow's avatar
Simon Marlow committed
24
import DsGRHSs
25
import DsUtils
26

27
28
import HsSyn		-- lots of things
import CoreSyn		-- lots of things
29
import CoreSubst
30
import MkCore
Simon Marlow's avatar
Simon Marlow committed
31
import CoreUtils
32
import CoreArity ( etaExpand )
33
import CoreUnfold
34
import CoreFVs
35
import Digraph
36

37
import TcType
38
import Type
39
import Coercion
40
import TysPrim  ( anyTypeOfKind )
Simon Marlow's avatar
Simon Marlow committed
41
42
43
import CostCentre
import Module
import Id
44
45
46
import TyCon	( tyConDataCons )
import Class
import DataCon	( dataConRepType )
47
import Name	( localiseName )
48
import MkId	( seqId )
49
import Var
50
import VarSet
Simon Marlow's avatar
Simon Marlow committed
51
import Rules
52
import VarEnv
53
import Outputable
Simon Marlow's avatar
Simon Marlow committed
54
55
import SrcLoc
import Maybes
56
import OrdList
Simon Marlow's avatar
Simon Marlow committed
57
58
59
import Bag
import BasicTypes hiding ( TopLevel )
import FastString
60
import Util
Simon Marlow's avatar
Simon Marlow committed
61

62
import MonadUtils
63
64
65
66
67
68
69
70
71
\end{code}

%************************************************************************
%*									*
\subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
%*									*
%************************************************************************

\begin{code}
72
73
dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
dsTopLHsBinds auto_scc binds = ds_lhs_binds auto_scc binds
74

75
dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
76
77
dsLHsBinds binds = do { binds' <- ds_lhs_binds NoSccs binds
                      ; return (fromOL binds') }
78
79

------------------------
80
ds_lhs_binds :: AutoScc -> LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
81

82
	 -- scc annotation policy (see below)
83
84
ds_lhs_binds auto_scc binds = do { ds_bs <- mapBagM (dsLHsBind auto_scc) binds
                                 ; return (foldBag appOL id nilOL ds_bs) }
85

86
87
88
dsLHsBind :: AutoScc -> LHsBind Id -> DsM (OrdList (Id,CoreExpr))
dsLHsBind auto_scc (L loc bind)
  = putSrcSpanDs loc $ dsHsBind auto_scc bind
89

90
dsHsBind :: AutoScc -> HsBind Id -> DsM (OrdList (Id,CoreExpr))
91

92
dsHsBind _ (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless })
93
  = do  { core_expr <- dsLExpr expr
94
95
96
97
98
99

	        -- Dictionary bindings are always VarBinds,
	        -- so we only need do this here
	; core_expr' <- addDictScc var core_expr
	; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr'
	      	   | otherwise         = var
100

101
	; return (unitOL (makeCorePair var' False 0 core_expr')) }
102

103
dsHsBind auto_scc (FunBind { fun_id = L _ fun, fun_matches = matches
104
105
		    , fun_co_fn = co_fn, fun_tick = tick 
                    , fun_infix = inf }) 
106
107
 = do	{ (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches
	; body'    <- mkOptTickBox tick body
108
	; wrap_fn' <- dsHsWrapper co_fn 
109
	; let rhs = addAutoScc auto_scc fun $ wrap_fn' (mkLams args body')
110
	; return (unitOL (makeCorePair fun False 0 rhs)) }
111

112
dsHsBind auto_scc (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty })
113
114
  = do	{ body_expr <- dsGuarded grhss ty
	; sel_binds <- mkSelectorBinds pat body_expr
115
116
	  -- We silently ignore inline pragmas; no makeCorePair
	  -- Not so cool, but really doesn't matter
117
118
119
    ; let sel_binds' = [ (v, addAutoScc auto_scc v expr)
                       | (v, expr) <- sel_binds ]
	; return (toOL sel_binds') }
sof's avatar
sof committed
120

121
	-- A common case: one exported variable
122
	-- Non-recursive bindings come through this way
123
124
	-- So do self-recursive bindings, and recursive bindings
	-- that have been chopped up with type signatures
125
126
127
dsHsBind auto_scc (AbsBinds { abs_tvs = all_tyvars, abs_ev_vars = dicts
               		    , abs_exports = [(tyvars, global, local, prags)]
               		    , abs_ev_binds = ev_binds, abs_binds = binds })
128
  = ASSERT( all (`elem` tyvars) all_tyvars )
129
130
    do	{ bind_prs    <- ds_lhs_binds NoSccs binds
        ; ds_ev_binds <- dsTcEvBinds ev_binds
131

132
	; let	core_bind = Rec (fromOL bind_prs)
133
	        rhs       = addAutoScc auto_scc global $
134
135
136
137
			    mkLams tyvars $ mkLams dicts $ 
	                    wrapDsEvBinds ds_ev_binds $
                            Let core_bind $
                            Var local
138
    
139
	; (spec_binds, rules) <- dsSpecs rhs prags
140
141

	; let   global'   = addIdSpecialisations global rules
142
143
		main_bind = makeCorePair global' (isDefaultMethod prags)
                                         (dictArity dicts) rhs 
144
    
145
	; return (main_bind `consOL` spec_binds) }
sof's avatar
sof committed
146

147
148
149
150
151
dsHsBind auto_scc (AbsBinds { abs_tvs = all_tyvars, abs_ev_vars = dicts
                            , abs_exports = exports, abs_ev_binds = ev_binds
                       	    , abs_binds = binds })
  = do	{ bind_prs    <- ds_lhs_binds NoSccs binds
        ; ds_ev_binds <- dsTcEvBinds ev_binds
152
	; let env = mkABEnv exports
153
154
	      do_one (lcl_id,rhs) | Just (_, gbl_id, _, _prags) <- lookupVarEnv env lcl_id
			          = (lcl_id, addAutoScc auto_scc gbl_id rhs)
155
156
				  | otherwise = (lcl_id,rhs)
	       
157
158
	      core_bind = Rec (map do_one (fromOL bind_prs))
	      	-- Monomorphic recursion possible, hence Rec
159

160
161
162
	      tup_expr     = mkBigCoreVarTup locals
	      tup_ty	   = exprType tup_expr
	      poly_tup_rhs = mkLams all_tyvars $ mkLams dicts $
163
164
165
	      		     wrapDsEvBinds ds_ev_binds $
			     Let core_bind $
	 	     	     tup_expr
166
167
	      locals       = [local | (_, _, local, _) <- exports]
	      local_tys    = map idType locals
168

169
	; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
170

171
	; let mk_bind ((tyvars, global, _, spec_prags), n)  -- locals!!n == local
172
173
	        = 	-- Need to make fresh locals to bind in the selector,
		      	-- because some of the tyvars will be bound to 'Any'
174
175
		  do { let ty_args = map mk_ty_arg all_tyvars
		           substitute = substTyWith all_tyvars ty_args
176
		     ; locals' <- newSysLocalsDs (map substitute local_tys)
177
		     ; tup_id  <- newSysLocalDs  (substitute tup_ty)
178
	             ; let rhs = mkLams tyvars $ mkLams dicts $
179
	      	     		 mkTupleSelector locals' (locals' !! n) tup_id $
180
181
			         mkVarApps (mkTyApps (Var poly_tup_id) ty_args)
			 		   dicts
182
183
184
                           full_rhs = Let (NonRec poly_tup_id poly_tup_rhs) rhs
		     ; (spec_binds, rules) <- dsSpecs full_rhs spec_prags
				                      
185
		     ; let global' = addIdSpecialisations global rules
186
		     ; return ((global', rhs) `consOL` spec_binds) }
187
	        where
188
	          mk_ty_arg all_tyvar
189
			| all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
190
	      		| otherwise		  = dsMkArbitraryType all_tyvar
191

192
	; export_binds_s <- mapM mk_bind (exports `zip` [0..])
193
	     -- Don't scc (auto-)annotate the tuple itself.
194

195
196
197
198
199
200
201
	; return ((poly_tup_id, poly_tup_rhs) `consOL` 
		    concatOL export_binds_s) }

--------------------------------------
data DsEvBind 
  = LetEvBind		-- Dictionary or coercion
      CoreBind		-- recursive or non-recursive
202

203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
  | CaseEvBind		-- Coercion binding by superclass selection
    			-- Desugars to case d of d { K _ g _ _ _ -> ... } 			
      DictId 		   -- b   The dictionary
      AltCon 		   -- K   Its constructor
      [CoreBndr] 	   -- _ g _ _ _   The binders in the alternative

wrapDsEvBinds :: [DsEvBind] -> CoreExpr -> CoreExpr
wrapDsEvBinds ds_ev_binds body = foldr wrap_one body ds_ev_binds
  where
    body_ty = exprType body
    wrap_one (LetEvBind b)       body = Let b body
    wrap_one (CaseEvBind x k xs) body = Case (Var x) x body_ty [(k,xs,body)]

dsTcEvBinds :: TcEvBinds -> DsM [DsEvBind]
dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds"	-- Zonker has got rid of this
dsTcEvBinds (EvBinds bs)   = dsEvBinds bs

dsEvBinds :: Bag EvBind -> DsM [DsEvBind]
dsEvBinds bs = return (map dsEvGroup sccs)
  where
    sccs :: [SCC EvBind]
    sccs = stronglyConnCompFromEdgedVertices edges

    edges :: [(EvBind, EvVar, [EvVar])]
    edges = foldrBag ((:) . mk_node) [] bs 

    mk_node :: EvBind -> (EvBind, EvVar, [EvVar])
    mk_node b@(EvBind var term) = (b, var, free_vars_of term)

    free_vars_of :: EvTerm -> [EvVar]
233
    free_vars_of (EvId v)           = [v]
234
235
    free_vars_of (EvCast v co)      = v : varSetElems (tyCoVarsOfCo co)
    free_vars_of (EvCoercion co)    = varSetElems (tyCoVarsOfCo co)
236
237
    free_vars_of (EvDFunApp _ _ vs) = vs
    free_vars_of (EvSuperClass d _) = [d]
238
239
240
241
242
243
244
245
246
247
248
249
250

dsEvGroup :: SCC EvBind -> DsEvBind
dsEvGroup (AcyclicSCC (EvBind co_var (EvSuperClass dict n)))
  | isCoVar co_var	 -- An equality superclass
  = ASSERT( null other_data_cons )
    CaseEvBind dict (DataAlt data_con) bndrs
  where
    (cls, tys) = getClassPredTys (evVarPred dict)
    (data_con:other_data_cons) = tyConDataCons (classTyCon cls)
    (ex_tvs, theta, rho) = tcSplitSigmaTy (applyTys (dataConRepType data_con) tys)
    (arg_tys, _) = splitFunTys rho
    bndrs = ex_tvs ++ map mk_wild_pred (theta `zip` [0..])
                   ++ map mkWildValBinder arg_tys
251
    mk_wild_pred (p, i) | i==n      = ASSERT( p `eqPred` (coVarPred co_var)) 
252
253
254
255
256
257
258
259
260
261
262
263
                                      co_var
                        | otherwise = mkWildEvBinder p
    
dsEvGroup (AcyclicSCC (EvBind v r))
  = LetEvBind (NonRec v (dsEvTerm r))

dsEvGroup (CyclicSCC bs)
  = LetEvBind (Rec (map ds_pair bs))
  where
    ds_pair (EvBind v r) = (v, dsEvTerm r)

dsEvTerm :: EvTerm -> CoreExpr
264
265
266
dsEvTerm (EvId v)                = Var v
dsEvTerm (EvCast v co)           = Cast (Var v) co
dsEvTerm (EvDFunApp df tys vars) = Var df `mkTyApps` tys `mkVarApps` vars
267
dsEvTerm (EvCoercion co)         = Coercion co
268
269
270
271
272
273
274
275
276
277
dsEvTerm (EvSuperClass d n)
  = ASSERT( isClassPred (classSCTheta cls !! n) )
    	    -- We can only select *dictionary* superclasses
	    -- in terms.  Equality superclasses are dealt with
	    -- in dsEvGroup, where they can generate a case expression
    Var sc_sel_id `mkTyApps` tys `App` Var d
  where
    sc_sel_id  = classSCSelId cls n	-- Zero-indexed
    (cls, tys) = getClassPredTys (evVarPred d)    
    
278
------------------------
279
280
281
282
283
makeCorePair :: Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr)
makeCorePair gbl_id is_default_method dict_arity rhs
  | is_default_method		      -- Default methods are *always* inlined
  = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs)

284
285
286
287
288
289
  | otherwise
  = case inlinePragmaSpec inline_prag of
      	  EmptyInlineSpec -> (gbl_id, rhs)
      	  NoInline        -> (gbl_id, rhs)
      	  Inlinable       -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)
          Inline          -> inline_pair
290

291
292
293
294
295
  where
    inline_prag   = idInlinePragma gbl_id
    inlinable_unf = mkInlinableUnfolding rhs
    inline_pair
       | Just arity <- inlinePragmaSat inline_prag
296
297
      	-- Add an Unfolding for an INLINE (but not for NOINLINE)
	-- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
298
       , let real_arity = dict_arity + arity
299
        -- NB: The arity in the InlineRule takes account of the dictionaries
300
301
302
303
304
305
       = ( gbl_id `setIdUnfolding` mkInlineUnfolding (Just real_arity) rhs
         , etaExpand real_arity rhs)

       | otherwise
       = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $
         (gbl_id `setIdUnfolding` mkInlineUnfolding Nothing rhs, rhs)
306
307
308
309
310
311


dictArity :: [Var] -> Arity
-- Don't count coercion variables in arity
dictArity dicts = count isId dicts

312
313

------------------------
314
type AbsBindEnv = VarEnv ([TyVar], Id, Id, TcSpecPrags)
315
316
317
	-- Maps the "lcl_id" for an AbsBind to
	-- its "gbl_id" and associated pragmas, if any

318
mkABEnv :: [([TyVar], Id, Id, TcSpecPrags)] -> AbsBindEnv
319
-- Takes the exports of a AbsBinds, and returns a mapping
320
321
--	lcl_id -> (tyvars, gbl_id, lcl_id, prags)
mkABEnv exports = mkVarEnv [ (lcl_id, export) | export@(_, _, lcl_id, _) <- exports]
322
323
\end{code}

324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
Note [Rules and inlining]
~~~~~~~~~~~~~~~~~~~~~~~~~
Common special case: no type or dictionary abstraction
This is a bit less trivial than you might suppose
The naive way woudl be to desguar to something like
	f_lcl = ...f_lcl...	-- The "binds" from AbsBinds
	M.f = f_lcl		-- Generated from "exports"
But we don't want that, because if M.f isn't exported,
it'll be inlined unconditionally at every call site (its rhs is 
trivial).  That would be ok unless it has RULES, which would 
thereby be completely lost.  Bad, bad, bad.

Instead we want to generate
	M.f = ...f_lcl...
	f_lcl = M.f
Now all is cool. The RULES are attached to M.f (by SimplCore), 
and f_lcl is rapidly inlined away.

This does not happen in the same way to polymorphic binds,
because they desugar to
	M.f = /\a. let f_lcl = ...f_lcl... in f_lcl
Although I'm a bit worried about whether full laziness might
346
float the f_lcl binding out and then inline M.f at its call site
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
375
376
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

Note [Specialising in no-dict case]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Even if there are no tyvars or dicts, we may have specialisation pragmas.
Class methods can generate
      AbsBinds [] [] [( ... spec-prag]
         { AbsBinds [tvs] [dicts] ...blah }
So the overloading is in the nested AbsBinds. A good example is in GHC.Float:

  class  (Real a, Fractional a) => RealFrac a  where
    round :: (Integral b) => a -> b

  instance  RealFrac Float  where
    {-# SPECIALIZE round :: Float -> Int #-}

The top-level AbsBinds for $cround has no tyvars or dicts (because the 
instance does not).  But the method is locally overloaded!

Note [Abstracting over tyvars only]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When abstracting over type variable only (not dictionaries), we don't really need to
built a tuple and select from it, as we do in the general case. Instead we can take

	AbsBinds [a,b] [ ([a,b], fg, fl, _),
		         ([b],   gg, gl, _) ]
		{ fl = e1
		  gl = e2
		   h = e3 }

and desugar it to

	fg = /\ab. let B in e1
	gg = /\b. let a = () in let B in S(e2)
	h  = /\ab. let B in e3

where B is the *non-recursive* binding
	fl = fg a b
	gl = gg b
	h  = h a b    -- See (b); note shadowing!

Notice (a) g has a different number of type variables to f, so we must
	     use the mkArbitraryType thing to fill in the gaps.  
	     We use a type-let to do that.

	 (b) The local variable h isn't in the exports, and rather than
	     clone a fresh copy we simply replace h by (h a b), where
	     the two h's have different types!  Shadowing happens here,
	     which looks confusing but works fine.

	 (c) The result is *still* quadratic-sized if there are a lot of
	     small bindings.  So if there are more than some small
	     number (10), we filter the binding set B by the free
	     variables of the particular RHS.  Tiresome.

Why got to this trouble?  It's a common case, and it removes the
quadratic-sized tuple desugaring.  Less clutter, hopefullly faster
compilation, especially in a case where there are a *lot* of
bindings.


407
408
409
410
411
412
413
414
415
416
417
418
419
Note [Eta-expanding INLINE things]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
   foo :: Eq a => a -> a
   {-# INLINE foo #-}
   foo x = ...

If (foo d) ever gets floated out as a common sub-expression (which can
happen as a result of method sharing), there's a danger that we never 
get to do the inlining, which is a Terribly Bad thing given that the
user said "inline"!

To avoid this we pre-emptively eta-expand the definition, so that foo
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
420
421
422
has the arity with which it is declared in the source code.  In this
example it has arity 2 (one for the Eq and one for x). Doing this 
should mean that (foo d) is a PAP and we don't share it.
423
424
425

Note [Nested arities]
~~~~~~~~~~~~~~~~~~~~~
426
427
428
429
430
431
432
433
434
435
436
437
438
439
For reasons that are not entirely clear, method bindings come out looking like
this:

  AbsBinds [] [] [$cfromT <= [] fromT]
    $cfromT [InlPrag=INLINE] :: T Bool -> Bool
    { AbsBinds [] [] [fromT <= [] fromT_1]
        fromT :: T Bool -> Bool
        { fromT_1 ((TBool b)) = not b } } }

Note the nested AbsBind.  The arity for the InlineRule on $cfromT should be
gotten from the binding for fromT_1.

It might be better to have just one level of AbsBinds, but that requires more
thought!
440

441
442
443
444
445
Note [Implementing SPECIALISE pragmas]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Example:
	f :: (Eq a, Ix b) => a -> b -> Bool
	{-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-}
446
        f = <poly_rhs>
447
448
449
450
451
452
453
454
455

From this the typechecker generates

    AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds

    SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX
                      -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ])

Note that wrap_fn can transform *any* function with the right type prefix 
456
457
    forall ab. (Eq a, Ix b) => XXX
regardless of XXX.  It's sort of polymorphic in XXX.  This is
458
459
460
461
462
463
464
465
useful: we use the same wrapper to transform each of the class ops, as
well as the dict.

From these we generate:

    Rule: 	forall p, q, (dp:Ix p), (dq:Ix q). 
                    f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq

466
    Spec bind:	f_spec = wrap_fn <poly_rhs>
467
468
469
470
471
472
473

Note that 

  * The LHS of the rule may mention dictionary *expressions* (eg
    $dfIxPair dp dq), and that is essential because the dp, dq are
    needed on the RHS.

474
475
  * The RHS of f_spec, <poly_rhs> has a *copy* of 'binds', so that it 
    can fully specialise it.
476

477
478
\begin{code}
------------------------
479
dsSpecs :: CoreExpr     -- Its rhs
480
        -> TcSpecPrags
481
        -> DsM ( OrdList (Id,CoreExpr) 	-- Binding for specialised Ids
482
	       , [CoreRule] )		-- Rules for the Global Ids
483
-- See Note [Implementing SPECIALISE pragmas]
484
485
486
487
488
489
490
491
492
493
494
495
dsSpecs _ IsDefaultMethod = return (nilOL, [])
dsSpecs poly_rhs (SpecPrags sps)
  = do { pairs <- mapMaybeM (dsSpec (Just poly_rhs)) sps
       ; let (spec_binds_s, rules) = unzip pairs
       ; return (concatOL spec_binds_s, rules) }

dsSpec :: Maybe CoreExpr  	-- Just rhs => RULE is for a local binding
       	  			-- Nothing => RULE is for an imported Id
				-- 	      rhs is in the Id's unfolding
       -> Located TcSpecPrag
       -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
496
497
498
499
500
501
502
503
504
  | isJust (isClassOpId_maybe poly_id)
  = putSrcSpanDs loc $ 
    do { warnDs (ptext (sLit "Ignoring useless SPECIALISE pragma for class method selector") 
                 <+> quotes (ppr poly_id))
       ; return Nothing  }  -- There is no point in trying to specialise a class op
       	 		    -- Moreover, classops don't (currently) have an inl_sat arity set
			    -- (it would be Just 0) and that in turn makes makeCorePair bleat

  | otherwise
505
506
507
508
509
510
  = putSrcSpanDs loc $ 
    do { let poly_name = idName poly_id
       ; spec_name <- newLocalName poly_name
       ; wrap_fn   <- dsHsWrapper spec_co
       ; let (bndrs, ds_lhs) = collectBinders (wrap_fn (Var poly_id))
             spec_ty = mkPiTypes bndrs (exprType ds_lhs)
511
512
513
       ; case decomposeRuleLhs bndrs ds_lhs of {
           Left msg -> do { warnDs msg; return Nothing } ;
           Right (final_bndrs, _fn, args) -> do
514
515
516
517
518
519

       { (spec_unf, unf_pairs) <- specUnfolding wrap_fn spec_ty (realIdUnfolding poly_id)

       ; let spec_id  = mkLocalId spec_name spec_ty 
         	            `setInlinePragma` inl_prag
         	 	    `setIdUnfolding`  spec_unf
520
521
522
523
524
             inl_prag | not (isDefaultInlinePragma spec_inl)    = spec_inl
         	      | not is_local_id  -- See Note [Specialising imported functions]
		      	    		 -- in OccurAnal
                      , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma
		      | otherwise                               = idInlinePragma poly_id
525
526
527
528
529
530
       	      -- Get the INLINE pragma from SPECIALISE declaration, or,
              -- failing that, from the original Id

             rule =  mkRule False {- Not auto -} is_local_id
                        (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
       			AlwaysActive poly_name
531
       		        final_bndrs args
532
533
534
535
536
537
538
539
540
541
       			(mkVarApps (Var spec_id) bndrs)

             spec_rhs  = wrap_fn poly_rhs
             spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs

       ; return (Just (spec_pair `consOL` unf_pairs, rule))
       } } }
  where
    is_local_id = isJust mb_poly_rhs
    poly_rhs | Just rhs <-  mb_poly_rhs
542
543
544
545
546
547
             = rhs  	    -- Local Id; this is its rhs
             | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id)
             = unfolding    -- Imported Id; this is its unfolding
	       		    -- Use realIdUnfolding so we get the unfolding 
			    -- even when it is a loop breaker. 
			    -- We want to specialise recursive functions!
548
             | otherwise = pprPanic "dsImpSpecs" (ppr poly_id)
549
	                    -- The type checker has checked that it *has* an unfolding
550

551
specUnfolding :: (CoreExpr -> CoreExpr) -> Type 
552
              -> Unfolding -> DsM (Unfolding, OrdList (Id,CoreExpr))
553
554
555
{-   [Dec 10: TEMPORARILY commented out, until we can straighten out how to
              generate unfoldings for specialised DFuns

556
specUnfolding wrap_fn spec_ty (DFunUnfolding _ _ ops)
557
558
  = do { let spec_rhss = map wrap_fn ops
       ; spec_ids <- mapM (mkSysLocalM (fsLit "spec") . exprType) spec_rhss
559
       ; return (mkDFunUnfolding spec_ty (map Var spec_ids), toOL (spec_ids `zip` spec_rhss)) }
560
-}
561
specUnfolding _ _ _
562
  = return (noUnfolding, nilOL)
563

564
565
dsMkArbitraryType :: TcTyVar -> Type
dsMkArbitraryType tv = anyTypeOfKind (tyVarKind tv)
566
567
\end{code}

568
569
570
571
572
573
574
%************************************************************************
%*									*
\subsection{Adding inline pragmas}
%*									*
%************************************************************************

\begin{code}
575
decomposeRuleLhs :: [Var] -> CoreExpr -> Either SDoc ([Var], Id, [CoreExpr])
576
577
578
579
-- Take apart the LHS of a RULE.  It's suuposed to look like
--     /\a. f a Int dOrdInt
-- or  /\a.\d:Ord a. let { dl::Ord [a] = dOrdList a d } in f [a] dl
-- That is, the RULE binders are lambda-bound
580
-- Returns Nothing if the LHS isn't of the expected shape
581
decomposeRuleLhs bndrs lhs 
582
  =  -- Note [Simplifying the left-hand side of a RULE]
583
584
    case collectArgs opt_lhs of
        (Var fn, args) -> check_bndrs fn args
Simon Marlow's avatar
Simon Marlow committed
585

586
587
        (Case scrut bndr ty [(DEFAULT, _, body)], args)
	        | isDeadBinder bndr	-- Note [Matching seqId]
588
		-> check_bndrs seqId (args' ++ args)
589
590
591
		where
		   args' = [Type (idType bndr), Type ty, scrut, body]
	   
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
	_other -> Left bad_shape_msg
 where
   opt_lhs = simpleOptExpr lhs

   check_bndrs fn args
     | null (dead_bndrs) = Right (extra_dict_bndrs ++ bndrs, fn, args)
     | otherwise         = Left (vcat (map dead_msg dead_bndrs))
     where
       arg_fvs = exprsFreeVars args

            -- Check for dead binders: Note [Unused spec binders]
       dead_bndrs = filterOut (`elemVarSet` arg_fvs) bndrs

            -- Add extra dict binders: Note [Constant rule dicts]
       extra_dict_bndrs = [ mkLocalId (localiseName (idName d)) (idType d)
                          | d <- varSetElems (arg_fvs `delVarSetList` bndrs)
         	          , isDictId d]


   bad_shape_msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar"))
                      2 (ppr opt_lhs)
613
614
   dead_msg bndr = hang (sep [ ptext (sLit "Forall'd") <+> pp_bndr bndr
			     , ptext (sLit "is not bound in RULE lhs")])
615
616
                      2 (ppr opt_lhs)
   pp_bndr bndr
617
618
619
    | isTyVar bndr  = ptext (sLit "type variable") <+> quotes (ppr bndr)
    | isEvVar bndr  = ptext (sLit "constraint") <+> quotes (ppr (evVarPred bndr))
    | otherwise     = ptext (sLit "variable") <+> quotes (ppr bndr)
620
621
\end{code}

622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
Note [Simplifying the left-hand side of a RULE]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
simpleOptExpr occurrence-analyses and simplifies the lhs
and thereby
(a) sorts dict bindings into NonRecs and inlines them
(b) substitute trivial lets so that they don't get in the way
    Note that we substitute the function too; we might 
    have this as a LHS:  let f71 = M.f Int in f71
(c) does eta reduction

For (c) consider the fold/build rule, which without simplification
looked like:
	fold k z (build (/\a. g a))  ==>  ...
This doesn't match unless you do eta reduction on the build argument.
Similarly for a LHS like
	augment g (build h) 
we do not want to get
	augment (\a. g a) (build h)
otherwise we don't match when given an argument like
	augment (\a. h a a) (build h)

NB: tcSimplifyRuleLhs is very careful not to generate complicated
    dictionary expressions that we might have to match

646
Note [Matching seqId]
647
648
649
650
651
~~~~~~~~~~~~~~~~~~~
The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
and this code turns it back into an application of seq!  
See Note [Rules for seq] in MkId for the details.

652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
Note [Unused spec binders]
~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
	f :: a -> a
	{-# SPECIALISE f :: Eq a => a -> a #-}
It's true that this *is* a more specialised type, but the rule
we get is something like this:
	f_spec d = f
	RULE: f = f_spec d
Note that the rule is bogus, becuase it mentions a 'd' that is
not bound on the LHS!  But it's a silly specialisation anyway, becuase
the constraint is unused.  We could bind 'd' to (error "unused")
but it seems better to reject the program because it's almost certainly
a mistake.  That's what the isDeadBinder call detects.

Note [Constant rule dicts]
~~~~~~~~~~~~~~~~~~~~~~~
When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict, 
which is presumably in scope at the function definition site, we can quantify 
over it too.  *Any* dict with that type will do.

So for example when you have
	f :: Eq a => a -> a
	f = <rhs>
	{-# SPECIALISE f :: Int -> Int #-}

Then we get the SpecPrag
	SpecPrag (f Int dInt) 

And from that we want the rule
	
	RULE forall dInt. f Int dInt = f_spec
	f_spec = let f = <rhs> in f Int dInt

But be careful!  That dInt might be GHC.Base.$fOrdInt, which is an External
Name, and you can't bind them in a lambda or forall without getting things
confused.   Likewise it might have an InlineRule or something, which would be
utterly bogus. So we really make a fresh Id, with the same unique and type
as the old one, but with an Internal name and no IdInfo.

692

sof's avatar
sof committed
693
694
695
696
697
698
699
%************************************************************************
%*									*
\subsection[addAutoScc]{Adding automatic sccs}
%*									*
%************************************************************************

\begin{code}
700
701
702
data AutoScc = NoSccs 
	     | AddSccs Module (Id -> Bool)
-- The (Id->Bool) says which Ids to add SCCs to 
703
-- But we never add a SCC to function marked INLINE
704
705
706
707
708
709
710
711

addAutoScc :: AutoScc	
	   -> Id	-- Binder
	   -> CoreExpr 	-- Rhs
	   -> CoreExpr	-- Scc'd Rhs

addAutoScc NoSccs _ rhs
  = rhs
712
713
addAutoScc _ id rhs | isInlinePragma (idInlinePragma id)
  = rhs
714
715
716
addAutoScc (AddSccs mod add_scc) id rhs
  | add_scc id = mkSCC (mkAutoCC id mod NotCafCC) rhs
  | otherwise  = rhs
sof's avatar
sof committed
717
718
\end{code}

719
720
If profiling and dealing with a dict binding,
wrap the dict in @_scc_ DICT <dict>@:
721
722

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
723
724
addDictScc :: Id -> CoreExpr -> DsM CoreExpr
addDictScc _ rhs = return rhs
725
726
727

{- DISABLED for now (need to somehow make up a name for the scc) -- SDM
  | not ( opt_SccProfilingOn && opt_AutoSccsOnDicts)
728
    || not (isDictId var)
729
  = return rhs				-- That's easy: do nothing
730

sof's avatar
sof committed
731
  | otherwise
732
  = do (mod, grp) <- getModuleAndGroupDs
sof's avatar
sof committed
733
	-- ToDo: do -dicts-all flag (mark dict things with individual CCs)
734
       return (Note (SCC (mkAllDictsCC mod grp False)) rhs)
735
-}
736
\end{code}
737
738
739
740
741
742
743
744
745
746


%************************************************************************
%*									*
		Desugaring coercions
%*									*
%************************************************************************


\begin{code}
747
748
749
750
751
752
753
754
755
756
757
758
dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
dsHsWrapper WpHole 	      = return (\e -> e)
dsHsWrapper (WpTyApp ty)      = return (\e -> App e (Type ty))
dsHsWrapper (WpLet ev_binds)  = do { ds_ev_binds <- dsTcEvBinds ev_binds
                                   ; return (wrapDsEvBinds ds_ev_binds) }
dsHsWrapper (WpCompose c1 c2) = do { k1 <- dsHsWrapper c1 
                                   ; k2 <- dsHsWrapper c2
                                   ; return (k1 . k2) }
dsHsWrapper (WpCast co)       = return (\e -> Cast e co) 
dsHsWrapper (WpEvLam ev)      = return (\e -> Lam ev e) 
dsHsWrapper (WpTyLam tv)      = return (\e -> Lam tv e) 
dsHsWrapper (WpEvApp evtrm)   = return (\e -> App e (dsEvTerm evtrm))
759
\end{code}