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