Simon Peyton Jones pushed to branch wip/T26724 at Glasgow Haskell Compiler / GHC
Commits:
52d00c05 by Simon Peyton Jones at 2026-01-07T10:24:21-05:00
Add missing InVar->OutVar lookup in SetLevels
As #26681 showed, the SetLevels pass was failing to map an InVar to
an OutVar. Very silly! I'm amazed it hasn't broken before now.
I have improved the type singatures (to mention InVar and OutVar)
so it's more obvious what needs to happen.
- - - - -
ab0a5594 by Cheng Shao at 2026-01-07T10:25:04-05:00
hadrian: drop deprecated pkgHashSplitObjs code path
This patch drops deprecated `pkgHashSplitObjs` code path from hadrian,
since GHC itself has removed split objs support many versions ago and
this code path is unused.
- - - - -
bb3a2ba1 by Cheng Shao at 2026-01-07T10:25:44-05:00
hadrian: remove linting/assertion in quick-validate flavour
The `quick-validate` flavour is meant for testing ghc and passing the
testsuite locally with similar settings to `validate` but faster. This
patch removes the linting/assertion overhead in `quick-validate` to
improve developer experience. I also took the chance to simplify
redundant logic of rts/library way definition in `validate` flavour.
- - - - -
7971f5dd by Cheng Shao at 2026-01-07T10:26:26-05:00
deriveConstants: clean up unused constants
This patch cleans up unused constants from `deriveConstants`, they are
not used by C/Cmm code in the RTS, nor compiler-generated code.
Co-authored-by: Codex
- - - - -
4df96993 by Cheng Shao at 2026-01-07T10:27:08-05:00
hadrian: pass -fno-omit-frame-pointer with +debug_info
This patch adds `-fno-omit-frame-pointer` as C/C++ compilation flag
when compiling with `+debug_info` flavour transformer. It's a sane
default when you care about debugging and reliable backtraces, and
makes debugging/profiling with bpf easier.
- - - - -
8a3900a3 by Aaron Allen at 2026-01-07T10:27:57-05:00
[26705] Include TyCl instances in data fam iface entry
Ensures dependent modules are recompiled when the class instances for a
data family instance change.
resolves #26705
- - - - -
a0b980af by Cheng Shao at 2026-01-07T10:28:38-05:00
hadrian: remove unused Hp2Ps/Hpc builders
This patch removes the Hp2Ps/Hpc builders from hadrian, they are
unused in the build system. Note that the hp2ps/hpc programs are still
built and not affected.
- - - - -
50a58757 by Cheng Shao at 2026-01-07T10:29:20-05:00
hadrian: only install js files to libdir for wasm/js targets
There are certain js files required for wasm/js targets to work, and
previously hadrian would install those js files to libdir
unconditionally on other targets as well. This could be a minor
annoyance for packagers especially when the unused js files contain
shebangs that interfere with the packaging process. This patch makes
hadrian only selectively install the right js files for the right
targets.
Co-authored-by: Codex
- - - - -
da40e553 by Simon Peyton Jones at 2026-01-07T10:30:00-05:00
Add flavour transformer assertions_stage1
This allows us to enable -DDEBUG assertions in the stage1 compiler
- - - - -
6a7b9938 by Simon Peyton Jones at 2026-01-07T17:43:30+00:00
Try harder to keep the substitution empty
Avoid unnecessary cloning of variables in the Simplifier.
Addresses #26724,
See Note [Keeping the substitution empty]
We get some big wins in compile time
Metrics: compile_time/bytes allocated
-------------------------------------
Baseline
Test Metric value New value Change
----------------------------------------------------------------------------
CoOpt_Singletons(normal) ghc/alloc 721,544,088 692,174,216 -4.1% GOOD
LargeRecord(normal) ghc/alloc 1,268,031,157 1,265,168,448 -0.2%
T14766(normal) ghc/alloc 918,218,533 688,432,296 -25.0% GOOD
T15703(normal) ghc/alloc 318,103,629 306,638,016 -3.6% GOOD
T17836(normal) ghc/alloc 419,174,584 418,400,824 -0.2%
T18478(normal) ghc/alloc 471,042,976 470,261,376 -0.2%
T20261(normal) ghc/alloc 573,387,162 563,663,336 -1.7%
T24984(normal) ghc/alloc 87,832,666 87,636,168 -0.2%
T25196(optasm) ghc/alloc 1,103,284,040 1,101,376,992 -0.2%
hard_hole_fits(normal) ghc/alloc 224,981,413 224,608,208 -0.2%
geo. mean -0.3%
minimum -25.0%
maximum +0.1%
Metric Decrease:
CoOpt_Singletons
T14766
T15703
- - - - -
21 changed files:
- compiler/GHC/Core/Opt/SetLevels.hs
- compiler/GHC/Core/Subst.hs
- compiler/GHC/Core/TyCo/Subst.hs
- compiler/GHC/Iface/Recomp.hs
- hadrian/doc/flavours.md
- hadrian/src/Base.hs
- hadrian/src/Builder.hs
- hadrian/src/Flavour.hs
- hadrian/src/Hadrian/Haskell/Hash.hs
- hadrian/src/Oracles/Setting.hs
- hadrian/src/Rules/Register.hs
- hadrian/src/Settings/Flavours/Validate.hs
- + testsuite/tests/driver/recomp26705/M.hs
- + testsuite/tests/driver/recomp26705/M2A.hs
- + testsuite/tests/driver/recomp26705/M2B.hs
- + testsuite/tests/driver/recomp26705/Makefile
- + testsuite/tests/driver/recomp26705/all.T
- + testsuite/tests/driver/recomp26705/recomp26705.stderr
- + testsuite/tests/simplCore/should_compile/T26681.hs
- testsuite/tests/simplCore/should_compile/all.T
- utils/deriveConstants/Main.hs
Changes:
=====================================
compiler/GHC/Core/Opt/SetLevels.hs
=====================================
@@ -91,6 +91,7 @@ import GHC.Core.Utils
import GHC.Core.Opt.Arity ( exprBotStrictness_maybe, isOneShotBndr )
import GHC.Core.FVs -- all of it
import GHC.Core.Subst
+import GHC.Core.TyCo.Subst( lookupTyVar )
import GHC.Core.Make ( sortQuantVars )
import GHC.Core.Type ( Type, tyCoVarsOfType
, mightBeUnliftedType, closeOverKindsDSet
@@ -466,8 +467,8 @@ lvlCase env scrut_fvs scrut' case_bndr ty alts
ty' = substTyUnchecked (le_subst env) ty
incd_lvl = incMinorLvl (le_ctxt_lvl env)
- dest_lvl = maxFvLevel (const True) env scrut_fvs
- -- Don't abstract over type variables, hence const True
+ dest_lvl = maxFvLevel includeTyVars env scrut_fvs
+ -- Don't abstract over type variables, hence includeTyVars
lvl_alt alts_env (AnnAlt con bs rhs)
= do { rhs' <- lvlMFE new_env True rhs
@@ -719,8 +720,11 @@ hasFreeJoin :: LevelEnv -> DVarSet -> Bool
-- (In the latter case it won't be a join point any more.)
-- Not treating top-level ones specially had a massive effect
-- on nofib/minimax/Prog.prog
-hasFreeJoin env fvs
- = not (maxFvLevel isJoinId env fvs == tOP_LEVEL)
+hasFreeJoin env fvs = anyDVarSet bad_join fvs
+ where
+ bad_join v = isJoinId v &&
+ maxIn True env v tOP_LEVEL /= tOP_LEVEL
+
{- Note [Saving work]
~~~~~~~~~~~~~~~~~~~~~
@@ -1607,10 +1611,10 @@ destLevel env fvs fvs_ty is_function is_bot
| otherwise = max_fv_id_level
where
- max_fv_id_level = maxFvLevel isId env fvs -- Max over Ids only; the
- -- tyvars will be abstracted
+ max_fv_id_level = maxFvLevel idsOnly env fvs -- Max over Ids only; the
+ -- tyvars will be abstracted
- as_far_as_poss = maxFvLevel' isId env fvs_ty
+ as_far_as_poss = maxFvLevel' idsOnly env fvs_ty
-- See Note [Floating and kind casts]
{- Note [Floating and kind casts]
@@ -1768,28 +1772,47 @@ extendCaseBndrEnv le@(LE { le_subst = subst, le_env = id_env })
, le_env = add_id id_env (case_bndr, scrut_var) }
extendCaseBndrEnv env _ _ = env
-maxFvLevel :: (Var -> Bool) -> LevelEnv -> DVarSet -> Level
-maxFvLevel max_me env var_set
- = nonDetStrictFoldDVarSet (maxIn max_me env) tOP_LEVEL var_set
+includeTyVars, idsOnly :: Bool
+idsOnly = False
+includeTyVars = True
+
+maxFvLevel :: Bool -> LevelEnv -> DVarSet -> Level
+maxFvLevel include_tyvars env var_set
+ = nonDetStrictFoldDVarSet (maxIn include_tyvars env) tOP_LEVEL var_set
-- It's OK to use a non-deterministic fold here because maxIn commutes.
-maxFvLevel' :: (Var -> Bool) -> LevelEnv -> TyCoVarSet -> Level
+maxFvLevel' :: Bool -> LevelEnv -> TyCoVarSet -> Level
-- Same but for TyCoVarSet
-maxFvLevel' max_me env var_set
- = nonDetStrictFoldUniqSet (maxIn max_me env) tOP_LEVEL var_set
+maxFvLevel' include_tyvars env var_set
+ = nonDetStrictFoldUniqSet (maxIn include_tyvars env) tOP_LEVEL var_set
-- It's OK to use a non-deterministic fold here because maxIn commutes.
-maxIn :: (Var -> Bool) -> LevelEnv -> InVar -> Level -> Level
-maxIn max_me (LE { le_lvl_env = lvl_env, le_env = id_env }) in_var lvl
+maxIn :: Bool -> LevelEnv -> InVar -> Level -> Level
+-- True <=> include tyvars
+maxIn include_tyvars env@(LE { le_subst = subst, le_env = id_env }) in_var lvl
+ | isId in_var
= case lookupVarEnv id_env in_var of
+ Nothing -> maxOut env in_var lvl
Just (abs_vars, _) -> foldr max_out lvl abs_vars
- Nothing -> max_out in_var lvl
- where
- max_out out_var lvl
- | max_me out_var = case lookupVarEnv lvl_env out_var of
- Just lvl' -> maxLvl lvl' lvl
- Nothing -> lvl
- | otherwise = lvl -- Ignore some vars depending on max_me
+ where
+ max_out out_var lvl
+ | isTyVar out_var && not include_tyvars
+ = lvl
+ | otherwise = maxOut env out_var lvl
+
+ | include_tyvars -- TyVars
+ = case lookupTyVar subst in_var of
+ Just ty -> nonDetStrictFoldVarSet (maxOut env) lvl (tyCoVarsOfType ty)
+ Nothing -> maxOut env in_var lvl
+
+ | otherwise -- Ignore free tyvars
+ = lvl
+
+maxOut :: LevelEnv -> OutVar -> Level -> Level
+maxOut (LE { le_lvl_env = lvl_env }) out_var lvl
+ = case lookupVarEnv lvl_env out_var of
+ Just lvl' -> maxLvl lvl' lvl
+ Nothing -> lvl
lookupVar :: LevelEnv -> Id -> LevelledExpr
lookupVar le v = case lookupVarEnv (le_env le) v of
=====================================
compiler/GHC/Core/Subst.hs
=====================================
@@ -380,8 +380,10 @@ substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id
old_ty = idType old_id
old_w = idMult old_id
- no_type_change = (isEmptyVarEnv tvs && isEmptyVarEnv cvs) ||
+ no_type_change = isEmptyTCvSubst subst ||
(noFreeVarsOfType old_ty && noFreeVarsOfType old_w)
+ -- isEmptyTCvSubst: see Note [Keeping the substitution empty]
+ -- in GHC.Core.TyCo.Subst
-- new_id has the right IdInfo
-- The lazy-set is because we're in a loop here, with
=====================================
compiler/GHC/Core/TyCo/Subst.hs
=====================================
@@ -960,7 +960,8 @@ substTyVarBndrUsing subst_fn subst@(Subst in_scope idenv tenv cenv) old_var
-- Assertion check that we are not capturing something in the substitution
old_ki = tyVarKind old_var
- no_kind_change = noFreeVarsOfType old_ki -- verify that kind is closed
+ no_kind_change = isEmptyTCvSubst subst || noFreeVarsOfType old_ki
+ -- isEmptyTCvSubst: see Note [Keeping the substitution empty]
no_change = no_kind_change && (new_var == old_var)
-- no_change means that the new_var is identical in
-- all respects to the old_var (same unique, same kind)
@@ -988,7 +989,8 @@ substCoVarBndrUsing subst_fn subst@(Subst in_scope idenv tenv cenv) old_var
(Subst (in_scope `extendInScopeSet` new_var) idenv tenv new_cenv, new_var)
where
new_co = mkCoVarCo new_var
- no_kind_change = noFreeVarsOfTypes [t1, t2]
+ no_kind_change = isEmptyTCvSubst subst || noFreeVarsOfTypes [t1, t2]
+ -- isEmptyTCvSubst: see Note [Keeping the substitution empty]
no_change = new_var == old_var && no_kind_change
new_cenv | no_change = delVarEnv cenv old_var
@@ -1034,3 +1036,22 @@ substTyCoBndr subst (Anon ty af) = (subst, Anon (substScaledTy subst ty
substTyCoBndr subst (Named (Bndr tv vis)) = (subst', Named (Bndr tv' vis))
where
(subst', tv') = substVarBndr subst tv
+
+{- Note [Keeping the substitution empty]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A very common situation is where we run over a term doing no cloning,
+no substitution, nothing. In that case the TCvSubst will be empty, and
+it is /very/ valuable to /keep/ it empty:
+
+* It's wasted effort to build up an identity substitution mapping
+ [x:->x, y:->y].
+
+* When we come to a binder, if the incoming substitution is empty,
+ we can avoid substituting its type; and that in turn may mean that
+ the binder itself does not change and we don't need to extend the
+ substitution.
+
+* In the Simplifier we substitute over both types and coercions.
+ If the substitution is empty, this is a no-op -- but only if it
+ is empty!
+-}
=====================================
compiler/GHC/Iface/Recomp.hs
=====================================
@@ -1797,7 +1797,9 @@ declExtras fix_fn ann_fn rule_env inst_env fi_env dm_env complete_env decl
IfaceSynonym{} -> IfaceSynonymExtras (fix_fn n)
(ann_fn (AnnOccName n))
IfaceFamily{} -> IfaceFamilyExtras (fix_fn n)
- (map ifFamInstAxiom (lookupOccEnvL fi_env n))
+ (map ifFamInstAxiom (lookupOccEnvL fi_env n)
+ ++ map ifDFun (lookupOccEnvL inst_env n)
+ )
(ann_fn (AnnOccName n))
IfacePatSyn{} -> IfacePatSynExtras (fix_fn n) (lookup_complete_match n)
_other -> IfaceOtherDeclExtras
=====================================
hadrian/doc/flavours.md
=====================================
@@ -297,7 +297,11 @@ The supported transformers are listed below:
</tr>
<tr>
<td><code>assertions</code></td>
- <td>Build the stage2 compiler with assertions enabled. </td>
+ <td>Build the stage2 compiler with <code>-DDEBUG</code> assertions enabled. </td>
+ </tr>
+ <tr>
+ <td><code>assertions_stage1</code></td>
+ <td>Build the stage1 compiler with <code>-DDEBUG</code> assertions enabled. </td>
</tr>
<tr>
<td><code>fully_static</code></td>
=====================================
hadrian/src/Base.hs
=====================================
@@ -149,14 +149,10 @@ ghcLibDeps stage iplace = do
ps <- mapM (\f -> stageLibPath stage <&> (-/- f))
[ "llvm-targets"
, "llvm-passes"
- , "ghc-interp.js"
, "settings"
, "targets" -/- "default.target"
, "ghc-usage.txt"
, "ghci-usage.txt"
- , "dyld.mjs"
- , "post-link.mjs"
- , "prelude.mjs"
]
cxxStdLib <- systemCxxStdLibConfPath (PackageDbLoc stage iplace)
return (cxxStdLib : ps)
=====================================
hadrian/src/Builder.hs
=====================================
@@ -170,8 +170,6 @@ data Builder = Alex
| GhcPkg GhcPkgMode Stage
| Haddock HaddockMode
| Happy
- | Hp2Ps
- | Hpc
| HsCpp
| JsCpp
| Hsc2Hs Stage
@@ -211,10 +209,6 @@ builderProvenance = \case
Haddock _ -> context Stage1 haddock
Hsc2Hs _ -> context stage0Boot hsc2hs
Unlit -> context stage0Boot unlit
-
- -- Never used
- Hpc -> context Stage1 hpcBin
- Hp2Ps -> context stage0Boot hp2ps
_ -> Nothing
where
context s p = Just $ vanillaContext s p
=====================================
hadrian/src/Flavour.hs
=====================================
@@ -70,7 +70,8 @@ flavourTransformers = M.fromList
, "fully_static" =: fullyStatic
, "host_fully_static" =: hostFullyStatic
, "collect_timings" =: collectTimings
- , "assertions" =: enableAssertions
+ , "assertions" =: enableAssertions Stage2
+ , "assertions_stage1" =: enableAssertions Stage1
, "debug_ghc" =: debugGhc Stage2
, "debug_stage1_ghc" =: debugGhc Stage1
, "lint" =: enableLinting
@@ -169,10 +170,10 @@ werror =
-- | Build C and Haskell objects with debugging information.
enableDebugInfo :: Flavour -> Flavour
enableDebugInfo = addArgs $ notStage0 ? mconcat
- [ builder (Ghc CompileHs) ? pure ["-g3"]
- , builder (Ghc CompileCWithGhc) ? pure ["-optc-g3"]
- , builder (Ghc CompileCppWithGhc) ? pure ["-optcxx-g3"]
- , builder (Cc CompileC) ? arg "-g3"
+ [ builder (Ghc CompileHs) ? pure ["-g3", "-optc-fno-omit-frame-pointer"]
+ , builder (Ghc CompileCWithGhc) ? pure ["-optc-g3", "-optc-fno-omit-frame-pointer"]
+ , builder (Ghc CompileCppWithGhc) ? pure ["-optcxx-g3", "-optcxx-fno-omit-frame-pointer"]
+ , builder (Cc CompileC) ? pure ["-g3", "-fno-omit-frame-pointer"]
, builder (Cabal Setup) ? arg "--disable-library-stripping"
, builder (Cabal Setup) ? arg "--disable-executable-stripping"
]
@@ -393,12 +394,12 @@ enableLateCCS = addArgs
? ((Profiling `wayUnit`) <$> getWay)
? arg "-fprof-late"
--- | Enable assertions for the stage2 compiler
-enableAssertions :: Flavour -> Flavour
-enableAssertions flav = flav { ghcDebugAssertions = f }
+-- | Enable -DDEBUG assertions in the compiler, at a specified stage
+enableAssertions :: Stage -> Flavour -> Flavour
+enableAssertions stage flav = flav { ghcDebugAssertions = f }
where
- f Stage2 = True
- f st = ghcDebugAssertions flav st
+ f s | s == stage = True
+ | otherwise = ghcDebugAssertions flav s
-- | Build the stage3 compiler using the non-moving GC.
enableBootNonmovingGc :: Flavour -> Flavour
=====================================
hadrian/src/Hadrian/Haskell/Hash.hs
=====================================
@@ -84,7 +84,6 @@ data PackageHashConfigInputs = PackageHashConfigInputs {
pkgHashDynExe :: Bool,
pkgHashProfLib :: Bool,
pkgHashProfExe :: Bool,
- pkgHashSplitObjs :: Bool,
pkgHashSplitSections :: Bool,
pkgHashStripLibs :: Bool,
pkgHashStripExes :: Bool,
@@ -140,7 +139,6 @@ pkgHashOracle = void $ addOracleCache $ \(PkgHashKey (stag, pkg)) -> do
pkgHashDynExe = dyn_ghc
pkgHashProfLib = profiling `Set.member` libWays
pkgHashProfExe = pkg == ghc && ghcProfiled flav stag
- pkgHashSplitObjs = False -- Deprecated
pkgHashSplitSections = ghcSplitSections flav
pkgHashStripExes = False
pkgHashStripLibs = False
@@ -239,7 +237,6 @@ renderPackageHashInputs PackageHashInputs{
, opt "dynamic-exe" False show pkgHashDynExe
, opt "prof-lib" False show pkgHashProfLib
, opt "prof-exe" False show pkgHashProfExe
- , opt "split-objs" False show pkgHashSplitObjs
, opt "split-sections" False show pkgHashSplitSections
, opt "stripped-lib" False show pkgHashStripLibs
, opt "stripped-exe" True show pkgHashStripExes
=====================================
hadrian/src/Oracles/Setting.hs
=====================================
@@ -9,7 +9,7 @@ module Oracles.Setting (
-- ** Target platform things
anyTargetOs, anyTargetArch, anyHostOs,
- isElfTarget, isOsxTarget, isWinTarget, isJsTarget, isArmTarget,
+ isElfTarget, isOsxTarget, isWinTarget, isJsTarget, isWasmTarget, isArmTarget,
isWinHost,
targetArmVersion
) where
@@ -128,6 +128,9 @@ isWinTarget = anyTargetOs [OSMinGW32]
isJsTarget :: Action Bool
isJsTarget = anyTargetArch [ArchJavaScript]
+isWasmTarget :: Action Bool
+isWasmTarget = anyTargetArch [ArchWasm32]
+
isOsxTarget :: Action Bool
isOsxTarget = anyTargetOs [OSDarwin]
=====================================
hadrian/src/Rules/Register.hs
=====================================
@@ -118,7 +118,18 @@ registerPackageRules rs stage iplace = do
pkgName <- getPackageNameFromConfFile conf
let pkg = unsafeFindPackageByName pkgName
- when (pkg == compiler) $ need =<< ghcLibDeps stage iplace
+ when (pkg == compiler) $ do
+ baseDeps <- ghcLibDeps stage iplace
+ jsTarget <- isJsTarget
+ wasmTarget <- isWasmTarget
+ libPath <- stageLibPath stage
+ let jsDeps
+ | jsTarget = ["ghc-interp.js"]
+ | otherwise = []
+ wasmDeps
+ | wasmTarget = ["dyld.mjs", "post-link.mjs", "prelude.mjs"]
+ | otherwise = []
+ need (baseDeps ++ map (libPath -/-) (jsDeps ++ wasmDeps))
-- Only used in guard when Stage0 {} but can be GlobalLibs or InTreeLibs
isBoot <- (pkg `notElem`) <$> stagePackages stage
=====================================
hadrian/src/Settings/Flavours/Validate.hs
=====================================
@@ -1,31 +1,16 @@
module Settings.Flavours.Validate (validateFlavour, slowValidateFlavour,
quickValidateFlavour) where
-import qualified Data.Set as Set
import Expression
import Flavour
-import Oracles.Flag
import {-# SOURCE #-} Settings.Default
-- Please update doc/flavours.md when changing this file.
validateFlavour :: Flavour
-validateFlavour = enableLinting $ werror $ defaultFlavour
+validateFlavour = enableLinting $ quickValidateFlavour
{ name = "validate"
, extraArgs = validateArgs <> defaultHaddockExtraArgs
- , libraryWays = Set.fromList <$>
- mconcat [ pure [vanilla]
- , notStage0 ? platformSupportsSharedLibs ? pure [dynamic]
- ]
- , rtsWays = Set.fromList <$>
- mconcat [ pure [vanilla, debug]
- , targetSupportsThreadedRts ? pure [threaded, threadedDebug]
- , notStage0 ? platformSupportsSharedLibs ? pure
- [ dynamic, debugDynamic
- ]
- , notStage0 ? platformSupportsSharedLibs ? targetSupportsThreadedRts ? pure
- [ threadedDynamic, threadedDebugDynamic ]
- ]
, ghcDebugAssertions = (<= Stage1)
}
@@ -59,6 +44,6 @@ quickValidateArgs = sourceArgs SourceArgs
}
quickValidateFlavour :: Flavour
-quickValidateFlavour = werror $ validateFlavour
+quickValidateFlavour = werror $ disableProfiledLibs $ defaultFlavour
{ name = "quick-validate"
, extraArgs = quickValidateArgs }
=====================================
testsuite/tests/driver/recomp26705/M.hs
=====================================
@@ -0,0 +1,5 @@
+module M where
+import M2
+
+x :: TD () -> String
+x = show
=====================================
testsuite/tests/driver/recomp26705/M2A.hs
=====================================
@@ -0,0 +1,7 @@
+{-# LANGUAGE TypeFamilies #-}
+module M2 where
+
+data family TD a
+
+data instance TD () = TDI
+ deriving Show
=====================================
testsuite/tests/driver/recomp26705/M2B.hs
=====================================
@@ -0,0 +1,6 @@
+{-# LANGUAGE TypeFamilies #-}
+module M2 where
+
+data family TD a
+
+data instance TD () = TDI
=====================================
testsuite/tests/driver/recomp26705/Makefile
=====================================
@@ -0,0 +1,13 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+# Recompilation tests
+
+recomp26705:
+ cp M2A.hs M2.hs
+ '$(TEST_HC)' $(TEST_HC_OPTS) --make M.hs
+ sleep 1
+ cp M2B.hs M2.hs
+ # This should fail
+ if '$(TEST_HC)' $(TEST_HC_OPTS) --make M.hs; then false; fi
=====================================
testsuite/tests/driver/recomp26705/all.T
=====================================
@@ -0,0 +1,3 @@
+test('recomp26705', [extra_files(['M2A.hs', 'M.hs', 'M2B.hs']),
+ when(fast(), skip), ignore_stdout],
+ makefile_test, [])
=====================================
testsuite/tests/driver/recomp26705/recomp26705.stderr
=====================================
@@ -0,0 +1,5 @@
+M.hs:5:5: error: [GHC-39999]
+ • No instance for ‘Show (TD ())’ arising from a use of ‘show’
+ • In the expression: show
+ In an equation for ‘x’: x = show
+
=====================================
testsuite/tests/simplCore/should_compile/T26681.hs
=====================================
@@ -0,0 +1,47 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+
+module T26681 where
+
+import Data.Kind (Type)
+import Data.Type.Equality
+import GHC.TypeLits
+import qualified Unsafe.Coerce
+
+
+{-# NOINLINE unsafeCoerceRefl #-}
+unsafeCoerceRefl :: a :~: b
+unsafeCoerceRefl = Unsafe.Coerce.unsafeCoerce Refl
+
+type family MapJust l where
+ MapJust '[] = '[]
+ MapJust (x : xs) = Just x : MapJust xs
+
+type family Tail l where
+ Tail (_ : xs) = xs
+
+lemMapJustCons :: MapJust sh :~: Just n : sh' -> sh :~: n : Tail sh
+lemMapJustCons Refl = unsafeCoerceRefl
+
+
+type ListX :: [Maybe Nat] -> (Maybe Nat -> Type) -> Type
+data ListX sh f where
+ ConsX :: !(f n) -> ListX (n : sh) f
+
+
+data JustN n where
+ JustN :: JustN (Just n)
+
+data UnconsListSRes f sh1 = forall n sh. (n : sh ~ sh1) => UnconsListSRes
+
+listsUncons :: forall sh1 f. ListX (MapJust sh1) JustN -> UnconsListSRes f sh1
+listsUncons (ConsX JustN)
+ | Refl <- lemMapJustCons @sh1 Refl
+ = UnconsListSRes
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -563,3 +563,4 @@ test('T26115', [grep_errmsg(r'DFun')], compile, ['-O -ddump-simpl -dsuppress-uni
test('T26116', normal, compile, ['-O -ddump-rules'])
test('T26117', [grep_errmsg(r'==')], compile, ['-O -ddump-simpl -dsuppress-uniques'])
test('T26349', normal, compile, ['-O -ddump-rules'])
+test('T26681', normal, compile, ['-O'])
=====================================
utils/deriveConstants/Main.hs
=====================================
@@ -397,7 +397,6 @@ wanteds os = concat
,fieldOffset Both "StgRegTable" "rHpAlloc"
,structField C "StgRegTable" "rCurrentAlloc"
,structField C "StgRegTable" "rRet"
- ,structField C "StgRegTable" "rNursery"
,defIntOffset Both "stgEagerBlackholeInfo"
"FUN_OFFSET(stgEagerBlackholeInfo)"
@@ -405,7 +404,6 @@ wanteds os = concat
,defIntOffset Both "stgGCFun" "FUN_OFFSET(stgGCFun)"
,fieldOffset Both "Capability" "r"
- ,fieldOffset C "Capability" "lock"
,structField C "Capability" "no"
,structField C "Capability" "mut_lists"
,structField C "Capability" "context_switch"
@@ -424,18 +422,11 @@ wanteds os = concat
,structField C "bdescr" "link"
,structField Both "bdescr" "flags"
- ,structSize C "generation"
,structField C "generation" "n_new_large_words"
- ,structField C "generation" "weak_ptr_list"
,structSize Both "CostCentreStack"
- ,structField C "CostCentreStack" "ccsID"
,structFieldH Both "CostCentreStack" "mem_alloc"
,structFieldH Both "CostCentreStack" "scc_count"
- ,structField C "CostCentreStack" "prevStack"
-
- ,structField C "CostCentre" "ccID"
- ,structField C "CostCentre" "link"
,structField C "StgHeader" "info"
,structField_ Both "StgHeader_ccs" "StgHeader" "prof.ccs"
@@ -472,18 +463,14 @@ wanteds os = concat
,closurePayload C "StgArrBytes" "payload"
,closureField C "StgTSO" "_link"
- ,closureField C "StgTSO" "global_link"
,closureField C "StgTSO" "what_next"
,closureField C "StgTSO" "why_blocked"
,closureField C "StgTSO" "block_info"
,closureField C "StgTSO" "blocked_exceptions"
,closureField C "StgTSO" "id"
,closureField C "StgTSO" "cap"
- ,closureField C "StgTSO" "saved_errno"
,closureField C "StgTSO" "trec"
,closureField C "StgTSO" "flags"
- ,closureField C "StgTSO" "dirty"
- ,closureField C "StgTSO" "bq"
,closureField C "StgTSO" "label"
,closureField C "StgTSO" "bound"
,closureField Both "StgTSO" "alloc_limit"
@@ -496,8 +483,6 @@ wanteds os = concat
,closureField C "StgStack" "dirty"
,closureField C "StgStack" "marking"
- ,structSize C "StgTSOProfInfo"
-
,closureField Both "StgUpdateFrame" "updatee"
,closureField Both "StgOrigThunkInfoFrame" "info_ptr"
@@ -519,19 +504,15 @@ wanteds os = concat
,closureFieldGcptr C "StgAP" "fun"
,closurePayload C "StgAP" "payload"
- ,thunkSize C "StgAP_STACK"
,closureField C "StgAP_STACK" "size"
,closureFieldGcptr C "StgAP_STACK" "fun"
,closurePayload C "StgAP_STACK" "payload"
- ,closureSize C "StgContinuation"
,closureField C "StgContinuation" "apply_mask_frame"
,closureField C "StgContinuation" "mask_frame_offset"
,closureField C "StgContinuation" "stack_size"
,closurePayload C "StgContinuation" "stack"
- ,thunkSize C "StgSelector"
-
,closureFieldGcptr C "StgInd" "indirectee"
,closureSize C "StgMutVar"
@@ -552,10 +533,6 @@ wanteds os = concat
,closureField C "StgCatchRetryFrame" "first_code"
,closureField C "StgCatchRetryFrame" "alt_code"
- ,closureField C "StgTVarWatchQueue" "closure"
- ,closureField C "StgTVarWatchQueue" "next_queue_entry"
- ,closureField C "StgTVarWatchQueue" "prev_queue_entry"
-
,closureSize C "StgTVar"
,closureField C "StgTVar" "current_value"
,closureField C "StgTVar" "first_watch_queue_entry"
@@ -595,29 +572,19 @@ wanteds os = concat
,closureSize C "StgStableName"
,closureField C "StgStableName" "sn"
- ,closureSize C "StgBlockingQueue"
- ,closureField C "StgBlockingQueue" "bh"
- ,closureField C "StgBlockingQueue" "owner"
- ,closureField C "StgBlockingQueue" "queue"
- ,closureField C "StgBlockingQueue" "link"
-
,closureSize C "MessageBlackHole"
,closureField C "MessageBlackHole" "link"
,closureField C "MessageBlackHole" "tso"
,closureField C "MessageBlackHole" "bh"
- ,closureSize C "StgCompactNFData"
,closureField C "StgCompactNFData" "totalW"
- ,closureField C "StgCompactNFData" "autoBlockW"
,closureField C "StgCompactNFData" "nursery"
- ,closureField C "StgCompactNFData" "last"
,closureField C "StgCompactNFData" "hp"
,closureField C "StgCompactNFData" "hpLim"
,closureField C "StgCompactNFData" "hash"
,closureField C "StgCompactNFData" "result"
,structSize C "StgCompactNFDataBlock"
- ,structField C "StgCompactNFDataBlock" "self"
,structField C "StgCompactNFDataBlock" "owner"
,structField C "StgCompactNFDataBlock" "next"
@@ -635,10 +602,7 @@ wanteds os = concat
"RTS_FLAGS" "DebugFlags.zero_on_gc"
,structField_ C "RtsFlags_GcFlags_initialStkSize"
"RTS_FLAGS" "GcFlags.initialStkSize"
- ,structField_ C "RtsFlags_MiscFlags_tickInterval"
- "RTS_FLAGS" "MiscFlags.tickInterval"
- ,structSize C "StgFunInfoExtraFwd"
,structField C "StgFunInfoExtraFwd" "slow_apply"
,structField C "StgFunInfoExtraFwd" "fun_type"
,structFieldH Both "StgFunInfoExtraFwd" "arity"
@@ -652,11 +616,9 @@ wanteds os = concat
,structField_ C "StgFunInfoExtraRev_bitmap_offset" "StgFunInfoExtraRev" "b.bitmap_offset"
,structField C "StgLargeBitmap" "size"
- ,fieldOffset C "StgLargeBitmap" "bitmap"
,structSize C "snEntry"
,structField C "snEntry" "sn_obj"
- ,structField C "snEntry" "addr"
,structSize C "spEntry"
,structField C "spEntry" "addr"
@@ -672,51 +634,15 @@ wanteds os = concat
else []
-- struct HsIface
- ,structField C "HsIface" "processRemoteCompletion_closure"
- ,structField C "HsIface" "runIO_closure"
- ,structField C "HsIface" "runNonIO_closure"
,structField C "HsIface" "Z0T_closure"
,structField C "HsIface" "True_closure"
,structField C "HsIface" "False_closure"
- ,structField C "HsIface" "unpackCString_closure"
- ,structField C "HsIface" "runFinalizzerBatch_closure"
- ,structField C "HsIface" "stackOverflow_closure"
,structField C "HsIface" "heapOverflow_closure"
- ,structField C "HsIface" "allocationLimitExceeded_closure"
- ,structField C "HsIface" "blockedIndefinitelyOnMVar_closure"
- ,structField C "HsIface" "blockedIndefinitelyOnSTM_closure"
,structField C "HsIface" "cannotCompactFunction_closure"
,structField C "HsIface" "cannotCompactPinned_closure"
,structField C "HsIface" "cannotCompactMutable_closure"
- ,structField C "HsIface" "nonTermination_closure"
,structField C "HsIface" "nestedAtomically_closure"
,structField C "HsIface" "noMatchingContinuationPrompt_closure"
- ,structField C "HsIface" "blockedOnBadFD_closure"
- ,structField C "HsIface" "runSparks_closure"
- ,structField C "HsIface" "ensureIOManagerIsRunning_closure"
- ,structField C "HsIface" "interruptIOManager_closure"
- ,structField C "HsIface" "ioManagerCapabilitiesChanged_closure"
- ,structField C "HsIface" "runHandlersPtr_closure"
- ,structField C "HsIface" "flushStdHandles_closure"
- ,structField C "HsIface" "runMainIO_closure"
- ,structField C "HsIface" "Czh_con_info"
- ,structField C "HsIface" "Izh_con_info"
- ,structField C "HsIface" "Fzh_con_info"
- ,structField C "HsIface" "Dzh_con_info"
- ,structField C "HsIface" "Wzh_con_info"
- ,structField C "HsIface" "runAllocationLimitHandler_closure"
- ,structField C "HsIface" "Ptr_con_info"
- ,structField C "HsIface" "FunPtr_con_info"
- ,structField C "HsIface" "I8zh_con_info"
- ,structField C "HsIface" "I16zh_con_info"
- ,structField C "HsIface" "I32zh_con_info"
- ,structField C "HsIface" "I64zh_con_info"
- ,structField C "HsIface" "W8zh_con_info"
- ,structField C "HsIface" "W16zh_con_info"
- ,structField C "HsIface" "W32zh_con_info"
- ,structField C "HsIface" "W64zh_con_info"
- ,structField C "HsIface" "StablePtr_con_info"
- ,structField C "HsIface" "StackSnapshot_closure"
,structField C "HsIface" "divZZeroException_closure"
,structField C "HsIface" "underflowException_closure"
,structField C "HsIface" "overflowException_closure"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/edf9ed5f83093b0243929f7bb4974ad...
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/edf9ed5f83093b0243929f7bb4974ad...
You're receiving this email because of your account on gitlab.haskell.org.
