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