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