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 ; return (unitOL (fun, wrap_fn' (mkLams args body'))) }
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 ; return (toOL sel_binds) }
118 dsHsBind auto_scc (AbsBinds { abs_tvs = [], abs_ev_vars = []
119 , abs_exports = exports, abs_ev_binds = ev_binds
120 , abs_binds = binds })
121 = do { bind_prs <- ds_lhs_binds NoSccs binds
122 ; ds_ev_binds <- dsTcEvBinds ev_binds
124 ; let core_prs = addEvPairs ds_ev_binds bind_prs
125 env = mkABEnv exports
127 | Just (_, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id
128 = do { let rhs' = addAutoScc auto_scc gbl_id rhs
129 ; (spec_binds, rules) <- dsSpecs gbl_id (Let (Rec core_prs) rhs') spec_prags
130 -- See Note [Specialising in no-dict case]
131 ; let gbl_id' = addIdSpecialisations gbl_id rules
132 main_bind = makeCorePair gbl_id' False 0 rhs'
133 ; return (main_bind : spec_binds) }
135 | otherwise = return [(lcl_id, rhs)]
137 locals' = [(lcl_id, Var gbl_id) | (_, gbl_id, lcl_id, _) <- exports]
138 -- Note [Rules and inlining]
139 ; export_binds <- mapM do_one core_prs
140 ; return (concat export_binds ++ locals' ++ rest) }
141 -- No Rec needed here (contrast the other AbsBinds cases)
142 -- because we can rely on the enclosing dsBind to wrap in Rec
145 dsHsBind auto_scc rest (AbsBinds { abs_tvs = tyvars, abs_ev_vars = []
146 , abs_exports = exports, abs_ev_binds = ev_binds
147 , abs_binds = binds })
148 | opt_DsMultiTyVar -- This (static) debug flag just lets us
149 -- switch on and off this optimisation to
150 -- see if it has any impact; it is on by default
151 , allOL isLazyEvBind ev_binds
152 = -- Note [Abstracting over tyvars only]
153 do { bind_prs <- ds_lhs_binds NoSccs binds
154 ; ds_ev_binds <- dsTcEvBinds ev_binds
156 ; let core_prs = addEvPairs ds_ev_binds bind_prs
157 arby_env = mkArbitraryTypeEnv tyvars exports
158 bndrs = mkVarSet (map fst core_prs)
160 add_lets | core_prs `lengthExceeds` 10 = add_some
162 add_some lg_binds rhs = mkLets [ NonRec b r | NonRec b r <- lg_binds
163 , b `elemVarSet` fvs] rhs
165 fvs = exprSomeFreeVars (`elemVarSet` bndrs) rhs
167 env = mkABEnv exports
168 mk_lg_bind lcl_id gbl_id tyvars
169 = NonRec (setIdInfo lcl_id vanillaIdInfo)
170 -- Nuke the IdInfo so that no old unfoldings
171 -- confuse use (it might mention something not
172 -- even in scope at the new site
173 (mkTyApps (Var gbl_id) (mkTyVarTys tyvars))
175 do_one lg_binds (lcl_id, rhs)
176 | Just (id_tvs, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id
177 = do { let rhs' = addAutoScc auto_scc gbl_id $
179 mkLets [ NonRec tv (Type (lookupVarEnv_NF arby_env tv))
180 | tv <- tyvars, not (tv `elem` id_tvs)] $
181 add_lets lg_binds rhs
182 ; (spec_binds, rules) <- dsSpecs gbl_id rhs' spec_prags
183 ; let gbl_id' = addIdSpecialisations gbl_id rules
184 main_bind = makeCorePair gbl_id' False 0 rhs'
185 ; return (mk_lg_bind lcl_id gbl_id' id_tvs, main_bind : spec_binds) }
187 = do { non_exp_gbl_id <- newUniqueId lcl_id (mkForAllTys tyvars (idType lcl_id))
188 ; return (mk_lg_bind lcl_id non_exp_gbl_id tyvars,
189 [(non_exp_gbl_id, mkLams tyvars (add_lets lg_binds rhs))]) }
191 ; (_, core_prs') <- fixDs (\ ~(lg_binds, _) -> mapAndUnzipM (do_one lg_binds) core_prs)
192 ; return (concat core_prs' ++ rest) }
195 -- A common case: one exported variable
196 -- Non-recursive bindings come through this way
197 -- So do self-recursive bindings, and recursive bindings
198 -- that have been chopped up with type signatures
199 dsHsBind auto_scc (AbsBinds { abs_tvs = all_tyvars, abs_ev_vars = dicts
200 , abs_exports = [(tyvars, global, local, prags)]
201 , abs_ev_binds = ev_binds, abs_binds = binds })
202 = ASSERT( all (`elem` tyvars) all_tyvars )
203 do { bind_prs <- ds_lhs_binds NoSccs binds
204 ; ds_ev_binds <- dsTcEvBinds ev_binds
206 ; let core_bind = Rec (fromOL bind_prs)
207 rhs = addAutoScc auto_scc global $
208 mkLams tyvars $ mkLams dicts $
209 wrapDsEvBinds ds_ev_binds $
213 ; (spec_binds, rules) <- dsSpecs global rhs prags
215 ; let global' = addIdSpecialisations global rules
216 main_bind = makeCorePair global' (isDefaultMethod prags)
217 (dictArity dicts) rhs
219 ; return (main_bind `consOL` spec_binds) }
221 dsHsBind auto_scc (AbsBinds { abs_tvs = all_tyvars, abs_ev_vars = dicts
222 , abs_exports = exports, abs_ev_binds = ev_binds
223 , abs_binds = binds })
224 = do { bind_prs <- ds_lhs_binds NoSccs binds
225 ; ds_ev_binds <- dsTcEvBinds ev_binds
226 ; let env = mkABEnv exports
227 do_one (lcl_id,rhs) | Just (_, gbl_id, _, _prags) <- lookupVarEnv env lcl_id
228 = (lcl_id, addAutoScc auto_scc gbl_id rhs)
229 | otherwise = (lcl_id,rhs)
231 core_bind = Rec (map do_one (fromOL bind_prs))
232 -- Monomorphic recursion possible, hence Rec
234 tup_expr = mkBigCoreVarTup locals
235 tup_ty = exprType tup_expr
236 poly_tup_rhs = mkLams all_tyvars $ mkLams dicts $
237 wrapDsEvBinds ds_ev_binds $
240 locals = [local | (_, _, local, _) <- exports]
241 local_tys = map idType locals
243 ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
245 ; let mk_bind ((tyvars, global, _, spec_prags), n) -- locals!!n == local
246 = -- Need to make fresh locals to bind in the selector,
247 -- because some of the tyvars will be bound to 'Any'
248 do { let ty_args = map mk_ty_arg all_tyvars
249 substitute = substTyWith all_tyvars ty_args
250 ; locals' <- newSysLocalsDs (map substitute local_tys)
251 ; tup_id <- newSysLocalDs (substitute tup_ty)
252 ; let rhs = mkLams tyvars $ mkLams dicts $
253 mkTupleSelector locals' (locals' !! n) tup_id $
254 mkVarApps (mkTyApps (Var poly_tup_id) ty_args)
256 ; (spec_binds, rules) <- dsSpecs global
257 (Let (NonRec poly_tup_id poly_tup_rhs) rhs)
259 ; let global' = addIdSpecialisations global rules
260 ; return ((global', rhs) `consOL` spec_binds) }
263 | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
264 | otherwise = dsMkArbitraryType all_tyvar
266 ; export_binds_s <- mapM mk_bind (exports `zip` [0..])
267 -- Don't scc (auto-)annotate the tuple itself.
269 ; return ((poly_tup_id, poly_tup_rhs) `consOL`
270 concatOL export_binds_s) }
272 --------------------------------------
274 = LetEvBind -- Dictionary or coercion
275 CoreBind -- recursive or non-recursive
277 | CaseEvBind -- Coercion binding by superclass selection
278 -- Desugars to case d of d { K _ g _ _ _ -> ... }
279 DictId -- b The dictionary
280 AltCon -- K Its constructor
281 [CoreBndr] -- _ g _ _ _ The binders in the alternative
283 wrapDsEvBinds :: [DsEvBind] -> CoreExpr -> CoreExpr
284 wrapDsEvBinds ds_ev_binds body = foldr wrap_one body ds_ev_binds
286 body_ty = exprType body
287 wrap_one (LetEvBind b) body = Let b body
288 wrap_one (CaseEvBind x k xs) body = Case (Var x) x body_ty [(k,xs,body)]
290 dsTcEvBinds :: TcEvBinds -> DsM [DsEvBind]
291 dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this
292 dsTcEvBinds (EvBinds bs) = dsEvBinds bs
294 dsEvBinds :: Bag EvBind -> DsM [DsEvBind]
295 dsEvBinds bs = return (map dsEvGroup sccs)
298 sccs = stronglyConnCompFromEdgedVertices edges
300 edges :: [(EvBind, EvVar, [EvVar])]
301 edges = foldrBag ((:) . mk_node) [] bs
303 mk_node :: EvBind -> (EvBind, EvVar, [EvVar])
304 mk_node b@(EvBind var term) = (b, var, free_vars_of term)
306 free_vars_of :: EvTerm -> [EvVar]
307 free_vars_of (EvId v) = [v]
308 free_vars_of (EvCast v co) = v : varSetElems (tyVarsOfType co)
309 free_vars_of (EvCoercion co) = varSetElems (tyVarsOfType co)
310 free_vars_of (EvDFunApp _ _ vs) = vs
311 free_vars_of (EvSuperClass d _) = [d]
313 dsEvGroup :: SCC EvBind -> DsEvBind
314 dsEvGroup (AcyclicSCC (EvBind co_var (EvSuperClass dict n)))
315 | isCoVar co_var -- An equality superclass
316 = ASSERT( null other_data_cons )
317 CaseEvBind dict (DataAlt data_con) bndrs
319 (cls, tys) = getClassPredTys (evVarPred dict)
320 (data_con:other_data_cons) = tyConDataCons (classTyCon cls)
321 (ex_tvs, theta, rho) = tcSplitSigmaTy (applyTys (dataConRepType data_con) tys)
322 (arg_tys, _) = splitFunTys rho
323 bndrs = ex_tvs ++ map mk_wild_pred (theta `zip` [0..])
324 ++ map mkWildValBinder arg_tys
325 mk_wild_pred (p, i) | i==n = ASSERT( p `tcEqPred` (coVarPred co_var))
327 | otherwise = mkWildEvBinder p
329 dsEvGroup (AcyclicSCC (EvBind v r))
330 = LetEvBind (NonRec v (dsEvTerm r))
332 dsEvGroup (CyclicSCC bs)
333 = LetEvBind (Rec (map ds_pair bs))
335 ds_pair (EvBind v r) = (v, dsEvTerm r)
337 dsEvTerm :: EvTerm -> CoreExpr
338 dsEvTerm (EvId v) = Var v
339 dsEvTerm (EvCast v co) = Cast (Var v) co
340 dsEvTerm (EvDFunApp df tys vars) = Var df `mkTyApps` tys `mkVarApps` vars
341 dsEvTerm (EvCoercion co) = Type co
342 dsEvTerm (EvSuperClass d n)
343 = ASSERT( isClassPred (classSCTheta cls !! n) )
344 -- We can only select *dictionary* superclasses
345 -- in terms. Equality superclasses are dealt with
346 -- in dsEvGroup, where they can generate a case expression
347 Var sc_sel_id `mkTyApps` tys `App` Var d
349 sc_sel_id = classSCSelId cls n -- Zero-indexed
350 (cls, tys) = getClassPredTys (evVarPred d)
352 ------------------------
353 makeCorePair :: Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr)
354 makeCorePair gbl_id is_default_method dict_arity rhs
355 | is_default_method -- Default methods are *always* inlined
356 = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs)
359 = case inlinePragmaSpec inline_prag of
360 EmptyInlineSpec -> (gbl_id, rhs)
361 NoInline -> (gbl_id, rhs)
362 Inlinable -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)
363 Inline -> inline_pair
366 inline_prag = idInlinePragma gbl_id
367 inlinable_unf = mkInlinableUnfolding rhs
369 | Just arity <- inlinePragmaSat inline_prag
370 -- Add an Unfolding for an INLINE (but not for NOINLINE)
371 -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
372 , let real_arity = dict_arity + arity
373 -- NB: The arity in the InlineRule takes account of the dictionaries
374 = ( gbl_id `setIdUnfolding` mkInlineUnfolding (Just real_arity) rhs
375 , etaExpand real_arity rhs)
378 = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $
379 (gbl_id `setIdUnfolding` mkInlineUnfolding Nothing rhs, rhs)
382 dictArity :: [Var] -> Arity
383 -- Don't count coercion variables in arity
384 dictArity dicts = count isId dicts
387 ------------------------
388 type AbsBindEnv = VarEnv ([TyVar], Id, Id, TcSpecPrags)
389 -- Maps the "lcl_id" for an AbsBind to
390 -- its "gbl_id" and associated pragmas, if any
392 mkABEnv :: [([TyVar], Id, Id, TcSpecPrags)] -> AbsBindEnv
393 -- Takes the exports of a AbsBinds, and returns a mapping
394 -- lcl_id -> (tyvars, gbl_id, lcl_id, prags)
395 mkABEnv exports = mkVarEnv [ (lcl_id, export) | export@(_, _, lcl_id, _) <- exports]
398 Note [Rules and inlining]
399 ~~~~~~~~~~~~~~~~~~~~~~~~~
400 Common special case: no type or dictionary abstraction
401 This is a bit less trivial than you might suppose
402 The naive way woudl be to desguar to something like
403 f_lcl = ...f_lcl... -- The "binds" from AbsBinds
404 M.f = f_lcl -- Generated from "exports"
405 But we don't want that, because if M.f isn't exported,
406 it'll be inlined unconditionally at every call site (its rhs is
407 trivial). That would be ok unless it has RULES, which would
408 thereby be completely lost. Bad, bad, bad.
410 Instead we want to generate
413 Now all is cool. The RULES are attached to M.f (by SimplCore),
414 and f_lcl is rapidly inlined away.
416 This does not happen in the same way to polymorphic binds,
417 because they desugar to
418 M.f = /\a. let f_lcl = ...f_lcl... in f_lcl
419 Although I'm a bit worried about whether full laziness might
420 float the f_lcl binding out and then inline M.f at its call site -}
422 Note [Specialising in no-dict case]
423 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
424 Even if there are no tyvars or dicts, we may have specialisation pragmas.
425 Class methods can generate
426 AbsBinds [] [] [( ... spec-prag]
427 { AbsBinds [tvs] [dicts] ...blah }
428 So the overloading is in the nested AbsBinds. A good example is in GHC.Float:
430 class (Real a, Fractional a) => RealFrac a where
431 round :: (Integral b) => a -> b
433 instance RealFrac Float where
434 {-# SPECIALIZE round :: Float -> Int #-}
436 The top-level AbsBinds for $cround has no tyvars or dicts (because the
437 instance does not). But the method is locally overloaded!
439 Note [Abstracting over tyvars only]
440 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
441 When abstracting over type variable only (not dictionaries), we don't really need to
442 built a tuple and select from it, as we do in the general case. Instead we can take
444 AbsBinds [a,b] [ ([a,b], fg, fl, _),
452 fg = /\ab. let B in e1
453 gg = /\b. let a = () in let B in S(e2)
454 h = /\ab. let B in e3
456 where B is the *non-recursive* binding
459 h = h a b -- See (b); note shadowing!
461 Notice (a) g has a different number of type variables to f, so we must
462 use the mkArbitraryType thing to fill in the gaps.
463 We use a type-let to do that.
465 (b) The local variable h isn't in the exports, and rather than
466 clone a fresh copy we simply replace h by (h a b), where
467 the two h's have different types! Shadowing happens here,
468 which looks confusing but works fine.
470 (c) The result is *still* quadratic-sized if there are a lot of
471 small bindings. So if there are more than some small
472 number (10), we filter the binding set B by the free
473 variables of the particular RHS. Tiresome.
475 Why got to this trouble? It's a common case, and it removes the
476 quadratic-sized tuple desugaring. Less clutter, hopefullly faster
477 compilation, especially in a case where there are a *lot* of
481 Note [Eta-expanding INLINE things]
482 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
484 foo :: Eq a => a -> a
488 If (foo d) ever gets floated out as a common sub-expression (which can
489 happen as a result of method sharing), there's a danger that we never
490 get to do the inlining, which is a Terribly Bad thing given that the
493 To avoid this we pre-emptively eta-expand the definition, so that foo
494 has the arity with which it is declared in the source code. In this
495 example it has arity 2 (one for the Eq and one for x). Doing this
496 should mean that (foo d) is a PAP and we don't share it.
498 Note [Nested arities]
499 ~~~~~~~~~~~~~~~~~~~~~
500 For reasons that are not entirely clear, method bindings come out looking like
503 AbsBinds [] [] [$cfromT <= [] fromT]
504 $cfromT [InlPrag=INLINE] :: T Bool -> Bool
505 { AbsBinds [] [] [fromT <= [] fromT_1]
506 fromT :: T Bool -> Bool
507 { fromT_1 ((TBool b)) = not b } } }
509 Note the nested AbsBind. The arity for the InlineRule on $cfromT should be
510 gotten from the binding for fromT_1.
512 It might be better to have just one level of AbsBinds, but that requires more
515 Note [Implementing SPECIALISE pragmas]
516 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
518 f :: (Eq a, Ix b) => a -> b -> Bool
519 {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-}
522 From this the typechecker generates
524 AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
526 SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX
527 -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ])
529 Note that wrap_fn can transform *any* function with the right type prefix
530 forall ab. (Eq a, Ix b) => XXX
531 regardless of XXX. It's sort of polymorphic in XXX. This is
532 useful: we use the same wrapper to transform each of the class ops, as
535 From these we generate:
537 Rule: forall p, q, (dp:Ix p), (dq:Ix q).
538 f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq
540 Spec bind: f_spec = wrap_fn <poly_rhs>
544 * The LHS of the rule may mention dictionary *expressions* (eg
545 $dfIxPair dp dq), and that is essential because the dp, dq are
548 * The RHS of f_spec, <poly_rhs> has a *copy* of 'binds', so that it
549 can fully specialise it.
552 ------------------------
553 dsSpecs :: Id -- The polymorphic Id
554 -> CoreExpr -- Its rhs
556 -> DsM ( OrdList (Id,CoreExpr) -- Binding for specialised Ids
557 , [CoreRule] ) -- Rules for the Global Ids
558 -- See Note [Implementing SPECIALISE pragmas]
559 dsSpecs poly_id poly_rhs prags
561 IsDefaultMethod -> return (nilOL, [])
562 SpecPrags sps -> do { pairs <- mapMaybeM spec_one sps
563 ; let (spec_binds_s, rules) = unzip pairs
564 ; return (concatOL spec_binds_s, rules) }
566 spec_one :: Located TcSpecPrag -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
567 spec_one (L loc (SpecPrag spec_co spec_inl))
569 do { let poly_name = idName poly_id
570 ; spec_name <- newLocalName poly_name
571 ; wrap_fn <- dsHsWrapper spec_co
572 ; let (bndrs, ds_lhs) = collectBinders (wrap_fn (Var poly_id))
573 spec_ty = mkPiTypes bndrs (exprType ds_lhs)
574 ; case decomposeRuleLhs ds_lhs of {
575 Nothing -> do { warnDs (decomp_msg spec_co)
580 -- Check for dead binders: Note [Unused spec binders]
581 let arg_fvs = exprsFreeVars args
582 bad_bndrs = filterOut (`elemVarSet` arg_fvs) bndrs
583 in if not (null bad_bndrs)
584 then do { warnDs (dead_msg bad_bndrs); return Nothing }
587 { (spec_unf, unf_pairs) <- specUnfolding wrap_fn spec_ty (realIdUnfolding poly_id)
589 ; let spec_id = mkLocalId spec_name spec_ty
590 `setInlinePragma` inl_prag
591 `setIdUnfolding` spec_unf
592 inl_prag | isDefaultInlinePragma spec_inl = idInlinePragma poly_id
593 | otherwise = spec_inl
594 -- Get the INLINE pragma from SPECIALISE declaration, or,
595 -- failing that, from the original Id
597 extra_dict_bndrs = [ mkLocalId (localiseName (idName d)) (idType d)
598 -- See Note [Constant rule dicts]
599 | d <- varSetElems (arg_fvs `delVarSetList` bndrs)
602 rule = mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
603 AlwaysActive poly_name
604 (extra_dict_bndrs ++ bndrs) args
605 (mkVarApps (Var spec_id) bndrs)
607 spec_rhs = wrap_fn poly_rhs
608 spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs
610 ; return (Just (spec_pair `consOL` unf_pairs, rule))
613 dead_msg bs = vcat [ sep [ptext (sLit "Useless constraint") <> plural bs
614 <+> ptext (sLit "in specialied type:"),
615 nest 2 (pprTheta (map get_pred bs))]
616 , ptext (sLit "SPECIALISE pragma ignored")]
617 get_pred b = ASSERT( isId b ) expectJust "dsSpec" (tcSplitPredTy_maybe (idType b))
620 = hang (ptext (sLit "Specialisation too complicated to desugar; ignored"))
621 2 (pprHsWrapper (ppr poly_id) spec_co)
624 specUnfolding :: (CoreExpr -> CoreExpr) -> Type
625 -> Unfolding -> DsM (Unfolding, OrdList (Id,CoreExpr))
626 specUnfolding wrap_fn spec_ty (DFunUnfolding _ _ ops)
627 = do { let spec_rhss = map wrap_fn ops
628 ; spec_ids <- mapM (mkSysLocalM (fsLit "spec") . exprType) spec_rhss
629 ; return (mkDFunUnfolding spec_ty (map Var spec_ids), toOL (spec_ids `zip` spec_rhss)) }
631 = return (noUnfolding, nilOL)
634 mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> TyVarEnv Type
635 -- If any of the tyvars is missing from any of the lists in
636 -- the second arg, return a binding in the result
637 mkArbitraryTypeEnv tyvars exports
638 = go emptyVarEnv exports
641 go env ((ltvs, _, _, _) : exports)
644 env' = foldl extend env [tv | tv <- tyvars
645 , not (tv `elem` ltvs)
646 , not (tv `elemVarEnv` env)]
648 extend env tv = extendVarEnv env tv (dsMkArbitraryType tv)
651 dsMkArbitraryType :: TcTyVar -> Type
652 dsMkArbitraryType tv = anyTypeOfKind (tyVarKind tv)
655 Note [Unused spec binders]
656 ~~~~~~~~~~~~~~~~~~~~~~~~~~
659 {-# SPECIALISE f :: Eq a => a -> a #-}
660 It's true that this *is* a more specialised type, but the rule
661 we get is something like this:
664 Note that the rule is bogus, becuase it mentions a 'd' that is
665 not bound on the LHS! But it's a silly specialisation anyway, becuase
666 the constraint is unused. We could bind 'd' to (error "unused")
667 but it seems better to reject the program because it's almost certainly
668 a mistake. That's what the isDeadBinder call detects.
670 Note [Constant rule dicts]
671 ~~~~~~~~~~~~~~~~~~~~~~~
672 When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,
673 which is presumably in scope at the function definition site, we can quantify
674 over it too. *Any* dict with that type will do.
676 So for example when you have
679 {-# SPECIALISE f :: Int -> Int #-}
681 Then we get the SpecPrag
682 SpecPrag (f Int dInt)
684 And from that we want the rule
686 RULE forall dInt. f Int dInt = f_spec
687 f_spec = let f = <rhs> in f Int dInt
689 But be careful! That dInt might be GHC.Base.$fOrdInt, which is an External
690 Name, and you can't bind them in a lambda or forall without getting things
691 confused. Likewise it might have an InlineRule or something, which would be
692 utterly bogus. So we really make a fresh Id, with the same unique and type
693 as the old one, but with an Internal name and no IdInfo.
695 %************************************************************************
697 \subsection{Adding inline pragmas}
699 %************************************************************************
702 decomposeRuleLhs :: CoreExpr -> Maybe (Id, [CoreExpr])
703 -- Take apart the LHS of a RULE. It's suuposed to look like
704 -- /\a. f a Int dOrdInt
705 -- or /\a.\d:Ord a. let { dl::Ord [a] = dOrdList a d } in f [a] dl
706 -- That is, the RULE binders are lambda-bound
707 -- Returns Nothing if the LHS isn't of the expected shape
709 = -- Note [Simplifying the left-hand side of a RULE]
710 case collectArgs (simpleOptExpr lhs) of
711 (Var fn, args) -> Just (fn, args)
713 (Case scrut bndr ty [(DEFAULT, _, body)], args)
714 | isDeadBinder bndr -- Note [Matching seqId]
715 -> Just (seqId, args' ++ args)
717 args' = [Type (idType bndr), Type ty, scrut, body]
719 _other -> Nothing -- Unexpected shape
722 Note [Simplifying the left-hand side of a RULE]
723 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
724 simpleOptExpr occurrence-analyses and simplifies the lhs
726 (a) sorts dict bindings into NonRecs and inlines them
727 (b) substitute trivial lets so that they don't get in the way
728 Note that we substitute the function too; we might
729 have this as a LHS: let f71 = M.f Int in f71
730 (c) does eta reduction
732 For (c) consider the fold/build rule, which without simplification
734 fold k z (build (/\a. g a)) ==> ...
735 This doesn't match unless you do eta reduction on the build argument.
736 Similarly for a LHS like
738 we do not want to get
739 augment (\a. g a) (build h)
740 otherwise we don't match when given an argument like
741 augment (\a. h a a) (build h)
743 NB: tcSimplifyRuleLhs is very careful not to generate complicated
744 dictionary expressions that we might have to match
747 Note [Matching seqId]
749 The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
750 and this code turns it back into an application of seq!
751 See Note [Rules for seq] in MkId for the details.
754 %************************************************************************
756 \subsection[addAutoScc]{Adding automatic sccs}
758 %************************************************************************
761 data AutoScc = NoSccs
762 | AddSccs Module (Id -> Bool)
763 -- The (Id->Bool) says which Ids to add SCCs to
764 -- But we never add a SCC to function marked INLINE
766 addAutoScc :: AutoScc
769 -> CoreExpr -- Scc'd Rhs
771 addAutoScc NoSccs _ rhs
773 addAutoScc _ id rhs | isInlinePragma (idInlinePragma id)
775 addAutoScc (AddSccs mod add_scc) id rhs
776 | add_scc id = mkSCC (mkAutoCC id mod NotCafCC) rhs
780 If profiling and dealing with a dict binding,
781 wrap the dict in @_scc_ DICT <dict>@:
784 addDictScc :: Id -> CoreExpr -> DsM CoreExpr
785 addDictScc _ rhs = return rhs
787 {- DISABLED for now (need to somehow make up a name for the scc) -- SDM
788 | not ( opt_SccProfilingOn && opt_AutoSccsOnDicts)
789 || not (isDictId var)
790 = return rhs -- That's easy: do nothing
793 = do (mod, grp) <- getModuleAndGroupDs
794 -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
795 return (Note (SCC (mkAllDictsCC mod grp False)) rhs)
800 %************************************************************************
804 %************************************************************************
808 dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
809 dsHsWrapper WpHole = return (\e -> e)
810 dsHsWrapper (WpTyApp ty) = return (\e -> App e (Type ty))
811 dsHsWrapper (WpLet ev_binds) = do { ds_ev_binds <- dsTcEvBinds ev_binds
812 ; return (wrapDsEvBinds ds_ev_binds) }
813 dsHsWrapper (WpCompose c1 c2) = do { k1 <- dsHsWrapper c1
814 ; k2 <- dsHsWrapper c2
816 dsHsWrapper (WpCast co) = return (\e -> Cast e co)
817 dsHsWrapper (WpEvLam ev) = return (\e -> Lam ev e)
818 dsHsWrapper (WpTyLam tv) = return (\e -> Lam tv e)
819 dsHsWrapper (WpEvApp evtrm) = return (\e -> App e (dsEvTerm evtrm))