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