[Git][ghc/ghc][wip/T26548] 2 commits: Wibbles

17 Jan 2026

Simon Peyton Jones pushed to branch wip/T26548 at Glasgow Haskell Compiler / GHC


Commits:
9e2dff0c by Simon Peyton Jones at 2026-01-17T22:16:11+00:00
Wibbles

In particular, a lambda is a value argument in interestingArg
For some reason I had changed this and it made many things worse
This wibble puts it back!

- - - - -
757166fb by Simon Peyton Jones at 2026-01-17T22:16:17+00:00
Tracing in SpecConstr only

- - - - -


3 changed files:

- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Opt/SpecConstr.hs
- testsuite/tests/simplCore/should_compile/T26615.stderr


Changes:

=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -1059,7 +1059,9 @@ interestingArg env e = go env 0 e
     go env n (Lam v e)
        | isTyVar v             = go env n e
        | n>0                   = NonTrivArg     -- (\x.b) e   is NonTriv
-       | otherwise             = NonTrivArg
+       | otherwise             = ValueArg       -- (\x.b)     is Value
+                                                -- Having ValueArg here is very important
+                                                -- for getting higher order functions to inline
     go _ _ (Case {})           = NonTrivArg
     go env n (Let b e)         = case go env' n e of
                                    ValueArg -> ValueArg
@@ -1069,10 +1071,9 @@ interestingArg env e = go env 0 e
 
     go_var n v
        | isConLikeId v = ValueArg   -- Experimenting with 'conlike' rather that
-                                    --    data constructors here
-                                    -- DFuns are con-like; see Note [Conlike is interesting]
+                                    --    data constructors here (includes DFuns)
                                     --    see (IA1) in Note [Interesting arguments]
-       | idArity v > n = NonTrivArg   -- Catches (eg) primops with arity but no unfolding
+       | idArity v > n = NonTrivArg -- Catches (eg) primops with arity but no unfolding
        | n > 0         = NonTrivArg -- Saturated or unknown call
        | otherwise  -- n==0, no value arguments; look for an interesting unfolding
        = case idUnfolding v of


=====================================
compiler/GHC/Core/Opt/SpecConstr.hs
=====================================
@@ -2602,7 +2602,8 @@ callToPat :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
 callToPat env bndr_occs call@(Call fn args con_env)
   = do  { let in_scope = substInScopeSet (sc_subst env)
 
-        ; arg_triples <- zipWith3M (argToPat env in_scope con_env) args bndr_occs (map (const NotMarkedStrict) args)
+        ; arg_triples <- zipWith3M (argToPat env in_scope con_env) args bndr_occs
+                                   (map (const NotMarkedStrict) args)
                    -- This zip trims the args to be no longer than
                    -- the lambdas in the function definition (bndr_occs)
 
@@ -2639,6 +2640,15 @@ callToPat env bndr_occs call@(Call fn args con_env)
               sanitise id = updateIdTypeAndMult expandTypeSynonyms id
                 -- See Note [Free type variables of the qvar types]
 
+--         ; pprTraceM "callToPatOut" $
+--           vcat [ text "fn:" <+> ppr fn
+--                , text "args:" <+> ppr args
+--                , text "arg_triples:" <+> ppr arg_triples
+--                , text "bndr_occs:" <+> ppr bndr_occs
+--                , text "pat_fvs:" <+> ppr pat_fvs
+--                , text "qvars':" <+> ppr qvars'
+--                , text "pats:" <+> ppr pats ]
+
         -- Check for bad coercion variables: see Note [SpecConstr and casts]
         ; let bad_covars = filter isCoVar qids
         ; warnPprTrace (not (null bad_covars))
@@ -2648,12 +2658,6 @@ callToPat env bndr_occs call@(Call fn args con_env)
           if interesting && null bad_covars
           then do { let cp_res = CP { cp_qvars = qvars', cp_args = pats
                                     , cp_strict_args = concat cbv_ids }

---                  ; pprTraceM "callToPatOut" $
---                    vcat [ text "fn:" <+> ppr fn
---                         , text "args:" <+> ppr args
---                         , text "bndr_occs:" <+> ppr bndr_occs
---                         , text "pat_fvs:" <+> ppr pat_fvs
---                         , text "cp_res:" <+> ppr cp_res ]
                   ; return (Just cp_res) }
           else return Nothing }
 
@@ -2684,9 +2688,9 @@ argToPat :: ScEnv
 
 argToPat env in_scope val_env arg arg_occ arg_str
   = do
-    -- pprTraceM "argToPatIn" (ppr arg)
+    -- pprTraceM "argToPatIn {" (ppr arg)
     !res <- argToPat1 env in_scope val_env arg arg_occ arg_str
