Andreas Klebinger pushed to branch wip/apk/tag-strict-bot at Glasgow Haskell Compiler / GHC Commits: 6a80ad60 by Andreas Klebinger at 2026-10-06T12:54:02+00:00 Fix a few tag inference bugs. * Treat bottoming functions and nullary join points as functions. * When generating bytecode don't rely on imported tag sigs. Fixes #27831, #27841 and #27842. - - - - - 23 changed files: - + changelog.d/T27831-bottoming-strict-field - + changelog.d/T27842-bytecode-imported-tags - compiler/GHC/Stg/EnforceEpt.hs - compiler/GHC/Stg/EnforceEpt/Rewrite.hs - compiler/GHC/Stg/EnforceEpt/Types.hs - + testsuite/tests/bytecode/T27842.hs - + testsuite/tests/bytecode/T27842.stdout - + testsuite/tests/bytecode/T27842A.hs - + testsuite/tests/bytecode/T27842N.hs - testsuite/tests/bytecode/all.T - testsuite/tests/simplStg/should_compile/all.T - + testsuite/tests/simplStg/should_compile/inferTags005.hs - + testsuite/tests/simplStg/should_compile/inferTags005.stderr - + testsuite/tests/simplStg/should_compile/inferTags006.hs - + testsuite/tests/simplStg/should_compile/inferTags006.stderr - + testsuite/tests/simplStg/should_run/InferTags007_A.hs - + testsuite/tests/simplStg/should_run/T27831.hs - + testsuite/tests/simplStg/should_run/T27831.stdout - + testsuite/tests/simplStg/should_run/T27857.hs - + testsuite/tests/simplStg/should_run/T27857.stdout - testsuite/tests/simplStg/should_run/all.T - + testsuite/tests/simplStg/should_run/inferTags007.hs - + testsuite/tests/simplStg/should_run/inferTags007.stdout Changes: ===================================== changelog.d/T27831-bottoming-strict-field ===================================== @@ -0,0 +1,8 @@ +section: compiler +issues: #27831 +mrs: !16719 +synopsis: + Fix a segfault that could occur when a bottoming function was stored in a strict field. +description: + This was happening when a function that always diverges (e.g. ``\_ -> error "..."``) was stored in a strict field, and the constructor was pattern matched on + in "nearby" code where the structure of the constructor application was still visible to GHC. ===================================== changelog.d/T27842-bytecode-imported-tags ===================================== @@ -0,0 +1,6 @@ +section: bytecode +issues: #27842 +mrs: !16719 +synopsis: + Fix a segfault caused by reusing interface files generated with + ``-fbyte-code-and-object-code`` for interpreter sessions using ``-fprefer-byte-code``. ===================================== compiler/GHC/Stg/EnforceEpt.hs ===================================== @@ -334,9 +334,15 @@ a) Tags for let-bindings: b) When referencing ids from other modules the Cmm backend will try to put a proper tag on these references through various means. When doing analysis we usually predict these cases to improve precision of the analysis. - But to my knowledge the bytecode generator makes no such attempts so we must - not infer imported bindings as tagged. - This is handled in GHC.Stg.EnforceEpt.Types.lookupInfo + The bytecode generator gives fewer guarantees about what it tags. + So we simply assume it fails to tag binders, even in the cases where it does. + + This is handled in GHC.Stg.EnforceEpt.Types.argTagInfo + + Eventually we will want to update the Analysis and bco code gen to uphold and + take advantage of tag inference at least to some degree. But for now it's + not a perf benefit for interpreted code, and essentially only run to uphold + the "strict field invariant"/EPT Invariant described in EPT enforcement. -} @@ -359,7 +365,7 @@ enforceEpt ppr_opts !for_bytecode logger this_mod stg_binds = do -- Rewrite STG to uphold the strict field invariant us_t <- mkSplitUniqSupply StgTag - let rewritten_binds = {-# SCC "StgEptRewrite" #-} rewriteTopBinds this_mod us_t stg_binds_w_tags :: [TgStgTopBinding] + let rewritten_binds = {-# SCC "StgEptRewrite" #-} rewriteTopBinds for_bytecode this_mod us_t stg_binds_w_tags :: [TgStgTopBinding] return (rewritten_binds,export_tag_info) @@ -414,12 +420,14 @@ inferTagExpr env (StgApp fun args) | isDeadEndAppSig (idDmdSig fun) (length args) = TagBottoming - | fun_arity == 0 -- Unknown arity => Thunk or unknown call + | not (isJoinId fun) -- zero arity join ids behave like functions NOT thunks. + , fun_arity == 0 -- Unknown arity => Thunk or unknown call = TagDunno -- Imported function with known return tag | Just (TagFun res_info) <- tagSigInfo (idInfo fun) , fun_arity == length args -- Saturated + , not (te_bytecode env) -- #27842 = res_info -- Local function with known return tag @@ -593,7 +601,7 @@ initSig (bndr, StgRhsClosure _ _ _ bndrs _ _) {- Note [Bottom functions are TagBottoming] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have a function with two branches with one +If we have a function with two branches with one branch being bottom, and the other returning a tagged unboxed tuple what is the result? We give it TagBottoming! To answer why consider this function: @@ -603,21 +611,40 @@ foo x = case x of True -> (# True,True #) False -> undefined -The true branch is obviously tagged. The other branch isn't. -We want to treat the *result* of foo as tagged as well so that -the combination of the branches also is tagged if all non-bottom -branches are tagged. -This is safe because the function is still always called/entered as long -as it's applied to arguments. Since the function will never return we can give -it safely any tag sig we like. -So we give it TagBottoming, as it allows the combined tag sig of the case expression -to be the combination of all non-bottoming branches. +The true branch obviously returns tagged components. The other branch is bottom. +We want to treat the components in the *result* returned by foo as tagged. +Because at a call site like: + + case foo e of + (# x, y #) -> + case x of + ... + +Either `foo` will have evaluated undefined or blown up. Or we will bind x and y +to tagged pointers. A fact we take advantage of to optimize `case x of`. + +The rule is then simple. A combination of the alternatives of the same case has +tagged components if all non-bottom branches have tagged components. + +To represent the bottoming alternatives we use TagBottoming. Which says all it's +components are tagged. Now the same is true if we have: + +foo :: Bool -> (# Bool, Bool #) +foo x = case x of + True -> (# True,True #) + False -> willCrash x + +Where we want to check: -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: +* Is `willCrash x` bottom? +* If it is not are the returned components tagged? - case bottom_id of { ...} +For the first question we have to be careful about the notion of bottom we use. +I've got this wrong in the past, because a underapplied bottoming function will +return a *function* as result. Rather than being bottom. +If the function *is* bottom then we treat it the same we do undefined above. And +use TagBottoming as the tagInfo of the expression. Hence the title of the Note. -} ----------------------------- ===================================== compiler/GHC/Stg/EnforceEpt/Rewrite.hs ===================================== @@ -3,6 +3,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedTuples #-} module GHC.Stg.EnforceEpt.Rewrite (rewriteTopBinds, rewriteOpApp) where @@ -13,7 +14,7 @@ import GHC.Builtin.PrimOps ( PrimOp(..) ) import GHC.Types.Basic ( CbvMark (..), isMarkedCbv , TopLevelFlag(..), isTopLevel ) import GHC.Types.Id -import GHC.Types.Name +import GHC.Types.Name ( nameIsLocalOrFrom ) import GHC.Types.Unique.Supply import GHC.Types.Unique.FM import GHC.Types.RepType @@ -22,10 +23,7 @@ import GHC.Unit.Types import GHC.Core.DataCon import GHC.Core ( AltCon(..) ) -import GHC.Core.Type - -import GHC.StgToCmm.Types -import GHC.StgToCmm.Closure (importedIdLFInfo) +import GHC.Core.Type ( definitelyLiftedType ) import GHC.Stg.Utils import GHC.Stg.Syntax as StgSyn @@ -40,9 +38,39 @@ import GHC.Utils.Misc import GHC.Stg.EnforceEpt.Types import Control.Monad - -newtype RM a = RM { unRM :: (State (UniqFM Id TagSig, UniqSupply, Module, IdSet) a) } - deriving (Functor, Monad, Applicative) +import GHC.Exts (oneShot) + +data RmContext = RmContext { rm_mod :: !Module, rm_interpreter :: !Bool } + +data RmState = RmState { rm_us :: !UniqSupply, rm_fvs :: IdSet, rm_sig_env :: !(UniqFM Id TagSig)} +newtype RM a = RM { unRM :: RmContext -> RmState -> (# RmState, a #) } + +instance Functor RM where + fmap f (RM x) = RM $ \env -> oneShot $ \state -> + let (# s1, x' #) = x env state + in (# s1, f x' #) + +instance Applicative RM where + (RM f) <*> (RM x) = RM $ oneShot $ \env -> oneShot $ \state -> + let (# s1,!f' #) = f env state + (# s2, x' #) = x env s1 + in (# s2, f' x' #) + pure x = RM $ \_ s -> (# s, x #) + +-- See Note [The one-shot state monad trick] in GHC.Utils.Monad +instance Monad RM where + RM x >>= f = RM $ oneShot $ \env -> oneShot $ \state -> + let (# s1, x' #) = x env state + in case (f x') of RM r -> r env s1 + +-- | runRM this_mod for_bytecode us fvs tag_env +runRM :: Module -> Bool -> UniqSupply -> RM a -> a +runRM mod for_bytecode us act = + case (unRM act) + (RmContext { rm_mod = mod, rm_interpreter = for_bytecode }) + (RmState { rm_us = us, rm_fvs = emptyVarSet, rm_sig_env = emptyUFM }) + of + (# _, r #) -> r ------------------------------------------------------------ -- Add cases around strict fields where required. @@ -107,30 +135,29 @@ when building the free variable list. -------------------------------- instance MonadUnique RM where - getUniqueSupplyM = RM $ do - (m, us, mod,lcls) <- get - let (us1, us2) = splitUniqSupply us - (put) (m,us2,mod,lcls) - return us1 + getUniqueSupplyM = RM $ \_ s -> + case splitUniqSupply (rm_us s) of + (us1, us2) -> (# s { rm_us = us2 }, us1 #) getMap :: RM (UniqFM Id TagSig) -getMap = RM $ ((\(fst,_,_,_) -> fst) <$> get) +getMap = RM $ \_ s -> (# s, rm_sig_env s #) setMap :: (UniqFM Id TagSig) -> RM () -setMap !m = RM $ do - (_,us,mod,lcls) <- get - put (m, us,mod,lcls) - -getMod :: RM Module -getMod = RM $ ( (\(_,_,thrd,_) -> thrd) <$> get) +setMap !m = RM $ \_ s -> (# s { rm_sig_env = m }, () #) getFVs :: RM IdSet -getFVs = RM $ ((\(_,_,_,lcls) -> lcls) <$> get) +getFVs = RM $ \_ s -> (# s, rm_fvs s #) setFVs :: IdSet -> RM () -setFVs !fvs = RM $ do - (tag_map,us,mod,_lcls) <- get - put (tag_map, us,mod,fvs) +setFVs !fvs = RM $ \_ s -> (# s { rm_fvs = fvs }, () #) + +getMod :: RM Module +getMod = RM $ \env s -> (# s, rm_mod env #) + +-- | When generating bytecode certain bindings might be untagged. So we have to +-- have a way to check for that. +getForBytecode :: RM Bool +getForBytecode = RM $ \env s -> (# s, rm_interpreter env #) -- Rewrite the RHS(s) while making the id and it's sig available -- to determine if things are tagged/need to be captured as FV. @@ -238,51 +265,26 @@ 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 - -- See Note [Bottom functions are TagBottoming] - | isDeadEndId v = pure False - | otherwise = do +isTagged v = do + for_bytecode <- getForBytecode this_mod <- getMod - -- See Note [Tag inference for interactive contexts] - let lookupDefault v = assertPpr (isInteractiveModule this_mod) - (text "unknown Id:" <> ppr this_mod <+> ppr v) - (TagVal TagDunno) - case nameIsLocalOrFrom this_mod (idName v) of - True - | definitelyUnliftedType (idType v) - -- NB: v might be the Id of a representation-polymorphic join point, - -- so we shouldn't use isUnliftedType here. See T22212. - -> return True - | otherwise -> do -- Local binding - !s <- getMap - let !sig = lookupWithDefaultUFM s (lookupDefault v) v - return $ case sig of - TagFun _ -> True -- function closure is tagged - TagVal TagDunno -> False - TagVal TagEPT -> True - TagVal TagBottoming -> True - TagVal (TagTuple _) -> True -- Consider unboxed tuples tagged. - -- Imported - False -> return $! - -- Determine whether it is tagged from the LFInfo of the imported id. - -- See Note [The LFInfo of Imported Ids] - case importedIdLFInfo v of - -- Function, applied not entered. - LFReEntrant {} - -> True - -- Thunks need to be entered. - LFThunk {} - -> False - -- LFCon means we already know the tag, and it's tagged. - LFCon {} - -> True - LFUnknown {} - -> False - LFUnlifted {} -- Unboxed, tagging irrelevant - -> True - LFLetNoEscape {} - -- Shouldn't be possible. I don't think we can export letNoEscapes - -> True + s <- getMap + let get_env_sig = lookupUFM s + massertPpr + -- Assert the env is complete for local lifted binders, which means either + -- - The binder is present in the env + -- - The binder is not a local lifted binder *or* comes from a ghci context + (isJust (get_env_sig v) + -- See Note [Tag inference for interactive contexts] + || isInteractiveModule this_mod + || not (nameIsLocalOrFrom this_mod (idName v)) + || not (definitelyLiftedType (idType v))) + (text "unknown Id:" <> ppr this_mod <+> ppr v) + -- TODO: We could refactor the whole pass such that we also set id_tagSig + -- for every imported id. But this likely comes with a heavy allocation + -- overhead so for now we just ensure to use the same logic across analysis + -- and rewriter. + pure $! isTaggedInfo $ argTagInfo for_bytecode (get_env_sig v) (StgVarArg v) isArgTagged :: StgArg -> RM Bool @@ -299,11 +301,10 @@ mkLocalArgId id = do --------------------------- -rewriteTopBinds :: Module -> UniqSupply -> [GenStgTopBinding 'InferTaggedBinders] -> [TgStgTopBinding] -rewriteTopBinds mod us binds = - let doBinds = mapM rewriteTop binds - - in evalState (unRM doBinds) (mempty, us, mod, mempty) +rewriteTopBinds :: Bool -- ^ Generating bytecode? + -> Module -> UniqSupply -> [GenStgTopBinding 'InferTaggedBinders] -> [TgStgTopBinding] +rewriteTopBinds for_bytecode mod us binds = + runRM mod for_bytecode us (mapM rewriteTop binds) rewriteTop :: InferStgTopBinding -> RM TgStgTopBinding rewriteTop (StgTopStringLit v s) = return $! (StgTopStringLit v s) ===================================== compiler/GHC/Stg/EnforceEpt/Types.hs ===================================== @@ -12,7 +12,7 @@ where import GHC.Prelude import GHC.Core.DataCon -import GHC.Core.Type (isUnliftedType) +import GHC.Core.Type (isUnliftedType, definitelyUnliftedType) import GHC.Types.Id import GHC.Stg.Syntax import GHC.Stg.EnforceEpt.TagSig as TagSig @@ -22,6 +22,7 @@ import GHC.Utils.Misc( zipWithEqual ) import GHC.Utils.Panic import GHC.StgToCmm.Types +import GHC.StgToCmm.Closure (importedIdLFInfo) {- ********************************************************************* * * @@ -97,31 +98,40 @@ lookupReturnInfo env fun = case lookupVarEnv (te_env env) fun of Just (TagVal _) -> Nothing Nothing -> Nothing --- | Look up a value-level tag for an argument: either from the env (where --- a function-typed argument flattens to TagEPT — its closure is tagged) --- or derived from information on the variable itself. -lookupInfo :: TagEnv p -> StgArg -> TagInfo -lookupInfo env (StgVarArg var) +-- | Look up a value-level tag. +-- +-- If the tag info is completely determined by Id info we use that tag. +-- If the tag info is dependent on the analysis/call site use the passed TagSig. +-- If the passed TagSig is Nothing we fall back to safe tag info based on id properties. +argTagInfo :: Bool -> (Maybe TagSig) -> StgArg -> TagInfo +{-# INLINE argTagInfo #-} -- Specialize for the call site. +argTagInfo _for_bytecode _env_sig (StgLitArg{}) = TagEPT +argTagInfo for_bytecode env_sig (StgVarArg var) -- Nullary data constructors like True, False | Just dc <- isDataConWorkId_maybe var , isNullaryRepDataCon dc , not for_bytecode = TagEPT - | isUnliftedType (idType var) + -- NB: v might be the Id of a representation-polymorphic join point, + -- so we shouldn't use isUnliftedType here. See T22212. + | definitelyUnliftedType (idType var) = TagEPT -- Variables in the environment. A function binding flattens to TagEPT -- since a function closure pointer is properly tagged; its return info -- is not relevant when the function is used as a value. - | Just sig <- lookupVarEnv (te_env env) var + | Just sig <- env_sig = case sig of TagVal info -> info TagFun _ -> TagEPT - | Just lf_info <- idLFInfo_maybe var - , not for_bytecode - = case lf_info of +-- Always save defaults. + | lf_info <- importedIdLFInfo var -- will make up LFInfo if not present. + = if for_bytecode + then TagDunno -- See Note [EPT enforcement for interpreted code] in GHC.Stg.EnforceEpt + else + case lf_info of -- Function, tagged (with arity) LFReEntrant {} -> TagEPT @@ -138,13 +148,12 @@ lookupInfo env (StgVarArg var) -- Shouldn't be possible. I don't think we can export letNoEscapes LFLetNoEscape {} -> panic "LFLetNoEscape exported" - | otherwise - = TagDunno - where - for_bytecode = te_bytecode env - -lookupInfo _ (StgLitArg {}) - = TagEPT +-- | Get tag info using the environment. +lookupInfo :: TagEnv p -> StgArg -> TagInfo +lookupInfo env arg@(StgVarArg var) = + let env_sig = (lookupVarEnv (te_env env) var) + in argTagInfo (te_bytecode env) env_sig arg +lookupInfo _env (StgLitArg{}) = TagEPT isDunnoSig :: TagSig -> Bool isDunnoSig (TagVal TagDunno) = True ===================================== testsuite/tests/bytecode/T27842.hs ===================================== @@ -0,0 +1,42 @@ +{-# LANGUAGE UnboxedTuples #-} +{-# OPTIONS_GHC -fno-worker-wrapper -fno-cpr-anal #-} +-- Regression test for #27842. +-- +-- The basic rundown is this: +-- We produce one interface file, however we store information dependent on the +-- code generation method in the interface file. +-- +-- We happen to pick the native code information to store in the interface file. +-- +-- When we compile a module M this way, and then generate byte code for code +-- depending on M based on M.hi we will assume certain exported definitions are EPT +-- tagged, despite the interpreter doing no such thing. +-- +-- This then led to crashes in the interpreter. +-- +-- We test three kinds of imported definitions: +-- * mk uses fun, a function whose TagSig says its result is tagged. +-- * bar uses just_con, a value whose LFInfo says it is a constructor. +-- * baz uses gt_con, the same for a nullary constructor. +module Main where + +import T27842A (fun, just_con, gt_con) +import T27842N (S(..), use_S, M(..), use_M, N(..), use_N) + +mk :: Int -> S +mk x = case fun x of (# xs, _ #) -> S xs +{-# NOINLINE mk #-} + +bar :: M +bar = M just_con +{-# NOINLINE bar #-} + +baz :: N +baz = N gt_con +{-# NOINLINE baz #-} + +main :: IO () +main = do + print (use_S (mk 42)) + print (use_M bar) + print (use_N baz) ===================================== testsuite/tests/bytecode/T27842.stdout ===================================== @@ -0,0 +1,3 @@ +42 +42 +3 ===================================== testsuite/tests/bytecode/T27842A.hs ===================================== @@ -0,0 +1,19 @@ +{-# LANGUAGE UnboxedTuples #-} +{-# OPTIONS_GHC -fno-worker-wrapper -fno-cpr-anal #-} +module T27842A (fun, just_con, gt_con) where + +-- The native EPT run gives fun the TagSig TagFun[TagTuple[TagEPT, TagDunno]]: +fun :: Int -> (# [Int], Int #) +fun x = let xs = x : xs in (# xs, x #) +{-# NOINLINE fun #-} + +-- In native code a static constructor, in bytecode an unevaluated closure. +just_con :: Maybe Int +just_con = Just 42 +{-# NOINLINE just_con #-} + +-- The same for a nullary constructor. Without its pointer tag, the object code +-- in T27842N would take the LT alternative, so GT shows the difference. +gt_con :: Ordering +gt_con = GT +{-# NOINLINE gt_con #-} ===================================== testsuite/tests/bytecode/T27842N.hs ===================================== @@ -0,0 +1,26 @@ +{-# OPTIONS_GHC -fno-byte-code-and-object-code #-} +-- We compile this module as native code, depending on A's interface file. +-- A itself is loaded into GHCi, despite it's interface file being generated based +-- on native code generation. +module T27842N (S(..), use_S, M(..), use_M, N(..), use_N) where + +data S = S ![Int] + +-- We take apart the strict constructor value and branch on the value in its field. +-- If the field content is not EPT this causes undefined behaviour. + +use_S :: S -> Int +use_S (S xs) = case xs of { (y:_) -> y; [] -> -1 } +{-# NOINLINE use_S #-} + +data M = M !(Maybe Int) + +use_M :: M -> Int +use_M (M m) = case m of { Just x -> x; Nothing -> -1 } +{-# NOINLINE use_M #-} + +data N = N !Ordering + +use_N :: N -> Int +use_N (N o) = case o of { LT -> 1; EQ -> 2; GT -> 3 } +{-# NOINLINE use_N #-} ===================================== testsuite/tests/bytecode/all.T ===================================== @@ -17,3 +17,12 @@ test('T26216', extra_files(["T26216_aux.hs"]), ghci_script, ['T26216.script']) test('T27001', [extra_files(['T27001.hs']), req_interp], run_command, ['{compiler} -e main -O -fno-unoptimized-core-for-interpreter T27001.hs']) + +# Bytecode must not trust tag information from imported interfaces, which +# comes from native code (#27842): neither the TagSig of an imported function +# nor the LFInfo of an imported value (with and without constructor fields). +test('T27842', [extra_files(['T27842A.hs', 'T27842N.hs']), req_interp], + run_command, + ['{compiler} -e main -O -fno-unoptimized-core-for-interpreter ' + '-fobject-code -fbyte-code-and-object-code -fwrite-byte-code -fprefer-byte-code ' + 'T27842.hs']) ===================================== testsuite/tests/simplStg/should_compile/all.T ===================================== @@ -25,5 +25,17 @@ test('inferTags003', [ only_ways(['optasm']), ], compile, ['-ddump-cmm -dno-typeable-binds -O']) test('inferTags004', normal, compile, ['-O -ddump-stg-tags -dno-typeable-binds -dsuppress-uniques']) test('T27005b', normal, compile, ['-O -ddump-stg-tags -dno-typeable-binds -dsuppress-uniques']) +# Both f and the join point j should have a signature TagTuple[TagEPT, TagEPT] +test('inferTags005', + grep_errmsg(r'(TagTuple\[TagEPT, TagEPT\])', [1]), + compile, + ['-O -fno-worker-wrapper -fno-cpr-anal -ddump-stg-tags ' + '-dno-typeable-binds -dsuppress-uniques']) +# The function needs to have a signature TagTuple[TagEPT, TagEPT] +test('inferTags006', + grep_errmsg(r'(TagTuple\[TagEPT, TagEPT\])', [1]), + compile, + ['-O -fno-worker-wrapper -fno-cpr-anal -fno-full-laziness -ddump-stg-tags ' + '-dno-typeable-binds -dsuppress-uniques']) test('T24806', grep_errmsg('^\\(T24806\\.\\$wgo'), compile, ['-O -ddump-stg-tags -dno-typeable-binds -dsuppress-uniques']) ===================================== testsuite/tests/simplStg/should_compile/inferTags005.hs ===================================== @@ -0,0 +1,39 @@ +{-# LANGUAGE UnboxedTuples #-} +module EnforceEpt005 where + +-- If we have +-- f x y = +-- join j = +-- <rhs> -- <TagTuple[TagEPT, TagEPT]]> +-- in case x of +-- 1 -> j +-- 2 -> j +-- _ -> +-- <something> -- <TagTuple[TagEPT, TagEPT]]> + +-- Consider the case where rhs and something both represent a tag value of <TagTuple[TagEPT, TagEPT]]> +-- In this case we want `f` to also give rise to TagFun [TagTuple[TagEPT, TagEPT]]] + +-- To achieve this we have to recognize j as a zero-arity function equivalent +-- which is what this test checks. + +-- The payoff is in `g` `r` is then known to be tagged, so `S r` needs no eval. +-- Only an unboxed tuple result exposes this. + +-- We disable worker/wrapper and CPR so `f` matches more closely the tests source. + +data T = A Int Int Int Int Int Int | B + +f :: Int -> Int -> (# T, T #) +f x y = case x of + 0 -> j + 1 -> j + _ -> (# B, B #) + where + j = (# A (y+1) (y*2) (y-3) (y*y) (y+x) (y*x), B #) +{-# NOINLINE f #-} + +data S = S !T + +g :: Int -> Int -> S +g x y = case f x y of (# r, _ #) -> S r ===================================== testsuite/tests/simplStg/should_compile/inferTags005.stderr ===================================== @@ -0,0 +1,2 @@ +TagTuple[TagEPT, TagEPT] +TagTuple[TagEPT, TagEPT] ===================================== testsuite/tests/simplStg/should_compile/inferTags006.hs ===================================== @@ -0,0 +1,31 @@ +{-# LANGUAGE UnboxedTuples #-} +module EnforceEpt006 where + +-- If we have +-- f x y = +-- join j = +-- <rhs> -- TagBottoming +-- in case x of +-- 1 -> j +-- 2 -> j +-- _ -> +-- <something> -- <TagTuple[TagEPT, TagEPT]]> + +-- Similar to inferTage005 we want to give `f` the signature: TagFun <TagTuple[TagEPT, TagEPT]]> +-- This requires us to give `j` a `TagFun[TagBottoming]` signature, which is safe because +-- either its execution will diverge, or the resulting tuple *will* have two +-- tagged values. + +data T = A Int Int Int Int Int Int | B + +f :: Int -> Int -> (# T, T #) +-- This case-of-case is just here to be optimized into a nullary join point. +f x y = case (case x of { 0 -> False; 1 -> False; _ -> True }) of + False -> error ("f: bad input " ++ show x ++ " " ++ show y ++ " " ++ show (x*y)) + True -> (# A (y+1) (y*2) (y-3) (y*y) (y+x) (y*x), B #) +{-# NOINLINE f #-} + +data S = S !T + +g :: Int -> Int -> S +g x y = case f x y of (# r, _ #) -> S r ===================================== testsuite/tests/simplStg/should_compile/inferTags006.stderr ===================================== @@ -0,0 +1 @@ +TagTuple[TagEPT, TagEPT] ===================================== testsuite/tests/simplStg/should_run/InferTags007_A.hs ===================================== @@ -0,0 +1,20 @@ +-- We suppress arity and LfInfo with the option. +{-# OPTIONS_GHC -fomit-interface-pragmas #-} +module InferTags007_A (fun, caf, bot, con) where + +fun :: Int -> Int +fun x = x + 1 +{-# NOINLINE fun #-} + +-- A CAF/thunk +caf :: [Int] +caf = map (* 2) [1 .. 10] +{-# NOINLINE caf #-} + +bot :: Int -> Int +bot _ = error "bot called" +{-# NOINLINE bot #-} + +con :: Maybe Int +con = Just 42 +{-# NOINLINE con #-} ===================================== testsuite/tests/simplStg/should_run/T27831.hs ===================================== @@ -0,0 +1,35 @@ +-- Regression test for #27831: a bottoming function stored in a strict +-- constructor field. +-- +-- Different parts of the tag inference machinery didn't agree on weither or not +-- a bottoming function should be treated as a EPT value, leading to a segfault. +module Main (main) where + +import Control.Exception +import GHC.Exts.Heap (GenClosure(..), getClosureData) +import System.Exit + +data T = MkT Int !(Int -> Int) + +t :: T +t = MkT 1 (\_ -> error "T27831") +{-# NOINLINE t #-} + +f :: () -> T +f _ = t +{-# OPAQUE f #-} + +main :: IO () +main = do + c <- getClosureData t + case c of + ThunkClosure{} -> putStrLn "FAIL: ThunkClosure" >> exitFailure + APClosure{} -> putStrLn "FAIL: APClosure" >> exitFailure + _ -> putStrLn "OK: not a thunk" + + case f () of MkT n _ -> print n + + r <- try (evaluate (case t of MkT _ g -> g 1)) + case r of + Left (ErrorCall msg) -> putStrLn ("OK: " ++ msg) + Right v -> putStrLn ("FAIL: got " ++ show v) >> exitFailure ===================================== testsuite/tests/simplStg/should_run/T27831.stdout ===================================== @@ -0,0 +1,3 @@ +OK: not a thunk +1 +OK: T27831 ===================================== testsuite/tests/simplStg/should_run/T27857.hs ===================================== @@ -0,0 +1,45 @@ +{-# LANGUAGE StrictData #-} +-- Regression test from #27857: We store a function that loops indefinitely +-- in a strict field. +module Main (main) where +import Control.Monad + +data Body + = BNone + | BStream ((Int -> IO ()) -> IO () -> IO ()) + | BIface (Int -> IO ()) + | BBuilder String + | BFile Int + +data Obj = Obj [String] Body Int + +newtype Resp = Resp Obj + +stream :: Int -> [String] -> ((Int -> IO ()) -> IO () -> IO ()) -> Resp +stream st hdr b = Resp $ Obj (show st : hdr) (BStream b) 0 + +noBody :: Int -> [String] -> Resp +noBody st hdr = Resp $ Obj (show st : hdr) BNone 0 + +infinite :: Resp +infinite = stream 200 ["text/plain"] body + where + body :: (Int -> IO ()) -> IO () -> IO () + body write flush = do + let go n = write n *> flush *> go (succ n) + go (0 :: Int) + +other :: Resp +other = noBody 404 [] + +name :: Body -> String +name b = case b of + BNone -> "None" + BStream _ -> "Stream" + BIface _ -> "Iface" + BBuilder _ -> "Builder" + BFile _ -> "File" + +main :: IO () +main = forM_ [("infinite", infinite), ("other", other)] $ \(n, Resp (Obj _ b _)) -> + putStrLn $ n ++ "=" ++ name b ===================================== testsuite/tests/simplStg/should_run/T27857.stdout ===================================== @@ -0,0 +1,2 @@ +infinite=Stream +other=None ===================================== testsuite/tests/simplStg/should_run/all.T ===================================== @@ -3,13 +3,15 @@ # extra run flags # expected process return value, if not zero -# Only compile with optimisation +# Only run optimised code, native and interpreted: +# We now generate bytecode from STG so we should test native and bytecode. def f( name, opts ): - opts.only_ways = ['optasm'] + opts.only_ways = ['optasm', 'ghci-opt'] setTestOpts(f) -test('T9291', normal, compile_and_run, ['']) +# Breakpoint ticks would break CSE which this tests. +test('T9291', [omit_ways(['ghci']), extra_hc_opts('-fno-break-points')], compile_and_run, ['']) test('T13536', normal, compile_and_run, ['']) test('T13536a', @@ -20,6 +22,16 @@ test('T13536a', test('inferTags001', normal, multimod_compile_and_run, ['inferTags001', 'inferTags001_a']) test('T22042', [extra_files(['T22042a.hs']),only_ways('normal'),unless(have_dynamic(), skip)], makefile_test, ['T22042']) -test('T23783', normal, multimod_compile_and_run, ['T23783', '-O -v0']) -test('unpack_enum', normal, compile_and_run, ['']) -test('T27005a', normal, compile_and_run, ['']) + +# Depends on tag inference being similarly effective for bytecode which it is not yet. +test('T23783', omit_ghci, multimod_compile_and_run, ['T23783', '-O -v0']) + +# Requires UNPACK which needs -O +test('unpack_enum', omit_ways(['ghci']), compile_and_run, ['']) + +# Tests that tag inference optimizes well, which is not the case for bytecode or +# when we insert profiling ticks. +test('T27005a', omit_ways(ghci_ways + prof_ways), compile_and_run, ['']) +test('T27831', omit_ways(ghci_ways + prof_ways), compile_and_run, ['']) +test('inferTags007', [extra_files(['InferTags007_A.hs'])], multimod_compile_and_run, ['inferTags007', '-O -v0']) +test('T27857', normal, compile_and_run, ['']) ===================================== testsuite/tests/simplStg/should_run/inferTags007.hs ===================================== @@ -0,0 +1,109 @@ +{-# LANGUAGE MagicHash #-} +-- This test sanity checks the tag info we generate for imported binders which +-- have no real info in the .hi file. +-- +-- This is important to avoid running into cases where we optimistically +-- generated better information based on things like type than the +-- compiled code actually provided. For example GHCi doesn't ensure tagging +-- of constructors. +module Main (main) where + +import Control.Exception +import Control.Monad +import GHC.Exts (Addr#) +import GHC.Exts.Heap (GenClosure(..), getClosureData) +import GHC.Internal.Control.Exception.Base (patError) +import System.Exit + +import qualified InferTags007_A as A + +data S a = S !a + +data P = MkP !(Addr# -> Int) + +-- Put the imported values into a strict field of a top level Con +con_top_fun :: S (Int -> Int) +con_top_fun = S A.fun +{-# NOINLINE con_top_fun #-} + +con_top_caf :: S [Int] +con_top_caf = S A.caf +{-# NOINLINE con_top_caf #-} + +con_top_bot :: S (Int -> Int) +con_top_bot = S A.bot +{-# NOINLINE con_top_bot #-} + +con_top_con :: S (Maybe Int) +con_top_con = S A.con +{-# NOINLINE con_top_con #-} + +con_top_pat :: P +con_top_pat = MkP patError +{-# NOINLINE con_top_pat #-} + +-- Put the imported values into a strict field of a Con inside a rhs +expr_fun :: () -> S (Int -> Int) +expr_fun _ = S A.fun +{-# OPAQUE expr_fun #-} + +expr_caf :: () -> S [Int] +expr_caf _ = S A.caf +{-# OPAQUE expr_caf #-} + +expr_bot :: () -> S (Int -> Int) +expr_bot _ = S A.bot +{-# OPAQUE expr_bot #-} + +expr_con :: () -> S (Maybe Int) +expr_con _ = S A.con +{-# OPAQUE expr_con #-} + +-- Actually use the field. +use_S_head :: S [Int] -> Int +use_S_head (S xs) = case xs of { (y:_) -> y; [] -> -1 } +{-# NOINLINE use_S_head #-} + +use_S_fromJust :: S (Maybe Int) -> Int +use_S_fromJust (S m) = case m of { Just x -> x; Nothing -> -1 } +{-# NOINLINE use_S_fromJust #-} + +use_S_apply :: S (Int -> Int) -> Int +use_S_apply (S f) = f 1 +{-# NOINLINE use_S_apply #-} + +checkNotThunk :: String -> a -> IO () +checkNotThunk name x = do + c <- getClosureData x + case c of + ThunkClosure{} -> putStrLn ("FAIL: " ++ name ++ " is a thunk") >> exitFailure + APClosure{} -> putStrLn ("FAIL: " ++ name ++ " is an AP") >> exitFailure + _ -> pure () + +-- Pattern matching binds the field itself, so no selector thunk is involved. +checkField :: String -> S a -> IO () +checkField name (S x) = checkNotThunk name x +{-# NOINLINE checkField #-} + +main :: IO () +main = do + -- Check if the pointer in the strict field is a thunk. + checkField "con_top_caf" con_top_caf + checkField "con_top_fun" con_top_fun + checkField "con_top_bot" con_top_bot + checkField "con_top_con" con_top_con + case con_top_pat of MkP f -> checkNotThunk "con_top_pat" f + checkField "expr_caf" (expr_caf ()) + checkField "expr_fun" (expr_fun ()) + checkField "expr_bot" (expr_bot ()) + checkField "expr_con" (expr_con ()) + + -- Actually execute a case on the contents of the field. + print (use_S_head con_top_caf, use_S_head (expr_caf ())) + print (use_S_fromJust con_top_con, use_S_fromJust (expr_con ())) + print (use_S_apply con_top_fun, use_S_apply (expr_fun ())) + forM_ [con_top_bot, expr_bot ()] $ \s -> do + r <- try (evaluate (use_S_apply s)) + case r of + Left (ErrorCall msg) -> putStrLn ("OK: " ++ msg) + Right v -> putStrLn ("FAIL: got " ++ show v) >> exitFailure ===================================== testsuite/tests/simplStg/should_run/inferTags007.stdout ===================================== @@ -0,0 +1,5 @@ +(2,2) +(42,42) +(2,2) +OK: bot called +OK: bot called View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6a80ad6082d30aa91e644b290b236a1e... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6a80ad6082d30aa91e644b290b236a1e... 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