+section: compiler

+synopsis: Fix a bug where an absent dictionary argument of a unary class could

+  be replaced by an error thunk, which GHC then evaluated, crashing the program.

+mrs:

+issues: #27627

+It is a global invariant that

+     a dictionary-typed expression is never bottom,

+The exception is unary classes; see (1) below.

+GHC.Core.Type.isTerminatingType says which types the invariant covers.

+How are we so sure about this?  GHC builds a dictionary in only two ways:

+(1) Unary classes

+

+The dictionary of a unary class is not a data constructor application at all:

+it *is* its single field.  See Note [Unary class magic] in GHC.Core.TyCon.

+So for

+

+   class Eq a => C1 a where { op :: a -> a }  -- Two fields: not unary

+   class Eq a => C2 a                         -- One field:  unary

+   class D a where { meth :: a -> a }         -- One field:  unary

+

+a (C1 a) dictionary is a data constructor application, so it cannot be bottom.

+A (C2 a) dictionary is precisely the (Eq a) dictionary it wraps, which cannot

+be bottom either.  But a (D a) dictionary is precisely the function `meth`, and

+the programmer can write

+

+   instance D Int where meth = undefined

+

+so it can perfectly well bottom.

+

+`isTerminatingType` therefore looks through unary classes, one field at a time,

+until it reaches a type that is not a unary class:

+

+   isTerminatingType (C1 a) = True    -- Stops at once: C1 is not unary

+   isTerminatingType (C2 a) = True    -- Looks through C2, reaches (Eq a)

+   isTerminatingType (D a)  = False   -- Looks through D,  reaches (a -> a)

+

+(2) Two kinds of callers, pulling in opposite directions

+

+Some code __relies__ on a dictionary being non-bottom, and evaluates one eagerly

+on the basis of that:

+

+   * -fdicts-strict makes dictionary arguments strict.

+     See GHC.Types.Demand.strictifyDictDmd

+

+   * exprOkForSpeculation says that (eq_sel d) terminates, so that

+        case (eq_sel d) of _ -> blah

+     can be discarded (exprOkToDiscard), or evaluated ahead of time.  See

+     Note [exprOkForSpeculation and type classes] in GHC.Core.Utils and

+     Note [Speculative evaluation] in GHC.CoreToStg.Prep

+

+Other code would otherwise __create__ a bottom value at a dictionary type, and

+it must not:

+

+   * Worker/wrapper replaces an absent argument with an error thunk or a

