DsBinds.lhs 39 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
14
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
Ian Lynagh's avatar
Ian Lynagh committed
15
16
17
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
18
--     http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
Ian Lynagh's avatar
Ian Lynagh committed
19
20
-- for details

21
module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
22
                 dsHsWrapper, dsTcEvBinds, dsEvBinds
23
  ) where
24

25
26
#include "HsVersions.h"

27
import {-# SOURCE #-}	DsExpr( dsLExpr )
28
29
import {-# SOURCE #-}	Match( matchWrapper )

30
import DsMonad
Simon Marlow's avatar
Simon Marlow committed
31
import DsGRHSs
32
import DsUtils
33

34
35
import HsSyn		-- lots of things
import CoreSyn		-- lots of things
36
import Literal          ( Literal(MachStr) )
37
import CoreSubst
38
import OccurAnal        ( occurAnalyseExpr )
39
import MkCore
Simon Marlow's avatar
Simon Marlow committed
40
import CoreUtils
41
import CoreArity ( etaExpand )
42
import CoreUnfold
43
import CoreFVs
44
45
import UniqSupply
import Unique( Unique )
46
import Digraph
47

48

49
import TyCon      ( isTupleTyCon, tyConDataCons_maybe )
50
import TcEvidence
51
import TcType
52
import Type
batterseapower's avatar
batterseapower committed
53
import Coercion hiding (substCo)
Joachim Breitner's avatar
Joachim Breitner committed
54
import TysWiredIn ( eqBoxDataCon, coercibleDataCon, tupleCon )
Simon Marlow's avatar
Simon Marlow committed
55
import Id
56
import Class
batterseapower's avatar
batterseapower committed
57
import DataCon	( dataConWorkId )
58
import Name
59
import MkId	( seqId )
60
import Var
61
import VarSet
Simon Marlow's avatar
Simon Marlow committed
62
import Rules
63
import VarEnv
64
import Outputable
Simon Marlow's avatar
Simon Marlow committed
65
66
import SrcLoc
import Maybes
67
import OrdList
Simon Marlow's avatar
Simon Marlow committed
68
69
import Bag
import BasicTypes hiding ( TopLevel )
Ian Lynagh's avatar
Ian Lynagh committed
70
import DynFlags
Simon Marlow's avatar
Simon Marlow committed
71
import FastString
72
import ErrUtils( MsgDoc )
73
import ListSetOps( getNth )
74
import Util
75
import Control.Monad( when )
76
import MonadUtils
77
import Control.Monad(liftM)
78
79
80
81
82
83
84
85
86
\end{code}

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

\begin{code}
87
88
dsTopLHsBinds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
dsTopLHsBinds binds = ds_lhs_binds binds
89

90
dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
91
dsLHsBinds binds = do { binds' <- ds_lhs_binds binds
92
                      ; return (fromOL binds') }
93
94

------------------------
95
ds_lhs_binds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
96

97
98
ds_lhs_binds binds = do { ds_bs <- mapBagM dsLHsBind binds
                        ; return (foldBag appOL id nilOL ds_bs) }
99

100
101
dsLHsBind :: LHsBind Id -> DsM (OrdList (Id,CoreExpr))
dsLHsBind (L loc bind) = putSrcSpanDs loc $ dsHsBind bind
102

103
dsHsBind :: HsBind Id -> DsM (OrdList (Id,CoreExpr))
104

105
dsHsBind (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless })
106
107
  = do  { dflags <- getDynFlags
        ; core_expr <- dsLExpr expr
108
109
110

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

114
        ; return (unitOL (makeCorePair dflags var' False 0 core_expr)) }
115

116
117
118
dsHsBind (FunBind { fun_id = L _ fun, fun_matches = matches
                  , fun_co_fn = co_fn, fun_tick = tick
                  , fun_infix = inf })
119
120
 = do	{ dflags <- getDynFlags
        ; (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches
121
        ; let body' = mkOptTickBox tick body
122
        ; rhs <- dsHsWrapper co_fn (mkLams args body')
123
        ; {- pprTrace "dsHsBind" (ppr fun <+> ppr (idInlinePragma fun)) $ -}
124
           return (unitOL (makeCorePair dflags fun False 0 rhs)) }
125
126
127

dsHsBind (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty
                  , pat_ticks = (rhs_tick, var_ticks) })
128
  = do	{ body_expr <- dsGuarded grhss ty
129
130
        ; let body' = mkOptTickBox rhs_tick body_expr
        ; sel_binds <- mkSelectorBinds var_ticks pat body'
131
132
	  -- We silently ignore inline pragmas; no makeCorePair
	  -- Not so cool, but really doesn't matter
133
    ; return (toOL sel_binds) }
sof's avatar
sof committed
134

135
	-- A common case: one exported variable
136
	-- Non-recursive bindings come through this way
137
138
	-- So do self-recursive bindings, and recursive bindings
	-- that have been chopped up with type signatures
139
140
141
dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
                   , abs_exports = [export]
                   , abs_ev_binds = ev_binds, abs_binds = binds })
142
143
  | ABE { abe_wrap = wrap, abe_poly = global
        , abe_mono = local, abe_prags = prags } <- export
144
145
  = do  { dflags <- getDynFlags
        ; bind_prs    <- ds_lhs_binds binds
146
	; let	core_bind = Rec (fromOL bind_prs)
147
148
        ; ds_binds <- dsTcEvBinds ev_binds
        ; rhs <- dsHsWrapper wrap $  -- Usually the identity
149
			    mkLams tyvars $ mkLams dicts $ 
150
	                    mkCoreLets ds_binds $
151
152
                            Let core_bind $
                            Var local
153
    
154
	; (spec_binds, rules) <- dsSpecs rhs prags
155
156

	; let   global'   = addIdSpecialisations global rules
157
		main_bind = makeCorePair dflags global' (isDefaultMethod prags)
158
                                         (dictArity dicts) rhs 
159
    
160
	; return (main_bind `consOL` spec_binds) }
sof's avatar
sof committed
161

162
163
164
dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
                   , abs_exports = exports, abs_ev_binds = ev_binds
                   , abs_binds = binds })
165
         -- See Note [Desugaring AbsBinds]
166
167
168
  = do  { dflags <- getDynFlags
        ; bind_prs    <- ds_lhs_binds binds
        ; let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs
169
                              | (lcl_id, rhs) <- fromOL bind_prs ]
170
	      	-- Monomorphic recursion possible, hence Rec
171

172
	      locals       = map abe_mono exports
173
174
	      tup_expr     = mkBigCoreVarTup locals
	      tup_ty	   = exprType tup_expr
175
176
        ; ds_binds <- dsTcEvBinds ev_binds
	; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $
177
	      		     mkCoreLets ds_binds $
178
179
			     Let core_bind $
	 	     	     tup_expr
180

181
	; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
182

183
184
	; let mk_bind (ABE { abe_wrap = wrap, abe_poly = global
                           , abe_mono = local, abe_prags = spec_prags })
185
	        = do { tup_id  <- newSysLocalDs tup_ty
186
	             ; rhs <- dsHsWrapper wrap $ 
187
                                 mkLams tyvars $ mkLams dicts $
188
189
	      	     		 mkTupleSelector locals local tup_id $
			         mkVarApps (Var poly_tup_id) (tyvars ++ dicts)
190
                     ; let rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs
191
		     ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags
192
193
194
195
196
		     ; let global' = (global `setInlinePragma` defaultInlinePragma)
                                             `addIdSpecialisations` rules
                           -- Kill the INLINE pragma because it applies to
                           -- the user written (local) function.  The global
                           -- Id is just the selector.  Hmm.  
197
		     ; return ((global', rhs) `consOL` spec_binds) }
198

199
        ; export_binds_s <- mapM mk_bind exports
200

201
202
	; return ((poly_tup_id, poly_tup_rhs) `consOL` 
		    concatOL export_binds_s) }
203
204
205
206
207
208
209
210
211
212
213
  where
    inline_env :: IdEnv Id   -- Maps a monomorphic local Id to one with
                             -- the inline pragma from the source
                             -- The type checker put the inline pragma
                             -- on the *global* Id, so we need to transfer it
    inline_env = mkVarEnv [ (lcl_id, setInlinePragma lcl_id prag)
                          | ABE { abe_mono = lcl_id, abe_poly = gbl_id } <- exports
                          , let prag = idInlinePragma gbl_id ]

    add_inline :: Id -> Id    -- tran
    add_inline lcl_id = lookupVarEnv inline_env lcl_id `orElse` lcl_id
214

Gergő Érdi's avatar
Gergő Érdi committed
215
216
dsHsBind (PatSynBind{}) = panic "dsHsBind: PatSynBind"

217
------------------------
218
219
makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr)
makeCorePair dflags gbl_id is_default_method dict_arity rhs
220
221
222
  | is_default_method		      -- Default methods are *always* inlined
  = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs)

223
224
225
226
227
228
  | otherwise
  = case inlinePragmaSpec inline_prag of
      	  EmptyInlineSpec -> (gbl_id, rhs)
      	  NoInline        -> (gbl_id, rhs)
      	  Inlinable       -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)
          Inline          -> inline_pair
229

230
231
  where
    inline_prag   = idInlinePragma gbl_id
232
    inlinable_unf = mkInlinableUnfolding dflags rhs
233
234
    inline_pair
       | Just arity <- inlinePragmaSat inline_prag
235
236
      	-- Add an Unfolding for an INLINE (but not for NOINLINE)
	-- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
237
       , let real_arity = dict_arity + arity
238
        -- NB: The arity in the InlineRule takes account of the dictionaries
239
240
241
242
243
244
       = ( 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)
245
246
247
248
249


dictArity :: [Var] -> Arity
-- Don't count coercion variables in arity
dictArity dicts = count isId dicts
250
251
\end{code}

252
253
254
255
256
257
258
259
260
261
[Desugaring AbsBinds]
~~~~~~~~~~~~~~~~~~~~~
In the general AbsBinds case we desugar the binding to this:

       tup a (d:Num a) = let fm = ...gm...
                             gm = ...fm...
                         in (fm,gm)
       f a d = case tup a d of { (fm,gm) -> fm }
       g a d = case tup a d of { (fm,gm) -> fm }

262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
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
284
float the f_lcl binding out and then inline M.f at its call site
285
286
287
288
289
290
291
292
293
294
295
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
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344

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.


345
346
347
348
349
350
351
352
353
354
355
356
357
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
358
359
360
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.
361
362
363

Note [Nested arities]
~~~~~~~~~~~~~~~~~~~~~
364
365
366
367
368
369
370
371
372
373
374
375
376
377
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!
378

379
380
381
382
383
Note [Implementing SPECIALISE pragmas]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Example:
	f :: (Eq a, Ix b) => a -> b -> Bool
	{-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-}
384
        f = <poly_rhs>
385
386
387
388
389
390
391
392
393

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 
394
395
    forall ab. (Eq a, Ix b) => XXX
regardless of XXX.  It's sort of polymorphic in XXX.  This is
396
397
398
399
400
401
402
403
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

404
    Spec bind:	f_spec = wrap_fn <poly_rhs>
405
406
407
408
409
410
411

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.

412
413
  * The RHS of f_spec, <poly_rhs> has a *copy* of 'binds', so that it 
    can fully specialise it.
414

415
416
\begin{code}
------------------------
417
dsSpecs :: CoreExpr     -- Its rhs
418
        -> TcSpecPrags
419
        -> DsM ( OrdList (Id,CoreExpr) 	-- Binding for specialised Ids
420
	       , [CoreRule] )		-- Rules for the Global Ids
421
-- See Note [Implementing SPECIALISE pragmas]
422
423
424
425
426
427
428
429
430
431
432
433
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))
434
435
436
437
438
439
440
441
  | 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

