2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 Pattern-matching bindings (HsBinds and MonoBinds)
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).
13 module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs,
18 #include "HsVersions.h"
20 import {-# SOURCE #-} DsExpr( dsLExpr )
21 import {-# SOURCE #-} Match( matchWrapper )
27 import HsSyn -- lots of things
28 import CoreSyn -- lots of things
32 import CoreArity ( etaExpand )
37 import TysPrim ( anyTypeOfKind )
41 import Name ( localiseName )
43 import Var ( Var, TyVar, tyVarKind )
44 import IdInfo ( vanillaIdInfo )
52 import BasicTypes hiding ( TopLevel )
54 import StaticFlags ( opt_DsMultiTyVar )
55 import Util ( count, lengthExceeds )
61 %************************************************************************
63 \subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
65 %************************************************************************
68 dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
69 dsTopLHsBinds auto_scc binds = ds_lhs_binds auto_scc binds
71 dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
72 dsLHsBinds binds = ds_lhs_binds NoSccs binds
75 ------------------------
76 ds_lhs_binds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
78 -- scc annotation policy (see below)
79 ds_lhs_binds auto_scc binds = foldM (dsLHsBind auto_scc) [] (bagToList binds)
82 -> [(Id,CoreExpr)] -- Put this on the end (avoid quadratic append)
84 -> DsM [(Id,CoreExpr)] -- Result
85 dsLHsBind auto_scc rest (L loc bind)
86 = putSrcSpanDs loc $ dsHsBind auto_scc rest bind
89 -> [(Id,CoreExpr)] -- Put this on the end (avoid quadratic append)
91 -> DsM [(Id,CoreExpr)] -- Result
93 dsHsBind _ rest (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless })
94 = do { core_expr <- dsLExpr expr
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'
102 ; return ((var', core_expr') : 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) }
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) }
118 dsHsBind auto_scc rest (AbsBinds [] [] exports binds)
119 = do { core_prs <- ds_lhs_binds NoSccs binds
120 ; let env = mkABEnv exports
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) }
130 | otherwise = return [(lcl_id, rhs)]
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
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)
149 add_lets | core_prs `lengthExceeds` 10 = add_some
151 add_some lg_binds rhs = mkLets [ NonRec b r | NonRec b r <- lg_binds
152 , b `elemVarSet` fvs] rhs
154 fvs = exprSomeFreeVars (`elemVarSet` bndrs) rhs
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))
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 $
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) }
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))]) }
180 ; (_, core_prs') <- fixDs (\ ~(lg_binds, _) -> mapAndUnzipM (do_one lg_binds) core_prs)
181 ; return (concat core_prs' ++ rest) }
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
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)
198 ; (spec_binds, rules) <- dsSpecs global rhs prags
200 ; let global' = addIdSpecialisations global rules
201 main_bind = makeCorePair global' (isDefaultMethod prags)
202 (dictArity dicts) rhs
204 ; return (main_bind : spec_binds ++ rest) }
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)
213 -- Rec because of mixed-up dictionary bindings
214 core_bind = Rec (map do_one core_prs)
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
223 ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
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)
236 ; (spec_binds, rules) <- dsSpecs global
237 (Let (NonRec poly_tup_id poly_tup_rhs) rhs)
239 ; let global' = addIdSpecialisations global rules
240 ; return ((global', rhs) : spec_binds) }
243 | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
244 | otherwise = dsMkArbitraryType all_tyvar
246 ; export_binds_s <- mapM mk_bind (exports `zip` [0..])
247 -- Don't scc (auto-)annotate the tuple itself.
249 ; return ((poly_tup_id, poly_tup_rhs) :
250 (concat export_binds_s ++ rest)) }
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)
258 | not (isInlinePragma inline_prag)
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)
270 = (gbl_id `setIdUnfolding` mkInlineRule rhs Nothing, rhs)
272 inline_prag = idInlinePragma gbl_id
274 dictArity :: [Var] -> Arity
275 -- Don't count coercion variables in arity
276 dictArity dicts = count isId dicts
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
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]
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.
302 Instead we want to generate
305 Now all is cool. The RULES are attached to M.f (by SimplCore),
306 and f_lcl is rapidly inlined away.
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 -}
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:
322 class (Real a, Fractional a) => RealFrac a where
323 round :: (Integral b) => a -> b
325 instance RealFrac Float where
326 {-# SPECIALIZE round :: Float -> Int #-}
328 The top-level AbsBinds for $cround has no tyvars or dicts (because the
329 instance does not). But the method is locally overloaded!
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
336 AbsBinds [a,b] [ ([a,b], fg, fl, _),
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
348 where B is the *non-recursive* binding
351 h = h a b -- See (b); note shadowing!
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.
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.
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.
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
373 Note [Eta-expanding INLINE things]
374 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
376 foo :: Eq a => a -> a
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
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.
390 Note [Nested arities]
391 ~~~~~~~~~~~~~~~~~~~~~
392 For reasons that are not entirely clear, method bindings come out looking like
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 } } }
401 Note the nested AbsBind. The arity for the InlineRule on $cfromT should be
402 gotten from the binding for fromT_1.
404 It might be better to have just one level of AbsBinds, but that requires more
407 Note [Implementing SPECIALISE pragmas]
408 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
410 f :: (Eq a, Ix b) => a -> b -> Bool
411 {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-}
414 From this the typechecker generates
416 AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
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 ])
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
427 From these we generate:
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
432 Spec bind: f_spec = wrap_fn <poly_rhs>
436 * The LHS of the rule may mention dictionary *expressions* (eg
437 $dfIxPair dp dq), and that is essential because the dp, dq are
440 * The RHS of f_spec, <poly_rhs> has a *copy* of 'binds', so that it
441 can fully specialise it.
444 ------------------------
445 dsSpecs :: Id -- The polymorphic Id
446 -> CoreExpr -- Its rhs
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
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) }
458 spec_one :: Located TcSpecPrag -> DsM (Maybe ([(Id,CoreExpr)], CoreRule))
459 spec_one (L loc (SpecPrag spec_co spec_inl))
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 spec_ty = exprType ds_spec_expr
466 ; case decomposeRuleLhs ds_spec_expr of {
467 Nothing -> do { warnDs (decomp_msg spec_co)
470 Just (bndrs, _fn, args) ->
472 -- Check for dead binders: Note [Unused spec binders]
473 case filter isDeadBinder bndrs of {
474 bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing }
477 { (spec_unf, unf_pairs) <- specUnfolding wrap_fn spec_ty (realIdUnfolding poly_id)
479 ; let 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
487 extra_dict_bndrs = [ mkLocalId (localiseName (idName d)) (idType d)
488 -- See Note [Constant rule dicts]
489 | d <- varSetElems (exprFreeVars ds_spec_expr)
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)
497 spec_rhs = wrap_fn poly_rhs
498 spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs
500 ; return (Just (spec_pair : unf_pairs, rule))
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))
510 = hang (ptext (sLit "Specialisation too complicated to desugar; ignored"))
511 2 (pprHsWrapper (ppr poly_id) spec_co)
514 specUnfolding :: (CoreExpr -> CoreExpr) -> Type
515 -> Unfolding -> DsM (Unfolding, [(Id,CoreExpr)])
516 specUnfolding wrap_fn spec_ty (DFunUnfolding _ _ ops)
517 = do { let spec_rhss = map wrap_fn ops
518 ; spec_ids <- mapM (mkSysLocalM (fsLit "spec") . exprType) spec_rhss
519 ; return (mkDFunUnfolding spec_ty (map Var spec_ids), spec_ids `zip` spec_rhss) }
521 = return (noUnfolding, [])
523 mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> TyVarEnv Type
524 -- If any of the tyvars is missing from any of the lists in
525 -- the second arg, return a binding in the result
526 mkArbitraryTypeEnv tyvars exports
527 = go emptyVarEnv exports
530 go env ((ltvs, _, _, _) : exports)
533 env' = foldl extend env [tv | tv <- tyvars
534 , not (tv `elem` ltvs)
535 , not (tv `elemVarEnv` env)]
537 extend env tv = extendVarEnv env tv (dsMkArbitraryType tv)
539 dsMkArbitraryType :: TcTyVar -> Type
540 dsMkArbitraryType tv = anyTypeOfKind (tyVarKind tv)
543 Note [Unused spec binders]
544 ~~~~~~~~~~~~~~~~~~~~~~~~~~
547 {-# SPECIALISE f :: Eq a => a -> a #-}
548 It's true that this *is* a more specialised type, but the rule
549 we get is something like this:
552 Note that the rule is bogus, becuase it mentions a 'd' that is
553 not bound on the LHS! But it's a silly specialisation anyway, becuase
554 the constraint is unused. We could bind 'd' to (error "unused")
555 but it seems better to reject the program because it's almost certainly
556 a mistake. That's what the isDeadBinder call detects.
558 Note [Constant rule dicts]
559 ~~~~~~~~~~~~~~~~~~~~~~~
560 When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,
561 which is presumably in scope at the function definition site, we can quantify
562 over it too. *Any* dict with that type will do.
564 So for example when you have
567 {-# SPECIALISE f :: Int -> Int #-}
569 Then we get the SpecPrag
570 SpecPrag (f Int dInt)
572 And from that we want the rule
574 RULE forall dInt. f Int dInt = f_spec
575 f_spec = let f = <rhs> in f Int dInt
577 But be careful! That dInt might be GHC.Base.$fOrdInt, which is an External
578 Name, and you can't bind them in a lambda or forall without getting things
579 confused. Likewise it might have an InlineRule or something, which would be
580 utterly bogus. So we really make a fresh Id, with the same unique and type
581 as the old one, but with an Internal name and no IdInfo.
583 %************************************************************************
585 \subsection{Adding inline pragmas}
587 %************************************************************************
590 decomposeRuleLhs :: CoreExpr -> Maybe ([Var], Id, [CoreExpr])
591 -- Take apart the LHS of a RULE. It's suuposed to look like
592 -- /\a. f a Int dOrdInt
593 -- or /\a.\d:Ord a. let { dl::Ord [a] = dOrdList a d } in f [a] dl
594 -- That is, the RULE binders are lambda-bound
595 -- Returns Nothing if the LHS isn't of the expected shape
597 = case collectArgs body of
598 (Var fn, args) -> Just (bndrs, fn, args)
600 (Case scrut bndr ty [(DEFAULT, _, body)], args)
601 | isDeadBinder bndr -- Note [Matching seqId]
602 -> Just (bndrs, seqId, args' ++ args)
604 args' = [Type (idType bndr), Type ty, scrut, body]
606 _other -> Nothing -- Unexpected shape
608 (bndrs, body) = collectBinders (simpleOptExpr lhs)
609 -- simpleOptExpr occurrence-analyses and simplifies the lhs
611 -- (a) identifies unused binders: Note [Unused spec binders]
612 -- (b) sorts dict bindings into NonRecs
613 -- so they can be inlined by 'decomp'
614 -- (c) substitute trivial lets so that they don't get in the way
615 -- Note that we substitute the function too; we might
616 -- have this as a LHS: let f71 = M.f Int in f71
617 -- NB: tcSimplifyRuleLhs is very careful not to generate complicated
618 -- dictionary expressions that we might have to match
621 Note [Matching seqId]
623 The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
624 and this code turns it back into an application of seq!
625 See Note [Rules for seq] in MkId for the details.
628 %************************************************************************
630 \subsection[addAutoScc]{Adding automatic sccs}
632 %************************************************************************
635 data AutoScc = NoSccs
636 | AddSccs Module (Id -> Bool)
637 -- The (Id->Bool) says which Ids to add SCCs to
638 -- But we never add a SCC to function marked INLINE
640 addAutoScc :: AutoScc
643 -> CoreExpr -- Scc'd Rhs
645 addAutoScc NoSccs _ rhs
647 addAutoScc _ id rhs | isInlinePragma (idInlinePragma id)
649 addAutoScc (AddSccs mod add_scc) id rhs
650 | add_scc id = mkSCC (mkAutoCC id mod NotCafCC) rhs
654 If profiling and dealing with a dict binding,
655 wrap the dict in @_scc_ DICT <dict>@:
658 addDictScc :: Id -> CoreExpr -> DsM CoreExpr
659 addDictScc _ rhs = return rhs
661 {- DISABLED for now (need to somehow make up a name for the scc) -- SDM
662 | not ( opt_SccProfilingOn && opt_AutoSccsOnDicts)
663 || not (isDictId var)
664 = return rhs -- That's easy: do nothing
667 = do (mod, grp) <- getModuleAndGroupDs
668 -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
669 return (Note (SCC (mkAllDictsCC mod grp False)) rhs)
674 %************************************************************************
678 %************************************************************************
682 dsCoercion :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
683 dsCoercion WpHole = return (\e -> e)
684 dsCoercion (WpCompose c1 c2) = do { k1 <- dsCoercion c1
685 ; k2 <- dsCoercion c2
687 dsCoercion (WpCast co) = return (\e -> Cast e co)
688 dsCoercion (WpLam id) = return (\e -> Lam id e)
689 dsCoercion (WpTyLam tv) = return (\e -> Lam tv e)
690 dsCoercion (WpApp v) | isTyVar v -- Probably a coercion var
691 = return (\e -> App e (Type (mkTyVarTy v)))
693 = return (\e -> App e (Var v))
694 dsCoercion (WpTyApp ty) = return (\e -> App e (Type ty))
695 dsCoercion (WpLet bs) = do { prs <- dsLHsBinds bs
696 ; return (\e -> Let (Rec prs) e) }