Simon Peyton Jones pushed to branch wip/T27629 at Glasgow Haskell Compiler / GHC Commits: eed2f9cc by Simon Peyton Jones at 2026-09-03T11:17:07+01:00 Re-introduce the "weird SpecDict" case In this commit commit f80375dd4945350a1d784e436975b48b9c736eaf Author: Simon Peyton Jones <simon.peytonjones@gmail.com> Date: Sun Jun 29 15:26:58 2025 +0100 Refactor of Specialise.hs I removed a test for a dictionary with unbound type variables. This turned out to be wrong; see #27629. So this MR re-introduces it. - - - - - 6 changed files: - compiler/GHC/Core/Opt/Specialise.hs - testsuite/tests/simplCore/should_compile/Makefile - + testsuite/tests/simplCore/should_compile/T27629.hs - + testsuite/tests/simplCore/should_compile/T27629.stderr - + testsuite/tests/simplCore/should_compile/T27629Plugin.hs - testsuite/tests/simplCore/should_compile/all.T Changes: ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -1713,9 +1713,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs ; let spec_rhs_bndrs = spec_bndrs ++ inner_rhs_bndrs' (rhs_uds2, inner_dumped_dbs) = dumpUDs spec_rhs_bndrs $ dx_binds `consDictBinds` rhs_uds - -- dx_binds comes from the arguments to the call, - -- and so can mention poly_qvars but no other local binders - spec_rhs = mkLams spec_rhs_bndrs $ + spec_rhs = mkLams spec_rhs_bndrs $ wrapDictBindsE inner_dumped_dbs rhs_body' rule_rhs_args = spec_bndrs @@ -1784,8 +1782,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs , text "rule_act" <+> ppr rule_act ] --- ; pprTrace "spec_call: rule" (vcat [ -- text "poly_qvars" <+> ppr poly_qvars --- text "rule_bndrs" <+> ppr rule_bndrs +-- ; pprTrace "spec_call: rule" (vcat [ text "rule_bndrs" <+> ppr rule_bndrs -- , text "rule_lhs_args" <+> ppr rule_lhs_args -- , text "all_call_args" <+> ppr all_call_args -- , ppr spec_rule ]) $ @@ -2611,6 +2608,14 @@ specHeader subst (bndr:bndrs) (UnspecType : args) -- a wildcard binder to match the dictionary (See Note [Specialising Calls] for -- the nitty-gritty), as a LHS rule and unfolding details. specHeader subst (bndr:bndrs) (SpecDict dict_arg : args) + | let in_scope = getInScopeVars (substInScopeSet subst) + bad_dict_fv v = isLocalVar v && not (v `elemVarSet` in_scope) + , not $ isEmptyVarSet $ exprSomeFreeVars bad_dict_fv dict_arg + = -- Do not specialise if `dict_arg` has any any free vars that are /not/ in scope + -- See Note [Weird special case for SpecDict] + specHeader mod subst (bndr:bndrs) (UnspecArg : args) + + | otherwise = do { -- Make up a fresh binder to use in the RULE -- It might turn into a dict binding (via bindAuxiliaryDict) which we -- then float, so we use cloneIdBndr to get a completely fresh binder @@ -2886,13 +2891,15 @@ We could zap `k` to (Any @Type) and `a` to (Any @(Any @Type)), but that is a lot of hard work for a very strange case. So we simply refrain from specialising in this case; hence the guard - allVarSet (`elemInScopeSet` in_scope) (exprFreeVars d) -in the SpecDict cased of specHeader. - -How did this strange polymorphic mkD arise in the first place? -From GHC.Core.Opt.Utils.abstractFloats, which was abstracting -over too many type variables. But that too is now fixed; -see Note [Which type variables to abstract over] in that module. + not $ isEmptyVarSet $ exprSomeFreeVars bad_dict_fv dict_arg +in the SpecDict case of `specHeader`. + +How did this strange polymorphic mkD arise in the first place? From +GHC.Core.Opt.Utils.abstractFloats, which was abstracting over too many type +variables. But that too is now fixed; see Note [Which type variables to abstract +over] in that module. So we don't actually have a Haskell source program that +triggers it (see #27629) -- only test T27629 that uses a plugin to inject a strange +definition. -} instance Outputable DictBind where ===================================== testsuite/tests/simplCore/should_compile/Makefile ===================================== @@ -3,6 +3,12 @@ include $(TOP)/mk/boilerplate.mk include $(TOP)/mk/test.mk +# T27629 runs a plugin that injects a Core binding +# that made the specialiser crash +T27629: + '$(TEST_HC)' $(TEST_HC_OPTS) --make -package ghc -dynamic-too -c T27629Plugin.hs + '$(TEST_HC)' $(TEST_HC_OPTS) -c -O -fpolymorphic-specialisation -dcore-lint T27629.hs + # T18815 should not have a non-recursive join-point for 'go' # Previously we ended up with # join {go_sPI w_sQ3 = case w_sQ3 of { GHC.Types.I# ww1_sQ6 -> ===================================== testsuite/tests/simplCore/should_compile/T27629.hs ===================================== @@ -0,0 +1,29 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# OPTIONS_GHC -fplugin=T27629Plugin #-} + +-- The plugin rewrites 'poly' to the example of +-- Note [Weird special case for SpecDict]: +-- +-- poly = /\x. \t. split @T (mkD @x MkT) [t] +-- +-- where mkD :: forall a. T -> C T is a new top-level binding +-- (mkD = /\a. \_. $fCT), so the tyvar x is free in the dictionary +-- *expression* but not in its *type* (C T). +module T27629 (poly, split, T (..), C (..)) where + +import Data.Kind (Type) + +data T = MkT + +class C b where + meth :: b -> b + +instance C T where + meth x = x + +split :: C b => [b] -> [b] +split [] = [] +split (x : xs) = meth x : split xs + +poly :: forall (x :: Type). T -> [T] +poly t = [t] ===================================== testsuite/tests/simplCore/should_compile/T27629.stderr ===================================== @@ -0,0 +1 @@ +ReproPlugin: injected weird SpecDict call into poly ===================================== testsuite/tests/simplCore/should_compile/T27629Plugin.hs ===================================== @@ -0,0 +1,94 @@ +-- Injects the example of Note [Weird special case for SpecDict] in +-- GHC.Core.Opt.Specialise, which cannot be written in source Haskell: +-- a call whose dictionary argument mentions a type variable that is +-- free in the dictionary expression but not in its type. +-- +-- Runs before the main Core pipeline (in particular before the +-- Specialiser). It adds +-- +-- mkD :: forall a. T -> C T {-# NOINLINE mkD #-} +-- mkD = /\a. \_. $fCT +-- +-- and rewrites poly = /\x. \t. [t] +-- to poly = /\x. \t. split @T (mkD @x MkT) [t] +{-# LANGUAGE CPP #-} +module T27629Plugin (plugin) where + +import GHC.Core.Make (mkCoreApps, mkListExpr) +import GHC.Core.Predicate (getClassPredTys_maybe) +import GHC.Plugins +#if __GLASGOW_HASKELL__ >= 1000 +import GHC.Types.InlinePragma (neverInlinePragma) +#else +import GHC.Types.Basic (neverInlinePragma) +#endif + +plugin :: Plugin +plugin = + defaultPlugin + { installCoreToDos = \_ todos -> + return (CoreDoPluginPass "inject-weird-specdict" pass : todos) + , pluginRecompile = purePlugin + } + +pass :: ModGuts -> CoreM ModGuts +pass guts = do + let binds = mg_binds guts + + dfun = case [b | b <- bindersOfBinds binds, isDFunId b] of + (b : _) -> b + [] -> panic "ReproPlugin: no dfun binding in module" + + dictTy = idType dfun -- C T + tyT = case getClassPredTys_maybe dictTy of + Just (_cls, [t]) -> t + _ -> panic "ReproPlugin: dfun type is not C T" + + mkTCon = case tyConDataCons (tyConAppTyCon tyT) of + (dc : _) -> dataConWorkId dc + [] -> panic "ReproPlugin: T has no data constructors" + + findTopId nm = + case [b | b <- bindersOfBinds binds, occNameString (getOccName b) == nm] of + (b : _) -> b + [] -> panic ("ReproPlugin: no top-level binding " ++ nm) + + splitId = findTopId "split" + polyId = findTopId "poly" + + uMkD <- getUniqueM + uTv <- getUniqueM + uWild <- getUniqueM + + let aTv = mkTyVar (mkSystemName uTv (mkTyVarOcc "a")) liftedTypeKind + mkDTy = mkSpecForAllTys [aTv] (mkFunctionType ManyTy tyT dictTy) + mkDId = + setInlinePragma + (mkExportedVanillaId (mkSystemName uMkD (mkVarOcc "mkD")) mkDTy) + neverInlinePragma + wild = mkSysLocal (fsLit "eta") uWild ManyTy tyT + mkDBind = NonRec mkDId (mkLams [aTv, wild] (Var dfun)) + + rewritePoly rhs + | (bndrs, _body) <- collectBinders rhs + , (x : _) <- reverse (filter isTyVar bndrs) + , (t : _) <- filter isId bndrs + = mkLams bndrs $ + mkCoreApps + (Var splitId) + [ Type tyT + , mkCoreApps (Var mkDId) [Type (mkTyVarTy x), Var mkTCon] + , mkListExpr tyT [Var t] + ] + | otherwise = + pprPanic "ReproPlugin: unexpected shape of poly" (ppr rhs) + + go (b, rhs) + | b == polyId = (b, rewritePoly rhs) + | otherwise = (b, rhs) + + -- One top-level Rec, so bind order is irrelevant. + binds' = [Rec (map go (flattenBinds binds) ++ flattenBinds [mkDBind])] + + putMsgS "ReproPlugin: injected weird SpecDict call into poly" + return guts {mg_binds = binds'} ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -611,3 +611,4 @@ test('T27296', [], makefile_test, ['T27296']) test('T27296b', [], makefile_test, ['T27296b']) test('T27589', [grep_errmsg(r'wombat')], compile, ['-O -ddump-simpl -dno-typeable-binds -dsuppress-uniques']) test('T27590', [grep_errmsg(r'wombat')], compile, ['-O -ddump-simpl -dno-typeable-binds -dsuppress-uniques']) +test('T27629', only_ways(['optasm']), makefile_test, ['T27629']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/eed2f9cccb80bddaa047bab6f754b491... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/eed2f9cccb80bddaa047bab6f754b491... 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