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