+section: compiler

+synopsis: Fix a bug where the specialiser could drop an argument that the

+  function's stable unfolding still used, resulting in a runtime crash.

+mrs: !16519

+issues: #27703

+section: compiler

+synopsis: Fix a bug where a class declared abstractly in an hs-boot file was

+  assumed not to be unary, so GHC speculatively evaluated a dictionary that

+  could be bottom, crashing the program.

+mrs: !16519

+issues: #27704

+Wrinkle (NBD2)

+  A class declared in an hs-boot file is an AbstractTyCon inside the module

+  loop:

+      module Callee where { class UC (a :: Type) }                -- Callee.hs-boot

+      module Callee where { class UC a where { ucm :: a -> a } }  -- Callee.hs

+  isUnaryClassTyCon returns False for it, but compiling the real declaration

+  may reveal a UnaryClassTyCon, whose dictionary is `ucm` and can be bottom.

+

+  Speculating a superclass selection from such a dictionary crashes (#27704).

+  So we must treat an AbstractTyCon as possibly unary.

+

+import GHC.Core.DataCon (dataConTyCon)

+import GHC.Core.Make      ( wrapFloats )

+import GHC.Core.Opt.Monad

+             , spec_bndrs1, dx_binds, spec_args) <- specHeader env rhs_bndrs all_call_args

+                       DFunId terminating  -> DFunId terminating

+Note [Do not drop dead args from specialisations]

+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

+When specialising a function, some of its arguments may be dead. For example

+gives the CallInfo [SpecType Int, UnspecArg, SpecDict $dShowInt, UnspecArg]

+for `f @Int`, in which `x` is dead. We used to drop such an argument from the

+specialisation and pass an absent filler in its place.

+We no longer do so, because the filler is applied to the function's stable

+unfolding template rather than to its optimised RHS, and the two may differ:

+the argument can be dead in the RHS and not in the template. The specialised

+function's unfolding then contains the filler, and any call site that inlines

+it evaluates the error thunk. See #27703 for an instance of how this goes wrong.

+and Core Lint complains, even though x only appears on the LHS.

+     :: SpecEnv

+specHeader env (bndr : bndrs) (SpecType ty : args)

+            <- specHeader env2 bndrs args

+specHeader env (bndr : bndrs) (UnspecType : args)

+            <- specHeader env' bndrs args

+specHeader env (bndr : bndrs) (SpecDict d : args)

+             <- specHeader env2 bndrs args

+specHeader env (bndr : bndrs) (_ : args)

+             <- specHeader env' bndrs args

+       ; let (mb_spec_bndr, spec_arg) = (Just bndr', varToCoreExpr bndr')

+specHeader env [] _ = pure (False, env, [], [], [], [], [], [])

+specHeader env bndrs []

+        isAlgTyCon, isVanillaAlgTyCon, isClassTyCon,

+        isUnaryClassTyCon, isUnaryClassTyCon_maybe, isTerminatingTyCon,

+        isFamInstTyCon,

+isUnaryClassTyCon :: TyCon -> Bool

+isUnaryClassTyCon tc = isClassTyCon tc && isNewTyCon tc

+

+isTerminatingTyCon :: TyCon -> Bool

+-- ^ True <=> a value of type (T t1..tn), where `T` is this TyCon, cannot be bottom.

+-- The only TyCons that satisfy `isTerminatingTyCon` are non-unary class TyCons.

+-- See (UCM3) in Note [Unary class magic], and

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

+-- An AbstractTyCon returns False: it comes from an hs-boot file, and the real

+-- declaration may turn out to be a unary class. See (NBD2) in that Note.

+isTerminatingTyCon tc = isClassTyCon tc && not (isUnaryClassTyCon tc)

+                                        && not (isAbstractTyCon tc)

+

+isUnaryClassTyCon_maybe :: TyCon -> Maybe (Class, DataCon)

+isUnaryClassTyCon_maybe (TyCon { tyConDetails = details })

+  | AlgTyCon { algTcFlavour = ClassTyCon cls _

+             , algTcRhs = NewTyCon {data_con = dc} } <- details

+  = Just (cls, dc)

+  | otherwise

+  = Nothing

+

+    Just tc -> isTerminatingTyCon tc

+      DFunId terminating -> terminating

+tcIdDetails _ ty IfDFunId              = return (mkDFunIdDetails cls)

+        mkDFunIdDetails,

+       -- Bool = True <=> a dictionary of this class cannot be bottom

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

+mkDFunIdDetails :: Class -> IdDetails

+mkDFunIdDetails cls = DFunId (isTerminatingTyCon (classTyCon cls))

+

+   pp (DFunId terminating)    = text "DFunId"

+                                <> ppWhen (not terminating) (text "(may-be-bottom)")

+  = mkExportedLocalId (mkDFunIdDetails clas)

+module Callee where

+

+import Mid

+

+-- The real UC is a *unary* class: one method, no superclasses.  So a (UC a)

+-- dictionary *is* the function ucm, and it can be bottom.

+class UC a where

+  ucm :: a -> a

+

+instance UC Int where

+  ucm = undefined

+

+instance MC Int where

+  mcm _ = 7

