Simon Peyton Jones pushed to branch wip/T26989 at Glasgow Haskell Compiler / GHC Commits: ba07cdb9 by Simon Peyton Jones at 2026-04-06T17:23:15+01:00 Wibbles [skip ci] - - - - - 2 changed files: - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs Changes: ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -2269,7 +2269,7 @@ simplInId :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr) simplInId env var cont | Just dc <- isDataConWorkId_maybe var , isLazyDataConRep dc -- See Note [Fast path for lazy data constructors] - = rebuild zapped_env (Var var) cont + = rebuild_go zapped_env (Var var) cont | otherwise = case substId env var of ContEx tvs cvs ids e -> simplExprF env' e cont @@ -2282,12 +2282,24 @@ simplInId env var cont where cont' = trimJoinCont out_id (idJoinPointHood out_id) cont - DoneEx e mb_join -> simplExprF zapped_env e cont' + DoneEx e mb_join -> simplOutExpr zapped_env e cont' where cont' = trimJoinCont var mb_join cont where zapped_env = zapSubstEnv env -- See Note [zapSubstEnv] + +--------------------------------------------------------- +simplOutExpr :: SimplEnvIS -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) +simplOutExpr env expr cont + = case fun of + Var v -> simplOutId env v cont' + Lam {} | not (null args) -> simplLam env fun cont' -- We have a beta-redex + _ -> rebuild_go env expr cont + where + (fun, args) <- collectArgs expr + cont' = pushArgs env Simplified (expType fun) args cont + --------------------------------------------------------- simplOutId :: SimplEnvIS -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr) @@ -2338,7 +2350,7 @@ simplOutId env fun cont ; let rr' = getRuntimeRep new_runrw_res_ty call' = mkApps (Var fun) [mkTyArg rr', mkTyArg new_runrw_res_ty, arg'] - ; rebuild env call' outer_cont } + ; rebuild_go env call' outer_cont } -- Normal case for (f e1 .. en) simplOutId env fun cont @@ -2351,8 +2363,9 @@ simplOutId env fun cont then tryRules env rules_for_me fun out_args else return Nothing ; case mb_match of { - Just (rule_arity, rhs) -> simplExprF env rhs $ - dropContArgs rule_arity cont ; + Just (rule_arity, rhs, rhs_args ) -> simplExprF env rhs $ + pushArgs env NoDup rhs_args $ + dropContArgs rule_arity cont ; Nothing -> -- Try inlining @@ -2444,8 +2457,10 @@ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_rules = rules }) = do { let args = reverse rev_args ; mb_match <- tryRules env rules fun (map argSpecArg args) ; case mb_match of - Just (rule_arity, rhs) -> simplExprF env rhs $ - pushSimplifiedArgs env (drop rule_arity args) cont + Just (rule_arity, rhs, rhs_args) + -> simplExprF env rhs $ + pushArgs env Simplified rhs_args $ + pushArgSpecs env (drop rule_arity args) cont Nothing -> rebuild env (argInfoExpr fun rev_args) cont } ----------------------------------- @@ -2707,10 +2722,11 @@ trySeqRules in_env scrut rhs cont ; let seq_rules = getRules rule_base seqId ; mb_match <- tryRules in_env seq_rules seqId out_args ; case mb_match of - Nothing -> return Nothing - Just (rule_arity, rhs) -> return (Just (rhs, cont')) + Nothing -> return Nothing + Just (rule_arity, rhs, rhs_args) -> return (Just (rhs, cont')) where - cont' = pushSimplifiedArgs in_env (drop rule_arity out_arg_specs) rule_cont + cont' = pushArgs in_env Simplified rhs_args $ + pushArgSpecs in_env (drop rule_arity out_arg_specs) rule_cont } where no_cast_scrut = drop_casts scrut @@ -3217,7 +3233,7 @@ reallyRebuildCase env scrut case_bndr alts cont -- Note [Case-of-case and full laziness] = do { case_expr <- simplAlts env scrut case_bndr alts (mkBoringStop (contHoleType cont)) - ; rebuild (zapSubstEnv env) case_expr cont } + ; rebuild env case_expr cont } | otherwise = do { (floats, env', cont') <- mkDupableCaseCont env alts cont ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -22,7 +22,7 @@ module GHC.Core.Opt.Simplify.Utils ( -- The continuation type SimplCont(..), DupFlag(..), FromWhat(..), StaticEnv, - isSimplified, contIsStop, + isSimplified, contIsStop, contHasArgs, contIsDupable, contResultType, contHoleType, contHoleScaling, contIsTrivial, contArgs, contIsRhs, countArgs, contOutArgs, dropContArgs, @@ -33,7 +33,7 @@ module GHC.Core.Opt.Simplify.Utils ( ArgInfo(..), ArgSpec(..), mkArgInfo, addValArgTo, addTyArgTo, argInfoExpr, argSpecArg, - pushSimplifiedArgs, + pushSimplifiedArgs, pushArgSpecs, isStrictArgInfo, lazyArgContext, abstractFloats, @@ -384,16 +384,29 @@ isStrictArgInfo (ArgInfo { ai_dmds = dmds }) | dmd:_ <- dmds = isStrUsedDmd dmd | otherwise = False -pushSimplifiedArgs :: SimplEnv - -> [ArgSpec] -- In normal, forward order - -> SimplCont -> SimplCont -pushSimplifiedArgs env args cont = foldr (pushSimplifiedArg env) cont args +pushArgs :: SimplEnvIS -> DupFlag -> Type -> [OutExpr] -> SimplCont -> SimplCont +pushArgs _env _dup _fun_ty [] cont + = cont +pushArgs env dup fun_ty (arg:args) cont + | Type ty <- arg + = ApplyToType { sc_hole_ty = fun_ty + , sc_arg_ty = ty, sc_env = env + , sc_cont = pushArgs env dup (piResultTy fun_ty ty) args } + | otherwise + = ApplyToVal { sc_dup = dup, sc_hole_ty = fun_ty + , sc_arg = arg, sc_env = env + , sc_cont = pushArgs env dup (funResultTy fun_ty) args } + +pushArgSpecs :: SimplEnvIS -- Barely needed, since sc_dup = Simplified + -> [ArgSpec] -- In normal, forward order + -> SimplCont -> SimplCont +pushArgSpecs env args cont = foldr (pushArgSpec env) cont args -- pushSimplifiedRevArgs env args cont = foldl' (\k a -> pushSimplifiedArg env a k) cont args -pushSimplifiedArg :: SimplEnv -> ArgSpec -> SimplCont -> SimplCont -pushSimplifiedArg _env (TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty }) cont +pushArgSpec :: SimplEnvIS -> ArgSpec -> SimplCont -> SimplCont +pushArgSpec _env (TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty }) cont = ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = cont } -pushSimplifiedArg env (ValArg { as_arg = arg, as_hole_ty = hole_ty }) cont +pushArgSpec env (ValArg { as_arg = arg, as_hole_ty = hole_ty }) cont = ApplyToVal { sc_arg = arg, sc_env = env, sc_dup = Simplified -- The SubstEnv will be ignored since sc_dup=Simplified , sc_hole_ty = hole_ty, sc_cont = cont } @@ -438,6 +451,11 @@ contIsRhs (Stop _ (RhsCtxt is_rec) _) = Just is_rec contIsRhs (CastIt { sc_cont = k }) = contIsRhs k -- For f = e |> co, treat e as Rhs context contIsRhs _ = Nothing +------------------- +contHasArgs (ApplyToTy {}) = True +contHasArgs (ApplyToVal {}) = True +contHasArgs _ = False + ------------------- contIsStop :: SimplCont -> Bool contIsStop (Stop {}) = True View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ba07cdb9f50e5416089fc8aceec24d8f... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ba07cdb9f50e5416089fc8aceec24d8f... You're receiving this email because of your account on gitlab.haskell.org.