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