Warn when a SPECIALISE pragma gives rise to a totally inactive rule
[ghc.git] / compiler / deSugar / DsBinds.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %
5
6 Pattern-matching bindings (HsBinds and MonoBinds)
7
8 Handles @HsBinds@; those at the top level require different handling,
9 in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at
10 lower levels it is preserved with @let@/@letrec@s).
11
12 \begin{code}
13 {-# OPTIONS -fno-warn-tabs #-}
14 -- The above warning supression flag is a temporary kludge.
15 -- While working on this module you are encouraged to remove it and
16 -- detab the module (please do the detabbing in a separate patch). See
17 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
18 -- for details
19
20 module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
21                  dsHsWrapper, dsTcEvBinds, dsEvBinds, dsTcCoercion
22   ) where
23
24 #include "HsVersions.h"
25
26 import {-# SOURCE #-}   DsExpr( dsLExpr )
27 import {-# SOURCE #-}   Match( matchWrapper )
28
29 import DsMonad
30 import DsGRHSs
31 import DsUtils
32
33 import HsSyn            -- lots of things
34 import CoreSyn          -- lots of things
35 import Literal          ( Literal(MachStr) )
36 import CoreSubst
37 import MkCore
38 import CoreUtils
39 import CoreArity ( etaExpand )
40 import CoreUnfold
41 import CoreFVs
42 import Digraph
43
44
45 import TyCon      ( isTupleTyCon, tyConDataCons_maybe )
46 import TcEvidence
47 import TcType
48 import Type
49 import Coercion hiding (substCo)
50 import TysWiredIn ( eqBoxDataCon, tupleCon )
51 import Id
52 import Class
53 import DataCon  ( dataConWorkId )
54 import Name     ( Name, localiseName )
55 import MkId     ( seqId )
56 import Var
57 import VarSet
58 import Rules
59 import VarEnv
60 import Outputable
61 import SrcLoc
62 import Maybes
63 import OrdList
64 import Bag
65 import BasicTypes hiding ( TopLevel )
66 import FastString
67 import ErrUtils( MsgDoc )
68 import Util
69 import Control.Monad( when )
70 import MonadUtils
71 \end{code}
72
73 %************************************************************************
74 %*                                                                      *
75 \subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
76 %*                                                                      *
77 %************************************************************************
78
79 \begin{code}
80 dsTopLHsBinds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
81 dsTopLHsBinds binds = ds_lhs_binds binds
82
83 dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
84 dsLHsBinds binds = do { binds' <- ds_lhs_binds binds
85                       ; return (fromOL binds') }
86
87 ------------------------
88 ds_lhs_binds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
89
90 ds_lhs_binds binds = do { ds_bs <- mapBagM dsLHsBind binds
91                         ; return (foldBag appOL id nilOL ds_bs) }
92
93 dsLHsBind :: LHsBind Id -> DsM (OrdList (Id,CoreExpr))
94 dsLHsBind (L loc bind)
95   = putSrcSpanDs loc $ dsHsBind bind
96
97 dsHsBind :: HsBind Id -> DsM (OrdList (Id,CoreExpr))
98
99 dsHsBind (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless })
100   = do  { core_expr <- dsLExpr expr
101
102                 -- Dictionary bindings are always VarBinds,
103                 -- so we only need do this here
104         ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr
105                    | otherwise         = var
106
107         ; return (unitOL (makeCorePair var' False 0 core_expr)) }
108
109 dsHsBind (FunBind { fun_id = L _ fun, fun_matches = matches
110                   , fun_co_fn = co_fn, fun_tick = tick
111                   , fun_infix = inf })
112  = do   { (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches
113         ; let body' = mkOptTickBox tick body
114               rhs = dsHsWrapper co_fn (mkLams args body')
115         ; {- pprTrace "dsHsBind" (ppr fun <+> ppr (idInlinePragma fun)) $ -}
116            return (unitOL (makeCorePair fun False 0 rhs)) }
117
118 dsHsBind (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty
119                   , pat_ticks = (rhs_tick, var_ticks) })
120   = do  { body_expr <- dsGuarded grhss ty
121         ; let body' = mkOptTickBox rhs_tick body_expr
122         ; sel_binds <- mkSelectorBinds var_ticks pat body'
123           -- We silently ignore inline pragmas; no makeCorePair
124           -- Not so cool, but really doesn't matter
125     ; return (toOL sel_binds) }
126
127         -- A common case: one exported variable
128         -- Non-recursive bindings come through this way
129         -- So do self-recursive bindings, and recursive bindings
130         -- that have been chopped up with type signatures
131 dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
132                    , abs_exports = [export]
133                    , abs_ev_binds = ev_binds, abs_binds = binds })
134   | ABE { abe_wrap = wrap, abe_poly = global
135         , abe_mono = local, abe_prags = prags } <- export
136   = do  { bind_prs    <- ds_lhs_binds binds
137         ; let   core_bind = Rec (fromOL bind_prs)
138                 rhs       = dsHsWrapper wrap $  -- Usually the identity
139                             mkLams tyvars $ mkLams dicts $ 
140                             mkCoreLets (dsTcEvBinds ev_binds) $
141                             Let core_bind $
142                             Var local
143     
144         ; (spec_binds, rules) <- dsSpecs rhs prags
145
146         ; let   global'   = addIdSpecialisations global rules
147                 main_bind = makeCorePair global' (isDefaultMethod prags)
148                                          (dictArity dicts) rhs 
149     
150         ; return (main_bind `consOL` spec_binds) }
151
152 dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
153                    , abs_exports = exports, abs_ev_binds = ev_binds
154                    , abs_binds = binds })
155   = do  { bind_prs    <- ds_lhs_binds binds
156         ; let core_bind = Rec (fromOL bind_prs)
157                 -- Monomorphic recursion possible, hence Rec
158
159               tup_expr     = mkBigCoreVarTup locals
160               tup_ty       = exprType tup_expr
161               poly_tup_rhs = mkLams tyvars $ mkLams dicts $
162                              mkCoreLets (dsTcEvBinds ev_binds) $
163                              Let core_bind $
164                              tup_expr
165               locals       = map abe_mono exports
166
167         ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
168
169         ; let mk_bind (ABE { abe_wrap = wrap, abe_poly = global
170                            , abe_mono = local, abe_prags = spec_prags })
171                 = do { tup_id  <- newSysLocalDs tup_ty
172                      ; let rhs = dsHsWrapper wrap $ 
173                                  mkLams tyvars $ mkLams dicts $
174                                  mkTupleSelector locals local tup_id $
175                                  mkVarApps (Var poly_tup_id) (tyvars ++ dicts)
176                            rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs
177                      ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags
178                      ; let global' = addIdSpecialisations global rules
179                      ; return ((global', rhs) `consOL` spec_binds) }
180
181         ; export_binds_s <- mapM mk_bind exports
182
183         ; return ((poly_tup_id, poly_tup_rhs) `consOL` 
184                     concatOL export_binds_s) }
185
186 ------------------------
187 makeCorePair :: Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr)
188 makeCorePair gbl_id is_default_method dict_arity rhs
189   | is_default_method                 -- Default methods are *always* inlined
190   = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs)
191
192   | otherwise
193   = case inlinePragmaSpec inline_prag of
194           EmptyInlineSpec -> (gbl_id, rhs)
195           NoInline        -> (gbl_id, rhs)
196           Inlinable       -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)
197           Inline          -> inline_pair
198
199   where
200     inline_prag   = idInlinePragma gbl_id
201     inlinable_unf = mkInlinableUnfolding rhs
202     inline_pair
203        | Just arity <- inlinePragmaSat inline_prag
204         -- Add an Unfolding for an INLINE (but not for NOINLINE)
205         -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
206        , let real_arity = dict_arity + arity
207         -- NB: The arity in the InlineRule takes account of the dictionaries
208        = ( gbl_id `setIdUnfolding` mkInlineUnfolding (Just real_arity) rhs
209          , etaExpand real_arity rhs)
210
211        | otherwise
212        = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $
213          (gbl_id `setIdUnfolding` mkInlineUnfolding Nothing rhs, rhs)
214
215
216 dictArity :: [Var] -> Arity
217 -- Don't count coercion variables in arity
218 dictArity dicts = count isId dicts
219 \end{code}
220
221 Note [Rules and inlining]
222 ~~~~~~~~~~~~~~~~~~~~~~~~~
223 Common special case: no type or dictionary abstraction
224 This is a bit less trivial than you might suppose
225 The naive way woudl be to desguar to something like
226         f_lcl = ...f_lcl...     -- The "binds" from AbsBinds
227         M.f = f_lcl             -- Generated from "exports"
228 But we don't want that, because if M.f isn't exported,
229 it'll be inlined unconditionally at every call site (its rhs is 
230 trivial).  That would be ok unless it has RULES, which would 
231 thereby be completely lost.  Bad, bad, bad.
232
233 Instead we want to generate
234         M.f = ...f_lcl...
235         f_lcl = M.f
236 Now all is cool. The RULES are attached to M.f (by SimplCore), 
237 and f_lcl is rapidly inlined away.
238
239 This does not happen in the same way to polymorphic binds,
240 because they desugar to
241         M.f = /\a. let f_lcl = ...f_lcl... in f_lcl
242 Although I'm a bit worried about whether full laziness might
243 float the f_lcl binding out and then inline M.f at its call site
244
245 Note [Specialising in no-dict case]
246 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
247 Even if there are no tyvars or dicts, we may have specialisation pragmas.
248 Class methods can generate
249       AbsBinds [] [] [( ... spec-prag]
250          { AbsBinds [tvs] [dicts] ...blah }
251 So the overloading is in the nested AbsBinds. A good example is in GHC.Float:
252
253   class  (Real a, Fractional a) => RealFrac a  where
254     round :: (Integral b) => a -> b
255
256   instance  RealFrac Float  where
257     {-# SPECIALIZE round :: Float -> Int #-}
258
259 The top-level AbsBinds for $cround has no tyvars or dicts (because the 
260 instance does not).  But the method is locally overloaded!
261
262 Note [Abstracting over tyvars only]
263 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
264 When abstracting over type variable only (not dictionaries), we don't really need to
265 built a tuple and select from it, as we do in the general case. Instead we can take
266
267         AbsBinds [a,b] [ ([a,b], fg, fl, _),
268                          ([b],   gg, gl, _) ]
269                 { fl = e1
270                   gl = e2
271                    h = e3 }
272
273 and desugar it to
274
275         fg = /\ab. let B in e1
276         gg = /\b. let a = () in let B in S(e2)
277         h  = /\ab. let B in e3
278
279 where B is the *non-recursive* binding
280         fl = fg a b
281         gl = gg b
282         h  = h a b    -- See (b); note shadowing!
283
284 Notice (a) g has a different number of type variables to f, so we must
285              use the mkArbitraryType thing to fill in the gaps.  
286              We use a type-let to do that.
287
288          (b) The local variable h isn't in the exports, and rather than
289              clone a fresh copy we simply replace h by (h a b), where
290              the two h's have different types!  Shadowing happens here,
291              which looks confusing but works fine.
292
293          (c) The result is *still* quadratic-sized if there are a lot of
294              small bindings.  So if there are more than some small
295              number (10), we filter the binding set B by the free
296              variables of the particular RHS.  Tiresome.
297
298 Why got to this trouble?  It's a common case, and it removes the
299 quadratic-sized tuple desugaring.  Less clutter, hopefullly faster
300 compilation, especially in a case where there are a *lot* of
301 bindings.
302
303
304 Note [Eta-expanding INLINE things]
305 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
306 Consider
307    foo :: Eq a => a -> a
308    {-# INLINE foo #-}
309    foo x = ...
310
311 If (foo d) ever gets floated out as a common sub-expression (which can
312 happen as a result of method sharing), there's a danger that we never 
313 get to do the inlining, which is a Terribly Bad thing given that the
314 user said "inline"!
315
316 To avoid this we pre-emptively eta-expand the definition, so that foo
317 has the arity with which it is declared in the source code.  In this
318 example it has arity 2 (one for the Eq and one for x). Doing this 
319 should mean that (foo d) is a PAP and we don't share it.
320
321 Note [Nested arities]
322 ~~~~~~~~~~~~~~~~~~~~~
323 For reasons that are not entirely clear, method bindings come out looking like
324 this:
325
326   AbsBinds [] [] [$cfromT <= [] fromT]
327     $cfromT [InlPrag=INLINE] :: T Bool -> Bool
328     { AbsBinds [] [] [fromT <= [] fromT_1]
329         fromT :: T Bool -> Bool
330         { fromT_1 ((TBool b)) = not b } } }
331
332 Note the nested AbsBind.  The arity for the InlineRule on $cfromT should be
333 gotten from the binding for fromT_1.
334
335 It might be better to have just one level of AbsBinds, but that requires more
336 thought!
337
338 Note [Implementing SPECIALISE pragmas]
339 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
340 Example:
341         f :: (Eq a, Ix b) => a -> b -> Bool
342         {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-}
343         f = <poly_rhs>
344
345 From this the typechecker generates
346
347     AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
348
349     SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX
350                       -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ])
351
352 Note that wrap_fn can transform *any* function with the right type prefix 
353     forall ab. (Eq a, Ix b) => XXX
354 regardless of XXX.  It's sort of polymorphic in XXX.  This is
355 useful: we use the same wrapper to transform each of the class ops, as
356 well as the dict.
357
358 From these we generate:
359
360     Rule:       forall p, q, (dp:Ix p), (dq:Ix q). 
361                     f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq
362
363     Spec bind:  f_spec = wrap_fn <poly_rhs>
364
365 Note that 
366
367   * The LHS of the rule may mention dictionary *expressions* (eg
368     $dfIxPair dp dq), and that is essential because the dp, dq are
369     needed on the RHS.
370
371   * The RHS of f_spec, <poly_rhs> has a *copy* of 'binds', so that it 
372     can fully specialise it.
373
374 \begin{code}
375 ------------------------
376 dsSpecs :: CoreExpr     -- Its rhs
377         -> TcSpecPrags
378         -> DsM ( OrdList (Id,CoreExpr)  -- Binding for specialised Ids
379                , [CoreRule] )           -- Rules for the Global Ids
380 -- See Note [Implementing SPECIALISE pragmas]
381 dsSpecs _ IsDefaultMethod = return (nilOL, [])
382 dsSpecs poly_rhs (SpecPrags sps)
383   = do { pairs <- mapMaybeM (dsSpec (Just poly_rhs)) sps
384        ; let (spec_binds_s, rules) = unzip pairs
385        ; return (concatOL spec_binds_s, rules) }
386
387 dsSpec :: Maybe CoreExpr        -- Just rhs => RULE is for a local binding
388                                 -- Nothing => RULE is for an imported Id
389                                 --            rhs is in the Id's unfolding
390        -> Located TcSpecPrag
391        -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
392 dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
393   | isJust (isClassOpId_maybe poly_id)
394   = putSrcSpanDs loc $ 
395     do { warnDs (ptext (sLit "Ignoring useless SPECIALISE pragma for class method selector") 
396                  <+> quotes (ppr poly_id))
397        ; return Nothing  }  -- There is no point in trying to specialise a class op
398                             -- Moreover, classops don't (currently) have an inl_sat arity set
399                             -- (it would be Just 0) and that in turn makes makeCorePair bleat
400
401   | no_act_spec && isNeverActive rule_act 
402   = putSrcSpanDs loc $ 
403     do { warnDs (ptext (sLit "Ignoring useless SPECIALISE pragma for NOINLINE function:")
404                  <+> quotes (ppr poly_id))
405        ; return Nothing  }  -- Function is NOINLINE, and the specialiation inherits that
406                             -- See Note [Activation pragmas for SPECIALISE]
407
408   | otherwise
409   = putSrcSpanDs loc $ 
410     do { let poly_name = idName poly_id
411        ; spec_name <- newLocalName poly_name
412        ; let (bndrs, ds_lhs) = collectBinders (dsHsWrapper spec_co (Var poly_id))
413              spec_ty = mkPiTypes bndrs (exprType ds_lhs)
414        ; case decomposeRuleLhs bndrs ds_lhs of {
415            Left msg -> do { warnDs msg; return Nothing } ;
416            Right (final_bndrs, _fn, args) -> do
417
418        { (spec_unf, unf_pairs) <- specUnfolding spec_co spec_ty (realIdUnfolding poly_id)
419
420        ; let spec_id  = mkLocalId spec_name spec_ty 
421                             `setInlinePragma` inl_prag
422                             `setIdUnfolding`  spec_unf
423              rule =  mkRule False {- Not auto -} is_local_id
424                         (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
425                         rule_act poly_name
426                         final_bndrs args
427                         (mkVarApps (Var spec_id) bndrs)
428
429              spec_rhs  = dsHsWrapper spec_co poly_rhs
430              spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs
431
432        ; when (isInlinePragma id_inl) (warnDs (specOnInline poly_name))
433        ; return (Just (spec_pair `consOL` unf_pairs, rule))
434        } } }
435   where
436     is_local_id = isJust mb_poly_rhs
437     poly_rhs | Just rhs <-  mb_poly_rhs
438              = rhs          -- Local Id; this is its rhs
439              | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id)
440              = unfolding    -- Imported Id; this is its unfolding
441                             -- Use realIdUnfolding so we get the unfolding 
442                             -- even when it is a loop breaker. 
443                             -- We want to specialise recursive functions!
444              | otherwise = pprPanic "dsImpSpecs" (ppr poly_id)
445                             -- The type checker has checked that it *has* an unfolding
446
447     id_inl = idInlinePragma poly_id
448
449     -- See Note [Activation pragmas for SPECIALISE]
450     inl_prag | not (isDefaultInlinePragma spec_inl)    = spec_inl
451              | not is_local_id  -- See Note [Specialising imported functions]
452                                  -- in OccurAnal
453              , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma
454              | otherwise                               = id_inl
455      -- Get the INLINE pragma from SPECIALISE declaration, or,
456      -- failing that, from the original Id
457
458     spec_prag_act = inlinePragmaActivation spec_inl
459
460     -- See Note [Activation pragmas for SPECIALISE]
461     -- no_act_spec is True if the user didn't write an explicit
462     -- phase specification in the SPECIALISE pragma
463     no_act_spec = case inlinePragmaSpec spec_inl of
464                     NoInline -> isNeverActive  spec_prag_act
465                     _        -> isAlwaysActive spec_prag_act
466     rule_act | no_act_spec = inlinePragmaActivation id_inl   -- Inherit
467              | otherwise   = spec_prag_act                   -- Specified by user
468
469
470 specUnfolding :: HsWrapper -> Type 
471               -> Unfolding -> DsM (Unfolding, OrdList (Id,CoreExpr))
472 {-   [Dec 10: TEMPORARILY commented out, until we can straighten out how to
473               generate unfoldings for specialised DFuns
474
475 specUnfolding wrap_fn spec_ty (DFunUnfolding _ _ ops)
476   = do { let spec_rhss = map wrap_fn ops
477        ; spec_ids <- mapM (mkSysLocalM (fsLit "spec") . exprType) spec_rhss
478        ; return (mkDFunUnfolding spec_ty (map Var spec_ids), toOL (spec_ids `zip` spec_rhss)) }
479 -}
480 specUnfolding _ _ _
481   = return (noUnfolding, nilOL)
482
483 specOnInline :: Name -> MsgDoc
484 specOnInline f = ptext (sLit "SPECIALISE pragma on INLINE function probably won't fire:") 
485                  <+> quotes (ppr f)
486 \end{code}
487
488
489 Note [Activation pragmas for SPECIALISE]
490 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
491 From a user SPECIALISE pragma for f, we generate
492   a) A top-level binding    spec_fn = rhs
493   b) A RULE                 f dOrd = spec_fn
494
495 We need two pragma-like things:
496
497 * spec_fn's inline pragma: inherited from f's inline pragma (ignoring 
498                            activation on SPEC), unless overriden by SPEC INLINE
499
500 * Activation of RULE: from SPECIALISE pragma (if activation given)
501                       otherwise from f's inline pragma
502
503 This is not obvious (see Trac #5237)!
504
505 Examples      Rule activation   Inline prag on spec'd fn
506 ---------------------------------------------------------------------
507 SPEC [n] f :: ty            [n]   Always, or NOINLINE [n]
508                                   copy f's prag
509
510 NOINLINE f
511 SPEC [n] f :: ty            [n]   NOINLINE
512                                   copy f's prag
513
514 NOINLINE [k] f
515 SPEC [n] f :: ty            [n]   NOINLINE [k]
516                                   copy f's prag
517
518 INLINE [k] f
519 SPEC [n] f :: ty            [n]   INLINE [k] 
520                                   copy f's prag
521
522 SPEC INLINE [n] f :: ty     [n]   INLINE [n]
523                                   (ignore INLINE prag on f,
524                                   same activation for rule and spec'd fn)
525
526 NOINLINE [k] f
527 SPEC f :: ty                [n]   INLINE [k]
528
529
530 %************************************************************************
531 %*                                                                      *
532 \subsection{Adding inline pragmas}
533 %*                                                                      *
534 %************************************************************************
535
536 \begin{code}
537 decomposeRuleLhs :: [Var] -> CoreExpr -> Either SDoc ([Var], Id, [CoreExpr])
538 -- Take apart the LHS of a RULE.  It's supposed to look like
539 --     /\a. f a Int dOrdInt
540 -- or  /\a.\d:Ord a. let { dl::Ord [a] = dOrdList a d } in f [a] dl
541 -- That is, the RULE binders are lambda-bound
542 -- Returns Nothing if the LHS isn't of the expected shape
543 decomposeRuleLhs bndrs lhs 
544   =  -- Note [Simplifying the left-hand side of a RULE]
545     case collectArgs opt_lhs of
546         (Var fn, args) -> check_bndrs fn args
547
548         (Case scrut bndr ty [(DEFAULT, _, body)], args)
549                 | isDeadBinder bndr     -- Note [Matching seqId]
550                 -> check_bndrs seqId (args' ++ args)
551                 where
552                    args' = [Type (idType bndr), Type ty, scrut, body]
553            
554         _other -> Left bad_shape_msg
555  where
556    opt_lhs = simpleOptExpr lhs
557
558    check_bndrs fn args
559      | null (dead_bndrs) = Right (extra_dict_bndrs ++ bndrs, fn, args)
560      | otherwise         = Left (vcat (map dead_msg dead_bndrs))
561      where
562        arg_fvs = exprsFreeVars args
563
564             -- Check for dead binders: Note [Unused spec binders]
565        dead_bndrs = filterOut (`elemVarSet` arg_fvs) bndrs
566
567             -- Add extra dict binders: Note [Constant rule dicts]
568        extra_dict_bndrs = [ mkLocalId (localiseName (idName d)) (idType d)
569                           | d <- varSetElems (arg_fvs `delVarSetList` bndrs)
570                           , isDictId d]
571
572
573    bad_shape_msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar"))
574                       2 (ppr opt_lhs)
575    dead_msg bndr = hang (sep [ ptext (sLit "Forall'd") <+> pp_bndr bndr
576                              , ptext (sLit "is not bound in RULE lhs")])
577                       2 (ppr opt_lhs)
578    pp_bndr bndr
579     | isTyVar bndr                      = ptext (sLit "type variable") <+> quotes (ppr bndr)
580     | Just pred <- evVarPred_maybe bndr = ptext (sLit "constraint") <+> quotes (ppr pred)
581     | otherwise                         = ptext (sLit "variable") <+> quotes (ppr bndr)
582 \end{code}
583
584 Note [Simplifying the left-hand side of a RULE]
585 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
586 simpleOptExpr occurrence-analyses and simplifies the lhs
587 and thereby
588 (a) sorts dict bindings into NonRecs and inlines them
589 (b) substitute trivial lets so that they don't get in the way
590     Note that we substitute the function too; we might 
591     have this as a LHS:  let f71 = M.f Int in f71
592 (c) does eta reduction
593
594 For (c) consider the fold/build rule, which without simplification
595 looked like:
596         fold k z (build (/\a. g a))  ==>  ...
597 This doesn't match unless you do eta reduction on the build argument.
598 Similarly for a LHS like
599         augment g (build h) 
600 we do not want to get
601         augment (\a. g a) (build h)
602 otherwise we don't match when given an argument like
603         augment (\a. h a a) (build h)
604
605 NB: tcSimplifyRuleLhs is very careful not to generate complicated
606     dictionary expressions that we might have to match
607
608 Note [Matching seqId]
609 ~~~~~~~~~~~~~~~~~~~
610 The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
611 and this code turns it back into an application of seq!  
612 See Note [Rules for seq] in MkId for the details.
613
614 Note [Unused spec binders]
615 ~~~~~~~~~~~~~~~~~~~~~~~~~~
616 Consider
617         f :: a -> a
618         {-# SPECIALISE f :: Eq a => a -> a #-}
619 It's true that this *is* a more specialised type, but the rule
620 we get is something like this:
621         f_spec d = f
622         RULE: f = f_spec d
623 Note that the rule is bogus, becuase it mentions a 'd' that is
624 not bound on the LHS!  But it's a silly specialisation anyway, becuase
625 the constraint is unused.  We could bind 'd' to (error "unused")
626 but it seems better to reject the program because it's almost certainly
627 a mistake.  That's what the isDeadBinder call detects.
628
629 Note [Constant rule dicts]
630 ~~~~~~~~~~~~~~~~~~~~~~~
631 When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict, 
632 which is presumably in scope at the function definition site, we can quantify 
633 over it too.  *Any* dict with that type will do.
634
635 So for example when you have
636         f :: Eq a => a -> a
637         f = <rhs>
638         {-# SPECIALISE f :: Int -> Int #-}
639
640 Then we get the SpecPrag
641         SpecPrag (f Int dInt) 
642
643 And from that we want the rule
644         
645         RULE forall dInt. f Int dInt = f_spec
646         f_spec = let f = <rhs> in f Int dInt
647
648 But be careful!  That dInt might be GHC.Base.$fOrdInt, which is an External
649 Name, and you can't bind them in a lambda or forall without getting things
650 confused.   Likewise it might have an InlineRule or something, which would be
651 utterly bogus. So we really make a fresh Id, with the same unique and type
652 as the old one, but with an Internal name and no IdInfo.
653
654
655 %************************************************************************
656 %*                                                                      *
657                 Desugaring evidence
658 %*                                                                      *
659 %************************************************************************
660
661
662 \begin{code}
663 dsHsWrapper :: HsWrapper -> CoreExpr -> CoreExpr
664 dsHsWrapper WpHole            e = e
665 dsHsWrapper (WpTyApp ty)      e = App e (Type ty)
666 dsHsWrapper (WpLet ev_binds)  e = mkCoreLets (dsTcEvBinds ev_binds) e
667 dsHsWrapper (WpCompose c1 c2) e = dsHsWrapper c1 (dsHsWrapper c2 e) 
668 dsHsWrapper (WpCast co)       e = dsTcCoercion co (mkCast e) 
669 dsHsWrapper (WpEvLam ev)      e = Lam ev e 
670 dsHsWrapper (WpTyLam tv)      e = Lam tv e 
671 dsHsWrapper (WpEvApp evtrm)   e = App e (dsEvTerm evtrm)
672
673 --------------------------------------
674 dsTcEvBinds :: TcEvBinds -> [CoreBind]
675 dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds"  -- Zonker has got rid of this
676 dsTcEvBinds (EvBinds bs)   = dsEvBinds bs
677
678 dsEvBinds :: Bag EvBind -> [CoreBind]
679 dsEvBinds bs = map ds_scc (sccEvBinds bs)
680   where
681     ds_scc (AcyclicSCC (EvBind v r)) = NonRec v (dsEvTerm r)
682     ds_scc (CyclicSCC bs)            = Rec (map ds_pair bs)
683
684     ds_pair (EvBind v r) = (v, dsEvTerm r)
685
686 sccEvBinds :: Bag EvBind -> [SCC EvBind]
687 sccEvBinds bs = stronglyConnCompFromEdgedVertices edges
688   where
689     edges :: [(EvBind, EvVar, [EvVar])]
690     edges = foldrBag ((:) . mk_node) [] bs 
691
692     mk_node :: EvBind -> (EvBind, EvVar, [EvVar])
693     mk_node b@(EvBind var term) = (b, var, evVarsOfTerm term)
694
695
696 ---------------------------------------
697 dsEvTerm :: EvTerm -> CoreExpr
698 dsEvTerm (EvId v) = Var v
699
700 dsEvTerm (EvCast v co) 
701   = dsTcCoercion co $ mkCast (Var v) -- 'v' is always a lifted evidence variable so it is
702                                      -- unnecessary to call varToCoreExpr v here.
703 dsEvTerm (EvKindCast v co)
704   = dsTcCoercion co $ (\_ -> Var v)
705
706 dsEvTerm (EvDFunApp df tys vars) = Var df `mkTyApps` tys `mkVarApps` vars
707 dsEvTerm (EvCoercion co)         = dsTcCoercion co mkEqBox
708 dsEvTerm (EvTupleSel v n)
709    = ASSERT( isTupleTyCon tc )
710      Case (Var v) (mkWildValBinder (varType v)) (tys !! n) [(DataAlt dc, xs, Var v')]
711   where
712     (tc, tys) = splitTyConApp (evVarPred v)
713     Just [dc] = tyConDataCons_maybe tc
714     v' = v `setVarType` ty_want
715     xs = map mkWildValBinder tys_before ++ v' : map mkWildValBinder tys_after
716     (tys_before, ty_want:tys_after) = splitAt n tys
717 dsEvTerm (EvTupleMk vs) = Var (dataConWorkId dc) `mkTyApps` tys `mkVarApps` vs
718   where dc = tupleCon ConstraintTuple (length vs)
719         tys = map varType vs
720 dsEvTerm (EvSuperClass d n)
721   = Var sc_sel_id `mkTyApps` tys `App` Var d
722   where
723     sc_sel_id  = classSCSelId cls n     -- Zero-indexed
724     (cls, tys) = getClassPredTys (evVarPred d)   
725 dsEvTerm (EvDelayedError ty msg) = Var errorId `mkTyApps` [ty] `mkApps` [litMsg]
726   where errorId = rUNTIME_ERROR_ID
727         litMsg  = Lit (MachStr msg)
728
729 ---------------------------------------
730 dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> CoreExpr
731 -- This is the crucial function that moves 
732 -- from LCoercions to Coercions; see Note [TcCoercions] in Coercion
733 -- e.g.  dsTcCoercion (trans g1 g2) k
734 --       = case g1 of EqBox g1# ->
735 --         case g2 of EqBox g2# ->
736 --         k (trans g1# g2#)
737 dsTcCoercion co thing_inside
738   = foldr wrap_in_case result_expr eqvs_covs
739   where
740     result_expr = thing_inside (ds_tc_coercion subst co)
741     result_ty   = exprType result_expr
742
743     -- We use the same uniques for the EqVars and the CoVars, and just change
744     -- the type. So the CoVars shadow the EqVars
745
746     eqvs_covs :: [(EqVar,CoVar)]
747     eqvs_covs = [(eqv, eqv `setIdType` mkCoercionType ty1 ty2)
748                 | eqv <- varSetElems (coVarsOfTcCo co)
749                 , let (ty1, ty2) = getEqPredTys (evVarPred eqv)]
750
751     subst = mkCvSubst emptyInScopeSet [(eqv, mkCoVarCo cov) | (eqv, cov) <- eqvs_covs]
752
753     wrap_in_case (eqv, cov) body 
754       = Case (Var eqv) eqv result_ty [(DataAlt eqBoxDataCon, [cov], body)]
755
756 ds_tc_coercion :: CvSubst -> TcCoercion -> Coercion
757 -- If the incoming TcCoercion if of type (a ~ b), 
758 --                 the result is of type (a ~# b)
759 -- The VarEnv maps EqVars of type (a ~ b) to Coercions of type (a ~# b)
760 -- No need for InScope set etc because the 
761 ds_tc_coercion subst tc_co
762   = go tc_co
763   where
764     go (TcRefl ty)            = Refl (Coercion.substTy subst ty)
765     go (TcTyConAppCo tc cos)  = mkTyConAppCo tc (map go cos)
766     go (TcAppCo co1 co2)      = mkAppCo (go co1) (go co2)
767     go (TcForAllCo tv co)     = mkForAllCo tv' (ds_tc_coercion subst' co)
768                               where
769                                 (subst', tv') = Coercion.substTyVarBndr subst tv
770     go (TcAxiomInstCo ax tys) = mkAxInstCo ax (map (Coercion.substTy subst) tys)
771     go (TcSymCo co)           = mkSymCo (go co)
772     go (TcTransCo co1 co2)    = mkTransCo (go co1) (go co2)
773     go (TcNthCo n co)         = mkNthCo n (go co)
774     go (TcInstCo co ty)       = mkInstCo (go co) ty
775     go (TcLetCo bs co)        = ds_tc_coercion (ds_co_binds bs) co
776     go (TcCoVarCo v)          = ds_ev_id subst v
777
778     ds_co_binds :: TcEvBinds -> CvSubst
779     ds_co_binds (EvBinds bs)      = foldl ds_scc subst (sccEvBinds bs)
780     ds_co_binds eb@(TcEvBinds {}) = pprPanic "ds_co_binds" (ppr eb)
781
782     ds_scc :: CvSubst -> SCC EvBind -> CvSubst
783     ds_scc subst (AcyclicSCC (EvBind v ev_term))
784       = extendCvSubstAndInScope subst v (ds_ev_term subst ev_term)
785     ds_scc _ (CyclicSCC other) = pprPanic "ds_scc:cyclic" (ppr other $$ ppr tc_co)
786
787     ds_ev_term :: CvSubst -> EvTerm -> Coercion
788     ds_ev_term subst (EvCoercion tc_co) = ds_tc_coercion subst tc_co
789     ds_ev_term subst (EvId v)           = ds_ev_id subst v
790     ds_ev_term _ other = pprPanic "ds_ev_term" (ppr other $$ ppr tc_co)
791
792     ds_ev_id :: CvSubst -> EqVar -> Coercion
793     ds_ev_id subst v
794      | Just co <- Coercion.lookupCoVar subst v = co
795      | otherwise  = pprPanic "ds_tc_coercion" (ppr v $$ ppr tc_co)
796 \end{code}