-    -- pprTraceM "argToPatOut" (ppr res)
+    -- pprTraceM "argToPatOut }" (ppr arg $$ ppr res)
     return res
 
 argToPat1 :: ScEnv
@@ -2780,7 +2784,8 @@ argToPat1 env in_scope val_env arg arg_occ _arg_str
   --    (b) we know what its value is
   -- In that case it counts as "interesting"
 argToPat1 env in_scope val_env (Var v) arg_occ arg_str
-  | sc_force env || specialisableArgOcc arg_occ  -- (a)
+  | -- pprTrace "argToPat:var" (ppr v $$ ppr is_value) $
+    sc_force env || specialisableArgOcc arg_occ  -- (a)
     -- See Note [Forcing specialisation], point (FS3)
   , is_value                                     -- (b)
        -- Ignoring sc_keen here to avoid gratuitously incurring Note [Reboxing]


=====================================
testsuite/tests/simplCore/should_compile/T26615.stderr
=====================================
@@ -2,7 +2,7 @@
 
 ==================== Tidy Core ====================
 Result size of Tidy Core
-  = {terms: 1,209, types: 1,139, coercions: 18, joins: 17/29}
+  = {terms: 1,200, types: 1,136, coercions: 18, joins: 17/29}
 
 -- RHS size: {terms: 6, types: 8, coercions: 0, joins: 0/0}
 unArray :: forall a. Array a -> SmallArray# a
@@ -725,7 +725,7 @@ lvl1
   = GHC.Internal.Control.Exception.Base.patError @LiftedRep @() lvl
 
 Rec {
--- RHS size: {terms: 133, types: 126, coercions: 0, joins: 1/2}
+-- RHS size: {terms: 130, types: 125, coercions: 0, joins: 1/2}
 T26615a.disjointSubtrees_$s$wdisjointSubtrees [InlPrag=INLINABLE[2],
                                                Occ=LoopBreaker]
   :: forall b a k.
@@ -748,7 +748,6 @@ T26615a.disjointSubtrees_$s$wdisjointSubtrees
         Empty -> GHC.Internal.Types.True;
         Leaf bx ds ->
           case ds of { L kB ds1 ->
-          case kB of k0 { __DEFAULT ->
           case eqWord# bx sc of {
             __DEFAULT -> GHC.Internal.Types.True;
             1# ->
@@ -780,8 +779,7 @@ T26615a.disjointSubtrees_$s$wdisjointSubtrees
                     }
                     }; } in
               jump $wlookupInArrayCont_
-                k0 sc1 0# (sizeofSmallArray# @Lifted @(Leaf k a) sc1)
-          }
+                kB sc1 0# (sizeofSmallArray# @Lifted @(Leaf k a) sc1)
           }
           };
         Collision bx bx1 ->
