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
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:
| ... | ... | @@ -1339,15 +1339,11 @@ simplExprF1 env (Let (Rec pairs) body) cont |
| 1339 | 1339 | |
| 1340 | 1340 | splitContForNoCaseCase :: SimplEnv -> SimplCont
|
| 1341 | 1341 | -> Maybe (SimplCont, SimplCont)
|
| 1342 | --- Splits `cont` into (inner, outer), where `inner` has only
|
|
| 1343 | --- applications, and `outer` is non-trivial
|
|
| 1342 | +-- When seCaseCase is off, this function splits `cont` into (inner, outer),
|
|
| 1343 | +-- where `inner` has only applications, and `outer` is non-trivial
|
|
| 1344 | 1344 | splitContForNoCaseCase env cont
|
| 1345 | - | not (seCaseCase env)
|
|
| 1346 | - , (inner, outer) <- splitContArgs cont
|
|
| 1347 | - , not (contIsStop outer)
|
|
| 1348 | - = Just (inner, outer)
|
|
| 1349 | - | otherwise
|
|
| 1350 | - = Nothing
|
|
| 1345 | + | seCaseCase env = Nothing
|
|
| 1346 | + | otherwise = splitContArgs cont
|
|
| 1351 | 1347 | |
| 1352 | 1348 | {- Note [Avoiding space leaks in OutType]
|
| 1353 | 1349 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
| ... | ... | @@ -632,17 +632,24 @@ contOutArgs env cont |
| 632 | 632 | -- No more arguments
|
| 633 | 633 | go _ = []
|
| 634 | 634 | |
| 635 | -splitContArgs :: SimplCont -> (SimplCont, SimplCont)
|
|
| 636 | --- Peel off an initial prefix of applications and casts
|
|
| 635 | +splitContArgs :: SimplCont -> Maybe (SimplCont, SimplCont)
|
|
| 636 | +-- Splits `cont` into (inner, outer), where `inner` has only
|
|
| 637 | +-- applications and casts, and `outer` is non-trivial
|
|
| 637 | 638 | splitContArgs cont@(ApplyToTy { sc_cont = cont1 })
|
| 638 | - | (inner, outer) <- splitContArgs cont1 = (cont { sc_cont = inner }, outer)
|
|
| 639 | + = do { (inner, outer) <- splitContArgs cont1
|
|
| 640 | + ; return (cont { sc_cont = inner }, outer) }
|
|
| 639 | 641 | splitContArgs cont@(ApplyToVal { sc_cont = cont1 })
|
| 640 | - | (inner, outer) <- splitContArgs cont1 = (cont { sc_cont = inner }, outer)
|
|
| 642 | + = do { (inner, outer) <- splitContArgs cont1
|
|
| 643 | + ; return (cont { sc_cont = inner }, outer) }
|
|
| 641 | 644 | splitContArgs cont@(CastIt { sc_cont = cont1 })
|
| 642 | - | (inner, outer) <- splitContArgs cont1 = (cont { sc_cont = inner }, outer)
|
|
| 643 | -splitContArgs cont
|
|
| 644 | - | contIsStop cont = (cont, cont)
|
|
| 645 | - | otherwise = (mkBoringStop (contHoleType cont), cont)
|
|
| 645 | + = do { (inner, outer) <- splitContArgs cont1
|
|
| 646 | + ; return (cont { sc_cont = inner }, outer) }
|
|
| 647 | +splitContArgs outer
|
|
| 648 | + | contIsStop outer = Nothing
|
|
| 649 | + | otherwise = pprTrace "splitContHoleType" (ppr hole_ty) $
|
|
| 650 | + return (mkBoringStop hole_ty, outer)
|
|
| 651 | + where
|
|
| 652 | + hole_ty = contHoleType outer
|
|
| 646 | 653 | |
| 647 | 654 | dropContArgs :: FullArgCount -> SimplCont -> SimplCont
|
| 648 | 655 | dropContArgs 0 cont = cont
|
| 1 | 1 | |
| 2 | 2 | ==================== Tidy Core ====================
|
| 3 | 3 | Result size of Tidy Core
|
| 4 | - = {terms: 127, types: 130, coercions: 48, joins: 0/0}
|
|
| 4 | + = {terms: 127, types: 130, coercions: 24, joins: 0/0}
|
|
| 5 | 5 | |
| 6 | 6 | $dmop
|
| 7 | - = (\ @a _ $dOrd xs ys ->
|
|
| 8 | - case $fOrdList_$ccompare $dOrd xs ys of {
|
|
| 9 | - __DEFAULT ->
|
|
| 10 | - reverse1 (reverse1 (reverse1 (reverse1 (++ xs ys) []) []) []) [];
|
|
| 11 | - GT -> reverse1 (reverse1 (reverse1 (reverse xs) []) []) []
|
|
| 12 | - })
|
|
| 13 | - `cast` <Co:20> :: ...
|
|
| 7 | + = \ @a $dC $dOrd xs ys ->
|
|
| 8 | + case $fOrdList_$ccompare $dOrd xs ys of {
|
|
| 9 | + __DEFAULT ->
|
|
| 10 | + (reverse1 (reverse1 (reverse1 (reverse1 (++ xs ys) []) []) []) [])
|
|
| 11 | + `cast` <Co:3>;
|
|
| 12 | + GT ->
|
|
| 13 | + (reverse1 (reverse1 (reverse1 (reverse xs) []) []) [])
|
|
| 14 | + `cast` <Co:3>
|
|
| 15 | + }
|
|
| 14 | 16 | |
| 15 | 17 | $fCInt_$cop
|
| 16 | - = (\ xs ys ->
|
|
| 17 | - case $fOrdList_$s$ccompare xs ys of {
|
|
| 18 | - __DEFAULT ->
|
|
| 19 | - reverse1 (reverse1 (reverse1 (reverse1 (++ xs ys) []) []) []) [];
|
|
| 20 | - GT -> reverse1 (reverse1 (reverse1 (reverse xs) []) []) []
|
|
| 21 | - })
|
|
| 22 | - `cast` <Co:11> :: ...
|
|
| 18 | + = \ xs ys ->
|
|
| 19 | + case $fOrdList_$s$ccompare xs ys of {
|
|
| 20 | + __DEFAULT ->
|
|
| 21 | + (reverse1 (reverse1 (reverse1 (reverse1 (++ xs ys) []) []) []) [])
|
|
| 22 | + `cast` <Co:3>;
|
|
| 23 | + GT ->
|
|
| 24 | + (reverse1 (reverse1 (reverse1 (reverse xs) []) []) [])
|
|
| 25 | + `cast` <Co:3>
|
|
| 26 | + }
|
|
| 23 | 27 | |
| 24 | 28 | $fCInt1
|
| 25 | 29 | = \ xs ys ->
|
| 26 | 30 | case $fOrdList_$s$ccompare xs ys of {
|
| 27 | 31 | __DEFAULT ->
|
| 28 | - reverse1 (reverse1 (reverse1 (reverse1 (++ xs ys) []) []) []) [];
|
|
| 29 | - GT -> reverse1 (reverse1 (reverse1 (reverse xs) []) []) []
|
|
| 32 | + (reverse1 (reverse1 (reverse1 (reverse1 (++ xs ys) []) []) []) [])
|
|
| 33 | + `cast` <Co:3>;
|
|
| 34 | + GT ->
|
|
| 35 | + (reverse1 (reverse1 (reverse1 (reverse xs) []) []) [])
|
|
| 36 | + `cast` <Co:3>
|
|
| 30 | 37 | }
|
| 31 | 38 | |
| 32 | -$fCInt = C:C ($fCInt1 `cast` <Co:11> :: ...)
|
|
| 39 | +$fCInt = C:C $fCInt1
|
|
| 33 | 40 | |
| 34 | 41 | test4 = reverse1 [] []
|
| 35 | 42 | |
| ... | ... | @@ -44,8 +51,8 @@ test |
| 44 | 51 | case $fOrdList_$s$ccompare [] xs of {
|
| 45 | 52 | __DEFAULT ->
|
| 46 | 53 | (reverse1 (reverse1 (reverse1 (reverse1 (++ [] xs) []) []) []) [])
|
| 47 | - `cast` <Co:3> :: ...;
|
|
| 48 | - GT -> test1 `cast` <Co:3> :: ...
|
|
| 54 | + `cast` <Co:3>;
|
|
| 55 | + GT -> test1 `cast` <Co:3>
|
|
| 49 | 56 | }
|
| 50 | 57 | |
| 51 | 58 |