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