Fix recursive superclasses (again). Fixes Trac #4809.
[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 module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
14                  dsHsWrapper, dsTcEvBinds, dsEvBinds, wrapDsEvBinds,
15                  DsEvBind(..), AutoScc(..)
16   ) where
17
18 #include "HsVersions.h"
19
20 import {-# SOURCE #-}   DsExpr( dsLExpr )
21 import {-# SOURCE #-}   Match( matchWrapper )
22
23 import DsMonad
24 import DsGRHSs
25 import DsUtils
26
27 import HsSyn            -- lots of things
28 import CoreSyn          -- lots of things
29 import CoreSubst
30 import MkCore
31 import CoreUtils
32 import CoreArity ( etaExpand )
33 import CoreUnfold
34 import CoreFVs
35 import Digraph
36
37 import TcType
38 import Type
39 import TysPrim  ( anyTypeOfKind )
40 import CostCentre
41 import Module
42 import Id
43 import TyCon    ( tyConDataCons )
44 import Class
45 import DataCon  ( dataConRepType )
46 import Name     ( localiseName )
47 import MkId     ( seqId )
48 import Var
49 import VarSet
50 import Rules
51 import VarEnv
52 import Outputable
53 import SrcLoc
54 import Maybes
55 import OrdList
56 import Bag
57 import BasicTypes hiding ( TopLevel )
58 import FastString
59 -- import StaticFlags   ( opt_DsMultiTyVar )
60 import Util
61
62 import MonadUtils
63 \end{code}
64
65 %************************************************************************
66 %*                                                                      *
67 \subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
68 %*                                                                      *
69 %************************************************************************
70
71 \begin{code}
72 dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
73 dsTopLHsBinds auto_scc binds = ds_lhs_binds auto_scc binds
74
75 dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
76 dsLHsBinds binds = do { binds' <- ds_lhs_binds NoSccs binds
77                       ; return (fromOL binds') }
78
79 ------------------------
80 ds_lhs_binds :: AutoScc -> LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
81
82          -- scc annotation policy (see below)
83 ds_lhs_binds auto_scc binds = do { ds_bs <- mapBagM (dsLHsBind auto_scc) binds
84                                  ; return (foldBag appOL id nilOL ds_bs) }
85
86 dsLHsBind :: AutoScc -> LHsBind Id -> DsM (OrdList (Id,CoreExpr))
87 dsLHsBind auto_scc (L loc bind)
88   = putSrcSpanDs loc $ dsHsBind auto_scc bind
89
90 dsHsBind :: AutoScc -> HsBind Id -> DsM (OrdList (Id,CoreExpr))
91
92 dsHsBind _ (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless })
93   = do  { core_expr <- dsLExpr expr
94
95                 -- Dictionary bindings are always VarBinds,
96                 -- so we only need do this here
97         ; core_expr' <- addDictScc var core_expr
98         ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr'
99                    | otherwise         = var
100
101         ; return (unitOL (var', core_expr')) }
102
103 dsHsBind auto_scc (FunBind { fun_id = L _ fun, fun_matches = matches
104                     , fun_co_fn = co_fn, fun_tick = tick 
105                     , fun_infix = inf }) 
106  = do   { (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches
107         ; body'    <- mkOptTickBox tick body
108         ; wrap_fn' <- dsHsWrapper co_fn 
109         ; let rhs = addAutoScc auto_scc fun $ wrap_fn' (mkLams args body')
110         ; return (unitOL (makeCorePair fun False 0 rhs)) }
111
112 dsHsBind auto_scc (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty })
113   = do  { body_expr <- dsGuarded grhss ty
114         ; sel_binds <- mkSelectorBinds pat body_expr
115           -- We silently ignore inline pragmas; no makeCorePair
116           -- Not so cool, but really doesn't matter
117     ; let sel_binds' = [ (v, addAutoScc auto_scc v expr)
118                        | (v, expr) <- sel_binds ]
119         ; return (toOL sel_binds') }
120
121         -- A common case: one exported variable
122         -- Non-recursive bindings come through this way
123         -- So do self-recursive bindings, and recursive bindings
124         -- that have been chopped up with type signatures
125 dsHsBind auto_scc (AbsBinds { abs_tvs = all_tyvars, abs_ev_vars = dicts
126                             , abs_exports = [(tyvars, global, local, prags)]
127                             , abs_ev_binds = ev_binds, abs_binds = binds })
128   = ASSERT( all (`elem` tyvars) all_tyvars )
129     do  { bind_prs    <- ds_lhs_binds NoSccs binds
130         ; ds_ev_binds <- dsTcEvBinds ev_binds
131
132         ; let   core_bind = Rec (fromOL bind_prs)
133                 rhs       = addAutoScc auto_scc global $
134                             mkLams tyvars $ mkLams dicts $ 
135                             wrapDsEvBinds ds_ev_binds $
136                             Let core_bind $
137                             Var local
138     
139         ; (spec_binds, rules) <- dsSpecs rhs prags
140
141         ; let   global'   = addIdSpecialisations global rules
142                 main_bind = makeCorePair global' (isDefaultMethod prags)
143                                          (dictArity dicts) rhs 
144     
145         ; return (main_bind `consOL` spec_binds) }
146
147 dsHsBind auto_scc (AbsBinds { abs_tvs = all_tyvars, abs_ev_vars = dicts
148                             , abs_exports = exports, abs_ev_binds = ev_binds
149                             , abs_binds = binds })
150   = do  { bind_prs    <- ds_lhs_binds NoSccs binds
151         ; ds_ev_binds <- dsTcEvBinds ev_binds
152         ; let env = mkABEnv exports
153               do_one (lcl_id,rhs) | Just (_, gbl_id, _, _prags) <- lookupVarEnv env lcl_id
154                                   = (lcl_id, addAutoScc auto_scc gbl_id rhs)
155                                   | otherwise = (lcl_id,rhs)
156                
157               core_bind = Rec (map do_one (fromOL bind_prs))
158                 -- Monomorphic recursion possible, hence Rec
159
160               tup_expr     = mkBigCoreVarTup locals
161               tup_ty       = exprType tup_expr
162               poly_tup_rhs = mkLams all_tyvars $ mkLams dicts $
163                              wrapDsEvBinds ds_ev_binds $
164                              Let core_bind $
165                              tup_expr
166               locals       = [local | (_, _, local, _) <- exports]
167               local_tys    = map idType locals
168
169         ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
170
171         ; let mk_bind ((tyvars, global, _, spec_prags), n)  -- locals!!n == local
172                 =       -- Need to make fresh locals to bind in the selector,
173                         -- because some of the tyvars will be bound to 'Any'
174                   do { let ty_args = map mk_ty_arg all_tyvars
175                            substitute = substTyWith all_tyvars ty_args
176                      ; locals' <- newSysLocalsDs (map substitute local_tys)
177                      ; tup_id  <- newSysLocalDs  (substitute tup_ty)
178                      ; let rhs = mkLams tyvars $ mkLams dicts $
179                                  mkTupleSelector locals' (locals' !! n) tup_id $
180                                  mkVarApps (mkTyApps (Var poly_tup_id) ty_args)
181                                            dicts
182                            full_rhs = Let (NonRec poly_tup_id poly_tup_rhs) rhs
183                      ; (spec_binds, rules) <- dsSpecs full_rhs spec_prags
184                                                       
185                      ; let global' = addIdSpecialisations global rules
186                      ; return ((global', rhs) `consOL` spec_binds) }
187                 where
188                   mk_ty_arg all_tyvar
189                         | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
190                         | otherwise               = dsMkArbitraryType all_tyvar
191
192         ; export_binds_s <- mapM mk_bind (exports `zip` [0..])
193              -- Don't scc (auto-)annotate the tuple itself.
194
195         ; return ((poly_tup_id, poly_tup_rhs) `consOL` 
196                     concatOL export_binds_s) }
197
198 --------------------------------------
199 data DsEvBind 
200   = LetEvBind           -- Dictionary or coercion
201       CoreBind          -- recursive or non-recursive
202
203   | CaseEvBind          -- Coercion binding by superclass selection
204                         -- Desugars to case d of d { K _ g _ _ _ -> ... }                       
205       DictId               -- b   The dictionary
206       AltCon               -- K   Its constructor
207       [CoreBndr]           -- _ g _ _ _   The binders in the alternative
208
209 wrapDsEvBinds :: [DsEvBind] -> CoreExpr -> CoreExpr
210 wrapDsEvBinds ds_ev_binds body = foldr wrap_one body ds_ev_binds
211   where
212     body_ty = exprType body
213     wrap_one (LetEvBind b)       body = Let b body
214     wrap_one (CaseEvBind x k xs) body = Case (Var x) x body_ty [(k,xs,body)]
215
216 dsTcEvBinds :: TcEvBinds -> DsM [DsEvBind]
217 dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds"  -- Zonker has got rid of this
218 dsTcEvBinds (EvBinds bs)   = dsEvBinds bs
219
220 dsEvBinds :: Bag EvBind -> DsM [DsEvBind]
221 dsEvBinds bs = return (map dsEvGroup sccs)
222   where
223     sccs :: [SCC EvBind]
224     sccs = stronglyConnCompFromEdgedVertices edges
225
226     edges :: [(EvBind, EvVar, [EvVar])]
227     edges = foldrBag ((:) . mk_node) [] bs 
228
229     mk_node :: EvBind -> (EvBind, EvVar, [EvVar])
230     mk_node b@(EvBind var term) = (b, var, free_vars_of term)
231
232     free_vars_of :: EvTerm -> [EvVar]
233     free_vars_of (EvId v)           = [v]
234     free_vars_of (EvCast v co)      = v : varSetElems (tyVarsOfType co)
235     free_vars_of (EvCoercion co)    = varSetElems (tyVarsOfType co)
236     free_vars_of (EvDFunApp _ _ vs) = vs
237     free_vars_of (EvSuperClass d _) = [d]
238
239 dsEvGroup :: SCC EvBind -> DsEvBind
240 dsEvGroup (AcyclicSCC (EvBind co_var (EvSuperClass dict n)))
241   | isCoVar co_var       -- An equality superclass
242   = ASSERT( null other_data_cons )
243     CaseEvBind dict (DataAlt data_con) bndrs
244   where
245     (cls, tys) = getClassPredTys (evVarPred dict)
246     (data_con:other_data_cons) = tyConDataCons (classTyCon cls)
247     (ex_tvs, theta, rho) = tcSplitSigmaTy (applyTys (dataConRepType data_con) tys)
248     (arg_tys, _) = splitFunTys rho
249     bndrs = ex_tvs ++ map mk_wild_pred (theta `zip` [0..])
250                    ++ map mkWildValBinder arg_tys
251     mk_wild_pred (p, i) | i==n      = ASSERT( p `tcEqPred` (coVarPred co_var)) 
252                                       co_var
253                         | otherwise = mkWildEvBinder p
254     
255 dsEvGroup (AcyclicSCC (EvBind v r))
256   = LetEvBind (NonRec v (dsEvTerm r))
257
258 dsEvGroup (CyclicSCC bs)
259   = LetEvBind (Rec (map ds_pair bs))
260   where
261     ds_pair (EvBind v r) = (v, dsEvTerm r)
262
263 dsEvTerm :: EvTerm -> CoreExpr
264 dsEvTerm (EvId v)                = Var v
265 dsEvTerm (EvCast v co)           = Cast (Var v) co
266 dsEvTerm (EvDFunApp df tys vars) = Var df `mkTyApps` tys `mkVarApps` vars
267 dsEvTerm (EvCoercion co)         = Type co
268 dsEvTerm (EvSuperClass d n)
269   = ASSERT( isClassPred (classSCTheta cls !! n) )
270             -- We can only select *dictionary* superclasses
271             -- in terms.  Equality superclasses are dealt with
272             -- in dsEvGroup, where they can generate a case expression
273     Var sc_sel_id `mkTyApps` tys `App` Var d
274   where
275     sc_sel_id  = classSCSelId cls n     -- Zero-indexed
276     (cls, tys) = getClassPredTys (evVarPred d)    
277     
278 ------------------------
279 makeCorePair :: Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr)
280 makeCorePair gbl_id is_default_method dict_arity rhs
281   | is_default_method                 -- Default methods are *always* inlined
282   = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs)
283
284   | otherwise
285   = case inlinePragmaSpec inline_prag of
286           EmptyInlineSpec -> (gbl_id, rhs)
287           NoInline        -> (gbl_id, rhs)
288           Inlinable       -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)
289           Inline          -> inline_pair
290
291   where
292     inline_prag   = idInlinePragma gbl_id
293     inlinable_unf = mkInlinableUnfolding rhs
294     inline_pair
295        | Just arity <- inlinePragmaSat inline_prag
296         -- Add an Unfolding for an INLINE (but not for NOINLINE)
297         -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
298        , let real_arity = dict_arity + arity
299         -- NB: The arity in the InlineRule takes account of the dictionaries
300        = ( gbl_id `setIdUnfolding` mkInlineUnfolding (Just real_arity) rhs
301          , etaExpand real_arity rhs)
302
303        | otherwise
304        = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $
305          (gbl_id `setIdUnfolding` mkInlineUnfolding Nothing rhs, rhs)
306
307
308 dictArity :: [Var] -> Arity
309 -- Don't count coercion variables in arity
310 dictArity dicts = count isId dicts
311
312
313 ------------------------
314 type AbsBindEnv = VarEnv ([TyVar], Id, Id, TcSpecPrags)
315         -- Maps the "lcl_id" for an AbsBind to
316         -- its "gbl_id" and associated pragmas, if any
317
318 mkABEnv :: [([TyVar], Id, Id, TcSpecPrags)] -> AbsBindEnv
319 -- Takes the exports of a AbsBinds, and returns a mapping
320 --      lcl_id -> (tyvars, gbl_id, lcl_id, prags)
321 mkABEnv exports = mkVarEnv [ (lcl_id, export) | export@(_, _, lcl_id, _) <- exports]
322 \end{code}
323
324 Note [Rules and inlining]
325 ~~~~~~~~~~~~~~~~~~~~~~~~~
326 Common special case: no type or dictionary abstraction
327 This is a bit less trivial than you might suppose
328 The naive way woudl be to desguar to something like
329         f_lcl = ...f_lcl...     -- The "binds" from AbsBinds
330         M.f = f_lcl             -- Generated from "exports"
331 But we don't want that, because if M.f isn't exported,
332 it'll be inlined unconditionally at every call site (its rhs is 
333 trivial).  That would be ok unless it has RULES, which would 
334 thereby be completely lost.  Bad, bad, bad.
335
336 Instead we want to generate
337         M.f = ...f_lcl...
338         f_lcl = M.f
339 Now all is cool. The RULES are attached to M.f (by SimplCore), 
340 and f_lcl is rapidly inlined away.
341
342 This does not happen in the same way to polymorphic binds,
343 because they desugar to
344         M.f = /\a. let f_lcl = ...f_lcl... in f_lcl
345 Although I'm a bit worried about whether full laziness might
346 float the f_lcl binding out and then inline M.f at its call site
347
348 Note [Specialising in no-dict case]
349 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
350 Even if there are no tyvars or dicts, we may have specialisation pragmas.
351 Class methods can generate
352       AbsBinds [] [] [( ... spec-prag]
353          { AbsBinds [tvs] [dicts] ...blah }
354 So the overloading is in the nested AbsBinds. A good example is in GHC.Float:
355
356   class  (Real a, Fractional a) => RealFrac a  where
357     round :: (Integral b) => a -> b
358
359   instance  RealFrac Float  where
360     {-# SPECIALIZE round :: Float -> Int #-}
361
362 The top-level AbsBinds for $cround has no tyvars or dicts (because the 
363 instance does not).  But the method is locally overloaded!
364
365 Note [Abstracting over tyvars only]
366 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
367 When abstracting over type variable only (not dictionaries), we don't really need to
368 built a tuple and select from it, as we do in the general case. Instead we can take
369
370         AbsBinds [a,b] [ ([a,b], fg, fl, _),
371                          ([b],   gg, gl, _) ]
372                 { fl = e1
373                   gl = e2
374                    h = e3 }
375
376 and desugar it to
377
378         fg = /\ab. let B in e1
379         gg = /\b. let a = () in let B in S(e2)
380         h  = /\ab. let B in e3
381
382 where B is the *non-recursive* binding
383         fl = fg a b
384         gl = gg b
385         h  = h a b    -- See (b); note shadowing!
386
387 Notice (a) g has a different number of type variables to f, so we must
388              use the mkArbitraryType thing to fill in the gaps.  
389              We use a type-let to do that.
390
391          (b) The local variable h isn't in the exports, and rather than
392              clone a fresh copy we simply replace h by (h a b), where
393              the two h's have different types!  Shadowing happens here,
394              which looks confusing but works fine.
395
396          (c) The result is *still* quadratic-sized if there are a lot of
397              small bindings.  So if there are more than some small
398              number (10), we filter the binding set B by the free
399              variables of the particular RHS.  Tiresome.
400
401 Why got to this trouble?  It's a common case, and it removes the
402 quadratic-sized tuple desugaring.  Less clutter, hopefullly faster
403 compilation, especially in a case where there are a *lot* of
404 bindings.
405
406
407 Note [Eta-expanding INLINE things]
408 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
409 Consider
410    foo :: Eq a => a -> a
411    {-# INLINE foo #-}
412    foo x = ...
413
414 If (foo d) ever gets floated out as a common sub-expression (which can
415 happen as a result of method sharing), there's a danger that we never 
416 get to do the inlining, which is a Terribly Bad thing given that the
417 user said "inline"!
418
419 To avoid this we pre-emptively eta-expand the definition, so that foo
420 has the arity with which it is declared in the source code.  In this
421 example it has arity 2 (one for the Eq and one for x). Doing this 
422 should mean that (foo d) is a PAP and we don't share it.
423
424 Note [Nested arities]
425 ~~~~~~~~~~~~~~~~~~~~~
426 For reasons that are not entirely clear, method bindings come out looking like
427 this:
428
429   AbsBinds [] [] [$cfromT <= [] fromT]
430     $cfromT [InlPrag=INLINE] :: T Bool -> Bool
431     { AbsBinds [] [] [fromT <= [] fromT_1]
432         fromT :: T Bool -> Bool
433         { fromT_1 ((TBool b)) = not b } } }
434
435 Note the nested AbsBind.  The arity for the InlineRule on $cfromT should be
436 gotten from the binding for fromT_1.
437
438 It might be better to have just one level of AbsBinds, but that requires more
439 thought!
440
441 Note [Implementing SPECIALISE pragmas]
442 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
443 Example:
444         f :: (Eq a, Ix b) => a -> b -> Bool
445         {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-}
446         f = <poly_rhs>
447
448 From this the typechecker generates
449
450     AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
451
452     SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX
453                       -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ])
454
455 Note that wrap_fn can transform *any* function with the right type prefix 
456     forall ab. (Eq a, Ix b) => XXX
457 regardless of XXX.  It's sort of polymorphic in XXX.  This is
458 useful: we use the same wrapper to transform each of the class ops, as
459 well as the dict.
460
461 From these we generate:
462
463     Rule:       forall p, q, (dp:Ix p), (dq:Ix q). 
464                     f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq
465
466     Spec bind:  f_spec = wrap_fn <poly_rhs>
467
468 Note that 
469
470   * The LHS of the rule may mention dictionary *expressions* (eg
471     $dfIxPair dp dq), and that is essential because the dp, dq are
472     needed on the RHS.
473
474   * The RHS of f_spec, <poly_rhs> has a *copy* of 'binds', so that it 
475     can fully specialise it.
476
477 \begin{code}
478 ------------------------
479 dsSpecs :: CoreExpr     -- Its rhs
480         -> TcSpecPrags
481         -> DsM ( OrdList (Id,CoreExpr)  -- Binding for specialised Ids
482                , [CoreRule] )           -- Rules for the Global Ids
483 -- See Note [Implementing SPECIALISE pragmas]
484 dsSpecs _ IsDefaultMethod = return (nilOL, [])
485 dsSpecs poly_rhs (SpecPrags sps)
486   = do { pairs <- mapMaybeM (dsSpec (Just poly_rhs)) sps
487        ; let (spec_binds_s, rules) = unzip pairs
488        ; return (concatOL spec_binds_s, rules) }
489
490 dsSpec :: Maybe CoreExpr        -- Just rhs => RULE is for a local binding
491                                 -- Nothing => RULE is for an imported Id
492                                 --            rhs is in the Id's unfolding
493        -> Located TcSpecPrag
494        -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
495 dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
496   = putSrcSpanDs loc $ 
497     do { let poly_name = idName poly_id
498        ; spec_name <- newLocalName poly_name
499        ; wrap_fn   <- dsHsWrapper spec_co
500        ; let (bndrs, ds_lhs) = collectBinders (wrap_fn (Var poly_id))
501              spec_ty = mkPiTypes bndrs (exprType ds_lhs)
502        ; case decomposeRuleLhs bndrs ds_lhs of {
503            Left msg -> do { warnDs msg; return Nothing } ;
504            Right (final_bndrs, _fn, args) -> do
505
506        { (spec_unf, unf_pairs) <- specUnfolding wrap_fn spec_ty (realIdUnfolding poly_id)
507
508        ; let spec_id  = mkLocalId spec_name spec_ty 
509                             `setInlinePragma` inl_prag
510                             `setIdUnfolding`  spec_unf
511              inl_prag | isDefaultInlinePragma spec_inl = idInlinePragma poly_id
512                       | otherwise                      = spec_inl
513               -- Get the INLINE pragma from SPECIALISE declaration, or,
514               -- failing that, from the original Id
515
516              rule =  mkRule False {- Not auto -} is_local_id
517                         (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
518                         AlwaysActive poly_name
519                         final_bndrs args
520                         (mkVarApps (Var spec_id) bndrs)
521
522              spec_rhs  = wrap_fn poly_rhs
523              spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs
524
525        ; return (Just (spec_pair `consOL` unf_pairs, rule))
526        } } }
527   where
528     is_local_id = isJust mb_poly_rhs
529     poly_rhs | Just rhs <-  mb_poly_rhs
530              = rhs
531              | Just unfolding <- maybeUnfoldingTemplate (idUnfolding poly_id)
532              = unfolding
533              | otherwise = pprPanic "dsImpSpecs" (ppr poly_id)
534         -- In the Nothing case the specialisation is for an imported Id
535         -- whose unfolding gives the RHS to be specialised
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
551 dsMkArbitraryType :: TcTyVar -> Type
552 dsMkArbitraryType tv = anyTypeOfKind (tyVarKind tv)
553 \end{code}
554
555 %************************************************************************
556 %*                                                                      *
557 \subsection{Adding inline pragmas}
558 %*                                                                      *
559 %************************************************************************
560
561 \begin{code}
562 decomposeRuleLhs :: [Var] -> CoreExpr -> Either SDoc ([Var], Id, [CoreExpr])
563 -- Take apart the LHS of a RULE.  It's suuposed to look like
564 --     /\a. f a Int dOrdInt
565 -- or  /\a.\d:Ord a. let { dl::Ord [a] = dOrdList a d } in f [a] dl
566 -- That is, the RULE binders are lambda-bound
567 -- Returns Nothing if the LHS isn't of the expected shape
568 decomposeRuleLhs bndrs lhs 
569   =  -- Note [Simplifying the left-hand side of a RULE]
570     case collectArgs opt_lhs of
571         (Var fn, args) -> check_bndrs fn args
572
573         (Case scrut bndr ty [(DEFAULT, _, body)], args)
574                 | isDeadBinder bndr     -- Note [Matching seqId]
575                 -> check_bndrs seqId (args' ++ args)
576                 where
577                    args' = [Type (idType bndr), Type ty, scrut, body]
578            
579         _other -> Left bad_shape_msg
580  where
581    opt_lhs = simpleOptExpr lhs
582
583    check_bndrs fn args
584      | null (dead_bndrs) = Right (extra_dict_bndrs ++ bndrs, fn, args)
585      | otherwise         = Left (vcat (map dead_msg dead_bndrs))
586      where
587        arg_fvs = exprsFreeVars args
588
589             -- Check for dead binders: Note [Unused spec binders]
590        dead_bndrs = filterOut (`elemVarSet` arg_fvs) bndrs
591
592             -- Add extra dict binders: Note [Constant rule dicts]
593        extra_dict_bndrs = [ mkLocalId (localiseName (idName d)) (idType d)
594                           | d <- varSetElems (arg_fvs `delVarSetList` bndrs)
595                           , isDictId d]
596
597
598    bad_shape_msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar"))
599                       2 (ppr opt_lhs)
600    dead_msg bndr = hang (ptext (sLit "Forall'd") <+> pp_bndr bndr
601                                  <+> ptext (sLit "is not bound in RULE lhs"))
602                       2 (ppr opt_lhs)
603    pp_bndr bndr
604     | isTyVar bndr = ptext (sLit "type variable") <+> ppr bndr
605     | isCoVar bndr = ptext (sLit "coercion variable") <+> ppr bndr
606     | isDictId bndr = ptext (sLit "constraint") <+> ppr (get_pred bndr)
607     | otherwise     = ptext (sLit "variable") <+> ppr bndr
608
609    get_pred b = ASSERT( isId b ) expectJust "decomposeRuleLhs" 
610                                  (tcSplitPredTy_maybe (idType b))
611 \end{code}
612
613 Note [Simplifying the left-hand side of a RULE]
614 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
615 simpleOptExpr occurrence-analyses and simplifies the lhs
616 and thereby
617 (a) sorts dict bindings into NonRecs and inlines them
618 (b) substitute trivial lets so that they don't get in the way
619     Note that we substitute the function too; we might 
620     have this as a LHS:  let f71 = M.f Int in f71
621 (c) does eta reduction
622
623 For (c) consider the fold/build rule, which without simplification
624 looked like:
625         fold k z (build (/\a. g a))  ==>  ...
626 This doesn't match unless you do eta reduction on the build argument.
627 Similarly for a LHS like
628         augment g (build h) 
629 we do not want to get
630         augment (\a. g a) (build h)
631 otherwise we don't match when given an argument like
632         augment (\a. h a a) (build h)
633
634 NB: tcSimplifyRuleLhs is very careful not to generate complicated
635     dictionary expressions that we might have to match
636
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 \subsection[addAutoScc]{Adding automatic sccs}
688 %*                                                                      *
689 %************************************************************************
690
691 \begin{code}
692 data AutoScc = NoSccs 
693              | AddSccs Module (Id -> Bool)
694 -- The (Id->Bool) says which Ids to add SCCs to 
695 -- But we never add a SCC to function marked INLINE
696
697 addAutoScc :: AutoScc   
698            -> Id        -- Binder
699            -> CoreExpr  -- Rhs
700            -> CoreExpr  -- Scc'd Rhs
701
702 addAutoScc NoSccs _ rhs
703   = rhs
704 addAutoScc _ id rhs | isInlinePragma (idInlinePragma id)
705   = rhs
706 addAutoScc (AddSccs mod add_scc) id rhs
707   | add_scc id = mkSCC (mkAutoCC id mod NotCafCC) rhs
708   | otherwise  = rhs
709 \end{code}
710
711 If profiling and dealing with a dict binding,
712 wrap the dict in @_scc_ DICT <dict>@:
713
714 \begin{code}
715 addDictScc :: Id -> CoreExpr -> DsM CoreExpr
716 addDictScc _ rhs = return rhs
717
718 {- DISABLED for now (need to somehow make up a name for the scc) -- SDM
719   | not ( opt_SccProfilingOn && opt_AutoSccsOnDicts)
720     || not (isDictId var)
721   = return rhs                          -- That's easy: do nothing
722
723   | otherwise
724   = do (mod, grp) <- getModuleAndGroupDs
725         -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
726        return (Note (SCC (mkAllDictsCC mod grp False)) rhs)
727 -}
728 \end{code}
729
730
731 %************************************************************************
732 %*                                                                      *
733                 Desugaring coercions
734 %*                                                                      *
735 %************************************************************************
736
737
738 \begin{code}
739 dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
740 dsHsWrapper WpHole            = return (\e -> e)
741 dsHsWrapper (WpTyApp ty)      = return (\e -> App e (Type ty))
742 dsHsWrapper (WpLet ev_binds)  = do { ds_ev_binds <- dsTcEvBinds ev_binds
743                                    ; return (wrapDsEvBinds ds_ev_binds) }
744 dsHsWrapper (WpCompose c1 c2) = do { k1 <- dsHsWrapper c1 
745                                    ; k2 <- dsHsWrapper c2
746                                    ; return (k1 . k2) }
747 dsHsWrapper (WpCast co)       = return (\e -> Cast e co) 
748 dsHsWrapper (WpEvLam ev)      = return (\e -> Lam ev e) 
749 dsHsWrapper (WpTyLam tv)      = return (\e -> Lam tv e) 
750 dsHsWrapper (WpEvApp evtrm)   = return (\e -> App e (dsEvTerm evtrm))
751 \end{code}