442
443
444
445
446
447
448
  | no_act_spec && isNeverActive rule_act 
  = putSrcSpanDs loc $ 
    do { warnDs (ptext (sLit "Ignoring useless SPECIALISE pragma for NOINLINE function:")
                 <+> quotes (ppr poly_id))
       ; return Nothing  }  -- Function is NOINLINE, and the specialiation inherits that
       	 		    -- See Note [Activation pragmas for SPECIALISE]

449
  | otherwise
450
  = putSrcSpanDs loc $ 
451
452
    do { uniq <- newUnique
       ; let poly_name = idName poly_id
453
454
             spec_occ  = mkSpecOcc (getOccName poly_name)
             spec_name = mkInternalName uniq spec_occ (getSrcSpan poly_name)
455
456
457
       ; (bndrs, ds_lhs) <- liftM collectBinders
                                  (dsHsWrapper spec_co (Var poly_id))
       ; let spec_ty = mkPiTypes bndrs (exprType ds_lhs)
458
459
460
461
       ; -- pprTrace "dsRule" (vcat [ ptext (sLit "Id:") <+> ppr poly_id
         --                         , ptext (sLit "spec_co:") <+> ppr spec_co
         --                         , ptext (sLit "ds_rhs:") <+> ppr ds_lhs ]) $
         case decomposeRuleLhs bndrs ds_lhs of {
462
           Left msg -> do { warnDs msg; return Nothing } ;
463
           Right (rule_bndrs, _fn, args) -> do
464

465
       { dflags <- getDynFlags
Simon Peyton Jones's avatar
Simon Peyton Jones committed
466
467
468
469
470
       ; let fn_unf    = realIdUnfolding poly_id
             unf_fvs   = stableUnfoldingVars fn_unf `orElse` emptyVarSet
             in_scope  = mkInScopeSet (unf_fvs `unionVarSet` exprsFreeVars args)
             spec_unf  = specUnfolding dflags (mkEmptySubst in_scope) bndrs args fn_unf
             spec_id   = mkLocalId spec_name spec_ty 
471
472
473
         	            `setInlinePragma` inl_prag
         	 	    `setIdUnfolding`  spec_unf
             rule =  mkRule False {- Not auto -} is_local_id
Ian Lynagh's avatar
Ian Lynagh committed
474
                        (mkFastString ("SPEC " ++ showPpr dflags poly_name))
475
       			rule_act poly_name
476
       		        rule_bndrs args
477
478
       			(mkVarApps (Var spec_id) bndrs)

479
       ; spec_rhs <- dsHsWrapper spec_co poly_rhs
480

Ian Lynagh's avatar
Ian Lynagh committed
481
482
       ; when (isInlinePragma id_inl && wopt Opt_WarnPointlessPragmas dflags)
              (warnDs (specOnInline poly_name))
Simon Peyton Jones's avatar
Simon Peyton Jones committed
483
484
485
486
487

       ; return (Just (unitOL (spec_id, spec_rhs), rule))
            -- NB: do *not* use makeCorePair on (spec_id,spec_rhs), because
            --     makeCorePair overwrites the unfolding, which we have
            --     just created using specUnfolding
488
489
490
491
       } } }
  where
    is_local_id = isJust mb_poly_rhs
    poly_rhs | Just rhs <-  mb_poly_rhs
