[Git][ghc/ghc][wip/andreask/infer_bottom] TagAnalysis: Treat all bottom ids as tagged during analysis.
Andreas Klebinger (@AndreasK)
gitlab at gitlab.haskell.org
Thu May 16 12:54:14 UTC 2024
Andreas Klebinger pushed to branch wip/andreask/infer_bottom at Glasgow Haskell Compiler / GHC
Commits:
2746307d by Andreas Klebinger at 2024-05-16T14:38:39+02:00
TagAnalysis: Treat all bottom ids as tagged during analysis.
Ticket #24806 showed that we also need to treat dead end thunks as
tagged during the analysis.
- - - - -
5 changed files:
- compiler/GHC/Stg/InferTags.hs
- compiler/GHC/Stg/InferTags/Rewrite.hs
- + testsuite/tests/simplStg/should_compile/T24806.hs
- + testsuite/tests/simplStg/should_compile/T24806.stderr
- testsuite/tests/simplStg/should_compile/all.T
Changes:
=====================================
compiler/GHC/Stg/InferTags.hs
=====================================
@@ -30,6 +30,7 @@ import GHC.Types.Name.Env (mkNameEnv, NameEnv)
import GHC.Driver.DynFlags
import GHC.Utils.Logger
import qualified GHC.Unit.Types
+import qualified Data.Type.Bool as else
{- Note [Tag Inference]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -301,12 +302,14 @@ inferTagExpr env (StgApp fun args)
(info, StgApp fun args)
where
!fun_arity = idArity fun
- info | fun_arity == 0 -- Unknown arity => Thunk or unknown call
- = TagDunno
+ info
+ -- It's important that we check for bottoms before all else.
+ -- See Note [Bottom functions are TagTagged] and #24806 for why.
+ | isDeadEndAppSig (idDmdSig fn) (length args)
+ = TagTagged
- | isDeadEndId fun
- , fun_arity == length args -- Implies we will simply call the function.
- = TagTagged -- See Note [Bottom functions are TagTagged]
+ | fun_arity == 0 -- Unknown arity => Thunk or unknown call
+ = TagDunno
| Just (TagSig res_info) <- tagSigInfo (idInfo fun)
, fun_arity == length args -- Saturated
@@ -500,6 +503,11 @@ it safely any tag sig we like.
So we give it TagTagged, as it allows the combined tag sig of the case expression
to be the combination of all non-bottoming branches.
+NB: After the analysis is done we go back to treating bottoming functions as
+untagged to ensure they are evaluated as expected in code like:
+
+ case bottom_id of { ...}
+
-}
-----------------------------
=====================================
compiler/GHC/Stg/InferTags/Rewrite.hs
=====================================
@@ -241,7 +241,10 @@ indicates a bug in the tag inference implementation.
For this reason we assert that we are running in interactive mode if a lookup fails.
-}
isTagged :: Id -> RM Bool
-isTagged v = do
+isTagged v
+ -- See Note [Bottom functions are TagTagged]
+ | isDeadEndId v = pure False
+ | otherwise = do
this_mod <- getMod
-- See Note [Tag inference for interactive contexts]
let lookupDefault v = assertPpr (isInteractiveModule this_mod)
=====================================
testsuite/tests/simplStg/should_compile/T24806.hs
=====================================
@@ -0,0 +1,19 @@
+module T24806 ( go ) where
+
+data List a = Nil | Cons a !(List a) -- deriving Show
+
+data Tup2 a b = Tup2 !a !b
+
+-- All branches of go return either two properly tagged values *or* are bottom.
+-- This means we should see something like:
+--
+-- (T24806.$wgo, <TagTuple[TagProper, TagProper]>) =
+--
+-- in the dump output.
+-- See Note [Bottom functions are TagTagged] for details why.
+go :: List a1 -> List a2 -> Tup2 (List a2) (List a2)
+go Nil ys = Tup2 ys Nil
+go (Cons _ xs) ys = case ys of
+ Nil -> undefined
+ Cons y ys' -> case go xs ys' of
+ Tup2 s zs -> Tup2 s (Cons y zs)
\ No newline at end of file
=====================================
testsuite/tests/simplStg/should_compile/T24806.stderr
=====================================
@@ -0,0 +1,99 @@
+
+==================== CodeGenAnal STG: ====================
+lvl6 :: GHC.Prim.Addr#
+[GblId, Unf=OtherCon []] =
+ "T24806.hs"#;
+
+lvl4 :: GHC.Prim.Addr#
+[GblId, Unf=OtherCon []] =
+ "T24806"#;
+
+lvl2 :: GHC.Prim.Addr#
+[GblId, Unf=OtherCon []] =
+ "main"#;
+
+lvl :: GHC.Prim.Addr#
+[GblId, Unf=OtherCon []] =
+ "undefined"#;
+
+(T24806.$WTup2, <TagProper>) =
+ {} \r [(conrep, <TagDunno>) (conrep1, <TagDunno>)]
+ case conrep of (conrep2, <TagProper>) {
+ __DEFAULT ->
+ case conrep1 of (conrep3, <TagProper>) {
+ __DEFAULT -> T24806.Tup2 [conrep2 conrep3];
+ };
+ };
+
+(T24806.$WCons, <TagProper>) =
+ {} \r [(conrep, <TagDunno>) (conrep1, <TagDunno>)]
+ case conrep1 of (conrep2, <TagProper>) {
+ __DEFAULT -> T24806.Cons [conrep conrep2];
+ };
+
+(lvl1, <TagDunno>) = {} \u [] GHC.CString.unpackCString# lvl;
+
+(lvl3, <TagDunno>) = {} \u [] GHC.CString.unpackCString# lvl2;
+
+(lvl5, <TagDunno>) = {} \u [] GHC.CString.unpackCString# lvl4;
+
+(lvl7, <TagDunno>) = {} \u [] GHC.CString.unpackCString# lvl6;
+
+(lvl8, <TagProper>) = GHC.Types.I#! [17#];
+
+(lvl9, <TagProper>) = GHC.Types.I#! [12#];
+
+(lvl10, <TagProper>) = GHC.Types.I#! [21#];
+
+(lvl11, <TagProper>) =
+ GHC.Internal.Stack.Types.SrcLoc! [lvl3
+ lvl5
+ lvl7
+ lvl8
+ lvl9
+ lvl8
+ lvl10];
+
+(lvl12, <TagProper>) =
+ GHC.Internal.Stack.Types.PushCallStack! [lvl1
+ lvl11
+ GHC.Internal.Stack.Types.EmptyCallStack];
+
+(lvl13, <TagDunno>) = {} \u [] GHC.Internal.Err.undefined lvl12;
+
+(T24806.Tup2, <TagDunno>) =
+ {} \r [(eta, <TagDunno>) (eta, <TagDunno>)] T24806.Tup2 [eta eta];
+
+(T24806.Nil, <TagProper>) = T24806.Nil! [];
+
+Rec {
+(T24806.$wgo, <TagTuple[TagProper, TagProper]>) =
+ {} \r [(ds, <TagProper>) (ys, <TagProper>)]
+ case ds of (wild, <TagProper>) {
+ T24806.Nil ->
+ case ys of (conrep, <TagProper>) {
+ __DEFAULT -> (#,#) [conrep T24806.Nil];
+ };
+ T24806.Cons (ds1, <TagDunno>) (xs, <TagProper>) ->
+ case ys of (wild1, <TagProper>) {
+ T24806.Nil -> lvl13;
+ T24806.Cons (y, <TagDunno>) (ys', <TagProper>) ->
+ case T24806.$wgo xs ys' of (wild2, <TagProper>) {
+ (#,#) (ww, <TagProper>) (ww1, <TagProper>) ->
+ let { (sat, <TagProper>) = T24806.Cons! [y ww1];
+ } in (#,#) [ww sat];
+ };
+ };
+ };
+end Rec }
+
+(T24806.go, <TagProper>) =
+ {} \r [(ds, <TagDunno>) (ys, <TagDunno>)]
+ case T24806.$wgo ds ys of (wild, <TagProper>) {
+ (#,#) (ww, <TagProper>) (ww1, <TagProper>) -> T24806.Tup2 [ww ww1];
+ };
+
+(T24806.Cons, <TagDunno>) =
+ {} \r [(eta, <TagDunno>) (eta, <TagDunno>)] T24806.Cons [eta eta];
+
+
=====================================
testsuite/tests/simplStg/should_compile/all.T
=====================================
@@ -23,3 +23,5 @@ test('inferTags003', [ only_ways(['optasm']),
grep_errmsg(r'(call stg\_ap\_0)', [1])
], compile, ['-ddump-cmm -dno-typeable-binds -O'])
test('inferTags004', normal, compile, ['-O -ddump-stg-tags -dno-typeable-binds -dsuppress-uniques'])
+
+test('T24806', grep_errmsg('^\\(T24806\\.\\$wgo'), compile, ['-O -ddump-stg-tags -dno-typeable-binds -dsuppress-uniques'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2746307d5594f6602c70cdf70730c6a3ef7c1ead
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2746307d5594f6602c70cdf70730c6a3ef7c1ead
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/20240516/3f497d13/attachment-0001.html>
More information about the ghc-commits
mailing list