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