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