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