[Git][ghc/ghc][wip/T26989] Wibbles [skip ci]

6 Apr 2026


      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.

    

Simon Peyton Jones (＠simonpj)

tags

participants (1)