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