[Git][ghc/ghc][master] Add regression test for #22611.
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue Jan 17 01:49:55 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
8c7a991c by Andreas Klebinger at 2023-01-16T20:49:34-05:00
Add regression test for #22611.
A case were a function used to fail to specialize, but now does.
- - - - -
3 changed files:
- + testsuite/tests/simplCore/should_compile/T22611.hs
- + testsuite/tests/simplCore/should_compile/T22611.stderr
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
testsuite/tests/simplCore/should_compile/T22611.hs
=====================================
@@ -0,0 +1,23 @@
+-- The method `alterF` inside containers is marked as INLINEABLE
+-- and hence should be specialized to the `CheckRes` Functor.
+
+-- This only started to work with 9.6, this test checks that we don't
+-- regress on this.
+
+{-# language LambdaCase, Strict, DeriveFunctor, DerivingStrategies #-}
+
+module T22611 where
+
+import Data.Map.Strict as Map
+import qualified Data.Map.Strict as Map
+
+foo :: Either Int Char -> Map (Either Int Char) v -> Maybe (v, (Map (Either Int Char) v))
+foo x subst = case Map.alterF alt x subst of
+ NotFound -> foo (fmap (toEnum . (+1) . fromEnum) x) subst
+ Found p q -> Just (p, q)
+ where
+ alt :: Maybe a1 -> CheckRes a1 (Maybe a2)
+ alt = (\case {Nothing -> NotFound; Just t -> Found t Nothing})
+
+data CheckRes a m = NotFound | Found !a ~m
+ deriving stock Functor
=====================================
testsuite/tests/simplCore/should_compile/T22611.stderr
=====================================
@@ -0,0 +1,285 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+ = {terms: 544, types: 486, coercions: 0, joins: 0/7}
+
+$WFound
+ = \ @a @m conrep conrep1 ->
+ case conrep of conrep2 { __DEFAULT -> Found conrep2 conrep1 }
+
+$fFunctorCheckRes_$c<$
+ = \ @a @a1 @b z ds ->
+ case z of z1 { __DEFAULT ->
+ case ds of {
+ NotFound -> NotFound;
+ Found a2 a3 -> Found a2 z1
+ }
+ }
+
+$fFunctorCheckRes_$cfmap
+ = \ @a @a1 @b f ds ->
+ case f of f1 { __DEFAULT ->
+ case ds of {
+ NotFound -> NotFound;
+ Found a2 a3 -> Found a2 (f1 a3)
+ }
+ }
+
+$fFunctorCheckRes
+ = \ @a -> C:Functor $fFunctorCheckRes_$cfmap $fFunctorCheckRes_$c<$
+
+Rec {
+$w$sgo15
+ = \ @a1 ww ww1 ds ds1 ->
+ case ds of ds2 { __DEFAULT ->
+ case ds1 of {
+ Bin ipv2 ipv3 ipv4 ipv5 ipv6 ->
+ case ds2 of wild1 {
+ Left a2 ->
+ case ipv3 of {
+ Left b2 ->
+ case a2 of { I# x# ->
+ case b2 of { I# y# ->
+ case <# x# y# of {
+ __DEFAULT ->
+ case ==# x# y# of {
+ __DEFAULT ->
+ $w$sgo15
+ (or# (uncheckedShiftRL# ww 1#) 9223372036854775808##)
+ (or# (uncheckedShiftRL# ww1 1#) (uncheckedShiftL# ww 63#))
+ wild1
+ ipv6;
+ 1# ->
+ case ww1 of ds3 {
+ __DEFAULT ->
+ let {
+ hi1 = or# (uncheckedShiftRL# ww 1#) 9223372036854775808## } in
+ let { zeros = word2Int# (ctz# ds3) } in
+ (# Just ipv4, uncheckedShiftRL# hi1 zeros,
+ or#
+ (uncheckedShiftRL#
+ (or# (uncheckedShiftRL# ds3 1#) (uncheckedShiftL# ww 63#))
+ zeros)
+ (uncheckedShiftL# hi1 (-# 64# zeros)) #);
+ 0## ->
+ (# Just ipv4, 0##,
+ uncheckedShiftRL#
+ (or# (uncheckedShiftRL# ww 1#) 9223372036854775808##)
+ (word2Int# (ctz# ww)) #)
+ }
+ };
+ 1# ->
+ $w$sgo15
+ (uncheckedShiftRL# ww 1#)
+ (or# (uncheckedShiftRL# ww1 1#) (uncheckedShiftL# ww 63#))
+ wild1
+ ipv5
+ }
+ }
+ };
+ Right ipv ->
+ $w$sgo15
+ (uncheckedShiftRL# ww 1#)
+ (or# (uncheckedShiftRL# ww1 1#) (uncheckedShiftL# ww 63#))
+ wild1
+ ipv5
+ };
+ Right a2 ->
+ case ipv3 of {
+ Left ipv ->
+ $w$sgo15
+ (or# (uncheckedShiftRL# ww 1#) 9223372036854775808##)
+ (or# (uncheckedShiftRL# ww1 1#) (uncheckedShiftL# ww 63#))
+ wild1
+ ipv6;
+ Right b2 ->
+ case a2 of { C# x ->
+ case b2 of { C# y ->
+ case eqChar# x y of {
+ __DEFAULT ->
+ case leChar# x y of {
+ __DEFAULT ->
+ $w$sgo15
+ (or# (uncheckedShiftRL# ww 1#) 9223372036854775808##)
+ (or# (uncheckedShiftRL# ww1 1#) (uncheckedShiftL# ww 63#))
+ wild1
+ ipv6;
+ 1# ->
+ $w$sgo15
+ (uncheckedShiftRL# ww 1#)
+ (or# (uncheckedShiftRL# ww1 1#) (uncheckedShiftL# ww 63#))
+ wild1
+ ipv5
+ };
+ 1# ->
+ case ww1 of ds3 {
+ __DEFAULT ->
+ let {
+ hi1 = or# (uncheckedShiftRL# ww 1#) 9223372036854775808## } in
+ let { zeros = word2Int# (ctz# ds3) } in
+ (# Just ipv4, uncheckedShiftRL# hi1 zeros,
+ or#
+ (uncheckedShiftRL#
+ (or# (uncheckedShiftRL# ds3 1#) (uncheckedShiftL# ww 63#)) zeros)
+ (uncheckedShiftL# hi1 (-# 64# zeros)) #);
+ 0## ->
+ (# Just ipv4, 0##,
+ uncheckedShiftRL#
+ (or# (uncheckedShiftRL# ww 1#) 9223372036854775808##)
+ (word2Int# (ctz# ww)) #)
+ }
+ }
+ }
+ }
+ }
+ };
+ Tip ->
+ case ww1 of ds3 {
+ __DEFAULT ->
+ let {
+ hi1 = or# (uncheckedShiftRL# ww 1#) 9223372036854775808## } in
+ let { zeros = word2Int# (ctz# ds3) } in
+ (# Nothing, uncheckedShiftRL# hi1 zeros,
+ or#
+ (uncheckedShiftRL#
+ (or# (uncheckedShiftRL# ds3 1#) (uncheckedShiftL# ww 63#)) zeros)
+ (uncheckedShiftL# hi1 (-# 64# zeros)) #);
+ 0## ->
+ (# Nothing, 0##,
+ uncheckedShiftRL#
+ (or# (uncheckedShiftRL# ww 1#) 9223372036854775808##)
+ (word2Int# (ctz# ww)) #)
+ }
+ }
+ }
+end Rec }
+
+$salterF
+ = \ @v @a f1 k1 m ->
+ case $w$sgo15 9223372036854775808## 0## k1 m of
+ { (# ww, ww1, ww2 #) ->
+ case f1 ww of {
+ NotFound -> NotFound;
+ Found a1 a2 ->
+ Found
+ a1
+ (case a2 of {
+ Nothing ->
+ case ww of {
+ Nothing -> m;
+ Just old -> case $wbogus (##) of { __DEFAULT -> $wgo ww1 ww2 m }
+ };
+ Just new ->
+ case new of new1 { __DEFAULT ->
+ case ww of {
+ Nothing -> $winsertAlong ww1 ww2 k1 new1 m;
+ Just ds -> $wreplaceAlong ww1 ww2 new1 m
+ }
+ }
+ })
+ }
+ }
+
+lvl
+ = \ @v ds ->
+ case ds of {
+ Nothing -> NotFound;
+ Just t -> case t of conrep { __DEFAULT -> Found conrep Nothing }
+ }
+
+Rec {
+$wfoo
+ = \ @v x subst ->
+ case $salterF lvl x subst of {
+ NotFound ->
+ case x of wild1 {
+ Left x1 -> $wfoo wild1 subst;
+ Right y ->
+ $wfoo
+ (Right
+ (case y of { C# c# ->
+ let { i# = +# (ord# c#) 1# } in
+ case leWord# (int2Word# i#) 1114111## of {
+ __DEFAULT -> $wlvl i#;
+ 1# -> C# (chr# i#)
+ }
+ }))
+ subst
+ };
+ Found p q -> (# p, q #)
+ }
+end Rec }
+
+foo
+ = \ @v x subst ->
+ case $wfoo x subst of { (# ww, ww1 #) -> Just (ww, ww1) }
+
+$trModule4 = "main"#
+
+$trModule3 = TrNameS $trModule4
+
+$trModule2 = "T22611"#
+
+$trModule1 = TrNameS $trModule2
+
+$trModule = Module $trModule3 $trModule1
+
+$krep = KindRepVar 1#
+
+$krep1 = KindRepVar 0#
+
+$tcCheckRes2 = "CheckRes"#
+
+$tcCheckRes1 = TrNameS $tcCheckRes2
+
+$tcCheckRes
+ = TyCon
+ 2720702776801478797#Word64
+ 9603347784695333983#Word64
+ $trModule
+ $tcCheckRes1
+ 0#
+ krep$*->*->*
+
+$krep2 = : $krep []
+
+$krep3 = : $krep1 $krep2
+
+$tc'NotFound1 = KindRepTyConApp $tcCheckRes $krep3
+
+$tc'NotFound3 = "'NotFound"#
+
+$tc'NotFound2 = TrNameS $tc'NotFound3
+
+$tc'NotFound
+ = TyCon
+ 11874520794839816490#Word64
+ 7404827959462889921#Word64
+ $trModule
+ $tc'NotFound2
+ 2#
+ $tc'NotFound1
+
+$krep4 = KindRepFun $krep $tc'NotFound1
+
+$tc'Found1 = KindRepFun $krep1 $krep4
+
+$tc'Found3 = "'Found"#
+
+$tc'Found2 = TrNameS $tc'Found3
+
+$tc'Found
+ = TyCon
+ 14824125456853884021#Word64
+ 17338070180827954559#Word64
+ $trModule
+ $tc'Found2
+ 2#
+ $tc'Found1
+
+
+------ Local rules for imported ids --------
+"SPEC/T22611 alterF @(CheckRes v) @(Either Int Char) @_" [2]
+ forall @v @a $dFunctor $dOrd. alterF $dFunctor $dOrd = $salterF
+
+
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -468,3 +468,5 @@ test('T22623', normal, multimod_compile, ['T22623', '-O -v0'])
test('T22662', normal, compile, [''])
test('T22725', normal, compile, ['-O'])
test('T22502', normal, compile, ['-O'])
+test('T22611', [when(wordsize(32), skip), grep_errmsg(r'\$salterF') ], compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-all'])
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8c7a991c8190c57977d876309c29bfbf046081dd
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8c7a991c8190c57977d876309c29bfbf046081dd
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230116/3c87f9a4/attachment-0001.html>
More information about the ghc-commits
mailing list