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
2 changed files:
Changes:
| ... | ... | @@ -2269,7 +2269,7 @@ simplInId :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr) |
| 2269 | 2269 | simplInId env var cont
|
| 2270 | 2270 | | Just dc <- isDataConWorkId_maybe var
|
| 2271 | 2271 | , isLazyDataConRep dc -- See Note [Fast path for lazy data constructors]
|
| 2272 | - = rebuild zapped_env (Var var) cont
|
|
| 2272 | + = rebuild_go zapped_env (Var var) cont
|
|
| 2273 | 2273 | | otherwise
|
| 2274 | 2274 | = case substId env var of
|
| 2275 | 2275 | ContEx tvs cvs ids e -> simplExprF env' e cont
|
| ... | ... | @@ -2282,12 +2282,24 @@ simplInId env var cont |
| 2282 | 2282 | where
|
| 2283 | 2283 | cont' = trimJoinCont out_id (idJoinPointHood out_id) cont
|
| 2284 | 2284 | |
| 2285 | - DoneEx e mb_join -> simplExprF zapped_env e cont'
|
|
| 2285 | + DoneEx e mb_join -> simplOutExpr zapped_env e cont'
|
|
| 2286 | 2286 | where
|
| 2287 | 2287 | cont' = trimJoinCont var mb_join cont
|
| 2288 | 2288 | where
|
| 2289 | 2289 | zapped_env = zapSubstEnv env -- See Note [zapSubstEnv]
|
| 2290 | 2290 | |
| 2291 | + |
|
| 2292 | +---------------------------------------------------------
|
|
| 2293 | +simplOutExpr :: SimplEnvIS -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr)
|
|
| 2294 | +simplOutExpr env expr cont
|
|
| 2295 | + = case fun of
|
|
| 2296 | + Var v -> simplOutId env v cont'
|
|
| 2297 | + Lam {} | not (null args) -> simplLam env fun cont' -- We have a beta-redex
|
|
| 2298 | + _ -> rebuild_go env expr cont
|
|
| 2299 | + where
|
|
| 2300 | + (fun, args) <- collectArgs expr
|
|
| 2301 | + cont' = pushArgs env Simplified (expType fun) args cont
|
|
| 2302 | + |
|
| 2291 | 2303 | ---------------------------------------------------------
|
| 2292 | 2304 | simplOutId :: SimplEnvIS -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr)
|
| 2293 | 2305 | |
| ... | ... | @@ -2338,7 +2350,7 @@ simplOutId env fun cont |
| 2338 | 2350 | |
| 2339 | 2351 | ; let rr' = getRuntimeRep new_runrw_res_ty
|
| 2340 | 2352 | call' = mkApps (Var fun) [mkTyArg rr', mkTyArg new_runrw_res_ty, arg']
|
| 2341 | - ; rebuild env call' outer_cont }
|
|
| 2353 | + ; rebuild_go env call' outer_cont }
|
|
| 2342 | 2354 | |
| 2343 | 2355 | -- Normal case for (f e1 .. en)
|
| 2344 | 2356 | simplOutId env fun cont
|
| ... | ... | @@ -2351,8 +2363,9 @@ simplOutId env fun cont |
| 2351 | 2363 | then tryRules env rules_for_me fun out_args
|
| 2352 | 2364 | else return Nothing
|
| 2353 | 2365 | ; case mb_match of {
|
| 2354 | - Just (rule_arity, rhs) -> simplExprF env rhs $
|
|
| 2355 | - dropContArgs rule_arity cont ;
|
|
| 2366 | + Just (rule_arity, rhs, rhs_args ) -> simplExprF env rhs $
|
|
| 2367 | + pushArgs env NoDup rhs_args $
|
|
| 2368 | + dropContArgs rule_arity cont ;
|
|
| 2356 | 2369 | Nothing ->
|
| 2357 | 2370 | |
| 2358 | 2371 | -- Try inlining
|
| ... | ... | @@ -2444,8 +2457,10 @@ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_rules = rules }) |
| 2444 | 2457 | = do { let args = reverse rev_args
|
| 2445 | 2458 | ; mb_match <- tryRules env rules fun (map argSpecArg args)
|
| 2446 | 2459 | ; case mb_match of
|
| 2447 | - Just (rule_arity, rhs) -> simplExprF env rhs $
|
|
| 2448 | - pushSimplifiedArgs env (drop rule_arity args) cont
|
|
| 2460 | + Just (rule_arity, rhs, rhs_args)
|
|
| 2461 | + -> simplExprF env rhs $
|
|
| 2462 | + pushArgs env Simplified rhs_args $
|
|
| 2463 | + pushArgSpecs env (drop rule_arity args) cont
|
|
| 2449 | 2464 | Nothing -> rebuild env (argInfoExpr fun rev_args) cont }
|
| 2450 | 2465 | |
| 2451 | 2466 | -----------------------------------
|
| ... | ... | @@ -2707,10 +2722,11 @@ trySeqRules in_env scrut rhs cont |
| 2707 | 2722 | ; let seq_rules = getRules rule_base seqId
|
| 2708 | 2723 | ; mb_match <- tryRules in_env seq_rules seqId out_args
|
| 2709 | 2724 | ; case mb_match of
|
| 2710 | - Nothing -> return Nothing
|
|
| 2711 | - Just (rule_arity, rhs) -> return (Just (rhs, cont'))
|
|
| 2725 | + Nothing -> return Nothing
|
|
| 2726 | + Just (rule_arity, rhs, rhs_args) -> return (Just (rhs, cont'))
|
|
| 2712 | 2727 | where
|
| 2713 | - cont' = pushSimplifiedArgs in_env (drop rule_arity out_arg_specs) rule_cont
|
|
| 2728 | + cont' = pushArgs in_env Simplified rhs_args $
|
|
| 2729 | + pushArgSpecs in_env (drop rule_arity out_arg_specs) rule_cont
|
|
| 2714 | 2730 | }
|
| 2715 | 2731 | where
|
| 2716 | 2732 | no_cast_scrut = drop_casts scrut
|
| ... | ... | @@ -3217,7 +3233,7 @@ reallyRebuildCase env scrut case_bndr alts cont |
| 3217 | 3233 | -- Note [Case-of-case and full laziness]
|
| 3218 | 3234 | = do { case_expr <- simplAlts env scrut case_bndr alts
|
| 3219 | 3235 | (mkBoringStop (contHoleType cont))
|
| 3220 | - ; rebuild (zapSubstEnv env) case_expr cont }
|
|
| 3236 | + ; rebuild env case_expr cont }
|
|
| 3221 | 3237 | |
| 3222 | 3238 | | otherwise
|
| 3223 | 3239 | = do { (floats, env', cont') <- mkDupableCaseCont env alts cont
|
| ... | ... | @@ -22,7 +22,7 @@ module GHC.Core.Opt.Simplify.Utils ( |
| 22 | 22 | |
| 23 | 23 | -- The continuation type
|
| 24 | 24 | SimplCont(..), DupFlag(..), FromWhat(..), StaticEnv,
|
| 25 | - isSimplified, contIsStop,
|
|
| 25 | + isSimplified, contIsStop, contHasArgs,
|
|
| 26 | 26 | contIsDupable, contResultType, contHoleType, contHoleScaling,
|
| 27 | 27 | contIsTrivial, contArgs, contIsRhs,
|
| 28 | 28 | countArgs, contOutArgs, dropContArgs,
|
| ... | ... | @@ -33,7 +33,7 @@ module GHC.Core.Opt.Simplify.Utils ( |
| 33 | 33 | ArgInfo(..), ArgSpec(..), mkArgInfo,
|
| 34 | 34 | addValArgTo, addTyArgTo,
|
| 35 | 35 | argInfoExpr, argSpecArg,
|
| 36 | - pushSimplifiedArgs,
|
|
| 36 | + pushSimplifiedArgs, pushArgSpecs,
|
|
| 37 | 37 | isStrictArgInfo, lazyArgContext,
|
| 38 | 38 | |
| 39 | 39 | abstractFloats,
|
| ... | ... | @@ -384,16 +384,29 @@ isStrictArgInfo (ArgInfo { ai_dmds = dmds }) |
| 384 | 384 | | dmd:_ <- dmds = isStrUsedDmd dmd
|
| 385 | 385 | | otherwise = False
|
| 386 | 386 | |
| 387 | -pushSimplifiedArgs :: SimplEnv
|
|
| 388 | - -> [ArgSpec] -- In normal, forward order
|
|
| 389 | - -> SimplCont -> SimplCont
|
|
| 390 | -pushSimplifiedArgs env args cont = foldr (pushSimplifiedArg env) cont args
|
|
| 387 | +pushArgs :: SimplEnvIS -> DupFlag -> Type -> [OutExpr] -> SimplCont -> SimplCont
|
|
| 388 | +pushArgs _env _dup _fun_ty [] cont
|
|
| 389 | + = cont
|
|
| 390 | +pushArgs env dup fun_ty (arg:args) cont
|
|
| 391 | + | Type ty <- arg
|
|
| 392 | + = ApplyToType { sc_hole_ty = fun_ty
|
|
| 393 | + , sc_arg_ty = ty, sc_env = env
|
|
| 394 | + , sc_cont = pushArgs env dup (piResultTy fun_ty ty) args }
|
|
| 395 | + | otherwise
|
|
| 396 | + = ApplyToVal { sc_dup = dup, sc_hole_ty = fun_ty
|
|
| 397 | + , sc_arg = arg, sc_env = env
|
|
| 398 | + , sc_cont = pushArgs env dup (funResultTy fun_ty) args }
|
|
| 399 | + |
|
| 400 | +pushArgSpecs :: SimplEnvIS -- Barely needed, since sc_dup = Simplified
|
|
| 401 | + -> [ArgSpec] -- In normal, forward order
|
|
| 402 | + -> SimplCont -> SimplCont
|
|
| 403 | +pushArgSpecs env args cont = foldr (pushArgSpec env) cont args
|
|
| 391 | 404 | -- pushSimplifiedRevArgs env args cont = foldl' (\k a -> pushSimplifiedArg env a k) cont args
|
| 392 | 405 | |
| 393 | -pushSimplifiedArg :: SimplEnv -> ArgSpec -> SimplCont -> SimplCont
|
|
| 394 | -pushSimplifiedArg _env (TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty }) cont
|
|
| 406 | +pushArgSpec :: SimplEnvIS -> ArgSpec -> SimplCont -> SimplCont
|
|
| 407 | +pushArgSpec _env (TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty }) cont
|
|
| 395 | 408 | = ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = cont }
|
| 396 | -pushSimplifiedArg env (ValArg { as_arg = arg, as_hole_ty = hole_ty }) cont
|
|
| 409 | +pushArgSpec env (ValArg { as_arg = arg, as_hole_ty = hole_ty }) cont
|
|
| 397 | 410 | = ApplyToVal { sc_arg = arg, sc_env = env, sc_dup = Simplified
|
| 398 | 411 | -- The SubstEnv will be ignored since sc_dup=Simplified
|
| 399 | 412 | , sc_hole_ty = hole_ty, sc_cont = cont }
|
| ... | ... | @@ -438,6 +451,11 @@ contIsRhs (Stop _ (RhsCtxt is_rec) _) = Just is_rec |
| 438 | 451 | contIsRhs (CastIt { sc_cont = k }) = contIsRhs k -- For f = e |> co, treat e as Rhs context
|
| 439 | 452 | contIsRhs _ = Nothing
|
| 440 | 453 | |
| 454 | +-------------------
|
|
| 455 | +contHasArgs (ApplyToTy {}) = True
|
|
| 456 | +contHasArgs (ApplyToVal {}) = True
|
|
| 457 | +contHasArgs _ = False
|
|
| 458 | + |
|
| 441 | 459 | -------------------
|
| 442 | 460 | contIsStop :: SimplCont -> Bool
|
| 443 | 461 | contIsStop (Stop {}) = True
|