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 )
42 import Var ( Var, TyVar, tyVarKind )
43 import IdInfo ( vanillaIdInfo )
51 import BasicTypes hiding ( TopLevel )
53 import StaticFlags ( opt_DsMultiTyVar )
54 import Util ( count, lengthExceeds )
60 %************************************************************************
62 \subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
64 %************************************************************************
67 dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
68 dsTopLHsBinds auto_scc binds = ds_lhs_binds auto_scc binds
70 dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
71 dsLHsBinds binds = ds_lhs_binds NoSccs binds
74 ------------------------
75 ds_lhs_binds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
77 -- scc annotation policy (see below)
78 ds_lhs_binds auto_scc binds = foldM (dsLHsBind auto_scc) [] (bagToList binds)
81 -> [(Id,CoreExpr)] -- Put this on the end (avoid quadratic append)
83 -> DsM [(Id,CoreExpr)] -- Result
84 dsLHsBind auto_scc rest (L loc bind)
85 = putSrcSpanDs loc $ dsHsBind auto_scc rest bind
88 -> [(Id,CoreExpr)] -- Put this on the end (avoid quadratic append)
90 -> DsM [(Id,CoreExpr)] -- Result
92 dsHsBind _ rest (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless })
93 = do { core_expr <- dsLExpr expr
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'
101 ; return ((var', core_expr') : 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) }
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) }
117 dsHsBind auto_scc rest (AbsBinds [] [] exports binds)
118 = do { core_prs <- ds_lhs_binds NoSccs binds
119 ; let env = mkABEnv exports
121 | Just (_, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id
122 = do { let rhs' = addAutoScc auto_scc gbl_id rhs
123 ; (spec_binds, rules) <- dsSpecs gbl_id (Let (Rec core_prs) rhs') spec_prags
124 -- See Note [Specialising in no-dict case]
125 ; let gbl_id' = addIdSpecialisations gbl_id rules
126 main_bind = makeCorePair gbl_id' False 0 rhs'
127 ; return (main_bind : spec_binds) }
129 | otherwise = return [(lcl_id, rhs)]
131 locals' = [(lcl_id, Var gbl_id) | (_, gbl_id, lcl_id, _) <- exports]
132 -- Note [Rules and inlining]
133 ; export_binds <- mapM do_one core_prs
134 ; return (concat export_binds ++ locals' ++ rest) }
135 -- No Rec needed here (contrast the other AbsBinds cases)
136 -- because we can rely on the enclosing dsBind to wrap in Rec
139 dsHsBind auto_scc rest (AbsBinds tyvars [] exports binds)
140 | opt_DsMultiTyVar -- This (static) debug flag just lets us
141 -- switch on and off this optimisation to
142 -- see if it has any impact; it is on by default
143 = -- Note [Abstracting over tyvars only]
144 do { core_prs <- ds_lhs_binds NoSccs binds
145 ; let arby_env = mkArbitraryTypeEnv tyvars exports
146 bndrs = mkVarSet (map fst core_prs)
148 add_lets | core_prs `lengthExceeds` 10 = add_some
150 add_some lg_binds rhs = mkLets [ NonRec b r | NonRec b r <- lg_binds
151 , b `elemVarSet` fvs] rhs
153 fvs = exprSomeFreeVars (`elemVarSet` bndrs) rhs
155 env = mkABEnv exports
156 mk_lg_bind lcl_id gbl_id tyvars
157 = NonRec (setIdInfo lcl_id vanillaIdInfo)
158 -- Nuke the IdInfo so that no old unfoldings
159 -- confuse use (it might mention something not
160 -- even in scope at the new site
161 (mkTyApps (Var gbl_id) (mkTyVarTys tyvars))
163 do_one lg_binds (lcl_id, rhs)
164 | Just (id_tvs, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id
165 = do { let rhs' = addAutoScc auto_scc gbl_id $
167 mkLets [ NonRec tv (Type (lookupVarEnv_NF arby_env tv))
168 | tv <- tyvars, not (tv `elem` id_tvs)] $
169 add_lets lg_binds rhs
170 ; (spec_binds, rules) <- dsSpecs gbl_id rhs' spec_prags
171 ; let gbl_id' = addIdSpecialisations gbl_id rules
172 main_bind = makeCorePair gbl_id' False 0 rhs'
173 ; return (mk_lg_bind lcl_id gbl_id' id_tvs, main_bind : spec_binds) }
175 = do { non_exp_gbl_id <- newUniqueId lcl_id (mkForAllTys tyvars (idType lcl_id))
176 ; return (mk_lg_bind lcl_id non_exp_gbl_id tyvars,
177 [(non_exp_gbl_id, mkLams tyvars (add_lets lg_binds rhs))]) }
179 ; (_, core_prs') <- fixDs (\ ~(lg_binds, _) -> mapAndUnzipM (do_one lg_binds) core_prs)
180 ; return (concat core_prs' ++ rest) }
182 -- Another common case: one exported variable
183 -- Non-recursive bindings come through this way
184 -- So do self-recursive bindings, and recursive bindings
185 -- that have been chopped up with type signatures
186 dsHsBind auto_scc rest
187 (AbsBinds all_tyvars dicts [(tyvars, global, local, prags)] binds)
188 = ASSERT( all (`elem` tyvars) all_tyvars )
189 do { core_prs <- ds_lhs_binds NoSccs binds
191 ; let -- Always treat the binds as recursive, because the
192 -- typechecker makes rather mixed-up dictionary bindings
193 core_bind = Rec core_prs
194 rhs = addAutoScc auto_scc global $
195 mkLams tyvars $ mkLams dicts $ Let core_bind (Var local)
197 ; (spec_binds, rules) <- dsSpecs global rhs prags
199 ; let global' = addIdSpecialisations global rules
200 main_bind = makeCorePair global' (isDefaultMethod prags)
201 (dictArity dicts) rhs
203 ; return (main_bind : spec_binds ++ rest) }
205 dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
206 = do { core_prs <- ds_lhs_binds NoSccs binds
207 ; let env = mkABEnv exports
208 do_one (lcl_id,rhs) | Just (_, gbl_id, _, _prags) <- lookupVarEnv env lcl_id
209 = (lcl_id, addAutoScc auto_scc gbl_id rhs)
210 | otherwise = (lcl_id,rhs)
212 -- Rec because of mixed-up dictionary bindings
213 core_bind = Rec (map do_one core_prs)
215 tup_expr = mkBigCoreVarTup locals
216 tup_ty = exprType tup_expr
217 poly_tup_rhs = mkLams all_tyvars $ mkLams dicts $
218 Let core_bind tup_expr
219 locals = [local | (_, _, local, _) <- exports]
220 local_tys = map idType locals
222 ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
224 ; let mk_bind ((tyvars, global, _, spec_prags), n) -- locals!!n == local
225 = -- Need to make fresh locals to bind in the selector,
226 -- because some of the tyvars will be bound to 'Any'
227 do { let ty_args = map mk_ty_arg all_tyvars
228 substitute = substTyWith all_tyvars ty_args
229 ; locals' <- newSysLocalsDs (map substitute local_tys)
230 ; tup_id <- newSysLocalDs (substitute tup_ty)
231 ; let rhs = mkLams tyvars $ mkLams dicts $
232 mkTupleSelector locals' (locals' !! n) tup_id $
233 mkVarApps (mkTyApps (Var poly_tup_id) ty_args)
235 ; (spec_binds, rules) <- dsSpecs global
236 (Let (NonRec poly_tup_id poly_tup_rhs) rhs)
238 ; let global' = addIdSpecialisations global rules
239 ; return ((global', rhs) : spec_binds) }
242 | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
243 | otherwise = dsMkArbitraryType all_tyvar
245 ; export_binds_s <- mapM mk_bind (exports `zip` [0..])
246 -- Don't scc (auto-)annotate the tuple itself.
248 ; return ((poly_tup_id, poly_tup_rhs) :
249 (concat export_binds_s ++ rest)) }
251 ------------------------
252 makeCorePair :: Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr)
253 makeCorePair gbl_id is_default_method dict_arity rhs
254 | is_default_method -- Default methods are *always* inlined
255 = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs)
257 | not (isInlinePragma inline_prag)
260 | Just arity <- inlinePragmaSat inline_prag
261 -- Add an Unfolding for an INLINE (but not for NOINLINE)
262 -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
263 = (gbl_id `setIdUnfolding` mkInlineRule rhs (Just (dict_arity + arity)),
264 -- NB: The arity in the InlineRule takes account of the dictionaries
268 = (gbl_id `setIdUnfolding` mkInlineRule rhs Nothing, rhs)
270 inline_prag = idInlinePragma gbl_id
272 dictArity :: [Var] -> Arity
273 -- Don't count coercion variables in arity
274 dictArity dicts = count isId dicts
277 ------------------------
278 type AbsBindEnv = VarEnv ([TyVar], Id, Id, TcSpecPrags)
279 -- Maps the "lcl_id" for an AbsBind to
280 -- its "gbl_id" and associated pragmas, if any
282 mkABEnv :: [([TyVar], Id, Id, TcSpecPrags)] -> AbsBindEnv
283 -- Takes the exports of a AbsBinds, and returns a mapping
284 -- lcl_id -> (tyvars, gbl_id, lcl_id, prags)
285 mkABEnv exports = mkVarEnv [ (lcl_id, export) | export@(_, _, lcl_id, _) <- exports]
288 Note [Rules and inlining]
289 ~~~~~~~~~~~~~~~~~~~~~~~~~
290 Common special case: no type or dictionary abstraction
291 This is a bit less trivial than you might suppose
292 The naive way woudl be to desguar to something like
293 f_lcl = ...f_lcl... -- The "binds" from AbsBinds
294 M.f = f_lcl -- Generated from "exports"
295 But we don't want that, because if M.f isn't exported,
296 it'll be inlined unconditionally at every call site (its rhs is
297 trivial). That would be ok unless it has RULES, which would
298 thereby be completely lost. Bad, bad, bad.
300 Instead we want to generate
303 Now all is cool. The RULES are attached to M.f (by SimplCore),
304 and f_lcl is rapidly inlined away.
306 This does not happen in the same way to polymorphic binds,
307 because they desugar to
308 M.f = /\a. let f_lcl = ...f_lcl... in f_lcl
309 Although I'm a bit worried about whether full laziness might
310 float the f_lcl binding out and then inline M.f at its call site -}
312 Note [Specialising in no-dict case]
313 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
314 Even if there are no tyvars or dicts, we may have specialisation pragmas.
315 Class methods can generate
316 AbsBinds [] [] [( ... spec-prag]
317 { AbsBinds [tvs] [dicts] ...blah }
318 So the overloading is in the nested AbsBinds. A good example is in GHC.Float:
320 class (Real a, Fractional a) => RealFrac a where
321 round :: (Integral b) => a -> b
323 instance RealFrac Float where
324 {-# SPECIALIZE round :: Float -> Int #-}
326 The top-level AbsBinds for $cround has no tyvars or dicts (because the
327 instance does not). But the method is locally overloaded!
329 Note [Abstracting over tyvars only]
330 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
331 When abstracting over type variable only (not dictionaries), we don't really need to
332 built a tuple and select from it, as we do in the general case. Instead we can take
334 AbsBinds [a,b] [ ([a,b], fg, fl, _),
342 fg = /\ab. let B in e1
343 gg = /\b. let a = () in let B in S(e2)
344 h = /\ab. let B in e3
346 where B is the *non-recursive* binding
349 h = h a b -- See (b); note shadowing!
351 Notice (a) g has a different number of type variables to f, so we must
352 use the mkArbitraryType thing to fill in the gaps.
353 We use a type-let to do that.
355 (b) The local variable h isn't in the exports, and rather than
356 clone a fresh copy we simply replace h by (h a b), where
357 the two h's have different types! Shadowing happens here,
358 which looks confusing but works fine.
360 (c) The result is *still* quadratic-sized if there are a lot of
361 small bindings. So if there are more than some small
362 number (10), we filter the binding set B by the free
363 variables of the particular RHS. Tiresome.
365 Why got to this trouble? It's a common case, and it removes the
366 quadratic-sized tuple desugaring. Less clutter, hopefullly faster
367 compilation, especially in a case where there are a *lot* of
371 Note [Eta-expanding INLINE things]
372 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
374 foo :: Eq a => a -> a
378 If (foo d) ever gets floated out as a common sub-expression (which can
379 happen as a result of method sharing), there's a danger that we never
380 get to do the inlining, which is a Terribly Bad thing given that the
383 To avoid this we pre-emptively eta-expand the definition, so that foo
384 has the arity with which it is declared in the source code. In this
385 example it has arity 2 (one for the Eq and one for x). Doing this
386 should mean that (foo d) is a PAP and we don't share it.
388 Note [Nested arities]
389 ~~~~~~~~~~~~~~~~~~~~~
390 For reasons that are not entirely clear, method bindings come out looking like
393 AbsBinds [] [] [$cfromT <= [] fromT]
394 $cfromT [InlPrag=INLINE] :: T Bool -> Bool
395 { AbsBinds [] [] [fromT <= [] fromT_1]
396 fromT :: T Bool -> Bool
397 { fromT_1 ((TBool b)) = not b } } }
399 Note the nested AbsBind. The arity for the InlineRule on $cfromT should be
400 gotten from the binding for fromT_1.
402 It might be better to have just one level of AbsBinds, but that requires more
405 Note [Implementing SPECIALISE pragmas]
406 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
408 f :: (Eq a, Ix b) => a -> b -> Bool
409 {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-}
412 From this the typechecker generates
414 AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
416 SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX
417 -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ])
419 Note that wrap_fn can transform *any* function with the right type prefix
420 forall ab. (Eq a, Ix b) => XXX
421 regardless of XXX. It's sort of polymorphic in XXX. This is
422 useful: we use the same wrapper to transform each of the class ops, as
425 From these we generate:
427 Rule: forall p, q, (dp:Ix p), (dq:Ix q).
428 f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq
430 Spec bind: f_spec = wrap_fn <poly_rhs>
434 * The LHS of the rule may mention dictionary *expressions* (eg
435 $dfIxPair dp dq), and that is essential because the dp, dq are
438 * The RHS of f_spec, <poly_rhs> has a *copy* of 'binds', so that it
439 can fully specialise it.
442 ------------------------
443 dsSpecs :: Id -- The polymorphic Id
444 -> CoreExpr -- Its rhs
446 -> DsM ( [(Id,CoreExpr)] -- Binding for specialised Ids
447 , [CoreRule] ) -- Rules for the Global Ids
448 -- See Note [Implementing SPECIALISE pragmas]
449 dsSpecs poly_id poly_rhs prags
451 IsDefaultMethod -> return ([], [])
452 SpecPrags sps -> do { pairs <- mapMaybeM spec_one sps
453 ; let (spec_binds_s, rules) = unzip pairs
454 ; return (concat spec_binds_s, rules) }
456 spec_one :: Located TcSpecPrag -> DsM (Maybe ([(Id,CoreExpr)], CoreRule))
457 spec_one (L loc (SpecPrag spec_co spec_inl))
459 do { let poly_name = idName poly_id
460 ; spec_name <- newLocalName poly_name
461 ; wrap_fn <- dsCoercion spec_co
462 ; let ds_spec_expr = wrap_fn (Var poly_id)
463 ; case decomposeRuleLhs ds_spec_expr of {
464 Nothing -> do { warnDs (decomp_msg spec_co)
467 Just (bndrs, _fn, args) ->
469 -- Check for dead binders: Note [Unused spec binders]
470 case filter isDeadBinder bndrs of {
471 bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing }
474 { (spec_unf, unf_pairs) <- specUnfolding wrap_fn (realIdUnfolding poly_id)
476 ; let spec_ty = exprType ds_spec_expr
477 spec_id = mkLocalId spec_name spec_ty
478 `setInlinePragma` inl_prag
479 `setIdUnfolding` spec_unf
480 inl_prag | isDefaultInlinePragma spec_inl = idInlinePragma poly_id
481 | otherwise = spec_inl
482 -- Get the INLINE pragma from SPECIALISE declaration, or,
483 -- failing that, from the original Id
485 extra_dict_bndrs = [ localiseId d -- See Note [Constant rule dicts]
486 | d <- varSetElems (exprFreeVars ds_spec_expr)
488 -- Note [Const rule dicts]
490 rule = mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
491 AlwaysActive poly_name
492 (extra_dict_bndrs ++ bndrs) args
493 (mkVarApps (Var spec_id) bndrs)
495 spec_rhs = wrap_fn poly_rhs
496 spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs
498 ; return (Just (spec_pair : unf_pairs, rule))
501 dead_msg bs = vcat [ sep [ptext (sLit "Useless constraint") <> plural bs
502 <+> ptext (sLit "in specialied type:"),
503 nest 2 (pprTheta (map get_pred bs))]
504 , ptext (sLit "SPECIALISE pragma ignored")]
505 get_pred b = ASSERT( isId b ) expectJust "dsSpec" (tcSplitPredTy_maybe (idType b))
508 = hang (ptext (sLit "Specialisation too complicated to desugar; ignored"))
509 2 (pprHsWrapper (ppr poly_id) spec_co)
512 specUnfolding :: (CoreExpr -> CoreExpr) -> Unfolding -> DsM (Unfolding, [(Id,CoreExpr)])
513 specUnfolding wrap_fn (DFunUnfolding con ops)
514 = do { let spec_rhss = map wrap_fn ops
515 ; spec_ids <- mapM (mkSysLocalM (fsLit "spec") . exprType) spec_rhss
516 ; return (DFunUnfolding con (map Var spec_ids), spec_ids `zip` spec_rhss) }
518 = return (noUnfolding, [])
520 mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> TyVarEnv Type
521 -- If any of the tyvars is missing from any of the lists in
522 -- the second arg, return a binding in the result
523 mkArbitraryTypeEnv tyvars exports
524 = go emptyVarEnv exports
527 go env ((ltvs, _, _, _) : exports)
530 env' = foldl extend env [tv | tv <- tyvars
531 , not (tv `elem` ltvs)
532 , not (tv `elemVarEnv` env)]
534 extend env tv = extendVarEnv env tv (dsMkArbitraryType tv)
536 dsMkArbitraryType :: TcTyVar -> Type
537 dsMkArbitraryType tv = anyTypeOfKind (tyVarKind tv)
540 Note [Unused spec binders]
541 ~~~~~~~~~~~~~~~~~~~~~~~~~~
544 {-# SPECIALISE f :: Eq a => a -> a #-}
545 It's true that this *is* a more specialised type, but the rule
546 we get is something like this:
549 Note that the rule is bogus, becuase it mentions a 'd' that is
550 not bound on the LHS! But it's a silly specialisation anyway, becuase
551 the constraint is unused. We could bind 'd' to (error "unused")
552 but it seems better to reject the program because it's almost certainly
553 a mistake. That's what the isDeadBinder call detects.
555 Note [Const rule dicts]
556 ~~~~~~~~~~~~~~~~~~~~~~~
557 When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,
558 which is presumably in scope at the function definition site, we can quantify
559 over it too. *Any* dict with that type will do.
561 So for example when you have
564 {-# SPECIALISE f :: Int -> Int #-}
566 Then we get the SpecPrag
567 SpecPrag (f Int dInt)
569 And from that we want the rule
571 RULE forall dInt. f Int dInt = f_spec
572 f_spec = let f = <rhs> in f Int dInt
574 But be careful! That dInt might be GHC.Base.$fOrdInt, which is an External
575 Name, and you can't bind them in a lambda or forall without getting things
576 confused. Hence the use of 'localiseId' to make it Internal.
579 %************************************************************************
581 \subsection{Adding inline pragmas}
583 %************************************************************************
586 decomposeRuleLhs :: CoreExpr -> Maybe ([Var], Id, [CoreExpr])
587 -- Take apart the LHS of a RULE. It's suuposed to look like
588 -- /\a. f a Int dOrdInt
589 -- or /\a.\d:Ord a. let { dl::Ord [a] = dOrdList a d } in f [a] dl
590 -- That is, the RULE binders are lambda-bound
591 -- Returns Nothing if the LHS isn't of the expected shape
593 = case collectArgs body of
594 (Var fn, args) -> Just (bndrs, fn, args)
596 (Case scrut bndr ty [(DEFAULT, _, body)], args)
597 | isDeadBinder bndr -- Note [Matching seqId]
598 -> Just (bndrs, seqId, args' ++ args)
600 args' = [Type (idType bndr), Type ty, scrut, body]
602 _other -> Nothing -- Unexpected shape
604 (bndrs, body) = collectBinders (simpleOptExpr lhs)
605 -- simpleOptExpr occurrence-analyses and simplifies the lhs
607 -- (a) identifies unused binders: Note [Unused spec binders]
608 -- (b) sorts dict bindings into NonRecs
609 -- so they can be inlined by 'decomp'
610 -- (c) substitute trivial lets so that they don't get in the way
611 -- Note that we substitute the function too; we might
612 -- have this as a LHS: let f71 = M.f Int in f71
613 -- NB: tcSimplifyRuleLhs is very careful not to generate complicated
614 -- dictionary expressions that we might have to match
617 Note [Matching seqId]
619 The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
620 and this code turns it back into an application of seq!
621 See Note [Rules for seq] in MkId for the details.
624 %************************************************************************
626 \subsection[addAutoScc]{Adding automatic sccs}
628 %************************************************************************
631 data AutoScc = NoSccs
632 | AddSccs Module (Id -> Bool)
633 -- The (Id->Bool) says which Ids to add SCCs to
635 addAutoScc :: AutoScc
638 -> CoreExpr -- Scc'd Rhs
640 addAutoScc NoSccs _ rhs
642 addAutoScc (AddSccs mod add_scc) id rhs
643 | add_scc id = mkSCC (mkAutoCC id mod NotCafCC) rhs
647 If profiling and dealing with a dict binding,
648 wrap the dict in @_scc_ DICT <dict>@:
651 addDictScc :: Id -> CoreExpr -> DsM CoreExpr
652 addDictScc _ rhs = return rhs
654 {- DISABLED for now (need to somehow make up a name for the scc) -- SDM
655 | not ( opt_SccProfilingOn && opt_AutoSccsOnDicts)
656 || not (isDictId var)
657 = return rhs -- That's easy: do nothing
660 = do (mod, grp) <- getModuleAndGroupDs
661 -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
662 return (Note (SCC (mkAllDictsCC mod grp False)) rhs)
667 %************************************************************************
671 %************************************************************************
675 dsCoercion :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
676 dsCoercion WpHole = return (\e -> e)
677 dsCoercion (WpCompose c1 c2) = do { k1 <- dsCoercion c1
678 ; k2 <- dsCoercion c2
680 dsCoercion (WpCast co) = return (\e -> Cast e co)
681 dsCoercion (WpLam id) = return (\e -> Lam id e)
682 dsCoercion (WpTyLam tv) = return (\e -> Lam tv e)
683 dsCoercion (WpApp v) | isTyVar v -- Probably a coercion var
684 = return (\e -> App e (Type (mkTyVarTy v)))
686 = return (\e -> App e (Var v))
687 dsCoercion (WpTyApp ty) = return (\e -> App e (Type ty))
688 dsCoercion (WpLet bs) = do { prs <- dsLHsBinds bs
689 ; return (\e -> Let (Rec prs) e) }