@@ -822,7 +820,7 @@ T26615a.disjointSubtrees_$s$wdisjointSubtrees
 end Rec }
 
 Rec {
--- RHS size: {terms: 705, types: 732, coercions: 18, joins: 13/23}
+-- RHS size: {terms: 699, types: 730, coercions: 18, joins: 13/23}
 T26615a.$wdisjointSubtrees [InlPrag=INLINABLE[2], Occ=LoopBreaker]
   :: forall k a b. Eq k => Int# -> HashMap k a -> HashMap k b -> Bool
 [GblId[StrictWorker([~, ~, !])],
@@ -852,7 +850,6 @@ T26615a.$wdisjointSubtrees [InlPrag=INLINABLE[2], Occ=LoopBreaker]
                          Empty -> GHC.Internal.Types.True;
                          Leaf bx [Occ=Once1] ds2 [Occ=Once1!] ->
                            case ds2 of { L kB [Occ=Once1] _ [Occ=Dead] ->
-                           case kB of k0 [Occ=Once1] { __DEFAULT ->
                            joinrec {
                              lookupCont_ [Occ=LoopBreakerT[5]]
                                :: Eq k => Word -> k -> Int -> HashMap k a -> Bool
@@ -980,8 +977,7 @@ T26615a.$wdisjointSubtrees [InlPrag=INLINABLE[2], Occ=LoopBreaker]
                                  }
                                  }; } in
                            jump lookupCont_
-                             $dEq (GHC.Internal.Types.W# bx) k0 (GHC.Internal.Types.I# ww) ds
-                           }
+                             $dEq (GHC.Internal.Types.W# bx) kB (GHC.Internal.Types.I# ww) ds
                            };
                          Collision _ [Occ=Dead] _ [Occ=Dead] ->
                            T26615a.$wdisjointSubtrees @k @b @a $dEq ww wild ds
@@ -992,7 +988,6 @@ T26615a.$wdisjointSubtrees [InlPrag=INLINABLE[2], Occ=LoopBreaker]
                      case ds1 of { L kA [Occ=Once2] _ [Occ=Dead] ->
                      case _b of wild2 [Occ=Once1] {
                        __DEFAULT ->
-                         case kA of k0 [Occ=Once1] { __DEFAULT ->
                          joinrec {
                            lookupCont_ [Occ=LoopBreakerT[5]]
                              :: Eq k => Word -> k -> Int -> HashMap k b -> Bool
@@ -1116,8 +1111,11 @@ T26615a.$wdisjointSubtrees [InlPrag=INLINABLE[2], Occ=LoopBreaker]
                                }
                                }; } in
                          jump lookupCont_
-                           $dEq (GHC.Internal.Types.W# bx) k0 (GHC.Internal.Types.I# ww) wild2
-                         };
+                           $dEq
+                           (GHC.Internal.Types.W# bx)
+                           kA
+                           (GHC.Internal.Types.I# ww)
+                           wild2;
                        Leaf bx1 [Occ=Once1] ds3 [Occ=Once1!] ->
                          case ds3 of { L kB [Occ=Once1] _ [Occ=Dead] ->
                          case GHC.Internal.Classes.neWord
@@ -1391,7 +1389,6 @@ T26615a.$wdisjointSubtrees
               Empty -> GHC.Internal.Types.True;
               Leaf bx ds2 ->
                 case ds2 of { L kB ds3 ->
-                case kB of k0 { __DEFAULT ->
                 join {
                   exit [Dmd=LC(S,C(1,C(1,C(1,L))))]
                     :: Word# -> k -> Word# -> Leaf k a -> Bool
@@ -1503,8 +1500,7 @@ T26615a.$wdisjointSubtrees
                           }
                       }
                       }; } in
-                jump $wlookupCont_ bx k0 ww ds
-                }
+                jump $wlookupCont_ bx kB ww ds
                 };
               Collision bx bx1 ->
                 T26615a.disjointSubtrees_$s$wdisjointSubtrees
@@ -1516,7 +1512,6 @@ T26615a.$wdisjointSubtrees
           case ds1 of { L kA ds2 ->
           case _b of wild2 {
             __DEFAULT ->
-              case kA of k0 { __DEFAULT ->
               join {
                 exit [Dmd=LC(S,C(1,C(1,C(1,L))))]
                   :: Word# -> k -> Word# -> Leaf k b -> Bool
@@ -1628,8 +1623,7 @@ T26615a.$wdisjointSubtrees
                         }
                     }
                     }; } in
-              jump $wlookupCont_ bx k0 ww wild2
-              };
+              jump $wlookupCont_ bx kA ww wild2;
             Leaf bx1 ds3 ->
               case ds3 of { L kB ds4 ->
               case neWord# bx bx1 of {
@@ -1950,7 +1944,7 @@ disjointSubtrees
 
 ==================== Tidy Core ====================
 Result size of Tidy Core
-  = {terms: 614, types: 666, coercions: 18, joins: 8/14}
+  = {terms: 609, types: 665, coercions: 18, joins: 8/14}
 
 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
 T26615.$trModule2 :: GHC.Internal.Prim.Addr#
@@ -2128,7 +2122,7 @@ $wpoly_lookupCont_
 end Rec }
 
 Rec {
--- RHS size: {terms: 448, types: 507, coercions: 18, joins: 8/13}
+-- RHS size: {terms: 443, types: 506, coercions: 18, joins: 8/13}
 T26615.$s$wdisjointSubtrees [InlPrag=[~], Occ=LoopBreaker]
   :: forall a b.
      GHC.Internal.Prim.Int#
@@ -2163,11 +2157,7 @@ T26615.$s$wdisjointSubtrees
             T26615a.Leaf bx1 ds3 ->
               case ds3 of { T26615a.L kB ds4 ->
               case GHC.Internal.Prim.neWord# bx bx1 of {
-                __DEFAULT ->
-                  case GHC.Internal.Classes.$fEqList_$s$c==1 kA kB of {
-                    False -> GHC.Internal.Types.True;
-                    True -> GHC.Internal.Types.False
-                  };
+                __DEFAULT -> GHC.Internal.Classes.$fEqList_$s$c/=1 kA kB;
                 1# -> GHC.Internal.Types.True
               }
               }



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/606ddfae3fc59c98d26fc66aaaa9f57...

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/606ddfae3fc59c98d26fc66aaaa9f57...
You're receiving this email because of your account on gitlab.haskell.org.

    

[Git][ghc/ghc][wip/T26548] 2 commits: Wibbles

Simon Peyton Jones (＠simonpj)