492
493
494
495
496
497
             = 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!
498
             | otherwise = pprPanic "dsImpSpecs" (ppr poly_id)
499
	                    -- The type checker has checked that it *has* an unfolding
500

501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
    id_inl = idInlinePragma poly_id

    -- See Note [Activation pragmas for SPECIALISE]
    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                               = id_inl
     -- Get the INLINE pragma from SPECIALISE declaration, or,
     -- failing that, from the original Id

    spec_prag_act = inlinePragmaActivation spec_inl

    -- See Note [Activation pragmas for SPECIALISE]
    -- no_act_spec is True if the user didn't write an explicit
    -- phase specification in the SPECIALISE pragma
    no_act_spec = case inlinePragmaSpec spec_inl of
                    NoInline -> isNeverActive  spec_prag_act
                    _        -> isAlwaysActive spec_prag_act
    rule_act | no_act_spec = inlinePragmaActivation id_inl   -- Inherit
             | otherwise   = spec_prag_act                   -- Specified by user


specOnInline :: Name -> MsgDoc
specOnInline f = ptext (sLit "SPECIALISE pragma on INLINE function probably won't fire:") 
                 <+> quotes (ppr f)
527
528
\end{code}

529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570

Note [Activation pragmas for SPECIALISE]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
From a user SPECIALISE pragma for f, we generate
  a) A top-level binding    spec_fn = rhs
  b) A RULE                 f dOrd = spec_fn

