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