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