We need two pragma-like things:

* spec_fn's inline pragma: inherited from f's inline pragma (ignoring 
                           activation on SPEC), unless overriden by SPEC INLINE

* Activation of RULE: from SPECIALISE pragma (if activation given)
                      otherwise from f's inline pragma

This is not obvious (see Trac #5237)!

Examples      Rule activation   Inline prag on spec'd fn
---------------------------------------------------------------------
SPEC [n] f :: ty            [n]   Always, or NOINLINE [n]
                                  copy f's prag

NOINLINE f
SPEC [n] f :: ty            [n]   NOINLINE
                                  copy f's prag

NOINLINE [k] f
SPEC [n] f :: ty            [n]   NOINLINE [k]
                                  copy f's prag

INLINE [k] f
SPEC [n] f :: ty            [n]   INLINE [k] 
                                  copy f's prag

SPEC INLINE [n] f :: ty     [n]   INLINE [n]
                                  (ignore INLINE prag on f,
                                  same activation for rule and spec'd fn)

NOINLINE [k] f
SPEC f :: ty                [n]   INLINE [k]


571
572
573
574
575
576
577
%************************************************************************
%*									*
\subsection{Adding inline pragmas}
%*									*
%************************************************************************

\begin{code}
578
decomposeRuleLhs :: [Var] -> CoreExpr -> Either SDoc ([Var], Id, [CoreExpr])
unknown's avatar
unknown committed
579
580
-- (decomposeRuleLhs bndrs lhs) takes apart the LHS of a RULE,
-- The 'bndrs' are the quantified binders of the rules, but decomposeRuleLhs
581
-- may add some extra dictionary binders (see Note [Free dictionaries])
unknown's avatar
unknown committed
582
--
583
-- Returns Nothing if the LHS isn't of the expected shape
584
585
586
587
588
589
590
591
-- Note [Decomposing the left-hand side of a RULE]
decomposeRuleLhs orig_bndrs orig_lhs
  | not (null unbound)    -- Check for things unbound on LHS
                          -- See Note [Unused spec binders]
  = Left (vcat (map dead_msg unbound))

  | Var fn_var <- fun
  , not (fn_var `elemVarSet` orig_bndr_set)
592
593
594
595
596
597
598
  = -- pprTrace "decmposeRuleLhs" (vcat [ ptext (sLit "orig_bndrs:") <+> ppr orig_bndrs
    --                                  , ptext (sLit "orig_lhs:") <+> ppr orig_lhs
    --                                  , ptext (sLit "lhs1:")     <+> ppr lhs1
    --                                  , ptext (sLit "bndrs1:") <+> ppr bndrs1
    --                                  , ptext (sLit "fn_var:") <+> ppr fn_var
    --                                  , ptext (sLit "args:")   <+> ppr args]) $
    Right (bndrs1, fn_var, args)
599
600
601
602
603
604
605
606

  | Case scrut bndr ty [(DEFAULT, _, body)] <- fun
  , isDeadBinder bndr	-- Note [Matching seqId]
  , let args' = [Type (idType bndr), Type ty, scrut, body]
  = Right (bndrs1, seqId, args' ++ args)

  | otherwise 
  = Left bad_shape_msg
607
 where
608
609
610
611
612
613
   lhs1       = drop_dicts orig_lhs
   lhs2       = simpleOptExpr lhs1  -- See Note [Simplify rule LHS]
   (fun,args) = collectArgs lhs2
   lhs_fvs    = exprFreeVars lhs2
   unbound    = filterOut (`elemVarSet` lhs_fvs) orig_bndrs
   bndrs1     = orig_bndrs ++ extra_dict_bndrs
614

615
   orig_bndr_set = mkVarSet orig_bndrs
616

617
        -- Add extra dict binders: Note [Free dictionaries]
618
619
620
   extra_dict_bndrs = [ mkLocalId (localiseName (idName d)) (idType d)
                      | d <- varSetElems (lhs_fvs `delVarSetList` orig_bndrs)
                      , isDictId d ]
621
622

   bad_shape_msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar"))
623
624
                      2 (vcat [ text "Optimised lhs:" <+> ppr lhs2
                              , text "Orig lhs:" <+> ppr orig_lhs])
625
626
   dead_msg bndr = hang (sep [ ptext (sLit "Forall'd") <+> pp_bndr bndr
			     , ptext (sLit "is not bound in RULE lhs")])
627
628
629
                      2 (vcat [ text "Orig bndrs:" <+> ppr orig_bndrs
                              , text "Orig lhs:" <+> ppr orig_lhs
                              , text "optimised lhs:" <+> ppr lhs2 ])
630
   pp_bndr bndr
631
632
633
    | isTyVar bndr                      = ptext (sLit "type variable") <+> quotes (ppr bndr)
    | Just pred <- evVarPred_maybe bndr = ptext (sLit "constraint") <+> quotes (ppr pred)
    | otherwise                         = ptext (sLit "variable") <+> quotes (ppr bndr)
634
635

   drop_dicts :: CoreExpr -> CoreExpr
636
637
638
639
   drop_dicts e 
       = wrap_lets needed bnds body
     where
       needed = orig_bndr_set `minusVarSet` exprFreeVars body
640
641
642
643
       (bnds, body) = split_lets (occurAnalyseExpr e)
       	   -- The occurAnalyseExpr drops dead bindings which is
           -- crucial to ensure that every binding is used later;
           -- which in turn makes wrap_lets work right
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661

   split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr)
   split_lets e
     | Let (NonRec d r) body <- e
     , isDictId d
     , (bs, body') <- split_lets body
     = ((d,r):bs, body')
     | otherwise
     = ([], e)

   wrap_lets :: VarSet -> [(DictId,CoreExpr)] -> CoreExpr -> CoreExpr
   wrap_lets _ [] body = body
   wrap_lets needed ((d, r) : bs) body
     | rhs_fvs `intersectsVarSet` needed = Let (NonRec d r) (wrap_lets needed' bs body)
     | otherwise                         = wrap_lets needed bs body
     where
       rhs_fvs = exprFreeVars r
       needed' = (needed `minusVarSet` rhs_fvs) `extendVarSet` d
662
663
\end{code}

664
Note [Decomposing the left-hand side of a RULE]
665
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
666
667
668
There are several things going on here.  
* drop_dicts: see Note [Drop dictionary bindings on rule LHS]
* simpleOptExpr: see Note [Simplify rule LHS]
669
* extra_dict_bndrs: see Note [Free dictionaries]
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696

Note [Drop dictionary bindings on rule LHS]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
drop_dicts drops dictionary bindings on the LHS where possible.  
   E.g.  let d:Eq [Int] = $fEqList $fEqInt in f d
     --> f d
   Reasoning here is that there is only one d:Eq [Int], and so we can 
   quantify over it. That makes 'd' free in the LHS, but that is later
   picked up by extra_dict_bndrs (Note [Dead spec binders]).

   NB 1: We can only drop the binding if the RHS doesn't bind
         one of the orig_bndrs, which we assume occur on RHS. 
         Example
            f :: (Eq a) => b -> a -> a
            {-# SPECIALISE f :: Eq a => b -> [a] -> [a] #-}
         Here we want to end up with
            RULE forall d:Eq a.  f ($dfEqList d) = f_spec d
         Of course, the ($dfEqlist d) in the pattern makes it less likely
         to match, but ther is no other way to get d:Eq a

   NB 2: We do drop_dicts *before* simplOptEpxr, so that we expect all 
         the evidence bindings to be wrapped around the outside of the
         LHS.  (After simplOptExpr they'll usually have been inlined.)
         dsHsWrapper does dependency analysis, so that civilised ones
         will be simple NonRec bindings.  We don't handle recursive
         dictionaries!

Gabor Greif's avatar
Gabor Greif committed
697
    NB3: In the common case of a non-overloaded, but perhaps-polymorphic
698
699
700
701
702
703
704
705
706
         specialisation, we don't need to bind *any* dictionaries for use
         in the RHS. For example (Trac #8331)
             {-# SPECIALIZE INLINE useAbstractMonad :: ReaderST s Int #-}
             useAbstractMonad :: MonadAbstractIOST m => m Int
         Here, deriving (MonadAbstractIOST (ReaderST s)) is a lot of code
         but the RHS uses no dictionaries, so we want to end up with
             RULE forall s (d :: MonadBstractIOST (ReaderT s)).
                useAbstractMonad (ReaderT s) d = $suseAbstractMonad s

707
708
709
   Trac #8848 is a good example of where there are some intersting
   dictionary bindings to discard.

710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
The drop_dicts algorithm is based on these observations:

  * Given (let d = rhs in e) where d is a DictId,
    matching 'e' will bind e's free variables.

  * So we want to keep the binding if one of the needed variables (for
    which we need a binding) is in fv(rhs) but not already in fv(e).

  * The "needed variables" are simply the orig_bndrs.  Consider
       f :: (Eq a, Show b) => a -> b -> String
       {-# SPECIALISE f :: (Show b) => Int -> b -> String
    Then orig_bndrs includes the *quantified* dictionaries of the type
    namely (dsb::Show b), but not the one for Eq Int

So we work inside out, applying the above criterion at each step.


727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
Note [Simplify rule LHS]
~~~~~~~~~~~~~~~~~~~~~~~~
simplOptExpr occurrence-analyses and simplifies the LHS:

   (a) Inline any remaining dictionary bindings (which hopefully 
       occur just once)

   (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) Do eta reduction.  To see why, 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)
748

749
Note [Matching seqId]
750
751
752
753
754
~~~~~~~~~~~~~~~~~~~
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.

755
756
757
758
759
760
761
762
763
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
Gabor Greif's avatar
typos    
Gabor Greif committed
764
765
Note that the rule is bogus, because it mentions a 'd' that is
not bound on the LHS!  But it's a silly specialisation anyway, because
766
767
768
769
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.

770
771
Note [Free dictionaries]
~~~~~~~~~~~~~~~~~~~~~~~~
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
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.

795

796
797
%************************************************************************
%*									*
798
		Desugaring evidence
799
800
801
802
803
%*									*
%************************************************************************


\begin{code}
804
dsHsWrapper :: HsWrapper -> CoreExpr -> DsM CoreExpr
805
806
807
808
809
dsHsWrapper WpHole 	      e = return e
dsHsWrapper (WpTyApp ty)      e = return $ App e (Type ty)
dsHsWrapper (WpLet ev_binds)  e = do bs <- dsTcEvBinds ev_binds
                                     return (mkCoreLets bs e)
dsHsWrapper (WpCompose c1 c2) e = dsHsWrapper c1 =<< dsHsWrapper c2 e
810
dsHsWrapper (WpCast co)       e = ASSERT(tcCoercionRole co == Representational)
Joachim Breitner's avatar
Joachim Breitner committed
811
                                  dsTcCoercion co (mkCast e)
812
813
814
dsHsWrapper (WpEvLam ev)      e = return $ Lam ev e 
dsHsWrapper (WpTyLam tv)      e = return $ Lam tv e 
dsHsWrapper (WpEvApp evtrm)   e = liftM (App e) (dsEvTerm evtrm)
815
816

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

821
dsEvBinds :: Bag EvBind -> DsM [CoreBind]
822
dsEvBinds bs = mapM ds_scc (sccEvBinds bs)
823
  where
824
825
    ds_scc (AcyclicSCC (EvBind v r)) = liftM (NonRec v) (dsEvTerm r)
    ds_scc (CyclicSCC bs)            = liftM Rec (mapM ds_pair bs)
826

827
    ds_pair (EvBind v r) = liftM ((,) v) (dsEvTerm r)
828
829
830
831
832
833
834
835

sccEvBinds :: Bag EvBind -> [SCC EvBind]
sccEvBinds bs = stronglyConnCompFromEdgedVertices edges
  where
    edges :: [(EvBind, EvVar, [EvVar])]
    edges = foldrBag ((:) . mk_node) [] bs 

    mk_node :: EvBind -> (EvBind, EvVar, [EvVar])
836
    mk_node b@(EvBind var term) = (b, var, varSetElems (evVarsOfTerm term))
837
838
839


---------------------------------------
840
dsEvTerm :: EvTerm -> DsM CoreExpr
841
dsEvTerm (EvId v) = return (Var v)
842

843
844
dsEvTerm (EvCast tm co) 
  = do { tm' <- dsEvTerm tm
845
       ; dsTcCoercion co $ mkCast tm' }
846
847
848
849
850
                        -- 'v' is always a lifted evidence variable so it is
                        -- unnecessary to call varToCoreExpr v here.

dsEvTerm (EvDFunApp df tys tms) = do { tms' <- mapM dsEvTerm tms
                                     ; return (Var df `mkTyApps` tys `mkApps` tms') }
851
852

dsEvTerm (EvCoercion (TcCoVarCo v)) = return (Var v)  -- See Note [Simple coercions]
Joachim Breitner's avatar
Joachim Breitner committed
853
dsEvTerm (EvCoercion co)            = dsTcCoercion co mkEqBox
854

855
dsEvTerm (EvTupleSel v n)
856
857
858
859
860
   = do { tm' <- dsEvTerm v
        ; let scrut_ty = exprType tm'
              (tc, tys) = splitTyConApp scrut_ty
    	      Just [dc] = tyConDataCons_maybe tc
    	      xs = mkTemplateLocals tys
861
              the_x = getNth xs n
862
863
864
865
866
867
868
869
870
871
872
        ; ASSERT( isTupleTyCon tc )
          return $
          Case tm' (mkWildValBinder scrut_ty) (idType the_x) [(DataAlt dc, xs, Var the_x)] }

dsEvTerm (EvTupleMk tms) 
  = do { tms' <- mapM dsEvTerm tms
       ; let tys = map exprType tms'
       ; return $ Var (dataConWorkId dc) `mkTyApps` tys `mkApps` tms' }
  where 
    dc = tupleCon ConstraintTuple (length tms)

873
dsEvTerm (EvSuperClass d n)
874
875
876
877
  = do { d' <- dsEvTerm d
       ; let (cls, tys) = getClassPredTys (exprType d')
             sc_sel_id  = classSCSelId cls n	-- Zero-indexed
       ; return $ Var sc_sel_id `mkTyApps` tys `App` d' }
878
  where
879

880
881
882
dsEvTerm (EvDelayedError ty msg) = return $ Var errorId `mkTyApps` [ty] `mkApps` [litMsg]
  where 
    errorId = rUNTIME_ERROR_ID
883
    litMsg  = Lit (MachStr (fastStringToByteString msg))
884

885
886
887
888
dsEvTerm (EvLit l) =
  case l of
    EvNum n -> mkIntegerExpr n
    EvStr s -> mkStringExprFS s
889

890
---------------------------------------
Joachim Breitner's avatar
Joachim Breitner committed
891
dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> DsM CoreExpr
892
-- This is the crucial function that moves 
893
-- from TcCoercions to Coercions; see Note [TcCoercions] in Coercion
894
895
896
897
-- e.g.  dsTcCoercion (trans g1 g2) k
--       = case g1 of EqBox g1# ->
--         case g2 of EqBox g2# ->
--         k (trans g1# g2#)
898
-- thing_inside will get a coercion at the role requested
Joachim Breitner's avatar
Joachim Breitner committed
899
dsTcCoercion co thing_inside
900
  = do { us <- newUniqueSupply
901
902
903
       ; let eqvs_covs :: [(EqVar,CoVar)]
             eqvs_covs = zipWith mk_co_var (varSetElems (coVarsOfTcCo co))
                                           (uniqsFromSupply us)
904

905
             subst = mkCvSubst emptyInScopeSet [(eqv, mkCoVarCo cov) | (eqv, cov) <- eqvs_covs]
Joachim Breitner's avatar
Joachim Breitner committed
906
             result_expr = thing_inside (ds_tc_coercion subst co)
907
             result_ty   = exprType result_expr
908

909
910
911
912
913
914
915
916
       ; return (foldr (wrap_in_case result_ty) result_expr eqvs_covs) }
  where
    mk_co_var :: Id -> Unique -> (Id, Id)
    mk_co_var eqv uniq = (eqv, mkUserLocal occ uniq ty loc)
       where
         eq_nm = idName eqv
         occ = nameOccName eq_nm
         loc = nameSrcSpan eq_nm
Joachim Breitner's avatar
Joachim Breitner committed
917
         ty  = mkCoercionType (getEqPredRole (evVarPred eqv)) ty1 ty2
918
919
         (ty1, ty2) = getEqPredTys (evVarPred eqv)

Joachim Breitner's avatar
Joachim Breitner committed
920
921
922
923
924
    wrap_in_case result_ty (eqv, cov) body
      = case getEqPredRole (evVarPred eqv) of
         Nominal          -> Case (Var eqv) eqv result_ty [(DataAlt eqBoxDataCon, [cov], body)]
         Representational -> Case (Var eqv) eqv result_ty [(DataAlt coercibleDataCon, [cov], body)]
         Phantom          -> panic "wrap_in_case/phantom"
925

Joachim Breitner's avatar
Joachim Breitner committed
926
927
928
929
ds_tc_coercion :: CvSubst -> TcCoercion -> Coercion
-- If the incoming TcCoercion if of type (a ~ b)   (resp.  Coercible a b)
--                 the result is of type (a ~# b)  (reps.  a ~# b)
-- The VarEnv maps EqVars of type (a ~ b) to Coercions of type (a ~# b) (resp. and so on)
930
-- No need for InScope set etc because the 
Joachim Breitner's avatar
Joachim Breitner committed
931
932
ds_tc_coercion subst tc_co
  = go tc_co
933
  where
Joachim Breitner's avatar
Joachim Breitner committed
934
935
936
    go (TcRefl r ty)            = Refl r (Coercion.substTy subst ty)
    go (TcTyConAppCo r tc cos)  = mkTyConAppCo r tc (map go cos)
    go (TcAppCo co1 co2)        = let leftCo    = go co1
937
                                      rightRole = nextRole leftCo in
Joachim Breitner's avatar
Joachim Breitner committed
938
939
                                  mkAppCoFlexible leftCo rightRole (go co2)
    go (TcForAllCo tv co)       = mkForAllCo tv' (ds_tc_coercion subst' co)
940
941
                              where
                                (subst', tv') = Coercion.substTyVarBndr subst tv
Joachim Breitner's avatar
Joachim Breitner committed
942
943
944
945
946
947
948
949
950
951
952
953
    go (TcAxiomInstCo ax ind cos)
                                = AxiomInstCo ax ind (map go cos)
    go (TcPhantomCo ty1 ty2)    = UnivCo Phantom ty1 ty2
    go (TcSymCo co)             = mkSymCo (go co)
    go (TcTransCo co1 co2)      = mkTransCo (go co1) (go co2)
    go (TcNthCo n co)           = mkNthCo n (go co)
    go (TcLRCo lr co)           = mkLRCo lr (go co)
    go (TcSubCo co)             = mkSubCo (go co)
    go (TcLetCo bs co)          = ds_tc_coercion (ds_co_binds bs) co
    go (TcCastCo co1 co2)       = mkCoCast (go co1) (go co2)
    go (TcCoVarCo v)            = ds_ev_id subst v
    go (TcAxiomRuleCo co ts cs) = AxiomRuleCo co (map (Coercion.substTy subst) ts) (map go cs)
954

955
956
957
958
959
960
    ds_co_binds :: TcEvBinds -> CvSubst
    ds_co_binds (EvBinds bs)      = foldl ds_scc subst (sccEvBinds bs)
    ds_co_binds eb@(TcEvBinds {}) = pprPanic "ds_co_binds" (ppr eb)

    ds_scc :: CvSubst -> SCC EvBind -> CvSubst
    ds_scc subst (AcyclicSCC (EvBind v ev_term))
961
      = extendCvSubstAndInScope subst v (ds_co_term subst ev_term)
962
963
    ds_scc _ (CyclicSCC other) = pprPanic "ds_scc:cyclic" (ppr other $$ ppr tc_co)

964
    ds_co_term :: CvSubst -> EvTerm -> Coercion
Joachim Breitner's avatar
Joachim Breitner committed
965
    ds_co_term subst (EvCoercion tc_co) = ds_tc_coercion subst tc_co
966
    ds_co_term subst (EvId v)           = ds_ev_id subst v
Joachim Breitner's avatar
Joachim Breitner committed
967
    ds_co_term subst (EvCast tm co)     = mkCoCast (ds_co_term subst tm) (ds_tc_coercion subst co)
968
    ds_co_term _ other = pprPanic "ds_co_term" (ppr other $$ ppr tc_co)
969
970
971
972
973

    ds_ev_id :: CvSubst -> EqVar -> Coercion
    ds_ev_id subst v
     | Just co <- Coercion.lookupCoVar subst v = co
     | otherwise  = pprPanic "ds_tc_coercion" (ppr v $$ ppr tc_co)
974
\end{code}
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001

Note [Simple coercions]
~~~~~~~~~~~~~~~~~~~~~~~
We have a special case for coercions that are simple variables.
Suppose   cv :: a ~ b   is in scope
Lacking the special case, if we see
	f a b cv
we'd desguar to
        f a b (case cv of EqBox (cv# :: a ~# b) -> EqBox cv#)
which is a bit stupid.  The special case does the obvious thing.

This turns out to be important when desugaring the LHS of a RULE
(see Trac #7837).  Suppose we have
    normalise        :: (a ~ Scalar a) => a -> a
    normalise_Double :: Double -> Double
    {-# RULES "normalise" normalise = normalise_Double #-}

Then the RULE we want looks like
     forall a, (cv:a~Scalar a). 
       normalise a cv = normalise_Double
But without the special case we generate the redundant box/unbox,
which simpleOpt (currently) doesn't remove. So the rule never matches.

Maybe simpleOpt should be smarter.  But it seems like a good plan
to simply never generate the redundant box/unbox in the first place.