Implement INLINABLE pragma
[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, 
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 [(Id,CoreExpr)]
73 dsTopLHsBinds auto_scc binds = do { binds' <- ds_lhs_binds auto_scc binds
74                                   ; return (fromOL binds') }
75
76 dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
77 dsLHsBinds binds = do { binds' <- ds_lhs_binds NoSccs binds
78                       ; return (fromOL binds') }
79
80 ------------------------
81 ds_lhs_binds :: AutoScc -> LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
82
83          -- scc annotation policy (see below)
84 ds_lhs_binds auto_scc binds = do { ds_bs <- mapBagM (dsLHsBind auto_scc) binds
85                                  ; return (foldBag appOL id nilOL ds_bs) }
86
87 dsLHsBind :: AutoScc -> LHsBind Id -> DsM (OrdList (Id,CoreExpr))
88 dsLHsBind auto_scc (L loc bind)
89   = putSrcSpanDs loc $ dsHsBind auto_scc bind
90
91 dsHsBind :: AutoScc -> HsBind Id -> DsM (OrdList (Id,CoreExpr))
92
93 dsHsBind _ (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless })
94   = do  { core_expr <- dsLExpr expr
95
96                 -- Dictionary bindings are always VarBinds,
97                 -- so we only need do this here
98         ; core_expr' <- addDictScc var core_expr
99         ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr'
100                    | otherwise         = var
101
102         ; return (unitOL (var', core_expr')) }
103
104 dsHsBind _ (FunBind { fun_id = L _ fun, fun_matches = matches 
105                     , fun_co_fn = co_fn, fun_tick = tick 
106                     , fun_infix = inf }) 
107  = do   { (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches
108         ; body'    <- mkOptTickBox tick body
109         ; wrap_fn' <- dsHsWrapper co_fn 
110         ; return (unitOL (fun, wrap_fn' (mkLams args body'))) }
111
112 dsHsBind _ (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         ; return (toOL sel_binds) }
116
117 {-
118 dsHsBind auto_scc (AbsBinds { abs_tvs = [], abs_ev_vars = []
119                             , abs_exports = exports, abs_ev_binds = ev_binds
120                             , abs_binds = binds })
121   = do  { bind_prs    <- ds_lhs_binds NoSccs binds
122         ; ds_ev_binds <- dsTcEvBinds ev_binds
123
124         ; let core_prs = addEvPairs ds_ev_binds bind_prs
125               env = mkABEnv exports
126               do_one (lcl_id, rhs) 
127                 | Just (_, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id
128                 = do { let rhs' = addAutoScc auto_scc gbl_id rhs
129                      ; (spec_binds, rules) <- dsSpecs gbl_id (Let (Rec core_prs) rhs') spec_prags
130                                     -- See Note [Specialising in no-dict case]
131                      ; let   gbl_id'   = addIdSpecialisations gbl_id rules
132                              main_bind = makeCorePair gbl_id' False 0 rhs'
133                      ; return (main_bind : spec_binds) }
134
135                 | otherwise = return [(lcl_id, rhs)]
136
137               locals'  = [(lcl_id, Var gbl_id) | (_, gbl_id, lcl_id, _) <- exports]
138                         -- Note [Rules and inlining]
139         ; export_binds <- mapM do_one core_prs
140         ; return (concat export_binds ++ locals' ++ rest) }
141                 -- No Rec needed here (contrast the other AbsBinds cases)
142                 -- because we can rely on the enclosing dsBind to wrap in Rec
143
144
145 dsHsBind auto_scc rest (AbsBinds { abs_tvs = tyvars, abs_ev_vars = []
146                                  , abs_exports = exports, abs_ev_binds = ev_binds
147                                  , abs_binds = binds })
148   | opt_DsMultiTyVar    -- This (static) debug flag just lets us
149                         -- switch on and off this optimisation to
150                         -- see if it has any impact; it is on by default
151   , allOL isLazyEvBind ev_binds
152   =     -- Note [Abstracting over tyvars only]
153     do  { bind_prs    <- ds_lhs_binds NoSccs binds
154         ; ds_ev_binds <- dsTcEvBinds ev_binds
155
156         ; let core_prs = addEvPairs ds_ev_binds bind_prs
157               arby_env = mkArbitraryTypeEnv tyvars exports
158               bndrs = mkVarSet (map fst core_prs)
159
160               add_lets | core_prs `lengthExceeds` 10 = add_some
161                        | otherwise                   = mkLets
162               add_some lg_binds rhs = mkLets [ NonRec b r | NonRec b r <- lg_binds
163                                                           , b `elemVarSet` fvs] rhs
164                 where
165                   fvs = exprSomeFreeVars (`elemVarSet` bndrs) rhs
166
167               env = mkABEnv exports
168               mk_lg_bind lcl_id gbl_id tyvars
169                  = NonRec (setIdInfo lcl_id vanillaIdInfo)
170                                 -- Nuke the IdInfo so that no old unfoldings
171                                 -- confuse use (it might mention something not
172                                 -- even in scope at the new site
173                           (mkTyApps (Var gbl_id) (mkTyVarTys tyvars))
174
175               do_one lg_binds (lcl_id, rhs) 
176                 | Just (id_tvs, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id
177                 = do { let rhs' = addAutoScc auto_scc gbl_id  $
178                                   mkLams id_tvs $
179                                   mkLets [ NonRec tv (Type (lookupVarEnv_NF arby_env tv))
180                                          | tv <- tyvars, not (tv `elem` id_tvs)] $
181                                   add_lets lg_binds rhs
182                      ; (spec_binds, rules) <- dsSpecs gbl_id rhs' spec_prags
183                      ; let   gbl_id'   = addIdSpecialisations gbl_id rules
184                              main_bind = makeCorePair gbl_id' False 0 rhs'
185                      ; return (mk_lg_bind lcl_id gbl_id' id_tvs, main_bind : spec_binds) }
186                 | otherwise
187                 = do { non_exp_gbl_id <- newUniqueId lcl_id (mkForAllTys tyvars (idType lcl_id))
188                      ; return (mk_lg_bind lcl_id non_exp_gbl_id tyvars,
189                                [(non_exp_gbl_id, mkLams tyvars (add_lets lg_binds rhs))]) }
190                                                   
191         ; (_, core_prs') <- fixDs (\ ~(lg_binds, _) -> mapAndUnzipM (do_one lg_binds) core_prs)
192         ; return (concat core_prs' ++ rest) }
193 -}
194
195         -- A common case: one exported variable
196         -- Non-recursive bindings come through this way
197         -- So do self-recursive bindings, and recursive bindings
198         -- that have been chopped up with type signatures
199 dsHsBind auto_scc (AbsBinds { abs_tvs = all_tyvars, abs_ev_vars = dicts
200                             , abs_exports = [(tyvars, global, local, prags)]
201                             , abs_ev_binds = ev_binds, abs_binds = binds })
202   = ASSERT( all (`elem` tyvars) all_tyvars )
203     do  { bind_prs    <- ds_lhs_binds NoSccs binds
204         ; ds_ev_binds <- dsTcEvBinds ev_binds
205
206         ; let   core_bind = Rec (fromOL bind_prs)
207                 rhs       = addAutoScc auto_scc global $
208                             mkLams tyvars $ mkLams dicts $ 
209                             wrapDsEvBinds ds_ev_binds $
210                             Let core_bind $
211                             Var local
212     
213         ; (spec_binds, rules) <- dsSpecs global rhs prags
214
215         ; let   global'   = addIdSpecialisations global rules
216                 main_bind = makeCorePair global' (isDefaultMethod prags)
217                                          (dictArity dicts) rhs 
218     
219         ; return (main_bind `consOL` spec_binds) }
220
221 dsHsBind auto_scc (AbsBinds { abs_tvs = all_tyvars, abs_ev_vars = dicts
222                             , abs_exports = exports, abs_ev_binds = ev_binds
223                             , abs_binds = binds })
224   = do  { bind_prs    <- ds_lhs_binds NoSccs binds
225         ; ds_ev_binds <- dsTcEvBinds ev_binds
226         ; let env = mkABEnv exports
227               do_one (lcl_id,rhs) | Just (_, gbl_id, _, _prags) <- lookupVarEnv env lcl_id
228                                   = (lcl_id, addAutoScc auto_scc gbl_id rhs)
229                                   | otherwise = (lcl_id,rhs)
230                
231               core_bind = Rec (map do_one (fromOL bind_prs))
232                 -- Monomorphic recursion possible, hence Rec
233
234               tup_expr     = mkBigCoreVarTup locals
235               tup_ty       = exprType tup_expr
236               poly_tup_rhs = mkLams all_tyvars $ mkLams dicts $
237                              wrapDsEvBinds ds_ev_binds $
238                              Let core_bind $
239                              tup_expr
240               locals       = [local | (_, _, local, _) <- exports]
241               local_tys    = map idType locals
242
243         ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
244
245         ; let mk_bind ((tyvars, global, _, spec_prags), n)  -- locals!!n == local
246                 =       -- Need to make fresh locals to bind in the selector,
247                         -- because some of the tyvars will be bound to 'Any'
248                   do { let ty_args = map mk_ty_arg all_tyvars
249                            substitute = substTyWith all_tyvars ty_args
250                      ; locals' <- newSysLocalsDs (map substitute local_tys)
251                      ; tup_id  <- newSysLocalDs  (substitute tup_ty)
252                      ; let rhs = mkLams tyvars $ mkLams dicts $
253                                  mkTupleSelector locals' (locals' !! n) tup_id $
254                                  mkVarApps (mkTyApps (Var poly_tup_id) ty_args)
255                                            dicts
256                      ; (spec_binds, rules) <- dsSpecs global
257                                                       (Let (NonRec poly_tup_id poly_tup_rhs) rhs)
258                                                       spec_prags
259                      ; let global' = addIdSpecialisations global rules
260                      ; return ((global', rhs) `consOL` spec_binds) }
261                 where
262                   mk_ty_arg all_tyvar
263                         | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
264                         | otherwise               = dsMkArbitraryType all_tyvar
265
266         ; export_binds_s <- mapM mk_bind (exports `zip` [0..])
267              -- Don't scc (auto-)annotate the tuple itself.
268
269         ; return ((poly_tup_id, poly_tup_rhs) `consOL` 
270                     concatOL export_binds_s) }
271
272 --------------------------------------
273 data DsEvBind 
274   = LetEvBind           -- Dictionary or coercion
275       CoreBind          -- recursive or non-recursive
276
277   | CaseEvBind          -- Coercion binding by superclass selection
278                         -- Desugars to case d of d { K _ g _ _ _ -> ... }                       
279       DictId               -- b   The dictionary
280       AltCon               -- K   Its constructor
281       [CoreBndr]           -- _ g _ _ _   The binders in the alternative
282
283 wrapDsEvBinds :: [DsEvBind] -> CoreExpr -> CoreExpr
284 wrapDsEvBinds ds_ev_binds body = foldr wrap_one body ds_ev_binds
285   where
286     body_ty = exprType body
287     wrap_one (LetEvBind b)       body = Let b body
288     wrap_one (CaseEvBind x k xs) body = Case (Var x) x body_ty [(k,xs,body)]
289
290 dsTcEvBinds :: TcEvBinds -> DsM [DsEvBind]
291 dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds"  -- Zonker has got rid of this
292 dsTcEvBinds (EvBinds bs)   = dsEvBinds bs
293
294 dsEvBinds :: Bag EvBind -> DsM [DsEvBind]
295 dsEvBinds bs = return (map dsEvGroup sccs)
296   where
297     sccs :: [SCC EvBind]
298     sccs = stronglyConnCompFromEdgedVertices edges
299
300     edges :: [(EvBind, EvVar, [EvVar])]
301     edges = foldrBag ((:) . mk_node) [] bs 
302
303     mk_node :: EvBind -> (EvBind, EvVar, [EvVar])
304     mk_node b@(EvBind var term) = (b, var, free_vars_of term)
305
306     free_vars_of :: EvTerm -> [EvVar]
307     free_vars_of (EvId v)           = [v]
308     free_vars_of (EvCast v co)      = v : varSetElems (tyVarsOfType co)
309     free_vars_of (EvCoercion co)    = varSetElems (tyVarsOfType co)
310     free_vars_of (EvDFunApp _ _ vs) = vs
311     free_vars_of (EvSuperClass d _) = [d]
312
313 dsEvGroup :: SCC EvBind -> DsEvBind
314 dsEvGroup (AcyclicSCC (EvBind co_var (EvSuperClass dict n)))
315   | isCoVar co_var       -- An equality superclass
316   = ASSERT( null other_data_cons )
317     CaseEvBind dict (DataAlt data_con) bndrs
318   where
319     (cls, tys) = getClassPredTys (evVarPred dict)
320     (data_con:other_data_cons) = tyConDataCons (classTyCon cls)
321     (ex_tvs, theta, rho) = tcSplitSigmaTy (applyTys (dataConRepType data_con) tys)
322     (arg_tys, _) = splitFunTys rho
323     bndrs = ex_tvs ++ map mk_wild_pred (theta `zip` [0..])
324                    ++ map mkWildValBinder arg_tys
325     mk_wild_pred (p, i) | i==n      = ASSERT( p `tcEqPred` (coVarPred co_var)) 
326                                       co_var
327                         | otherwise = mkWildEvBinder p
328     
329 dsEvGroup (AcyclicSCC (EvBind v r))
330   = LetEvBind (NonRec v (dsEvTerm r))
331
332 dsEvGroup (CyclicSCC bs)
333   = LetEvBind (Rec (map ds_pair bs))
334   where
335     ds_pair (EvBind v r) = (v, dsEvTerm r)
336
337 dsEvTerm :: EvTerm -> CoreExpr
338 dsEvTerm (EvId v)                = Var v
339 dsEvTerm (EvCast v co)           = Cast (Var v) co 
340 dsEvTerm (EvDFunApp df tys vars) = Var df `mkTyApps` tys `mkVarApps` vars
341 dsEvTerm (EvCoercion co)         = Type co
342 dsEvTerm (EvSuperClass d n)
343   = ASSERT( isClassPred (classSCTheta cls !! n) )
344             -- We can only select *dictionary* superclasses
345             -- in terms.  Equality superclasses are dealt with
346             -- in dsEvGroup, where they can generate a case expression
347     Var sc_sel_id `mkTyApps` tys `App` Var d
348   where
349     sc_sel_id  = classSCSelId cls n     -- Zero-indexed
350     (cls, tys) = getClassPredTys (evVarPred d)    
351     
352 ------------------------
353 makeCorePair :: Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr)
354 makeCorePair gbl_id is_default_method dict_arity rhs
355   | is_default_method                 -- Default methods are *always* inlined
356   = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs)
357
358   | otherwise
359   = case inlinePragmaSpec inline_prag of
360           EmptyInlineSpec -> (gbl_id, rhs)
361           NoInline        -> (gbl_id, rhs)
362           Inlinable       -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)
363           Inline          -> inline_pair
364
365   where
366     inline_prag   = idInlinePragma gbl_id
367     inlinable_unf = mkInlinableUnfolding rhs
368     inline_pair
369        | Just arity <- inlinePragmaSat inline_prag
370         -- Add an Unfolding for an INLINE (but not for NOINLINE)
371         -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
372        , let real_arity = dict_arity + arity
373         -- NB: The arity in the InlineRule takes account of the dictionaries
374        = ( gbl_id `setIdUnfolding` mkInlineUnfolding (Just real_arity) rhs
375          , etaExpand real_arity rhs)
376
377        | otherwise
378        = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $
379          (gbl_id `setIdUnfolding` mkInlineUnfolding Nothing rhs, rhs)
380
381
382 dictArity :: [Var] -> Arity
383 -- Don't count coercion variables in arity
384 dictArity dicts = count isId dicts
385
386
387 ------------------------
388 type AbsBindEnv = VarEnv ([TyVar], Id, Id, TcSpecPrags)
389         -- Maps the "lcl_id" for an AbsBind to
390         -- its "gbl_id" and associated pragmas, if any
391
392 mkABEnv :: [([TyVar], Id, Id, TcSpecPrags)] -> AbsBindEnv
393 -- Takes the exports of a AbsBinds, and returns a mapping
394 --      lcl_id -> (tyvars, gbl_id, lcl_id, prags)
395 mkABEnv exports = mkVarEnv [ (lcl_id, export) | export@(_, _, lcl_id, _) <- exports]
396 \end{code}
397
398 Note [Rules and inlining]
399 ~~~~~~~~~~~~~~~~~~~~~~~~~
400 Common special case: no type or dictionary abstraction
401 This is a bit less trivial than you might suppose
402 The naive way woudl be to desguar to something like
403         f_lcl = ...f_lcl...     -- The "binds" from AbsBinds
404         M.f = f_lcl             -- Generated from "exports"
405 But we don't want that, because if M.f isn't exported,
406 it'll be inlined unconditionally at every call site (its rhs is 
407 trivial).  That would be ok unless it has RULES, which would 
408 thereby be completely lost.  Bad, bad, bad.
409
410 Instead we want to generate
411         M.f = ...f_lcl...
412         f_lcl = M.f
413 Now all is cool. The RULES are attached to M.f (by SimplCore), 
414 and f_lcl is rapidly inlined away.
415
416 This does not happen in the same way to polymorphic binds,
417 because they desugar to
418         M.f = /\a. let f_lcl = ...f_lcl... in f_lcl
419 Although I'm a bit worried about whether full laziness might
420 float the f_lcl binding out and then inline M.f at its call site -}
421
422 Note [Specialising in no-dict case]
423 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
424 Even if there are no tyvars or dicts, we may have specialisation pragmas.
425 Class methods can generate
426       AbsBinds [] [] [( ... spec-prag]
427          { AbsBinds [tvs] [dicts] ...blah }
428 So the overloading is in the nested AbsBinds. A good example is in GHC.Float:
429
430   class  (Real a, Fractional a) => RealFrac a  where
431     round :: (Integral b) => a -> b
432
433   instance  RealFrac Float  where
434     {-# SPECIALIZE round :: Float -> Int #-}
435
436 The top-level AbsBinds for $cround has no tyvars or dicts (because the 
437 instance does not).  But the method is locally overloaded!
438
439 Note [Abstracting over tyvars only]
440 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
441 When abstracting over type variable only (not dictionaries), we don't really need to
442 built a tuple and select from it, as we do in the general case. Instead we can take
443
444         AbsBinds [a,b] [ ([a,b], fg, fl, _),
445                          ([b],   gg, gl, _) ]
446                 { fl = e1
447                   gl = e2
448                    h = e3 }
449
450 and desugar it to
451
452         fg = /\ab. let B in e1
453         gg = /\b. let a = () in let B in S(e2)
454         h  = /\ab. let B in e3
455
456 where B is the *non-recursive* binding
457         fl = fg a b
458         gl = gg b
459         h  = h a b    -- See (b); note shadowing!
460
461 Notice (a) g has a different number of type variables to f, so we must
462              use the mkArbitraryType thing to fill in the gaps.  
463              We use a type-let to do that.
464
465          (b) The local variable h isn't in the exports, and rather than
466              clone a fresh copy we simply replace h by (h a b), where
467              the two h's have different types!  Shadowing happens here,
468              which looks confusing but works fine.
469
470          (c) The result is *still* quadratic-sized if there are a lot of
471              small bindings.  So if there are more than some small
472              number (10), we filter the binding set B by the free
473              variables of the particular RHS.  Tiresome.
474
475 Why got to this trouble?  It's a common case, and it removes the
476 quadratic-sized tuple desugaring.  Less clutter, hopefullly faster
477 compilation, especially in a case where there are a *lot* of
478 bindings.
479
480
481 Note [Eta-expanding INLINE things]
482 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
483 Consider
484    foo :: Eq a => a -> a
485    {-# INLINE foo #-}
486    foo x = ...
487
488 If (foo d) ever gets floated out as a common sub-expression (which can
489 happen as a result of method sharing), there's a danger that we never 
490 get to do the inlining, which is a Terribly Bad thing given that the
491 user said "inline"!
492
493 To avoid this we pre-emptively eta-expand the definition, so that foo
494 has the arity with which it is declared in the source code.  In this
495 example it has arity 2 (one for the Eq and one for x). Doing this 
496 should mean that (foo d) is a PAP and we don't share it.
497
498 Note [Nested arities]
499 ~~~~~~~~~~~~~~~~~~~~~
500 For reasons that are not entirely clear, method bindings come out looking like
501 this:
502
503   AbsBinds [] [] [$cfromT <= [] fromT]
504     $cfromT [InlPrag=INLINE] :: T Bool -> Bool
505     { AbsBinds [] [] [fromT <= [] fromT_1]
506         fromT :: T Bool -> Bool
507         { fromT_1 ((TBool b)) = not b } } }
508
509 Note the nested AbsBind.  The arity for the InlineRule on $cfromT should be
510 gotten from the binding for fromT_1.
511
512 It might be better to have just one level of AbsBinds, but that requires more
513 thought!
514
515 Note [Implementing SPECIALISE pragmas]
516 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
517 Example:
518         f :: (Eq a, Ix b) => a -> b -> Bool
519         {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-}
520         f = <poly_rhs>
521
522 From this the typechecker generates
523
524     AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
525
526     SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX
527                       -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ])
528
529 Note that wrap_fn can transform *any* function with the right type prefix 
530     forall ab. (Eq a, Ix b) => XXX
531 regardless of XXX.  It's sort of polymorphic in XXX.  This is
532 useful: we use the same wrapper to transform each of the class ops, as
533 well as the dict.
534
535 From these we generate:
536
537     Rule:       forall p, q, (dp:Ix p), (dq:Ix q). 
538                     f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq
539
540     Spec bind:  f_spec = wrap_fn <poly_rhs>
541
542 Note that 
543
544   * The LHS of the rule may mention dictionary *expressions* (eg
545     $dfIxPair dp dq), and that is essential because the dp, dq are
546     needed on the RHS.
547
548   * The RHS of f_spec, <poly_rhs> has a *copy* of 'binds', so that it 
549     can fully specialise it.
550
551 \begin{code}
552 ------------------------
553 dsSpecs :: Id           -- The polymorphic Id
554         -> CoreExpr     -- Its rhs
555         -> TcSpecPrags
556         -> DsM ( OrdList (Id,CoreExpr)  -- Binding for specialised Ids
557                , [CoreRule] )           -- Rules for the Global Ids
558 -- See Note [Implementing SPECIALISE pragmas]
559 dsSpecs poly_id poly_rhs prags
560   = case prags of
561       IsDefaultMethod      -> return (nilOL, [])
562       SpecPrags sps -> do { pairs <- mapMaybeM spec_one sps
563                           ; let (spec_binds_s, rules) = unzip pairs
564                           ; return (concatOL spec_binds_s, rules) }
565  where 
566     spec_one :: Located TcSpecPrag -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
567     spec_one (L loc (SpecPrag spec_co spec_inl))
568       = putSrcSpanDs loc $ 
569         do { let poly_name = idName poly_id
570            ; spec_name <- newLocalName poly_name
571            ; wrap_fn   <- dsHsWrapper spec_co
572            ; let (bndrs, ds_lhs) = collectBinders (wrap_fn (Var poly_id))
573                  spec_ty = mkPiTypes bndrs (exprType ds_lhs)
574            ; case decomposeRuleLhs ds_lhs of {
575                Nothing -> do { warnDs (decomp_msg spec_co)
576                              ; return Nothing } ;
577
578                Just (_fn, args) ->
579
580            -- Check for dead binders: Note [Unused spec binders]
581              let arg_fvs = exprsFreeVars args
582                  bad_bndrs = filterOut (`elemVarSet` arg_fvs) bndrs
583              in if not (null bad_bndrs)
584                 then do { warnDs (dead_msg bad_bndrs); return Nothing } 
585                 else do
586
587            { (spec_unf, unf_pairs) <- specUnfolding wrap_fn spec_ty (realIdUnfolding poly_id)
588
589            ; let spec_id  = mkLocalId spec_name spec_ty 
590                             `setInlinePragma` inl_prag
591                             `setIdUnfolding`  spec_unf
592                  inl_prag | isDefaultInlinePragma spec_inl = idInlinePragma poly_id
593                           | otherwise                      = spec_inl
594                       -- Get the INLINE pragma from SPECIALISE declaration, or,
595                       -- failing that, from the original Id
596
597                  extra_dict_bndrs = [ mkLocalId (localiseName (idName d)) (idType d)
598                                             -- See Note [Constant rule dicts]
599                                     | d <- varSetElems (arg_fvs `delVarSetList` bndrs)
600                                     , isDictId d]
601
602                  rule =  mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
603                                 AlwaysActive poly_name
604                                 (extra_dict_bndrs ++ bndrs) args
605                                 (mkVarApps (Var spec_id) bndrs)
606
607                  spec_rhs  = wrap_fn poly_rhs
608                  spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs
609
610             ; return (Just (spec_pair `consOL` unf_pairs, rule))
611             } } }
612
613     dead_msg bs = vcat [ sep [ptext (sLit "Useless constraint") <> plural bs
614                                  <+> ptext (sLit "in specialied type:"),
615                              nest 2 (pprTheta (map get_pred bs))]
616                        , ptext (sLit "SPECIALISE pragma ignored")]
617     get_pred b = ASSERT( isId b ) expectJust "dsSpec" (tcSplitPredTy_maybe (idType b))
618
619     decomp_msg spec_co 
620         = hang (ptext (sLit "Specialisation too complicated to desugar; ignored"))
621              2 (pprHsWrapper (ppr poly_id) spec_co)
622              
623
624 specUnfolding :: (CoreExpr -> CoreExpr) -> Type 
625               -> Unfolding -> DsM (Unfolding, OrdList (Id,CoreExpr))
626 specUnfolding wrap_fn spec_ty (DFunUnfolding _ _ ops)
627   = do { let spec_rhss = map wrap_fn ops
628        ; spec_ids <- mapM (mkSysLocalM (fsLit "spec") . exprType) spec_rhss
629        ; return (mkDFunUnfolding spec_ty (map Var spec_ids), toOL (spec_ids `zip` spec_rhss)) }
630 specUnfolding _ _ _
631   = return (noUnfolding, nilOL)
632
633 {-
634 mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> TyVarEnv Type
635 -- If any of the tyvars is missing from any of the lists in 
636 -- the second arg, return a binding in the result
637 mkArbitraryTypeEnv tyvars exports
638   = go emptyVarEnv exports
639   where
640     go env [] = env
641     go env ((ltvs, _, _, _) : exports)
642         = go env' exports
643         where
644           env' = foldl extend env [tv | tv <- tyvars
645                                       , not (tv `elem` ltvs)
646                                       , not (tv `elemVarEnv` env)]
647
648     extend env tv = extendVarEnv env tv (dsMkArbitraryType tv)
649 -}
650
651 dsMkArbitraryType :: TcTyVar -> Type
652 dsMkArbitraryType tv = anyTypeOfKind (tyVarKind tv)
653 \end{code}
654
655 Note [Unused spec binders]
656 ~~~~~~~~~~~~~~~~~~~~~~~~~~
657 Consider
658         f :: a -> a
659         {-# SPECIALISE f :: Eq a => a -> a #-}
660 It's true that this *is* a more specialised type, but the rule
661 we get is something like this:
662         f_spec d = f
663         RULE: f = f_spec d
664 Note that the rule is bogus, becuase it mentions a 'd' that is
665 not bound on the LHS!  But it's a silly specialisation anyway, becuase
666 the constraint is unused.  We could bind 'd' to (error "unused")
667 but it seems better to reject the program because it's almost certainly
668 a mistake.  That's what the isDeadBinder call detects.
669
670 Note [Constant rule dicts]
671 ~~~~~~~~~~~~~~~~~~~~~~~
672 When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict, 
673 which is presumably in scope at the function definition site, we can quantify 
674 over it too.  *Any* dict with that type will do.
675
676 So for example when you have
677         f :: Eq a => a -> a
678         f = <rhs>
679         {-# SPECIALISE f :: Int -> Int #-}
680
681 Then we get the SpecPrag
682         SpecPrag (f Int dInt) 
683
684 And from that we want the rule
685         
686         RULE forall dInt. f Int dInt = f_spec
687         f_spec = let f = <rhs> in f Int dInt
688
689 But be careful!  That dInt might be GHC.Base.$fOrdInt, which is an External
690 Name, and you can't bind them in a lambda or forall without getting things
691 confused.   Likewise it might have an InlineRule or something, which would be
692 utterly bogus. So we really make a fresh Id, with the same unique and type
693 as the old one, but with an Internal name and no IdInfo.
694
695 %************************************************************************
696 %*                                                                      *
697 \subsection{Adding inline pragmas}
698 %*                                                                      *
699 %************************************************************************
700
701 \begin{code}
702 decomposeRuleLhs :: CoreExpr -> Maybe (Id, [CoreExpr])
703 -- Take apart the LHS of a RULE.  It's suuposed to look like
704 --     /\a. f a Int dOrdInt
705 -- or  /\a.\d:Ord a. let { dl::Ord [a] = dOrdList a d } in f [a] dl
706 -- That is, the RULE binders are lambda-bound
707 -- Returns Nothing if the LHS isn't of the expected shape
708 decomposeRuleLhs lhs 
709   =  -- Note [Simplifying the left-hand side of a RULE]
710     case collectArgs (simpleOptExpr lhs) of
711         (Var fn, args) -> Just (fn, args)
712
713         (Case scrut bndr ty [(DEFAULT, _, body)], args)
714                 | isDeadBinder bndr     -- Note [Matching seqId]
715                 -> Just (seqId, args' ++ args)
716                 where
717                    args' = [Type (idType bndr), Type ty, scrut, body]
718            
719         _other -> Nothing       -- Unexpected shape
720 \end{code}
721
722 Note [Simplifying the left-hand side of a RULE]
723 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
724 simpleOptExpr occurrence-analyses and simplifies the lhs
725 and thereby
726 (a) sorts dict bindings into NonRecs and inlines them
727 (b) substitute trivial lets so that they don't get in the way
728     Note that we substitute the function too; we might 
729     have this as a LHS:  let f71 = M.f Int in f71
730 (c) does eta reduction
731
732 For (c) consider the fold/build rule, which without simplification
733 looked like:
734         fold k z (build (/\a. g a))  ==>  ...
735 This doesn't match unless you do eta reduction on the build argument.
736 Similarly for a LHS like
737         augment g (build h) 
738 we do not want to get
739         augment (\a. g a) (build h)
740 otherwise we don't match when given an argument like
741         augment (\a. h a a) (build h)
742
743 NB: tcSimplifyRuleLhs is very careful not to generate complicated
744     dictionary expressions that we might have to match
745
746
747 Note [Matching seqId]
748 ~~~~~~~~~~~~~~~~~~~
749 The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
750 and this code turns it back into an application of seq!  
751 See Note [Rules for seq] in MkId for the details.
752
753
754 %************************************************************************
755 %*                                                                      *
756 \subsection[addAutoScc]{Adding automatic sccs}
757 %*                                                                      *
758 %************************************************************************
759
760 \begin{code}
761 data AutoScc = NoSccs 
762              | AddSccs Module (Id -> Bool)
763 -- The (Id->Bool) says which Ids to add SCCs to 
764 -- But we never add a SCC to function marked INLINE
765
766 addAutoScc :: AutoScc   
767            -> Id        -- Binder
768            -> CoreExpr  -- Rhs
769            -> CoreExpr  -- Scc'd Rhs
770
771 addAutoScc NoSccs _ rhs
772   = rhs
773 addAutoScc _ id rhs | isInlinePragma (idInlinePragma id)
774   = rhs
775 addAutoScc (AddSccs mod add_scc) id rhs
776   | add_scc id = mkSCC (mkAutoCC id mod NotCafCC) rhs
777   | otherwise  = rhs
778 \end{code}
779
780 If profiling and dealing with a dict binding,
781 wrap the dict in @_scc_ DICT <dict>@:
782
783 \begin{code}
784 addDictScc :: Id -> CoreExpr -> DsM CoreExpr
785 addDictScc _ rhs = return rhs
786
787 {- DISABLED for now (need to somehow make up a name for the scc) -- SDM
788   | not ( opt_SccProfilingOn && opt_AutoSccsOnDicts)
789     || not (isDictId var)
790   = return rhs                          -- That's easy: do nothing
791
792   | otherwise
793   = do (mod, grp) <- getModuleAndGroupDs
794         -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
795        return (Note (SCC (mkAllDictsCC mod grp False)) rhs)
796 -}
797 \end{code}
798
799
800 %************************************************************************
801 %*                                                                      *
802                 Desugaring coercions
803 %*                                                                      *
804 %************************************************************************
805
806
807 \begin{code}
808 dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
809 dsHsWrapper WpHole            = return (\e -> e)
810 dsHsWrapper (WpTyApp ty)      = return (\e -> App e (Type ty))
811 dsHsWrapper (WpLet ev_binds)  = do { ds_ev_binds <- dsTcEvBinds ev_binds
812                                    ; return (wrapDsEvBinds ds_ev_binds) }
813 dsHsWrapper (WpCompose c1 c2) = do { k1 <- dsHsWrapper c1 
814                                    ; k2 <- dsHsWrapper c2
815                                    ; return (k1 . k2) }
816 dsHsWrapper (WpCast co)       = return (\e -> Cast e co) 
817 dsHsWrapper (WpEvLam ev)      = return (\e -> Lam ev e) 
818 dsHsWrapper (WpTyLam tv)      = return (\e -> Lam tv e) 
819 dsHsWrapper (WpEvApp evtrm)   = return (\e -> App e (dsEvTerm evtrm))
820 \end{code}