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