+{-# LANGUAGE KindSignatures #-}

+module Callee where

+

+import Data.Kind (Type)

+

+-- Abstract class declaration: no context, no methods, no associated types,

+-- so GHC.Tc.TyCl builds an AbstractTyCon rather than a UnaryClassTyCon.

+class UC (a :: Type)

+module Main where

+import Mid

+import Callee ()

+

+main :: IO ()

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

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

+module Mid where

+

+import {-# SOURCE #-} Callee

+

+class UC a => MC a where

+  mcm :: a -> Int

+

+data Dict c where

+  Dict :: c => Dict c

+

+{-# NOINLINE keep #-}

+keep :: [Dict c] -> Int

+keep xs = length xs + 41

+

+{-# NOINLINE f #-}

+f :: forall a. MC a => a -> Int

+f _ = keep [Dict :: Dict (UC a)]

+42

+test('T27704',

+     [extra_files(['Main.hs', 'Mid.hs', 'Callee.hs', 'Callee.hs-boot'])],

+     multimod_compile_and_run,

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

+module Callee where

+

+import Mid ()

+

+-- Really unary: the dictionary /is/ ucm, so it can be bottom.

+class UC a where

+  ucm :: a -> a

+

+instance UC Int where

+  ucm = id

+

+instance UC a => UC [a] where

+  ucm = error "ucm[] forced"

+{-# LANGUAGE KindSignatures #-}

+module Callee where

+

+import Data.Kind (Type)

+

+-- No context, no methods, no associated types, so buildAbstractClass makes an

+-- AbstractTyCon rather than a UnaryClassTyCon: Mid cannot see that UC is unary.

+class UC (a :: Type)

+

+instance UC a => UC [a]

+module Main where

+import Mid

+import Callee ()

+

+main :: IO ()

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

+{-# LANGUAGE GADTs, ScopedTypeVariables #-}

+module Mid where

+

+import {-# SOURCE #-} Callee

+

+data Dict c where

+  Dict :: c => Dict c

+

+{-# NOINLINE keep #-}

+keep :: [Dict c] -> Int

+keep xs = length xs + 41

+

+-- Builds a (UC [a]) dictionary but never forces it.  The dfun comes from the

+-- hs-boot file, where UC looks non-unary, so its DFunId must not claim to

+-- terminate: with -fspec-eval-dictfun, CorePrep would speculate it.

+{-# NOINLINE f #-}

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

+f _ = keep [Dict :: Dict (UC [a])]

+42

+test('T27704a',

+     [extra_files(['Main.hs', 'Mid.hs', 'Callee.hs', 'Callee.hs-boot'])],

+     multimod_compile_and_run,

+     ['Main', '-O -fspec-eval-dictfun'])

+-- RHS size: {terms: 5, types: 6, coercions: 0, joins: 0/0}

+T17966.$fCBoolb [InlPrag=CONLIKE] :: forall b. Show b => C Bool b

+[LclIdX[DFunId(may-be-bottom)],

+ Arity=1,

+ Unf=Unf{Src=StableSystem, TopLvl=True,

+         Value=True, ConLike=True, WorkFree=True, Expandable=True,

+         Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)

+         Tmpl= \ (@b_anX) (v_B1 [Occ=Once1] :: Show b_anX) ->

+                 T17966.C:C @Bool @b_anX ($cm_aJp @b_anX v_B1)}]

+[LclIdX[DFunId(may-be-bottom)],

+-- Dead arguments are kept in specialisations.

+-- See Note [Do not drop dead args from specialisations] in GHC.Core.Opt.Specialise

+  = {terms: 39, types: 38, coercions: 0, joins: 0/0}

+-- RHS size: {terms: 14, types: 11, coercions: 0, joins: 0/0}

+$sfoo [InlPrag=NOINLINE[0]] :: () -> Int -> [Char]

+[LclId, Arity=2]

+  = \ (ds :: ()) (y :: Int) ->

+      GHC.Internal.Base.build

+             (GHC.Internal.Types.unpackFoldrCString# @b "!"# c n)

+             (GHC.Internal.Show.$fShowInt_$cshow y))

+            forall (ds [Occ=Once1] :: ()) ($dShow [Occ=Dead] :: Show Int).

+              foo @Int ds $dShow

+              = $sfoo ds]

+             (GHC.Internal.Types.unpackFoldrCString# @b "!"# c n)

+{-# LANGUAGE RankNTypes #-}

+module Lib (g) where

+

+{-# NOINLINE consume #-}

+consume :: Int -> Int

+consume n = n `seq` 0

+

+{-# RULES "consume/drop" [~1] forall n. consume n = 0 #-}

+

+-- A dead value argument (n) that comes *before* the dictionary we

+-- specialise on.  No implicit parameters involved.

+{-# INLINE [1] f #-}

+f :: forall a. Int -> Show a => a -> String

+f n y = show y ++ replicate (consume n) '!'

+

+{-# NOINLINE g #-}

+g :: Bool -> String

+g b = f 7 b ++ "."

+module Main where

+import Lib

+

+main :: IO ()

+main = putStrLn (g True)

+True.

+test('T27703',

+     [extra_files(['Main.hs', 'Lib.hs'])],

+     multimod_compile_and_run,

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