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