Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 7fe4f2ec by Luite Stegeman at 2026-06-17T05:35:09-04:00 tag inference: don't confuse functions with their return values inferTagRhs was mixing up taggedness for closures and return values for function closures. We really shouldn't assign TagTuple to a properly tagged function returning a tuple. We fix this by keeping track of functions (TagFun) separately from values (TagVal) and keeping track of their return value. TagFun is also used for join points. fixes #27005 - - - - - 22 changed files: - + changelog.d/tag-inference-27005 - compiler/GHC/Core/Utils.hs - compiler/GHC/Stg/EnforceEpt.hs - compiler/GHC/Stg/EnforceEpt/Rewrite.hs - compiler/GHC/Stg/EnforceEpt/TagSig.hs - compiler/GHC/Stg/EnforceEpt/Types.hs - testsuite/tests/core-to-stg/T14895.stderr - testsuite/tests/simplCore/should_compile/T4201.stdout - + testsuite/tests/simplCore/should_run/T27005.hs - + testsuite/tests/simplCore/should_run/T27005.stdout - + testsuite/tests/simplCore/should_run/T27005_aux.hs - testsuite/tests/simplCore/should_run/all.T - testsuite/tests/simplStg/should_compile/T24806.hs - testsuite/tests/simplStg/should_compile/T24806.stderr - + testsuite/tests/simplStg/should_compile/T27005b.hs - + testsuite/tests/simplStg/should_compile/T27005b.stderr - testsuite/tests/simplStg/should_compile/all.T - testsuite/tests/simplStg/should_compile/inferTags004.hs - testsuite/tests/simplStg/should_compile/inferTags004.stderr - + testsuite/tests/simplStg/should_run/T27005a.hs - + testsuite/tests/simplStg/should_run/T27005a.stdout - testsuite/tests/simplStg/should_run/all.T Changes: ===================================== changelog.d/tag-inference-27005 ===================================== @@ -0,0 +1,8 @@ +section: compiler +synopsis: Eliminate redundant thunks introduced by tag inference. +description: { + Tag inference is now more precise in tracking function results, eliminating + redundant thunks for certain functions that return an unboxed tuple. +} +issues: #27005 +mrs: !15688 ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -3252,7 +3252,7 @@ That is in STG after tag inference we get: Str=<1L><ML>, Unf=OtherCon []] = {} \r [x y] - case x<TagProper> of x' [Occ=Once1] { + case x<TagVal[TagEPT]> of x' [Occ=Once1] { __DEFAULT -> case y of y' [Occ=Once1] { __DEFAULT -> @@ -3277,8 +3277,8 @@ But if we add an extra eval on `y` during worker/wrapper we this this: Str=<1L><!L>, Unf=OtherCon []] = {} \r [x y] - case y<TagProper> of y' [Occ=Once1] { __DEFAULT -> - case x<TagProper> of x' [Occ=Once1] { + case y<TagVal[TagEPT]> of y' [Occ=Once1] { __DEFAULT -> + case x<TagVal[TagEPT]> of x' [Occ=Once1] { __DEFAULT -> case Find.$wmyPred y' of pred_y [Occ=Once1] { __DEFAULT -> ===================================== compiler/GHC/Stg/EnforceEpt.hs ===================================== @@ -40,9 +40,6 @@ A pointer is Evaluated and Properly Tagged (EPT) when the pointer A binder is EPT when all the runtime pointers it binds are EPT. -Note that a lifted EPT pointer will never point to a thunk, nor will it be -tagged `000` (meaning "might be a thunk"). - See https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/rts/haskell-execution/... for more information on pointer tagging. @@ -57,11 +54,15 @@ Examples: * In practice, GHC also guarantees that strict fields (and others) are EPT; see Note [EPT enforcement]. -Caveat: -Currently, the proper tag for builtin *unlifted* data types such as `Array#` is -not `001` but `000`, which is not a proper tag for lifted data. -This means that UnliftedRep is not a proper sub-rep of LiftedRep. -SG thinks it would be good to fix this; see #21792. +Wrinkles: + +EPT1: The proper tag for builtin *unlifted* data types such as `Array#` is + not `001` but `000`, which is not a proper tag for lifted data. + This means that UnliftedRep is not a proper sub-rep of LiftedRep. + SG thinks it would be good to fix this; see #21792. +EPT2: The proper tag for PAPs is `000`, so there are values from lifted data types + that are EPT with a zero tag. +EPT3: Non-pointer values don't have a tag at all, but we still treat them as EPT. Note [EPT enforcement] ~~~~~~~~~~~~~~~~~~~~~~ @@ -261,18 +262,39 @@ might destroy the EPT Invariant, hence we need to enforce the EPT invariant {- Note [TagInfo of functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The purpose of tag inference is really to figure out when we don't have to enter -value closures. There the meaning of the tag is fairly obvious. -For functions we never make use of the tag info so we have two choices: -* Treat them as TagDunno -* Treat them as TagProper (as they *are* tagged with their arity) and be really - careful to make sure we still enter them when needed. -As it makes little difference for runtime performance I've treated functions as TagDunno in a few places where -it made the code simpler. But besides implementation complexity there isn't any reason -why we couldn't be more rigorous in dealing with functions. - -NB: It turned in #21193 that PAPs get tag zero, so the tag check can't be omitted for functions. -So option two isn't really an option without reworking this anyway. +'TagFun' represents an evaluated function and carries the return-value TagInfo +for saturated calls. See Note [TagSig and TagInfo] in GHC.Stg.EnforceEpt.TagSig. + +Join points (StgLetNoEscape) are treated like functions: they are jumped to, +never entered via a closure pointer. Even nullary join points get TagFun +rather than TagVal TagDunno, so their return-value info flows through. + +Additionally we also special case bottoming functions. +See Note [Bottom functions are TagBottoming]. + +Function values when properly tagged have either their arity, 1 for very large +arities, or zero for PAPs (#21193) as tag. However the runtime currently doesn't +maintain the EPT status of function pointers. So while we keep track of +evaluated function binders using 'TagFun' this has a weaker guarantee than for +values. For functions it only represents a pointer to an evaluated function, but +doesn't give any guarantee about the function's pointer tag. + +Sadly because PAPs get tag zero (#21193), other issues in the RTS (#21193) and +the potential of over/underapplication of arguments, even evaluated function +binders still require inspection of their closure before they can be applied. +That is, even if we have + + case f of f' -> ... f' x ... + +the code for `f' x` can't be made meaningfully more efficient by knowing `f'` is +already evaluated. + +However tracking evaluation status for functions is still worthwhile, as we rely +on the EPT pass to force strict constructor fields. For an application +`StrictJust f` we would usually insert an eval of `f` around the constructor +application. However if we infer `f` to be already evaluated we can avoid this, +which was a significant performance benefit in #27005. Similarly we can still +turn redundant eval-cases on functions into a no-op. Note [EPT enforcement debugging] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -361,7 +383,6 @@ type InferExtEq i = ( XLet i ~ XLet 'InferTaggedBinders inferTags :: Bool -> [GenStgTopBinding 'CodeGen] -> [GenStgTopBinding 'InferTaggedBinders] inferTags for_bytecode binds = - -- pprTrace "Binds" (pprGenStgTopBindings shortStgPprOpts $ binds) $ snd (mapAccumL inferTagTopBind (initEnv for_bytecode) binds) ----------------------- @@ -389,18 +410,20 @@ inferTagExpr env (StgApp fun args) !fun_arity = idArity fun info -- It's important that we check for bottoms before all else. - -- See Note [Bottom functions are TagTagged] and #24806 for why. + -- See Note [Bottom functions are TagBottoming] and #24806 for why. | isDeadEndAppSig (idDmdSig fun) (length args) - = TagTagged + = TagBottoming | fun_arity == 0 -- Unknown arity => Thunk or unknown call = TagDunno - | Just (TagSig res_info) <- tagSigInfo (idInfo fun) + -- Imported function with known return tag + | Just (TagFun res_info) <- tagSigInfo (idInfo fun) , fun_arity == length args -- Saturated = res_info - | Just (TagSig res_info) <- lookupSig env fun + -- Local function with known return tag + | Just res_info <- lookupReturnInfo env fun , fun_arity == length args -- Saturated = res_info @@ -412,7 +435,7 @@ inferTagExpr env (StgConApp con cn args tys) = (inferConTag env con args, StgConApp con cn args tys) inferTagExpr _ (StgLit l) - = (TagTagged, StgLit l) + = (TagEPT, StgLit l) inferTagExpr env (StgTick tick body) = (info, StgTick tick body') @@ -446,7 +469,7 @@ inferTagExpr in_env (StgCase scrut bndr ty alts) mk_bndr :: BinderP p -> TagInfo -> (Id, TagSig) mk_bndr tup_bndr tup_info = -- pprTrace "mk_ubx_bndr_info" ( ppr bndr <+> ppr info ) $ - (getBinderId in_env tup_bndr, TagSig tup_info) + (getBinderId in_env tup_bndr, TagVal tup_info) -- no case binder in alt_env here, unboxed tuple binders are dead after unarise alt_env = extendSigEnv in_env bndrs' (info, rhs') = inferTagExpr alt_env rhs @@ -478,16 +501,16 @@ inferTagExpr in_env (StgCase scrut bndr ty alts) , let (alt_env,bndrs') = addAltBndrInfo case_env con bndrs (info, rhs') = inferTagExpr alt_env rhs ] - alt_info = foldr combineAltInfo TagTagged infos + alt_info = foldr combineAltInfo TagBottoming infos in ( alt_info, StgCase scrut' bndr' ty alts') where -- Single unboxed tuple alternative scrut_infos bndrs = case scrut_info of - TagTagged -> Just $ replicate (length bndrs) TagProper + TagBottoming -> Just $ replicate (length bndrs) TagBottoming TagTuple infos -> Just infos _ -> Nothing (scrut_info, scrut') = inferTagExpr in_env scrut - bndr' = (getBinderId in_env bndr, TagSig TagProper) + bndr' = (getBinderId in_env bndr, TagVal TagEPT) -- Compute binder sigs based on the constructors strict fields. -- NB: Not used if we have tuple info from the scrutinee. @@ -503,7 +526,7 @@ addAltBndrInfo env (DataAlt con) bndrs mk_bndr :: (BinderP p -> StrictnessMark -> (Id, TagSig)) mk_bndr bndr mark | isUnliftedType (idType id) || isMarkedStrict mark - = (id, TagSig TagProper) + = (id, TagVal TagEPT) | otherwise = noSig env bndr where @@ -523,7 +546,7 @@ inferTagBind in_env (StgNonRec bndr rhs) (env', StgNonRec (id, out_sig) rhs') where id = getBinderId in_env bndr - (in_sig,rhs') = inferTagRhs id in_env rhs + (in_sig, rhs') = inferTagRhs id in_env rhs out_sig = mkLetSig in_env in_sig env' = extendSigEnv in_env [(id, out_sig)] @@ -536,13 +559,12 @@ inferTagBind in_env (StgRec pairs) init_sigs = map (initSig) $ zip in_ids rhss (out_env, pairs') = go in_env init_sigs rhss - go :: forall q. (OutputableInferPass q , InferExtEq q) => TagEnv q -> [TagSig] -> [GenStgRhs q] - -> (TagSigEnv, [((Id,TagSig), GenStgRhs 'InferTaggedBinders)]) + go :: forall q. (OutputableInferPass q , InferExtEq q) + => TagEnv q -> [TagSig] -> [GenStgRhs q] + -> (TagSigEnv, [((Id,TagSig), GenStgRhs 'InferTaggedBinders)]) go go_env in_sigs go_rhss - -- | pprTrace "go" (ppr in_ids $$ ppr in_sigs $$ ppr out_sigs $$ ppr rhss') False - -- = undefined | in_sigs == out_sigs = (te_env rhs_env, out_bndrs `zip` rhss') - | otherwise = go env' out_sigs rhss' + | otherwise = go env' out_sigs rhss' where in_bndrs = in_ids `zip` in_sigs out_bndrs = map updateBndr in_bndrs -- TODO: Keeps in_ids alive @@ -552,25 +574,28 @@ inferTagBind in_env (StgRec pairs) anaRhs :: Id -> GenStgRhs q -> (TagSig, GenStgRhs 'InferTaggedBinders) anaRhs bnd rhs = - let (sig_rhs,rhs') = inferTagRhs bnd rhs_env rhs + let (sig_rhs, rhs') = inferTagRhs bnd rhs_env rhs in (mkLetSig go_env sig_rhs, rhs') updateBndr :: (Id,TagSig) -> (Id,TagSig) updateBndr (v,sig) = (setIdTagSig v sig, sig) +-- Initial signature for the fixpoint loop. initSig :: forall p. (Id, GenStgRhs p) -> TagSig --- Initial signature for the fixpoint loop -initSig (_bndr, StgRhsCon {}) = TagSig TagTagged -initSig (bndr, StgRhsClosure _ _ _ _ _ _) = - fromMaybe defaultSig (idTagSig_maybe bndr) - where defaultSig = (TagSig TagTagged) - -{- Note [Bottom functions are TagTagged] +initSig (_bndr, StgRhsCon {}) + = TagVal TagBottoming +initSig (bndr, StgRhsClosure _ _ _ bndrs _ _) + | notNull bndrs || isJoinId bndr + = fromMaybe (TagFun TagBottoming) (idTagSig_maybe bndr) + | otherwise -- thunk + = fromMaybe (TagVal TagBottoming) (idTagSig_maybe bndr) + +{- Note [Bottom functions are TagBottoming] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we have a function with two branches with one being bottom, and the other returning a tagged -unboxed tuple what is the result? We give it TagTagged! +unboxed tuple what is the result? We give it TagBottoming! To answer why consider this function: foo :: Bool -> (# Bool, Bool #) @@ -585,7 +610,7 @@ 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 TagTagged, as it allows the combined tag sig of the case expression +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. NB: After the analysis is done we go back to treating bottoming functions as @@ -603,13 +628,20 @@ inferTagRhs :: forall p. -> GenStgRhs p -- ^ -> (TagSig, GenStgRhs 'InferTaggedBinders) inferTagRhs bnd_id in_env (StgRhsClosure ext cc upd bndrs body typ) - | isDeadEndId bnd_id && (notNull) bndrs - -- See Note [Bottom functions are TagTagged] - = (TagSig TagTagged, StgRhsClosure ext cc upd out_bndrs body' typ) - | otherwise - = --pprTrace "inferTagRhsClosure" (ppr (_top, _grp_ids, env,info')) $ - (TagSig info', StgRhsClosure ext cc upd out_bndrs body' typ) + | isDeadEndId bnd_id && is_fun_or_join + -- See Note [Bottom functions are TagBottoming] + = ( TagFun TagBottoming + , StgRhsClosure ext cc upd out_bndrs body' typ) + | is_fun_or_join + = ( TagFun info + , StgRhsClosure ext cc upd out_bndrs body' typ) + | otherwise -- thunk (never a join point) + = ( TagVal TagDunno + , StgRhsClosure ext cc upd out_bndrs body' typ) where + -- Join points are treated like functions. See Note [TagInfo of functions] + is_fun_or_join = notNull bndrs || isJoinId bnd_id + out_bndrs | Just marks <- idCbvMarks_maybe bnd_id -- Sometimes an we eta-expand foo with additional arguments after ww, and we also trim @@ -620,37 +652,29 @@ inferTagRhs bnd_id in_env (StgRhsClosure ext cc upd bndrs body typ) env' = extendSigEnv in_env out_bndrs (info, body') = inferTagExpr env' body - info' - -- It's a thunk - | null bndrs - = TagDunno - -- TODO: We could preserve tuple fields for thunks - -- as well. But likely not worth the complexity. - - | otherwise = info mkArgSig :: BinderP p -> CbvMark -> (Id,TagSig) mkArgSig bndp mark = let id = getBinderId in_env bndp tag = case mark of - MarkedCbv -> TagProper + MarkedCbv -> TagEPT _ - | isUnliftedType (idType id) -> TagProper + | isUnliftedType (idType id) -> TagEPT | otherwise -> TagDunno - in (id, TagSig tag) + in (id, TagVal tag) inferTagRhs _ env _rhs@(StgRhsCon cc con cn ticks args typ) -- Constructors, which have untagged arguments to strict fields -- become thunks. We encode this by giving changing RhsCon nodes the info TagDunno = --pprTrace "inferTagRhsCon" (ppr grp_ids) $ - (TagSig (inferConTag env con args), StgRhsCon cc con cn ticks args typ) + (TagVal (inferConTag env con args), StgRhsCon cc con cn ticks args typ) -- Adjust let semantics to the targeted backend. -- See Note [EPT enforcement for interpreted code] mkLetSig :: TagEnv p -> TagSig -> TagSig mkLetSig env in_sig - | for_bytecode = TagSig TagDunno - | otherwise = in_sig + | for_bytecode = TagVal TagDunno + | otherwise = in_sig where for_bytecode = te_bytecode env @@ -658,52 +682,53 @@ mkLetSig env in_sig ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @inferConTag@ will infer the proper tag signature for a binding who's RHS is a constructor or a StgConApp expression. -Usually these will simply be TagProper. But there are exceptions. +Usually these will simply be TagEPT. But there are exceptions. If any of the fields in the constructor are strict, but any argument to these fields is not tagged then we will have to case on the argument before storing in the constructor. Which means for let bindings the RHS turns into a thunk which obviously is no longer properly tagged. For example we might start with: - let x<TagDunno> = f ... - let c<TagProper> = StrictPair x True + let x<TagVal[TagDunno]> = f ... + let c<TagVal[TagEPT]> = StrictPair x True But we know during the rewrite stage x will need to be evaluated in the RHS of `c` so we will infer: - let x<TagDunno> = f ... - let c<TagDunno> = StrictPair x True + let x<TagVal[TagDunno]> = f ... + let c<TagVal[TagDunno]> = StrictPair x True Which in the rewrite stage will then be rewritten into: - let x<TagDunno> = f ... - let c<TagDunno> = case x of x' -> StrictPair x' True + let x<TagVal[TagDunno]> = f ... + let c<TagVal[TagDunno]> = case x of x' -> StrictPair x' True The other exception is unboxed tuples. These will get a TagTuple signature with a list of TagInfo about their individual binders as argument. As example: - let c<TagProper> = True - let x<TagDunno> = ... - let f<?> z = case z of z'<TagProper> -> (# c, x #) + let c<TagVal[TagEPT]> = True + let x<TagVal[TagDunno]> = ... + let f<?> z = case z of z'<TagVal[TagEPT]> -> (# c, x #) -Here we will infer for f the Signature <TagTuple[TagProper,TagDunno]>. +Here we will infer for f the Signature <TagFun[TagTuple[TagEPT,TagDunno]]>. This information will be used if we scrutinize a saturated application of `f` in order to determine the taggedness of the result. That is for `case f x of (# r1,r2 #) -> rhs` we can infer -r1<TagProper> and r2<TagDunno> which allows us to skip all tag checks on `r1` +r1<TagVal[TagEPT]> and r2<TagVal[TagDunno]> which allows us to skip all tag checks on `r1` in `rhs`. Things get a bit more complicated with nesting: - let closeFd<TagTuple[...]> = ... + let closeFd<TagFun[...]> = ... let f x = ... case x of _ -> Solo# closeFd -The "natural" signature for the Solo# branch in `f` would be <TagTuple[TagTuple[...]]>. -But we flatten this out to <TagTuple[TagDunno]> for the time being as it improves compile -time and there doesn't seem to huge benefit to doing differently. +We only keep track of function return types for bindings, not values: +TagInfo has no constructor for "function with return info". Therefore the +signature of `f` becomes <TagFun[TagTuple[TagEPT]]>. We lose the information +about the return type of `closeFd`. -} @@ -721,7 +746,7 @@ inferConTag env con args -- text "info:" <> ppr info) $ info where - info = if any arg_needs_eval strictArgs then TagDunno else TagProper + info = if any arg_needs_eval strictArgs then TagDunno else TagEPT strictArgs = zipEqual args (dataConRuntimeRepStrictness con) :: ([(StgArg, StrictnessMark)]) arg_needs_eval (arg,strict) -- lazy args @@ -730,10 +755,10 @@ inferConTag env con args -- banged args need to be tagged, or require eval = not (isTaggedInfo tag) - flatten_arg_tag (TagTagged) = TagProper - flatten_arg_tag (TagProper ) = TagProper - flatten_arg_tag (TagTuple _) = TagDunno -- See Note [Constructor TagSigs] - flatten_arg_tag (TagDunno) = TagDunno + flatten_arg_tag TagBottoming = TagEPT + flatten_arg_tag TagEPT = TagEPT + flatten_arg_tag (TagTuple _) = TagDunno -- See Note [Constructor TagSigs] + flatten_arg_tag TagDunno = TagDunno collectExportInfo :: [GenStgTopBinding 'InferTaggedBinders] -> NameEnv TagSig @@ -746,15 +771,14 @@ collectExportInfo binds = collect (StgTopLifted bnd) = case bnd of StgNonRec (id,sig) _rhs - | TagSig TagDunno <- sig -> [] + | TagVal TagDunno <- sig -> [] + | TagVal TagBottoming <- sig -> [] | otherwise -> [(idName id,sig)] StgRec bnds -> collectRec bnds collectRec :: [(BinderP 'InferTaggedBinders, rhs)] -> [(Name,TagSig)] collectRec [] = [] - collectRec (bnd:bnds) - | (p,_rhs) <- bnd - , (id,sig) <- p - , TagSig TagDunno <- sig - = (idName id,sig) : collectRec bnds - | otherwise = collectRec bnds + collectRec (((id,sig), _rhs) : bnds) + | TagVal TagDunno <- sig = collectRec bnds + | TagVal TagBottoming <- sig = collectRec bnds + | otherwise = (idName id, sig) : collectRec bnds ===================================== compiler/GHC/Stg/EnforceEpt/Rewrite.hs ===================================== @@ -239,14 +239,14 @@ For this reason we assert that we are running in interactive mode if a lookup fa -} isTagged :: Id -> RM Bool isTagged v - -- See Note [Bottom functions are TagTagged] + -- See Note [Bottom functions are TagBottoming] | isDeadEndId v = pure False | otherwise = do 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) - (TagSig TagDunno) + (TagVal TagDunno) case nameIsLocalOrFrom this_mod (idName v) of True | definitelyUnliftedType (idType v) @@ -257,12 +257,11 @@ isTagged v !s <- getMap let !sig = lookupWithDefaultUFM s (lookupDefault v) v return $ case sig of - TagSig info -> - case info of - TagDunno -> False - TagProper -> True - TagTagged -> True - TagTuple _ -> True -- Consider unboxed tuples tagged. + 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. @@ -279,7 +278,7 @@ isTagged v -> True LFUnknown {} -> False - LFUnlifted {} + LFUnlifted {} -- Unboxed, tagging irrelevant -> True LFLetNoEscape {} -- Shouldn't be possible. I don't think we can export letNoEscapes @@ -385,7 +384,7 @@ rewriteArg (lit@StgLitArg{}) = return lit rewriteId :: Id -> RM Id rewriteId v = do !is_tagged <- isTagged v - if is_tagged then return $! setIdTagSig v (TagSig TagProper) + if is_tagged then return $! setIdTagSig v (TagVal TagEPT) else return v rewriteExpr :: GenStgExpr 'InferTaggedBinders -> RM (GenStgExpr 'CodeGen) ===================================== compiler/GHC/Stg/EnforceEpt/TagSig.hs ===================================== @@ -16,65 +16,119 @@ import GHC.Types.Name.Env( NameEnv ) import GHC.Utils.Outputable import GHC.Utils.Binary import GHC.Utils.Panic.Plain -import Data.Coerce -- | Information to be exposed in interface files which is produced -- by the stg2stg passes. type StgCgInfos = NameEnv TagSig -newtype TagSig -- The signature for each binding, this is a newtype as we might - -- want to track more information in the future. - = TagSig TagInfo +-- Note [TagSig and TagInfo] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- 'TagSig' describes a *binding*; 'TagInfo' describes a *runtime value*. +-- +-- A binding denotes either a value or a function: +-- +-- * 'TagVal' i — the binding holds a value whose runtime shape is 'i'. +-- 'i' covers thunks (TagDunno), evaluated/tagged heap +-- pointers (TagEPT), unboxed tuples (TagTuple), and +-- bottoming computations (TagBottoming). +-- +-- * 'TagFun' i — the binding is a function or join point. A function +-- closure is always EPT. 'i' describes what a +-- *saturated call* returns. +-- See Note [TagInfo of functions] in GHC.Stg.EnforceEpt. +-- +-- This split keeps 'combineAltInfo' at the value level: case alternatives +-- combine 'TagInfo', not 'TagSig'. An alternative that returns a function +-- closure gets 'TagEPT' (closure pointer is tagged) with no tracked return +-- info — the return info only matters once the function is applied, and at +-- that point it's looked up from the binding's 'TagSig' via +-- 'lookupReturnInfo'. + +-- | The signature attached to a binding. +data TagSig + = TagVal TagInfo -- ^ A value binding (thunk, constructor, etc.) + | TagFun TagInfo -- ^ A function/join-point binding; carries the + -- TagInfo of saturated-call return values. + -- See Note [TagInfo of functions]. deriving (Eq) +-- Note [TagInfo lattice] +-- ~~~~~~~~~~~~~~~~~~~~~~ +-- The TagInfo lattice describes what we know about whether a runtime value +-- is properly tagged (pointer tag bits set for heap pointers): +-- +-- TagBottoming (bottom) ⊑ {TagEPT, TagTuple _} ⊑ TagDunno (top) +-- +-- TagBottoming is the identity element for 'combineAltInfo': it is used as +-- the initial signature in fixpoint loops and for dead-end (bottoming) +-- computations, since their return value can be given any tag — they never +-- actually return. + +-- | What we know about a runtime value. data TagInfo - = TagDunno -- We don't know anything about the tag. - | TagTuple [TagInfo] -- Represents a function/thunk which when evaluated - -- will return a Unboxed tuple whos components have - -- the given TagInfos. - | TagProper -- Heap pointer to properly-tagged value - | TagTagged -- Bottom of the domain. + = TagDunno -- ^ We don't know anything about the tag. + | TagTuple [TagInfo] -- ^ An unboxed tuple with taginfo for each element. + | TagEPT -- ^ An evaluated and properly tagged value. + -- See Note [Evaluated and Properly Tagged]. + | TagBottoming -- ^ Bottom of the domain. + -- See Note [Bottom functions are TagBottoming] in GHC.Stg.EnforceEpt. deriving (Eq) instance Outputable TagInfo where - ppr TagTagged = text "TagTagged" - ppr TagDunno = text "TagDunno" - ppr TagProper = text "TagProper" - ppr (TagTuple tis) = text "TagTuple" <> brackets (pprWithCommas ppr tis) + ppr TagBottoming = text "TagBottoming" + ppr TagDunno = text "TagDunno" + ppr TagEPT = text "TagEPT" + ppr (TagTuple tis) = text "TagTuple" <> brackets (pprWithCommas ppr tis) instance Binary TagInfo where - put_ bh TagDunno = putByte bh 1 + put_ bh TagDunno = putByte bh 1 put_ bh (TagTuple flds) = putByte bh 2 >> put_ bh flds - put_ bh TagProper = putByte bh 3 - put_ bh TagTagged = putByte bh 4 + put_ bh TagEPT = putByte bh 3 + put_ bh TagBottoming = putByte bh 4 get bh = do tag <- getByte bh case tag of 1 -> return TagDunno 2 -> TagTuple <$> get bh - 3 -> return TagProper - 4 -> return TagTagged + 3 -> return TagEPT + 4 -> return TagBottoming _ -> panic ("get TagInfo " ++ show tag) instance Outputable TagSig where - ppr (TagSig ti) = char '<' <> ppr ti <> char '>' + ppr (TagVal ti) = char '<' <> text "TagVal" <> brackets (ppr ti) <> char '>' + ppr (TagFun ti) = char '<' <> text "TagFun" <> brackets (ppr ti) <> char '>' + instance OutputableBndr (Id,TagSig) where pprInfixOcc = ppr pprPrefixOcc = ppr instance Binary TagSig where - put_ bh (TagSig sig) = put_ bh sig - get bh = pure TagSig <*> get bh + put_ bh (TagVal ti) = putByte bh 1 >> put_ bh ti + put_ bh (TagFun ti) = putByte bh 2 >> put_ bh ti + get bh = do tag <- getByte bh + case tag of 1 -> TagVal <$> get bh + 2 -> TagFun <$> get bh + _ -> panic ("get TagSig " ++ show tag) +-- | Is the given binding known to be properly tagged (or irrelevant, as for +-- unboxed values and bottoming computations)? isTaggedSig :: TagSig -> Bool -isTaggedSig (TagSig TagProper) = True -isTaggedSig (TagSig TagTagged) = True -isTaggedSig _ = False +isTaggedSig (TagFun _) = True +isTaggedSig (TagVal ti) = isTaggedInfo ti + +-- | Is the given value-level tag known to be properly tagged? +-- NB: unboxed tuples are *not* treated as tagged here; they are handled +-- specially by the rewriter (which considers them already evaluated). +isTaggedInfo :: TagInfo -> Bool +isTaggedInfo TagEPT = True +isTaggedInfo TagBottoming = True +isTaggedInfo _ = False seqTagSig :: TagSig -> () -seqTagSig = coerce seqTagInfo +seqTagSig (TagVal ti) = seqTagInfo ti +seqTagSig (TagFun ti) = seqTagInfo ti seqTagInfo :: TagInfo -> () -seqTagInfo TagTagged = () +seqTagInfo TagBottoming = () seqTagInfo TagDunno = () -seqTagInfo TagProper = () -seqTagInfo (TagTuple tis) = foldl' (\_unit sig -> seqTagSig (coerce sig)) () tis +seqTagInfo TagEPT = () +seqTagInfo (TagTuple tis) = foldl' (\_unit info -> seqTagInfo info) () tis ===================================== compiler/GHC/Stg/EnforceEpt/Types.hs ===================================== @@ -35,15 +35,23 @@ type InferStgExpr = GenStgExpr 'InferTaggedBinders type InferStgRhs = GenStgRhs 'InferTaggedBinders type InferStgAlt = GenStgAlt 'InferTaggedBinders +-- | Combine TagInfo from the alternatives of a case expression. +-- Note that this operates at the value level: case alternatives return +-- values. See Note [TagSig and TagInfo]. combineAltInfo :: TagInfo -> TagInfo -> TagInfo -combineAltInfo TagDunno _ = TagDunno -combineAltInfo _ TagDunno = TagDunno -combineAltInfo (TagTuple {}) TagProper = TagDunno -- This can happen with rep-polymorphic result, see #26107 -combineAltInfo TagProper (TagTuple {}) = TagDunno -- This can happen with rep-polymorphic result, see #26107 -combineAltInfo TagProper TagProper = TagProper +combineAltInfo TagBottoming ti = ti +combineAltInfo ti TagBottoming = ti +combineAltInfo TagDunno TagDunno = TagDunno +combineAltInfo TagDunno TagEPT = TagDunno +combineAltInfo TagDunno (TagTuple {}) = TagDunno +combineAltInfo TagEPT TagDunno = TagDunno +combineAltInfo (TagTuple {}) TagDunno = TagDunno +combineAltInfo TagEPT TagEPT = TagEPT +-- TagEPT/TagTuple are incompatible (can arise with rep-polymorphic +-- results, see #26107); fall through to TagDunno. +combineAltInfo TagEPT (TagTuple {}) = TagDunno +combineAltInfo (TagTuple {}) TagEPT = TagDunno combineAltInfo (TagTuple is1) (TagTuple is2) = TagTuple (zipWithEqual combineAltInfo is1 is2) -combineAltInfo (TagTagged) ti = ti -combineAltInfo ti TagTagged = ti type TagSigEnv = IdEnv TagSig data TagEnv p = TE { te_env :: TagSigEnv @@ -75,48 +83,58 @@ makeTagged env = TE { te_env = te_env env noSig :: TagEnv p -> BinderP p -> (Id, TagSig) noSig env bndr - | isUnliftedType (idType var) = (var, TagSig TagProper) - | otherwise = (var, TagSig TagDunno) + | isUnliftedType (idType var) = (var, TagVal TagEPT) + | otherwise = (var, TagVal TagDunno) where var = getBinderId env bndr --- | Look up a sig in the given env -lookupSig :: TagEnv p -> Id -> Maybe TagSig -lookupSig env fun = lookupVarEnv (te_env env) fun - --- | Look up a sig in the env or derive it from information --- in the arg itself. +-- | Look up the return-value tag of a function for saturated call analysis. +-- Returns 'Just retInfo' if the function binding has a 'TagFun' signature, +-- 'Nothing' otherwise. +lookupReturnInfo :: TagEnv p -> Id -> Maybe TagInfo +lookupReturnInfo env fun = case lookupVarEnv (te_env env) fun of + Just (TagFun ret_info) -> Just ret_info + 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) -- Nullary data constructors like True, False | Just dc <- isDataConWorkId_maybe var , isNullaryRepDataCon dc , not for_bytecode - = TagProper + = TagEPT | isUnliftedType (idType var) - = TagProper + = TagEPT - -- Variables in the environment. - | Just (TagSig info) <- lookupVarEnv (te_env env) var - = info + -- 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 + = case sig of + TagVal info -> info + TagFun _ -> TagEPT | Just lf_info <- idLFInfo_maybe var , not for_bytecode = case lf_info of -- Function, tagged (with arity) LFReEntrant {} - -> TagProper + -> TagEPT -- Thunks need to be entered. LFThunk {} -> TagDunno -- Constructors, already tagged. LFCon {} - -> TagProper + -> TagEPT LFUnknown {} -> TagDunno LFUnlifted {} - -> TagProper + -> TagEPT -- Shouldn't be possible. I don't think we can export letNoEscapes LFLetNoEscape {} -> panic "LFLetNoEscape exported" @@ -126,19 +144,13 @@ lookupInfo env (StgVarArg var) for_bytecode = te_bytecode env lookupInfo _ (StgLitArg {}) - = TagProper + = TagEPT isDunnoSig :: TagSig -> Bool -isDunnoSig (TagSig TagDunno) = True -isDunnoSig (TagSig TagProper) = False -isDunnoSig (TagSig TagTuple{}) = False -isDunnoSig (TagSig TagTagged{}) = False - -isTaggedInfo :: TagInfo -> Bool -isTaggedInfo TagProper = True -isTaggedInfo TagTagged = True -isTaggedInfo _ = False +isDunnoSig (TagVal TagDunno) = True +isDunnoSig _ = False +-- | Extend the tag environment. extendSigEnv :: TagEnv p -> [(Id,TagSig)] -> TagEnv p extendSigEnv env@(TE { te_env = sig_env }) bndrs = env { te_env = extendVarEnvList sig_env bndrs } ===================================== testsuite/tests/core-to-stg/T14895.stderr ===================================== @@ -8,7 +8,7 @@ T14895.go [GblId, Arity=2, Str=<MC(1,L)><1L>, Unf=OtherCon []] = {} \r [f ds] case ds of wild { - GHC.Internal.Data.Either.Left e [Occ=Once1] -> wild<TagProper>; + GHC.Internal.Data.Either.Left e [Occ=Once1] -> wild<TagVal[TagEPT]>; GHC.Internal.Data.Either.Right a1 [Occ=Once1] -> let { go_sat [Occ=Once1] :: b ===================================== testsuite/tests/simplCore/should_compile/T4201.stdout ===================================== @@ -1,4 +1,4 @@ lift :: Foo -> T - [HasNoCafRefs, TagSig: <TagProper>, LambdaFormInfo: LFReEntrant 1, - Arity: 1, Strictness: <1!A>, CPR: 1, + [HasNoCafRefs, TagSig: <TagFun[TagEPT]>, + LambdaFormInfo: LFReEntrant 1, Arity: 1, Strictness: <1!A>, CPR: 1, Unfolding: Core: <vanilla> bof `cast` (Sym N:Foo ->_R <T>_R)] ===================================== testsuite/tests/simplCore/should_run/T27005.hs ===================================== @@ -0,0 +1,14 @@ +module Main (main) where +import GHC.Exts.Heap (GenClosure(..), getClosureData) +import T27005_aux (T(..), S(..), f) +import System.Exit + +main :: IO () +main = do + let !t = MkT (MkS (pure ()) 0) + dup <- f t + c <- getClosureData dup + case c of + ThunkClosure{} -> putStrLn "FAIL" >> exitFailure + APClosure{} -> putStrLn "FAIL" >> exitFailure + _ -> putStrLn "OK" ===================================== testsuite/tests/simplCore/should_run/T27005.stdout ===================================== @@ -0,0 +1 @@ +OK ===================================== testsuite/tests/simplCore/should_run/T27005_aux.hs ===================================== @@ -0,0 +1,12 @@ +module T27005_aux (T(..), S(..), f) where +import GHC.Stack + +class Monad m => C m +instance C IO + +data S = MkS !(IO ()) Int +data T = MkT !S + +{-# SPECIALISE f :: HasCallStack => T -> IO T #-} +f :: (C m, HasCallStack) => T -> m T +f (MkT a) = do () <- pure (); pure $! MkT a ===================================== testsuite/tests/simplCore/should_run/all.T ===================================== @@ -122,3 +122,4 @@ test('AppIsHNF', normal, compile_and_run, ['-O']) test('T24359b', normal, compile_and_run, ['-O']) test('T23429', normal, compile_and_run, ['-O']) test('T27071', normal, compile_and_run, ['-O -fworker-wrapper-cbv']) +test('T27005', [], multimod_compile_and_run, ['T27005', '-O']) ===================================== testsuite/tests/simplStg/should_compile/T24806.hs ===================================== @@ -7,10 +7,10 @@ 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]>) = +-- (T24806.$wgo, <TagFun[TagTuple[TagEPT, TagEPT]]>) = -- -- in the dump output. --- See Note [Bottom functions are TagTagged] for details why. +-- See Note [Bottom functions are TagBottoming] 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 ===================================== testsuite/tests/simplStg/should_compile/T24806.stderr ===================================== @@ -1,99 +1,77 @@ ==================== CodeGenAnal STG: ==================== -lvl6 :: GHC.Prim.Addr# +lvl6 :: GHC.Internal.Prim.Addr# [GblId, Unf=OtherCon []] = "T24806.hs"#; -lvl4 :: GHC.Prim.Addr# +lvl4 :: GHC.Internal.Prim.Addr# [GblId, Unf=OtherCon []] = "T24806"#; -lvl2 :: GHC.Prim.Addr# +lvl2 :: GHC.Internal.Prim.Addr# [GblId, Unf=OtherCon []] = "main"#; -lvl :: GHC.Prim.Addr# +lvl :: GHC.Internal.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]; - }; +(T24806.Tup2, <TagFun[TagDunno]>) = + {} \r [(eta, <TagVal[TagDunno]>) (eta, <TagVal[TagDunno]>)] T24806.Tup2 [eta eta]; -(lvl1, <TagDunno>) = {} \u [] GHC.CString.unpackCString# lvl; +(T24806.Nil, <TagVal[TagEPT]>) = T24806.Nil! []; -(lvl3, <TagDunno>) = {} \u [] GHC.CString.unpackCString# lvl2; +(T24806.Cons, <TagFun[TagDunno]>) = + {} \r [(eta, <TagVal[TagDunno]>) (eta, <TagVal[TagDunno]>)] T24806.Cons [eta eta]; -(lvl5, <TagDunno>) = {} \u [] GHC.CString.unpackCString# lvl4; +(lvl1, <TagVal[TagDunno]>) = + {} \u [] GHC.Internal.CString.unpackCString# lvl; -(lvl7, <TagDunno>) = {} \u [] GHC.CString.unpackCString# lvl6; +(lvl3, <TagVal[TagDunno]>) = + {} \u [] GHC.Internal.CString.unpackCString# lvl2; -(lvl8, <TagProper>) = GHC.Types.I#! [17#]; +(lvl5, <TagVal[TagDunno]>) = + {} \u [] GHC.Internal.CString.unpackCString# lvl4; -(lvl9, <TagProper>) = GHC.Types.I#! [12#]; +(lvl7, <TagVal[TagDunno]>) = + {} \u [] GHC.Internal.CString.unpackCString# lvl6; -(lvl10, <TagProper>) = GHC.Types.I#! [21#]; +(lvl8, <TagVal[TagEPT]>) = + GHC.Internal.Stack.Types.SrcLoc! [lvl3 lvl5 lvl7 17# 12# 17# 21#]; -(lvl11, <TagProper>) = - GHC.Internal.Stack.Types.SrcLoc! [lvl3 - lvl5 - lvl7 - lvl8 - lvl9 - lvl8 - lvl10]; - -(lvl12, <TagProper>) = +(lvl9, <TagVal[TagEPT]>) = GHC.Internal.Stack.Types.PushCallStack! [lvl1 - lvl11 + lvl8 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! []; +(lvl10, <TagVal[TagDunno]>) = {} \u [] GHC.Internal.Err.undefined lvl9; Rec { -(T24806.$wgo, <TagTuple[TagProper, TagProper]>) = - {} \r [(ds, <TagProper>) (ys, <TagProper>)] - case ds of (wild, <TagProper>) { +(T24806.$wgo, <TagFun[TagTuple[TagEPT, TagEPT]]>) = + {} \r [(ds, <TagVal[TagEPT]>) (ys, <TagVal[TagEPT]>)] + case ds of (wild, <TagVal[TagEPT]>) { T24806.Nil -> - case ys of (conrep, <TagProper>) { - __DEFAULT -> (#,#) [conrep T24806.Nil]; + case ys of (wild1, <TagVal[TagEPT]>) { + __DEFAULT -> (#,#) [wild1 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]; + T24806.Cons (ds1, <TagVal[TagDunno]>) (xs, <TagVal[TagEPT]>) -> + case ys of (wild1, <TagVal[TagEPT]>) { + T24806.Nil -> lvl10; + T24806.Cons (y, <TagVal[TagDunno]>) (ys', <TagVal[TagEPT]>) -> + case T24806.$wgo xs ys' of (wild2, <TagVal[TagEPT]>) { + (#,#) (ww, <TagVal[TagEPT]>) (ww1, <TagVal[TagEPT]>) -> + let { ($wgo_sat, <TagVal[TagEPT]>) = T24806.Cons! [y ww1]; + } in (#,#) [ww $wgo_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.go, <TagFun[TagEPT]>) = + {} \r [(ds, <TagVal[TagDunno]>) (ys, <TagVal[TagDunno]>)] + case T24806.$wgo ds ys of (wild, <TagVal[TagEPT]>) { + (#,#) (ww, <TagVal[TagEPT]>) (ww1, <TagVal[TagEPT]>) -> + T24806.Tup2 [ww ww1]; }; -(T24806.Cons, <TagDunno>) = - {} \r [(eta, <TagDunno>) (eta, <TagDunno>)] T24806.Cons [eta eta]; - ===================================== testsuite/tests/simplStg/should_compile/T27005b.hs ===================================== @@ -0,0 +1,16 @@ +{-# LANGUAGE BangPatterns, UnboxedTuples #-} +module T27005b where + +-- A function returning an unboxed tuple whose single component is itself a +-- function. With the TagFun/TagVal split, `f`'s tag signature records that the +-- returned component is properly tagged (TagEPT), so when `g` scrutinises the +-- result of `f h` the binder `x` is already known to be evaluated. Hence the +-- pair `(x, x)` is built without re-evaluating `x`. +f :: (Bool -> Bool) -> (# Bool -> Bool #) +f !x = (# x #) +{-# NOINLINE f #-} + +g :: (Bool -> Bool) -> (Bool -> Bool, Bool -> Bool) +g h = + case f h of + (# !x #) -> (x, x) ===================================== testsuite/tests/simplStg/should_compile/T27005b.stderr ===================================== @@ -0,0 +1,16 @@ + +==================== CodeGenAnal STG: ==================== +(T27005b.f, <TagFun[TagTuple[TagEPT]]>) = + {} \r [(x, <TagVal[TagDunno]>)] + case x of (x1, <TagVal[TagEPT]>) { + __DEFAULT -> GHC.Internal.Types.MkSolo# [x1]; + }; + +(T27005b.g, <TagFun[TagEPT]>) = + {} \r [(h, <TagVal[TagDunno]>)] + case T27005b.f h of (ds, <TagVal[TagEPT]>) { + GHC.Internal.Types.MkSolo# (ipv, <TagVal[TagEPT]>) -> + case ipv of (x, <TagVal[TagEPT]>) { __DEFAULT -> (,) [x x]; }; + }; + + ===================================== testsuite/tests/simplStg/should_compile/all.T ===================================== @@ -24,5 +24,6 @@ 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('T27005b', 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']) ===================================== testsuite/tests/simplStg/should_compile/inferTags004.hs ===================================== @@ -7,5 +7,5 @@ x = x f :: a -> (# Int, a #) -- Adapted from a TODO in EnforceEpt. -- f's tag signature should indicate that the second component --- of its result is properly tagged: TagTuple[TagDunno,TagProper] +-- of its result is properly tagged: TagTuple[TagDunno,TagEPT] f g = case g of !g' -> (# x, g' #) ===================================== testsuite/tests/simplStg/should_compile/inferTags004.stderr ===================================== @@ -1,12 +1,12 @@ ==================== CodeGenAnal STG: ==================== Rec { -(EnforceEpt004.x, <TagDunno>) = {} \u [] EnforceEpt004.x; +(EnforceEpt004.x, <TagVal[TagDunno]>) = {} \u [] EnforceEpt004.x; end Rec } -(EnforceEpt004.f, <TagTuple[TagDunno, TagProper]>) = - {} \r [(g, <TagDunno>)] - case g of (g', <TagProper>) { +(EnforceEpt004.f, <TagFun[TagTuple[TagDunno, TagEPT]]>) = + {} \r [(g, <TagVal[TagDunno]>)] + case g of (g', <TagVal[TagEPT]>) { __DEFAULT -> (#,#) [EnforceEpt004.x g']; }; ===================================== testsuite/tests/simplStg/should_run/T27005a.hs ===================================== @@ -0,0 +1,30 @@ +{-# LANGUAGE UnboxedTuples, MagicHash #-} +-- Test for EnforceEpt mixing up tag signatures between functions and their return values +module Main (main) where + +import GHC.Exts +import GHC.Exts.Heap (GenClosure(..), getClosureData) +import System.Exit + +-- an evaluated function that returns a tuple +g :: State# RealWorld -> (# State# RealWorld, () #) +g s = (# s, () #) +{-# NOINLINE g #-} + +data S = MkS !(State# RealWorld -> (# State# RealWorld, () #)) Int +data T = MkT !S + +s :: S +s = MkS g 0 +{-# NOINLINE s #-} + +t :: T +t = MkT s + +main :: IO () +main = do + c <- getClosureData t + case c of + ThunkClosure{} -> putStrLn "FAIL: ThunkClosure" >> exitFailure + APClosure{} -> putStrLn "FAIL: APClosure" >> exitFailure + _ -> putStrLn "OK" ===================================== testsuite/tests/simplStg/should_run/T27005a.stdout ===================================== @@ -0,0 +1 @@ +OK ===================================== testsuite/tests/simplStg/should_run/all.T ===================================== @@ -21,4 +21,5 @@ 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, ['']) \ No newline at end of file +test('unpack_enum', normal, compile_and_run, ['']) +test('T27005a', normal, compile_and_run, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7fe4f2ec3ce12ea138177c81a019dcfc... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7fe4f2ec3ce12ea138177c81a019dcfc... You're receiving this email because of your account on gitlab.haskell.org.