28e866d8e9436dc782fd81e250aa88a37d4c3cf3
[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
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)
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 = mkRule this_mod False {- Not auto -} 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
507 {- Note [SPECIALISE on INLINE functions]
508 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
509 We used to warn that using SPECIALISE for a function marked INLINE
510 would be a no-op; but it isn't! Especially with worker/wrapper split
511 we might have
512 {-# INLINE f #-}
513 f :: Ord a => Int -> a -> ...
514 f d x y = case x of I# x' -> $wf d x' y
515
516 We might want to specialise 'f' so that we in turn specialise '$wf'.
517 We can't even /name/ '$wf' in the source code, so we can't specialise
518 it even if we wanted to. Trac #10721 is a case in point.
519
520 Note [Activation pragmas for SPECIALISE]
521 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
522 From a user SPECIALISE pragma for f, we generate
523 a) A top-level binding spec_fn = rhs
524 b) A RULE f dOrd = spec_fn
525
526 We need two pragma-like things:
527
528 * spec_fn's inline pragma: inherited from f's inline pragma (ignoring
529 activation on SPEC), unless overriden by SPEC INLINE
530
531 * Activation of RULE: from SPECIALISE pragma (if activation given)
532 otherwise from f's inline pragma
533
534 This is not obvious (see Trac #5237)!
535
536 Examples Rule activation Inline prag on spec'd fn
537 ---------------------------------------------------------------------
538 SPEC [n] f :: ty [n] Always, or NOINLINE [n]
539 copy f's prag
540
541 NOINLINE f
542 SPEC [n] f :: ty [n] NOINLINE
543 copy f's prag
544
545 NOINLINE [k] f
546 SPEC [n] f :: ty [n] NOINLINE [k]
547 copy f's prag
548
549 INLINE [k] f
550 SPEC [n] f :: ty [n] INLINE [k]
551 copy f's prag
552
553 SPEC INLINE [n] f :: ty [n] INLINE [n]
554 (ignore INLINE prag on f,
555 same activation for rule and spec'd fn)
556
557 NOINLINE [k] f
558 SPEC f :: ty [n] INLINE [k]
559
560
561 ************************************************************************
562 * *
563 \subsection{Adding inline pragmas}
564 * *
565 ************************************************************************
566 -}
567
568 decomposeRuleLhs :: [Var] -> CoreExpr -> Either SDoc ([Var], Id, [CoreExpr])
569 -- (decomposeRuleLhs bndrs lhs) takes apart the LHS of a RULE,
570 -- The 'bndrs' are the quantified binders of the rules, but decomposeRuleLhs
571 -- may add some extra dictionary binders (see Note [Free dictionaries])
572 --
573 -- Returns Nothing if the LHS isn't of the expected shape
574 -- Note [Decomposing the left-hand side of a RULE]
575 decomposeRuleLhs orig_bndrs orig_lhs
576 | not (null unbound) -- Check for things unbound on LHS
577 -- See Note [Unused spec binders]
578 = Left (vcat (map dead_msg unbound))
579
580 | Just (fn_id, args) <- decompose fun2 args2
581 , let extra_dict_bndrs = mk_extra_dict_bndrs fn_id args
582 = -- pprTrace "decmposeRuleLhs" (vcat [ ptext (sLit "orig_bndrs:") <+> ppr orig_bndrs
583 -- , ptext (sLit "orig_lhs:") <+> ppr orig_lhs
584 -- , ptext (sLit "lhs1:") <+> ppr lhs1
585 -- , ptext (sLit "extra_dict_bndrs:") <+> ppr extra_dict_bndrs
586 -- , ptext (sLit "fn_id:") <+> ppr fn_id
587 -- , ptext (sLit "args:") <+> ppr args]) $
588 Right (orig_bndrs ++ extra_dict_bndrs, fn_id, args)
589
590 | otherwise
591 = Left bad_shape_msg
592 where
593 lhs1 = drop_dicts orig_lhs
594 lhs2 = simpleOptExpr lhs1 -- See Note [Simplify rule LHS]
595 (fun2,args2) = collectArgs lhs2
596
597 lhs_fvs = exprFreeVars lhs2
598 unbound = filterOut (`elemVarSet` lhs_fvs) orig_bndrs
599
600 orig_bndr_set = mkVarSet orig_bndrs
601
602 -- Add extra dict binders: Note [Free dictionaries]
603 mk_extra_dict_bndrs fn_id args
604 = [ mkLocalId (localiseName (idName d)) (idType d)
605 | d <- varSetElems (exprsFreeVars args `delVarSetList` (fn_id : orig_bndrs))
606 -- fn_id: do not quantify over the function itself, which may
607 -- itself be a dictionary (in pathological cases, Trac #10251)
608 , isDictId d ]
609
610 decompose (Var fn_id) args
611 | not (fn_id `elemVarSet` orig_bndr_set)
612 = Just (fn_id, args)
613
614 decompose _ _ = Nothing
615
616 bad_shape_msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar"))
617 2 (vcat [ text "Optimised lhs:" <+> ppr lhs2
618 , text "Orig lhs:" <+> ppr orig_lhs])
619 dead_msg bndr = hang (sep [ ptext (sLit "Forall'd") <+> pp_bndr bndr
620 , ptext (sLit "is not bound in RULE lhs")])
621 2 (vcat [ text "Orig bndrs:" <+> ppr orig_bndrs
622 , text "Orig lhs:" <+> ppr orig_lhs
623 , text "optimised lhs:" <+> ppr lhs2 ])
624 pp_bndr bndr
625 | isTyVar bndr = ptext (sLit "type variable") <+> quotes (ppr bndr)
626 | Just pred <- evVarPred_maybe bndr = ptext (sLit "constraint") <+> quotes (ppr pred)
627 | otherwise = ptext (sLit "variable") <+> quotes (ppr bndr)
628
629 drop_dicts :: CoreExpr -> CoreExpr
630 drop_dicts e
631 = wrap_lets needed bnds body
632 where
633 needed = orig_bndr_set `minusVarSet` exprFreeVars body
634 (bnds, body) = split_lets (occurAnalyseExpr e)
635 -- The occurAnalyseExpr drops dead bindings which is
636 -- crucial to ensure that every binding is used later;
637 -- which in turn makes wrap_lets work right
638
639 split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr)
640 split_lets e
641 | Let (NonRec d r) body <- e
642 , isDictId d
643 , (bs, body') <- split_lets body
644 = ((d,r):bs, body')
645 | otherwise
646 = ([], e)
647
648 wrap_lets :: VarSet -> [(DictId,CoreExpr)] -> CoreExpr -> CoreExpr
649 wrap_lets _ [] body = body
650 wrap_lets needed ((d, r) : bs) body
651 | rhs_fvs `intersectsVarSet` needed = Let (NonRec d r) (wrap_lets needed' bs body)
652 | otherwise = wrap_lets needed bs body
653 where
654 rhs_fvs = exprFreeVars r
655 needed' = (needed `minusVarSet` rhs_fvs) `extendVarSet` d
656
657 {-
658 Note [Decomposing the left-hand side of a RULE]
659 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
660 There are several things going on here.
661 * drop_dicts: see Note [Drop dictionary bindings on rule LHS]
662 * simpleOptExpr: see Note [Simplify rule LHS]
663 * extra_dict_bndrs: see Note [Free dictionaries]
664
665 Note [Drop dictionary bindings on rule LHS]
666 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
667 drop_dicts drops dictionary bindings on the LHS where possible.
668 E.g. let d:Eq [Int] = $fEqList $fEqInt in f d
669 --> f d
670 Reasoning here is that there is only one d:Eq [Int], and so we can
671 quantify over it. That makes 'd' free in the LHS, but that is later
672 picked up by extra_dict_bndrs (Note [Dead spec binders]).
673
674 NB 1: We can only drop the binding if the RHS doesn't bind
675 one of the orig_bndrs, which we assume occur on RHS.
676 Example
677 f :: (Eq a) => b -> a -> a
678 {-# SPECIALISE f :: Eq a => b -> [a] -> [a] #-}
679 Here we want to end up with
680 RULE forall d:Eq a. f ($dfEqList d) = f_spec d
681 Of course, the ($dfEqlist d) in the pattern makes it less likely
682 to match, but there is no other way to get d:Eq a
683
684 NB 2: We do drop_dicts *before* simplOptEpxr, so that we expect all
685 the evidence bindings to be wrapped around the outside of the
686 LHS. (After simplOptExpr they'll usually have been inlined.)
687 dsHsWrapper does dependency analysis, so that civilised ones
688 will be simple NonRec bindings. We don't handle recursive
689 dictionaries!
690
691 NB3: In the common case of a non-overloaded, but perhaps-polymorphic
692 specialisation, we don't need to bind *any* dictionaries for use
693 in the RHS. For example (Trac #8331)
694 {-# SPECIALIZE INLINE useAbstractMonad :: ReaderST s Int #-}
695 useAbstractMonad :: MonadAbstractIOST m => m Int
696 Here, deriving (MonadAbstractIOST (ReaderST s)) is a lot of code
697 but the RHS uses no dictionaries, so we want to end up with
698 RULE forall s (d :: MonadAbstractIOST (ReaderT s)).
699 useAbstractMonad (ReaderT s) d = $suseAbstractMonad s
700
701 Trac #8848 is a good example of where there are some intersting
702 dictionary bindings to discard.
703
704 The drop_dicts algorithm is based on these observations:
705
706 * Given (let d = rhs in e) where d is a DictId,
707 matching 'e' will bind e's free variables.
708
709 * So we want to keep the binding if one of the needed variables (for
710 which we need a binding) is in fv(rhs) but not already in fv(e).
711
712 * The "needed variables" are simply the orig_bndrs. Consider
713 f :: (Eq a, Show b) => a -> b -> String
714 ... SPECIALISE f :: (Show b) => Int -> b -> String ...
715 Then orig_bndrs includes the *quantified* dictionaries of the type
716 namely (dsb::Show b), but not the one for Eq Int
717
718 So we work inside out, applying the above criterion at each step.
719
720
721 Note [Simplify rule LHS]
722 ~~~~~~~~~~~~~~~~~~~~~~~~
723 simplOptExpr occurrence-analyses and simplifies the LHS:
724
725 (a) Inline any remaining dictionary bindings (which hopefully
726 occur just once)
727
728 (b) Substitute trivial lets so that they don't get in the way
729 Note that we substitute the function too; we might
730 have this as a LHS: let f71 = M.f Int in f71
731
732 (c) Do eta reduction. To see why, consider the fold/build rule,
733 which without simplification looked like:
734 fold k z (build (/\a. g a)) ==> ...
735 This doesn't match unless you do eta reduction on the build argument.
736 Similarly for a LHS like
737 augment g (build h)
738 we do not want to get
739 augment (\a. g a) (build h)
740 otherwise we don't match when given an argument like
741 augment (\a. h a a) (build h)
742
743 Note [Matching seqId]
744 ~~~~~~~~~~~~~~~~~~~
745 The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
746 and this code turns it back into an application of seq!
747 See Note [Rules for seq] in MkId for the details.
748
749 Note [Unused spec binders]
750 ~~~~~~~~~~~~~~~~~~~~~~~~~~
751 Consider
752 f :: a -> a
753 ... SPECIALISE f :: Eq a => a -> a ...
754 It's true that this *is* a more specialised type, but the rule
755 we get is something like this:
756 f_spec d = f
757 RULE: f = f_spec d
758 Note that the rule is bogus, because it mentions a 'd' that is
759 not bound on the LHS! But it's a silly specialisation anyway, because
760 the constraint is unused. We could bind 'd' to (error "unused")
761 but it seems better to reject the program because it's almost certainly
762 a mistake. That's what the isDeadBinder call detects.
763
764 Note [Free dictionaries]
765 ~~~~~~~~~~~~~~~~~~~~~~~~
766 When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,
767 which is presumably in scope at the function definition site, we can quantify
768 over it too. *Any* dict with that type will do.
769
770 So for example when you have
771 f :: Eq a => a -> a
772 f = <rhs>
773 ... SPECIALISE f :: Int -> Int ...
774
775 Then we get the SpecPrag
776 SpecPrag (f Int dInt)
777
778 And from that we want the rule
779
780 RULE forall dInt. f Int dInt = f_spec
781 f_spec = let f = <rhs> in f Int dInt
782
783 But be careful! That dInt might be GHC.Base.$fOrdInt, which is an External
784 Name, and you can't bind them in a lambda or forall without getting things
785 confused. Likewise it might have an InlineRule or something, which would be
786 utterly bogus. So we really make a fresh Id, with the same unique and type
787 as the old one, but with an Internal name and no IdInfo.
788
789
790 ************************************************************************
791 * *
792 Desugaring evidence
793 * *
794 ************************************************************************
795
796 -}
797
798 dsHsWrapper :: HsWrapper -> CoreExpr -> DsM CoreExpr
799 dsHsWrapper WpHole e = return e
800 dsHsWrapper (WpTyApp ty) e = return $ App e (Type ty)
801 dsHsWrapper (WpLet ev_binds) e = do bs <- dsTcEvBinds ev_binds
802 return (mkCoreLets bs e)
803 dsHsWrapper (WpCompose c1 c2) e = do { e1 <- dsHsWrapper c2 e
804 ; dsHsWrapper c1 e1 }
805 dsHsWrapper (WpFun c1 c2 t1 _) e = do { x <- newSysLocalDs t1
806 ; e1 <- dsHsWrapper c1 (Var x)
807 ; e2 <- dsHsWrapper c2 (e `mkCoreAppDs` e1)
808 ; return (Lam x e2) }
809 dsHsWrapper (WpCast co) e = ASSERT(tcCoercionRole co == Representational)
810 dsTcCoercion co (mkCastDs e)
811 dsHsWrapper (WpEvLam ev) e = return $ Lam ev e
812 dsHsWrapper (WpTyLam tv) e = return $ Lam tv e
813 dsHsWrapper (WpEvApp tm) e = liftM (App e) (dsEvTerm tm)
814
815 --------------------------------------
816 dsTcEvBinds_s :: [TcEvBinds] -> DsM [CoreBind]
817 dsTcEvBinds_s [] = return []
818 dsTcEvBinds_s (b:rest) = ASSERT( null rest ) -- Zonker ensures null
819 dsTcEvBinds b
820
821 dsTcEvBinds :: TcEvBinds -> DsM [CoreBind]
822 dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this
823 dsTcEvBinds (EvBinds bs) = dsEvBinds bs
824
825 dsEvBinds :: Bag EvBind -> DsM [CoreBind]
826 dsEvBinds bs = mapM ds_scc (sccEvBinds bs)
827 where
828 ds_scc (AcyclicSCC (EvBind { eb_lhs = v, eb_rhs = r }))
829 = liftM (NonRec v) (dsEvTerm r)
830 ds_scc (CyclicSCC bs) = liftM Rec (mapM ds_pair bs)
831
832 ds_pair (EvBind { eb_lhs = v, eb_rhs = r }) = liftM ((,) v) (dsEvTerm r)
833
834 sccEvBinds :: Bag EvBind -> [SCC EvBind]
835 sccEvBinds bs = stronglyConnCompFromEdgedVertices edges
836 where
837 edges :: [(EvBind, EvVar, [EvVar])]
838 edges = foldrBag ((:) . mk_node) [] bs
839
840 mk_node :: EvBind -> (EvBind, EvVar, [EvVar])
841 mk_node b@(EvBind { eb_lhs = var, eb_rhs = term })
842 = (b, var, varSetElems (evVarsOfTerm term))
843
844
845 ---------------------------------------
846 dsEvTerm :: EvTerm -> DsM CoreExpr
847 dsEvTerm (EvId v) = return (Var v)
848
849 dsEvTerm (EvCast tm co)
850 = do { tm' <- dsEvTerm tm
851 ; dsTcCoercion co $ mkCastDs tm' }
852 -- 'v' is always a lifted evidence variable so it is
853 -- unnecessary to call varToCoreExpr v here.
854
855 dsEvTerm (EvDFunApp df tys tms) = return (Var df `mkTyApps` tys `mkApps` (map Var tms))
856 dsEvTerm (EvCoercion (TcCoVarCo v)) = return (Var v) -- See Note [Simple coercions]
857 dsEvTerm (EvCoercion co) = dsTcCoercion co mkEqBox
858 dsEvTerm (EvSuperClass d n)
859 = do { d' <- dsEvTerm d
860 ; let (cls, tys) = getClassPredTys (exprType d')
861 sc_sel_id = classSCSelId cls n -- Zero-indexed
862 ; return $ Var sc_sel_id `mkTyApps` tys `App` d' }
863
864 dsEvTerm (EvDelayedError ty msg) = return $ Var errorId `mkTyApps` [ty] `mkApps` [litMsg]
865 where
866 errorId = tYPE_ERROR_ID
867 litMsg = Lit (MachStr (fastStringToByteString msg))
868
869 dsEvTerm (EvLit l) =
870 case l of
871 EvNum n -> mkIntegerExpr n
872 EvStr s -> mkStringExprFS s
873
874 dsEvTerm (EvCallStack cs) = dsEvCallStack cs
875
876 dsEvTerm (EvTypeable ev) = dsEvTypeable ev
877
878 dsEvTypeable :: EvTypeable -> DsM CoreExpr
879 dsEvTypeable ev =
880 do tyCl <- dsLookupTyCon typeableClassName
881 typeRepTc <- dsLookupTyCon typeRepTyConName
882 let tyRepType = mkTyConApp typeRepTc []
883
884 (ty, rep) <-
885 case ev of
886
887 EvTypeableTyCon tc ks ->
888 do ctr <- dsLookupGlobalId mkPolyTyConAppName
889 mkTyCon <- dsLookupGlobalId mkTyConName
890 dflags <- getDynFlags
891 let mkRep cRep kReps tReps =
892 mkApps (Var ctr) [ cRep, mkListExpr tyRepType kReps
893 , mkListExpr tyRepType tReps ]
894
895 let kindRep k =
896 case splitTyConApp_maybe k of
897 Nothing -> panic "dsEvTypeable: not a kind constructor"
898 Just (kc,ks) ->
899 do kcRep <- tyConRep dflags mkTyCon kc
900 reps <- mapM kindRep ks
901 return (mkRep kcRep [] reps)
902
903 tcRep <- tyConRep dflags mkTyCon tc
904
905 kReps <- mapM kindRep ks
906
907 return ( mkTyConApp tc ks
908 , mkRep tcRep kReps []
909 )
910
911 EvTypeableTyApp t1 t2 ->
912 do e1 <- getRep tyCl t1
913 e2 <- getRep tyCl t2
914 ctr <- dsLookupGlobalId mkAppTyName
915
916 return ( mkAppTy (snd t1) (snd t2)
917 , mkApps (Var ctr) [ e1, e2 ]
918 )
919
920 EvTypeableTyLit t ->
921 do e <- tyLitRep t
922 return (snd t, e)
923
924 -- TyRep -> Typeable t
925 -- see also: Note [Memoising typeOf]
926 repName <- newSysLocalDs tyRepType
927 let proxyT = mkProxyPrimTy (typeKind ty) ty
928 method = bindNonRec repName rep
929 $ mkLams [mkWildValBinder proxyT] (Var repName)
930
931 -- package up the method as `Typeable` dictionary
932 return $ mkCastDs method $ mkSymCo $ getTypeableCo tyCl ty
933
934 where
935 -- co: method -> Typeable k t
936 getTypeableCo tc t =
937 case instNewTyCon_maybe tc [typeKind t, t] of
938 Just (_,co) -> co
939 _ -> panic "Class `Typeable` is not a `newtype`."
940
941 -- Typeable t -> TyRep
942 getRep tc (ev,t) =
943 do typeableExpr <- dsEvTerm ev
944 let co = getTypeableCo tc t
945 method = mkCastDs typeableExpr co
946 proxy = mkTyApps (Var proxyHashId) [typeKind t, t]
947 return (mkApps method [proxy])
948
949 -- KnownNat t -> TyRep (also used for KnownSymbol)
950 tyLitRep (ev,t) =
951 do dict <- dsEvTerm ev
952 fun <- dsLookupGlobalId $
953 case typeKind t of
954 k | eqType k typeNatKind -> typeNatTypeRepName
955 | eqType k typeSymbolKind -> typeSymbolTypeRepName
956 | otherwise -> panic "dsEvTypeable: unknown type lit kind"
957 let finst = mkTyApps (Var fun) [t]
958 proxy = mkTyApps (Var proxyHashId) [typeKind t, t]
959 return (mkApps finst [ dict, proxy ])
960
961 -- This part could be cached
962 tyConRep dflags mkTyCon tc =
963 do pkgStr <- mkStringExprFS pkg_fs
964 modStr <- mkStringExprFS modl_fs
965 nameStr <- mkStringExprFS name_fs
966 return (mkApps (Var mkTyCon) [ int64 high, int64 low
967 , pkgStr, modStr, nameStr
968 ])
969 where
970 tycon_name = tyConName tc
971 modl = nameModule tycon_name
972 pkg = modulePackageKey modl
973
974 modl_fs = moduleNameFS (moduleName modl)
975 pkg_fs = packageKeyFS pkg
976 name_fs = occNameFS (nameOccName tycon_name)
977 hash_name_fs
978 | isPromotedTyCon tc = appendFS (mkFastString "$k") name_fs
979 | isPromotedDataCon tc = appendFS (mkFastString "$c") name_fs
980 | isTupleTyCon tc &&
981 returnsConstraintKind (tyConKind tc)
982 = appendFS (mkFastString "$p") name_fs
983 | otherwise = name_fs
984
985 hashThis = unwords $ map unpackFS [pkg_fs, modl_fs, hash_name_fs]
986 Fingerprint high low = fingerprintString hashThis
987
988 int64
989 | wORD_SIZE dflags == 4 = mkWord64LitWord64
990 | otherwise = mkWordLit dflags . fromIntegral
991
992
993
994 {- Note [Memoising typeOf]
995 ~~~~~~~~~~~~~~~~~~~~~~~~~~
996 See #3245, #9203
997
998 IMPORTANT: we don't want to recalculate the TypeRep once per call with
999 the proxy argument. This is what went wrong in #3245 and #9203. So we
1000 help GHC by manually keeping the 'rep' *outside* the lambda.
1001 -}
1002
1003
1004
1005
1006
1007 dsEvCallStack :: EvCallStack -> DsM CoreExpr
1008 -- See Note [Overview of implicit CallStacks] in TcEvidence.hs
1009 dsEvCallStack cs = do
1010 df <- getDynFlags
1011 m <- getModule
1012 srcLocDataCon <- dsLookupDataCon srcLocDataConName
1013 let srcLocTyCon = dataConTyCon srcLocDataCon
1014 let srcLocTy = mkTyConTy srcLocTyCon
1015 let mkSrcLoc l =
1016 liftM (mkCoreConApps srcLocDataCon)
1017 (sequence [ mkStringExpr (showPpr df $ modulePackageKey m)
1018 , mkStringExprFS (moduleNameFS $ moduleName m)
1019 , mkStringExprFS (srcSpanFile l)
1020 , return $ mkIntExprInt df (srcSpanStartLine l)
1021 , return $ mkIntExprInt df (srcSpanStartCol l)
1022 , return $ mkIntExprInt df (srcSpanEndLine l)
1023 , return $ mkIntExprInt df (srcSpanEndCol l)
1024 ])
1025
1026 -- Be careful to use [Char] instead of String here to avoid
1027 -- unnecessary dependencies on GHC.Base, particularly when
1028 -- building GHC.Err.absentError
1029 let callSiteTy = mkBoxedTupleTy [mkListTy charTy, srcLocTy]
1030
1031 matchId <- newSysLocalDs $ mkListTy callSiteTy
1032
1033 callStackDataCon <- dsLookupDataCon callStackDataConName
1034 let callStackTyCon = dataConTyCon callStackDataCon
1035 let callStackTy = mkTyConTy callStackTyCon
1036 let emptyCS = mkCoreConApps callStackDataCon [mkNilExpr callSiteTy]
1037 let pushCS name loc rest =
1038 mkWildCase rest callStackTy callStackTy
1039 [( DataAlt callStackDataCon
1040 , [matchId]
1041 , mkCoreConApps callStackDataCon
1042 [mkConsExpr callSiteTy
1043 (mkCoreTup [name, loc])
1044 (Var matchId)]
1045 )]
1046 let mkPush name loc tm = do
1047 nameExpr <- mkStringExprFS name
1048 locExpr <- mkSrcLoc loc
1049 case tm of
1050 EvCallStack EvCsEmpty -> return (pushCS nameExpr locExpr emptyCS)
1051 _ -> do tmExpr <- dsEvTerm tm
1052 -- at this point tmExpr :: IP sym CallStack
1053 -- but we need the actual CallStack to pass to pushCS,
1054 -- so we use unwrapIP to strip the dictionary wrapper
1055 -- See Note [Overview of implicit CallStacks]
1056 let ip_co = unwrapIP (exprType tmExpr)
1057 return (pushCS nameExpr locExpr (mkCastDs tmExpr ip_co))
1058 case cs of
1059 EvCsTop name loc tm -> mkPush name loc tm
1060 EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm
1061 EvCsEmpty -> panic "Cannot have an empty CallStack"
1062
1063 ---------------------------------------
1064 dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> DsM CoreExpr
1065 -- This is the crucial function that moves
1066 -- from TcCoercions to Coercions; see Note [TcCoercions] in Coercion
1067 -- e.g. dsTcCoercion (trans g1 g2) k
1068 -- = case g1 of EqBox g1# ->
1069 -- case g2 of EqBox g2# ->
1070 -- k (trans g1# g2#)
1071 -- thing_inside will get a coercion at the role requested
1072 dsTcCoercion co thing_inside
1073 = do { us <- newUniqueSupply
1074 ; let eqvs_covs :: [(EqVar,CoVar)]
1075 eqvs_covs = zipWith mk_co_var (varSetElems (coVarsOfTcCo co))
1076 (uniqsFromSupply us)
1077
1078 subst = mkCvSubst emptyInScopeSet [(eqv, mkCoVarCo cov) | (eqv, cov) <- eqvs_covs]
1079 result_expr = thing_inside (ds_tc_coercion subst co)
1080 result_ty = exprType result_expr
1081
1082 ; return (foldr (wrap_in_case result_ty) result_expr eqvs_covs) }
1083 where
1084 mk_co_var :: Id -> Unique -> (Id, Id)
1085 mk_co_var eqv uniq = (eqv, mkUserLocal occ uniq ty loc)
1086 where
1087 eq_nm = idName eqv
1088 occ = nameOccName eq_nm
1089 loc = nameSrcSpan eq_nm
1090 ty = mkCoercionType (getEqPredRole (evVarPred eqv)) ty1 ty2
1091 (ty1, ty2) = getEqPredTys (evVarPred eqv)
1092
1093 wrap_in_case result_ty (eqv, cov) body
1094 = case getEqPredRole (evVarPred eqv) of
1095 Nominal -> Case (Var eqv) eqv result_ty [(DataAlt eqBoxDataCon, [cov], body)]
1096 Representational -> Case (Var eqv) eqv result_ty [(DataAlt coercibleDataCon, [cov], body)]
1097 Phantom -> panic "wrap_in_case/phantom"
1098
1099 ds_tc_coercion :: CvSubst -> TcCoercion -> Coercion
1100 -- If the incoming TcCoercion if of type (a ~ b) (resp. Coercible a b)
1101 -- the result is of type (a ~# b) (reps. a ~# b)
1102 -- The VarEnv maps EqVars of type (a ~ b) to Coercions of type (a ~# b) (resp. and so on)
1103 -- No need for InScope set etc because the
1104 ds_tc_coercion subst tc_co
1105 = go tc_co
1106 where
1107 go (TcRefl r ty) = Refl r (Coercion.substTy subst ty)
1108 go (TcTyConAppCo r tc cos) = mkTyConAppCo r tc (map go cos)
1109 go (TcAppCo co1 co2) = mkAppCo (go co1) (go co2)
1110 go (TcForAllCo tv co) = mkForAllCo tv' (ds_tc_coercion subst' co)
1111 where
1112 (subst', tv') = Coercion.substTyVarBndr subst tv
1113 go (TcAxiomInstCo ax ind cos)
1114 = AxiomInstCo ax ind (map go cos)
1115 go (TcPhantomCo ty1 ty2) = UnivCo (fsLit "ds_tc_coercion") Phantom ty1 ty2
1116 go (TcSymCo co) = mkSymCo (go co)
1117 go (TcTransCo co1 co2) = mkTransCo (go co1) (go co2)
1118 go (TcNthCo n co) = mkNthCo n (go co)
1119 go (TcLRCo lr co) = mkLRCo lr (go co)
1120 go (TcSubCo co) = mkSubCo (go co)
1121 go (TcLetCo bs co) = ds_tc_coercion (ds_co_binds bs) co
1122 go (TcCastCo co1 co2) = mkCoCast (go co1) (go co2)
1123 go (TcCoVarCo v) = ds_ev_id subst v
1124 go (TcAxiomRuleCo co ts cs) = AxiomRuleCo co (map (Coercion.substTy subst) ts) (map go cs)
1125 go (TcCoercion co) = co
1126
1127 ds_co_binds :: TcEvBinds -> CvSubst
1128 ds_co_binds (EvBinds bs) = foldl ds_scc subst (sccEvBinds bs)
1129 ds_co_binds eb@(TcEvBinds {}) = pprPanic "ds_co_binds" (ppr eb)
1130
1131 ds_scc :: CvSubst -> SCC EvBind -> CvSubst
1132 ds_scc subst (AcyclicSCC (EvBind { eb_lhs = v, eb_rhs = ev_term }))
1133 = extendCvSubstAndInScope subst v (ds_co_term subst ev_term)
1134 ds_scc _ (CyclicSCC other) = pprPanic "ds_scc:cyclic" (ppr other $$ ppr tc_co)
1135
1136 ds_co_term :: CvSubst -> EvTerm -> Coercion
1137 ds_co_term subst (EvCoercion tc_co) = ds_tc_coercion subst tc_co
1138 ds_co_term subst (EvId v) = ds_ev_id subst v
1139 ds_co_term subst (EvCast tm co) = mkCoCast (ds_co_term subst tm) (ds_tc_coercion subst co)
1140 ds_co_term _ other = pprPanic "ds_co_term" (ppr other $$ ppr tc_co)
1141
1142 ds_ev_id :: CvSubst -> EqVar -> Coercion
1143 ds_ev_id subst v
1144 | Just co <- Coercion.lookupCoVar subst v = co
1145 | otherwise = pprPanic "ds_tc_coercion" (ppr v $$ ppr tc_co)
1146
1147 {-
1148 Note [Simple coercions]
1149 ~~~~~~~~~~~~~~~~~~~~~~~
1150 We have a special case for coercions that are simple variables.
1151 Suppose cv :: a ~ b is in scope
1152 Lacking the special case, if we see
1153 f a b cv
1154 we'd desguar to
1155 f a b (case cv of EqBox (cv# :: a ~# b) -> EqBox cv#)
1156 which is a bit stupid. The special case does the obvious thing.
1157
1158 This turns out to be important when desugaring the LHS of a RULE
1159 (see Trac #7837). Suppose we have
1160 normalise :: (a ~ Scalar a) => a -> a
1161 normalise_Double :: Double -> Double
1162 {-# RULES "normalise" normalise = normalise_Double #-}
1163
1164 Then the RULE we want looks like
1165 forall a, (cv:a~Scalar a).
1166 normalise a cv = normalise_Double
1167 But without the special case we generate the redundant box/unbox,
1168 which simpleOpt (currently) doesn't remove. So the rule never matches.
1169
1170 Maybe simpleOpt should be smarter. But it seems like a good plan
1171 to simply never generate the redundant box/unbox in the first place.
1172 -}