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