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,
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 [(Id,CoreExpr)]
73 dsTopLHsBinds auto_scc binds = do { binds' <- ds_lhs_binds auto_scc binds
74 ; return (fromOL binds') }
76 dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
77 dsLHsBinds binds = do { binds' <- ds_lhs_binds NoSccs binds
78 ; return (fromOL binds') }
80 ------------------------
81 ds_lhs_binds :: AutoScc -> LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
83 -- scc annotation policy (see below)
84 ds_lhs_binds auto_scc binds = do { ds_bs <- mapBagM (dsLHsBind auto_scc) binds
85 ; return (foldBag appOL id nilOL ds_bs) }
87 dsLHsBind :: AutoScc -> LHsBind Id -> DsM (OrdList (Id,CoreExpr))
88 dsLHsBind auto_scc (L loc bind)
89 = putSrcSpanDs loc $ dsHsBind auto_scc bind
91 dsHsBind :: AutoScc -> HsBind Id -> DsM (OrdList (Id,CoreExpr))
93 dsHsBind _ (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 (unitOL (var', core_expr')) }
104 dsHsBind _ (FunBind { fun_id = L _ fun, fun_matches = matches
105 , fun_co_fn = co_fn, fun_tick = tick
107 = do { (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches
108 ; body' <- mkOptTickBox tick body
109 ; wrap_fn' <- dsHsWrapper co_fn
110 ; let rhs = wrap_fn' (mkLams args body')
111 ; return (unitOL (makeCorePair fun False 0 rhs)) }
113 dsHsBind _ (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 -- We silently ignore inline pragmas; no makeCorePair
117 -- Not so cool, but really doesn't matter
118 ; return (toOL sel_binds) }
120 -- A common case: one exported variable
121 -- Non-recursive bindings come through this way
122 -- So do self-recursive bindings, and recursive bindings
123 -- that have been chopped up with type signatures
124 dsHsBind auto_scc (AbsBinds { abs_tvs = all_tyvars, abs_ev_vars = dicts
125 , abs_exports = [(tyvars, global, local, prags)]
126 , abs_ev_binds = ev_binds, abs_binds = binds })
127 = ASSERT( all (`elem` tyvars) all_tyvars )
128 do { bind_prs <- ds_lhs_binds NoSccs binds
129 ; ds_ev_binds <- dsTcEvBinds ev_binds
131 ; let core_bind = Rec (fromOL bind_prs)
132 rhs = addAutoScc auto_scc global $
133 mkLams tyvars $ mkLams dicts $
134 wrapDsEvBinds ds_ev_binds $
138 ; (spec_binds, rules) <- dsSpecs global rhs prags
140 ; let global' = addIdSpecialisations global rules
141 main_bind = makeCorePair global' (isDefaultMethod prags)
142 (dictArity dicts) rhs
144 ; return (main_bind `consOL` spec_binds) }
146 dsHsBind auto_scc (AbsBinds { abs_tvs = all_tyvars, abs_ev_vars = dicts
147 , abs_exports = exports, abs_ev_binds = ev_binds
148 , abs_binds = binds })
149 = do { bind_prs <- ds_lhs_binds NoSccs binds
150 ; ds_ev_binds <- dsTcEvBinds ev_binds
151 ; let env = mkABEnv exports
152 do_one (lcl_id,rhs) | Just (_, gbl_id, _, _prags) <- lookupVarEnv env lcl_id
153 = (lcl_id, addAutoScc auto_scc gbl_id rhs)
154 | otherwise = (lcl_id,rhs)
156 core_bind = Rec (map do_one (fromOL bind_prs))
157 -- Monomorphic recursion possible, hence Rec
159 tup_expr = mkBigCoreVarTup locals
160 tup_ty = exprType tup_expr
161 poly_tup_rhs = mkLams all_tyvars $ mkLams dicts $
162 wrapDsEvBinds ds_ev_binds $
165 locals = [local | (_, _, local, _) <- exports]
166 local_tys = map idType locals
168 ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
170 ; let mk_bind ((tyvars, global, _, spec_prags), n) -- locals!!n == local
171 = -- Need to make fresh locals to bind in the selector,
172 -- because some of the tyvars will be bound to 'Any'
173 do { let ty_args = map mk_ty_arg all_tyvars
174 substitute = substTyWith all_tyvars ty_args
175 ; locals' <- newSysLocalsDs (map substitute local_tys)
176 ; tup_id <- newSysLocalDs (substitute tup_ty)
177 ; let rhs = mkLams tyvars $ mkLams dicts $
178 mkTupleSelector locals' (locals' !! n) tup_id $
179 mkVarApps (mkTyApps (Var poly_tup_id) ty_args)
181 ; (spec_binds, rules) <- dsSpecs global
182 (Let (NonRec poly_tup_id poly_tup_rhs) rhs)
184 ; let global' = addIdSpecialisations global rules
185 ; return ((global', rhs) `consOL` spec_binds) }
188 | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
189 | otherwise = dsMkArbitraryType all_tyvar
191 ; export_binds_s <- mapM mk_bind (exports `zip` [0..])
192 -- Don't scc (auto-)annotate the tuple itself.
194 ; return ((poly_tup_id, poly_tup_rhs) `consOL`
195 concatOL export_binds_s) }
197 --------------------------------------
199 = LetEvBind -- Dictionary or coercion
200 CoreBind -- recursive or non-recursive
202 | CaseEvBind -- Coercion binding by superclass selection
203 -- Desugars to case d of d { K _ g _ _ _ -> ... }
204 DictId -- b The dictionary
205 AltCon -- K Its constructor
206 [CoreBndr] -- _ g _ _ _ The binders in the alternative
208 wrapDsEvBinds :: [DsEvBind] -> CoreExpr -> CoreExpr
209 wrapDsEvBinds ds_ev_binds body = foldr wrap_one body ds_ev_binds
211 body_ty = exprType body
212 wrap_one (LetEvBind b) body = Let b body
213 wrap_one (CaseEvBind x k xs) body = Case (Var x) x body_ty [(k,xs,body)]
215 dsTcEvBinds :: TcEvBinds -> DsM [DsEvBind]
216 dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this
217 dsTcEvBinds (EvBinds bs) = dsEvBinds bs
219 dsEvBinds :: Bag EvBind -> DsM [DsEvBind]
220 dsEvBinds bs = return (map dsEvGroup sccs)
223 sccs = stronglyConnCompFromEdgedVertices edges
225 edges :: [(EvBind, EvVar, [EvVar])]
226 edges = foldrBag ((:) . mk_node) [] bs
228 mk_node :: EvBind -> (EvBind, EvVar, [EvVar])
229 mk_node b@(EvBind var term) = (b, var, free_vars_of term)
231 free_vars_of :: EvTerm -> [EvVar]
232 free_vars_of (EvId v) = [v]
233 free_vars_of (EvCast v co) = v : varSetElems (tyVarsOfType co)
234 free_vars_of (EvCoercion co) = varSetElems (tyVarsOfType co)
235 free_vars_of (EvDFunApp _ _ vs) = vs
236 free_vars_of (EvSuperClass d _) = [d]
238 dsEvGroup :: SCC EvBind -> DsEvBind
239 dsEvGroup (AcyclicSCC (EvBind co_var (EvSuperClass dict n)))
240 | isCoVar co_var -- An equality superclass
241 = ASSERT( null other_data_cons )
242 CaseEvBind dict (DataAlt data_con) bndrs
244 (cls, tys) = getClassPredTys (evVarPred dict)
245 (data_con:other_data_cons) = tyConDataCons (classTyCon cls)
246 (ex_tvs, theta, rho) = tcSplitSigmaTy (applyTys (dataConRepType data_con) tys)
247 (arg_tys, _) = splitFunTys rho
248 bndrs = ex_tvs ++ map mk_wild_pred (theta `zip` [0..])
249 ++ map mkWildValBinder arg_tys
250 mk_wild_pred (p, i) | i==n = ASSERT( p `tcEqPred` (coVarPred co_var))
252 | otherwise = mkWildEvBinder p
254 dsEvGroup (AcyclicSCC (EvBind v r))
255 = LetEvBind (NonRec v (dsEvTerm r))
257 dsEvGroup (CyclicSCC bs)
258 = LetEvBind (Rec (map ds_pair bs))
260 ds_pair (EvBind v r) = (v, dsEvTerm r)
262 dsEvTerm :: EvTerm -> CoreExpr
263 dsEvTerm (EvId v) = Var v
264 dsEvTerm (EvCast v co) = Cast (Var v) co
265 dsEvTerm (EvDFunApp df tys vars) = Var df `mkTyApps` tys `mkVarApps` vars
266 dsEvTerm (EvCoercion co) = Type co
267 dsEvTerm (EvSuperClass d n)
268 = ASSERT( isClassPred (classSCTheta cls !! n) )
269 -- We can only select *dictionary* superclasses
270 -- in terms. Equality superclasses are dealt with
271 -- in dsEvGroup, where they can generate a case expression
272 Var sc_sel_id `mkTyApps` tys `App` Var d
274 sc_sel_id = classSCSelId cls n -- Zero-indexed
275 (cls, tys) = getClassPredTys (evVarPred d)
277 ------------------------
278 makeCorePair :: Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr)
279 makeCorePair gbl_id is_default_method dict_arity rhs
280 | is_default_method -- Default methods are *always* inlined
281 = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs)
284 = case inlinePragmaSpec inline_prag of
285 EmptyInlineSpec -> (gbl_id, rhs)
286 NoInline -> (gbl_id, rhs)
287 Inlinable -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)
288 Inline -> inline_pair
291 inline_prag = idInlinePragma gbl_id
292 inlinable_unf = mkInlinableUnfolding rhs
294 | Just arity <- inlinePragmaSat inline_prag
295 -- Add an Unfolding for an INLINE (but not for NOINLINE)
296 -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
297 , let real_arity = dict_arity + arity
298 -- NB: The arity in the InlineRule takes account of the dictionaries
299 = ( gbl_id `setIdUnfolding` mkInlineUnfolding (Just real_arity) rhs
300 , etaExpand real_arity rhs)
303 = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $
304 (gbl_id `setIdUnfolding` mkInlineUnfolding Nothing rhs, rhs)
307 dictArity :: [Var] -> Arity
308 -- Don't count coercion variables in arity
309 dictArity dicts = count isId dicts
312 ------------------------
313 type AbsBindEnv = VarEnv ([TyVar], Id, Id, TcSpecPrags)
314 -- Maps the "lcl_id" for an AbsBind to
315 -- its "gbl_id" and associated pragmas, if any
317 mkABEnv :: [([TyVar], Id, Id, TcSpecPrags)] -> AbsBindEnv
318 -- Takes the exports of a AbsBinds, and returns a mapping
319 -- lcl_id -> (tyvars, gbl_id, lcl_id, prags)
320 mkABEnv exports = mkVarEnv [ (lcl_id, export) | export@(_, _, lcl_id, _) <- exports]
323 Note [Rules and inlining]
324 ~~~~~~~~~~~~~~~~~~~~~~~~~
325 Common special case: no type or dictionary abstraction
326 This is a bit less trivial than you might suppose
327 The naive way woudl be to desguar to something like
328 f_lcl = ...f_lcl... -- The "binds" from AbsBinds
329 M.f = f_lcl -- Generated from "exports"
330 But we don't want that, because if M.f isn't exported,
331 it'll be inlined unconditionally at every call site (its rhs is
332 trivial). That would be ok unless it has RULES, which would
333 thereby be completely lost. Bad, bad, bad.
335 Instead we want to generate
338 Now all is cool. The RULES are attached to M.f (by SimplCore),
339 and f_lcl is rapidly inlined away.
341 This does not happen in the same way to polymorphic binds,
342 because they desugar to
343 M.f = /\a. let f_lcl = ...f_lcl... in f_lcl
344 Although I'm a bit worried about whether full laziness might
345 float the f_lcl binding out and then inline M.f at its call site
347 Note [Specialising in no-dict case]
348 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
349 Even if there are no tyvars or dicts, we may have specialisation pragmas.
350 Class methods can generate
351 AbsBinds [] [] [( ... spec-prag]
352 { AbsBinds [tvs] [dicts] ...blah }
353 So the overloading is in the nested AbsBinds. A good example is in GHC.Float:
355 class (Real a, Fractional a) => RealFrac a where
356 round :: (Integral b) => a -> b
358 instance RealFrac Float where
359 {-# SPECIALIZE round :: Float -> Int #-}
361 The top-level AbsBinds for $cround has no tyvars or dicts (because the
362 instance does not). But the method is locally overloaded!
364 Note [Abstracting over tyvars only]
365 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
366 When abstracting over type variable only (not dictionaries), we don't really need to
367 built a tuple and select from it, as we do in the general case. Instead we can take
369 AbsBinds [a,b] [ ([a,b], fg, fl, _),
377 fg = /\ab. let B in e1
378 gg = /\b. let a = () in let B in S(e2)
379 h = /\ab. let B in e3
381 where B is the *non-recursive* binding
384 h = h a b -- See (b); note shadowing!
386 Notice (a) g has a different number of type variables to f, so we must
387 use the mkArbitraryType thing to fill in the gaps.
388 We use a type-let to do that.
390 (b) The local variable h isn't in the exports, and rather than
391 clone a fresh copy we simply replace h by (h a b), where
392 the two h's have different types! Shadowing happens here,
393 which looks confusing but works fine.
395 (c) The result is *still* quadratic-sized if there are a lot of
396 small bindings. So if there are more than some small
397 number (10), we filter the binding set B by the free
398 variables of the particular RHS. Tiresome.
400 Why got to this trouble? It's a common case, and it removes the
401 quadratic-sized tuple desugaring. Less clutter, hopefullly faster
402 compilation, especially in a case where there are a *lot* of
406 Note [Eta-expanding INLINE things]
407 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
409 foo :: Eq a => a -> a
413 If (foo d) ever gets floated out as a common sub-expression (which can
414 happen as a result of method sharing), there's a danger that we never
415 get to do the inlining, which is a Terribly Bad thing given that the
418 To avoid this we pre-emptively eta-expand the definition, so that foo
419 has the arity with which it is declared in the source code. In this
420 example it has arity 2 (one for the Eq and one for x). Doing this
421 should mean that (foo d) is a PAP and we don't share it.
423 Note [Nested arities]
424 ~~~~~~~~~~~~~~~~~~~~~
425 For reasons that are not entirely clear, method bindings come out looking like
428 AbsBinds [] [] [$cfromT <= [] fromT]
429 $cfromT [InlPrag=INLINE] :: T Bool -> Bool
430 { AbsBinds [] [] [fromT <= [] fromT_1]
431 fromT :: T Bool -> Bool
432 { fromT_1 ((TBool b)) = not b } } }
434 Note the nested AbsBind. The arity for the InlineRule on $cfromT should be
435 gotten from the binding for fromT_1.
437 It might be better to have just one level of AbsBinds, but that requires more
440 Note [Implementing SPECIALISE pragmas]
441 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
443 f :: (Eq a, Ix b) => a -> b -> Bool
444 {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-}
447 From this the typechecker generates
449 AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
451 SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX
452 -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ])
454 Note that wrap_fn can transform *any* function with the right type prefix
455 forall ab. (Eq a, Ix b) => XXX
456 regardless of XXX. It's sort of polymorphic in XXX. This is
457 useful: we use the same wrapper to transform each of the class ops, as
460 From these we generate:
462 Rule: forall p, q, (dp:Ix p), (dq:Ix q).
463 f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq
465 Spec bind: f_spec = wrap_fn <poly_rhs>
469 * The LHS of the rule may mention dictionary *expressions* (eg
470 $dfIxPair dp dq), and that is essential because the dp, dq are
473 * The RHS of f_spec, <poly_rhs> has a *copy* of 'binds', so that it
474 can fully specialise it.
477 ------------------------
478 dsSpecs :: Id -- The polymorphic Id
479 -> CoreExpr -- Its rhs
481 -> DsM ( OrdList (Id,CoreExpr) -- Binding for specialised Ids
482 , [CoreRule] ) -- Rules for the Global Ids
483 -- See Note [Implementing SPECIALISE pragmas]
484 dsSpecs poly_id poly_rhs prags
486 IsDefaultMethod -> return (nilOL, [])
487 SpecPrags sps -> do { pairs <- mapMaybeM spec_one sps
488 ; let (spec_binds_s, rules) = unzip pairs
489 ; return (concatOL spec_binds_s, rules) }
491 spec_one :: Located TcSpecPrag -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
492 spec_one (L loc (SpecPrag spec_co spec_inl))
494 do { let poly_name = idName poly_id
495 ; spec_name <- newLocalName poly_name
496 ; wrap_fn <- dsHsWrapper spec_co
497 ; let (bndrs, ds_lhs) = collectBinders (wrap_fn (Var poly_id))
498 spec_ty = mkPiTypes bndrs (exprType ds_lhs)
499 ; case decomposeRuleLhs ds_lhs of {
500 Nothing -> do { warnDs (decomp_msg spec_co)
505 -- Check for dead binders: Note [Unused spec binders]
506 let arg_fvs = exprsFreeVars args
507 bad_bndrs = filterOut (`elemVarSet` arg_fvs) bndrs
508 in if not (null bad_bndrs)
509 then do { warnDs (dead_msg bad_bndrs); return Nothing }
512 { (spec_unf, unf_pairs) <- specUnfolding wrap_fn spec_ty (realIdUnfolding poly_id)
514 ; let spec_id = mkLocalId spec_name spec_ty
515 `setInlinePragma` inl_prag
516 `setIdUnfolding` spec_unf
517 inl_prag | isDefaultInlinePragma spec_inl = idInlinePragma poly_id
518 | otherwise = spec_inl
519 -- Get the INLINE pragma from SPECIALISE declaration, or,
520 -- failing that, from the original Id
522 extra_dict_bndrs = [ mkLocalId (localiseName (idName d)) (idType d)
523 -- See Note [Constant rule dicts]
524 | d <- varSetElems (arg_fvs `delVarSetList` bndrs)
527 rule = mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
528 AlwaysActive poly_name
529 (extra_dict_bndrs ++ bndrs) args
530 (mkVarApps (Var spec_id) bndrs)
532 spec_rhs = wrap_fn poly_rhs
533 spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs
535 ; return (Just (spec_pair `consOL` unf_pairs, rule))
538 dead_msg bs = vcat [ sep [ptext (sLit "Useless constraint") <> plural bs
539 <+> ptext (sLit "in specialied type:"),
540 nest 2 (pprTheta (map get_pred bs))]
541 , ptext (sLit "SPECIALISE pragma ignored")]
542 get_pred b = ASSERT( isId b ) expectJust "dsSpec" (tcSplitPredTy_maybe (idType b))
545 = hang (ptext (sLit "Specialisation too complicated to desugar; ignored"))
546 2 (pprHsWrapper (ppr poly_id) spec_co)
549 specUnfolding :: (CoreExpr -> CoreExpr) -> Type
550 -> Unfolding -> DsM (Unfolding, OrdList (Id,CoreExpr))
551 specUnfolding wrap_fn spec_ty (DFunUnfolding _ _ ops)
552 = do { let spec_rhss = map wrap_fn ops
553 ; spec_ids <- mapM (mkSysLocalM (fsLit "spec") . exprType) spec_rhss
554 ; return (mkDFunUnfolding spec_ty (map Var spec_ids), toOL (spec_ids `zip` spec_rhss)) }
556 = return (noUnfolding, nilOL)
559 mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> TyVarEnv Type
560 -- If any of the tyvars is missing from any of the lists in
561 -- the second arg, return a binding in the result
562 mkArbitraryTypeEnv tyvars exports
563 = go emptyVarEnv exports
566 go env ((ltvs, _, _, _) : exports)
569 env' = foldl extend env [tv | tv <- tyvars
570 , not (tv `elem` ltvs)
571 , not (tv `elemVarEnv` env)]
573 extend env tv = extendVarEnv env tv (dsMkArbitraryType tv)
576 dsMkArbitraryType :: TcTyVar -> Type
577 dsMkArbitraryType tv = anyTypeOfKind (tyVarKind tv)
580 Note [Unused spec binders]
581 ~~~~~~~~~~~~~~~~~~~~~~~~~~
584 {-# SPECIALISE f :: Eq a => a -> a #-}
585 It's true that this *is* a more specialised type, but the rule
586 we get is something like this:
589 Note that the rule is bogus, becuase it mentions a 'd' that is
590 not bound on the LHS! But it's a silly specialisation anyway, becuase
591 the constraint is unused. We could bind 'd' to (error "unused")
592 but it seems better to reject the program because it's almost certainly
593 a mistake. That's what the isDeadBinder call detects.
595 Note [Constant rule dicts]
596 ~~~~~~~~~~~~~~~~~~~~~~~
597 When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,
598 which is presumably in scope at the function definition site, we can quantify
599 over it too. *Any* dict with that type will do.
601 So for example when you have
604 {-# SPECIALISE f :: Int -> Int #-}
606 Then we get the SpecPrag
607 SpecPrag (f Int dInt)
609 And from that we want the rule
611 RULE forall dInt. f Int dInt = f_spec
612 f_spec = let f = <rhs> in f Int dInt
614 But be careful! That dInt might be GHC.Base.$fOrdInt, which is an External
615 Name, and you can't bind them in a lambda or forall without getting things
616 confused. Likewise it might have an InlineRule or something, which would be
617 utterly bogus. So we really make a fresh Id, with the same unique and type
618 as the old one, but with an Internal name and no IdInfo.
620 %************************************************************************
622 \subsection{Adding inline pragmas}
624 %************************************************************************
627 decomposeRuleLhs :: CoreExpr -> Maybe (Id, [CoreExpr])
628 -- Take apart the LHS of a RULE. It's suuposed to look like
629 -- /\a. f a Int dOrdInt
630 -- or /\a.\d:Ord a. let { dl::Ord [a] = dOrdList a d } in f [a] dl
631 -- That is, the RULE binders are lambda-bound
632 -- Returns Nothing if the LHS isn't of the expected shape
634 = -- Note [Simplifying the left-hand side of a RULE]
635 case collectArgs (simpleOptExpr lhs) of
636 (Var fn, args) -> Just (fn, args)
638 (Case scrut bndr ty [(DEFAULT, _, body)], args)
639 | isDeadBinder bndr -- Note [Matching seqId]
640 -> Just (seqId, args' ++ args)
642 args' = [Type (idType bndr), Type ty, scrut, body]
644 _other -> Nothing -- Unexpected shape
647 Note [Simplifying the left-hand side of a RULE]
648 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
649 simpleOptExpr occurrence-analyses and simplifies the lhs
651 (a) sorts dict bindings into NonRecs and inlines them
652 (b) substitute trivial lets so that they don't get in the way
653 Note that we substitute the function too; we might
654 have this as a LHS: let f71 = M.f Int in f71
655 (c) does eta reduction
657 For (c) consider the fold/build rule, which without simplification
659 fold k z (build (/\a. g a)) ==> ...
660 This doesn't match unless you do eta reduction on the build argument.
661 Similarly for a LHS like
663 we do not want to get
664 augment (\a. g a) (build h)
665 otherwise we don't match when given an argument like
666 augment (\a. h a a) (build h)
668 NB: tcSimplifyRuleLhs is very careful not to generate complicated
669 dictionary expressions that we might have to match
672 Note [Matching seqId]
674 The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
675 and this code turns it back into an application of seq!
676 See Note [Rules for seq] in MkId for the details.
679 %************************************************************************
681 \subsection[addAutoScc]{Adding automatic sccs}
683 %************************************************************************
686 data AutoScc = NoSccs
687 | AddSccs Module (Id -> Bool)
688 -- The (Id->Bool) says which Ids to add SCCs to
689 -- But we never add a SCC to function marked INLINE
691 addAutoScc :: AutoScc
694 -> CoreExpr -- Scc'd Rhs
696 addAutoScc NoSccs _ rhs
698 addAutoScc _ id rhs | isInlinePragma (idInlinePragma id)
700 addAutoScc (AddSccs mod add_scc) id rhs
701 | add_scc id = mkSCC (mkAutoCC id mod NotCafCC) rhs
705 If profiling and dealing with a dict binding,
706 wrap the dict in @_scc_ DICT <dict>@:
709 addDictScc :: Id -> CoreExpr -> DsM CoreExpr
710 addDictScc _ rhs = return rhs
712 {- DISABLED for now (need to somehow make up a name for the scc) -- SDM
713 | not ( opt_SccProfilingOn && opt_AutoSccsOnDicts)
714 || not (isDictId var)
715 = return rhs -- That's easy: do nothing
718 = do (mod, grp) <- getModuleAndGroupDs
719 -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
720 return (Note (SCC (mkAllDictsCC mod grp False)) rhs)
725 %************************************************************************
729 %************************************************************************
733 dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
734 dsHsWrapper WpHole = return (\e -> e)
735 dsHsWrapper (WpTyApp ty) = return (\e -> App e (Type ty))
736 dsHsWrapper (WpLet ev_binds) = do { ds_ev_binds <- dsTcEvBinds ev_binds
737 ; return (wrapDsEvBinds ds_ev_binds) }
738 dsHsWrapper (WpCompose c1 c2) = do { k1 <- dsHsWrapper c1
739 ; k2 <- dsHsWrapper c2
741 dsHsWrapper (WpCast co) = return (\e -> Cast e co)
742 dsHsWrapper (WpEvLam ev) = return (\e -> Lam ev e)
743 dsHsWrapper (WpTyLam tv) = return (\e -> Lam tv e)
744 dsHsWrapper (WpEvApp evtrm) = return (\e -> App e (dsEvTerm evtrm))