Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: bc6c0db6 by sheaf at 2026-10-31T09:22:20-04:00 mightBeFunTy: hotfix for #27979 ce01ccb6 refactored 'GHC.Types.RepType.mightBeFunTy' to look through unary classes. That change introduced the helper function 'unwrap_type' which was supposed to always return an unwrapped type, but its fallback equation mistakenly returned the original type. This caused the subsequent 'tyConAppTyCon_maybe' to fail in cases where it should succeed (e.g. looking through foralls). In this commit, we move all the unary class unwrapping logic into 'unwrapType' where it belonged from the start, and update the documentation of 'unwrapType' to better explain what it should be used for (#26695). Fixes #27979 #26695 ------------------------- Metric Increase: T5642 ------------------------- - - - - - 6 changed files: - + changelog.d/T27979 - compiler/GHC/Types/RepType.hs - + testsuite/tests/codeGen/should_compile/T27979.hs - + testsuite/tests/codeGen/should_compile/T27979.stderr - testsuite/tests/codeGen/should_compile/all.T - testsuite/tests/count-deps/CountDepsParser.stdout Changes: ===================================== changelog.d/T27979 ===================================== @@ -0,0 +1,10 @@ + +section: compiler +issues: #27979 +mrs: !16873 +synopsis: + Avoid performance regressions when evaluating values whose types are + polymorphic +description: + Evaluating a value of a type such as ``forall a. D a`` for a datatype ``D`` + again uses fast inline code instead of a slower fallback in the RTS. ===================================== compiler/GHC/Types/RepType.hs ===================================== @@ -32,7 +32,6 @@ import GHC.Types.Basic (Arity, RepArity) import GHC.Core.DataCon import GHC.Core.Coercion import GHC.Core.TyCon -import GHC.Core.TyCon.Set import GHC.Core.TyCon.RecWalk import GHC.Core.TyCo.Rep import GHC.Core.Type @@ -80,13 +79,21 @@ isNvUnaryRep :: [PrimRep] -> Bool isNvUnaryRep [_] = True isNvUnaryRep _ = False --- | Gets rid of the stuff that prevents us from understanding the --- runtime representation of a type. Including: --- 1. Casts --- 2. Newtypes --- 3. Foralls --- 4. Synonyms --- But not type/data families, because we don't have the envs to hand. +-- | Look through casts, foralls, type synonyms, newtypes and unary classes +-- at the top-level of a type. +-- +-- Does /not/ reduce type family applications nor peel off data family instance +-- newtypes. +-- +-- Use this function to try to discover the 'TyCon' used to represent values +-- of a type at runtime: +-- +-- * the function arrow: the values are functions; +-- * a data type: the values are built from its data constructors; +-- * a primitive type constructor (e.g. @Int#@, @ByteArray#@). +-- +-- __Warning__: do __not__ use this function to compute the runtime +-- representation of a type (#26695). That's what 'typePrimRep' is for. unwrapType :: Type -> Type unwrapType ty | Just (_, unwrapped) @@ -105,12 +112,20 @@ unwrapType ty -- cf. GHC.Core.Coercion.unwrapNewTypeStepper stepper :: RecTcChecker -> TyCon -> [Type] -> NormaliseStepResult () stepper rec_nts tc tys + -- Unwrap newtypes. | Just (ty', _) <- instNewTyCon_maybe tc tys - = case checkRecTc rec_nts tc of - Just rec_nts' -> NS_Step rec_nts' (go ty') () - Nothing -> NS_Abort -- infinite newtypes + = step ty' + -- Look through unary classes. + | Just (_cls, dc) <- isUnaryClassTyCon_maybe tc + , [Scaled _ ty'] <- dataConInstArgTys dc tys + = step ty' | otherwise = NS_Done + where + step ty' = + case checkRecTc rec_nts tc of + Just rec_nts' -> NS_Step rec_nts' (go ty') () + Nothing -> NS_Abort -- fell into a loop (e.g. recursive newtypes) -- | Count the arity of a function post-unarisation, including zero-width arguments. -- @@ -711,7 +726,7 @@ primRepToType = anyTypeOfKind . mkTYPEapp . primRepToRuntimeRep -------------- mightBeFunTy :: Type -> Bool -- ^ Might this type be a function type, including after looking through --- newtypes and reducing type family applications? +-- newtypes, unary classes, and reducing type family applications? -- -- In particular, returns @True@ for @IO a@: after unwrapping the newtype, -- we get @State# RealWorld -> (# State# RealWorld, a #)@, which is indeed a @@ -734,26 +749,9 @@ mightBeFunTy ty -- definitely not a function type. | definitelyUnliftedType ty = False - | Just tc <- tyConAppTyCon_maybe (unwrap_type ty) + | Just tc <- tyConAppTyCon_maybe (unwrapType ty) -- A proper datatype (such as 'Int' or 'Maybe Bool') is definitely not -- a function type. (This does not include newtypes nor type families.) = not $ isBoxedDataTyCon tc | otherwise = True - - where - -- Use 'unwrapType' to look through casts, newtypes and foralls. - -- Separately, look through unary classes (supposed to be transparent as per - -- Note [Unary class magic] in GHC.Core.TyCon). We don't try to reduce type - -- family applications, as we don't have a FamInstEnv to hand. - unwrap_type = go emptyTyConSet - where - go seen_tcs ty - | Just (tc, tys) <- splitTyConApp_maybe (unwrapType ty) - , Just (_cls, unary_dc) <- isUnaryClassTyCon_maybe tc - , [inst_meth_ty] <- map scaledThing (dataConInstArgTys unary_dc tys) - = if tc `elemTyConSet` seen_tcs - then ty -- cycle detected: bail out - else go (seen_tcs `extendTyConSet` tc) inst_meth_ty - | otherwise - = ty ===================================== testsuite/tests/codeGen/should_compile/T27979.hs ===================================== @@ -0,0 +1,19 @@ +module T27979 (poly, elemAge) where + +data Box a = Box Int [a] + +newtype Age = Age Int + +mkBox :: Int -> Box a +mkBox n = Box n [] +{-# NOINLINE mkBox #-} + +cafP :: Box a +cafP = mkBox 1 + +poly :: Int -> Int +poly i = case (cafP :: Box ()) of Box n _ -> n + i + +elemAge :: [Age] -> Int +elemAge (Age n : _) = n +elemAge [] = 0 ===================================== testsuite/tests/codeGen/should_compile/T27979.stderr ===================================== @@ -0,0 +1,4 @@ +!! The Cmm must not contain a call to the RTS's "stg_ap_0" fast entry point +!! (generic evaluation of an unknown closure). +!! +!! See #27979. ===================================== testsuite/tests/codeGen/should_compile/all.T ===================================== @@ -152,3 +152,4 @@ test('T20298b', normal, compile, ['-O2 -dno-bignum-rules -ddump-simpl -dno-typea test('T20298c', normal, compile, ['-O2 -dno-builtin-rules -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques']) test('T27368', normal, compile, ['-O']) +test('T27979', [req_cmm, check_errmsg('stg_ap_0_fast')], compile, ['-O -ddump-cmm -dno-typeable-binds -dsuppress-uniques']) ===================================== testsuite/tests/count-deps/CountDepsParser.stdout ===================================== @@ -58,7 +58,6 @@ GHC.Core.TyCo.Tidy GHC.Core.TyCon GHC.Core.TyCon.Env GHC.Core.TyCon.RecWalk -GHC.Core.TyCon.Set GHC.Core.Type GHC.Core.Unfold GHC.Core.Unfold.Make View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bc6c0db64a4a3e0f217c2db94cbdc067... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bc6c0db64a4a3e0f217c2db94cbdc067... 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