Simon Peyton Jones pushed to branch wip/T27737 at Glasgow Haskell Compiler / GHC Commits: eac53361 by Simon Peyton Jones at 2026-09-23T23:56:52+01:00 Wibbles - - - - - 3 changed files: - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - testsuite/tests/simplCore/should_compile/T26903.stderr Changes: ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -1339,15 +1339,11 @@ simplExprF1 env (Let (Rec pairs) body) cont splitContForNoCaseCase :: SimplEnv -> SimplCont -> Maybe (SimplCont, SimplCont) --- Splits `cont` into (inner, outer), where `inner` has only --- applications, and `outer` is non-trivial +-- When seCaseCase is off, this function splits `cont` into (inner, outer), +-- where `inner` has only applications, and `outer` is non-trivial splitContForNoCaseCase env cont - | not (seCaseCase env) - , (inner, outer) <- splitContArgs cont - , not (contIsStop outer) - = Just (inner, outer) - | otherwise - = Nothing + | seCaseCase env = Nothing + | otherwise = splitContArgs cont {- Note [Avoiding space leaks in OutType] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -632,17 +632,24 @@ contOutArgs env cont -- No more arguments go _ = [] -splitContArgs :: SimplCont -> (SimplCont, SimplCont) --- Peel off an initial prefix of applications and casts +splitContArgs :: SimplCont -> Maybe (SimplCont, SimplCont) +-- Splits `cont` into (inner, outer), where `inner` has only +-- applications and casts, and `outer` is non-trivial splitContArgs cont@(ApplyToTy { sc_cont = cont1 }) - | (inner, outer) <- splitContArgs cont1 = (cont { sc_cont = inner }, outer) + = do { (inner, outer) <- splitContArgs cont1 + ; return (cont { sc_cont = inner }, outer) } splitContArgs cont@(ApplyToVal { sc_cont = cont1 }) - | (inner, outer) <- splitContArgs cont1 = (cont { sc_cont = inner }, outer) + = do { (inner, outer) <- splitContArgs cont1 + ; return (cont { sc_cont = inner }, outer) } splitContArgs cont@(CastIt { sc_cont = cont1 }) - | (inner, outer) <- splitContArgs cont1 = (cont { sc_cont = inner }, outer) -splitContArgs cont - | contIsStop cont = (cont, cont) - | otherwise = (mkBoringStop (contHoleType cont), cont) + = do { (inner, outer) <- splitContArgs cont1 + ; return (cont { sc_cont = inner }, outer) } +splitContArgs outer + | contIsStop outer = Nothing + | otherwise = pprTrace "splitContHoleType" (ppr hole_ty) $ + return (mkBoringStop hole_ty, outer) + where + hole_ty = contHoleType outer dropContArgs :: FullArgCount -> SimplCont -> SimplCont dropContArgs 0 cont = cont ===================================== testsuite/tests/simplCore/should_compile/T26903.stderr ===================================== @@ -1,35 +1,42 @@ ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 127, types: 130, coercions: 48, joins: 0/0} + = {terms: 127, types: 130, coercions: 24, joins: 0/0} $dmop - = (\ @a _ $dOrd xs ys -> - case $fOrdList_$ccompare $dOrd xs ys of { - __DEFAULT -> - reverse1 (reverse1 (reverse1 (reverse1 (++ xs ys) []) []) []) []; - GT -> reverse1 (reverse1 (reverse1 (reverse xs) []) []) [] - }) - `cast` <Co:20> :: ... + = \ @a $dC $dOrd xs ys -> + case $fOrdList_$ccompare $dOrd xs ys of { + __DEFAULT -> + (reverse1 (reverse1 (reverse1 (reverse1 (++ xs ys) []) []) []) []) + `cast` <Co:3>; + GT -> + (reverse1 (reverse1 (reverse1 (reverse xs) []) []) []) + `cast` <Co:3> + } $fCInt_$cop - = (\ xs ys -> - case $fOrdList_$s$ccompare xs ys of { - __DEFAULT -> - reverse1 (reverse1 (reverse1 (reverse1 (++ xs ys) []) []) []) []; - GT -> reverse1 (reverse1 (reverse1 (reverse xs) []) []) [] - }) - `cast` <Co:11> :: ... + = \ xs ys -> + case $fOrdList_$s$ccompare xs ys of { + __DEFAULT -> + (reverse1 (reverse1 (reverse1 (reverse1 (++ xs ys) []) []) []) []) + `cast` <Co:3>; + GT -> + (reverse1 (reverse1 (reverse1 (reverse xs) []) []) []) + `cast` <Co:3> + } $fCInt1 = \ xs ys -> case $fOrdList_$s$ccompare xs ys of { __DEFAULT -> - reverse1 (reverse1 (reverse1 (reverse1 (++ xs ys) []) []) []) []; - GT -> reverse1 (reverse1 (reverse1 (reverse xs) []) []) [] + (reverse1 (reverse1 (reverse1 (reverse1 (++ xs ys) []) []) []) []) + `cast` <Co:3>; + GT -> + (reverse1 (reverse1 (reverse1 (reverse xs) []) []) []) + `cast` <Co:3> } -$fCInt = C:C ($fCInt1 `cast` <Co:11> :: ...) +$fCInt = C:C $fCInt1 test4 = reverse1 [] [] @@ -44,8 +51,8 @@ test case $fOrdList_$s$ccompare [] xs of { __DEFAULT -> (reverse1 (reverse1 (reverse1 (reverse1 (++ [] xs) []) []) []) []) - `cast` <Co:3> :: ...; - GT -> test1 `cast` <Co:3> :: ... + `cast` <Co:3>; + GT -> test1 `cast` <Co:3> } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/eac53361f27c482cfdb34ca51f64f538... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/eac53361f27c482cfdb34ca51f64f538... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help