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