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