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