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
36 import TysPrim ( anyTypeOfKind )
41 import Var ( Var, TyVar, tyVarKind )
42 import IdInfo ( vanillaIdInfo )
50 import BasicTypes hiding ( TopLevel )
52 import StaticFlags ( opt_DsMultiTyVar )
53 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 {- 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.
129 Instead we want to generate
132 Now all is cool. The RULES are attached to M.f (by SimplCore),
133 and f_lcl is rapidly inlined away.
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 -}
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
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)
151 | otherwise = (lcl_id, rhs)
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
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
165 AbsBinds [a,b] [ ([a,b], fg, fl, _),
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
177 where B is the *non-recursive* binding
180 h = h a b -- See (b); note shadowing!
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.
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.
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.
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
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)
212 add_lets | core_prs `lengthExceeds` 10 = add_some
214 add_some lg_binds rhs = mkLets [ NonRec b r | NonRec b r <- lg_binds
215 , b `elemVarSet` fvs] rhs
217 fvs = exprSomeFreeVars (`elemVarSet` bndrs) rhs
219 ar_env = mkArityEnv binds
220 env = mkABEnv exports
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))
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 $
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'))
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))) }
244 ; (_, core_prs') <- fixDs (\ ~(lg_binds, _) -> mapAndUnzipM (do_one lg_binds) core_prs)
245 ; return (core_prs' ++ rest) }
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
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
261 ; (spec_binds, rules) <- dsSpecs all_tyvars dicts tyvars global
262 local inl_arity core_bind prags
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
269 ; return (main_bind : spec_binds ++ rest) }
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)
279 -- Rec because of mixed-up dictionary bindings
280 core_bind = Rec (map do_one core_prs)
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
289 ; poly_tup_id <- newSysLocalDs (exprType poly_tup_expr)
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
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)
306 ; return ((global', rhs) : spec_binds) }
309 | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
310 | otherwise = dsMkArbitraryType all_tyvar
312 ; export_binds_s <- mapM mk_bind (exports `zip` [0..])
313 -- Don't scc (auto-)annotate the tuple itself.
315 ; return ((poly_tup_id, poly_tup_expr) :
316 (concat export_binds_s ++ rest)) }
318 ------------------------
319 makeCorePair :: Id-> Arity -> CoreExpr -> (Id, CoreExpr)
320 makeCorePair gbl_id arity rhs
321 = (addInline gbl_id arity rhs, rhs)
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
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]
333 mkArityEnv :: LHsBinds Id -> IdEnv Arity
334 -- Maps a local to the arity of its definition
335 mkArityEnv binds = foldrBag (plusVarEnv . lhsBindArity) emptyVarEnv binds
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
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
349 lhsBindArity _ = emptyVarEnv -- PatBind/VarBind
351 dictArity :: [Var] -> Arity
352 -- Don't count coercion variables in arity
353 dictArity dicts = count isId dicts
355 lookupArity :: IdEnv Arity -> Id -> Arity
356 lookupArity ar_env id = lookupVarEnv ar_env id `orElse` 0
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
369 For reasons that are not entirely clear, method bindings come out looking like
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 } } }
378 Note the nested AbsBind. The arity for the InlineRule on $cfromT should be
379 gotten from the binding for fromT_1.
381 It might be better to have just one level of AbsBinds, but that requires more
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
393 -- f :: (Eq a, Ix b) => a -> b -> b
394 -- {-# SPECIALISE f :: Ix b => Int -> b -> b #-}
396 -- AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
398 -- SpecPrag (/\b.\(d:Ix b). f Int b dInt d)
399 -- (forall b. Ix b => Int -> b -> b)
401 -- Rule: forall b,(d:Ix b). f Int b dInt d = f_spec b d
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
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
411 -- and the RULE forall as, ds. f es = f_spec as ds
413 -- It is *possible* that 'es' does not mention all of the dictionaries 'ds'
414 -- (a bit silly, because then the
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) }
421 spec_one :: LSpecPrag -> DsM (Maybe ([(Id,CoreExpr)], CoreRule))
422 spec_one (L loc (SpecPrag spec_co spec_inl))
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)
432 Just (bndrs, _fn, args) ->
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 }
439 { (spec_unf, unf_pairs) <- specUnfolding wrap_fn (idUnfolding poly_id)
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
451 spec_id_arity = inl_arity + count isDictId bndrs
453 extra_dict_bndrs = [ localiseId d -- See Note [Constant rule dicts]
454 | d <- varSetElems (exprFreeVars ds_spec_expr)
456 -- Note [Const rule dicts]
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)
463 spec_rhs = wrap_fn (mkLams (tvs ++ dicts) f_body)
464 spec_pair = makeCorePair spec_id spec_id_arity spec_rhs
466 ; return (Just (spec_pair : unf_pairs, rule))
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
475 void_tvs = all_tvs \\ tvs
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))
484 = hang (ptext (sLit "Specialisation too complicated to desugar; ignored"))
485 2 (pprHsWrapper (ppr poly_id) spec_co)
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) }
494 = return (noUnfolding, [])
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
503 go env ((ltvs, _, _, _) : exports)
506 env' = foldl extend env [tv | tv <- tyvars
507 , not (tv `elem` ltvs)
508 , not (tv `elemVarEnv` env)]
510 extend env tv = extendVarEnv env tv (dsMkArbitraryType tv)
512 dsMkArbitraryType :: TcTyVar -> Type
513 dsMkArbitraryType tv = anyTypeOfKind (tyVarKind tv)
516 Note [Unused spec binders]
517 ~~~~~~~~~~~~~~~~~~~~~~~~~~
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:
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.
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.
537 So for example when you have
540 {-# SPECIALISE f :: Int -> Int #-}
542 Then we get the SpecPrag
543 SpecPrag (f Int dInt)
545 And from that we want the rule
547 RULE forall dInt. f Int dInt = f_spec
548 f_spec = let f = <rhs> in f Int dInt
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.
555 %************************************************************************
557 \subsection{Adding inline pragmas}
559 %************************************************************************
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
569 = case collectArgs body of
570 (Var fn, args) -> Just (bndrs, fn, args)
572 (Case scrut bndr ty [(DEFAULT, _, body)], args)
573 | isDeadBinder bndr -- Note [Matching seqId]
574 -> Just (bndrs, seqId, args' ++ args)
576 args' = [Type (idType bndr), Type ty, scrut, body]
578 _other -> Nothing -- Unexpected shape
580 (bndrs, body) = collectBinders (simpleOptExpr lhs)
581 -- simpleOptExpr occurrence-analyses and simplifies the lhs
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
593 Note [Matching seqId]
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.
600 %************************************************************************
602 \subsection[addAutoScc]{Adding automatic sccs}
604 %************************************************************************
607 data AutoScc = NoSccs
608 | AddSccs Module (Id -> Bool)
609 -- The (Id->Bool) says which Ids to add SCCs to
611 addAutoScc :: AutoScc
614 -> CoreExpr -- Scc'd Rhs
616 addAutoScc NoSccs _ rhs
618 addAutoScc (AddSccs mod add_scc) id rhs
619 | add_scc id = mkSCC (mkAutoCC id mod NotCafCC) rhs
623 If profiling and dealing with a dict binding,
624 wrap the dict in @_scc_ DICT <dict>@:
627 addDictScc :: Id -> CoreExpr -> DsM CoreExpr
628 addDictScc _ rhs = return rhs
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
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)
643 %************************************************************************
647 %************************************************************************
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
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)))
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) }