1{- 2(c) The University of Glasgow 2006 3(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 4-} 5 6{-# LANGUAGE CPP #-} 7{-# LANGUAGE MultiWayIf #-} 8 9module GHC.Core.SimpleOpt ( 10 -- ** Simple expression optimiser 11 simpleOptPgm, simpleOptExpr, simpleOptExprWith, 12 13 -- ** Join points 14 joinPointBinding_maybe, joinPointBindings_maybe, 15 16 -- ** Predicates on expressions 17 exprIsConApp_maybe, exprIsLiteral_maybe, exprIsLambda_maybe, 18 19 -- ** Coercions and casts 20 pushCoArg, pushCoValArg, pushCoTyArg, collectBindersPushingCo 21 ) where 22 23#include "GhclibHsVersions.h" 24 25import GHC.Prelude 26 27import GHC.Core.Opt.Arity( etaExpandToJoinPoint ) 28 29import GHC.Core 30import GHC.Core.Subst 31import GHC.Core.Utils 32import GHC.Core.FVs 33import {-# SOURCE #-} GHC.Core.Unfold( mkUnfolding ) 34import GHC.Core.Make ( FloatBind(..) ) 35import GHC.Core.Ppr ( pprCoreBindings, pprRules ) 36import GHC.Core.Opt.OccurAnal( occurAnalyseExpr, occurAnalysePgm ) 37import GHC.Types.Literal 38import GHC.Types.Id 39import GHC.Types.Id.Info ( unfoldingInfo, setUnfoldingInfo, setRuleInfo, IdInfo (..) ) 40import GHC.Types.Var ( isNonCoVarId ) 41import GHC.Types.Var.Set 42import GHC.Types.Var.Env 43import GHC.Core.DataCon 44import GHC.Types.Demand( etaConvertStrictSig ) 45import GHC.Core.Coercion.Opt ( optCoercion ) 46import GHC.Core.Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList 47 , isInScope, substTyVarBndr, cloneTyVarBndr ) 48import GHC.Core.Coercion hiding ( substCo, substCoVarBndr ) 49import GHC.Core.TyCon ( tyConArity ) 50import GHC.Core.Multiplicity 51import GHC.Builtin.Types 52import GHC.Builtin.Names 53import GHC.Types.Basic 54import GHC.Unit.Module ( Module ) 55import GHC.Utils.Error 56import GHC.Driver.Session 57import GHC.Utils.Outputable 58import GHC.Data.Pair 59import GHC.Utils.Misc 60import GHC.Data.Maybe ( orElse ) 61import GHC.Data.FastString 62import Data.List 63import qualified Data.ByteString as BS 64 65{- 66************************************************************************ 67* * 68 The Simple Optimiser 69* * 70************************************************************************ 71 72Note [The simple optimiser] 73~~~~~~~~~~~~~~~~~~~~~~~~~~~ 74The simple optimiser is a lightweight, pure (non-monadic) function 75that rapidly does a lot of simple optimisations, including 76 77 - inlining things that occur just once, 78 or whose RHS turns out to be trivial 79 - beta reduction 80 - case of known constructor 81 - dead code elimination 82 83It does NOT do any call-site inlining; it only inlines a function if 84it can do so unconditionally, dropping the binding. It thereby 85guarantees to leave no un-reduced beta-redexes. 86 87It is careful to follow the guidance of "Secrets of the GHC inliner", 88and in particular the pre-inline-unconditionally and 89post-inline-unconditionally story, to do effective beta reduction on 90functions called precisely once, without repeatedly optimising the same 91expression. In fact, the simple optimiser is a good example of this 92little dance in action; the full Simplifier is a lot more complicated. 93 94-} 95 96simpleOptExpr :: HasDebugCallStack => DynFlags -> CoreExpr -> CoreExpr 97-- See Note [The simple optimiser] 98-- Do simple optimisation on an expression 99-- The optimisation is very straightforward: just 100-- inline non-recursive bindings that are used only once, 101-- or where the RHS is trivial 102-- 103-- We also inline bindings that bind a Eq# box: see 104-- See Note [Getting the map/coerce RULE to work]. 105-- 106-- Also we convert functions to join points where possible (as 107-- the occurrence analyser does most of the work anyway). 108-- 109-- The result is NOT guaranteed occurrence-analysed, because 110-- in (let x = y in ....) we substitute for x; so y's occ-info 111-- may change radically 112 113simpleOptExpr dflags expr 114 = -- pprTrace "simpleOptExpr" (ppr init_subst $$ ppr expr) 115 simpleOptExprWith dflags init_subst expr 116 where 117 init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr)) 118 -- It's potentially important to make a proper in-scope set 119 -- Consider let x = ..y.. in \y. ...x... 120 -- Then we should remember to clone y before substituting 121 -- for x. It's very unlikely to occur, because we probably 122 -- won't *be* substituting for x if it occurs inside a 123 -- lambda. 124 -- 125 -- It's a bit painful to call exprFreeVars, because it makes 126 -- three passes instead of two (occ-anal, and go) 127 128simpleOptExprWith :: HasDebugCallStack => DynFlags -> Subst -> InExpr -> OutExpr 129-- See Note [The simple optimiser] 130simpleOptExprWith dflags subst expr 131 = simple_opt_expr init_env (occurAnalyseExpr expr) 132 where 133 init_env = SOE { soe_dflags = dflags 134 , soe_inl = emptyVarEnv 135 , soe_subst = subst } 136 137---------------------- 138simpleOptPgm :: DynFlags -> Module 139 -> CoreProgram -> [CoreRule] 140 -> IO (CoreProgram, [CoreRule]) 141-- See Note [The simple optimiser] 142simpleOptPgm dflags this_mod binds rules 143 = do { dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis" 144 FormatCore (pprCoreBindings occ_anald_binds $$ pprRules rules ); 145 146 ; return (reverse binds', rules') } 147 where 148 occ_anald_binds = occurAnalysePgm this_mod 149 (\_ -> True) {- All unfoldings active -} 150 (\_ -> False) {- No rules active -} 151 rules binds 152 153 (final_env, binds') = foldl' do_one (emptyEnv dflags, []) occ_anald_binds 154 final_subst = soe_subst final_env 155 156 rules' = substRulesForImportedIds final_subst rules 157 -- We never unconditionally inline into rules, 158 -- hence paying just a substitution 159 160 do_one (env, binds') bind 161 = case simple_opt_bind env bind TopLevel of 162 (env', Nothing) -> (env', binds') 163 (env', Just bind') -> (env', bind':binds') 164 165-- In these functions the substitution maps InVar -> OutExpr 166 167---------------------- 168type SimpleClo = (SimpleOptEnv, InExpr) 169 170data SimpleOptEnv 171 = SOE { soe_dflags :: DynFlags 172 , soe_inl :: IdEnv SimpleClo 173 -- Deals with preInlineUnconditionally; things 174 -- that occur exactly once and are inlined 175 -- without having first been simplified 176 177 , soe_subst :: Subst 178 -- Deals with cloning; includes the InScopeSet 179 } 180 181instance Outputable SimpleOptEnv where 182 ppr (SOE { soe_inl = inl, soe_subst = subst }) 183 = text "SOE {" <+> vcat [ text "soe_inl =" <+> ppr inl 184 , text "soe_subst =" <+> ppr subst ] 185 <+> text "}" 186 187emptyEnv :: DynFlags -> SimpleOptEnv 188emptyEnv dflags 189 = SOE { soe_dflags = dflags 190 , soe_inl = emptyVarEnv 191 , soe_subst = emptySubst } 192 193soeZapSubst :: SimpleOptEnv -> SimpleOptEnv 194soeZapSubst env@(SOE { soe_subst = subst }) 195 = env { soe_inl = emptyVarEnv, soe_subst = zapSubstEnv subst } 196 197soeSetInScope :: SimpleOptEnv -> SimpleOptEnv -> SimpleOptEnv 198-- Take in-scope set from env1, and the rest from env2 199soeSetInScope (SOE { soe_subst = subst1 }) 200 env2@(SOE { soe_subst = subst2 }) 201 = env2 { soe_subst = setInScope subst2 (substInScope subst1) } 202 203--------------- 204simple_opt_clo :: SimpleOptEnv -> SimpleClo -> OutExpr 205simple_opt_clo env (e_env, e) 206 = simple_opt_expr (soeSetInScope env e_env) e 207 208simple_opt_expr :: HasCallStack => SimpleOptEnv -> InExpr -> OutExpr 209simple_opt_expr env expr 210 = go expr 211 where 212 subst = soe_subst env 213 in_scope = substInScope subst 214 in_scope_env = (in_scope, simpleUnfoldingFun) 215 216 --------------- 217 go (Var v) 218 | Just clo <- lookupVarEnv (soe_inl env) v 219 = simple_opt_clo env clo 220 | otherwise 221 = lookupIdSubst (soe_subst env) v 222 223 go (App e1 e2) = simple_app env e1 [(env,e2)] 224 go (Type ty) = Type (substTy subst ty) 225 go (Coercion co) = Coercion (go_co co) 226 go (Lit lit) = Lit lit 227 go (Tick tickish e) = mkTick (substTickish subst tickish) (go e) 228 go (Cast e co) = mk_cast (go e) (go_co co) 229 go (Let bind body) = case simple_opt_bind env bind NotTopLevel of 230 (env', Nothing) -> simple_opt_expr env' body 231 (env', Just bind) -> Let bind (simple_opt_expr env' body) 232 233 go lam@(Lam {}) = go_lam env [] lam 234 go (Case e b ty as) 235 -- See Note [Getting the map/coerce RULE to work] 236 | isDeadBinder b 237 , Just (_, [], con, _tys, es) <- exprIsConApp_maybe in_scope_env e' 238 -- We don't need to be concerned about floats when looking for coerce. 239 , Just (altcon, bs, rhs) <- findAlt (DataAlt con) as 240 = case altcon of 241 DEFAULT -> go rhs 242 _ -> foldr wrapLet (simple_opt_expr env' rhs) mb_prs 243 where 244 (env', mb_prs) = mapAccumL (simple_out_bind NotTopLevel) env $ 245 zipEqual "simpleOptExpr" bs es 246 247 -- Note [Getting the map/coerce RULE to work] 248 | isDeadBinder b 249 , [(DEFAULT, _, rhs)] <- as 250 , isCoVarType (varType b) 251 , (Var fun, _args) <- collectArgs e 252 , fun `hasKey` coercibleSCSelIdKey 253 -- without this last check, we get #11230 254 = go rhs 255 256 | otherwise 257 = Case e' b' (substTy subst ty) 258 (map (go_alt env') as) 259 where 260 e' = go e 261 (env', b') = subst_opt_bndr env b 262 263 ---------------------- 264 go_co co = optCoercion (soe_dflags env) (getTCvSubst subst) co 265 266 ---------------------- 267 go_alt env (con, bndrs, rhs) 268 = (con, bndrs', simple_opt_expr env' rhs) 269 where 270 (env', bndrs') = subst_opt_bndrs env bndrs 271 272 ---------------------- 273 -- go_lam tries eta reduction 274 go_lam env bs' (Lam b e) 275 = go_lam env' (b':bs') e 276 where 277 (env', b') = subst_opt_bndr env b 278 go_lam env bs' e 279 | Just etad_e <- tryEtaReduce bs e' = etad_e 280 | otherwise = mkLams bs e' 281 where 282 bs = reverse bs' 283 e' = simple_opt_expr env e 284 285mk_cast :: CoreExpr -> CoercionR -> CoreExpr 286-- Like GHC.Core.Utils.mkCast, but does a full reflexivity check. 287-- mkCast doesn't do that because the Simplifier does (in simplCast) 288-- But in SimpleOpt it's nice to kill those nested casts (#18112) 289mk_cast (Cast e co1) co2 = mk_cast e (co1 `mkTransCo` co2) 290mk_cast (Tick t e) co = Tick t (mk_cast e co) 291mk_cast e co | isReflexiveCo co = e 292 | otherwise = Cast e co 293 294---------------------- 295-- simple_app collects arguments for beta reduction 296simple_app :: HasDebugCallStack => SimpleOptEnv -> InExpr -> [SimpleClo] -> CoreExpr 297 298simple_app env (Var v) as 299 | Just (env', e) <- lookupVarEnv (soe_inl env) v 300 = simple_app (soeSetInScope env env') e as 301 302 | let unf = idUnfolding v 303 , isCompulsoryUnfolding (idUnfolding v) 304 , isAlwaysActive (idInlineActivation v) 305 -- See Note [Unfold compulsory unfoldings in LHSs] 306 = simple_app (soeZapSubst env) (unfoldingTemplate unf) as 307 308 | otherwise 309 , let out_fn = lookupIdSubst (soe_subst env) v 310 = finish_app env out_fn as 311 312simple_app env (App e1 e2) as 313 = simple_app env e1 ((env, e2) : as) 314 315simple_app env (Lam b e) (a:as) 316 = wrapLet mb_pr (simple_app env' e as) 317 where 318 (env', mb_pr) = simple_bind_pair env b Nothing a NotTopLevel 319 320simple_app env (Tick t e) as 321 -- Okay to do "(Tick t e) x ==> Tick t (e x)"? 322 | t `tickishScopesLike` SoftScope 323 = mkTick t $ simple_app env e as 324 325-- (let x = e in b) a1 .. an => let x = e in (b a1 .. an) 326-- The let might appear there as a result of inlining 327-- e.g. let f = let x = e in b 328-- in f a1 a2 329-- (#13208) 330-- However, do /not/ do this transformation for join points 331-- See Note [simple_app and join points] 332simple_app env (Let bind body) args 333 = case simple_opt_bind env bind NotTopLevel of 334 (env', Nothing) -> simple_app env' body args 335 (env', Just bind') 336 | isJoinBind bind' -> finish_app env expr' args 337 | otherwise -> Let bind' (simple_app env' body args) 338 where 339 expr' = Let bind' (simple_opt_expr env' body) 340 341simple_app env e as 342 = finish_app env (simple_opt_expr env e) as 343 344finish_app :: SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr 345finish_app _ fun [] 346 = fun 347finish_app env fun (arg:args) 348 = finish_app env (App fun (simple_opt_clo env arg)) args 349 350---------------------- 351simple_opt_bind :: SimpleOptEnv -> InBind -> TopLevelFlag 352 -> (SimpleOptEnv, Maybe OutBind) 353simple_opt_bind env (NonRec b r) top_level 354 = (env', case mb_pr of 355 Nothing -> Nothing 356 Just (b,r) -> Just (NonRec b r)) 357 where 358 (b', r') = joinPointBinding_maybe b r `orElse` (b, r) 359 (env', mb_pr) = simple_bind_pair env b' Nothing (env,r') top_level 360 361simple_opt_bind env (Rec prs) top_level 362 = (env'', res_bind) 363 where 364 res_bind = Just (Rec (reverse rev_prs')) 365 prs' = joinPointBindings_maybe prs `orElse` prs 366 (env', bndrs') = subst_opt_bndrs env (map fst prs') 367 (env'', rev_prs') = foldl' do_pr (env', []) (prs' `zip` bndrs') 368 do_pr (env, prs) ((b,r), b') 369 = (env', case mb_pr of 370 Just pr -> pr : prs 371 Nothing -> prs) 372 where 373 (env', mb_pr) = simple_bind_pair env b (Just b') (env,r) top_level 374 375---------------------- 376simple_bind_pair :: SimpleOptEnv 377 -> InVar -> Maybe OutVar 378 -> SimpleClo 379 -> TopLevelFlag 380 -> (SimpleOptEnv, Maybe (OutVar, OutExpr)) 381 -- (simple_bind_pair subst in_var out_rhs) 382 -- either extends subst with (in_var -> out_rhs) 383 -- or returns Nothing 384simple_bind_pair env@(SOE { soe_inl = inl_env, soe_subst = subst }) 385 in_bndr mb_out_bndr clo@(rhs_env, in_rhs) 386 top_level 387 | Type ty <- in_rhs -- let a::* = TYPE ty in <body> 388 , let out_ty = substTy (soe_subst rhs_env) ty 389 = ASSERT2( isTyVar in_bndr, ppr in_bndr $$ ppr in_rhs ) 390 (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing) 391 392 | Coercion co <- in_rhs 393 , let out_co = optCoercion (soe_dflags env) (getTCvSubst (soe_subst rhs_env)) co 394 = ASSERT( isCoVar in_bndr ) 395 (env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing) 396 397 | ASSERT2( isNonCoVarId in_bndr, ppr in_bndr ) 398 -- The previous two guards got rid of tyvars and coercions 399 -- See Note [Core type and coercion invariant] in GHC.Core 400 pre_inline_unconditionally 401 = (env { soe_inl = extendVarEnv inl_env in_bndr clo }, Nothing) 402 403 | otherwise 404 = simple_out_bind_pair env in_bndr mb_out_bndr out_rhs 405 occ active stable_unf top_level 406 where 407 stable_unf = isStableUnfolding (idUnfolding in_bndr) 408 active = isAlwaysActive (idInlineActivation in_bndr) 409 occ = idOccInfo in_bndr 410 411 out_rhs | Just join_arity <- isJoinId_maybe in_bndr 412 = simple_join_rhs join_arity 413 | otherwise 414 = simple_opt_clo env clo 415 416 simple_join_rhs join_arity -- See Note [Preserve join-binding arity] 417 = mkLams join_bndrs' (simple_opt_expr env_body join_body) 418 where 419 env0 = soeSetInScope env rhs_env 420 (join_bndrs, join_body) = collectNBinders join_arity in_rhs 421 (env_body, join_bndrs') = subst_opt_bndrs env0 join_bndrs 422 423 pre_inline_unconditionally :: Bool 424 pre_inline_unconditionally 425 | isExportedId in_bndr = False 426 | stable_unf = False 427 | not active = False -- Note [Inline prag in simplOpt] 428 | not (safe_to_inline occ) = False 429 | otherwise = True 430 431 -- Unconditionally safe to inline 432 safe_to_inline :: OccInfo -> Bool 433 safe_to_inline IAmALoopBreaker{} = False 434 safe_to_inline IAmDead = True 435 safe_to_inline OneOcc{ occ_in_lam = NotInsideLam 436 , occ_n_br = 1 } = True 437 safe_to_inline OneOcc{} = False 438 safe_to_inline ManyOccs{} = False 439 440------------------- 441simple_out_bind :: TopLevelFlag 442 -> SimpleOptEnv 443 -> (InVar, OutExpr) 444 -> (SimpleOptEnv, Maybe (OutVar, OutExpr)) 445simple_out_bind top_level env@(SOE { soe_subst = subst }) (in_bndr, out_rhs) 446 | Type out_ty <- out_rhs 447 = ASSERT2( isTyVar in_bndr, ppr in_bndr $$ ppr out_ty $$ ppr out_rhs ) 448 (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing) 449 450 | Coercion out_co <- out_rhs 451 = ASSERT( isCoVar in_bndr ) 452 (env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing) 453 454 | otherwise 455 = simple_out_bind_pair env in_bndr Nothing out_rhs 456 (idOccInfo in_bndr) True False top_level 457 458------------------- 459simple_out_bind_pair :: SimpleOptEnv 460 -> InId -> Maybe OutId -> OutExpr 461 -> OccInfo -> Bool -> Bool -> TopLevelFlag 462 -> (SimpleOptEnv, Maybe (OutVar, OutExpr)) 463simple_out_bind_pair env in_bndr mb_out_bndr out_rhs 464 occ_info active stable_unf top_level 465 | ASSERT2( isNonCoVarId in_bndr, ppr in_bndr ) 466 -- Type and coercion bindings are caught earlier 467 -- See Note [Core type and coercion invariant] 468 post_inline_unconditionally 469 = ( env' { soe_subst = extendIdSubst (soe_subst env) in_bndr out_rhs } 470 , Nothing) 471 472 | otherwise 473 = ( env', Just (out_bndr, out_rhs) ) 474 where 475 (env', bndr1) = case mb_out_bndr of 476 Just out_bndr -> (env, out_bndr) 477 Nothing -> subst_opt_bndr env in_bndr 478 out_bndr = add_info env' in_bndr top_level out_rhs bndr1 479 480 post_inline_unconditionally :: Bool 481 post_inline_unconditionally 482 | isExportedId in_bndr = False -- Note [Exported Ids and trivial RHSs] 483 | stable_unf = False -- Note [Stable unfoldings and postInlineUnconditionally] 484 | not active = False -- in GHC.Core.Opt.Simplify.Utils 485 | is_loop_breaker = False -- If it's a loop-breaker of any kind, don't inline 486 -- because it might be referred to "earlier" 487 | exprIsTrivial out_rhs = True 488 | coercible_hack = True 489 | otherwise = False 490 491 is_loop_breaker = isWeakLoopBreaker occ_info 492 493 -- See Note [Getting the map/coerce RULE to work] 494 coercible_hack | (Var fun, args) <- collectArgs out_rhs 495 , Just dc <- isDataConWorkId_maybe fun 496 , dc `hasKey` heqDataConKey || dc `hasKey` coercibleDataConKey 497 = all exprIsTrivial args 498 | otherwise 499 = False 500 501{- Note [Exported Ids and trivial RHSs] 502~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 503We obviously do not want to unconditionally inline an Id that is exported. 504In GHC.Core.Opt.Simplify.Utils, Note [Top level and postInlineUnconditionally], we 505explain why we don't inline /any/ top-level things unconditionally, even 506trivial ones. But we do here! Why? In the simple optimiser 507 508 * We do no rule rewrites 509 * We do no call-site inlining 510 511Those differences obviate the reasons for not inlining a trivial rhs, 512and increase the benefit for doing so. So we unconditionally inline trivial 513rhss here. 514 515Note [Preserve join-binding arity] 516~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 517Be careful /not/ to eta-reduce the RHS of a join point, lest we lose 518the join-point arity invariant. #15108 was caused by simplifying 519the RHS with simple_opt_expr, which does eta-reduction. Solution: 520simplify the RHS of a join point by simplifying under the lambdas 521(which of course should be there). 522 523Note [simple_app and join points] 524~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 525In general for let-bindings we can do this: 526 (let { x = e } in b) a ==> let { x = e } in b a 527 528But not for join points! For two reasons: 529 530- We would need to push the continuation into the RHS: 531 (join { j = e } in b) a ==> let { j' = e a } in b[j'/j] a 532 NB ----^^ 533 and also change the type of j, hence j'. 534 That's a bit sophisticated for the very simple optimiser. 535 536- We might end up with something like 537 join { j' = e a } in 538 (case blah of ) 539 ( True -> j' void# ) a 540 ( False -> blah ) 541 and now the call to j' doesn't look like a tail call, and 542 Lint may reject. I say "may" because this is /explicitly/ 543 allowed in the "Compiling without Continuations" paper 544 (Section 3, "Managing \Delta"). But GHC currently does not 545 allow this slightly-more-flexible form. See GHC.Core 546 Note [Join points are less general than the paper]. 547 548The simple thing to do is to disable this transformation 549for join points in the simple optimiser 550 551Note [The Let-Unfoldings Invariant] 552~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 553A program has the Let-Unfoldings property iff: 554 555- For every let-bound variable f, whether top-level or nested, whether 556 recursive or not: 557 - Both the binding Id of f, and every occurrence Id of f, has an idUnfolding. 558 - For non-INLINE things, that unfolding will be f's right hand sids 559 - For INLINE things (which have a "stable" unfolding) that unfolding is 560 semantically equivalent to f's RHS, but derived from the original RHS of f 561 rather that its current RHS. 562 563Informally, we can say that in a program that has the Let-Unfoldings property, 564all let-bound Id's have an explicit unfolding attached to them. 565 566Currently, the simplifier guarantees the Let-Unfoldings invariant for anything 567it outputs. 568 569-} 570 571---------------------- 572subst_opt_bndrs :: SimpleOptEnv -> [InVar] -> (SimpleOptEnv, [OutVar]) 573subst_opt_bndrs env bndrs = mapAccumL subst_opt_bndr env bndrs 574 575subst_opt_bndr :: SimpleOptEnv -> InVar -> (SimpleOptEnv, OutVar) 576subst_opt_bndr env bndr 577 | isTyVar bndr = (env { soe_subst = subst_tv }, tv') 578 | isCoVar bndr = (env { soe_subst = subst_cv }, cv') 579 | otherwise = subst_opt_id_bndr env bndr 580 where 581 subst = soe_subst env 582 (subst_tv, tv') = substTyVarBndr subst bndr 583 (subst_cv, cv') = substCoVarBndr subst bndr 584 585subst_opt_id_bndr :: SimpleOptEnv -> InId -> (SimpleOptEnv, OutId) 586-- Nuke all fragile IdInfo, unfolding, and RULES; it gets added back later by 587-- add_info. 588-- 589-- Rather like SimplEnv.substIdBndr 590-- 591-- It's important to zap fragile OccInfo (which GHC.Core.Subst.substIdBndr 592-- carefully does not do) because simplOptExpr invalidates it 593 594subst_opt_id_bndr env@(SOE { soe_subst = subst, soe_inl = inl }) old_id 595 = (env { soe_subst = new_subst, soe_inl = new_inl }, new_id) 596 where 597 Subst in_scope id_subst tv_subst cv_subst = subst 598 599 id1 = uniqAway in_scope old_id 600 id2 = updateIdTypeAndMult (substTy subst) id1 601 new_id = zapFragileIdInfo id2 602 -- Zaps rules, unfolding, and fragile OccInfo 603 -- The unfolding and rules will get added back later, by add_info 604 605 new_in_scope = in_scope `extendInScopeSet` new_id 606 607 no_change = new_id == old_id 608 609 -- Extend the substitution if the unique has changed, 610 -- See the notes with substTyVarBndr for the delSubstEnv 611 new_id_subst 612 | no_change = delVarEnv id_subst old_id 613 | otherwise = extendVarEnv id_subst old_id (Var new_id) 614 615 new_subst = Subst new_in_scope new_id_subst tv_subst cv_subst 616 new_inl = delVarEnv inl old_id 617 618---------------------- 619add_info :: SimpleOptEnv -> InVar -> TopLevelFlag -> OutExpr -> OutVar -> OutVar 620add_info env old_bndr top_level new_rhs new_bndr 621 | isTyVar old_bndr = new_bndr 622 | otherwise = lazySetIdInfo new_bndr new_info 623 where 624 subst = soe_subst env 625 dflags = soe_dflags env 626 old_info = idInfo old_bndr 627 628 -- Add back in the rules and unfolding which were 629 -- removed by zapFragileIdInfo in subst_opt_id_bndr. 630 -- 631 -- See Note [The Let-Unfoldings Invariant] 632 new_info = idInfo new_bndr `setRuleInfo` new_rules 633 `setUnfoldingInfo` new_unfolding 634 635 old_rules = ruleInfo old_info 636 new_rules = substSpec subst new_bndr old_rules 637 638 old_unfolding = unfoldingInfo old_info 639 new_unfolding | isStableUnfolding old_unfolding 640 = substUnfolding subst old_unfolding 641 | otherwise 642 = unfolding_from_rhs 643 644 unfolding_from_rhs = mkUnfolding dflags InlineRhs 645 (isTopLevel top_level) 646 False -- may be bottom or not 647 new_rhs 648 649simpleUnfoldingFun :: IdUnfoldingFun 650simpleUnfoldingFun id 651 | isAlwaysActive (idInlineActivation id) = idUnfolding id 652 | otherwise = noUnfolding 653 654wrapLet :: Maybe (Id,CoreExpr) -> CoreExpr -> CoreExpr 655wrapLet Nothing body = body 656wrapLet (Just (b,r)) body = Let (NonRec b r) body 657 658{- 659Note [Inline prag in simplOpt] 660~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 661If there's an INLINE/NOINLINE pragma that restricts the phase in 662which the binder can be inlined, we don't inline here; after all, 663we don't know what phase we're in. Here's an example 664 665 foo :: Int -> Int -> Int 666 {-# INLINE foo #-} 667 foo m n = inner m 668 where 669 {-# INLINE [1] inner #-} 670 inner m = m+n 671 672 bar :: Int -> Int 673 bar n = foo n 1 674 675When inlining 'foo' in 'bar' we want the let-binding for 'inner' 676to remain visible until Phase 1 677 678Note [Unfold compulsory unfoldings in LHSs] 679~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 680When the user writes `RULES map coerce = coerce` as a rule, the rule 681will only ever match if simpleOptExpr replaces coerce by its unfolding 682on the LHS, because that is the core that the rule matching engine 683will find. So do that for everything that has a compulsory 684unfolding. Also see Note [Desugaring coerce as cast] in GHC.HsToCore. 685 686However, we don't want to inline 'seq', which happens to also have a 687compulsory unfolding, so we only do this unfolding only for things 688that are always-active. See Note [User-defined RULES for seq] in GHC.Types.Id.Make. 689 690Note [Getting the map/coerce RULE to work] 691~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 692We wish to allow the "map/coerce" RULE to fire: 693 694 {-# RULES "map/coerce" map coerce = coerce #-} 695 696The naive core produced for this is 697 698 forall a b (dict :: Coercible * a b). 699 map @a @b (coerce @a @b @dict) = coerce @[a] @[b] @dict' 700 701 where dict' :: Coercible [a] [b] 702 dict' = ... 703 704This matches literal uses of `map coerce` in code, but that's not what we 705want. We want it to match, say, `map MkAge` (where newtype Age = MkAge Int) 706too. Some of this is addressed by compulsorily unfolding coerce on the LHS, 707yielding 708 709 forall a b (dict :: Coercible * a b). 710 map @a @b (\(x :: a) -> case dict of 711 MkCoercible (co :: a ~R# b) -> x |> co) = ... 712 713Getting better. But this isn't exactly what gets produced. This is because 714Coercible essentially has ~R# as a superclass, and superclasses get eagerly 715extracted during solving. So we get this: 716 717 forall a b (dict :: Coercible * a b). 718 case Coercible_SCSel @* @a @b dict of 719 _ [Dead] -> map @a @b (\(x :: a) -> case dict of 720 MkCoercible (co :: a ~R# b) -> x |> co) = ... 721 722Unfortunately, this still abstracts over a Coercible dictionary. We really 723want it to abstract over the ~R# evidence. So, we have Desugar.unfold_coerce, 724which transforms the above to (see also Note [Desugaring coerce as cast] in 725Desugar) 726 727 forall a b (co :: a ~R# b). 728 let dict = MkCoercible @* @a @b co in 729 case Coercible_SCSel @* @a @b dict of 730 _ [Dead] -> map @a @b (\(x :: a) -> case dict of 731 MkCoercible (co :: a ~R# b) -> x |> co) = let dict = ... in ... 732 733Now, we need simpleOptExpr to fix this up. It does so by taking three 734separate actions: 735 1. Inline certain non-recursive bindings. The choice whether to inline 736 is made in simple_bind_pair. Note the rather specific check for 737 MkCoercible in there. 738 739 2. Stripping case expressions like the Coercible_SCSel one. 740 See the `Case` case of simple_opt_expr's `go` function. 741 742 3. Look for case expressions that unpack something that was 743 just packed and inline them. This is also done in simple_opt_expr's 744 `go` function. 745 746This is all a fair amount of special-purpose hackery, but it's for 747a good cause. And it won't hurt other RULES and such that it comes across. 748 749 750************************************************************************ 751* * 752 Join points 753* * 754************************************************************************ 755-} 756 757-- | Returns Just (bndr,rhs) if the binding is a join point: 758-- If it's a JoinId, just return it 759-- If it's not yet a JoinId but is always tail-called, 760-- make it into a JoinId and return it. 761-- In the latter case, eta-expand the RHS if necessary, to make the 762-- lambdas explicit, as is required for join points 763-- 764-- Precondition: the InBndr has been occurrence-analysed, 765-- so its OccInfo is valid 766joinPointBinding_maybe :: InBndr -> InExpr -> Maybe (InBndr, InExpr) 767joinPointBinding_maybe bndr rhs 768 | not (isId bndr) 769 = Nothing 770 771 | isJoinId bndr 772 = Just (bndr, rhs) 773 774 | AlwaysTailCalled join_arity <- tailCallInfo (idOccInfo bndr) 775 , (bndrs, body) <- etaExpandToJoinPoint join_arity rhs 776 , let str_sig = idStrictness bndr 777 str_arity = count isId bndrs -- Strictness demands are for Ids only 778 join_bndr = bndr `asJoinId` join_arity 779 `setIdStrictness` etaConvertStrictSig str_arity str_sig 780 = Just (join_bndr, mkLams bndrs body) 781 782 | otherwise 783 = Nothing 784 785joinPointBindings_maybe :: [(InBndr, InExpr)] -> Maybe [(InBndr, InExpr)] 786joinPointBindings_maybe bndrs 787 = mapM (uncurry joinPointBinding_maybe) bndrs 788 789 790{- Note [Strictness and join points] 791~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 792Suppose we have 793 794 let f = \x. if x>200 then e1 else e1 795 796and we know that f is strict in x. Then if we subsequently 797discover that f is an arity-2 join point, we'll eta-expand it to 798 799 let f = \x y. if x>200 then e1 else e1 800 801and now it's only strict if applied to two arguments. So we should 802adjust the strictness info. 803 804A more common case is when 805 806 f = \x. error ".." 807 808and again its arity increases (#15517) 809-} 810 811{- ********************************************************************* 812* * 813 exprIsConApp_maybe 814* * 815************************************************************************ 816 817Note [exprIsConApp_maybe] 818~~~~~~~~~~~~~~~~~~~~~~~~~ 819exprIsConApp_maybe is a very important function. There are two principal 820uses: 821 * case e of { .... } 822 * cls_op e, where cls_op is a class operation 823 824In both cases you want to know if e is of form (C e1..en) where C is 825a data constructor. 826 827However e might not *look* as if 828 829 830Note [exprIsConApp_maybe on literal strings] 831~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 832See #9400 and #13317. 833 834Conceptually, a string literal "abc" is just ('a':'b':'c':[]), but in Core 835they are represented as unpackCString# "abc"# by GHC.Core.Make.mkStringExprFS, or 836unpackCStringUtf8# when the literal contains multi-byte UTF8 characters. 837 838For optimizations we want to be able to treat it as a list, so they can be 839decomposed when used in a case-statement. exprIsConApp_maybe detects those 840calls to unpackCString# and returns: 841 842Just (':', [Char], ['a', unpackCString# "bc"]). 843 844We need to be careful about UTF8 strings here. ""# contains a ByteString, so 845we must parse it back into a FastString to split off the first character. 846That way we can treat unpackCString# and unpackCStringUtf8# in the same way. 847 848We must also be careful about 849 lvl = "foo"# 850 ...(unpackCString# lvl)... 851to ensure that we see through the let-binding for 'lvl'. Hence the 852(exprIsLiteral_maybe .. arg) in the guard before the call to 853dealWithStringLiteral. 854 855Note [Push coercions in exprIsConApp_maybe] 856~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 857In #13025 I found a case where we had 858 op (df @t1 @t2) -- op is a ClassOp 859where 860 df = (/\a b. K e1 e2) |> g 861 862To get this to come out we need to simplify on the fly 863 ((/\a b. K e1 e2) |> g) @t1 @t2 864 865Hence the use of pushCoArgs. 866 867Note [exprIsConApp_maybe on data constructors with wrappers] 868~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 869Problem: 870- some data constructors have wrappers 871- these wrappers inline late (see MkId Note [Activation for data constructor wrappers]) 872- but we still want case-of-known-constructor to fire early. 873 874Example: 875 data T = MkT !Int 876 $WMkT n = case n of n' -> MkT n' -- Wrapper for MkT 877 foo x = case $WMkT e of MkT y -> blah 878 879Here we want the case-of-known-constructor transformation to fire, giving 880 foo x = case e of x' -> let y = x' in blah 881 882Here's how exprIsConApp_maybe achieves this: 883 8840. Start with scrutinee = $WMkT e 885 8861. Inline $WMkT on-the-fly. That's why data-constructor wrappers are marked 887 as expandable. (See GHC.Core.Utils.isExpandableApp.) Now we have 888 scrutinee = (\n. case n of n' -> MkT n') e 889 8902. Beta-reduce the application, generating a floated 'let'. 891 See Note [beta-reduction in exprIsConApp_maybe] below. Now we have 892 scrutinee = case n of n' -> MkT n' 893 with floats {Let n = e} 894 8953. Float the "case x of x' ->" binding out. Now we have 896 scrutinee = MkT n' 897 with floats {Let n = e; case n of n' ->} 898 899And now we have a known-constructor MkT that we can return. 900 901Notice that both (2) and (3) require exprIsConApp_maybe to gather and return 902a bunch of floats, both let and case bindings. 903 904Note that this strategy introduces some subtle scenarios where a data-con 905wrapper can be replaced by a data-con worker earlier than we’d like, see 906Note [exprIsConApp_maybe for data-con wrappers: tricky corner]. 907 908Note [beta-reduction in exprIsConApp_maybe] 909~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 910The unfolding a definition (_e.g._ a let-bound variable or a datacon wrapper) is 911typically a function. For instance, take the wrapper for MkT in Note 912[exprIsConApp_maybe on data constructors with wrappers]: 913 914 $WMkT n = case n of { n' -> T n' } 915 916If `exprIsConApp_maybe` is trying to analyse `$MkT arg`, upon unfolding of $MkT, 917it will see 918 919 (\n -> case n of { n' -> T n' }) arg 920 921In order to go progress, `exprIsConApp_maybe` must perform a beta-reduction. 922 923We don't want to blindly substitute `arg` in the body of the function, because 924it duplicates work. We can (and, in fact, used to) substitute `arg` in the body, 925but only when `arg` is a variable (or something equally work-free). 926 927But, because of Note [exprIsConApp_maybe on data constructors with wrappers], 928'exprIsConApp_maybe' now returns floats. So, instead, we can beta-reduce 929_always_: 930 931 (\x -> body) arg 932 933Is transformed into 934 935 let x = arg in body 936 937Which, effectively, means emitting a float `let x = arg` and recursively 938analysing the body. 939 940For newtypes, this strategy requires that their wrappers have compulsory unfoldings. 941Suppose we have 942 newtype T a b where 943 MkT :: a -> T b a -- Note args swapped 944 945This defines a worker function MkT, a wrapper function $WMkT, and an axT: 946 $WMkT :: forall a b. a -> T b a 947 $WMkT = /\b a. \(x:a). MkT a b x -- A real binding 948 949 MkT :: forall a b. a -> T a b 950 MkT = /\a b. \(x:a). x |> (ax a b) -- A compulsory unfolding 951 952 axiom axT :: a ~R# T a b 953 954Now we are optimising 955 case $WMkT (I# 3) |> sym axT of I# y -> ... 956we clearly want to simplify this. If $WMkT did not have a compulsory 957unfolding, we would end up with 958 let a = I#3 in case a of I# y -> ... 959because in general, we do this on-the-fly beta-reduction 960 (\x. e) blah --> let x = blah in e 961and then float the let. (Substitution would risk duplicating 'blah'.) 962 963But if the case-of-known-constructor doesn't actually fire (i.e. 964exprIsConApp_maybe does not return Just) then nothing happens, and nothing 965will happen the next time either. 966 967See test T16254, which checks the behavior of newtypes. 968 969Note [Don't float join points] 970~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 971exprIsConApp_maybe should succeed on 972 let v = e in Just v 973returning [x=e] as one of the [FloatBind]. But it must 974NOT succeed on 975 join j x = rhs in Just v 976because join-points can't be gaily floated. Consider 977 case (join j x = rhs in Just) of 978 K p q -> blah 979We absolutely must not "simplify" this to 980 join j x = rhs 981 in blah 982because j's return type is (Maybe t), quite different to blah's. 983 984You might think this could never happen, because j can't be 985tail-called in the body if the body returns a constructor. But 986in !3113 we had a /dead/ join point (which is not illegal), 987and its return type was wonky. 988 989The simple thing is not to float a join point. The next iteration 990of the simplifier will sort everything out. And it there is 991a join point, the chances are that the body is not a constructor 992application, so failing faster is good. 993 994Note [exprIsConApp_maybe for data-con wrappers: tricky corner] 995~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 996Generally speaking 997 998 * exprIsConApp_maybe honours the inline phase; that is, it does not look 999 inside the unfolding for an Id unless its unfolding is active in this phase. 1000 That phase-sensitivity is expressed in the InScopeEnv (specifically, the 1001 IdUnfoldingFun component of the InScopeEnv) passed to exprIsConApp_maybe. 1002 1003 * Data-constructor wrappers are active only in phase 0 (the last phase); 1004 see Note [Activation for data constructor wrappers] in GHC.Types.Id.Make. 1005 1006On the face of it that means that exprIsConApp_maybe won't look inside data 1007constructor wrappers until phase 0. But that seems pretty Bad. So we cheat. 1008For data con wrappers we unconditionally look inside its unfolding, regardless 1009of phase, so that we get case-of-known-constructor to fire in every phase. 1010 1011Perhaps unsurprisingly, this cheating can backfire. An example: 1012 1013 data T = C !A B 1014 foo p q = let x = C e1 e2 in seq x $ f x 1015 {-# RULE "wurble" f (C a b) = b #-} 1016 1017In Core, the RHS of foo is 1018 1019 let x = $WC e1 e2 in case x of y { C _ _ -> f x } 1020 1021and after doing a binder swap and inlining x, we have: 1022 1023 case $WC e1 e2 of y { C _ _ -> f y } 1024 1025Case-of-known-constructor fires, but now we have to reconstruct a binding for 1026`y` (which was dead before the binder swap) on the RHS of the case alternative. 1027Naturally, we’ll use the worker: 1028 1029 case e1 of a { DEFAULT -> let y = C a e2 in f y } 1030 1031and after inlining `y`, we have: 1032 1033 case e1 of a { DEFAULT -> f (C a e2) } 1034 1035Now we might hope the "wurble" rule would fire, but alas, it will not: we have 1036replaced $WC with C, but the (desugared) rule matches on $WC! We weren’t 1037supposed to inline $WC yet for precisely that reason (see Note [Activation for 1038data constructor wrappers]), but our cheating in exprIsConApp_maybe came back to 1039bite us. 1040 1041This is rather unfortunate, especially since this can happen inside stable 1042unfoldings as well as ordinary code (which really happened, see !3041). But 1043there is no obvious solution except to delay case-of-known-constructor on 1044data-con wrappers, and that cure would be worse than the disease. 1045 1046This Note exists solely to document the problem. 1047-} 1048 1049data ConCont = CC [CoreExpr] Coercion 1050 -- Substitution already applied 1051 1052-- | Returns @Just ([b1..bp], dc, [t1..tk], [x1..xn])@ if the argument 1053-- expression is a *saturated* constructor application of the form @let b1 in 1054-- .. let bp in dc t1..tk x1 .. xn@, where t1..tk are the 1055-- *universally-quantified* type args of 'dc'. Floats can also be (and most 1056-- likely are) single-alternative case expressions. Why does 1057-- 'exprIsConApp_maybe' return floats? We may have to look through lets and 1058-- cases to detect that we are in the presence of a data constructor wrapper. In 1059-- this case, we need to return the lets and cases that we traversed. See Note 1060-- [exprIsConApp_maybe on data constructors with wrappers]. Data constructor wrappers 1061-- are unfolded late, but we really want to trigger case-of-known-constructor as 1062-- early as possible. See also Note [Activation for data constructor wrappers] 1063-- in "GHC.Types.Id.Make". 1064-- 1065-- We also return the incoming InScopeSet, augmented with 1066-- the binders from any [FloatBind] that we return 1067exprIsConApp_maybe :: HasDebugCallStack 1068 => InScopeEnv -> CoreExpr 1069 -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr]) 1070exprIsConApp_maybe (in_scope, id_unf) expr 1071 = go (Left in_scope) [] expr (CC [] (mkRepReflCo (exprType expr))) 1072 where 1073 go :: Either InScopeSet Subst 1074 -- Left in-scope means "empty substitution" 1075 -- Right subst means "apply this substitution to the CoreExpr" 1076 -- NB: in the call (go subst floats expr cont) 1077 -- the substitution applies to 'expr', but /not/ to 'floats' or 'cont' 1078 -> [FloatBind] -> CoreExpr -> ConCont 1079 -- Notice that the floats here are in reverse order 1080 -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr]) 1081 go subst floats (Tick t expr) cont 1082 | not (tickishIsCode t) = go subst floats expr cont 1083 1084 go subst floats (Cast expr co1) (CC args co2) 1085 | Just (args', m_co1') <- pushCoArgs (subst_co subst co1) args 1086 -- See Note [Push coercions in exprIsConApp_maybe] 1087 = case m_co1' of 1088 MCo co1' -> go subst floats expr (CC args' (co1' `mkTransCo` co2)) 1089 MRefl -> go subst floats expr (CC args' co2) 1090 1091 go subst floats (App fun arg) (CC args co) 1092 = go subst floats fun (CC (subst_expr subst arg : args) co) 1093 1094 go subst floats (Lam bndr body) (CC (arg:args) co) 1095 | exprIsTrivial arg -- Don't duplicate stuff! 1096 = go (extend subst bndr arg) floats body (CC args co) 1097 | otherwise 1098 = let (subst', bndr') = subst_bndr subst bndr 1099 float = FloatLet (NonRec bndr' arg) 1100 in go subst' (float:floats) body (CC args co) 1101 1102 go subst floats (Let (NonRec bndr rhs) expr) cont 1103 | not (isJoinId bndr) 1104 -- Crucial guard! See Note [Don't float join points] 1105 = let rhs' = subst_expr subst rhs 1106 (subst', bndr') = subst_bndr subst bndr 1107 float = FloatLet (NonRec bndr' rhs') 1108 in go subst' (float:floats) expr cont 1109 1110 go subst floats (Case scrut b _ [(con, vars, expr)]) cont 1111 = let 1112 scrut' = subst_expr subst scrut 1113 (subst', b') = subst_bndr subst b 1114 (subst'', vars') = subst_bndrs subst' vars 1115 float = FloatCase scrut' b' con vars' 1116 in 1117 go subst'' (float:floats) expr cont 1118 1119 go (Right sub) floats (Var v) cont 1120 = go (Left (substInScope sub)) 1121 floats 1122 (lookupIdSubst sub v) 1123 cont 1124 1125 go (Left in_scope) floats (Var fun) cont@(CC args co) 1126 1127 | Just con <- isDataConWorkId_maybe fun 1128 , count isValArg args == idArity fun 1129 = succeedWith in_scope floats $ 1130 pushCoDataCon con args co 1131 1132 -- Look through data constructor wrappers: they inline late (See Note 1133 -- [Activation for data constructor wrappers]) but we want to do 1134 -- case-of-known-constructor optimisation eagerly (see Note 1135 -- [exprIsConApp_maybe on data constructors with wrappers]). 1136 | isDataConWrapId fun 1137 , let rhs = uf_tmpl (realIdUnfolding fun) 1138 = go (Left in_scope) floats rhs cont 1139 1140 -- Look through dictionary functions; see Note [Unfolding DFuns] 1141 | DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = dfun_args } <- unfolding 1142 , bndrs `equalLength` args -- See Note [DFun arity check] 1143 , let subst = mkOpenSubst in_scope (bndrs `zip` args) 1144 = succeedWith in_scope floats $ 1145 pushCoDataCon con (map (substExpr subst) dfun_args) co 1146 1147 -- Look through unfoldings, but only arity-zero one; 1148 -- if arity > 0 we are effectively inlining a function call, 1149 -- and that is the business of callSiteInline. 1150 -- In practice, without this test, most of the "hits" were 1151 -- CPR'd workers getting inlined back into their wrappers, 1152 | idArity fun == 0 1153 , Just rhs <- expandUnfolding_maybe unfolding 1154 , let in_scope' = extendInScopeSetSet in_scope (exprFreeVars rhs) 1155 = go (Left in_scope') floats rhs cont 1156 1157 -- See Note [exprIsConApp_maybe on literal strings] 1158 | (fun `hasKey` unpackCStringIdKey) || 1159 (fun `hasKey` unpackCStringUtf8IdKey) 1160 , [arg] <- args 1161 , Just (LitString str) <- exprIsLiteral_maybe (in_scope, id_unf) arg 1162 = succeedWith in_scope floats $ 1163 dealWithStringLiteral fun str co 1164 where 1165 unfolding = id_unf fun 1166 1167 go _ _ _ _ = Nothing 1168 1169 succeedWith :: InScopeSet -> [FloatBind] 1170 -> Maybe (DataCon, [Type], [CoreExpr]) 1171 -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr]) 1172 succeedWith in_scope rev_floats x 1173 = do { (con, tys, args) <- x 1174 ; let floats = reverse rev_floats 1175 ; return (in_scope, floats, con, tys, args) } 1176 1177 ---------------------------- 1178 -- Operations on the (Either InScopeSet GHC.Core.Subst) 1179 -- The Left case is wildly dominant 1180 subst_co (Left {}) co = co 1181 subst_co (Right s) co = GHC.Core.Subst.substCo s co 1182 1183 subst_expr (Left {}) e = e 1184 subst_expr (Right s) e = substExpr s e 1185 1186 subst_bndr msubst bndr 1187 = (Right subst', bndr') 1188 where 1189 (subst', bndr') = substBndr subst bndr 1190 subst = case msubst of 1191 Left in_scope -> mkEmptySubst in_scope 1192 Right subst -> subst 1193 1194 subst_bndrs subst bs = mapAccumL subst_bndr subst bs 1195 1196 extend (Left in_scope) v e = Right (extendSubst (mkEmptySubst in_scope) v e) 1197 extend (Right s) v e = Right (extendSubst s v e) 1198 1199 1200-- See Note [exprIsConApp_maybe on literal strings] 1201dealWithStringLiteral :: Var -> BS.ByteString -> Coercion 1202 -> Maybe (DataCon, [Type], [CoreExpr]) 1203 1204-- This is not possible with user-supplied empty literals, GHC.Core.Make.mkStringExprFS 1205-- turns those into [] automatically, but just in case something else in GHC 1206-- generates a string literal directly. 1207dealWithStringLiteral _ str co 1208 | BS.null str 1209 = pushCoDataCon nilDataCon [Type charTy] co 1210 1211dealWithStringLiteral fun str co 1212 = let strFS = mkFastStringByteString str 1213 1214 char = mkConApp charDataCon [mkCharLit (headFS strFS)] 1215 charTail = BS.tail (bytesFS strFS) 1216 1217 -- In singleton strings, just add [] instead of unpackCstring# ""#. 1218 rest = if BS.null charTail 1219 then mkConApp nilDataCon [Type charTy] 1220 else App (Var fun) 1221 (Lit (LitString charTail)) 1222 1223 in pushCoDataCon consDataCon [Type charTy, char, rest] co 1224 1225{- 1226Note [Unfolding DFuns] 1227~~~~~~~~~~~~~~~~~~~~~~ 1228DFuns look like 1229 1230 df :: forall a b. (Eq a, Eq b) -> Eq (a,b) 1231 df a b d_a d_b = MkEqD (a,b) ($c1 a b d_a d_b) 1232 ($c2 a b d_a d_b) 1233 1234So to split it up we just need to apply the ops $c1, $c2 etc 1235to the very same args as the dfun. It takes a little more work 1236to compute the type arguments to the dictionary constructor. 1237 1238Note [DFun arity check] 1239~~~~~~~~~~~~~~~~~~~~~~~ 1240Here we check that the total number of supplied arguments (including 1241type args) matches what the dfun is expecting. This may be *less* 1242than the ordinary arity of the dfun: see Note [DFun unfoldings] in GHC.Core 1243-} 1244 1245exprIsLiteral_maybe :: InScopeEnv -> CoreExpr -> Maybe Literal 1246-- Same deal as exprIsConApp_maybe, but much simpler 1247-- Nevertheless we do need to look through unfoldings for 1248-- Integer and string literals, which are vigorously hoisted to top level 1249-- and not subsequently inlined 1250exprIsLiteral_maybe env@(_, id_unf) e 1251 = case e of 1252 Lit l -> Just l 1253 Tick _ e' -> exprIsLiteral_maybe env e' -- dubious? 1254 Var v 1255 | Just rhs <- expandUnfolding_maybe (id_unf v) 1256 , Just l <- exprIsLiteral_maybe env rhs 1257 -> Just l 1258 Var v 1259 | Just rhs <- expandUnfolding_maybe (id_unf v) 1260 , Just b <- matchBignum env rhs 1261 -> Just b 1262 e 1263 | Just b <- matchBignum env e 1264 -> Just b 1265 1266 | otherwise 1267 -> Nothing 1268 where 1269 matchBignum env e 1270 | Just (_env,_fb,dc,_tys,[arg]) <- exprIsConApp_maybe env e 1271 , Just (LitNumber _ i) <- exprIsLiteral_maybe env arg 1272 = if 1273 | dc == naturalNSDataCon -> Just (mkLitNatural i) 1274 | dc == integerISDataCon -> Just (mkLitInteger i) 1275 | otherwise -> Nothing 1276 | otherwise 1277 = Nothing 1278 1279{- 1280Note [exprIsLambda_maybe] 1281~~~~~~~~~~~~~~~~~~~~~~~~~~ 1282exprIsLambda_maybe will, given an expression `e`, try to turn it into the form 1283`Lam v e'` (returned as `Just (v,e')`). Besides using lambdas, it looks through 1284casts (using the Push rule), and it unfolds function calls if the unfolding 1285has a greater arity than arguments are present. 1286 1287Currently, it is used in GHC.Core.Rules.match, and is required to make 1288"map coerce = coerce" match. 1289-} 1290 1291exprIsLambda_maybe :: InScopeEnv -> CoreExpr 1292 -> Maybe (Var, CoreExpr,[Tickish Id]) 1293 -- See Note [exprIsLambda_maybe] 1294 1295-- The simple case: It is a lambda already 1296exprIsLambda_maybe _ (Lam x e) 1297 = Just (x, e, []) 1298 1299-- Still straightforward: Ticks that we can float out of the way 1300exprIsLambda_maybe (in_scope_set, id_unf) (Tick t e) 1301 | tickishFloatable t 1302 , Just (x, e, ts) <- exprIsLambda_maybe (in_scope_set, id_unf) e 1303 = Just (x, e, t:ts) 1304 1305-- Also possible: A casted lambda. Push the coercion inside 1306exprIsLambda_maybe (in_scope_set, id_unf) (Cast casted_e co) 1307 | Just (x, e,ts) <- exprIsLambda_maybe (in_scope_set, id_unf) casted_e 1308 -- Only do value lambdas. 1309 -- this implies that x is not in scope in gamma (makes this code simpler) 1310 , not (isTyVar x) && not (isCoVar x) 1311 , ASSERT( not $ x `elemVarSet` tyCoVarsOfCo co) True 1312 , Just (x',e') <- pushCoercionIntoLambda in_scope_set x e co 1313 , let res = Just (x',e',ts) 1314 = --pprTrace "exprIsLambda_maybe:Cast" (vcat [ppr casted_e,ppr co,ppr res)]) 1315 res 1316 1317-- Another attempt: See if we find a partial unfolding 1318exprIsLambda_maybe (in_scope_set, id_unf) e 1319 | (Var f, as, ts) <- collectArgsTicks tickishFloatable e 1320 , idArity f > count isValArg as 1321 -- Make sure there is hope to get a lambda 1322 , Just rhs <- expandUnfolding_maybe (id_unf f) 1323 -- Optimize, for beta-reduction 1324 , let e' = simpleOptExprWith unsafeGlobalDynFlags (mkEmptySubst in_scope_set) (rhs `mkApps` as) 1325 -- Recurse, because of possible casts 1326 , Just (x', e'', ts') <- exprIsLambda_maybe (in_scope_set, id_unf) e' 1327 , let res = Just (x', e'', ts++ts') 1328 = -- pprTrace "exprIsLambda_maybe:Unfold" (vcat [ppr e, ppr (x',e'')]) 1329 res 1330 1331exprIsLambda_maybe _ _e 1332 = -- pprTrace "exprIsLambda_maybe:Fail" (vcat [ppr _e]) 1333 Nothing 1334 1335 1336{- ********************************************************************* 1337* * 1338 The "push rules" 1339* * 1340************************************************************************ 1341 1342Here we implement the "push rules" from FC papers: 1343 1344* The push-argument rules, where we can move a coercion past an argument. 1345 We have 1346 (fun |> co) arg 1347 and we want to transform it to 1348 (fun arg') |> co' 1349 for some suitable co' and transformed arg'. 1350 1351* The PushK rule for data constructors. We have 1352 (K e1 .. en) |> co 1353 and we want to transform to 1354 (K e1' .. en') 1355 by pushing the coercion into the arguments 1356-} 1357 1358pushCoArgs :: CoercionR -> [CoreArg] -> Maybe ([CoreArg], MCoercion) 1359pushCoArgs co [] = return ([], MCo co) 1360pushCoArgs co (arg:args) = do { (arg', m_co1) <- pushCoArg co arg 1361 ; case m_co1 of 1362 MCo co1 -> do { (args', m_co2) <- pushCoArgs co1 args 1363 ; return (arg':args', m_co2) } 1364 MRefl -> return (arg':args, MRefl) } 1365 1366pushCoArg :: CoercionR -> CoreArg -> Maybe (CoreArg, MCoercion) 1367-- We have (fun |> co) arg, and we want to transform it to 1368-- (fun arg) |> co 1369-- This may fail, e.g. if (fun :: N) where N is a newtype 1370-- C.f. simplCast in GHC.Core.Opt.Simplify 1371-- 'co' is always Representational 1372-- If the returned coercion is Nothing, then it would have been reflexive 1373pushCoArg co (Type ty) = do { (ty', m_co') <- pushCoTyArg co ty 1374 ; return (Type ty', m_co') } 1375pushCoArg co val_arg = do { (arg_co, m_co') <- pushCoValArg co 1376 ; return (val_arg `mkCast` arg_co, m_co') } 1377 1378pushCoTyArg :: CoercionR -> Type -> Maybe (Type, MCoercionR) 1379-- We have (fun |> co) @ty 1380-- Push the coercion through to return 1381-- (fun @ty') |> co' 1382-- 'co' is always Representational 1383-- If the returned coercion is Nothing, then it would have been reflexive; 1384-- it's faster not to compute it, though. 1385pushCoTyArg co ty 1386 -- The following is inefficient - don't do `eqType` here, the coercion 1387 -- optimizer will take care of it. See #14737. 1388 -- -- | tyL `eqType` tyR 1389 -- -- = Just (ty, Nothing) 1390 1391 | isReflCo co 1392 = Just (ty, MRefl) 1393 1394 | isForAllTy_ty tyL 1395 = ASSERT2( isForAllTy_ty tyR, ppr co $$ ppr ty ) 1396 Just (ty `mkCastTy` co1, MCo co2) 1397 1398 | otherwise 1399 = Nothing 1400 where 1401 Pair tyL tyR = coercionKind co 1402 -- co :: tyL ~ tyR 1403 -- tyL = forall (a1 :: k1). ty1 1404 -- tyR = forall (a2 :: k2). ty2 1405 1406 co1 = mkSymCo (mkNthCo Nominal 0 co) 1407 -- co1 :: k2 ~N k1 1408 -- Note that NthCo can extract a Nominal equality between the 1409 -- kinds of the types related by a coercion between forall-types. 1410 -- See the NthCo case in GHC.Core.Lint. 1411 1412 co2 = mkInstCo co (mkGReflLeftCo Nominal ty co1) 1413 -- co2 :: ty1[ (ty|>co1)/a1 ] ~ ty2[ ty/a2 ] 1414 -- Arg of mkInstCo is always nominal, hence mkNomReflCo 1415 1416pushCoValArg :: CoercionR -> Maybe (Coercion, MCoercion) 1417-- We have (fun |> co) arg 1418-- Push the coercion through to return 1419-- (fun (arg |> co_arg)) |> co_res 1420-- 'co' is always Representational 1421-- If the second returned Coercion is actually Nothing, then no cast is necessary; 1422-- the returned coercion would have been reflexive. 1423pushCoValArg co 1424 -- The following is inefficient - don't do `eqType` here, the coercion 1425 -- optimizer will take care of it. See #14737. 1426 -- -- | tyL `eqType` tyR 1427 -- -- = Just (mkRepReflCo arg, Nothing) 1428 1429 | isReflCo co 1430 = Just (mkRepReflCo arg, MRefl) 1431 1432 | isFunTy tyL 1433 , (co_mult, co1, co2) <- decomposeFunCo Representational co 1434 , isReflexiveCo co_mult 1435 -- We can't push the coercion in the case where co_mult isn't reflexivity: 1436 -- it could be an unsafe axiom, and losing this information could yield 1437 -- ill-typed terms. For instance (fun x ::(1) Int -> (fun _ -> () |> co) x) 1438 -- with co :: (Int -> ()) ~ (Int %1 -> ()), would reduce to (fun x ::(1) Int 1439 -- -> (fun _ ::(Many) Int -> ()) x) which is ill-typed 1440 1441 -- If co :: (tyL1 -> tyL2) ~ (tyR1 -> tyR2) 1442 -- then co1 :: tyL1 ~ tyR1 1443 -- co2 :: tyL2 ~ tyR2 1444 = ASSERT2( isFunTy tyR, ppr co $$ ppr arg ) 1445 Just (mkSymCo co1, MCo co2) 1446 1447 | otherwise 1448 = Nothing 1449 where 1450 arg = funArgTy tyR 1451 Pair tyL tyR = coercionKind co 1452 1453pushCoercionIntoLambda 1454 :: InScopeSet -> Var -> CoreExpr -> CoercionR -> Maybe (Var, CoreExpr) 1455-- This implements the Push rule from the paper on coercions 1456-- (\x. e) |> co 1457-- ===> 1458-- (\x'. e |> co') 1459pushCoercionIntoLambda in_scope x e co 1460 | ASSERT(not (isTyVar x) && not (isCoVar x)) True 1461 , Pair s1s2 t1t2 <- coercionKind co 1462 , Just (_, _s1,_s2) <- splitFunTy_maybe s1s2 1463 , Just (w1, t1,_t2) <- splitFunTy_maybe t1t2 1464 , (co_mult, co1, co2) <- decomposeFunCo Representational co 1465 , isReflexiveCo co_mult 1466 -- We can't push the coercion in the case where co_mult isn't 1467 -- reflexivity. See pushCoValArg for more details. 1468 = let 1469 -- Should we optimize the coercions here? 1470 -- Otherwise they might not match too well 1471 x' = x `setIdType` t1 `setIdMult` w1 1472 in_scope' = in_scope `extendInScopeSet` x' 1473 subst = extendIdSubst (mkEmptySubst in_scope') 1474 x 1475 (mkCast (Var x') co1) 1476 in Just (x', substExpr subst e `mkCast` co2) 1477 | otherwise 1478 = pprTrace "exprIsLambda_maybe: Unexpected lambda in case" (ppr (Lam x e)) 1479 Nothing 1480 1481pushCoDataCon :: DataCon -> [CoreExpr] -> Coercion 1482 -> Maybe (DataCon 1483 , [Type] -- Universal type args 1484 , [CoreExpr]) -- All other args incl existentials 1485-- Implement the KPush reduction rule as described in "Down with kinds" 1486-- The transformation applies iff we have 1487-- (C e1 ... en) `cast` co 1488-- where co :: (T t1 .. tn) ~ to_ty 1489-- The left-hand one must be a T, because exprIsConApp returned True 1490-- but the right-hand one might not be. (Though it usually will.) 1491pushCoDataCon dc dc_args co 1492 | isReflCo co || from_ty `eqType` to_ty -- try cheap test first 1493 , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) dc_args 1494 = Just (dc, map exprToType univ_ty_args, rest_args) 1495 1496 | Just (to_tc, to_tc_arg_tys) <- splitTyConApp_maybe to_ty 1497 , to_tc == dataConTyCon dc 1498 -- These two tests can fail; we might see 1499 -- (C x y) `cast` (g :: T a ~ S [a]), 1500 -- where S is a type function. In fact, exprIsConApp 1501 -- will probably not be called in such circumstances, 1502 -- but there's nothing wrong with it 1503 1504 = let 1505 tc_arity = tyConArity to_tc 1506 dc_univ_tyvars = dataConUnivTyVars dc 1507 dc_ex_tcvars = dataConExTyCoVars dc 1508 arg_tys = dataConRepArgTys dc 1509 1510 non_univ_args = dropList dc_univ_tyvars dc_args 1511 (ex_args, val_args) = splitAtList dc_ex_tcvars non_univ_args 1512 1513 -- Make the "Psi" from the paper 1514 omegas = decomposeCo tc_arity co (tyConRolesRepresentational to_tc) 1515 (psi_subst, to_ex_arg_tys) 1516 = liftCoSubstWithEx Representational 1517 dc_univ_tyvars 1518 omegas 1519 dc_ex_tcvars 1520 (map exprToType ex_args) 1521 1522 -- Cast the value arguments (which include dictionaries) 1523 new_val_args = zipWith cast_arg (map scaledThing arg_tys) val_args 1524 cast_arg arg_ty arg = mkCast arg (psi_subst arg_ty) 1525 1526 to_ex_args = map Type to_ex_arg_tys 1527 1528 dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tcvars, 1529 ppr arg_tys, ppr dc_args, 1530 ppr ex_args, ppr val_args, ppr co, ppr from_ty, ppr to_ty, ppr to_tc 1531 , ppr $ mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args) ] 1532 in 1533 ASSERT2( eqType from_ty (mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args)), dump_doc ) 1534 ASSERT2( equalLength val_args arg_tys, dump_doc ) 1535 Just (dc, to_tc_arg_tys, to_ex_args ++ new_val_args) 1536 1537 | otherwise 1538 = Nothing 1539 1540 where 1541 Pair from_ty to_ty = coercionKind co 1542 1543collectBindersPushingCo :: CoreExpr -> ([Var], CoreExpr) 1544-- Collect lambda binders, pushing coercions inside if possible 1545-- E.g. (\x.e) |> g g :: <Int> -> blah 1546-- = (\x. e |> Nth 1 g) 1547-- 1548-- That is, 1549-- 1550-- collectBindersPushingCo ((\x.e) |> g) === ([x], e |> Nth 1 g) 1551collectBindersPushingCo e 1552 = go [] e 1553 where 1554 -- Peel off lambdas until we hit a cast. 1555 go :: [Var] -> CoreExpr -> ([Var], CoreExpr) 1556 -- The accumulator is in reverse order 1557 go bs (Lam b e) = go (b:bs) e 1558 go bs (Cast e co) = go_c bs e co 1559 go bs e = (reverse bs, e) 1560 1561 -- We are in a cast; peel off casts until we hit a lambda. 1562 go_c :: [Var] -> CoreExpr -> CoercionR -> ([Var], CoreExpr) 1563 -- (go_c bs e c) is same as (go bs e (e |> c)) 1564 go_c bs (Cast e co1) co2 = go_c bs e (co1 `mkTransCo` co2) 1565 go_c bs (Lam b e) co = go_lam bs b e co 1566 go_c bs e co = (reverse bs, mkCast e co) 1567 1568 -- We are in a lambda under a cast; peel off lambdas and build a 1569 -- new coercion for the body. 1570 go_lam :: [Var] -> Var -> CoreExpr -> CoercionR -> ([Var], CoreExpr) 1571 -- (go_lam bs b e c) is same as (go_c bs (\b.e) c) 1572 go_lam bs b e co 1573 | isTyVar b 1574 , let Pair tyL tyR = coercionKind co 1575 , ASSERT( isForAllTy_ty tyL ) 1576 isForAllTy_ty tyR 1577 , isReflCo (mkNthCo Nominal 0 co) -- See Note [collectBindersPushingCo] 1578 = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkTyVarTy b))) 1579 1580 | isCoVar b 1581 , let Pair tyL tyR = coercionKind co 1582 , ASSERT( isForAllTy_co tyL ) 1583 isForAllTy_co tyR 1584 , isReflCo (mkNthCo Nominal 0 co) -- See Note [collectBindersPushingCo] 1585 , let cov = mkCoVarCo b 1586 = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkCoercionTy cov))) 1587 1588 | isId b 1589 , let Pair tyL tyR = coercionKind co 1590 , ASSERT( isFunTy tyL) isFunTy tyR 1591 , (co_mult, co_arg, co_res) <- decomposeFunCo Representational co 1592 , isReflCo co_mult -- See Note [collectBindersPushingCo] 1593 , isReflCo co_arg -- See Note [collectBindersPushingCo] 1594 = go_c (b:bs) e co_res 1595 1596 | otherwise = (reverse bs, mkCast (Lam b e) co) 1597 1598{- 1599 1600Note [collectBindersPushingCo] 1601~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1602We just look for coercions of form 1603 <type> # w -> blah 1604(and similarly for foralls) to keep this function simple. We could do 1605more elaborate stuff, but it'd involve substitution etc. 1606 1607-} 1608