Generate Typeable info at definition sites
[ghc.git] / compiler / deSugar / DsBinds.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5
6 Pattern-matching bindings (HsBinds and MonoBinds)
7
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).
11 -}
12
13 {-# LANGUAGE CPP #-}
14
15 module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
16 dsHsWrapper, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds, dsMkUserRule
17 ) where
18
19 #include "HsVersions.h"
20
21 import {-# SOURCE #-} DsExpr( dsLExpr )
22 import {-# SOURCE #-} Match( matchWrapper )
23
24 import DsMonad
25 import DsGRHSs
26 import DsUtils
27
28 import HsSyn -- lots of things
29 import CoreSyn -- lots of things
30 import Literal ( Literal(MachStr) )
31 import CoreSubst
32 import OccurAnal ( occurAnalyseExpr )
33 import MkCore
34 import CoreUtils
35 import CoreArity ( etaExpand )
36 import CoreUnfold
37 import CoreFVs
38 import UniqSupply
39 import Digraph
40
41 import PrelNames
42 import TysPrim ( mkProxyPrimTy )
43 import TyCon
44 import TcEvidence
45 import TcType
46 import Type
47 import Kind( isKind )
48 import Coercion hiding (substCo)
49 import TysWiredIn ( eqBoxDataCon, coercibleDataCon, mkListTy
50 , mkBoxedTupleTy, charTy
51 , typeNatKind, typeSymbolKind )
52 import Id
53 import MkId(proxyHashId)
54 import Class
55 import DataCon ( dataConTyCon )
56 import Name
57 import IdInfo ( IdDetails(..) )
58 import Var
59 import VarSet
60 import Rules
61 import VarEnv
62 import Outputable
63 import Module
64 import SrcLoc
65 import Maybes
66 import OrdList
67 import Bag
68 import BasicTypes hiding ( TopLevel )
69 import DynFlags
70 import FastString
71 import Util
72 import MonadUtils
73 import Control.Monad(liftM,when)
74
75 {-**********************************************************************
76 * *
77 Desugaring a MonoBinds
78 * *
79 **********************************************************************-}
80
81 dsTopLHsBinds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
82 dsTopLHsBinds binds = ds_lhs_binds binds
83
84 dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
85 dsLHsBinds binds = do { binds' <- ds_lhs_binds binds
86 ; return (fromOL binds') }
87
88 ------------------------
89 ds_lhs_binds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
90
91 ds_lhs_binds binds = do { ds_bs <- mapBagM dsLHsBind binds
92 ; return (foldBag appOL id nilOL ds_bs) }
93
94 dsLHsBind :: LHsBind Id -> DsM (OrdList (Id,CoreExpr))
95 dsLHsBind (L loc bind) = putSrcSpanDs loc $ dsHsBind bind
96
97 dsHsBind :: HsBind Id -> DsM (OrdList (Id,CoreExpr))
98
99 dsHsBind (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless })
100 = do { dflags <- getDynFlags
101 ; core_expr <- dsLExpr expr
102
103 -- Dictionary bindings are always VarBinds,
104 -- so we only need do this here
105 ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr
106 | otherwise = var
107
108 ; return (unitOL (makeCorePair dflags var' False 0 core_expr)) }
109
110 dsHsBind (FunBind { fun_id = L _ fun, fun_matches = matches
111 , fun_co_fn = co_fn, fun_tick = tick
112 , fun_infix = inf })
113 = do { dflags <- getDynFlags
114 ; (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches
115 ; let body' = mkOptTickBox tick body
116 ; rhs <- dsHsWrapper co_fn (mkLams args body')
117 ; {- pprTrace "dsHsBind" (ppr fun <+> ppr (idInlinePragma fun)) $ -}
118 return (unitOL (makeCorePair dflags fun False 0 rhs)) }
119
120 dsHsBind (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty
121 , pat_ticks = (rhs_tick, var_ticks) })
122 = do { body_expr <- dsGuarded grhss ty
123 ; let body' = mkOptTickBox rhs_tick body_expr
124 ; sel_binds <- mkSelectorBinds var_ticks pat body'
125 -- We silently ignore inline pragmas; no makeCorePair
126 -- Not so cool, but really doesn't matter
127 ; return (toOL sel_binds) }
128
129 -- A common case: one exported variable
130 -- Non-recursive bindings come through this way
131 -- So do self-recursive bindings, and recursive bindings
132 -- that have been chopped up with type signatures
133 dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
134 , abs_exports = [export]
135 , abs_ev_binds = ev_binds, abs_binds = binds })
136 | ABE { abe_wrap = wrap, abe_poly = global
137 , abe_mono = local, abe_prags = prags } <- export
138 = do { dflags <- getDynFlags
139 ; bind_prs <- ds_lhs_binds binds
140 ; let core_bind = Rec (fromOL bind_prs)
141 ; ds_binds <- dsTcEvBinds_s ev_binds
142 ; rhs <- dsHsWrapper wrap $ -- Usually the identity
143 mkLams tyvars $ mkLams dicts $
144 mkCoreLets ds_binds $
145 Let core_bind $
146 Var local
147
148 ; (spec_binds, rules) <- dsSpecs rhs prags
149
150 ; let global' = addIdSpecialisations global rules
151 main_bind = makeCorePair dflags global' (isDefaultMethod prags)
152 (dictArity dicts) rhs
153
154 ; return (main_bind `consOL` spec_binds) }
155
156 dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
157 , abs_exports = exports, abs_ev_binds = ev_binds
158 , abs_binds = binds })
159 -- See Note [Desugaring AbsBinds]
160 = do { dflags <- getDynFlags
161 ; bind_prs <- ds_lhs_binds binds
162 ; let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs
163 | (lcl_id, rhs) <- fromOL bind_prs ]
164 -- Monomorphic recursion possible, hence Rec
165
166 locals = map abe_mono exports
167 tup_expr = mkBigCoreVarTup locals
168 tup_ty = exprType tup_expr
169 ; ds_binds <- dsTcEvBinds_s ev_binds
170 ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $
171 mkCoreLets ds_binds $
172 Let core_bind $
173 tup_expr
174
175 ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
176
177 ; let mk_bind (ABE { abe_wrap = wrap, abe_poly = global
178 , abe_mono = local, abe_prags = spec_prags })
179 = do { tup_id <- newSysLocalDs tup_ty
180 ; rhs <- dsHsWrapper wrap $
181 mkLams tyvars $ mkLams dicts $
182 mkTupleSelector locals local tup_id $
183 mkVarApps (Var poly_tup_id) (tyvars ++ dicts)
184 ; let rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs
185 ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags
186 ; let global' = (global `setInlinePragma` defaultInlinePragma)
187 `addIdSpecialisations` rules
188 -- Kill the INLINE pragma because it applies to
189 -- the user written (local) function. The global
190 -- Id is just the selector. Hmm.
191 ; return ((global', rhs) `consOL` spec_binds) }
192
193 ; export_binds_s <- mapM mk_bind exports
194
195 ; return ((poly_tup_id, poly_tup_rhs) `consOL`
196 concatOL export_binds_s) }
197 where
198 inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with
199 -- the inline pragma from the source
200 -- The type checker put the inline pragma
201 -- on the *global* Id, so we need to transfer it
202 inline_env = mkVarEnv [ (lcl_id, setInlinePragma lcl_id prag)
203 | ABE { abe_mono = lcl_id, abe_poly = gbl_id } <- exports
204 , let prag = idInlinePragma gbl_id ]
205
206 add_inline :: Id -> Id -- tran
207 add_inline lcl_id = lookupVarEnv inline_env lcl_id `orElse` lcl_id
208
209 dsHsBind (PatSynBind{}) = panic "dsHsBind: PatSynBind"
210
211 ------------------------
212 makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr)
213 makeCorePair dflags gbl_id is_default_method dict_arity rhs
214 | is_default_method -- Default methods are *always* inlined
215 = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs)
216
217 | DFunId is_newtype <- idDetails gbl_id
218 = (mk_dfun_w_stuff is_newtype, rhs)
219
220 | otherwise
221 = case inlinePragmaSpec inline_prag of
222 EmptyInlineSpec -> (gbl_id, rhs)
223 NoInline -> (gbl_id, rhs)
224 Inlinable -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)
225 Inline -> inline_pair
226
227 where
228 inline_prag = idInlinePragma gbl_id
229 inlinable_unf = mkInlinableUnfolding dflags rhs
230 inline_pair
231 | Just arity <- inlinePragmaSat inline_prag
232 -- Add an Unfolding for an INLINE (but not for NOINLINE)
233 -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
234 , let real_arity = dict_arity + arity
235 -- NB: The arity in the InlineRule takes account of the dictionaries
236 = ( gbl_id `setIdUnfolding` mkInlineUnfolding (Just real_arity) rhs
237 , etaExpand real_arity rhs)
238
239 | otherwise
240 = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $
241 (gbl_id `setIdUnfolding` mkInlineUnfolding Nothing rhs, rhs)
242
243 -- See Note [ClassOp/DFun selection] in TcInstDcls
244 -- See Note [Single-method classes] in TcInstDcls
245 mk_dfun_w_stuff is_newtype
246 | is_newtype
247 = gbl_id `setIdUnfolding` mkInlineUnfolding (Just 0) rhs
248 `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 }
249 | otherwise
250 = gbl_id `setIdUnfolding` mkDFunUnfolding dfun_bndrs dfun_constr dfun_args
251 `setInlinePragma` dfunInlinePragma
252 (dfun_bndrs, dfun_body) = collectBinders (simpleOptExpr rhs)
253 (dfun_con, dfun_args) = collectArgs dfun_body
254 dfun_constr | Var id <- dfun_con
255 , DataConWorkId con <- idDetails id
256 = con
257 | otherwise = pprPanic "makeCorePair: dfun" (ppr rhs)
258
259
260 dictArity :: [Var] -> Arity
261 -- Don't count coercion variables in arity
262 dictArity dicts = count isId dicts
263
264 {-
265 [Desugaring AbsBinds]
266 ~~~~~~~~~~~~~~~~~~~~~
267 In the general AbsBinds case we desugar the binding to this:
268
269 tup a (d:Num a) = let fm = ...gm...
270 gm = ...fm...
271 in (fm,gm)
272 f a d = case tup a d of { (fm,gm) -> fm }
273 g a d = case tup a d of { (fm,gm) -> fm }
274
275 Note [Rules and inlining]
276 ~~~~~~~~~~~~~~~~~~~~~~~~~
277 Common special case: no type or dictionary abstraction
278 This is a bit less trivial than you might suppose
279 The naive way woudl be to desguar to something like
280 f_lcl = ...f_lcl... -- The "binds" from AbsBinds
281 M.f = f_lcl -- Generated from "exports"
282 But we don't want that, because if M.f isn't exported,
283 it'll be inlined unconditionally at every call site (its rhs is
284 trivial). That would be ok unless it has RULES, which would
285 thereby be completely lost. Bad, bad, bad.
286
287 Instead we want to generate
288 M.f = ...f_lcl...
289 f_lcl = M.f
290 Now all is cool. The RULES are attached to M.f (by SimplCore),
291 and f_lcl is rapidly inlined away.
292
293 This does not happen in the same way to polymorphic binds,
294 because they desugar to
295 M.f = /\a. let f_lcl = ...f_lcl... in f_lcl
296 Although I'm a bit worried about whether full laziness might
297 float the f_lcl binding out and then inline M.f at its call site
298
299 Note [Specialising in no-dict case]
300 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
301 Even if there are no tyvars or dicts, we may have specialisation pragmas.
302 Class methods can generate
303 AbsBinds [] [] [( ... spec-prag]
304 { AbsBinds [tvs] [dicts] ...blah }
305 So the overloading is in the nested AbsBinds. A good example is in GHC.Float:
306
307 class (Real a, Fractional a) => RealFrac a where
308 round :: (Integral b) => a -> b
309
310 instance RealFrac Float where
311 {-# SPECIALIZE round :: Float -> Int #-}
312
313 The top-level AbsBinds for $cround has no tyvars or dicts (because the
314 instance does not). But the method is locally overloaded!
315
316 Note [Abstracting over tyvars only]
317 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
318 When abstracting over type variable only (not dictionaries), we don't really need to
319 built a tuple and select from it, as we do in the general case. Instead we can take
320
321 AbsBinds [a,b] [ ([a,b], fg, fl, _),
322 ([b], gg, gl, _) ]
323 { fl = e1
324 gl = e2
325 h = e3 }
326
327 and desugar it to
328
329 fg = /\ab. let B in e1
330 gg = /\b. let a = () in let B in S(e2)
331 h = /\ab. let B in e3
332
333 where B is the *non-recursive* binding
334 fl = fg a b
335 gl = gg b
336 h = h a b -- See (b); note shadowing!
337
338 Notice (a) g has a different number of type variables to f, so we must
339 use the mkArbitraryType thing to fill in the gaps.
340 We use a type-let to do that.
341
342 (b) The local variable h isn't in the exports, and rather than
343 clone a fresh copy we simply replace h by (h a b), where
344 the two h's have different types! Shadowing happens here,
345 which looks confusing but works fine.
346
347 (c) The result is *still* quadratic-sized if there are a lot of
348 small bindings. So if there are more than some small
349 number (10), we filter the binding set B by the free
350 variables of the particular RHS. Tiresome.
351
352 Why got to this trouble? It's a common case, and it removes the
353 quadratic-sized tuple desugaring. Less clutter, hopefully faster
354 compilation, especially in a case where there are a *lot* of
355 bindings.
356
357
358 Note [Eta-expanding INLINE things]
359 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
360 Consider
361 foo :: Eq a => a -> a
362 {-# INLINE foo #-}
363 foo x = ...
364
365 If (foo d) ever gets floated out as a common sub-expression (which can
366 happen as a result of method sharing), there's a danger that we never
367 get to do the inlining, which is a Terribly Bad thing given that the
368 user said "inline"!
369
370 To avoid this we pre-emptively eta-expand the definition, so that foo
371 has the arity with which it is declared in the source code. In this
372 example it has arity 2 (one for the Eq and one for x). Doing this
373 should mean that (foo d) is a PAP and we don't share it.
374
375 Note [Nested arities]
376 ~~~~~~~~~~~~~~~~~~~~~
377 For reasons that are not entirely clear, method bindings come out looking like
378 this:
379
380 AbsBinds [] [] [$cfromT <= [] fromT]
381 $cfromT [InlPrag=INLINE] :: T Bool -> Bool
382 { AbsBinds [] [] [fromT <= [] fromT_1]
383 fromT :: T Bool -> Bool
384 { fromT_1 ((TBool b)) = not b } } }
385
386 Note the nested AbsBind. The arity for the InlineRule on $cfromT should be
387 gotten from the binding for fromT_1.
388
389 It might be better to have just one level of AbsBinds, but that requires more
390 thought!
391 -}
392
393 ------------------------
394 dsSpecs :: CoreExpr -- Its rhs
395 -> TcSpecPrags
396 -> DsM ( OrdList (Id,CoreExpr) -- Binding for specialised Ids
397 , [CoreRule] ) -- Rules for the Global Ids
398 -- See Note [Handling SPECIALISE pragmas] in TcBinds
399 dsSpecs _ IsDefaultMethod = return (nilOL, [])
400 dsSpecs poly_rhs (SpecPrags sps)
401 = do { pairs <- mapMaybeM (dsSpec (Just poly_rhs)) sps
402 ; let (spec_binds_s, rules) = unzip pairs
403 ; return (concatOL spec_binds_s, rules) }
404
405 dsSpec :: Maybe CoreExpr -- Just rhs => RULE is for a local binding
406 -- Nothing => RULE is for an imported Id
407 -- rhs is in the Id's unfolding
408 -> Located TcSpecPrag
409 -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
410 dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
411 | isJust (isClassOpId_maybe poly_id)
412 = putSrcSpanDs loc $
413 do { warnDs (ptext (sLit "Ignoring useless SPECIALISE pragma for class method selector")
414 <+> quotes (ppr poly_id))
415 ; return Nothing } -- There is no point in trying to specialise a class op
416 -- Moreover, classops don't (currently) have an inl_sat arity set
417 -- (it would be Just 0) and that in turn makes makeCorePair bleat
418
419 | no_act_spec && isNeverActive rule_act
420 = putSrcSpanDs loc $
421 do { warnDs (ptext (sLit "Ignoring useless SPECIALISE pragma for NOINLINE function:")
422 <+> quotes (ppr poly_id))
423 ; return Nothing } -- Function is NOINLINE, and the specialiation inherits that
424 -- See Note [Activation pragmas for SPECIALISE]
425
426 | otherwise
427 = putSrcSpanDs loc $
428 do { uniq <- newUnique
429 ; let poly_name = idName poly_id
430 spec_occ = mkSpecOcc (getOccName poly_name)
431 spec_name = mkInternalName uniq spec_occ (getSrcSpan poly_name)
432 ; (bndrs, ds_lhs) <- liftM collectBinders
433 (dsHsWrapper spec_co (Var poly_id))
434 ; let spec_ty = mkPiTypes bndrs (exprType ds_lhs)
435 ; -- pprTrace "dsRule" (vcat [ ptext (sLit "Id:") <+> ppr poly_id
436 -- , ptext (sLit "spec_co:") <+> ppr spec_co
437 -- , ptext (sLit "ds_rhs:") <+> ppr ds_lhs ]) $
438 case decomposeRuleLhs bndrs ds_lhs of {
439 Left msg -> do { warnDs msg; return Nothing } ;
440 Right (rule_bndrs, _fn, args) -> do
441
442 { dflags <- getDynFlags
443 ; this_mod <- getModule
444 ; let fn_unf = realIdUnfolding poly_id
445 unf_fvs = stableUnfoldingVars fn_unf `orElse` emptyVarSet
446 in_scope = mkInScopeSet (unf_fvs `unionVarSet` exprsFreeVars args)
447 spec_unf = specUnfolding dflags (mkEmptySubst in_scope) bndrs args fn_unf
448 spec_id = mkLocalId spec_name spec_ty
449 `setInlinePragma` inl_prag
450 `setIdUnfolding` spec_unf
451 ; rule <- dsMkUserRule this_mod is_local_id
452 (mkFastString ("SPEC " ++ showPpr dflags poly_name))
453 rule_act poly_name
454 rule_bndrs args
455 (mkVarApps (Var spec_id) bndrs)
456
457 ; spec_rhs <- dsHsWrapper spec_co poly_rhs
458
459 -- Commented out: see Note [SPECIALISE on INLINE functions]
460 -- ; when (isInlinePragma id_inl)
461 -- (warnDs $ ptext (sLit "SPECIALISE pragma on INLINE function probably won't fire:")
462 -- <+> quotes (ppr poly_name))
463
464 ; return (Just (unitOL (spec_id, spec_rhs), rule))
465 -- NB: do *not* use makeCorePair on (spec_id,spec_rhs), because
466 -- makeCorePair overwrites the unfolding, which we have
467 -- just created using specUnfolding
468 } } }
469 where
470 is_local_id = isJust mb_poly_rhs
471 poly_rhs | Just rhs <- mb_poly_rhs
472 = rhs -- Local Id; this is its rhs
473 | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id)
474 = unfolding -- Imported Id; this is its unfolding
475 -- Use realIdUnfolding so we get the unfolding
476 -- even when it is a loop breaker.
477 -- We want to specialise recursive functions!
478 | otherwise = pprPanic "dsImpSpecs" (ppr poly_id)
479 -- The type checker has checked that it *has* an unfolding
480
481 id_inl = idInlinePragma poly_id
482
483 -- See Note [Activation pragmas for SPECIALISE]
484 inl_prag | not (isDefaultInlinePragma spec_inl) = spec_inl
485 | not is_local_id -- See Note [Specialising imported functions]
486 -- in OccurAnal
487 , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma
488 | otherwise = id_inl
489 -- Get the INLINE pragma from SPECIALISE declaration, or,
490 -- failing that, from the original Id
491
492 spec_prag_act = inlinePragmaActivation spec_inl
493
494 -- See Note [Activation pragmas for SPECIALISE]
495 -- no_act_spec is True if the user didn't write an explicit
496 -- phase specification in the SPECIALISE pragma
497 no_act_spec = case inlinePragmaSpec spec_inl of
498 NoInline -> isNeverActive spec_prag_act
499 _ -> isAlwaysActive spec_prag_act
500 rule_act | no_act_spec = inlinePragmaActivation id_inl -- Inherit
501 | otherwise = spec_prag_act -- Specified by user
502
503
504 dsMkUserRule :: Module -> Bool -> RuleName -> Activation
505 -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> DsM CoreRule
506 dsMkUserRule this_mod is_local name act fn bndrs args rhs = do
507 let rule = mkRule this_mod False is_local name act fn bndrs args rhs
508 dflags <- getDynFlags
509 when (isOrphan (ru_orphan rule) && wopt Opt_WarnOrphans dflags) $
510 warnDs (ruleOrphWarn rule)
511 return rule
512
513 ruleOrphWarn :: CoreRule -> SDoc
514 ruleOrphWarn rule = ptext (sLit "Orphan rule:") <+> ppr rule
515
516 {- Note [SPECIALISE on INLINE functions]
517 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
518 We used to warn that using SPECIALISE for a function marked INLINE
519 would be a no-op; but it isn't! Especially with worker/wrapper split
520 we might have
521 {-# INLINE f #-}
522 f :: Ord a => Int -> a -> ...
523 f d x y = case x of I# x' -> $wf d x' y
524
525 We might want to specialise 'f' so that we in turn specialise '$wf'.
526 We can't even /name/ '$wf' in the source code, so we can't specialise
527 it even if we wanted to. Trac #10721 is a case in point.
528
529 Note [Activation pragmas for SPECIALISE]
530 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
531 From a user SPECIALISE pragma for f, we generate
532 a) A top-level binding spec_fn = rhs
533 b) A RULE f dOrd = spec_fn
534
535 We need two pragma-like things:
536
537 * spec_fn's inline pragma: inherited from f's inline pragma (ignoring
538 activation on SPEC), unless overriden by SPEC INLINE
539
540 * Activation of RULE: from SPECIALISE pragma (if activation given)
541 otherwise from f's inline pragma
542
543 This is not obvious (see Trac #5237)!
544
545 Examples Rule activation Inline prag on spec'd fn
546 ---------------------------------------------------------------------
547 SPEC [n] f :: ty [n] Always, or NOINLINE [n]
548 copy f's prag
549
550 NOINLINE f
551 SPEC [n] f :: ty [n] NOINLINE
552 copy f's prag
553
554 NOINLINE [k] f
555 SPEC [n] f :: ty [n] NOINLINE [k]
556 copy f's prag
557
558 INLINE [k] f
559 SPEC [n] f :: ty [n] INLINE [k]
560 copy f's prag
561
562 SPEC INLINE [n] f :: ty [n] INLINE [n]
563 (ignore INLINE prag on f,
564 same activation for rule and spec'd fn)
565
566 NOINLINE [k] f
567 SPEC f :: ty [n] INLINE [k]
568
569
570 ************************************************************************
571 * *
572 \subsection{Adding inline pragmas}
573 * *
574 ************************************************************************
575 -}
576
577 decomposeRuleLhs :: [Var] -> CoreExpr -> Either SDoc ([Var], Id, [CoreExpr])
578 -- (decomposeRuleLhs bndrs lhs) takes apart the LHS of a RULE,
579 -- The 'bndrs' are the quantified binders of the rules, but decomposeRuleLhs
580 -- may add some extra dictionary binders (see Note [Free dictionaries])
581 --
582 -- Returns Nothing if the LHS isn't of the expected shape
583 -- Note [Decomposing the left-hand side of a RULE]
584 decomposeRuleLhs orig_bndrs orig_lhs
585 | not (null unbound) -- Check for things unbound on LHS
586 -- See Note [Unused spec binders]
587 = Left (vcat (map dead_msg unbound))
588
589 | Just (fn_id, args) <- decompose fun2 args2
590 , let extra_dict_bndrs = mk_extra_dict_bndrs fn_id args
591 = -- pprTrace "decmposeRuleLhs" (vcat [ ptext (sLit "orig_bndrs:") <+> ppr orig_bndrs
592 -- , ptext (sLit "orig_lhs:") <+> ppr orig_lhs
593 -- , ptext (sLit "lhs1:") <+> ppr lhs1
594 -- , ptext (sLit "extra_dict_bndrs:") <+> ppr extra_dict_bndrs
595 -- , ptext (sLit "fn_id:") <+> ppr fn_id
596 -- , ptext (sLit "args:") <+> ppr args]) $
597 Right (orig_bndrs ++ extra_dict_bndrs, fn_id, args)
598
599 | otherwise
600 = Left bad_shape_msg
601 where
602 lhs1 = drop_dicts orig_lhs
603 lhs2 = simpleOptExpr lhs1 -- See Note [Simplify rule LHS]
604 (fun2,args2) = collectArgs lhs2
605
606 lhs_fvs = exprFreeVars lhs2
607 unbound = filterOut (`elemVarSet` lhs_fvs) orig_bndrs
608
609 orig_bndr_set = mkVarSet orig_bndrs
610
611 -- Add extra dict binders: Note [Free dictionaries]
612 mk_extra_dict_bndrs fn_id args
613 = [ mkLocalId (localiseName (idName d)) (idType d)
614 | d <- varSetElems (exprsFreeVars args `delVarSetList` (fn_id : orig_bndrs))
615 -- fn_id: do not quantify over the function itself, which may
616 -- itself be a dictionary (in pathological cases, Trac #10251)
617 , isDictId d ]
618
619 decompose (Var fn_id) args
620 | not (fn_id `elemVarSet` orig_bndr_set)
621 = Just (fn_id, args)
622
623 decompose _ _ = Nothing
624
625 bad_shape_msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar"))
626 2 (vcat [ text "Optimised lhs:" <+> ppr lhs2
627 , text "Orig lhs:" <+> ppr orig_lhs])
628 dead_msg bndr = hang (sep [ ptext (sLit "Forall'd") <+> pp_bndr bndr
629 , ptext (sLit "is not bound in RULE lhs")])
630 2 (vcat [ text "Orig bndrs:" <+> ppr orig_bndrs
631 , text "Orig lhs:" <+> ppr orig_lhs
632 , text "optimised lhs:" <+> ppr lhs2 ])
633 pp_bndr bndr
634 | isTyVar bndr = ptext (sLit "type variable") <+> quotes (ppr bndr)
635 | Just pred <- evVarPred_maybe bndr = ptext (sLit "constraint") <+> quotes (ppr pred)
636 | otherwise = ptext (sLit "variable") <+> quotes (ppr bndr)
637
638 drop_dicts :: CoreExpr -> CoreExpr
639 drop_dicts e
640 = wrap_lets needed bnds body
641 where
642 needed = orig_bndr_set `minusVarSet` exprFreeVars body
643 (bnds, body) = split_lets (occurAnalyseExpr e)
644 -- The occurAnalyseExpr drops dead bindings which is
645 -- crucial to ensure that every binding is used later;
646 -- which in turn makes wrap_lets work right
647
648 split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr)
649 split_lets e
650 | Let (NonRec d r) body <- e
651 , isDictId d
652 , (bs, body') <- split_lets body
653 = ((d,r):bs, body')
654 | otherwise
655 = ([], e)
656
657 wrap_lets :: VarSet -> [(DictId,CoreExpr)] -> CoreExpr -> CoreExpr
658 wrap_lets _ [] body = body
659 wrap_lets needed ((d, r) : bs) body
660 | rhs_fvs `intersectsVarSet` needed = Let (NonRec d r) (wrap_lets needed' bs body)
661 | otherwise = wrap_lets needed bs body
662 where
663 rhs_fvs = exprFreeVars r
664 needed' = (needed `minusVarSet` rhs_fvs) `extendVarSet` d
665
666 {-
667 Note [Decomposing the left-hand side of a RULE]
668 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
669 There are several things going on here.
670 * drop_dicts: see Note [Drop dictionary bindings on rule LHS]
671 * simpleOptExpr: see Note [Simplify rule LHS]
672 * extra_dict_bndrs: see Note [Free dictionaries]
673
674 Note [Drop dictionary bindings on rule LHS]
675 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
676 drop_dicts drops dictionary bindings on the LHS where possible.
677 E.g. let d:Eq [Int] = $fEqList $fEqInt in f d
678 --> f d
679 Reasoning here is that there is only one d:Eq [Int], and so we can
680 quantify over it. That makes 'd' free in the LHS, but that is later
681 picked up by extra_dict_bndrs (Note [Dead spec binders]).
682
683 NB 1: We can only drop the binding if the RHS doesn't bind
684 one of the orig_bndrs, which we assume occur on RHS.
685 Example
686 f :: (Eq a) => b -> a -> a
687 {-# SPECIALISE f :: Eq a => b -> [a] -> [a] #-}
688 Here we want to end up with
689 RULE forall d:Eq a. f ($dfEqList d) = f_spec d
690 Of course, the ($dfEqlist d) in the pattern makes it less likely
691 to match, but there is no other way to get d:Eq a
692
693 NB 2: We do drop_dicts *before* simplOptEpxr, so that we expect all
694 the evidence bindings to be wrapped around the outside of the
695 LHS. (After simplOptExpr they'll usually have been inlined.)
696 dsHsWrapper does dependency analysis, so that civilised ones
697 will be simple NonRec bindings. We don't handle recursive
698 dictionaries!
699
700 NB3: In the common case of a non-overloaded, but perhaps-polymorphic
701 specialisation, we don't need to bind *any* dictionaries for use
702 in the RHS. For example (Trac #8331)
703 {-# SPECIALIZE INLINE useAbstractMonad :: ReaderST s Int #-}
704 useAbstractMonad :: MonadAbstractIOST m => m Int
705 Here, deriving (MonadAbstractIOST (ReaderST s)) is a lot of code
706 but the RHS uses no dictionaries, so we want to end up with
707 RULE forall s (d :: MonadAbstractIOST (ReaderT s)).
708 useAbstractMonad (ReaderT s) d = $suseAbstractMonad s
709
710 Trac #8848 is a good example of where there are some intersting
711 dictionary bindings to discard.
712
713 The drop_dicts algorithm is based on these observations:
714
715 * Given (let d = rhs in e) where d is a DictId,
716 matching 'e' will bind e's free variables.
717
718 * So we want to keep the binding if one of the needed variables (for
719 which we need a binding) is in fv(rhs) but not already in fv(e).
720
721 * The "needed variables" are simply the orig_bndrs. Consider
722 f :: (Eq a, Show b) => a -> b -> String
723 ... SPECIALISE f :: (Show b) => Int -> b -> String ...
724 Then orig_bndrs includes the *quantified* dictionaries of the type
725 namely (dsb::Show b), but not the one for Eq Int
726
727 So we work inside out, applying the above criterion at each step.
728
729
730 Note [Simplify rule LHS]
731 ~~~~~~~~~~~~~~~~~~~~~~~~
732 simplOptExpr occurrence-analyses and simplifies the LHS:
733
734 (a) Inline any remaining dictionary bindings (which hopefully
735 occur just once)
736
737 (b) Substitute trivial lets so that they don't get in the way
738 Note that we substitute the function too; we might
739 have this as a LHS: let f71 = M.f Int in f71
740
741 (c) Do eta reduction. To see why, consider the fold/build rule,
742 which without simplification looked like:
743 fold k z (build (/\a. g a)) ==> ...
744 This doesn't match unless you do eta reduction on the build argument.
745 Similarly for a LHS like
746 augment g (build h)
747 we do not want to get
748 augment (\a. g a) (build h)
749 otherwise we don't match when given an argument like
750 augment (\a. h a a) (build h)
751
752 Note [Matching seqId]
753 ~~~~~~~~~~~~~~~~~~~
754 The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
755 and this code turns it back into an application of seq!
756 See Note [Rules for seq] in MkId for the details.
757
758 Note [Unused spec binders]
759 ~~~~~~~~~~~~~~~~~~~~~~~~~~
760 Consider
761 f :: a -> a
762 ... SPECIALISE f :: Eq a => a -> a ...
763 It's true that this *is* a more specialised type, but the rule
764 we get is something like this:
765 f_spec d = f
766 RULE: f = f_spec d
767 Note that the rule is bogus, because it mentions a 'd' that is
768 not bound on the LHS! But it's a silly specialisation anyway, because
769 the constraint is unused. We could bind 'd' to (error "unused")
770 but it seems better to reject the program because it's almost certainly
771 a mistake. That's what the isDeadBinder call detects.
772
773 Note [Free dictionaries]
774 ~~~~~~~~~~~~~~~~~~~~~~~~
775 When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,
776 which is presumably in scope at the function definition site, we can quantify
777 over it too. *Any* dict with that type will do.
778
779 So for example when you have
780 f :: Eq a => a -> a
781 f = <rhs>
782 ... SPECIALISE f :: Int -> Int ...
783
784 Then we get the SpecPrag
785 SpecPrag (f Int dInt)
786
787 And from that we want the rule
788
789 RULE forall dInt. f Int dInt = f_spec
790 f_spec = let f = <rhs> in f Int dInt
791
792 But be careful! That dInt might be GHC.Base.$fOrdInt, which is an External
793 Name, and you can't bind them in a lambda or forall without getting things
794 confused. Likewise it might have an InlineRule or something, which would be
795 utterly bogus. So we really make a fresh Id, with the same unique and type
796 as the old one, but with an Internal name and no IdInfo.
797
798
799 ************************************************************************
800 * *
801 Desugaring evidence
802 * *
803 ************************************************************************
804
805 -}
806
807 dsHsWrapper :: HsWrapper -> CoreExpr -> DsM CoreExpr
808 dsHsWrapper WpHole e = return e
809 dsHsWrapper (WpTyApp ty) e = return $ App e (Type ty)
810 dsHsWrapper (WpLet ev_binds) e = do bs <- dsTcEvBinds ev_binds
811 return (mkCoreLets bs e)
812 dsHsWrapper (WpCompose c1 c2) e = do { e1 <- dsHsWrapper c2 e
813 ; dsHsWrapper c1 e1 }
814 dsHsWrapper (WpFun c1 c2 t1 _) e = do { x <- newSysLocalDs t1
815 ; e1 <- dsHsWrapper c1 (Var x)
816 ; e2 <- dsHsWrapper c2 (mkCoreAppDs (text "dsHsWrapper") e e1)
817 ; return (Lam x e2) }
818 dsHsWrapper (WpCast co) e = ASSERT(tcCoercionRole co == Representational)
819 dsTcCoercion co (mkCastDs e)
820 dsHsWrapper (WpEvLam ev) e = return $ Lam ev e
821 dsHsWrapper (WpTyLam tv) e = return $ Lam tv e
822 dsHsWrapper (WpEvApp tm) e = liftM (App e) (dsEvTerm tm)
823
824 --------------------------------------
825 dsTcEvBinds_s :: [TcEvBinds] -> DsM [CoreBind]
826 dsTcEvBinds_s [] = return []
827 dsTcEvBinds_s (b:rest) = ASSERT( null rest ) -- Zonker ensures null
828 dsTcEvBinds b
829
830 dsTcEvBinds :: TcEvBinds -> DsM [CoreBind]
831 dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this
832 dsTcEvBinds (EvBinds bs) = dsEvBinds bs
833
834 dsEvBinds :: Bag EvBind -> DsM [CoreBind]
835 dsEvBinds bs = mapM ds_scc (sccEvBinds bs)
836 where
837 ds_scc (AcyclicSCC (EvBind { eb_lhs = v, eb_rhs = r }))
838 = liftM (NonRec v) (dsEvTerm r)
839 ds_scc (CyclicSCC bs) = liftM Rec (mapM ds_pair bs)
840
841 ds_pair (EvBind { eb_lhs = v, eb_rhs = r }) = liftM ((,) v) (dsEvTerm r)
842
843 sccEvBinds :: Bag EvBind -> [SCC EvBind]
844 sccEvBinds bs = stronglyConnCompFromEdgedVertices edges
845 where
846 edges :: [(EvBind, EvVar, [EvVar])]
847 edges = foldrBag ((:) . mk_node) [] bs
848
849 mk_node :: EvBind -> (EvBind, EvVar, [EvVar])
850 mk_node b@(EvBind { eb_lhs = var, eb_rhs = term })
851 = (b, var, varSetElems (evVarsOfTerm term))
852
853
854 {-**********************************************************************
855 * *
856 Desugaring EvTerms
857 * *
858 **********************************************************************-}
859
860 dsEvTerm :: EvTerm -> DsM CoreExpr
861 dsEvTerm (EvId v) = return (Var v)
862 dsEvTerm (EvCallStack cs) = dsEvCallStack cs
863 dsEvTerm (EvTypeable ty ev) = dsEvTypeable ty ev
864 dsEvTerm (EvLit (EvNum n)) = mkIntegerExpr n
865 dsEvTerm (EvLit (EvStr s)) = mkStringExprFS s
866
867 dsEvTerm (EvCast tm co)
868 = do { tm' <- dsEvTerm tm
869 ; dsTcCoercion co $ mkCastDs tm' }
870 -- 'v' is always a lifted evidence variable so it is
871 -- unnecessary to call varToCoreExpr v here.
872
873 dsEvTerm (EvDFunApp df tys tms)
874 = return (Var df `mkTyApps` tys `mkApps` (map Var tms))
875
876 dsEvTerm (EvCoercion (TcCoVarCo v)) = return (Var v) -- See Note [Simple coercions]
877 dsEvTerm (EvCoercion co) = dsTcCoercion co mkEqBox
878
879 dsEvTerm (EvSuperClass d n)
880 = do { d' <- dsEvTerm d
881 ; let (cls, tys) = getClassPredTys (exprType d')
882 sc_sel_id = classSCSelId cls n -- Zero-indexed
883 ; return $ Var sc_sel_id `mkTyApps` tys `App` d' }
884
885 dsEvTerm (EvDelayedError ty msg)
886 = return $ Var errorId `mkTyApps` [ty] `mkApps` [litMsg]
887 where
888 errorId = tYPE_ERROR_ID
889 litMsg = Lit (MachStr (fastStringToByteString msg))
890
891 {-**********************************************************************
892 * *
893 Desugaring Typeable dictionaries
894 * *
895 **********************************************************************-}
896
897 dsEvTypeable :: Type -> EvTypeable -> DsM CoreExpr
898 -- Return a CoreExpr :: Typeable ty
899 -- This code is tightly coupled to the representation
900 -- of TypeRep, in base library Data.Typeable.Internals
901 dsEvTypeable ty ev
902 = do { tyCl <- dsLookupTyCon typeableClassName -- Typeable
903 ; let kind = typeKind ty
904 Just typeable_data_con
905 = tyConSingleDataCon_maybe tyCl -- "Data constructor"
906 -- for Typeable
907
908 ; rep_expr <- ds_ev_typeable ty ev
909
910 -- Build Core for (let r::TypeRep = rep in \proxy. rep)
911 -- See Note [Memoising typeOf]
912 ; repName <- newSysLocalDs (exprType rep_expr)
913 ; let proxyT = mkProxyPrimTy kind ty
914 method = bindNonRec repName rep_expr
915 $ mkLams [mkWildValBinder proxyT] (Var repName)
916
917 -- Package up the method as `Typeable` dictionary
918 ; return $ mkConApp typeable_data_con [Type kind, Type ty, method] }
919
920
921 ds_ev_typeable :: Type -> EvTypeable -> DsM CoreExpr
922 -- Returns a CoreExpr :: TypeRep ty
923 ds_ev_typeable ty EvTypeableTyCon
924 | Just (tc, ks) <- splitTyConApp_maybe ty
925 = ASSERT( all isKind ks )
926 do { ctr <- dsLookupGlobalId mkPolyTyConAppName
927 -- mkPolyTyConApp :: TyCon -> [KindRep] -> [TypeRep] -> TypeRep
928 ; tyRepTc <- dsLookupTyCon typeRepTyConName -- TypeRep (the TyCon)
929 ; let tyRepType = mkTyConApp tyRepTc [] -- TypeRep (the Type)
930 mkRep cRep kReps tReps
931 = mkApps (Var ctr) [ cRep
932 , mkListExpr tyRepType kReps
933 , mkListExpr tyRepType tReps ]
934
935 kindRep k -- Returns CoreExpr :: TypeRep for that kind k
936 = case splitTyConApp_maybe k of
937 Nothing -> panic "dsEvTypeable: not a kind constructor"
938 Just (kc,ks) -> do { kcRep <- tyConRep kc
939 ; reps <- mapM kindRep ks
940 ; return (mkRep kcRep [] reps) }
941
942 ; tcRep <- tyConRep tc
943 ; kReps <- mapM kindRep ks
944 ; return (mkRep tcRep kReps []) }
945
946 ds_ev_typeable ty (EvTypeableTyApp ev1 ev2)
947 | Just (t1,t2) <- splitAppTy_maybe ty
948 = do { e1 <- getRep ev1 t1
949 ; e2 <- getRep ev2 t2
950 ; ctr <- dsLookupGlobalId mkAppTyName
951 ; return ( mkApps (Var ctr) [ e1, e2 ] ) }
952
953 ds_ev_typeable ty (EvTypeableTyLit ev)
954 = do { fun <- dsLookupGlobalId tr_fun
955 ; dict <- dsEvTerm ev -- Of type KnownNat/KnownSym
956 ; let proxy = mkTyApps (Var proxyHashId) [ty_kind, ty]
957 ; return (mkApps (mkTyApps (Var fun) [ty]) [ dict, proxy ]) }
958 where
959 ty_kind = typeKind ty
960
961 -- tr_fun is the Name of
962 -- typeNatTypeRep :: KnownNat a => Proxy# a -> TypeRep
963 -- of typeSymbolTypeRep :: KnownSymbol a => Proxy# a -> TypeRep
964 tr_fun | ty_kind `eqType` typeNatKind = typeNatTypeRepName
965 | ty_kind `eqType` typeSymbolKind = typeSymbolTypeRepName
966 | otherwise = panic "dsEvTypeable: unknown type lit kind"
967
968
969 ds_ev_typeable ty ev
970 = pprPanic "dsEvTypeable" (ppr ty $$ ppr ev)
971
972 getRep :: EvTerm -> Type -- EvTerm for Typeable ty, and ty
973 -> DsM CoreExpr -- Return CoreExpr :: TypeRep (of ty)
974 -- namely (typeRep# dict proxy)
975 -- Remember that
976 -- typeRep# :: forall k (a::k). Typeable k a -> Proxy k a -> TypeRep
977 getRep ev ty
978 = do { typeable_expr <- dsEvTerm ev
979 ; typeRepId <- dsLookupGlobalId typeRepIdName
980 ; let ty_args = [typeKind ty, ty]
981 ; return (mkApps (mkTyApps (Var typeRepId) ty_args)
982 [ typeable_expr
983 , mkTyApps (Var proxyHashId) ty_args ]) }
984
985 tyConRep :: TyCon -> DsM CoreExpr
986 -- Returns CoreExpr :: TyCon
987 tyConRep tc
988 | Just tc_rep_nm <- tyConRepName_maybe tc
989 = do { tc_rep_id <- dsLookupGlobalId tc_rep_nm
990 ; return (Var tc_rep_id) }
991 | otherwise
992 = pprPanic "tyConRep" (ppr tc)
993
994 {- Note [Memoising typeOf]
995 ~~~~~~~~~~~~~~~~~~~~~~~~~~
996 See #3245, #9203
997
998 IMPORTANT: we don't want to recalculate the TypeRep once per call with
999 the proxy argument. This is what went wrong in #3245 and #9203. So we
1000 help GHC by manually keeping the 'rep' *outside* the lambda.
1001 -}
1002
1003
1004 {-**********************************************************************
1005 * *
1006 Desugaring EvCallStack evidence
1007 * *
1008 **********************************************************************-}
1009
1010 dsEvCallStack :: EvCallStack -> DsM CoreExpr
1011 -- See Note [Overview of implicit CallStacks] in TcEvidence.hs
1012 dsEvCallStack cs = do
1013 df <- getDynFlags
1014 m <- getModule
1015 srcLocDataCon <- dsLookupDataCon srcLocDataConName
1016 let srcLocTyCon = dataConTyCon srcLocDataCon
1017 let srcLocTy = mkTyConTy srcLocTyCon
1018 let mkSrcLoc l =
1019 liftM (mkCoreConApps srcLocDataCon)
1020 (sequence [ mkStringExprFS (unitIdFS $ moduleUnitId m)
1021 , mkStringExprFS (moduleNameFS $ moduleName m)
1022 , mkStringExprFS (srcSpanFile l)
1023 , return $ mkIntExprInt df (srcSpanStartLine l)
1024 , return $ mkIntExprInt df (srcSpanStartCol l)
1025 , return $ mkIntExprInt df (srcSpanEndLine l)
1026 , return $ mkIntExprInt df (srcSpanEndCol l)
1027 ])
1028
1029 -- Be careful to use [Char] instead of String here to avoid
1030 -- unnecessary dependencies on GHC.Base, particularly when
1031 -- building GHC.Err.absentError
1032 let callSiteTy = mkBoxedTupleTy [mkListTy charTy, srcLocTy]
1033
1034 matchId <- newSysLocalDs $ mkListTy callSiteTy
1035
1036 callStackDataCon <- dsLookupDataCon callStackDataConName
1037 let callStackTyCon = dataConTyCon callStackDataCon
1038 let callStackTy = mkTyConTy callStackTyCon
1039 let emptyCS = mkCoreConApps callStackDataCon [mkNilExpr callSiteTy]
1040 let pushCS name loc rest =
1041 mkWildCase rest callStackTy callStackTy
1042 [( DataAlt callStackDataCon
1043 , [matchId]
1044 , mkCoreConApps callStackDataCon
1045 [mkConsExpr callSiteTy
1046 (mkCoreTup [name, loc])
1047 (Var matchId)]
1048 )]
1049 let mkPush name loc tm = do
1050 nameExpr <- mkStringExprFS name
1051 locExpr <- mkSrcLoc loc
1052 case tm of
1053 EvCallStack EvCsEmpty -> return (pushCS nameExpr locExpr emptyCS)
1054 _ -> do tmExpr <- dsEvTerm tm
1055 -- at this point tmExpr :: IP sym CallStack
1056 -- but we need the actual CallStack to pass to pushCS,
1057 -- so we use unwrapIP to strip the dictionary wrapper
1058 -- See Note [Overview of implicit CallStacks]
1059 let ip_co = unwrapIP (exprType tmExpr)
1060 return (pushCS nameExpr locExpr (mkCastDs tmExpr ip_co))
1061 case cs of
1062 EvCsTop name loc tm -> mkPush name loc tm
1063 EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm
1064 EvCsEmpty -> panic "Cannot have an empty CallStack"
1065
1066 {-**********************************************************************
1067 * *
1068 Desugaring Coercions
1069 * *
1070 **********************************************************************-}
1071
1072 dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> DsM CoreExpr
1073 -- This is the crucial function that moves
1074 -- from TcCoercions to Coercions; see Note [TcCoercions] in Coercion
1075 -- e.g. dsTcCoercion (trans g1 g2) k
1076 -- = case g1 of EqBox g1# ->
1077 -- case g2 of EqBox g2# ->
1078 -- k (trans g1# g2#)
1079 -- thing_inside will get a coercion at the role requested
1080 dsTcCoercion co thing_inside
1081 = do { us <- newUniqueSupply
1082 ; let eqvs_covs :: [(EqVar,CoVar)]
1083 eqvs_covs = zipWith mk_co_var (varSetElems (coVarsOfTcCo co))
1084 (uniqsFromSupply us)
1085
1086 subst = mkCvSubst emptyInScopeSet [(eqv, mkCoVarCo cov) | (eqv, cov) <- eqvs_covs]
1087 result_expr = thing_inside (ds_tc_coercion subst co)
1088 result_ty = exprType result_expr
1089
1090 ; return (foldr (wrap_in_case result_ty) result_expr eqvs_covs) }
1091 where
1092 mk_co_var :: Id -> Unique -> (Id, Id)
1093 mk_co_var eqv uniq = (eqv, mkUserLocal occ uniq ty loc)
1094 where
1095 eq_nm = idName eqv
1096 occ = nameOccName eq_nm
1097 loc = nameSrcSpan eq_nm
1098 ty = mkCoercionType (getEqPredRole (evVarPred eqv)) ty1 ty2
1099 (ty1, ty2) = getEqPredTys (evVarPred eqv)
1100
1101 wrap_in_case result_ty (eqv, cov) body
1102 = case getEqPredRole (evVarPred eqv) of
1103 Nominal -> Case (Var eqv) eqv result_ty [(DataAlt eqBoxDataCon, [cov], body)]
1104 Representational -> Case (Var eqv) eqv result_ty [(DataAlt coercibleDataCon, [cov], body)]
1105 Phantom -> panic "wrap_in_case/phantom"
1106
1107 ds_tc_coercion :: CvSubst -> TcCoercion -> Coercion
1108 -- If the incoming TcCoercion if of type (a ~ b) (resp. Coercible a b)
1109 -- the result is of type (a ~# b) (reps. a ~# b)
1110 -- The VarEnv maps EqVars of type (a ~ b) to Coercions of type (a ~# b) (resp. and so on)
1111 -- No need for InScope set etc because the
1112 ds_tc_coercion subst tc_co
1113 = go tc_co
1114 where
1115 go (TcRefl r ty) = Refl r (Coercion.substTy subst ty)
1116 go (TcTyConAppCo r tc cos) = mkTyConAppCo r tc (map go cos)
1117 go (TcAppCo co1 co2) = mkAppCo (go co1) (go co2)
1118 go (TcForAllCo tv co) = mkForAllCo tv' (ds_tc_coercion subst' co)
1119 where
1120 (subst', tv') = Coercion.substTyVarBndr subst tv
1121 go (TcAxiomInstCo ax ind cos)
1122 = AxiomInstCo ax ind (map go cos)
1123 go (TcPhantomCo ty1 ty2) = UnivCo (fsLit "ds_tc_coercion") Phantom ty1 ty2
1124 go (TcSymCo co) = mkSymCo (go co)
1125 go (TcTransCo co1 co2) = mkTransCo (go co1) (go co2)
1126 go (TcNthCo n co) = mkNthCo n (go co)
1127 go (TcLRCo lr co) = mkLRCo lr (go co)
1128 go (TcSubCo co) = mkSubCo (go co)
1129 go (TcLetCo bs co) = ds_tc_coercion (ds_co_binds bs) co
1130 go (TcCastCo co1 co2) = mkCoCast (go co1) (go co2)
1131 go (TcCoVarCo v) = ds_ev_id subst v
1132 go (TcAxiomRuleCo co ts cs) = AxiomRuleCo co (map (Coercion.substTy subst) ts) (map go cs)
1133 go (TcCoercion co) = co
1134
1135 ds_co_binds :: TcEvBinds -> CvSubst
1136 ds_co_binds (EvBinds bs) = foldl ds_scc subst (sccEvBinds bs)
1137 ds_co_binds eb@(TcEvBinds {}) = pprPanic "ds_co_binds" (ppr eb)
1138
1139 ds_scc :: CvSubst -> SCC EvBind -> CvSubst
1140 ds_scc subst (AcyclicSCC (EvBind { eb_lhs = v, eb_rhs = ev_term }))
1141 = extendCvSubstAndInScope subst v (ds_co_term subst ev_term)
1142 ds_scc _ (CyclicSCC other) = pprPanic "ds_scc:cyclic" (ppr other $$ ppr tc_co)
1143
1144 ds_co_term :: CvSubst -> EvTerm -> Coercion
1145 ds_co_term subst (EvCoercion tc_co) = ds_tc_coercion subst tc_co
1146 ds_co_term subst (EvId v) = ds_ev_id subst v
1147 ds_co_term subst (EvCast tm co) = mkCoCast (ds_co_term subst tm) (ds_tc_coercion subst co)
1148 ds_co_term _ other = pprPanic "ds_co_term" (ppr other $$ ppr tc_co)
1149
1150 ds_ev_id :: CvSubst -> EqVar -> Coercion
1151 ds_ev_id subst v
1152 | Just co <- Coercion.lookupCoVar subst v = co
1153 | otherwise = pprPanic "ds_tc_coercion" (ppr v $$ ppr tc_co)
1154
1155 {-
1156 Note [Simple coercions]
1157 ~~~~~~~~~~~~~~~~~~~~~~~
1158 We have a special case for coercions that are simple variables.
1159 Suppose cv :: a ~ b is in scope
1160 Lacking the special case, if we see
1161 f a b cv
1162 we'd desguar to
1163 f a b (case cv of EqBox (cv# :: a ~# b) -> EqBox cv#)
1164 which is a bit stupid. The special case does the obvious thing.
1165
1166 This turns out to be important when desugaring the LHS of a RULE
1167 (see Trac #7837). Suppose we have
1168 normalise :: (a ~ Scalar a) => a -> a
1169 normalise_Double :: Double -> Double
1170 {-# RULES "normalise" normalise = normalise_Double #-}
1171
1172 Then the RULE we want looks like
1173 forall a, (cv:a~Scalar a).
1174 normalise a cv = normalise_Double
1175 But without the special case we generate the redundant box/unbox,
1176 which simpleOpt (currently) doesn't remove. So the rule never matches.
1177
1178 Maybe simpleOpt should be smarter. But it seems like a good plan
1179 to simply never generate the redundant box/unbox in the first place.
1180 -}