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