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