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