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