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 )
40 import TysPrim ( anyTypeOfKind )
44 import TyCon ( tyConDataCons )
46 import DataCon ( dataConRepType )
47 import Name ( localiseName )
58 import BasicTypes hiding ( TopLevel )
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 (makeCorePair var' False 0 core_expr')) }
103 dsHsBind auto_scc (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 = addAutoScc auto_scc fun $ wrap_fn' (mkLams args body')
110 ; return (unitOL (makeCorePair fun False 0 rhs)) }
112 dsHsBind auto_scc (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 ; let sel_binds' = [ (v, addAutoScc auto_scc v expr)
118 | (v, expr) <- sel_binds ]
119 ; return (toOL sel_binds') }
121 -- A common case: one exported variable
122 -- Non-recursive bindings come through this way
123 -- So do self-recursive bindings, and recursive bindings
124 -- that have been chopped up with type signatures
125 dsHsBind auto_scc (AbsBinds { abs_tvs = all_tyvars, abs_ev_vars = dicts
126 , abs_exports = [(tyvars, global, local, prags)]
127 , abs_ev_binds = ev_binds, abs_binds = binds })
128 = ASSERT( all (`elem` tyvars) all_tyvars )
129 do { bind_prs <- ds_lhs_binds NoSccs binds
130 ; ds_ev_binds <- dsTcEvBinds ev_binds
132 ; let core_bind = Rec (fromOL bind_prs)
133 rhs = addAutoScc auto_scc global $
134 mkLams tyvars $ mkLams dicts $
135 wrapDsEvBinds ds_ev_binds $
139 ; (spec_binds, rules) <- dsSpecs rhs prags
141 ; let global' = addIdSpecialisations global rules
142 main_bind = makeCorePair global' (isDefaultMethod prags)
143 (dictArity dicts) rhs
145 ; return (main_bind `consOL` spec_binds) }
147 dsHsBind auto_scc (AbsBinds { abs_tvs = all_tyvars, abs_ev_vars = dicts
148 , abs_exports = exports, abs_ev_binds = ev_binds
149 , abs_binds = binds })
150 = do { bind_prs <- ds_lhs_binds NoSccs binds
151 ; ds_ev_binds <- dsTcEvBinds ev_binds
152 ; let env = mkABEnv exports
153 do_one (lcl_id,rhs) | Just (_, gbl_id, _, _prags) <- lookupVarEnv env lcl_id
154 = (lcl_id, addAutoScc auto_scc gbl_id rhs)
155 | otherwise = (lcl_id,rhs)
157 core_bind = Rec (map do_one (fromOL bind_prs))
158 -- Monomorphic recursion possible, hence Rec
160 tup_expr = mkBigCoreVarTup locals
161 tup_ty = exprType tup_expr
162 poly_tup_rhs = mkLams all_tyvars $ mkLams dicts $
163 wrapDsEvBinds ds_ev_binds $
166 locals = [local | (_, _, local, _) <- exports]
167 local_tys = map idType locals
169 ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
171 ; let mk_bind ((tyvars, global, _, spec_prags), n) -- locals!!n == local
172 = -- Need to make fresh locals to bind in the selector,
173 -- because some of the tyvars will be bound to 'Any'
174 do { let ty_args = map mk_ty_arg all_tyvars
175 substitute = substTyWith all_tyvars ty_args
176 ; locals' <- newSysLocalsDs (map substitute local_tys)
177 ; tup_id <- newSysLocalDs (substitute tup_ty)
178 ; let rhs = mkLams tyvars $ mkLams dicts $
179 mkTupleSelector locals' (locals' !! n) tup_id $
180 mkVarApps (mkTyApps (Var poly_tup_id) ty_args)
182 full_rhs = Let (NonRec poly_tup_id poly_tup_rhs) rhs
183 ; (spec_binds, rules) <- dsSpecs full_rhs spec_prags
185 ; let global' = addIdSpecialisations global rules
186 ; return ((global', rhs) `consOL` spec_binds) }
189 | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
190 | otherwise = dsMkArbitraryType all_tyvar
192 ; export_binds_s <- mapM mk_bind (exports `zip` [0..])
193 -- Don't scc (auto-)annotate the tuple itself.
195 ; return ((poly_tup_id, poly_tup_rhs) `consOL`
196 concatOL export_binds_s) }
198 --------------------------------------
200 = LetEvBind -- Dictionary or coercion
201 CoreBind -- recursive or non-recursive
203 | CaseEvBind -- Coercion binding by superclass selection
204 -- Desugars to case d of d { K _ g _ _ _ -> ... }
205 DictId -- b The dictionary
206 AltCon -- K Its constructor
207 [CoreBndr] -- _ g _ _ _ The binders in the alternative
209 wrapDsEvBinds :: [DsEvBind] -> CoreExpr -> CoreExpr
210 wrapDsEvBinds ds_ev_binds body = foldr wrap_one body ds_ev_binds
212 body_ty = exprType body
213 wrap_one (LetEvBind b) body = Let b body
214 wrap_one (CaseEvBind x k xs) body = Case (Var x) x body_ty [(k,xs,body)]
216 dsTcEvBinds :: TcEvBinds -> DsM [DsEvBind]
217 dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this
218 dsTcEvBinds (EvBinds bs) = dsEvBinds bs
220 dsEvBinds :: Bag EvBind -> DsM [DsEvBind]
221 dsEvBinds bs = return (map dsEvGroup sccs)
224 sccs = stronglyConnCompFromEdgedVertices edges
226 edges :: [(EvBind, EvVar, [EvVar])]
227 edges = foldrBag ((:) . mk_node) [] bs
229 mk_node :: EvBind -> (EvBind, EvVar, [EvVar])
230 mk_node b@(EvBind var term) = (b, var, free_vars_of term)
232 free_vars_of :: EvTerm -> [EvVar]
233 free_vars_of (EvId v) = [v]
234 free_vars_of (EvCast v co) = v : varSetElems (tyCoVarsOfCo co)
235 free_vars_of (EvCoercion co) = varSetElems (tyCoVarsOfCo co)
236 free_vars_of (EvDFunApp _ _ vs) = vs
237 free_vars_of (EvSuperClass d _) = [d]
239 dsEvGroup :: SCC EvBind -> DsEvBind
240 dsEvGroup (AcyclicSCC (EvBind co_var (EvSuperClass dict n)))
241 | isCoVar co_var -- An equality superclass
242 = ASSERT( null other_data_cons )
243 CaseEvBind dict (DataAlt data_con) bndrs
245 (cls, tys) = getClassPredTys (evVarPred dict)
246 (data_con:other_data_cons) = tyConDataCons (classTyCon cls)
247 (ex_tvs, theta, rho) = tcSplitSigmaTy (applyTys (dataConRepType data_con) tys)
248 (arg_tys, _) = splitFunTys rho
249 bndrs = ex_tvs ++ map mk_wild_pred (theta `zip` [0..])
250 ++ map mkWildValBinder arg_tys
251 mk_wild_pred (p, i) | i==n = ASSERT( p `eqPred` (coVarPred co_var))
253 | otherwise = mkWildEvBinder p
255 dsEvGroup (AcyclicSCC (EvBind v r))
256 = LetEvBind (NonRec v (dsEvTerm r))
258 dsEvGroup (CyclicSCC bs)
259 = LetEvBind (Rec (map ds_pair bs))
261 ds_pair (EvBind v r) = (v, dsEvTerm r)
263 dsEvTerm :: EvTerm -> CoreExpr
264 dsEvTerm (EvId v) = Var v
265 dsEvTerm (EvCast v co) = Cast (Var v) co
266 dsEvTerm (EvDFunApp df tys vars) = Var df `mkTyApps` tys `mkVarApps` vars
267 dsEvTerm (EvCoercion co) = Coercion co
268 dsEvTerm (EvSuperClass d n)
269 = ASSERT( isClassPred (classSCTheta cls !! n) )
270 -- We can only select *dictionary* superclasses
271 -- in terms. Equality superclasses are dealt with
272 -- in dsEvGroup, where they can generate a case expression
273 Var sc_sel_id `mkTyApps` tys `App` Var d
275 sc_sel_id = classSCSelId cls n -- Zero-indexed
276 (cls, tys) = getClassPredTys (evVarPred d)
278 ------------------------
279 makeCorePair :: Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr)
280 makeCorePair gbl_id is_default_method dict_arity rhs
281 | is_default_method -- Default methods are *always* inlined
282 = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs)
285 = case inlinePragmaSpec inline_prag of
286 EmptyInlineSpec -> (gbl_id, rhs)
287 NoInline -> (gbl_id, rhs)
288 Inlinable -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)
289 Inline -> inline_pair
292 inline_prag = idInlinePragma gbl_id
293 inlinable_unf = mkInlinableUnfolding rhs
295 | Just arity <- inlinePragmaSat inline_prag
296 -- Add an Unfolding for an INLINE (but not for NOINLINE)
297 -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
298 , let real_arity = dict_arity + arity
299 -- NB: The arity in the InlineRule takes account of the dictionaries
300 = ( gbl_id `setIdUnfolding` mkInlineUnfolding (Just real_arity) rhs
301 , etaExpand real_arity rhs)
304 = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $
305 (gbl_id `setIdUnfolding` mkInlineUnfolding Nothing rhs, rhs)
308 dictArity :: [Var] -> Arity
309 -- Don't count coercion variables in arity
310 dictArity dicts = count isId dicts
313 ------------------------
314 type AbsBindEnv = VarEnv ([TyVar], Id, Id, TcSpecPrags)
315 -- Maps the "lcl_id" for an AbsBind to
316 -- its "gbl_id" and associated pragmas, if any
318 mkABEnv :: [([TyVar], Id, Id, TcSpecPrags)] -> AbsBindEnv
319 -- Takes the exports of a AbsBinds, and returns a mapping
320 -- lcl_id -> (tyvars, gbl_id, lcl_id, prags)
321 mkABEnv exports = mkVarEnv [ (lcl_id, export) | export@(_, _, lcl_id, _) <- exports]
324 Note [Rules and inlining]
325 ~~~~~~~~~~~~~~~~~~~~~~~~~
326 Common special case: no type or dictionary abstraction
327 This is a bit less trivial than you might suppose
328 The naive way woudl be to desguar to something like
329 f_lcl = ...f_lcl... -- The "binds" from AbsBinds
330 M.f = f_lcl -- Generated from "exports"
331 But we don't want that, because if M.f isn't exported,
332 it'll be inlined unconditionally at every call site (its rhs is
333 trivial). That would be ok unless it has RULES, which would
334 thereby be completely lost. Bad, bad, bad.
336 Instead we want to generate
339 Now all is cool. The RULES are attached to M.f (by SimplCore),
340 and f_lcl is rapidly inlined away.
342 This does not happen in the same way to polymorphic binds,
343 because they desugar to
344 M.f = /\a. let f_lcl = ...f_lcl... in f_lcl
345 Although I'm a bit worried about whether full laziness might
346 float the f_lcl binding out and then inline M.f at its call site
348 Note [Specialising in no-dict case]
349 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
350 Even if there are no tyvars or dicts, we may have specialisation pragmas.
351 Class methods can generate
352 AbsBinds [] [] [( ... spec-prag]
353 { AbsBinds [tvs] [dicts] ...blah }
354 So the overloading is in the nested AbsBinds. A good example is in GHC.Float:
356 class (Real a, Fractional a) => RealFrac a where
357 round :: (Integral b) => a -> b
359 instance RealFrac Float where
360 {-# SPECIALIZE round :: Float -> Int #-}
362 The top-level AbsBinds for $cround has no tyvars or dicts (because the
363 instance does not). But the method is locally overloaded!
365 Note [Abstracting over tyvars only]
366 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
367 When abstracting over type variable only (not dictionaries), we don't really need to
368 built a tuple and select from it, as we do in the general case. Instead we can take
370 AbsBinds [a,b] [ ([a,b], fg, fl, _),
378 fg = /\ab. let B in e1
379 gg = /\b. let a = () in let B in S(e2)
380 h = /\ab. let B in e3
382 where B is the *non-recursive* binding
385 h = h a b -- See (b); note shadowing!
387 Notice (a) g has a different number of type variables to f, so we must
388 use the mkArbitraryType thing to fill in the gaps.
389 We use a type-let to do that.
391 (b) The local variable h isn't in the exports, and rather than
392 clone a fresh copy we simply replace h by (h a b), where
393 the two h's have different types! Shadowing happens here,
394 which looks confusing but works fine.
396 (c) The result is *still* quadratic-sized if there are a lot of
397 small bindings. So if there are more than some small
398 number (10), we filter the binding set B by the free
399 variables of the particular RHS. Tiresome.
401 Why got to this trouble? It's a common case, and it removes the
402 quadratic-sized tuple desugaring. Less clutter, hopefullly faster
403 compilation, especially in a case where there are a *lot* of
407 Note [Eta-expanding INLINE things]
408 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
410 foo :: Eq a => a -> a
414 If (foo d) ever gets floated out as a common sub-expression (which can
415 happen as a result of method sharing), there's a danger that we never
416 get to do the inlining, which is a Terribly Bad thing given that the
419 To avoid this we pre-emptively eta-expand the definition, so that foo
420 has the arity with which it is declared in the source code. In this
421 example it has arity 2 (one for the Eq and one for x). Doing this
422 should mean that (foo d) is a PAP and we don't share it.
424 Note [Nested arities]
425 ~~~~~~~~~~~~~~~~~~~~~
426 For reasons that are not entirely clear, method bindings come out looking like
429 AbsBinds [] [] [$cfromT <= [] fromT]
430 $cfromT [InlPrag=INLINE] :: T Bool -> Bool
431 { AbsBinds [] [] [fromT <= [] fromT_1]
432 fromT :: T Bool -> Bool
433 { fromT_1 ((TBool b)) = not b } } }
435 Note the nested AbsBind. The arity for the InlineRule on $cfromT should be
436 gotten from the binding for fromT_1.
438 It might be better to have just one level of AbsBinds, but that requires more
441 Note [Implementing SPECIALISE pragmas]
442 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
444 f :: (Eq a, Ix b) => a -> b -> Bool
445 {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-}
448 From this the typechecker generates
450 AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
452 SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX
453 -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ])
455 Note that wrap_fn can transform *any* function with the right type prefix
456 forall ab. (Eq a, Ix b) => XXX
457 regardless of XXX. It's sort of polymorphic in XXX. This is
458 useful: we use the same wrapper to transform each of the class ops, as
461 From these we generate:
463 Rule: forall p, q, (dp:Ix p), (dq:Ix q).
464 f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq
466 Spec bind: f_spec = wrap_fn <poly_rhs>
470 * The LHS of the rule may mention dictionary *expressions* (eg
471 $dfIxPair dp dq), and that is essential because the dp, dq are
474 * The RHS of f_spec, <poly_rhs> has a *copy* of 'binds', so that it
475 can fully specialise it.
478 ------------------------
479 dsSpecs :: 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 _ IsDefaultMethod = return (nilOL, [])
485 dsSpecs poly_rhs (SpecPrags sps)
486 = do { pairs <- mapMaybeM (dsSpec (Just poly_rhs)) sps
487 ; let (spec_binds_s, rules) = unzip pairs
488 ; return (concatOL spec_binds_s, rules) }
490 dsSpec :: Maybe CoreExpr -- Just rhs => RULE is for a local binding
491 -- Nothing => RULE is for an imported Id
492 -- rhs is in the Id's unfolding
493 -> Located TcSpecPrag
494 -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
495 dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
497 do { let poly_name = idName poly_id
498 ; spec_name <- newLocalName poly_name
499 ; wrap_fn <- dsHsWrapper spec_co
500 ; let (bndrs, ds_lhs) = collectBinders (wrap_fn (Var poly_id))
501 spec_ty = mkPiTypes bndrs (exprType ds_lhs)
502 ; case decomposeRuleLhs bndrs ds_lhs of {
503 Left msg -> do { warnDs msg; return Nothing } ;
504 Right (final_bndrs, _fn, args) -> do
506 { (spec_unf, unf_pairs) <- specUnfolding wrap_fn spec_ty (realIdUnfolding poly_id)
508 ; let spec_id = mkLocalId spec_name spec_ty
509 `setInlinePragma` inl_prag
510 `setIdUnfolding` spec_unf
511 inl_prag | isDefaultInlinePragma spec_inl = idInlinePragma poly_id
512 | otherwise = spec_inl
513 -- Get the INLINE pragma from SPECIALISE declaration, or,
514 -- failing that, from the original Id
516 rule = mkRule False {- Not auto -} is_local_id
517 (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
518 AlwaysActive poly_name
520 (mkVarApps (Var spec_id) bndrs)
522 spec_rhs = wrap_fn poly_rhs
523 spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs
525 ; return (Just (spec_pair `consOL` unf_pairs, rule))
528 is_local_id = isJust mb_poly_rhs
529 poly_rhs | Just rhs <- mb_poly_rhs
530 = rhs -- Local Id; this is its rhs
531 | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id)
532 = unfolding -- Imported Id; this is its unfolding
533 -- Use realIdUnfolding so we get the unfolding
534 -- even when it is a loop breaker.
535 -- We want to specialise recursive functions!
536 | otherwise = pprPanic "dsImpSpecs" (ppr poly_id)
537 -- The type checker has checked that it *has* an unfolding
539 specUnfolding :: (CoreExpr -> CoreExpr) -> Type
540 -> Unfolding -> DsM (Unfolding, OrdList (Id,CoreExpr))
541 {- [Dec 10: TEMPORARILY commented out, until we can straighten out how to
542 generate unfoldings for specialised DFuns
544 specUnfolding wrap_fn spec_ty (DFunUnfolding _ _ ops)
545 = do { let spec_rhss = map wrap_fn ops
546 ; spec_ids <- mapM (mkSysLocalM (fsLit "spec") . exprType) spec_rhss
547 ; return (mkDFunUnfolding spec_ty (map Var spec_ids), toOL (spec_ids `zip` spec_rhss)) }
550 = return (noUnfolding, nilOL)
552 dsMkArbitraryType :: TcTyVar -> Type
553 dsMkArbitraryType tv = anyTypeOfKind (tyVarKind tv)
556 %************************************************************************
558 \subsection{Adding inline pragmas}
560 %************************************************************************
563 decomposeRuleLhs :: [Var] -> CoreExpr -> Either SDoc ([Var], Id, [CoreExpr])
564 -- Take apart the LHS of a RULE. It's suuposed to look like
565 -- /\a. f a Int dOrdInt
566 -- or /\a.\d:Ord a. let { dl::Ord [a] = dOrdList a d } in f [a] dl
567 -- That is, the RULE binders are lambda-bound
568 -- Returns Nothing if the LHS isn't of the expected shape
569 decomposeRuleLhs bndrs lhs
570 = -- Note [Simplifying the left-hand side of a RULE]
571 case collectArgs opt_lhs of
572 (Var fn, args) -> check_bndrs fn args
574 (Case scrut bndr ty [(DEFAULT, _, body)], args)
575 | isDeadBinder bndr -- Note [Matching seqId]
576 -> check_bndrs seqId (args' ++ args)
578 args' = [Type (idType bndr), Type ty, scrut, body]
580 _other -> Left bad_shape_msg
582 opt_lhs = simpleOptExpr lhs
585 | null (dead_bndrs) = Right (extra_dict_bndrs ++ bndrs, fn, args)
586 | otherwise = Left (vcat (map dead_msg dead_bndrs))
588 arg_fvs = exprsFreeVars args
590 -- Check for dead binders: Note [Unused spec binders]
591 dead_bndrs = filterOut (`elemVarSet` arg_fvs) bndrs
593 -- Add extra dict binders: Note [Constant rule dicts]
594 extra_dict_bndrs = [ mkLocalId (localiseName (idName d)) (idType d)
595 | d <- varSetElems (arg_fvs `delVarSetList` bndrs)
599 bad_shape_msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar"))
601 dead_msg bndr = hang (sep [ ptext (sLit "Forall'd") <+> pp_bndr bndr
602 , ptext (sLit "is not bound in RULE lhs")])
605 | isTyVar bndr = ptext (sLit "type variable") <+> quotes (ppr bndr)
606 | isEvVar bndr = ptext (sLit "constraint") <+> quotes (ppr (evVarPred bndr))
607 | otherwise = ptext (sLit "variable") <+> quotes (ppr bndr)
610 Note [Simplifying the left-hand side of a RULE]
611 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
612 simpleOptExpr occurrence-analyses and simplifies the lhs
614 (a) sorts dict bindings into NonRecs and inlines them
615 (b) substitute trivial lets so that they don't get in the way
616 Note that we substitute the function too; we might
617 have this as a LHS: let f71 = M.f Int in f71
618 (c) does eta reduction
620 For (c) consider the fold/build rule, which without simplification
622 fold k z (build (/\a. g a)) ==> ...
623 This doesn't match unless you do eta reduction on the build argument.
624 Similarly for a LHS like
626 we do not want to get
627 augment (\a. g a) (build h)
628 otherwise we don't match when given an argument like
629 augment (\a. h a a) (build h)
631 NB: tcSimplifyRuleLhs is very careful not to generate complicated
632 dictionary expressions that we might have to match
634 Note [Matching seqId]
636 The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
637 and this code turns it back into an application of seq!
638 See Note [Rules for seq] in MkId for the details.
640 Note [Unused spec binders]
641 ~~~~~~~~~~~~~~~~~~~~~~~~~~
644 {-# SPECIALISE f :: Eq a => a -> a #-}
645 It's true that this *is* a more specialised type, but the rule
646 we get is something like this:
649 Note that the rule is bogus, becuase it mentions a 'd' that is
650 not bound on the LHS! But it's a silly specialisation anyway, becuase
651 the constraint is unused. We could bind 'd' to (error "unused")
652 but it seems better to reject the program because it's almost certainly
653 a mistake. That's what the isDeadBinder call detects.
655 Note [Constant rule dicts]
656 ~~~~~~~~~~~~~~~~~~~~~~~
657 When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,
658 which is presumably in scope at the function definition site, we can quantify
659 over it too. *Any* dict with that type will do.
661 So for example when you have
664 {-# SPECIALISE f :: Int -> Int #-}
666 Then we get the SpecPrag
667 SpecPrag (f Int dInt)
669 And from that we want the rule
671 RULE forall dInt. f Int dInt = f_spec
672 f_spec = let f = <rhs> in f Int dInt
674 But be careful! That dInt might be GHC.Base.$fOrdInt, which is an External
675 Name, and you can't bind them in a lambda or forall without getting things
676 confused. Likewise it might have an InlineRule or something, which would be
677 utterly bogus. So we really make a fresh Id, with the same unique and type
678 as the old one, but with an Internal name and no IdInfo.
681 %************************************************************************
683 \subsection[addAutoScc]{Adding automatic sccs}
685 %************************************************************************
688 data AutoScc = NoSccs
689 | AddSccs Module (Id -> Bool)
690 -- The (Id->Bool) says which Ids to add SCCs to
691 -- But we never add a SCC to function marked INLINE
693 addAutoScc :: AutoScc
696 -> CoreExpr -- Scc'd Rhs
698 addAutoScc NoSccs _ rhs
700 addAutoScc _ id rhs | isInlinePragma (idInlinePragma id)
702 addAutoScc (AddSccs mod add_scc) id rhs
703 | add_scc id = mkSCC (mkAutoCC id mod NotCafCC) rhs
707 If profiling and dealing with a dict binding,
708 wrap the dict in @_scc_ DICT <dict>@:
711 addDictScc :: Id -> CoreExpr -> DsM CoreExpr
712 addDictScc _ rhs = return rhs
714 {- DISABLED for now (need to somehow make up a name for the scc) -- SDM
715 | not ( opt_SccProfilingOn && opt_AutoSccsOnDicts)
716 || not (isDictId var)
717 = return rhs -- That's easy: do nothing
720 = do (mod, grp) <- getModuleAndGroupDs
721 -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
722 return (Note (SCC (mkAllDictsCC mod grp False)) rhs)
727 %************************************************************************
731 %************************************************************************
735 dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
736 dsHsWrapper WpHole = return (\e -> e)
737 dsHsWrapper (WpTyApp ty) = return (\e -> App e (Type ty))
738 dsHsWrapper (WpLet ev_binds) = do { ds_ev_binds <- dsTcEvBinds ev_binds
739 ; return (wrapDsEvBinds ds_ev_binds) }
740 dsHsWrapper (WpCompose c1 c2) = do { k1 <- dsHsWrapper c1
741 ; k2 <- dsHsWrapper c2
743 dsHsWrapper (WpCast co) = return (\e -> Cast e co)
744 dsHsWrapper (WpEvLam ev) = return (\e -> Lam ev e)
745 dsHsWrapper (WpTyLam tv) = return (\e -> Lam tv e)
746 dsHsWrapper (WpEvApp evtrm) = return (\e -> App e (dsEvTerm evtrm))