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 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 Util
60
61 import MonadUtils
62 import HscTypes (MonadThings)
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 = all_tyvars, abs_ev_vars = dicts
126                             , abs_exports = [(tyvars, global, local, prags)]
127                             , abs_ev_binds = ev_binds, abs_binds = binds })
128   = ASSERT( all (`elem` tyvars) all_tyvars )
129     do  { bind_prs    <- ds_lhs_binds NoSccs binds
130         ; ds_ev_binds <- dsTcEvBinds ev_binds
131
132         ; let   core_bind = Rec (fromOL bind_prs)
133                 rhs       = addAutoScc auto_scc global $
134                             mkLams tyvars $ mkLams dicts $ 
135                             wrapDsEvBinds ds_ev_binds $
136                             Let core_bind $
137                             Var local
138     
139         ; (spec_binds, rules) <- dsSpecs rhs prags
140
141         ; let   global'   = addIdSpecialisations global rules
142                 main_bind = makeCorePair global' (isDefaultMethod prags)
143                                          (dictArity dicts) rhs 
144     
145         ; return (main_bind `consOL` spec_binds) }
146
147 dsHsBind auto_scc (AbsBinds { abs_tvs = all_tyvars, abs_ev_vars = dicts
148                             , abs_exports = exports, abs_ev_binds = ev_binds
149                             , abs_binds = binds })
150   = do  { bind_prs    <- ds_lhs_binds NoSccs binds
151         ; ds_ev_binds <- dsTcEvBinds ev_binds
152         ; let env = mkABEnv exports
153               do_one (lcl_id,rhs) | Just (_, gbl_id, _, _prags) <- lookupVarEnv env lcl_id
154                                   = (lcl_id, addAutoScc auto_scc gbl_id rhs)
155                                   | otherwise = (lcl_id,rhs)
156                
157               core_bind = Rec (map do_one (fromOL bind_prs))
158                 -- Monomorphic recursion possible, hence Rec
159
160               tup_expr     = mkBigCoreVarTup locals
161               tup_ty       = exprType tup_expr
162               poly_tup_rhs = mkLams all_tyvars $ mkLams dicts $
163                              wrapDsEvBinds ds_ev_binds $
164                              Let core_bind $
165                              tup_expr
166               locals       = [local | (_, _, local, _) <- exports]
167               local_tys    = map idType locals
168
169         ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
170
171         ; let mk_bind ((tyvars, global, _, spec_prags), n)  -- locals!!n == local
172                 =       -- Need to make fresh locals to bind in the selector,
173                         -- because some of the tyvars will be bound to 'Any'
174                   do { let ty_args = map mk_ty_arg all_tyvars
175                            substitute = substTyWith all_tyvars ty_args
176                      ; locals' <- newSysLocalsDs (map substitute local_tys)
177                      ; tup_id  <- newSysLocalDs  (substitute tup_ty)
178                      ; let rhs = mkLams tyvars $ mkLams dicts $
179                                  mkTupleSelector locals' (locals' !! n) tup_id $
180                                  mkVarApps (mkTyApps (Var poly_tup_id) ty_args)
181                                            dicts
182                            full_rhs = Let (NonRec poly_tup_id poly_tup_rhs) rhs
183                      ; (spec_binds, rules) <- dsSpecs full_rhs spec_prags
184                                                       
185                      ; let global' = addIdSpecialisations global rules
186                      ; return ((global', rhs) `consOL` spec_binds) }
187                 where
188                   mk_ty_arg all_tyvar
189                         | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
190                         | otherwise               = dsMkArbitraryType all_tyvar
191
192         ; export_binds_s <- mapM mk_bind (exports `zip` [0..])
193              -- Don't scc (auto-)annotate the tuple itself.
194
195         ; return ((poly_tup_id, poly_tup_rhs) `consOL` 
196                     concatOL export_binds_s) }
197
198 --------------------------------------
199 data DsEvBind 
200   = LetEvBind           -- Dictionary or coercion
201       CoreBind          -- recursive or non-recursive
202
203   | CaseEvBind          -- Coercion binding by superclass selection
204                         -- Desugars to case d of d { K _ g _ _ _ -> ... }                       
205       DictId               -- b   The dictionary
206       AltCon               -- K   Its constructor
207       [CoreBndr]           -- _ g _ _ _   The binders in the alternative
208
209 wrapDsEvBinds :: [DsEvBind] -> CoreExpr -> CoreExpr
210 wrapDsEvBinds ds_ev_binds body = foldr wrap_one body ds_ev_binds
211   where
212     body_ty = exprType body
213     wrap_one (LetEvBind b)       body = Let b body
214     wrap_one (CaseEvBind x k xs) body = Case (Var x) x body_ty [(k,xs,body)]
215
216 dsTcEvBinds :: TcEvBinds -> DsM [DsEvBind]
217 dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds"  -- Zonker has got rid of this
218 dsTcEvBinds (EvBinds bs)   = dsEvBinds bs
219
220 dsEvBinds :: Bag EvBind -> DsM [DsEvBind]
221 dsEvBinds bs = mapM dsEvGroup sccs
222   where
223     sccs :: [SCC EvBind]
224     sccs = stronglyConnCompFromEdgedVertices edges
225
226     edges :: [(EvBind, EvVar, [EvVar])]
227     edges = foldrBag ((:) . mk_node) [] bs 
228
229     mk_node :: EvBind -> (EvBind, EvVar, [EvVar])
230     mk_node b@(EvBind var term) = (b, var, free_vars_of term)
231
232     free_vars_of :: EvTerm -> [EvVar]
233     free_vars_of (EvId v)           = [v]
234     free_vars_of (EvCast v co)      = v : varSetElems (tyVarsOfType co)
235     free_vars_of (EvCoercion co)    = varSetElems (tyVarsOfType co)
236     free_vars_of (EvDFunApp _ _ vs) = vs
237     free_vars_of (EvSuperClass d _) = [d]
238     free_vars_of (EvInteger _)      = []
239     free_vars_of (EvAxiom _ _)      = []
240
241 dsEvGroup :: MonadThings m => SCC EvBind -> m DsEvBind
242 dsEvGroup (AcyclicSCC (EvBind co_var (EvSuperClass dict n)))
243   | isCoVar co_var       -- An equality superclass
244   = ASSERT( null other_data_cons )
245     return (CaseEvBind dict (DataAlt data_con) bndrs)
246   where
247     (cls, tys) = getClassPredTys (evVarPred dict)
248     (data_con:other_data_cons) = tyConDataCons (classTyCon cls)
249     (ex_tvs, theta, rho) = tcSplitSigmaTy (applyTys (dataConRepType data_con) tys)
250     (arg_tys, _) = splitFunTys rho
251     bndrs = ex_tvs ++ map mk_wild_pred (theta `zip` [0..])
252                    ++ map mkWildValBinder arg_tys
253     mk_wild_pred (p, i) | i==n      = ASSERT( p `tcEqPred` (coVarPred co_var)) 
254                                       co_var
255                         | otherwise = mkWildEvBinder p
256     
257 dsEvGroup (AcyclicSCC (EvBind v r))
258   = do d <- dsEvTerm r
259        return (LetEvBind (NonRec v d))
260
261 dsEvGroup (CyclicSCC bs)
262   = do ds <- mapM ds_pair bs
263        return (LetEvBind (Rec ds))
264   where
265     ds_pair (EvBind v r) = do ev <- dsEvTerm r
266                               return (v, ev)
267
268 dsEvTerm :: MonadThings m => EvTerm -> m CoreExpr
269 dsEvTerm (EvId v)         = return (Var v)
270 dsEvTerm (EvCast v co)    = return (Cast (Var v) co)
271 dsEvTerm (EvDFunApp df tys vars) =
272                             return (Var df `mkTyApps` tys `mkVarApps` vars)
273 dsEvTerm (EvCoercion co)  = return (Type 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   = putSrcSpanDs loc $ 
505     do { let poly_name = idName poly_id
506        ; spec_name <- newLocalName poly_name
507        ; wrap_fn   <- dsHsWrapper spec_co
508        ; let (bndrs, ds_lhs) = collectBinders (wrap_fn (Var poly_id))
509              spec_ty = mkPiTypes bndrs (exprType ds_lhs)
510        ; case decomposeRuleLhs bndrs ds_lhs of {
511            Left msg -> do { warnDs msg; return Nothing } ;
512            Right (final_bndrs, _fn, args) -> do
513
514        { (spec_unf, unf_pairs) <- specUnfolding wrap_fn spec_ty (realIdUnfolding poly_id)
515
516        ; let spec_id  = mkLocalId spec_name spec_ty 
517                             `setInlinePragma` inl_prag
518                             `setIdUnfolding`  spec_unf
519              inl_prag | isDefaultInlinePragma spec_inl = idInlinePragma poly_id
520                       | otherwise                      = spec_inl
521               -- Get the INLINE pragma from SPECIALISE declaration, or,
522               -- failing that, from the original Id
523
524              rule =  mkRule False {- Not auto -} is_local_id
525                         (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
526                         AlwaysActive poly_name
527                         final_bndrs args
528                         (mkVarApps (Var spec_id) bndrs)
529
530              spec_rhs  = wrap_fn poly_rhs
531              spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs
532
533        ; return (Just (spec_pair `consOL` unf_pairs, rule))
534        } } }
535   where
536     is_local_id = isJust mb_poly_rhs
537     poly_rhs | Just rhs <-  mb_poly_rhs
538              = rhs          -- Local Id; this is its rhs
539              | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id)
540              = unfolding    -- Imported Id; this is its unfolding
541                             -- Use realIdUnfolding so we get the unfolding 
542                             -- even when it is a loop breaker. 
543                             -- We want to specialise recursive functions!
544              | otherwise = pprPanic "dsImpSpecs" (ppr poly_id)
545                             -- The type checker has checked that it *has* an unfolding
546
547 specUnfolding :: (CoreExpr -> CoreExpr) -> Type 
548               -> Unfolding -> DsM (Unfolding, OrdList (Id,CoreExpr))
549 {-   [Dec 10: TEMPORARILY commented out, until we can straighten out how to
550               generate unfoldings for specialised DFuns
551
552 specUnfolding wrap_fn spec_ty (DFunUnfolding _ _ ops)
553   = do { let spec_rhss = map wrap_fn ops
554        ; spec_ids <- mapM (mkSysLocalM (fsLit "spec") . exprType) spec_rhss
555        ; return (mkDFunUnfolding spec_ty (map Var spec_ids), toOL (spec_ids `zip` spec_rhss)) }
556 -}
557 specUnfolding _ _ _
558   = return (noUnfolding, nilOL)
559
560 dsMkArbitraryType :: TcTyVar -> Type
561 dsMkArbitraryType tv = anyTypeOfKind (tyVarKind tv)
562 \end{code}
563
564 %************************************************************************
565 %*                                                                      *
566 \subsection{Adding inline pragmas}
567 %*                                                                      *
568 %************************************************************************
569
570 \begin{code}
571 decomposeRuleLhs :: [Var] -> CoreExpr -> Either SDoc ([Var], Id, [CoreExpr])
572 -- Take apart the LHS of a RULE.  It's suuposed to look like
573 --     /\a. f a Int dOrdInt
574 -- or  /\a.\d:Ord a. let { dl::Ord [a] = dOrdList a d } in f [a] dl
575 -- That is, the RULE binders are lambda-bound
576 -- Returns Nothing if the LHS isn't of the expected shape
577 decomposeRuleLhs bndrs lhs 
578   =  -- Note [Simplifying the left-hand side of a RULE]
579     case collectArgs opt_lhs of
580         (Var fn, args) -> check_bndrs fn args
581
582         (Case scrut bndr ty [(DEFAULT, _, body)], args)
583                 | isDeadBinder bndr     -- Note [Matching seqId]
584                 -> check_bndrs seqId (args' ++ args)
585                 where
586                    args' = [Type (idType bndr), Type ty, scrut, body]
587            
588         _other -> Left bad_shape_msg
589  where
590    opt_lhs = simpleOptExpr lhs
591
592    check_bndrs fn args
593      | null (dead_bndrs) = Right (extra_dict_bndrs ++ bndrs, fn, args)
594      | otherwise         = Left (vcat (map dead_msg dead_bndrs))
595      where
596        arg_fvs = exprsFreeVars args
597
598             -- Check for dead binders: Note [Unused spec binders]
599        dead_bndrs = filterOut (`elemVarSet` arg_fvs) bndrs
600
601             -- Add extra dict binders: Note [Constant rule dicts]
602        extra_dict_bndrs = [ mkLocalId (localiseName (idName d)) (idType d)
603                           | d <- varSetElems (arg_fvs `delVarSetList` bndrs)
604                           , isDictId d]
605
606
607    bad_shape_msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar"))
608                       2 (ppr opt_lhs)
609    dead_msg bndr = hang (ptext (sLit "Forall'd") <+> pp_bndr bndr
610                                  <+> ptext (sLit "is not bound in RULE lhs"))
611                       2 (ppr opt_lhs)
612    pp_bndr bndr
613     | isTyVar bndr = ptext (sLit "type variable") <+> ppr bndr
614     | isCoVar bndr = ptext (sLit "coercion variable") <+> ppr bndr
615     | isDictId bndr = ptext (sLit "constraint") <+> ppr (get_pred bndr)
616     | otherwise     = ptext (sLit "variable") <+> ppr bndr
617
618    get_pred b = ASSERT( isId b ) expectJust "decomposeRuleLhs" 
619                                  (tcSplitPredTy_maybe (idType b))
620 \end{code}
621
622 Note [Simplifying the left-hand side of a RULE]
623 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
624 simpleOptExpr occurrence-analyses and simplifies the lhs
625 and thereby
626 (a) sorts dict bindings into NonRecs and inlines them
627 (b) substitute trivial lets so that they don't get in the way
628     Note that we substitute the function too; we might 
629     have this as a LHS:  let f71 = M.f Int in f71
630 (c) does eta reduction
631
632 For (c) consider the fold/build rule, which without simplification
633 looked like:
634         fold k z (build (/\a. g a))  ==>  ...
635 This doesn't match unless you do eta reduction on the build argument.
636 Similarly for a LHS like
637         augment g (build h) 
638 we do not want to get
639         augment (\a. g a) (build h)
640 otherwise we don't match when given an argument like
641         augment (\a. h a a) (build h)
642
643 NB: tcSimplifyRuleLhs is very careful not to generate complicated
644     dictionary expressions that we might have to match
645
646
647 Note [Matching seqId]
648 ~~~~~~~~~~~~~~~~~~~
649 The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
650 and this code turns it back into an application of seq!  
651 See Note [Rules for seq] in MkId for the details.
652
653 Note [Unused spec binders]
654 ~~~~~~~~~~~~~~~~~~~~~~~~~~
655 Consider
656         f :: a -> a
657         {-# SPECIALISE f :: Eq a => a -> a #-}
658 It's true that this *is* a more specialised type, but the rule
659 we get is something like this:
660         f_spec d = f
661         RULE: f = f_spec d
662 Note that the rule is bogus, becuase it mentions a 'd' that is
663 not bound on the LHS!  But it's a silly specialisation anyway, becuase
664 the constraint is unused.  We could bind 'd' to (error "unused")
665 but it seems better to reject the program because it's almost certainly
666 a mistake.  That's what the isDeadBinder call detects.
667
668 Note [Constant rule dicts]
669 ~~~~~~~~~~~~~~~~~~~~~~~
670 When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict, 
671 which is presumably in scope at the function definition site, we can quantify 
672 over it too.  *Any* dict with that type will do.
673
674 So for example when you have
675         f :: Eq a => a -> a
676         f = <rhs>
677         {-# SPECIALISE f :: Int -> Int #-}
678
679 Then we get the SpecPrag
680         SpecPrag (f Int dInt) 
681
682 And from that we want the rule
683         
684         RULE forall dInt. f Int dInt = f_spec
685         f_spec = let f = <rhs> in f Int dInt
686
687 But be careful!  That dInt might be GHC.Base.$fOrdInt, which is an External
688 Name, and you can't bind them in a lambda or forall without getting things
689 confused.   Likewise it might have an InlineRule or something, which would be
690 utterly bogus. So we really make a fresh Id, with the same unique and type
691 as the old one, but with an Internal name and no IdInfo.
692
693
694 %************************************************************************
695 %*                                                                      *
696 \subsection[addAutoScc]{Adding automatic sccs}
697 %*                                                                      *
698 %************************************************************************
699
700 \begin{code}
701 data AutoScc = NoSccs 
702              | AddSccs Module (Id -> Bool)
703 -- The (Id->Bool) says which Ids to add SCCs to 
704 -- But we never add a SCC to function marked INLINE
705
706 addAutoScc :: AutoScc   
707            -> Id        -- Binder
708            -> CoreExpr  -- Rhs
709            -> CoreExpr  -- Scc'd Rhs
710
711 addAutoScc NoSccs _ rhs
712   = rhs
713 addAutoScc _ id rhs | isInlinePragma (idInlinePragma id)
714   = rhs
715 addAutoScc (AddSccs mod add_scc) id rhs
716   | add_scc id = mkSCC (mkAutoCC id mod NotCafCC) rhs
717   | otherwise  = rhs
718 \end{code}
719
720 If profiling and dealing with a dict binding,
721 wrap the dict in @_scc_ DICT <dict>@:
722
723 \begin{code}
724 addDictScc :: Id -> CoreExpr -> DsM CoreExpr
725 addDictScc _ rhs = return rhs
726
727 {- DISABLED for now (need to somehow make up a name for the scc) -- SDM
728   | not ( opt_SccProfilingOn && opt_AutoSccsOnDicts)
729     || not (isDictId var)
730   = return rhs                          -- That's easy: do nothing
731
732   | otherwise
733   = do (mod, grp) <- getModuleAndGroupDs
734         -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
735        return (Note (SCC (mkAllDictsCC mod grp False)) rhs)
736 -}
737 \end{code}
738
739
740 %************************************************************************
741 %*                                                                      *
742                 Desugaring coercions
743 %*                                                                      *
744 %************************************************************************
745
746
747 \begin{code}
748 dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
749 dsHsWrapper WpHole            = return (\e -> e)
750 dsHsWrapper (WpTyApp ty)      = return (\e -> App e (Type ty))
751 dsHsWrapper (WpLet ev_binds)  = do { ds_ev_binds <- dsTcEvBinds ev_binds
752                                    ; return (wrapDsEvBinds ds_ev_binds) }
753 dsHsWrapper (WpCompose c1 c2) = do { k1 <- dsHsWrapper c1 
754                                    ; k2 <- dsHsWrapper c2
755                                    ; return (k1 . k2) }
756 dsHsWrapper (WpCast co)       = return (\e -> Cast e co) 
757 dsHsWrapper (WpEvLam ev)      = return (\e -> Lam ev e) 
758 dsHsWrapper (WpTyLam tv)      = return (\e -> Lam tv e) 
759 dsHsWrapper (WpEvApp evtrm)   = do ev <- dsEvTerm evtrm
760                                    return (\e -> App e ev)
761 \end{code}