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, dsSpec,
14 dsHsWrapper, dsTcEvBinds, dsEvBinds, wrapDsEvBinds,
15 DsEvBind(..), AutoScc(..)
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 )
39 import TysPrim ( anyTypeOfKind )
43 import TyCon ( tyConDataCons )
45 import DataCon ( dataConRepType )
46 import Name ( localiseName )
57 import BasicTypes hiding ( TopLevel )
59 -- import StaticFlags ( opt_DsMultiTyVar )
65 %************************************************************************
67 \subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
69 %************************************************************************
72 dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
73 dsTopLHsBinds auto_scc binds = ds_lhs_binds auto_scc binds
75 dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
76 dsLHsBinds binds = do { binds' <- ds_lhs_binds NoSccs binds
77 ; return (fromOL binds') }
79 ------------------------
80 ds_lhs_binds :: AutoScc -> LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
82 -- scc annotation policy (see below)
83 ds_lhs_binds auto_scc binds = do { ds_bs <- mapBagM (dsLHsBind auto_scc) binds
84 ; return (foldBag appOL id nilOL ds_bs) }
86 dsLHsBind :: AutoScc -> LHsBind Id -> DsM (OrdList (Id,CoreExpr))
87 dsLHsBind auto_scc (L loc bind)
88 = putSrcSpanDs loc $ dsHsBind auto_scc bind
90 dsHsBind :: AutoScc -> HsBind Id -> DsM (OrdList (Id,CoreExpr))
92 dsHsBind _ (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 (unitOL (var', core_expr')) }
103 dsHsBind _ (FunBind { fun_id = L _ fun, fun_matches = matches
104 , fun_co_fn = co_fn, fun_tick = tick
106 = do { (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches
107 ; body' <- mkOptTickBox tick body
108 ; wrap_fn' <- dsHsWrapper co_fn
109 ; let rhs = wrap_fn' (mkLams args body')
110 ; return (unitOL (makeCorePair fun False 0 rhs)) }
112 dsHsBind _ (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 -- We silently ignore inline pragmas; no makeCorePair
116 -- Not so cool, but really doesn't matter
117 ; return (toOL sel_binds) }
119 -- A common case: one exported variable
120 -- Non-recursive bindings come through this way
121 -- So do self-recursive bindings, and recursive bindings
122 -- that have been chopped up with type signatures
123 dsHsBind auto_scc (AbsBinds { abs_tvs = all_tyvars, abs_ev_vars = dicts
124 , abs_exports = [(tyvars, global, local, prags)]
125 , abs_ev_binds = ev_binds, abs_binds = binds })
126 = ASSERT( all (`elem` tyvars) all_tyvars )
127 do { bind_prs <- ds_lhs_binds NoSccs binds
128 ; ds_ev_binds <- dsTcEvBinds ev_binds
130 ; let core_bind = Rec (fromOL bind_prs)
131 rhs = addAutoScc auto_scc global $
132 mkLams tyvars $ mkLams dicts $
133 wrapDsEvBinds ds_ev_binds $
137 ; (spec_binds, rules) <- dsSpecs rhs prags
139 ; let global' = addIdSpecialisations global rules
140 main_bind = makeCorePair global' (isDefaultMethod prags)
141 (dictArity dicts) rhs
143 ; return (main_bind `consOL` spec_binds) }
145 dsHsBind auto_scc (AbsBinds { abs_tvs = all_tyvars, abs_ev_vars = dicts
146 , abs_exports = exports, abs_ev_binds = ev_binds
147 , abs_binds = binds })
148 = do { bind_prs <- ds_lhs_binds NoSccs binds
149 ; ds_ev_binds <- dsTcEvBinds ev_binds
150 ; let env = mkABEnv exports
151 do_one (lcl_id,rhs) | Just (_, gbl_id, _, _prags) <- lookupVarEnv env lcl_id
152 = (lcl_id, addAutoScc auto_scc gbl_id rhs)
153 | otherwise = (lcl_id,rhs)
155 core_bind = Rec (map do_one (fromOL bind_prs))
156 -- Monomorphic recursion possible, hence Rec
158 tup_expr = mkBigCoreVarTup locals
159 tup_ty = exprType tup_expr
160 poly_tup_rhs = mkLams all_tyvars $ mkLams dicts $
161 wrapDsEvBinds ds_ev_binds $
164 locals = [local | (_, _, local, _) <- exports]
165 local_tys = map idType locals
167 ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
169 ; let mk_bind ((tyvars, global, _, spec_prags), n) -- locals!!n == local
170 = -- Need to make fresh locals to bind in the selector,
171 -- because some of the tyvars will be bound to 'Any'
172 do { let ty_args = map mk_ty_arg all_tyvars
173 substitute = substTyWith all_tyvars ty_args
174 ; locals' <- newSysLocalsDs (map substitute local_tys)
175 ; tup_id <- newSysLocalDs (substitute tup_ty)
176 ; let rhs = mkLams tyvars $ mkLams dicts $
177 mkTupleSelector locals' (locals' !! n) tup_id $
178 mkVarApps (mkTyApps (Var poly_tup_id) ty_args)
180 full_rhs = Let (NonRec poly_tup_id poly_tup_rhs) rhs
181 ; (spec_binds, rules) <- dsSpecs full_rhs spec_prags
183 ; let global' = addIdSpecialisations global rules
184 ; return ((global', rhs) `consOL` spec_binds) }
187 | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
188 | otherwise = dsMkArbitraryType all_tyvar
190 ; export_binds_s <- mapM mk_bind (exports `zip` [0..])
191 -- Don't scc (auto-)annotate the tuple itself.
193 ; return ((poly_tup_id, poly_tup_rhs) `consOL`
194 concatOL export_binds_s) }
196 --------------------------------------
198 = LetEvBind -- Dictionary or coercion
199 CoreBind -- recursive or non-recursive
201 | CaseEvBind -- Coercion binding by superclass selection
202 -- Desugars to case d of d { K _ g _ _ _ -> ... }
203 DictId -- b The dictionary
204 AltCon -- K Its constructor
205 [CoreBndr] -- _ g _ _ _ The binders in the alternative
207 wrapDsEvBinds :: [DsEvBind] -> CoreExpr -> CoreExpr
208 wrapDsEvBinds ds_ev_binds body = foldr wrap_one body ds_ev_binds
210 body_ty = exprType body
211 wrap_one (LetEvBind b) body = Let b body
212 wrap_one (CaseEvBind x k xs) body = Case (Var x) x body_ty [(k,xs,body)]
214 dsTcEvBinds :: TcEvBinds -> DsM [DsEvBind]
215 dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this
216 dsTcEvBinds (EvBinds bs) = dsEvBinds bs
218 dsEvBinds :: Bag EvBind -> DsM [DsEvBind]
219 dsEvBinds bs = return (map dsEvGroup sccs)
222 sccs = stronglyConnCompFromEdgedVertices edges
224 edges :: [(EvBind, EvVar, [EvVar])]
225 edges = foldrBag ((:) . mk_node) [] bs
227 mk_node :: EvBind -> (EvBind, EvVar, [EvVar])
228 mk_node b@(EvBind var term) = (b, var, free_vars_of term)
230 free_vars_of :: EvTerm -> [EvVar]
231 free_vars_of (EvId v) = [v]
232 free_vars_of (EvCast v co) = v : varSetElems (tyVarsOfType co)
233 free_vars_of (EvCoercion co) = varSetElems (tyVarsOfType co)
234 free_vars_of (EvDFunApp _ _ vs) = vs
235 free_vars_of (EvSuperClass d _) = [d]
237 dsEvGroup :: SCC EvBind -> DsEvBind
238 dsEvGroup (AcyclicSCC (EvBind co_var (EvSuperClass dict n)))
239 | isCoVar co_var -- An equality superclass
240 = ASSERT( null other_data_cons )
241 CaseEvBind dict (DataAlt data_con) bndrs
243 (cls, tys) = getClassPredTys (evVarPred dict)
244 (data_con:other_data_cons) = tyConDataCons (classTyCon cls)
245 (ex_tvs, theta, rho) = tcSplitSigmaTy (applyTys (dataConRepType data_con) tys)
246 (arg_tys, _) = splitFunTys rho
247 bndrs = ex_tvs ++ map mk_wild_pred (theta `zip` [0..])
248 ++ map mkWildValBinder arg_tys
249 mk_wild_pred (p, i) | i==n = ASSERT( p `tcEqPred` (coVarPred co_var))
251 | otherwise = mkWildEvBinder p
253 dsEvGroup (AcyclicSCC (EvBind v r))
254 = LetEvBind (NonRec v (dsEvTerm r))
256 dsEvGroup (CyclicSCC bs)
257 = LetEvBind (Rec (map ds_pair bs))
259 ds_pair (EvBind v r) = (v, dsEvTerm r)
261 dsEvTerm :: EvTerm -> CoreExpr
262 dsEvTerm (EvId v) = Var v
263 dsEvTerm (EvCast v co) = Cast (Var v) co
264 dsEvTerm (EvDFunApp df tys vars) = Var df `mkTyApps` tys `mkVarApps` vars
265 dsEvTerm (EvCoercion co) = Type co
266 dsEvTerm (EvSuperClass d n)
267 = ASSERT( isClassPred (classSCTheta cls !! n) )
268 -- We can only select *dictionary* superclasses
269 -- in terms. Equality superclasses are dealt with
270 -- in dsEvGroup, where they can generate a case expression
271 Var sc_sel_id `mkTyApps` tys `App` Var d
273 sc_sel_id = classSCSelId cls n -- Zero-indexed
274 (cls, tys) = getClassPredTys (evVarPred d)
276 ------------------------
277 makeCorePair :: Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr)
278 makeCorePair gbl_id is_default_method dict_arity rhs
279 | is_default_method -- Default methods are *always* inlined
280 = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs)
283 = case inlinePragmaSpec inline_prag of
284 EmptyInlineSpec -> (gbl_id, rhs)
285 NoInline -> (gbl_id, rhs)
286 Inlinable -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)
287 Inline -> inline_pair
290 inline_prag = idInlinePragma gbl_id
291 inlinable_unf = mkInlinableUnfolding rhs
293 | Just arity <- inlinePragmaSat inline_prag
294 -- Add an Unfolding for an INLINE (but not for NOINLINE)
295 -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
296 , let real_arity = dict_arity + arity
297 -- NB: The arity in the InlineRule takes account of the dictionaries
298 = ( gbl_id `setIdUnfolding` mkInlineUnfolding (Just real_arity) rhs
299 , etaExpand real_arity rhs)
302 = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $
303 (gbl_id `setIdUnfolding` mkInlineUnfolding Nothing rhs, rhs)
306 dictArity :: [Var] -> Arity
307 -- Don't count coercion variables in arity
308 dictArity dicts = count isId dicts
311 ------------------------
312 type AbsBindEnv = VarEnv ([TyVar], Id, Id, TcSpecPrags)
313 -- Maps the "lcl_id" for an AbsBind to
314 -- its "gbl_id" and associated pragmas, if any
316 mkABEnv :: [([TyVar], Id, Id, TcSpecPrags)] -> AbsBindEnv
317 -- Takes the exports of a AbsBinds, and returns a mapping
318 -- lcl_id -> (tyvars, gbl_id, lcl_id, prags)
319 mkABEnv exports = mkVarEnv [ (lcl_id, export) | export@(_, _, lcl_id, _) <- exports]
322 Note [Rules and inlining]
323 ~~~~~~~~~~~~~~~~~~~~~~~~~
324 Common special case: no type or dictionary abstraction
325 This is a bit less trivial than you might suppose
326 The naive way woudl be to desguar to something like
327 f_lcl = ...f_lcl... -- The "binds" from AbsBinds
328 M.f = f_lcl -- Generated from "exports"
329 But we don't want that, because if M.f isn't exported,
330 it'll be inlined unconditionally at every call site (its rhs is
331 trivial). That would be ok unless it has RULES, which would
332 thereby be completely lost. Bad, bad, bad.
334 Instead we want to generate
337 Now all is cool. The RULES are attached to M.f (by SimplCore),
338 and f_lcl is rapidly inlined away.
340 This does not happen in the same way to polymorphic binds,
341 because they desugar to
342 M.f = /\a. let f_lcl = ...f_lcl... in f_lcl
343 Although I'm a bit worried about whether full laziness might
344 float the f_lcl binding out and then inline M.f at its call site
346 Note [Specialising in no-dict case]
347 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
348 Even if there are no tyvars or dicts, we may have specialisation pragmas.
349 Class methods can generate
350 AbsBinds [] [] [( ... spec-prag]
351 { AbsBinds [tvs] [dicts] ...blah }
352 So the overloading is in the nested AbsBinds. A good example is in GHC.Float:
354 class (Real a, Fractional a) => RealFrac a where
355 round :: (Integral b) => a -> b
357 instance RealFrac Float where
358 {-# SPECIALIZE round :: Float -> Int #-}
360 The top-level AbsBinds for $cround has no tyvars or dicts (because the
361 instance does not). But the method is locally overloaded!
363 Note [Abstracting over tyvars only]
364 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
365 When abstracting over type variable only (not dictionaries), we don't really need to
366 built a tuple and select from it, as we do in the general case. Instead we can take
368 AbsBinds [a,b] [ ([a,b], fg, fl, _),
376 fg = /\ab. let B in e1
377 gg = /\b. let a = () in let B in S(e2)
378 h = /\ab. let B in e3
380 where B is the *non-recursive* binding
383 h = h a b -- See (b); note shadowing!
385 Notice (a) g has a different number of type variables to f, so we must
386 use the mkArbitraryType thing to fill in the gaps.
387 We use a type-let to do that.
389 (b) The local variable h isn't in the exports, and rather than
390 clone a fresh copy we simply replace h by (h a b), where
391 the two h's have different types! Shadowing happens here,
392 which looks confusing but works fine.
394 (c) The result is *still* quadratic-sized if there are a lot of
395 small bindings. So if there are more than some small
396 number (10), we filter the binding set B by the free
397 variables of the particular RHS. Tiresome.
399 Why got to this trouble? It's a common case, and it removes the
400 quadratic-sized tuple desugaring. Less clutter, hopefullly faster
401 compilation, especially in a case where there are a *lot* of
405 Note [Eta-expanding INLINE things]
406 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
408 foo :: Eq a => a -> a
412 If (foo d) ever gets floated out as a common sub-expression (which can
413 happen as a result of method sharing), there's a danger that we never
414 get to do the inlining, which is a Terribly Bad thing given that the
417 To avoid this we pre-emptively eta-expand the definition, so that foo
418 has the arity with which it is declared in the source code. In this
419 example it has arity 2 (one for the Eq and one for x). Doing this
420 should mean that (foo d) is a PAP and we don't share it.
422 Note [Nested arities]
423 ~~~~~~~~~~~~~~~~~~~~~
424 For reasons that are not entirely clear, method bindings come out looking like
427 AbsBinds [] [] [$cfromT <= [] fromT]
428 $cfromT [InlPrag=INLINE] :: T Bool -> Bool
429 { AbsBinds [] [] [fromT <= [] fromT_1]
430 fromT :: T Bool -> Bool
431 { fromT_1 ((TBool b)) = not b } } }
433 Note the nested AbsBind. The arity for the InlineRule on $cfromT should be
434 gotten from the binding for fromT_1.
436 It might be better to have just one level of AbsBinds, but that requires more
439 Note [Implementing SPECIALISE pragmas]
440 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
442 f :: (Eq a, Ix b) => a -> b -> Bool
443 {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-}
446 From this the typechecker generates
448 AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
450 SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX
451 -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ])
453 Note that wrap_fn can transform *any* function with the right type prefix
454 forall ab. (Eq a, Ix b) => XXX
455 regardless of XXX. It's sort of polymorphic in XXX. This is
456 useful: we use the same wrapper to transform each of the class ops, as
459 From these we generate:
461 Rule: forall p, q, (dp:Ix p), (dq:Ix q).
462 f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq
464 Spec bind: f_spec = wrap_fn <poly_rhs>
468 * The LHS of the rule may mention dictionary *expressions* (eg
469 $dfIxPair dp dq), and that is essential because the dp, dq are
472 * The RHS of f_spec, <poly_rhs> has a *copy* of 'binds', so that it
473 can fully specialise it.
476 ------------------------
477 dsSpecs :: CoreExpr -- Its rhs
479 -> DsM ( OrdList (Id,CoreExpr) -- Binding for specialised Ids
480 , [CoreRule] ) -- Rules for the Global Ids
481 -- See Note [Implementing SPECIALISE pragmas]
482 dsSpecs _ IsDefaultMethod = return (nilOL, [])
483 dsSpecs poly_rhs (SpecPrags sps)
484 = do { pairs <- mapMaybeM (dsSpec (Just poly_rhs)) sps
485 ; let (spec_binds_s, rules) = unzip pairs
486 ; return (concatOL spec_binds_s, rules) }
488 dsSpec :: Maybe CoreExpr -- Just rhs => RULE is for a local binding
489 -- Nothing => RULE is for an imported Id
490 -- rhs is in the Id's unfolding
491 -> Located TcSpecPrag
492 -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
493 dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
495 do { let poly_name = idName poly_id
496 ; spec_name <- newLocalName poly_name
497 ; wrap_fn <- dsHsWrapper spec_co
498 ; let (bndrs, ds_lhs) = collectBinders (wrap_fn (Var poly_id))
499 spec_ty = mkPiTypes bndrs (exprType ds_lhs)
500 ; case decomposeRuleLhs ds_lhs of {
501 Nothing -> do { warnDs (decomp_msg spec_co)
506 -- Check for dead binders: Note [Unused spec binders]
507 let arg_fvs = exprsFreeVars args
508 bad_bndrs = filterOut (`elemVarSet` arg_fvs) bndrs
509 in if not (null bad_bndrs)
510 then do { warnDs (dead_msg bad_bndrs); return Nothing }
513 { (spec_unf, unf_pairs) <- specUnfolding wrap_fn spec_ty (realIdUnfolding poly_id)
515 ; let spec_id = mkLocalId spec_name spec_ty
516 `setInlinePragma` inl_prag
517 `setIdUnfolding` spec_unf
518 inl_prag | isDefaultInlinePragma spec_inl = idInlinePragma poly_id
519 | otherwise = spec_inl
520 -- Get the INLINE pragma from SPECIALISE declaration, or,
521 -- failing that, from the original Id
523 extra_dict_bndrs = [ mkLocalId (localiseName (idName d)) (idType d)
524 -- See Note [Constant rule dicts]
525 | d <- varSetElems (arg_fvs `delVarSetList` bndrs)
528 rule = mkRule False {- Not auto -} is_local_id
529 (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
530 AlwaysActive poly_name
531 (extra_dict_bndrs ++ bndrs) args
532 (mkVarApps (Var spec_id) bndrs)
534 spec_rhs = wrap_fn poly_rhs
535 spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs
537 ; return (Just (spec_pair `consOL` unf_pairs, rule))
540 dead_msg bs = vcat [ sep [ptext (sLit "Useless constraint") <> plural bs
541 <+> ptext (sLit "in specialied type:"),
542 nest 2 (pprTheta (map get_pred bs))]
543 , ptext (sLit "SPECIALISE pragma ignored")]
544 get_pred b = ASSERT( isId b ) expectJust "dsSpec" (tcSplitPredTy_maybe (idType b))
547 = hang (ptext (sLit "Specialisation too complicated to desugar; ignored"))
548 2 (pprHsWrapper (ppr poly_id) spec_co)
550 is_local_id = isJust mb_poly_rhs
551 poly_rhs | Just rhs <- mb_poly_rhs
553 | Just unfolding <- maybeUnfoldingTemplate (idUnfolding poly_id)
555 | otherwise = pprPanic "dsImpSpecs" (ppr poly_id)
556 -- In the Nothing case the specialisation is for an imported Id
557 -- whose unfolding gives the RHS to be specialised
558 -- The type checker has checked that it has an unfolding
560 specUnfolding :: (CoreExpr -> CoreExpr) -> Type
561 -> Unfolding -> DsM (Unfolding, OrdList (Id,CoreExpr))
562 specUnfolding wrap_fn spec_ty (DFunUnfolding _ _ ops)
563 = do { let spec_rhss = map wrap_fn ops
564 ; spec_ids <- mapM (mkSysLocalM (fsLit "spec") . exprType) spec_rhss
565 ; return (mkDFunUnfolding spec_ty (map Var spec_ids), toOL (spec_ids `zip` spec_rhss)) }
567 = return (noUnfolding, nilOL)
570 mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> TyVarEnv Type
571 -- If any of the tyvars is missing from any of the lists in
572 -- the second arg, return a binding in the result
573 mkArbitraryTypeEnv tyvars exports
574 = go emptyVarEnv exports
577 go env ((ltvs, _, _, _) : exports)
580 env' = foldl extend env [tv | tv <- tyvars
581 , not (tv `elem` ltvs)
582 , not (tv `elemVarEnv` env)]
584 extend env tv = extendVarEnv env tv (dsMkArbitraryType tv)
587 dsMkArbitraryType :: TcTyVar -> Type
588 dsMkArbitraryType tv = anyTypeOfKind (tyVarKind tv)
591 Note [Unused spec binders]
592 ~~~~~~~~~~~~~~~~~~~~~~~~~~
595 {-# SPECIALISE f :: Eq a => a -> a #-}
596 It's true that this *is* a more specialised type, but the rule
597 we get is something like this:
600 Note that the rule is bogus, becuase it mentions a 'd' that is
601 not bound on the LHS! But it's a silly specialisation anyway, becuase
602 the constraint is unused. We could bind 'd' to (error "unused")
603 but it seems better to reject the program because it's almost certainly
604 a mistake. That's what the isDeadBinder call detects.
606 Note [Constant rule dicts]
607 ~~~~~~~~~~~~~~~~~~~~~~~
608 When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,
609 which is presumably in scope at the function definition site, we can quantify
610 over it too. *Any* dict with that type will do.
612 So for example when you have
615 {-# SPECIALISE f :: Int -> Int #-}
617 Then we get the SpecPrag
618 SpecPrag (f Int dInt)
620 And from that we want the rule
622 RULE forall dInt. f Int dInt = f_spec
623 f_spec = let f = <rhs> in f Int dInt
625 But be careful! That dInt might be GHC.Base.$fOrdInt, which is an External
626 Name, and you can't bind them in a lambda or forall without getting things
627 confused. Likewise it might have an InlineRule or something, which would be
628 utterly bogus. So we really make a fresh Id, with the same unique and type
629 as the old one, but with an Internal name and no IdInfo.
631 %************************************************************************
633 \subsection{Adding inline pragmas}
635 %************************************************************************
638 decomposeRuleLhs :: CoreExpr -> Maybe (Id, [CoreExpr])
639 -- Take apart the LHS of a RULE. It's suuposed to look like
640 -- /\a. f a Int dOrdInt
641 -- or /\a.\d:Ord a. let { dl::Ord [a] = dOrdList a d } in f [a] dl
642 -- That is, the RULE binders are lambda-bound
643 -- Returns Nothing if the LHS isn't of the expected shape
645 = -- Note [Simplifying the left-hand side of a RULE]
646 case collectArgs (simpleOptExpr lhs) of
647 (Var fn, args) -> Just (fn, args)
649 (Case scrut bndr ty [(DEFAULT, _, body)], args)
650 | isDeadBinder bndr -- Note [Matching seqId]
651 -> Just (seqId, args' ++ args)
653 args' = [Type (idType bndr), Type ty, scrut, body]
655 _other -> Nothing -- Unexpected shape
658 Note [Simplifying the left-hand side of a RULE]
659 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
660 simpleOptExpr occurrence-analyses and simplifies the lhs
662 (a) sorts dict bindings into NonRecs and inlines them
663 (b) substitute trivial lets so that they don't get in the way
664 Note that we substitute the function too; we might
665 have this as a LHS: let f71 = M.f Int in f71
666 (c) does eta reduction
668 For (c) consider the fold/build rule, which without simplification
670 fold k z (build (/\a. g a)) ==> ...
671 This doesn't match unless you do eta reduction on the build argument.
672 Similarly for a LHS like
674 we do not want to get
675 augment (\a. g a) (build h)
676 otherwise we don't match when given an argument like
677 augment (\a. h a a) (build h)
679 NB: tcSimplifyRuleLhs is very careful not to generate complicated
680 dictionary expressions that we might have to match
683 Note [Matching seqId]
685 The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
686 and this code turns it back into an application of seq!
687 See Note [Rules for seq] in MkId for the details.
690 %************************************************************************
692 \subsection[addAutoScc]{Adding automatic sccs}
694 %************************************************************************
697 data AutoScc = NoSccs
698 | AddSccs Module (Id -> Bool)
699 -- The (Id->Bool) says which Ids to add SCCs to
700 -- But we never add a SCC to function marked INLINE
702 addAutoScc :: AutoScc
705 -> CoreExpr -- Scc'd Rhs
707 addAutoScc NoSccs _ rhs
709 addAutoScc _ id rhs | isInlinePragma (idInlinePragma id)
711 addAutoScc (AddSccs mod add_scc) id rhs
712 | add_scc id = mkSCC (mkAutoCC id mod NotCafCC) rhs
716 If profiling and dealing with a dict binding,
717 wrap the dict in @_scc_ DICT <dict>@:
720 addDictScc :: Id -> CoreExpr -> DsM CoreExpr
721 addDictScc _ rhs = return rhs
723 {- DISABLED for now (need to somehow make up a name for the scc) -- SDM
724 | not ( opt_SccProfilingOn && opt_AutoSccsOnDicts)
725 || not (isDictId var)
726 = return rhs -- That's easy: do nothing
729 = do (mod, grp) <- getModuleAndGroupDs
730 -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
731 return (Note (SCC (mkAllDictsCC mod grp False)) rhs)
736 %************************************************************************
740 %************************************************************************
744 dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
745 dsHsWrapper WpHole = return (\e -> e)
746 dsHsWrapper (WpTyApp ty) = return (\e -> App e (Type ty))
747 dsHsWrapper (WpLet ev_binds) = do { ds_ev_binds <- dsTcEvBinds ev_binds
748 ; return (wrapDsEvBinds ds_ev_binds) }
749 dsHsWrapper (WpCompose c1 c2) = do { k1 <- dsHsWrapper c1
750 ; k2 <- dsHsWrapper c2
752 dsHsWrapper (WpCast co) = return (\e -> Cast e co)
753 dsHsWrapper (WpEvLam ev) = return (\e -> Lam ev e)
754 dsHsWrapper (WpTyLam tv) = return (\e -> Lam tv e)
755 dsHsWrapper (WpEvApp evtrm) = return (\e -> App e (dsEvTerm evtrm))