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