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