+     rubbish literal.  See Note [Don't make fillers for terminating types]

+     in GHC.Core.Opt.WorkWrap.Utils

+

+isTerminatingType is the condition used by both, so we the latter

+kind of caller doesn't put bottoms in places where the former kind of

+caller requires them to be absent.

+

+The result of `isTerminatingType` depnds only on the type at the end of the

+chain of fields, so `isTerminatingType` returns the same thing for a unary class

+and its field: if it says False for (C2 a) then it also says False for (Eq a).

+#27627 is an example of how we got it wrong before.  `isTerminatingType` used

+to stop at the unary class C2 rather than look through it, so worker/wrapper

+made an error thunk for a (C2 a) dictionary, while exprOkForSpeculation

+evaluated that very same value as a (Eq a) dictionary.

+

+(3) Cyclic superclasses

+

+With UndecidableSuperClasses the chain of fields can loop back on itself:

+

+   class D2 a => D1 a

+   class D1 a => D2 a

+

+`isTerminatingType` returns false as soon as it detects a cycle

+

+(4) Keeping the invariant true

+

+We can check the invariant in core lint: `lintLetBind` rejects a binding

+whose type is terminating and whose right hand side is bottom. It checks

+bindings only, which is where the absent-filler machinery of worker/wrapper and

+Specialise puts such values.

+However, there is a complication. With -fdefer-type-errors (and

+-fdefer-typed-holes, and friends) GHC binds a dictionary it could not solve to

+`typeError`, which is bottom:

+   $dEq :: Eq T

+   $dEq = case typeError "No instance for (Eq T) ..."# of {}

+`GHC.Core.Lint.isDeferredTypeError` handles this.

+dataConInstArgTys      :: DataCon -> [Type] -> [Scaled Type]

+        -- Check that we have not bound bottom at a type whose values are

+        -- assumed to be non-bottom, such as a dictionary. (See #24934, #25924, #27627).

+        -- A deferred type error is an exception.

+        -- See (4) in Note [NON-BOTTOM-DICTS invariant] in GHC.Core

+       ; checkL (not (isTerminatingType binder_ty)

+                 || not (exprIsDeadEnd rhs)

+                 || isDeferredTypeError rhs)

+           (mkBottomTerminatingTyMsg binder)

+

+isDeferredTypeError :: CoreExpr -> Bool

+-- ^ True if it contains a call to `typeError` like -fdefer-type-errors and its

+-- relatives insert, such as

+--     case typeError @LiftedRep @() "No instance for ..."# of {}

+-- See (4) in Note [NON-BOTTOM-DICTS invariant] in GHC.Core

+isDeferredTypeError = go

+  where

+    go (Case scrut _ _ []) = go scrut

+    go (App fun _)         = go fun

+    go (Cast expr _)       = go expr

+    go (Tick _ expr)       = go expr

+    go (Var v)             = v `hasKey` typeErrorIdKey

+    go _                   = False

+

+mkBottomTerminatingTyMsg :: Id -> SDoc

+-- See (4) in Note [NON-BOTTOM-DICTS invariant] in GHC.Core

+mkBottomTerminatingTyMsg binder

+  = vcat [ text "Binder of a terminating type is bound to bottom:"

+         , nest 2 (ppr binder <+> dcolon <+> ppr (idType binder))

+         , text "A value of this type is assumed never to be bottom,"

+         , text "so GHC may evaluate this binding without being asked to." ]

+

+type (isTerminatingType): a non-unary class dictionary, a unary class dictionary

+that wraps a non-unary class dictionary, a boxed equality, or a constraint tuple.

+  * #27627: we selected a superclass from an absent dictionary of a unary class

+   class, might be bottom, because it is represented by its single field alone.

+   It is bottom exactly when a value of that field's type can be bottom, so

+   GHC.Core.Type.isTerminatingType looks through unary classes to decide.  For

+

+       class Eq a => C2 a                    -- Field: an (Eq a) dictionary

+       class D a where { meth :: a -> a }    -- Field: a function

+

+   a (C2 a) dictionary cannot be bottom but a (D a) dictionary can.

+   See Note [NON-BOTTOM-DICTS invariant] in GHC.Core.

+        unwrapUnaryClasses,

+import GHC.Core.TyCon.Set( TyConSet, emptyTyConSet, elemTyConSet, extendTyConSet )

+import {-# SOURCE #-} GHC.Core.DataCon( dataConInstArgTys )

+

+isTerminatingType ty = case tyConAppTyCon_maybe (unwrapUnaryClasses id ty) of

+               -- We ask about the type that represents the dictionary, not the

+               -- type we were handed, because a unary class dictionary **is** the

+               -- field it wraps.  A non-unary class TyCon is terminating; a

+               -- unary one is left here only when there is a cylce,

+               -- and then the dictionary really can be bottom.

+               -- See (1) and (3) in Note [NON-BOTTOM-DICTS invariant] in

+               -- GHC.Core, and (UCM3) in Note [Unary class magic]

+-- | Look through unary classes, and return the first type

+-- that is not a unary class. For

+--

+--     class Eq a => C2 a                         -- Unary

+--     class D a where { meth :: a -> a }         -- Unary

+--     class Eq a => C1 a where { op :: a -> a }  -- Not unary

+--

+-- this returns (Eq a) for (C2 a), (a -> a) for (D a), and (C1 a) unchanged.

+--

+-- With UndecidableSuperClasses we can have a cycle:

+--

+--     class D2 a => D1 a

+--     class D1 a => D2 a

+--

+-- so we stop and return when we detect a cycle.

+-- See Note [Unary class magic] in GHC.Core.TyCon

+unwrapUnaryClasses :: (Type -> Type)  -- ^ Normalise a type before each step.

+                                      -- Pass 'id' to leave it alone, or

+                                      -- 'GHC.Types.RepType.unwrapType' to see

+                                      -- through newtypes, casts and foralls

+                   -> Type -> Type

+unwrapUnaryClasses norm = go emptyTyConSet

+  where

+    go :: TyConSet -> Type -> Type

+    go seen ty

+      | Just (tc, tys)        <- splitTyConApp_maybe (norm ty)

+      , Just (_cls, dict_con) <- isUnaryClassTyCon_maybe tc

+      , [fld_ty]              <- map scaledThing (dataConInstArgTys dict_con tys)

+      , not (tc `elemTyConSet` seen)

+      = go (seen `extendTyConSet` tc) fld_ty

+      | otherwise

+      = ty

+

+   C is a unary class whose one field is the method `op`, so a (C a) dictionary

+   **is** that function and can be bottom.  Hence

+   (sc_sel (d :: D a)) might not be terminating.

+   See (1) in Note [NON-BOTTOM-DICTS invariant] in GHC.Core.

+  -- Use 'unwrapType' to look through casts, newtypes and foralls, and

+  -- 'unwrapUnaryClasses' to look through unary classes (which are 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.

+  | Just tc <- tyConAppTyCon_maybe (unwrapUnaryClasses unwrapType ty)

+{-# LANGUAGE GADTs, ConstraintKinds, ScopedTypeVariables #-}

+{-# OPTIONS_GHC -fno-worker-wrapper #-}

+module Callee where

+

+-- TC is not unary: it has a superclass field and a method field.  So $p1TC is

+-- an ordinary selector, ($p1TC d) is not a trivial expression, and CorePrep

+-- gives it a binding of its own.

+class Eq a => TC a where

+  tcDummy :: a -> Int

+

+-- UC is unary: a single superclass field.  Its dictionary is precisely the

+-- (TC a) dictionary it wraps, so it cannot be bottom either.

+class TC a => UC a where {}

+

+instance TC Int where tcDummy _ = 0

+instance UC Int

+

+data Dict c where

+  Dict :: c => Dict c

+

+-- Ignores its argument, so the Dict below is absent-demanded, and hence so is

+-- the UC dictionary that Dict carries.

+{-# NOINLINE discard #-}

+discard :: Dict c -> Int

+discard _ = 42

+

+-- The Core of the body is

+--     discard (Dict @(Eq a) ($p1TC ($p1UC d)))

+-- The constructor application is a value, so CorePrep floats the selection

+-- out of the argument and evaluates it at the head of b.  -fno-worker-wrapper

+-- keeps the dictionary parameter, so the caller has to pass one.

+{-# NOINLINE b #-}

+b :: forall a. UC a => a -> Int

+b _ = discard (Dict :: Dict (Eq a))

+module Caller where

+

+import Callee

+

+-- b does not use its dictionary, so a's dictionary is absent.  Worker/wrapper

+-- used to drop it and pass an error thunk to b in its place, which b then

+-- evaluated.  Now isTerminatingType looks through the unary class UC, sees the

+-- (TC a) dictionary underneath, and refuses to make a filler.

+{-# NOINLINE a #-}

+a :: UC t => t -> Int

+a x = b x + 1

+module Main where

+import Caller

+main :: IO ()

+main = print (a (1 :: Int))

+43

+test('T27627',

+     [extra_files(['Main.hs', 'Caller.hs', 'Callee.hs'])],

+     multimod_compile_and_run,

+     ['Main', '-O'])