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