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 )
64 %************************************************************************
66 \subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
68 %************************************************************************
71 dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
72 dsTopLHsBinds auto_scc binds = ds_lhs_binds auto_scc binds
74 dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
75 dsLHsBinds binds = do { binds' <- ds_lhs_binds NoSccs binds
76 ; return (fromOL binds') }
78 ------------------------
79 ds_lhs_binds :: AutoScc -> LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
81 -- scc annotation policy (see below)
82 ds_lhs_binds auto_scc binds = do { ds_bs <- mapBagM (dsLHsBind auto_scc) binds
83 ; return (foldBag appOL id nilOL ds_bs) }
85 dsLHsBind :: AutoScc -> LHsBind Id -> DsM (OrdList (Id,CoreExpr))
86 dsLHsBind auto_scc (L loc bind)
87 = putSrcSpanDs loc $ dsHsBind auto_scc bind
89 dsHsBind :: AutoScc -> HsBind Id -> DsM (OrdList (Id,CoreExpr))
91 dsHsBind _ (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless })
92 = do { core_expr <- dsLExpr expr
94 -- Dictionary bindings are always VarBinds,
95 -- so we only need do this here
96 ; core_expr' <- addDictScc var core_expr
97 ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr'
100 ; return (unitOL (makeCorePair var' False 0 core_expr')) }
102 dsHsBind auto_scc (FunBind { fun_id = L _ fun, fun_matches = matches
103 , fun_co_fn = co_fn, fun_tick = tick
105 = do { (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches
106 ; body' <- mkOptTickBox tick body
107 ; wrap_fn' <- dsHsWrapper co_fn
108 ; let rhs = addAutoScc auto_scc fun $ wrap_fn' (mkLams args body')
109 ; return (unitOL (makeCorePair fun False 0 rhs)) }
111 dsHsBind auto_scc (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty })
112 = do { body_expr <- dsGuarded grhss ty
113 ; sel_binds <- mkSelectorBinds pat body_expr
114 -- We silently ignore inline pragmas; no makeCorePair
115 -- Not so cool, but really doesn't matter
116 ; let sel_binds' = [ (v, addAutoScc auto_scc v expr)
117 | (v, expr) <- sel_binds ]
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 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 full_rhs = Let (NonRec poly_tup_id poly_tup_rhs) rhs
182 ; (spec_binds, rules) <- dsSpecs full_rhs spec_prags
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 :: CoreExpr -- Its rhs
480 -> DsM ( OrdList (Id,CoreExpr) -- Binding for specialised Ids
481 , [CoreRule] ) -- Rules for the Global Ids
482 -- See Note [Implementing SPECIALISE pragmas]
483 dsSpecs _ IsDefaultMethod = return (nilOL, [])
484 dsSpecs poly_rhs (SpecPrags sps)
485 = do { pairs <- mapMaybeM (dsSpec (Just poly_rhs)) sps
486 ; let (spec_binds_s, rules) = unzip pairs
487 ; return (concatOL spec_binds_s, rules) }
489 dsSpec :: Maybe CoreExpr -- Just rhs => RULE is for a local binding
490 -- Nothing => RULE is for an imported Id
491 -- rhs is in the Id's unfolding
492 -> Located TcSpecPrag
493 -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
494 dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
496 do { let poly_name = idName poly_id
497 ; spec_name <- newLocalName poly_name
498 ; wrap_fn <- dsHsWrapper spec_co
499 ; let (bndrs, ds_lhs) = collectBinders (wrap_fn (Var poly_id))
500 spec_ty = mkPiTypes bndrs (exprType ds_lhs)
501 ; case decomposeRuleLhs bndrs ds_lhs of {
502 Left msg -> do { warnDs msg; return Nothing } ;
503 Right (final_bndrs, _fn, args) -> do
505 { (spec_unf, unf_pairs) <- specUnfolding wrap_fn spec_ty (realIdUnfolding poly_id)
507 ; let spec_id = mkLocalId spec_name spec_ty
508 `setInlinePragma` inl_prag
509 `setIdUnfolding` spec_unf
510 inl_prag | isDefaultInlinePragma spec_inl = idInlinePragma poly_id
511 | otherwise = spec_inl
512 -- Get the INLINE pragma from SPECIALISE declaration, or,
513 -- failing that, from the original Id
515 rule = mkRule False {- Not auto -} is_local_id
516 (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
517 AlwaysActive poly_name
519 (mkVarApps (Var spec_id) bndrs)
521 spec_rhs = wrap_fn poly_rhs
522 spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs
524 ; return (Just (spec_pair `consOL` unf_pairs, rule))
527 is_local_id = isJust mb_poly_rhs
528 poly_rhs | Just rhs <- mb_poly_rhs
529 = rhs -- Local Id; this is its rhs
530 | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id)
531 = unfolding -- Imported Id; this is its unfolding
532 -- Use realIdUnfolding so we get the unfolding
533 -- even when it is a loop breaker.
534 -- We want to specialise recursive functions!
535 | otherwise = pprPanic "dsImpSpecs" (ppr poly_id)
536 -- The type checker has checked that it *has* an unfolding
538 specUnfolding :: (CoreExpr -> CoreExpr) -> Type
539 -> Unfolding -> DsM (Unfolding, OrdList (Id,CoreExpr))
540 {- [Dec 10: TEMPORARILY commented out, until we can straighten out how to
541 generate unfoldings for specialised DFuns
543 specUnfolding wrap_fn spec_ty (DFunUnfolding _ _ ops)
544 = do { let spec_rhss = map wrap_fn ops
545 ; spec_ids <- mapM (mkSysLocalM (fsLit "spec") . exprType) spec_rhss
546 ; return (mkDFunUnfolding spec_ty (map Var spec_ids), toOL (spec_ids `zip` spec_rhss)) }
549 = return (noUnfolding, nilOL)
551 dsMkArbitraryType :: TcTyVar -> Type
552 dsMkArbitraryType tv = anyTypeOfKind (tyVarKind tv)
555 %************************************************************************
557 \subsection{Adding inline pragmas}
559 %************************************************************************
562 decomposeRuleLhs :: [Var] -> CoreExpr -> Either SDoc ([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
568 decomposeRuleLhs bndrs lhs
569 = -- Note [Simplifying the left-hand side of a RULE]
570 case collectArgs opt_lhs of
571 (Var fn, args) -> check_bndrs fn args
573 (Case scrut bndr ty [(DEFAULT, _, body)], args)
574 | isDeadBinder bndr -- Note [Matching seqId]
575 -> check_bndrs seqId (args' ++ args)
577 args' = [Type (idType bndr), Type ty, scrut, body]
579 _other -> Left bad_shape_msg
581 opt_lhs = simpleOptExpr lhs
584 | null (dead_bndrs) = Right (extra_dict_bndrs ++ bndrs, fn, args)
585 | otherwise = Left (vcat (map dead_msg dead_bndrs))
587 arg_fvs = exprsFreeVars args
589 -- Check for dead binders: Note [Unused spec binders]
590 dead_bndrs = filterOut (`elemVarSet` arg_fvs) bndrs
592 -- Add extra dict binders: Note [Constant rule dicts]
593 extra_dict_bndrs = [ mkLocalId (localiseName (idName d)) (idType d)
594 | d <- varSetElems (arg_fvs `delVarSetList` bndrs)
598 bad_shape_msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar"))
600 dead_msg bndr = hang (ptext (sLit "Forall'd") <+> pp_bndr bndr
601 <+> ptext (sLit "is not bound in RULE lhs"))
604 | isTyVar bndr = ptext (sLit "type variable") <+> ppr bndr
605 | isCoVar bndr = ptext (sLit "coercion variable") <+> ppr bndr
606 | isDictId bndr = ptext (sLit "constraint") <+> ppr (get_pred bndr)
607 | otherwise = ptext (sLit "variable") <+> ppr bndr
609 get_pred b = ASSERT( isId b ) expectJust "decomposeRuleLhs"
610 (tcSplitPredTy_maybe (idType b))
613 Note [Simplifying the left-hand side of a RULE]
614 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
615 simpleOptExpr occurrence-analyses and simplifies the lhs
617 (a) sorts dict bindings into NonRecs and inlines them
618 (b) substitute trivial lets so that they don't get in the way
619 Note that we substitute the function too; we might
620 have this as a LHS: let f71 = M.f Int in f71
621 (c) does eta reduction
623 For (c) consider the fold/build rule, which without simplification
625 fold k z (build (/\a. g a)) ==> ...
626 This doesn't match unless you do eta reduction on the build argument.
627 Similarly for a LHS like
629 we do not want to get
630 augment (\a. g a) (build h)
631 otherwise we don't match when given an argument like
632 augment (\a. h a a) (build h)
634 NB: tcSimplifyRuleLhs is very careful not to generate complicated
635 dictionary expressions that we might have to match
638 Note [Matching seqId]
640 The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
641 and this code turns it back into an application of seq!
642 See Note [Rules for seq] in MkId for the details.
644 Note [Unused spec binders]
645 ~~~~~~~~~~~~~~~~~~~~~~~~~~
648 {-# SPECIALISE f :: Eq a => a -> a #-}
649 It's true that this *is* a more specialised type, but the rule
650 we get is something like this:
653 Note that the rule is bogus, becuase it mentions a 'd' that is
654 not bound on the LHS! But it's a silly specialisation anyway, becuase
655 the constraint is unused. We could bind 'd' to (error "unused")
656 but it seems better to reject the program because it's almost certainly
657 a mistake. That's what the isDeadBinder call detects.
659 Note [Constant rule dicts]
660 ~~~~~~~~~~~~~~~~~~~~~~~
661 When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,
662 which is presumably in scope at the function definition site, we can quantify
663 over it too. *Any* dict with that type will do.
665 So for example when you have
668 {-# SPECIALISE f :: Int -> Int #-}
670 Then we get the SpecPrag
671 SpecPrag (f Int dInt)
673 And from that we want the rule
675 RULE forall dInt. f Int dInt = f_spec
676 f_spec = let f = <rhs> in f Int dInt
678 But be careful! That dInt might be GHC.Base.$fOrdInt, which is an External
679 Name, and you can't bind them in a lambda or forall without getting things
680 confused. Likewise it might have an InlineRule or something, which would be
681 utterly bogus. So we really make a fresh Id, with the same unique and type
682 as the old one, but with an Internal name and no IdInfo.
685 %************************************************************************
687 \subsection[addAutoScc]{Adding automatic sccs}
689 %************************************************************************
692 data AutoScc = NoSccs
693 | AddSccs Module (Id -> Bool)
694 -- The (Id->Bool) says which Ids to add SCCs to
695 -- But we never add a SCC to function marked INLINE
697 addAutoScc :: AutoScc
700 -> CoreExpr -- Scc'd Rhs
702 addAutoScc NoSccs _ rhs
704 addAutoScc _ id rhs | isInlinePragma (idInlinePragma id)
706 addAutoScc (AddSccs mod add_scc) id rhs
707 | add_scc id = mkSCC (mkAutoCC id mod NotCafCC) rhs
711 If profiling and dealing with a dict binding,
712 wrap the dict in @_scc_ DICT <dict>@:
715 addDictScc :: Id -> CoreExpr -> DsM CoreExpr
716 addDictScc _ rhs = return rhs
718 {- DISABLED for now (need to somehow make up a name for the scc) -- SDM
719 | not ( opt_SccProfilingOn && opt_AutoSccsOnDicts)
720 || not (isDictId var)
721 = return rhs -- That's easy: do nothing
724 = do (mod, grp) <- getModuleAndGroupDs
725 -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
726 return (Note (SCC (mkAllDictsCC mod grp False)) rhs)
731 %************************************************************************
735 %************************************************************************
739 dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
740 dsHsWrapper WpHole = return (\e -> e)
741 dsHsWrapper (WpTyApp ty) = return (\e -> App e (Type ty))
742 dsHsWrapper (WpLet ev_binds) = do { ds_ev_binds <- dsTcEvBinds ev_binds
743 ; return (wrapDsEvBinds ds_ev_binds) }
744 dsHsWrapper (WpCompose c1 c2) = do { k1 <- dsHsWrapper c1
745 ; k2 <- dsHsWrapper c2
747 dsHsWrapper (WpCast co) = return (\e -> Cast e co)
748 dsHsWrapper (WpEvLam ev) = return (\e -> Lam ev e)
749 dsHsWrapper (WpTyLam tv) = return (\e -> Lam tv e)
750 dsHsWrapper (WpEvApp evtrm) = return (\e -> App e (dsEvTerm evtrm))