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