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