Zubin pushed to branch wip/27627 at Glasgow Haskell Compiler / GHC

Commits:

17 changed files:

Changes:

  • compiler/GHC/Core/Lint.hs
    ... ... @@ -566,8 +566,8 @@ lintLetBind top_lvl rec_flag binder rhs rhs_ty
    566 566 
             -- Check that we have not bound bottom at a type whose values are
    567 567 
             -- assumed to be non-bottom, such as a dictionary. (See #24934, #25924, #27627).
    568 568 
             -- A deferred type error is an exception.
    569 
    -        -- See (4) in Note [NON-BOTTOM-DICTS invariant] in GHC.Core
    570 
    -       ; checkL (not (isTerminatingType binder_ty)
    569 
    +        -- See (5) in Note [NON-BOTTOM-DICTS invariant] in GHC.Core
    570 
    +       ; checkL (not (mightBeTerminatingType binder_ty)
    571 571 
                      || not (exprIsDeadEnd rhs)
    572 572 
                      || isDeferredTypeError rhs)
    573 573 
                (mkBottomTerminatingTyMsg binder)
    ... ... @@ -3827,7 +3827,7 @@ isDeferredTypeError :: CoreExpr -> Bool
    3827 3827 
     -- ^ True if it contains a call to `typeError` like -fdefer-type-errors and its
    3828 3828 
     -- relatives insert, such as
    3829 3829 
     --     case typeError @LiftedRep @() "No instance for ..."# of {}
    3830 
    --- See (4) in Note [NON-BOTTOM-DICTS invariant] in GHC.Core
    3830 
    +-- See (5) in Note [NON-BOTTOM-DICTS invariant] in GHC.Core
    3831 3831 
     isDeferredTypeError = go
    3832 3832 
       where
    3833 3833 
         go (Case scrut _ _ []) = go scrut
    ... ... @@ -3838,7 +3838,7 @@ isDeferredTypeError = go
    3838 3838 
         go _                   = False
    3839 3839
    3840 3840 
     mkBottomTerminatingTyMsg :: Id -> SDoc
    3841 
    --- See (4) in Note [NON-BOTTOM-DICTS invariant] in GHC.Core
    3841 
    +-- See (5) in Note [NON-BOTTOM-DICTS invariant] in GHC.Core
    3842 3842 
     mkBottomTerminatingTyMsg binder
    3843 3843 
       = vcat [ text "Binder of a terminating type is bound to bottom:"
    3844 3844 
              , nest 2 (ppr binder <+> dcolon <+> ppr (idType binder))

  • compiler/GHC/Core/Make.hs
    ... ... @@ -227,7 +227,7 @@ mkLitRubbish :: Type -> Maybe CoreExpr
    227 227 
     -- Fail (returning Nothing) if
    228 228 
     --    * the RuntimeRep of the Type is not monomorphic;
    229 229 
     --    * the type is (a ~# b), the type of coercion
    230 
    ---    * the type is terminating (isTerminatingType), e.g. a dictionary
    230 
    +--    * the type might be terminating (mightBeTerminatingType), e.g. a dictionary
    231 231 
     -- See INVARIANT 1, 2 and 3 of item (2) in Note [Rubbish literals]
    232 232 
     -- in GHC.Types.Literal
    233 233 
     mkLitRubbish ty
    ... ... @@ -235,7 +235,7 @@ mkLitRubbish ty
    235 235 
       = Nothing   -- Satisfy INVARIANT 1
    236 236 
       | isEqPred ty
    237 237 
       = Nothing   -- Satisfy INVARIANT 2
    238 
    -  | isTerminatingType ty
    238 
    +  | mightBeTerminatingType ty
    239 239 
       = Nothing   -- Satisfy INVARIANT 3
    240 240 
       | otherwise
    241 241 
       = Just (Lit (LitRubbish torc rep) `mkTyApps` [ty])

  • compiler/GHC/Core/Opt/WorkWrap/Utils.hs
    ... ... @@ -1068,11 +1068,11 @@ unbox_one_arg opts arg_var
    1068 1068 
     -- same type as @id@. Otherwise, no suitable filler could be found.
    1069 1069 
     mkAbsentFiller :: Module -> Id -> StrictnessMark -> Maybe CoreExpr
    1070 1070 
     mkAbsentFiller mod arg str
    1071 
    -  -- We never make a filler for a terminating type: it might be speculatively
    1072 
    -  -- evaluated or have a field projected out of it.
    1071 
    +  -- We never make a filler for a type that might be terminating: it might be
    1072 
    +  -- speculatively evaluated or have a field projected out of it.
    1073 1073 
       -- See (AF4) in Note [Absent fillers], and
    1074 1074 
       -- Note [Don't make fillers for terminating types].
    1075 
    -  | isTerminatingType arg_ty
    1075 
    +  | mightBeTerminatingType arg_ty
    1076 1076 
       = Nothing
    1077 1077
    1078 1078 
       -- The lifted case: bind 'absentError'. See (AF1) in Note [Absent fillers]

  • compiler/GHC/Core/Type.hs
    ... ... @@ -132,7 +132,9 @@ module GHC.Core.Type (
    132 132 
             mightBeLiftedType, mightBeUnliftedType,
    133 133 
             definitelyLiftedType, definitelyUnliftedType,
    134 134 
             isAlgType, isDataFamilyApp, isSatTyFamApp,
    135 
    -        isPrimitiveType, isStrictType, isTerminatingType,
    135 
    +        isPrimitiveType, isStrictType,
    136 
    +        IsTerminating(..), typeTerminating,
    137 
    +        definitelyTerminatingType, mightBeTerminatingType,
    136 138 
             unwrapUnaryClasses,
    137 139 
             isLevityTy, isLevityVar,
    138 140 
             isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy,
    ... ... @@ -2458,22 +2460,46 @@ isAlgType ty
    2458 2460 
     isStrictType :: HasDebugCallStack => Type -> Bool
    2459 2461 
     isStrictType = isUnliftedType
    2460 2462
    2461 
    -isTerminatingType :: HasDebugCallStack => Type -> Bool
    2462 
    --- ^ True <=> a term of this type cannot be bottom
    2463 
    --- This identifies the types described by
    2464 
    ---    Note [NON-BOTTOM-DICTS invariant] in GHC.Core
    2463 
    +-- | Returned by 'typeTerminating'.
    2464 
    +-- See Note [NON-BOTTOM-DICTS invariant] in GHC.Core
    2465 
    +data IsTerminating
    2466 
    +  = SurelyTerminating     -- ^ A term of this type is never bottom
    2467 
    +  | SurelyNotTerminating  -- ^ A term of this type may well be bottom
    2468 
    +  | MaybeTerminating      -- ^ We cannot tell; see (4) in the Note
    2469 
    +  deriving (Eq, Show)
    2470 
    +
    2471 
    +instance Outputable IsTerminating where
    2472 
    +  ppr = text . show
    2473 
    +
    2474 
    +typeTerminating :: HasDebugCallStack => Type -> IsTerminating
    2475 
    +-- ^ Says whether a term of this type can be bottom.
    2476 
    +-- See Note [NON-BOTTOM-DICTS invariant] in GHC.Core
    2465 2477 
     -- NB: unlifted types are not terminating types!
    2466 2478 
     --     e.g. you can write a term (loop 1)::Int# that diverges.
    2467 
    -isTerminatingType ty = case tyConAppTyCon_maybe (unwrapUnaryClasses id ty) of
    2468 
    -    Just tc -> isClassTyCon tc && not (isUnaryClassTyCon tc)
    2469 
    -               -- We ask about the type that represents the dictionary, not the
    2470 
    -               -- type we were handed, because a unary class dictionary **is** the
    2471 
    -               -- field it wraps.  A non-unary class TyCon is terminating; a
    2472 
    -               -- unary one is left here only when there is a cylce,
    2473 
    -               -- and then the dictionary really can be bottom.
    2474 
    -               -- See (1) and (3) in Note [NON-BOTTOM-DICTS invariant] in
    2475 
    -               -- GHC.Core, and (UCM3) in Note [Unary class magic]
    2476 
    -    _       -> False
    2479 
    +typeTerminating ty
    2480 
    +  | Just tc <- tyConAppTyCon_maybe unwrapped
    2481 
    +  , isClassTyCon tc
    2482 
    +  = if isUnaryClassTyCon tc
    2483 
    +    then SurelyNotTerminating   -- Only left here by a cycle; see (3)
    2484 
    +    else SurelyTerminating
    2485 
    +
    2486 
    +  | ConstraintLike <- typeTypeOrConstraint unwrapped
    2487 
    +  = MaybeTerminating            -- See (4)
    2488 
    +
    2489 
    +  | otherwise
    2490 
    +  = SurelyNotTerminating
    2491 
    +  where
    2492 
    +    unwrapped = dropForAlls (unwrapUnaryClasses dropForAlls ty)
    2493 
    +
    2494 
    +definitelyTerminatingType :: HasDebugCallStack => Type -> Bool
    2495 
    +-- ^ For callers that will evaluate a term of this type.
    2496 
    +-- See (2) in Note [NON-BOTTOM-DICTS invariant] in GHC.Core
    2497 
    +definitelyTerminatingType ty = typeTerminating ty == SurelyTerminating
    2498 
    +
    2499 
    +mightBeTerminatingType :: HasDebugCallStack => Type -> Bool
    2500 
    +-- ^ For callers that will put a bottoming term at this type.
    2501 
    +-- See (2) in Note [NON-BOTTOM-DICTS invariant] in GHC.Core
    2502 
    +mightBeTerminatingType ty = typeTerminating ty /= SurelyNotTerminating
    2477 2503
    2478 2504 
     -- | Look through unary classes, and return the first type
    2479 2505 
     -- that is not a unary class. For

  • compiler/GHC/Core/Utils.hs
    ... ... @@ -2275,7 +2275,7 @@ app_ok fun_ok primop_ok fun args
    2275 2275
    2276 2276 
           _other  -- Unlifted and terminating types;
    2277 2277 
                   -- Also c.f. the Var case of exprIsHNF
    2278 
    -         |  isTerminatingType fun_ty  -- See Note [exprOkForSpeculation and type classes]
    2278 
    +         |  definitelyTerminatingType fun_ty  -- See Note [exprOkForSpeculation and type classes]
    2279 2279 
              || definitelyUnliftedType fun_ty
    2280 2280 
              -> assertPpr (n_val_args == 0) (ppr fun $$ ppr args)
    2281 2281 
                 True  -- Both terminating types (e.g. Eq a), and unlifted types (e.g. Int#)

  • compiler/GHC/Types/Demand.hs
    ... ... @@ -91,7 +91,7 @@ import GHC.Types.Unique.FM
    91 91 
     import GHC.Types.Basic
    92 92 
     import GHC.Data.Maybe   ( orElse )
    93 93
    94 
    -import GHC.Core.Type    ( Type, isTerminatingType )
    94 
    +import GHC.Core.Type    ( Type, definitelyTerminatingType )
    95 95 
     import GHC.Core.DataCon ( splitDataProductType_maybe, StrictnessMark, isMarkedStrict )
    96 96 
     import GHC.Core.Multiplicity    ( scaledThing )
    97 97
    ... ... @@ -1064,7 +1064,7 @@ strictifyDmd = plusDmd seqDmd
    1064 1064 
     strictifyDictDmd :: Type -> Demand -> Demand
    1065 1065 
     strictifyDictDmd ty (n :* Prod b ds)
    1066 1066 
       | not (isAbs n)
    1067 
    -  , isTerminatingType ty
    1067 
    +  , definitelyTerminatingType ty
    1068 1068 
       , Just (_tc, _arg_tys, _data_con, field_tys) <- splitDataProductType_maybe ty
    1069 1069 
       = C_1N :* mkProd b (zipWith strictifyDictDmd (map scaledThing field_tys) ds)
    1070 1070 
           -- main idea: ensure it's strict

  • compiler/GHC/Types/Id/Make.hs
    ... ... @@ -498,7 +498,7 @@ mkDictSelId name clas
    498 498 
                   mkFunctionType ManyTy pred_ty res_ty
    499 499 
                  -- See Note [Type classes and linear types]
    500 500
    501 
    -    terminating = isTerminatingType res_ty || definitelyUnliftedType res_ty
    501 
    +    terminating = definitelyTerminatingType res_ty || definitelyUnliftedType res_ty
    502 502 
                       -- If the field is unlifted, it can't be bottom
    503 503 
                       -- Ditto if it's a terminating type
    504 504

  • testsuite/tests/core-to-stg/T27627a/Callee.hs
    1 
    +{-# LANGUAGE GADTs, ConstraintKinds, ScopedTypeVariables, TypeFamilies #-}
    2 
    +{-# LANGUAGE UndecidableInstances, UndecidableSuperClasses, FlexibleInstances #-}
    3 
    +{-# OPTIONS_GHC -fno-worker-wrapper #-}
    4 
    +module Callee where
    5 
    +
    6 
    +import Data.Kind (Constraint)
    7 
    +
    8 
    +-- A Constraint-kinded type family.  It always reduces to (TC a), but
    9 
    +-- unwrapUnaryClasses does not reduce type families, so it cannot walk
    10 
    +-- through this field.  See (4) in Note [NON-BOTTOM-DICTS invariant].
    11 
    +type family F a :: Constraint
    12 
    +type instance F a = TC a
    13 
    +
    14 
    +-- Not unary: a superclass field and a method field.
    15 
    +class Eq a => TC a where
    16 
    +  tcDummy :: a -> Int
    17 
    +
    18 
    +-- Unary: a single superclass field, whose type is the unreduced family
    19 
    +-- application (F a).
    20 
    +class F a => UC a
    21 
    +
    22 
    +instance TC Int where tcDummy _ = 0
    23 
    +instance UC Int
    24 
    +
    25 
    +data Dict c where
    26 
    +  Dict :: c => Dict c
    27 
    +
    28 
    +{-# NOINLINE discard #-}
    29 
    +discard :: Dict c -> Int
    30 
    +discard _ = 42
    31 
    +
    32 
    +{-# NOINLINE b #-}
    33 
    +b :: forall a. UC a => a -> Int
    34 
    +b _ = discard (Dict :: Dict (Eq a))

  • testsuite/tests/core-to-stg/T27627a/Caller.hs
    1 
    +module Caller where
    2 
    +
    3 
    +import Callee
    4 
    +
    5 
    +-- b does not use its dictionary, so a's dictionary is absent.  Worker/wrapper
    6 
    +-- must not replace it with an error thunk: at runtime a (UC t) dictionary is a
    7 
    +-- (TC t) dictionary, and Callee speculates a superclass selection out of it.
    8 
    +{-# NOINLINE a #-}
    9 
    +a :: UC t => t -> Int
    10 
    +a x = b x + 1

  • testsuite/tests/core-to-stg/T27627a/Main.hs
    1 
    +module Main where
    2 
    +
    3 
    +import Caller
    4 
    +
    5 
    +main :: IO ()
    6 
    +main = print (a (3 :: Int))

  • testsuite/tests/core-to-stg/T27627a/T27627a.stdout
    1 
    +43

  • testsuite/tests/core-to-stg/T27627a/all.T
    1 
    +test('T27627a',
    2 
    +     [extra_files(['Main.hs', 'Caller.hs', 'Callee.hs'])],
    3 
    +     multimod_compile_and_run,
    4 
    +     ['Main', '-O'])

  • testsuite/tests/core-to-stg/T27627b/Callee.hs
    1 
    +{-# LANGUAGE GADTs, ConstraintKinds, ScopedTypeVariables, QuantifiedConstraints #-}
    2 
    +{-# LANGUAGE UndecidableInstances, FlexibleInstances, RankNTypes #-}
    3 
    +{-# OPTIONS_GHC -fno-worker-wrapper #-}
    4 
    +module Callee where
    5 
    +
    6 
    +-- Not unary: a superclass field and a method field, so (TC a) is terminating.
    7 
    +class Eq a => TC a where
    8 
    +  tcDummy :: a -> Int
    9 
    +
    10 
    +-- Unary: one superclass field, of type (forall a. TC (f a)).
    11 
    +-- unwrapUnaryClasses cannot walk through a forall, so it cannot reach the
    12 
    +-- class underneath.  See (4) in Note [NON-BOTTOM-DICTS invariant].
    13 
    +class (forall a. TC (f a)) => UQ f
    14 
    +
    15 
    +newtype Id a = MkId a
    16 
    +instance Eq (Id a) where _ == _ = True
    17 
    +instance TC (Id a) where tcDummy _ = 0
    18 
    +instance UQ Id
    19 
    +
    20 
    +data Dict c where
    21 
    +  Dict :: c => Dict c
    22 
    +
    23 
    +{-# NOINLINE discard #-}
    24 
    +discard :: Dict c -> Int
    25 
    +discard _ = 42
    26 
    +
    27 
    +{-# NOINLINE b #-}
    28 
    +b :: forall f. UQ f => f Int -> Int
    29 
    +b _ = discard (Dict :: Dict (Eq (f Int)))

  • testsuite/tests/core-to-stg/T27627b/Caller.hs
    1 
    +module Caller where
    2 
    +
    3 
    +import Callee
    4 
    +
    5 
    +-- b does not use its dictionary, so a's dictionary is absent.  Worker/wrapper
    6 
    +-- must not replace it with an error thunk: Callee speculates a superclass
    7 
    +-- selection out of it.
    8 
    +{-# NOINLINE a #-}
    9 
    +a :: UQ f => f Int -> Int
    10 
    +a x = b x + 1

  • testsuite/tests/core-to-stg/T27627b/Main.hs
    1 
    +module Main where
    2 
    +
    3 
    +import Callee
    4 
    +import Caller
    5 
    +
    6 
    +main :: IO ()
    7 
    +main = print (a (MkId 3 :: Id Int))

  • testsuite/tests/core-to-stg/T27627b/T27627b.stdout
    1 
    +43

  • testsuite/tests/core-to-stg/T27627b/all.T
    1 
    +test('T27627b',
    2 
    +     [extra_files(['Main.hs', 'Caller.hs', 'Callee.hs'])],
    3 
    +     multimod_compile_and_run,
    4 
    +     ['Main', '-O'])

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help Notification message regarding https://gitlab.haskell.org/ghc/ghc/-/commit/226d0699fd676e8f54163519d35d50df95a5aca4 at 1786705617