bfe43235116bf5a244a9669a7dbdc64b6a774f19
[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                  dsCoercion,
15                  AutoScc(..)
16   ) where
17
18 #include "HsVersions.h"
19
20 import {-# SOURCE #-}   DsExpr( dsLExpr )
21 import {-# SOURCE #-}   Match( matchWrapper )
22
23 import DsMonad
24 import DsGRHSs
25 import DsUtils
26
27 import HsSyn            -- lots of things
28 import CoreSyn          -- lots of things
29 import CoreSubst
30 import MkCore
31 import CoreUtils
32 import CoreArity ( etaExpand )
33 import CoreUnfold
34 import CoreFVs
35
36 import TcType
37 import TysPrim  ( anyTypeOfKind )
38 import CostCentre
39 import Module
40 import Id
41 import Name     ( localiseName )
42 import MkId     ( seqId )
43 import Var      ( Var, TyVar, tyVarKind )
44 import IdInfo   ( vanillaIdInfo )
45 import VarSet
46 import Rules
47 import VarEnv
48 import Outputable
49 import SrcLoc
50 import Maybes
51 import Bag
52 import BasicTypes hiding ( TopLevel )
53 import FastString
54 import StaticFlags      ( opt_DsMultiTyVar )
55 import Util             ( count, lengthExceeds )
56
57 import MonadUtils
58 import Control.Monad
59 \end{code}
60
61 %************************************************************************
62 %*                                                                      *
63 \subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
64 %*                                                                      *
65 %************************************************************************
66
67 \begin{code}
68 dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
69 dsTopLHsBinds auto_scc binds = ds_lhs_binds auto_scc binds
70
71 dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
72 dsLHsBinds binds = ds_lhs_binds NoSccs binds
73
74
75 ------------------------
76 ds_lhs_binds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
77
78          -- scc annotation policy (see below)
79 ds_lhs_binds auto_scc binds =  foldM (dsLHsBind auto_scc) [] (bagToList binds)
80
81 dsLHsBind :: AutoScc
82          -> [(Id,CoreExpr)]     -- Put this on the end (avoid quadratic append)
83          -> LHsBind Id
84          -> DsM [(Id,CoreExpr)] -- Result
85 dsLHsBind auto_scc rest (L loc bind)
86   = putSrcSpanDs loc $ dsHsBind auto_scc rest bind
87
88 dsHsBind :: AutoScc
89          -> [(Id,CoreExpr)]     -- Put this on the end (avoid quadratic append)
90          -> HsBind Id
91          -> DsM [(Id,CoreExpr)] -- Result
92
93 dsHsBind _ rest (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 ((var', core_expr') : rest) }
103
104 dsHsBind _ rest 
105          (FunBind { fun_id = L _ fun, fun_matches = matches, 
106                     fun_co_fn = co_fn, fun_tick = tick, fun_infix = inf }) 
107  = do   { (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches
108         ; body'    <- mkOptTickBox tick body
109         ; wrap_fn' <- dsCoercion co_fn 
110         ; return ((fun, wrap_fn' (mkLams args body')) : rest) }
111
112 dsHsBind _ rest 
113          (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         ; return (sel_binds ++ rest) }
117
118 dsHsBind auto_scc rest (AbsBinds [] [] exports binds)
119   = do  { core_prs <- ds_lhs_binds NoSccs binds
120         ; let env = mkABEnv exports
121               do_one (lcl_id, rhs) 
122                 | Just (_, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id
123                 = do { let rhs' = addAutoScc auto_scc gbl_id rhs
124                      ; (spec_binds, rules) <- dsSpecs gbl_id (Let (Rec core_prs) rhs') spec_prags
125                                     -- See Note [Specialising in no-dict case]
126                      ; let   gbl_id'   = addIdSpecialisations gbl_id rules
127                              main_bind = makeCorePair gbl_id' False 0 rhs'
128                      ; return (main_bind : spec_binds) }
129
130                 | otherwise = return [(lcl_id, rhs)]
131
132               locals'  = [(lcl_id, Var gbl_id) | (_, gbl_id, lcl_id, _) <- exports]
133                         -- Note [Rules and inlining]
134         ; export_binds <- mapM do_one core_prs
135         ; return (concat export_binds ++ locals' ++ rest) }
136                 -- No Rec needed here (contrast the other AbsBinds cases)
137                 -- because we can rely on the enclosing dsBind to wrap in Rec
138
139
140 dsHsBind auto_scc rest (AbsBinds tyvars [] exports binds)
141   | opt_DsMultiTyVar    -- This (static) debug flag just lets us
142                         -- switch on and off this optimisation to
143                         -- see if it has any impact; it is on by default
144   =     -- Note [Abstracting over tyvars only]
145     do  { core_prs <- ds_lhs_binds NoSccs binds
146         ; let arby_env = mkArbitraryTypeEnv tyvars exports
147               bndrs = mkVarSet (map fst core_prs)
148
149               add_lets | core_prs `lengthExceeds` 10 = add_some
150                        | otherwise                   = mkLets
151               add_some lg_binds rhs = mkLets [ NonRec b r | NonRec b r <- lg_binds
152                                                           , b `elemVarSet` fvs] rhs
153                 where
154                   fvs = exprSomeFreeVars (`elemVarSet` bndrs) rhs
155
156               env = mkABEnv exports
157               mk_lg_bind lcl_id gbl_id tyvars
158                  = NonRec (setIdInfo lcl_id vanillaIdInfo)
159                                 -- Nuke the IdInfo so that no old unfoldings
160                                 -- confuse use (it might mention something not
161                                 -- even in scope at the new site
162                           (mkTyApps (Var gbl_id) (mkTyVarTys tyvars))
163
164               do_one lg_binds (lcl_id, rhs) 
165                 | Just (id_tvs, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id
166                 = do { let rhs' = addAutoScc auto_scc gbl_id  $
167                                   mkLams id_tvs $
168                                   mkLets [ NonRec tv (Type (lookupVarEnv_NF arby_env tv))
169                                          | tv <- tyvars, not (tv `elem` id_tvs)] $
170                                   add_lets lg_binds rhs
171                      ; (spec_binds, rules) <- dsSpecs gbl_id rhs' spec_prags
172                      ; let   gbl_id'   = addIdSpecialisations gbl_id rules
173                              main_bind = makeCorePair gbl_id' False 0 rhs'
174                      ; return (mk_lg_bind lcl_id gbl_id' id_tvs, main_bind : spec_binds) }
175                 | otherwise
176                 = do { non_exp_gbl_id <- newUniqueId lcl_id (mkForAllTys tyvars (idType lcl_id))
177                      ; return (mk_lg_bind lcl_id non_exp_gbl_id tyvars,
178                                [(non_exp_gbl_id, mkLams tyvars (add_lets lg_binds rhs))]) }
179                                                   
180         ; (_, core_prs') <- fixDs (\ ~(lg_binds, _) -> mapAndUnzipM (do_one lg_binds) core_prs)
181         ; return (concat core_prs' ++ rest) }
182
183         -- Another common case: one exported variable
184         -- Non-recursive bindings come through this way
185         -- So do self-recursive bindings, and recursive bindings
186         -- that have been chopped up with type signatures
187 dsHsBind auto_scc rest
188      (AbsBinds all_tyvars dicts [(tyvars, global, local, prags)] binds)
189   = ASSERT( all (`elem` tyvars) all_tyvars )
190     do  { core_prs <- ds_lhs_binds NoSccs binds
191
192         ; let   -- Always treat the binds as recursive, because the 
193                 -- typechecker makes rather mixed-up dictionary bindings
194                 core_bind = Rec core_prs
195                 rhs       = addAutoScc auto_scc global $
196                             mkLams tyvars $ mkLams dicts $ Let core_bind (Var local)
197     
198         ; (spec_binds, rules) <- dsSpecs global rhs prags
199
200         ; let   global'   = addIdSpecialisations global rules
201                 main_bind = makeCorePair global' (isDefaultMethod prags)
202                                          (dictArity dicts) rhs 
203     
204         ; return (main_bind : spec_binds ++ rest) }
205
206 dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
207   = do  { core_prs <- ds_lhs_binds NoSccs binds
208         ; let env = mkABEnv exports
209               do_one (lcl_id,rhs) | Just (_, gbl_id, _, _prags) <- lookupVarEnv env lcl_id
210                                   = (lcl_id, addAutoScc auto_scc gbl_id rhs)
211                                   | otherwise = (lcl_id,rhs)
212                
213                 -- Rec because of mixed-up dictionary bindings
214               core_bind = Rec (map do_one core_prs)
215
216               tup_expr     = mkBigCoreVarTup locals
217               tup_ty       = exprType tup_expr
218               poly_tup_rhs = mkLams all_tyvars $ mkLams dicts $
219                              Let core_bind tup_expr
220               locals       = [local | (_, _, local, _) <- exports]
221               local_tys    = map idType locals
222
223         ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
224
225         ; let mk_bind ((tyvars, global, _, spec_prags), n)  -- locals!!n == local
226                 =       -- Need to make fresh locals to bind in the selector,
227                         -- because some of the tyvars will be bound to 'Any'
228                   do { let ty_args = map mk_ty_arg all_tyvars
229                            substitute = substTyWith all_tyvars ty_args
230                      ; locals' <- newSysLocalsDs (map substitute local_tys)
231                      ; tup_id  <- newSysLocalDs  (substitute tup_ty)
232                      ; let rhs = mkLams tyvars $ mkLams dicts $
233                                  mkTupleSelector locals' (locals' !! n) tup_id $
234                                  mkVarApps (mkTyApps (Var poly_tup_id) ty_args)
235                                            dicts
236                      ; (spec_binds, rules) <- dsSpecs global
237                                                       (Let (NonRec poly_tup_id poly_tup_rhs) rhs)
238                                                       spec_prags
239                      ; let global' = addIdSpecialisations global rules
240                      ; return ((global', rhs) : spec_binds) }
241                 where
242                   mk_ty_arg all_tyvar
243                         | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
244                         | otherwise               = dsMkArbitraryType all_tyvar
245
246         ; export_binds_s <- mapM mk_bind (exports `zip` [0..])
247              -- Don't scc (auto-)annotate the tuple itself.
248
249         ; return ((poly_tup_id, poly_tup_rhs) : 
250                     (concat export_binds_s ++ rest)) }
251
252 ------------------------
253 makeCorePair :: Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr)
254 makeCorePair gbl_id is_default_method dict_arity rhs
255   | is_default_method                 -- Default methods are *always* inlined
256   = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs)
257
258   | not (isInlinePragma inline_prag)
259   = (gbl_id, rhs)
260
261   | Just arity <- inlinePragmaSat inline_prag
262         -- Add an Unfolding for an INLINE (but not for NOINLINE)
263         -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
264   , let real_arity = dict_arity + arity
265         -- NB: The arity in the InlineRule takes account of the dictionaries
266   = (gbl_id `setIdUnfolding` mkInlineRule rhs (Just real_arity),
267      etaExpand real_arity rhs)
268
269   | otherwise
270   = (gbl_id `setIdUnfolding` mkInlineRule rhs Nothing, rhs)
271   where
272     inline_prag = idInlinePragma gbl_id
273
274 dictArity :: [Var] -> Arity
275 -- Don't count coercion variables in arity
276 dictArity dicts = count isId dicts
277
278
279 ------------------------
280 type AbsBindEnv = VarEnv ([TyVar], Id, Id, TcSpecPrags)
281         -- Maps the "lcl_id" for an AbsBind to
282         -- its "gbl_id" and associated pragmas, if any
283
284 mkABEnv :: [([TyVar], Id, Id, TcSpecPrags)] -> AbsBindEnv
285 -- Takes the exports of a AbsBinds, and returns a mapping
286 --      lcl_id -> (tyvars, gbl_id, lcl_id, prags)
287 mkABEnv exports = mkVarEnv [ (lcl_id, export) | export@(_, _, lcl_id, _) <- exports]
288 \end{code}
289
290 Note [Rules and inlining]
291 ~~~~~~~~~~~~~~~~~~~~~~~~~
292 Common special case: no type or dictionary abstraction
293 This is a bit less trivial than you might suppose
294 The naive way woudl be to desguar to something like
295         f_lcl = ...f_lcl...     -- The "binds" from AbsBinds
296         M.f = f_lcl             -- Generated from "exports"
297 But we don't want that, because if M.f isn't exported,
298 it'll be inlined unconditionally at every call site (its rhs is 
299 trivial).  That would be ok unless it has RULES, which would 
300 thereby be completely lost.  Bad, bad, bad.
301
302 Instead we want to generate
303         M.f = ...f_lcl...
304         f_lcl = M.f
305 Now all is cool. The RULES are attached to M.f (by SimplCore), 
306 and f_lcl is rapidly inlined away.
307
308 This does not happen in the same way to polymorphic binds,
309 because they desugar to
310         M.f = /\a. let f_lcl = ...f_lcl... in f_lcl
311 Although I'm a bit worried about whether full laziness might
312 float the f_lcl binding out and then inline M.f at its call site -}
313
314 Note [Specialising in no-dict case]
315 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
316 Even if there are no tyvars or dicts, we may have specialisation pragmas.
317 Class methods can generate
318       AbsBinds [] [] [( ... spec-prag]
319          { AbsBinds [tvs] [dicts] ...blah }
320 So the overloading is in the nested AbsBinds. A good example is in GHC.Float:
321
322   class  (Real a, Fractional a) => RealFrac a  where
323     round :: (Integral b) => a -> b
324
325   instance  RealFrac Float  where
326     {-# SPECIALIZE round :: Float -> Int #-}
327
328 The top-level AbsBinds for $cround has no tyvars or dicts (because the 
329 instance does not).  But the method is locally overloaded!
330
331 Note [Abstracting over tyvars only]
332 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
333 When abstracting over type variable only (not dictionaries), we don't really need to
334 built a tuple and select from it, as we do in the general case. Instead we can take
335
336         AbsBinds [a,b] [ ([a,b], fg, fl, _),
337                          ([b],   gg, gl, _) ]
338                 { fl = e1
339                   gl = e2
340                    h = e3 }
341
342 and desugar it to
343
344         fg = /\ab. let B in e1
345         gg = /\b. let a = () in let B in S(e2)
346         h  = /\ab. let B in e3
347
348 where B is the *non-recursive* binding
349         fl = fg a b
350         gl = gg b
351         h  = h a b    -- See (b); note shadowing!
352
353 Notice (a) g has a different number of type variables to f, so we must
354              use the mkArbitraryType thing to fill in the gaps.  
355              We use a type-let to do that.
356
357          (b) The local variable h isn't in the exports, and rather than
358              clone a fresh copy we simply replace h by (h a b), where
359              the two h's have different types!  Shadowing happens here,
360              which looks confusing but works fine.
361
362          (c) The result is *still* quadratic-sized if there are a lot of
363              small bindings.  So if there are more than some small
364              number (10), we filter the binding set B by the free
365              variables of the particular RHS.  Tiresome.
366
367 Why got to this trouble?  It's a common case, and it removes the
368 quadratic-sized tuple desugaring.  Less clutter, hopefullly faster
369 compilation, especially in a case where there are a *lot* of
370 bindings.
371
372
373 Note [Eta-expanding INLINE things]
374 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
375 Consider
376    foo :: Eq a => a -> a
377    {-# INLINE foo #-}
378    foo x = ...
379
380 If (foo d) ever gets floated out as a common sub-expression (which can
381 happen as a result of method sharing), there's a danger that we never 
382 get to do the inlining, which is a Terribly Bad thing given that the
383 user said "inline"!
384
385 To avoid this we pre-emptively eta-expand the definition, so that foo
386 has the arity with which it is declared in the source code.  In this
387 example it has arity 2 (one for the Eq and one for x). Doing this 
388 should mean that (foo d) is a PAP and we don't share it.
389
390 Note [Nested arities]
391 ~~~~~~~~~~~~~~~~~~~~~
392 For reasons that are not entirely clear, method bindings come out looking like
393 this:
394
395   AbsBinds [] [] [$cfromT <= [] fromT]
396     $cfromT [InlPrag=INLINE] :: T Bool -> Bool
397     { AbsBinds [] [] [fromT <= [] fromT_1]
398         fromT :: T Bool -> Bool
399         { fromT_1 ((TBool b)) = not b } } }
400
401 Note the nested AbsBind.  The arity for the InlineRule on $cfromT should be
402 gotten from the binding for fromT_1.
403
404 It might be better to have just one level of AbsBinds, but that requires more
405 thought!
406
407 Note [Implementing SPECIALISE pragmas]
408 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
409 Example:
410         f :: (Eq a, Ix b) => a -> b -> Bool
411         {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-}
412         f = <poly_rhs>
413
414 From this the typechecker generates
415
416     AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
417
418     SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX
419                       -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ])
420
421 Note that wrap_fn can transform *any* function with the right type prefix 
422     forall ab. (Eq a, Ix b) => XXX
423 regardless of XXX.  It's sort of polymorphic in XXX.  This is
424 useful: we use the same wrapper to transform each of the class ops, as
425 well as the dict.
426
427 From these we generate:
428
429     Rule:       forall p, q, (dp:Ix p), (dq:Ix q). 
430                     f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq
431
432     Spec bind:  f_spec = wrap_fn <poly_rhs>
433
434 Note that 
435
436   * The LHS of the rule may mention dictionary *expressions* (eg
437     $dfIxPair dp dq), and that is essential because the dp, dq are
438     needed on the RHS.
439
440   * The RHS of f_spec, <poly_rhs> has a *copy* of 'binds', so that it 
441     can fully specialise it.
442
443 \begin{code}
444 ------------------------
445 dsSpecs :: Id           -- The polymorphic Id
446         -> CoreExpr     -- Its rhs
447         -> TcSpecPrags
448         -> DsM ( [(Id,CoreExpr)]        -- Binding for specialised Ids
449                , [CoreRule] )           -- Rules for the Global Ids
450 -- See Note [Implementing SPECIALISE pragmas]
451 dsSpecs poly_id poly_rhs prags
452   = case prags of
453       IsDefaultMethod      -> return ([], [])
454       SpecPrags sps -> do { pairs <- mapMaybeM spec_one sps
455                           ; let (spec_binds_s, rules) = unzip pairs
456                           ; return (concat spec_binds_s, rules) }
457  where 
458     spec_one :: Located TcSpecPrag -> DsM (Maybe ([(Id,CoreExpr)], CoreRule))
459     spec_one (L loc (SpecPrag spec_co spec_inl))
460       = putSrcSpanDs loc $ 
461         do { let poly_name = idName poly_id
462            ; spec_name <- newLocalName poly_name
463            ; wrap_fn   <- dsCoercion spec_co
464            ; let ds_spec_expr = wrap_fn (Var poly_id)
465            ; case decomposeRuleLhs ds_spec_expr of {
466                Nothing -> do { warnDs (decomp_msg spec_co)
467                              ; return Nothing } ;
468
469                Just (bndrs, _fn, args) ->
470
471            -- Check for dead binders: Note [Unused spec binders]
472              case filter isDeadBinder bndrs of {
473                 bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing } 
474                    | otherwise -> do
475
476            { (spec_unf, unf_pairs) <- specUnfolding wrap_fn (realIdUnfolding poly_id)
477
478            ; let spec_ty = exprType ds_spec_expr
479                  spec_id  = mkLocalId spec_name spec_ty 
480                             `setInlinePragma` inl_prag
481                             `setIdUnfolding`  spec_unf
482                  inl_prag | isDefaultInlinePragma spec_inl = idInlinePragma poly_id
483                           | otherwise                      = spec_inl
484                       -- Get the INLINE pragma from SPECIALISE declaration, or,
485                       -- failing that, from the original Id
486
487                  extra_dict_bndrs = [ mkLocalId (localiseName (idName d)) (idType d)
488                                             -- See Note [Constant rule dicts]
489                                     | d <- varSetElems (exprFreeVars ds_spec_expr)
490                                     , isDictId d]
491
492                  rule =  mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
493                                 AlwaysActive poly_name
494                                 (extra_dict_bndrs ++ bndrs) args
495                                 (mkVarApps (Var spec_id) bndrs)
496
497                  spec_rhs  = wrap_fn poly_rhs
498                  spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs
499
500             ; return (Just (spec_pair : unf_pairs, rule))
501             } } } }
502
503     dead_msg bs = vcat [ sep [ptext (sLit "Useless constraint") <> plural bs
504                                  <+> ptext (sLit "in specialied type:"),
505                              nest 2 (pprTheta (map get_pred bs))]
506                        , ptext (sLit "SPECIALISE pragma ignored")]
507     get_pred b = ASSERT( isId b ) expectJust "dsSpec" (tcSplitPredTy_maybe (idType b))
508
509     decomp_msg spec_co 
510         = hang (ptext (sLit "Specialisation too complicated to desugar; ignored"))
511              2 (pprHsWrapper (ppr poly_id) spec_co)
512              
513
514 specUnfolding :: (CoreExpr -> CoreExpr) -> Unfolding -> DsM (Unfolding, [(Id,CoreExpr)])
515 specUnfolding wrap_fn (DFunUnfolding con ops)
516   = do { let spec_rhss = map wrap_fn ops
517        ; spec_ids <- mapM (mkSysLocalM (fsLit "spec") . exprType) spec_rhss
518        ; return (DFunUnfolding con (map Var spec_ids), spec_ids `zip` spec_rhss) }
519 specUnfolding _ _
520   = return (noUnfolding, [])
521
522 mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> TyVarEnv Type
523 -- If any of the tyvars is missing from any of the lists in 
524 -- the second arg, return a binding in the result
525 mkArbitraryTypeEnv tyvars exports
526   = go emptyVarEnv exports
527   where
528     go env [] = env
529     go env ((ltvs, _, _, _) : exports)
530         = go env' exports
531         where
532           env' = foldl extend env [tv | tv <- tyvars
533                                       , not (tv `elem` ltvs)
534                                       , not (tv `elemVarEnv` env)]
535
536     extend env tv = extendVarEnv env tv (dsMkArbitraryType tv)
537
538 dsMkArbitraryType :: TcTyVar -> Type
539 dsMkArbitraryType tv = anyTypeOfKind (tyVarKind tv)
540 \end{code}
541
542 Note [Unused spec binders]
543 ~~~~~~~~~~~~~~~~~~~~~~~~~~
544 Consider
545         f :: a -> a
546         {-# SPECIALISE f :: Eq a => a -> a #-}
547 It's true that this *is* a more specialised type, but the rule
548 we get is something like this:
549         f_spec d = f
550         RULE: f = f_spec d
551 Note that the rule is bogus, becuase it mentions a 'd' that is
552 not bound on the LHS!  But it's a silly specialisation anyway, becuase
553 the constraint is unused.  We could bind 'd' to (error "unused")
554 but it seems better to reject the program because it's almost certainly
555 a mistake.  That's what the isDeadBinder call detects.
556
557 Note [Constant rule dicts]
558 ~~~~~~~~~~~~~~~~~~~~~~~
559 When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict, 
560 which is presumably in scope at the function definition site, we can quantify 
561 over it too.  *Any* dict with that type will do.
562
563 So for example when you have
564         f :: Eq a => a -> a
565         f = <rhs>
566         {-# SPECIALISE f :: Int -> Int #-}
567
568 Then we get the SpecPrag
569         SpecPrag (f Int dInt) 
570
571 And from that we want the rule
572         
573         RULE forall dInt. f Int dInt = f_spec
574         f_spec = let f = <rhs> in f Int dInt
575
576 But be careful!  That dInt might be GHC.Base.$fOrdInt, which is an External
577 Name, and you can't bind them in a lambda or forall without getting things
578 confused.   Likewise it might have an InlineRule or something, which would be
579 utterly bogus. So we really make a fresh Id, with the same unique and type
580 as the old one, but with an Internal name and no IdInfo.
581
582 %************************************************************************
583 %*                                                                      *
584 \subsection{Adding inline pragmas}
585 %*                                                                      *
586 %************************************************************************
587
588 \begin{code}
589 decomposeRuleLhs :: CoreExpr -> Maybe ([Var], Id, [CoreExpr])
590 -- Take apart the LHS of a RULE.  It's suuposed to look like
591 --     /\a. f a Int dOrdInt
592 -- or  /\a.\d:Ord a. let { dl::Ord [a] = dOrdList a d } in f [a] dl
593 -- That is, the RULE binders are lambda-bound
594 -- Returns Nothing if the LHS isn't of the expected shape
595 decomposeRuleLhs lhs 
596   = case collectArgs body of
597         (Var fn, args) -> Just (bndrs, fn, args)
598
599         (Case scrut bndr ty [(DEFAULT, _, body)], args)
600                 | isDeadBinder bndr     -- Note [Matching seqId]
601                 -> Just (bndrs, seqId, args' ++ args)
602                 where
603                    args' = [Type (idType bndr), Type ty, scrut, body]
604            
605         _other -> Nothing       -- Unexpected shape
606   where
607     (bndrs, body) = collectBinders (simpleOptExpr lhs)
608         -- simpleOptExpr occurrence-analyses and simplifies the lhs
609         -- and thereby
610         -- (a) identifies unused binders: Note [Unused spec binders]
611         -- (b) sorts dict bindings into NonRecs 
612         --      so they can be inlined by 'decomp'
613         -- (c) substitute trivial lets so that they don't get in the way
614         --     Note that we substitute the function too; we might 
615         --     have this as a LHS:  let f71 = M.f Int in f71
616         -- NB: tcSimplifyRuleLhs is very careful not to generate complicated
617         --     dictionary expressions that we might have to match
618 \end{code}
619
620 Note [Matching seqId]
621 ~~~~~~~~~~~~~~~~~~~
622 The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
623 and this code turns it back into an application of seq!  
624 See Note [Rules for seq] in MkId for the details.
625
626
627 %************************************************************************
628 %*                                                                      *
629 \subsection[addAutoScc]{Adding automatic sccs}
630 %*                                                                      *
631 %************************************************************************
632
633 \begin{code}
634 data AutoScc = NoSccs 
635              | AddSccs Module (Id -> Bool)
636 -- The (Id->Bool) says which Ids to add SCCs to 
637 -- But we never add a SCC to function marked INLINE
638
639 addAutoScc :: AutoScc   
640            -> Id        -- Binder
641            -> CoreExpr  -- Rhs
642            -> CoreExpr  -- Scc'd Rhs
643
644 addAutoScc NoSccs _ rhs
645   = rhs
646 addAutoScc _ id rhs | isInlinePragma (idInlinePragma id)
647   = rhs
648 addAutoScc (AddSccs mod add_scc) id rhs
649   | add_scc id = mkSCC (mkAutoCC id mod NotCafCC) rhs
650   | otherwise  = rhs
651 \end{code}
652
653 If profiling and dealing with a dict binding,
654 wrap the dict in @_scc_ DICT <dict>@:
655
656 \begin{code}
657 addDictScc :: Id -> CoreExpr -> DsM CoreExpr
658 addDictScc _ rhs = return rhs
659
660 {- DISABLED for now (need to somehow make up a name for the scc) -- SDM
661   | not ( opt_SccProfilingOn && opt_AutoSccsOnDicts)
662     || not (isDictId var)
663   = return rhs                          -- That's easy: do nothing
664
665   | otherwise
666   = do (mod, grp) <- getModuleAndGroupDs
667         -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
668        return (Note (SCC (mkAllDictsCC mod grp False)) rhs)
669 -}
670 \end{code}
671
672
673 %************************************************************************
674 %*                                                                      *
675                 Desugaring coercions
676 %*                                                                      *
677 %************************************************************************
678
679
680 \begin{code}
681 dsCoercion :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
682 dsCoercion WpHole            = return (\e -> e)
683 dsCoercion (WpCompose c1 c2) = do { k1 <- dsCoercion c1 
684                                   ; k2 <- dsCoercion c2
685                                   ; return (k1 . k2) }
686 dsCoercion (WpCast co)       = return (\e -> Cast e co) 
687 dsCoercion (WpLam id)        = return (\e -> Lam id e) 
688 dsCoercion (WpTyLam tv)      = return (\e -> Lam tv e) 
689 dsCoercion (WpApp v)         | isTyVar v   -- Probably a coercion var
690                              = return (\e -> App e (Type (mkTyVarTy v)))
691                              | otherwise
692                              = return (\e -> App e (Var v))
693 dsCoercion (WpTyApp ty)      = return (\e -> App e (Type ty))
694 dsCoercion (WpLet bs)        = do { prs <- dsLHsBinds bs
695                                   ; return (\e -> Let (Rec prs) e) }
696 \end{code}