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 )
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 {- Note [Rules and inlining]
119 ~~~~~~~~~~~~~~~~~~~~~~~~~
120 Common special case: no type or dictionary abstraction
121 This is a bit less trivial than you might suppose
122 The naive way woudl be to desguar to something like
123 f_lcl = ...f_lcl... -- The "binds" from AbsBinds
124 M.f = f_lcl -- Generated from "exports"
125 But we don't want that, because if M.f isn't exported,
126 it'll be inlined unconditionally at every call site (its rhs is
127 trivial). That would be ok unless it has RULES, which would
128 thereby be completely lost. Bad, bad, bad.
130 Instead we want to generate
133 Now all is cool. The RULES are attached to M.f (by SimplCore),
134 and f_lcl is rapidly inlined away.
136 This does not happen in the same way to polymorphic binds,
137 because they desugar to
138 M.f = /\a. let f_lcl = ...f_lcl... in f_lcl
139 Although I'm a bit worried about whether full laziness might
140 float the f_lcl binding out and then inline M.f at its call site -}
142 dsHsBind auto_scc rest (AbsBinds [] [] exports binds)
143 = do { core_prs <- ds_lhs_binds NoSccs binds
144 ; let env = mkABEnv exports
145 ar_env = mkArityEnv binds
147 | Just (_, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id
148 = WARN( not (null spec_prags), ppr gbl_id $$ ppr spec_prags ) -- Not overloaded
149 makeCorePair gbl_id (lookupArity ar_env lcl_id)
150 (addAutoScc auto_scc gbl_id rhs)
152 | otherwise = (lcl_id, rhs)
154 locals' = [(lcl_id, Var gbl_id) | (_, gbl_id, lcl_id, _) <- exports]
155 -- Note [Rules and inlining]
156 ; return (map do_one core_prs ++ locals' ++ rest) }
157 -- No Rec needed here (contrast the other AbsBinds cases)
158 -- because we can rely on the enclosing dsBind to wrap in Rec
161 {- Note [Abstracting over tyvars only]
162 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
163 When abstracting over type variable only (not dictionaries), we don't really need to
164 built a tuple and select from it, as we do in the general case. Instead we can take
166 AbsBinds [a,b] [ ([a,b], fg, fl, _),
174 fg = /\ab. let B in e1
175 gg = /\b. let a = () in let B in S(e2)
176 h = /\ab. let B in e3
178 where B is the *non-recursive* binding
181 h = h a b -- See (b); note shadowing!
183 Notice (a) g has a different number of type variables to f, so we must
184 use the mkArbitraryType thing to fill in the gaps.
185 We use a type-let to do that.
187 (b) The local variable h isn't in the exports, and rather than
188 clone a fresh copy we simply replace h by (h a b), where
189 the two h's have different types! Shadowing happens here,
190 which looks confusing but works fine.
192 (c) The result is *still* quadratic-sized if there are a lot of
193 small bindings. So if there are more than some small
194 number (10), we filter the binding set B by the free
195 variables of the particular RHS. Tiresome.
197 Why got to this trouble? It's a common case, and it removes the
198 quadratic-sized tuple desugaring. Less clutter, hopefullly faster
199 compilation, especially in a case where there are a *lot* of
204 dsHsBind auto_scc rest (AbsBinds tyvars [] exports binds)
205 | opt_DsMultiTyVar -- This (static) debug flag just lets us
206 -- switch on and off this optimisation to
207 -- see if it has any impact; it is on by default
208 = -- Note [Abstracting over tyvars only]
209 do { core_prs <- ds_lhs_binds NoSccs binds
210 ; let arby_env = mkArbitraryTypeEnv tyvars exports
211 bndrs = mkVarSet (map fst core_prs)
213 add_lets | core_prs `lengthExceeds` 10 = add_some
215 add_some lg_binds rhs = mkLets [ NonRec b r | NonRec b r <- lg_binds
216 , b `elemVarSet` fvs] rhs
218 fvs = exprSomeFreeVars (`elemVarSet` bndrs) rhs
220 ar_env = mkArityEnv binds
221 env = mkABEnv exports
223 mk_lg_bind lcl_id gbl_id tyvars
224 = NonRec (setIdInfo lcl_id vanillaIdInfo)
225 -- Nuke the IdInfo so that no old unfoldings
226 -- confuse use (it might mention something not
227 -- even in scope at the new site
228 (mkTyApps (Var gbl_id) (mkTyVarTys tyvars))
230 do_one lg_binds (lcl_id, rhs)
231 | Just (id_tvs, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id
232 = WARN( not (null spec_prags), ppr gbl_id $$ ppr spec_prags ) -- Not overloaded
233 (let rhs' = addAutoScc auto_scc gbl_id $
235 mkLets [ NonRec tv (Type (lookupVarEnv_NF arby_env tv))
236 | tv <- tyvars, not (tv `elem` id_tvs)] $
237 add_lets lg_binds rhs
238 in return (mk_lg_bind lcl_id gbl_id id_tvs,
239 makeCorePair gbl_id (lookupArity ar_env lcl_id) rhs'))
241 = do { non_exp_gbl_id <- newUniqueId lcl_id (mkForAllTys tyvars (idType lcl_id))
242 ; return (mk_lg_bind lcl_id non_exp_gbl_id tyvars,
243 (non_exp_gbl_id, mkLams tyvars (add_lets lg_binds rhs))) }
245 ; (_, core_prs') <- fixDs (\ ~(lg_binds, _) -> mapAndUnzipM (do_one lg_binds) core_prs)
246 ; return (core_prs' ++ rest) }
248 -- Another common case: one exported variable
249 -- Non-recursive bindings come through this way
250 -- So do self-recursive bindings, and recursive bindings
251 -- that have been chopped up with type signatures
252 dsHsBind auto_scc rest
253 (AbsBinds all_tyvars dicts [(tyvars, global, local, prags)] binds)
254 = ASSERT( all (`elem` tyvars) all_tyvars )
255 do { core_prs <- ds_lhs_binds NoSccs binds
257 ; let -- Always treat the binds as recursive, because the typechecker
258 -- makes rather mixed-up dictionary bindings
259 core_bind = Rec core_prs
260 inl_arity = lookupArity (mkArityEnv binds) local
262 ; (spec_binds, rules) <- dsSpecs all_tyvars dicts tyvars global
263 local inl_arity core_bind prags
265 ; let global' = addIdSpecialisations global rules
266 rhs = addAutoScc auto_scc global $
267 mkLams tyvars $ mkLams dicts $ Let core_bind (Var local)
268 main_bind = makeCorePair global' (inl_arity + dictArity dicts) rhs
270 ; return (main_bind : spec_binds ++ rest) }
272 dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
273 = do { core_prs <- ds_lhs_binds NoSccs binds
274 ; let env = mkABEnv exports
275 ar_env = mkArityEnv binds
276 do_one (lcl_id,rhs) | Just (_, gbl_id, _, _prags) <- lookupVarEnv env lcl_id
277 = (lcl_id, addAutoScc auto_scc gbl_id rhs)
278 | otherwise = (lcl_id,rhs)
280 -- Rec because of mixed-up dictionary bindings
281 core_bind = Rec (map do_one core_prs)
283 tup_expr = mkBigCoreVarTup locals
284 tup_ty = exprType tup_expr
285 poly_tup_expr = mkLams all_tyvars $ mkLams dicts $
286 Let core_bind tup_expr
287 locals = [local | (_, _, local, _) <- exports]
288 local_tys = map idType locals
290 ; poly_tup_id <- newSysLocalDs (exprType poly_tup_expr)
292 ; let mk_bind ((tyvars, global, local, spec_prags), n) -- locals!!n == local
293 = -- Need to make fresh locals to bind in the selector,
294 -- because some of the tyvars will be bound to 'Any'
295 do { let ty_args = map mk_ty_arg all_tyvars
296 substitute = substTyWith all_tyvars ty_args
297 ; locals' <- newSysLocalsDs (map substitute local_tys)
298 ; tup_id <- newSysLocalDs (substitute tup_ty)
299 ; (spec_binds, rules) <- dsSpecs all_tyvars dicts tyvars global local
300 (lookupArity ar_env local) core_bind
302 ; let global' = addIdSpecialisations global rules
303 rhs = mkLams tyvars $ mkLams dicts $
304 mkTupleSelector locals' (locals' !! n) tup_id $
305 mkVarApps (mkTyApps (Var poly_tup_id) ty_args)
307 ; return ((global', rhs) : spec_binds) }
310 | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
311 | otherwise = dsMkArbitraryType all_tyvar
313 ; export_binds_s <- mapM mk_bind (exports `zip` [0..])
314 -- Don't scc (auto-)annotate the tuple itself.
316 ; return ((poly_tup_id, poly_tup_expr) :
317 (concat export_binds_s ++ rest)) }
319 ------------------------
320 makeCorePair :: Id-> Arity -> CoreExpr -> (Id, CoreExpr)
321 makeCorePair gbl_id arity rhs
322 | isInlinePragma (idInlinePragma gbl_id)
323 -- Add an Unfolding for an INLINE (but not for NOINLINE)
324 -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
325 = (gbl_id `setIdUnfolding` mkInlineRule InlSat rhs arity,
330 ------------------------
331 type AbsBindEnv = VarEnv ([TyVar], Id, Id, [LSpecPrag])
332 -- Maps the "lcl_id" for an AbsBind to
333 -- its "gbl_id" and associated pragmas, if any
335 mkABEnv :: [([TyVar], Id, Id, [LSpecPrag])] -> AbsBindEnv
336 -- Takes the exports of a AbsBinds, and returns a mapping
337 -- lcl_id -> (tyvars, gbl_id, lcl_id, prags)
338 mkABEnv exports = mkVarEnv [ (lcl_id, export) | export@(_, _, lcl_id, _) <- exports]
340 mkArityEnv :: LHsBinds Id -> IdEnv Arity
341 -- Maps a local to the arity of its definition
342 mkArityEnv binds = foldrBag (plusVarEnv . lhsBindArity) emptyVarEnv binds
344 lhsBindArity :: LHsBind Id -> IdEnv Arity
345 lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms }))
346 = unitVarEnv (unLoc id) (matchGroupArity ms)
347 lhsBindArity (L _ (AbsBinds { abs_exports = exports
349 , abs_binds = binds }))
350 = mkVarEnv [ (gbl, lookupArity ar_env lcl + n_val_dicts)
351 | (_, gbl, lcl, _) <- exports]
352 where -- See Note [Nested arities]
353 ar_env = mkArityEnv binds
354 n_val_dicts = dictArity dicts
356 lhsBindArity _ = emptyVarEnv -- PatBind/VarBind
358 dictArity :: [Var] -> Arity
359 -- Don't count coercion variables in arity
360 dictArity dicts = count isId dicts
362 lookupArity :: IdEnv Arity -> Id -> Arity
363 lookupArity ar_env id = lookupVarEnv ar_env id `orElse` 0
366 Note [Eta-expanding INLINE things]
367 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
369 foo :: Eq a => a -> a
373 If (foo d) ever gets floated out as a common sub-expression (which can
374 happen as a result of method sharing), there's a danger that we never
375 get to do the inlining, which is a Terribly Bad thing given that the
378 To avoid this we pre-emptively eta-expand the definition, so that foo
379 has the arity with which it is declared in the source code. In this
380 example it has arity 2 (one for the Eq and one for x). Doing this
381 should mean that (foo d) is a PAP and we don't share it.
383 Note [Nested arities]
384 ~~~~~~~~~~~~~~~~~~~~~
385 For reasons that are not entirely clear, method bindings come out looking like
388 AbsBinds [] [] [$cfromT <= [] fromT]
389 $cfromT [InlPrag=INLINE] :: T Bool -> Bool
390 { AbsBinds [] [] [fromT <= [] fromT_1]
391 fromT :: T Bool -> Bool
392 { fromT_1 ((TBool b)) = not b } } }
394 Note the nested AbsBind. The arity for the InlineRule on $cfromT should be
395 gotten from the binding for fromT_1.
397 It might be better to have just one level of AbsBinds, but that requires more
402 ------------------------
403 dsSpecs :: [TyVar] -> [DictId] -> [TyVar]
404 -> Id -> Id -> Arity -- Global, local, arity of local
405 -> CoreBind -> [LSpecPrag]
406 -> DsM ( [(Id,CoreExpr)] -- Binding for specialised Ids
407 , [CoreRule] ) -- Rules for the Global Ids
409 -- f :: (Eq a, Ix b) => a -> b -> b
410 -- {-# SPECIALISE f :: Ix b => Int -> b -> b #-}
412 -- AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
414 -- SpecPrag (/\b.\(d:Ix b). f Int b dInt d)
415 -- (forall b. Ix b => Int -> b -> b)
417 -- Rule: forall b,(d:Ix b). f Int b dInt d = f_spec b d
419 -- Spec bind: f_spec = Let f = /\ab \(d1:Eq a)(d2:Ix b). let binds in f_mono
420 -- /\b.\(d:Ix b). in f Int b dInt d
421 -- The idea is that f occurs just once, so it'll be
422 -- inlined and specialised
424 -- Given SpecPrag (/\as.\ds. f es) t, we have
425 -- the defn f_spec as ds = let-nonrec f = /\fas\fds. let f_mono = <f-rhs> in f_mono
427 -- and the RULE forall as, ds. f es = f_spec as ds
429 -- It is *possible* that 'es' does not mention all of the dictionaries 'ds'
430 -- (a bit silly, because then the
432 dsSpecs all_tvs dicts tvs poly_id mono_id inl_arity mono_bind prags
433 = do { pairs <- mapMaybeM spec_one prags
434 ; let (spec_binds_s, rules) = unzip pairs
435 ; return (concat spec_binds_s, rules) }
437 spec_one :: LSpecPrag -> DsM (Maybe ([(Id,CoreExpr)], CoreRule))
438 spec_one (L loc (SpecPrag spec_co spec_inl))
440 do { let poly_name = idName poly_id
441 ; spec_name <- newLocalName poly_name
442 ; wrap_fn <- dsCoercion spec_co
443 ; let ds_spec_expr = wrap_fn (Var poly_id)
444 ; case decomposeRuleLhs ds_spec_expr of {
445 Nothing -> do { warnDs (decomp_msg spec_co)
448 Just (bndrs, _fn, args) ->
450 -- Check for dead binders: Note [Unused spec binders]
451 case filter isDeadBinder bndrs of {
452 bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing }
455 { (spec_unf, unf_pairs) <- specUnfolding wrap_fn (realIdUnfolding poly_id)
457 ; let f_body = fix_up (Let mono_bind (Var mono_id))
458 spec_ty = exprType ds_spec_expr
459 spec_id = mkLocalId spec_name spec_ty
460 `setInlinePragma` inl_prag
461 `setIdUnfolding` spec_unf
462 inl_prag | isDefaultInlinePragma spec_inl = idInlinePragma poly_id
463 | otherwise = spec_inl
464 -- Get the INLINE pragma from SPECIALISE declaration, or,
465 -- failing that, from the original Id
467 spec_id_arity = inl_arity + count isDictId bndrs
469 extra_dict_bndrs = [ localiseId d -- See Note [Constant rule dicts]
470 | d <- varSetElems (exprFreeVars ds_spec_expr)
472 -- Note [Const rule dicts]
474 rule = mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
475 AlwaysActive poly_name
476 (extra_dict_bndrs ++ bndrs) args
477 (mkVarApps (Var spec_id) bndrs)
479 spec_rhs = wrap_fn (mkLams (tvs ++ dicts) f_body)
480 spec_pair = makeCorePair spec_id spec_id_arity spec_rhs
482 ; return (Just (spec_pair : unf_pairs, rule))
485 -- Bind to Any any of all_ptvs that aren't
486 -- relevant for this particular function
487 fix_up body | null void_tvs = body
488 | otherwise = mkTyApps (mkLams void_tvs body) $
489 map dsMkArbitraryType void_tvs
491 void_tvs = all_tvs \\ tvs
493 dead_msg bs = vcat [ sep [ptext (sLit "Useless constraint") <> plural bs
494 <+> ptext (sLit "in specialied type:"),
495 nest 2 (pprTheta (map get_pred bs))]
496 , ptext (sLit "SPECIALISE pragma ignored")]
497 get_pred b = ASSERT( isId b ) expectJust "dsSpec" (tcSplitPredTy_maybe (idType b))
500 = hang (ptext (sLit "Specialisation too complicated to desugar; ignored"))
501 2 (pprHsWrapper (ppr poly_id) spec_co)
504 specUnfolding :: (CoreExpr -> CoreExpr) -> Unfolding -> DsM (Unfolding, [(Id,CoreExpr)])
505 specUnfolding wrap_fn (DFunUnfolding con ops)
506 = do { let spec_rhss = map wrap_fn ops
507 ; spec_ids <- mapM (mkSysLocalM (fsLit "spec") . exprType) spec_rhss
508 ; return (DFunUnfolding con (map Var spec_ids), spec_ids `zip` spec_rhss) }
510 = return (noUnfolding, [])
512 mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> TyVarEnv Type
513 -- If any of the tyvars is missing from any of the lists in
514 -- the second arg, return a binding in the result
515 mkArbitraryTypeEnv tyvars exports
516 = go emptyVarEnv exports
519 go env ((ltvs, _, _, _) : exports)
522 env' = foldl extend env [tv | tv <- tyvars
523 , not (tv `elem` ltvs)
524 , not (tv `elemVarEnv` env)]
526 extend env tv = extendVarEnv env tv (dsMkArbitraryType tv)
528 dsMkArbitraryType :: TcTyVar -> Type
529 dsMkArbitraryType tv = anyTypeOfKind (tyVarKind tv)
532 Note [Unused spec binders]
533 ~~~~~~~~~~~~~~~~~~~~~~~~~~
536 {-# SPECIALISE f :: Eq a => a -> a #-}
537 It's true that this *is* a more specialised type, but the rule
538 we get is something like this:
541 Note that the rule is bogus, becuase it mentions a 'd' that is
542 not bound on the LHS! But it's a silly specialisation anyway, becuase
543 the constraint is unused. We could bind 'd' to (error "unused")
544 but it seems better to reject the program because it's almost certainly
545 a mistake. That's what the isDeadBinder call detects.
547 Note [Const rule dicts]
548 ~~~~~~~~~~~~~~~~~~~~~~~
549 When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,
550 which is presumably in scope at the function definition site, we can quantify
551 over it too. *Any* dict with that type will do.
553 So for example when you have
556 {-# SPECIALISE f :: Int -> Int #-}
558 Then we get the SpecPrag
559 SpecPrag (f Int dInt)
561 And from that we want the rule
563 RULE forall dInt. f Int dInt = f_spec
564 f_spec = let f = <rhs> in f Int dInt
566 But be careful! That dInt might be GHC.Base.$fOrdInt, which is an External
567 Name, and you can't bind them in a lambda or forall without getting things
568 confused. Hence the use of 'localiseId' to make it Internal.
571 %************************************************************************
573 \subsection{Adding inline pragmas}
575 %************************************************************************
578 decomposeRuleLhs :: CoreExpr -> Maybe ([Var], Id, [CoreExpr])
579 -- Take apart the LHS of a RULE. It's suuposed to look like
580 -- /\a. f a Int dOrdInt
581 -- or /\a.\d:Ord a. let { dl::Ord [a] = dOrdList a d } in f [a] dl
582 -- That is, the RULE binders are lambda-bound
583 -- Returns Nothing if the LHS isn't of the expected shape
585 = case collectArgs body of
586 (Var fn, args) -> Just (bndrs, fn, args)
588 (Case scrut bndr ty [(DEFAULT, _, body)], args)
589 | isDeadBinder bndr -- Note [Matching seqId]
590 -> Just (bndrs, seqId, args' ++ args)
592 args' = [Type (idType bndr), Type ty, scrut, body]
594 _other -> Nothing -- Unexpected shape
596 (bndrs, body) = collectBinders (simpleOptExpr lhs)
597 -- simpleOptExpr occurrence-analyses and simplifies the lhs
599 -- (a) identifies unused binders: Note [Unused spec binders]
600 -- (b) sorts dict bindings into NonRecs
601 -- so they can be inlined by 'decomp'
602 -- (c) substitute trivial lets so that they don't get in the way
603 -- Note that we substitute the function too; we might
604 -- have this as a LHS: let f71 = M.f Int in f71
605 -- NB: tcSimplifyRuleLhs is very careful not to generate complicated
606 -- dictionary expressions that we might have to match
609 Note [Matching seqId]
611 The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
612 and this code turns it back into an application of seq!
613 See Note [Rules for seq] in MkId for the details.
616 %************************************************************************
618 \subsection[addAutoScc]{Adding automatic sccs}
620 %************************************************************************
623 data AutoScc = NoSccs
624 | AddSccs Module (Id -> Bool)
625 -- The (Id->Bool) says which Ids to add SCCs to
627 addAutoScc :: AutoScc
630 -> CoreExpr -- Scc'd Rhs
632 addAutoScc NoSccs _ rhs
634 addAutoScc (AddSccs mod add_scc) id rhs
635 | add_scc id = mkSCC (mkAutoCC id mod NotCafCC) rhs
639 If profiling and dealing with a dict binding,
640 wrap the dict in @_scc_ DICT <dict>@:
643 addDictScc :: Id -> CoreExpr -> DsM CoreExpr
644 addDictScc _ rhs = return rhs
646 {- DISABLED for now (need to somehow make up a name for the scc) -- SDM
647 | not ( opt_SccProfilingOn && opt_AutoSccsOnDicts)
648 || not (isDictId var)
649 = return rhs -- That's easy: do nothing
652 = do (mod, grp) <- getModuleAndGroupDs
653 -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
654 return (Note (SCC (mkAllDictsCC mod grp False)) rhs)
659 %************************************************************************
663 %************************************************************************
667 dsCoercion :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
668 dsCoercion WpHole = return (\e -> e)
669 dsCoercion (WpCompose c1 c2) = do { k1 <- dsCoercion c1
670 ; k2 <- dsCoercion c2
672 dsCoercion (WpCast co) = return (\e -> Cast e co)
673 dsCoercion (WpLam id) = return (\e -> Lam id e)
674 dsCoercion (WpTyLam tv) = return (\e -> Lam tv e)
675 dsCoercion (WpApp v) | isTyVar v -- Probably a coercion var
676 = return (\e -> App e (Type (mkTyVarTy v)))
678 = return (\e -> App e (Var v))
679 dsCoercion (WpTyApp ty) = return (\e -> App e (Type ty))
680 dsCoercion (WpLet bs) = do { prs <- dsLHsBinds bs
681 ; return (\e -> Let (Rec prs) e) }