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