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