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