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.
participants (1)
-
Simon Peyton Jones (＠simonpj)