- ghc-commits - Haskell.org

[Git][ghc/ghc][master] [26705] Include TyCl instances in data fam iface entry
by Marge Bot (＠marge-bot) 07 Jan '26

07 Jan '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 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 - - - - - 7 changed files: - compiler/GHC/Iface/Recomp.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 Changes: ===================================== 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 ===================================== 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 + View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8a3900a325a8f476d1e31a84deeab93… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8a3900a325a8f476d1e31a84deeab93… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] hadrian: pass -fno-omit-frame-pointer with +debug_info
by Marge Bot (＠marge-bot) 07 Jan '26

07 Jan '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 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. - - - - - 1 changed file: - hadrian/src/Flavour.hs Changes: ===================================== hadrian/src/Flavour.hs ===================================== @@ -169,10 +169,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" ] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4df969934fcbd6588f5e10919d39645… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4df969934fcbd6588f5e10919d39645… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] deriveConstants: clean up unused constants
by Marge Bot (＠marge-bot) 07 Jan '26

07 Jan '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 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 <codex(a)openai.com> - - - - - 1 changed file: - utils/deriveConstants/Main.hs Changes: ===================================== 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/-/commit/7971f5ddaa511d10fd54f43e44ef058… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7971f5ddaa511d10fd54f43e44ef058… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] hadrian: remove linting/assertion in quick-validate flavour
by Marge Bot (＠marge-bot) 07 Jan '26

07 Jan '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 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. - - - - - 1 changed file: - hadrian/src/Settings/Flavours/Validate.hs Changes: ===================================== 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 } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bb3a2ba1eefadf0b2ef4f39b31337a2… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bb3a2ba1eefadf0b2ef4f39b31337a2… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] hadrian: drop deprecated pkgHashSplitObjs code path
by Marge Bot (＠marge-bot) 07 Jan '26

07 Jan '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 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. - - - - - 1 changed file: - hadrian/src/Hadrian/Haskell/Hash.hs Changes: ===================================== 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 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ab0a5594e1f6c785e711d38a41996ab… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ab0a5594e1f6c785e711d38a41996ab… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Add missing InVar->OutVar lookup in SetLevels
by Marge Bot (＠marge-bot) 07 Jan '26

07 Jan '26

Marge Bot pushed to branch master 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. - - - - - 3 changed files: - compiler/GHC/Core/Opt/SetLevels.hs - + testsuite/tests/simplCore/should_compile/T26681.hs - testsuite/tests/simplCore/should_compile/all.T 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 ===================================== 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']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/52d00c05e1d803b36c93295399fe931… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/52d00c05e1d803b36c93295399fe931… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26722] 8 commits: compiler: add targetHasRTSWays function
by Simon Peyton Jones (＠simonpj) 07 Jan '26

07 Jan '26

Simon Peyton Jones pushed to branch wip/T26722 at Glasgow Haskell Compiler / GHC Commits: 69e0ab59 by Cheng Shao at 2026-01-06T19:37:56-05:00 compiler: add targetHasRTSWays function This commit adds a `targetHasRTSWays` util function in `GHC.Driver.Session` to query if the target RTS has a given Ways (e.g. WayThreaded). - - - - - 25a0ab94 by Cheng Shao at 2026-01-06T19:37:56-05:00 compiler: link on-demand external interpreter with threaded RTS This commit makes the compiler link the on-demand external interpreter program with threaded RTS if it is available in the target RTS ways. This is a better default than the previous single-threaded RTS, and it enables the external interpreter to benefit from parallelism when deserializing CreateBCOs messages. - - - - - 92404a2b by Cheng Shao at 2026-01-06T19:37:56-05:00 hadrian: link iserv with threaded RTS This commit makes hadrian link iserv with threaded RTS if it's available in the RTS ways. Also cleans up the iserv main C program which can be replaced by the `-fkeep-cafs` link-time option. - - - - - a20542d2 by Cheng Shao at 2026-01-06T19:38:38-05:00 ghc-internal: remove unused GMP macros This patch removes unused GMP related macros from `ghc-internal`. The in-tree GMP version was hard coded and outdated, but it was not used anywhere anyway. - - - - - 4079dcd6 by Cheng Shao at 2026-01-06T19:38:38-05:00 hadrian: fix in-tree gmp configure error on newer c compilers Building in-tree gmp on newer c compilers that default to c23 fails at configure stage, this patch fixes it, see added comment for explanation. - - - - - 414d1fe1 by Cheng Shao at 2026-01-06T19:39:20-05:00 compiler: fix LLVM backend pdep/pext handling for i386 target This patch fixes LLVM backend's pdep/pext handling for i386 target, and also removes non-existent 128/256/512 bit hs_pdep/hs_pext callees. See amended note for more explanation. Fixes #26450. Co-authored-by: Codex <codex(a)openai.com> - - - - - c7f6fba3 by Cheng Shao at 2026-01-06T19:39:20-05:00 ci: remove allow_failure flag for i386 alpine job The LLVM codegen issue for i386 has been fixed, and the i386 alpine job should pass now. This commit removes the allow_failure flag so that other i386 regressions in the future are signaled more timely. - - - - - c0b944c2 by Simon Peyton Jones at 2026-01-07T12:50:35+00:00 Add evals for strict data-con args in worker-functions This fixes #26722, by adding an eval in a worker for arguments of strict data constructors, even if the function body uses them strictly. See (WIS1) in Note [Which Ids should be strictified] - - - - - 25 changed files: - .gitlab/generate-ci/gen_ci.hs - .gitlab/jobs.yaml - compiler/GHC.hs - compiler/GHC/CmmToLlvm/CodeGen.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Tidy.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Runtime/Interpreter/C.hs - compiler/GHC/Runtime/Interpreter/Init.hs - compiler/GHC/Stg/EnforceEpt.hs - compiler/GHC/StgToCmm/Closure.hs - compiler/GHC/StgToCmm/Expr.hs - hadrian/src/Flavour.hs - hadrian/src/Packages.hs - hadrian/src/Rules/Gmp.hs - hadrian/src/Settings/Packages.hs - libraries/ghc-internal/configure.ac - libraries/ghc-internal/include/HsIntegerGmp.h.in - testsuite/tests/simplCore/should_compile/T18013.stderr - + testsuite/tests/simplCore/should_compile/T26722.hs - + testsuite/tests/simplCore/should_compile/T26722.stderr - testsuite/tests/simplCore/should_compile/all.T - − utils/iserv/cbits/iservmain.c - utils/iserv/iserv.cabal.in Changes: ===================================== .gitlab/generate-ci/gen_ci.hs ===================================== @@ -1250,7 +1250,7 @@ alpine_x86 = , fullyStaticBrokenTests (disableValidate (allowFailureGroup (standardBuildsWithConfig Amd64 (Linux Alpine312) staticNativeInt))) -- Dynamically linked build, suitable for building your own static executables on alpine , disableValidate (standardBuildsWithConfig Amd64 (Linux Alpine323) (splitSectionsBroken vanilla)) - , allowFailureGroup (standardBuildsWithConfig I386 (Linux Alpine323) (splitSectionsBroken vanilla)) + , standardBuildsWithConfig I386 (Linux Alpine323) (splitSectionsBroken vanilla) ] where -- ghcilink002 broken due to #17869 ===================================== .gitlab/jobs.yaml ===================================== @@ -484,7 +484,7 @@ ".gitlab/ci.sh clean", "cat ci_timings.txt" ], - "allow_failure": true, + "allow_failure": false, "artifacts": { "expire_in": "2 weeks", "paths": [ @@ -1155,7 +1155,7 @@ ".gitlab/ci.sh clean", "cat ci_timings.txt" ], - "allow_failure": true, + "allow_failure": false, "artifacts": { "expire_in": "8 weeks", "paths": [ @@ -4034,7 +4034,7 @@ ".gitlab/ci.sh clean", "cat ci_timings.txt" ], - "allow_failure": true, + "allow_failure": false, "artifacts": { "expire_in": "1 year", "paths": [ ===================================== compiler/GHC.hs ===================================== @@ -719,7 +719,7 @@ setTopSessionDynFlags dflags = do { interpCreateProcess = createIservProcessHook (hsc_hooks hsc_env) } - interp <- liftIO $ initInterpreter tmpfs logger platform finder_cache unit_env interp_opts + interp <- liftIO $ initInterpreter dflags tmpfs logger platform finder_cache unit_env interp_opts modifySession $ \h -> hscSetFlags dflags h{ hsc_IC = (hsc_IC h){ ic_dflags = dflags } ===================================== compiler/GHC/CmmToLlvm/CodeGen.hs ===================================== @@ -248,6 +248,14 @@ Since x86 PDep/PExt instructions only exist for 32/64 bit widths we use the 32bit variant to compute the 8/16bit primops. To do so we extend/truncate the argument/result around the call. + +Note that the 64-bit intrinsics (`llvm.x86.bmi.pdep.64` and +`llvm.x86.bmi.pext.64`) are only legal on 64-bit x86 targets, not on +i386. Therefore on i386 we must fall back to the runtime helper +(`hs_pdep64`/`hs_pext64`) for the 64-bit primops. + +See https://github.com/llvm/llvm-project/issues/172857 for upstream +discussion about portable pdep/pext intrinsics. -} genCall (PrimTarget op@(MO_Pdep w)) [dst] args = do cfg <- getConfig @@ -970,36 +978,34 @@ cmmPrimOpFunctions mop = do W8 -> fsLit "llvm.x86.bmi.pdep.32" W16 -> fsLit "llvm.x86.bmi.pdep.32" W32 -> fsLit "llvm.x86.bmi.pdep.32" - W64 -> fsLit "llvm.x86.bmi.pdep.64" - W128 -> fsLit "llvm.x86.bmi.pdep.128" - W256 -> fsLit "llvm.x86.bmi.pdep.256" - W512 -> fsLit "llvm.x86.bmi.pdep.512" + W64 + | is32bit -> fsLit "hs_pdep64" + | otherwise -> fsLit "llvm.x86.bmi.pdep.64" + -- LLVM only provides x86 PDep/PExt intrinsics for 32/64 bits + _ -> unsupported | otherwise -> case w of W8 -> fsLit "hs_pdep8" W16 -> fsLit "hs_pdep16" W32 -> fsLit "hs_pdep32" W64 -> fsLit "hs_pdep64" - W128 -> fsLit "hs_pdep128" - W256 -> fsLit "hs_pdep256" - W512 -> fsLit "hs_pdep512" + _ -> unsupported MO_Pext w | isBmi2Enabled -> case w of -- See Note [LLVM PDep/PExt intrinsics] W8 -> fsLit "llvm.x86.bmi.pext.32" W16 -> fsLit "llvm.x86.bmi.pext.32" W32 -> fsLit "llvm.x86.bmi.pext.32" - W64 -> fsLit "llvm.x86.bmi.pext.64" - W128 -> fsLit "llvm.x86.bmi.pext.128" - W256 -> fsLit "llvm.x86.bmi.pext.256" - W512 -> fsLit "llvm.x86.bmi.pext.512" + W64 + | is32bit -> fsLit "hs_pext64" + | otherwise -> fsLit "llvm.x86.bmi.pext.64" + -- LLVM only provides x86 PDep/PExt intrinsics for 32/64 bits + _ -> unsupported | otherwise -> case w of W8 -> fsLit "hs_pext8" W16 -> fsLit "hs_pext16" W32 -> fsLit "hs_pext32" W64 -> fsLit "hs_pext64" - W128 -> fsLit "hs_pext128" - W256 -> fsLit "hs_pext256" - W512 -> fsLit "hs_pext512" + _ -> unsupported MO_AddIntC w -> case w of W8 -> fsLit "llvm.sadd.with.overflow.i8" ===================================== compiler/GHC/Core/Opt/SpecConstr.hs ===================================== @@ -2062,7 +2062,7 @@ mkSeqs seqees res_ty rhs = addEval :: Var -> CoreExpr -> CoreExpr addEval arg_id rhs -- Argument representing strict field and it's worth passing via cbv - | shouldStrictifyIdForCbv arg_id + | wantCbvForId arg_id = Case (Var arg_id) (localiseId arg_id) -- See (SCF1) in Note [SpecConstr and strict fields] res_ty ===================================== compiler/GHC/Core/Tidy.hs ===================================== @@ -38,7 +38,7 @@ import GHC.Utils.Outputable import GHC.Types.RepType (typePrimRep) import GHC.Utils.Panic import GHC.Types.Basic (isMarkedCbv, CbvMark (..)) -import GHC.Core.Utils (shouldUseCbvForId) +import GHC.Core.Utils ( wantCbvForId ) {- ************************************************************************ @@ -197,7 +197,7 @@ computeCbvInfo fun_id rhs isSimplePrimRep _ = False mkMark arg - | not $ shouldUseCbvForId arg = NotMarkedCbv + | not $ wantCbvForId arg = NotMarkedCbv -- We can only safely use cbv for strict arguments | (isStrUsedDmd (idDemandInfo arg)) , not (isDeadEndId fun_id) = MarkedCbv ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -58,7 +58,7 @@ module GHC.Core.Utils ( isJoinBind, -- * Tag inference - mkStrictFieldSeqs, shouldStrictifyIdForCbv, shouldUseCbvForId, + mkStrictFieldSeqs, wantCbvForId, -- * unsafeEqualityProof isUnsafeEqualityCase, @@ -2902,18 +2902,24 @@ Here comes the tricky part: If we make $wloop strict in both x/y and we get: }; end Rec } -Here both x and y are known to be tagged in the function body since we pass strict worker args using unlifted cbv. -This means the seqs on x and y both become no-ops and compared to the first version the seq on `y` disappears at runtime. - -The downside is that the caller of $wfoo potentially has to evaluate `y` once if we can't prove it isn't already evaluated. -But y coming out of a strict field is in WHNF so safe to evaluated. And most of the time it will be properly tagged+evaluated -already at the call site because of the EPT Invariant! See Note [EPT enforcement] for more in this. -This makes GHC itself around 1% faster despite doing slightly more work! So this is generally quite good. - -We only apply this when we think there is a benefit in doing so however. There are a number of cases in which -it would be useless to insert an extra seq. ShouldStrictifyIdForCbv tries to identify these to avoid churn in the +Here both x and y are known to be tagged in the function body since we pass +strict worker args using unlifted cbv. This means the seqs on x and y both +become no-ops (via (EPT-codegen) in Not [EPT enforcement]) and, compared to the +first version, the seq on `y` disappears at runtime. + +The downside is that the caller of $wfoo potentially has to evaluate `y` once if +we can't prove it isn't already evaluated. But y coming out of a strict field +is in WHNF so safe to evaluated. And most of the time it will be properly +tagged+evaluated already at the call site because of the EPT Invariant! See Note +[EPT enforcement] for more in this. This makes GHC itself around 1% faster +despite doing slightly more work! So this is generally quite good. + +We only apply this when we think there is a benefit in doing so however. There +are a number of cases in which it would be useless to insert an extra +seq. `wantCbvForId` tries to identify these to avoid churn in the simplifier. See Note [Which Ids should be strictified] for details on this. -} + mkStrictFieldSeqs :: [(Id,StrictnessMark)] -> CoreExpr -> (CoreExpr) mkStrictFieldSeqs args rhs = foldr addEval rhs args @@ -2923,7 +2929,7 @@ mkStrictFieldSeqs args rhs = addEval (arg_id,arg_cbv) (rhs) -- Argument representing strict field. | isMarkedStrict arg_cbv - , shouldStrictifyIdForCbv arg_id + , wantCbvForId arg_id -- Make sure to remove unfoldings here to avoid the simplifier dropping those for OtherCon[] unfoldings. = Case (Var $! zapIdUnfolding arg_id) arg_id case_ty ([Alt DEFAULT [] rhs]) -- Normal argument @@ -2943,87 +2949,99 @@ There are multiple reasons why we might not want to insert a seq in the rhs to strictify a functions argument: 1) The argument doesn't exist at runtime. - -For zero width types (like Types) there is no benefit as we don't operate on them -at runtime at all. This includes things like void#, coercions and state tokens. + For zero width types (like Types) there is no benefit as we don't operate on them + at runtime at all. This includes things like void#, coercions and state tokens. 2) The argument is a unlifted type. - -If the argument is a unlifted type the calling convention already is explicitly -cbv. This means inserting a seq on this argument wouldn't do anything as the seq -would be a no-op *and* it wouldn't affect the calling convention. + If the argument is a unlifted type the calling convention already is explicitly + cbv. This means inserting a seq on this argument wouldn't do anything as the seq + would be a no-op *and* it wouldn't affect the calling convention. 3) The argument is absent. + If the argument is absent in the body there is no advantage to it being passed as + cbv to the function. The function won't ever look at it so we don't save any work. -If the argument is absent in the body there is no advantage to it being passed as -cbv to the function. The function won't ever look at it so we don't safe any work. - -This mostly happens for join point. For example we might have: - - data T = MkT ![Int] [Char] - f t = case t of MkT xs{strict} ys-> snd (xs,ys) - -and abstract the case alternative to: + This mostly happens for join points. For example we might have: - f t = join j1 = \xs ys -> snd (xs,ys) - in case t of MkT xs{strict} ys-> j1 xs xy + data T = MkT ![Int] [Char] + f t = case t of MkT xs{strict} ys-> snd (xs,ys) -While we "use" xs inside `j1` it's not used inside the function `snd` we pass it to. -In short a absent demand means neither our RHS, nor any function we pass the argument -to will inspect it. So there is no work to be saved by forcing `xs` early. + and abstract the case alternative to: -NB: There is an edge case where if we rebox we *can* end up seqing an absent value. -Note [Absent fillers] has an example of this. However this is so rare it's not worth -caring about here. + f t = join j1 = \xs ys -> snd (xs,ys) + in case t of MkT xs{strict} ys-> j1 xs xy -4) The argument is already strict. + While we "use" xs inside `j1` it's not used inside the function `snd` we pass it to. + In short a absent demand means neither our RHS, nor any function we pass the argument + to will inspect it. So there is no work to be saved by forcing `xs` early. -Consider this code: - - data T = MkT ![Int] - f t = case t of MkT xs{strict} -> reverse xs - -The `xs{strict}` indicates that `xs` is used strictly by the `reverse xs`. -If we do a w/w split, and add the extra eval on `xs`, we'll get - - $wf xs = - case xs of xs1 -> - let t = MkT xs1 in - case t of MkT xs2 -> reverse xs2 - -That's not wrong; but the w/w body will simplify to - - $wf xs = case xs of xs1 -> reverse xs1 - -and now we'll drop the `case xs` because `xs1` is used strictly in its scope. -Adding that eval was a waste of time. So don't add it for strictly-demanded Ids. + NB: There is an edge case where if we rebox we *can* end up seqing an absent value. + Note [Absent fillers] has an example of this. However this is so rare it's not worth + caring about here. 5) Functions - -Functions are tricky (see Note [TagInfo of functions] in EnforceEpt). -But the gist of it even if we make a higher order function argument strict -we can't avoid the tag check when it's used later in the body. -So there is no benefit. + Functions are tricky (see Note [TagInfo of functions] in EnforceEpt). + But the gist of it even if we make a higher order function argument strict + we can't avoid the tag check when it's used later in the body. + So there is no benefit. + +Wrinkles: + +(WIS1) You might have thought that we can omit the eval if the argument is used + strictly demanded in the body. But you'd be wrong. Consider this code: + data T = MkT ![Int] + f t = case t of MkT xs{Dmd=STR} -> reverse xs + + The `xs{Dmd=STR}` indicates that `xs` is used strictly by the `reverse xs`. + If we do a w/w split, and add the extra eval on `xs`, we'll get + $wf xs = case xs of xs1 -> + let t = MkT xs1 in + case t of MkT xs2 -> reverse xs2 + + That's not wrong; but you might wonder if the eval on `xs` is needed + when it is certainly evaluated by the `reverse`. But yes, it is (#26722): + g s True t = f s t t + g s False t = g s True t + + f True (MkT xs) t = f False (MkT xs) t + f False (MkT xs) _ = xs + + After worker/wrapper we get: + g s b t = case t of MkT ww -> $wg s b ww + $wg s ds ww = case ds of { + False -> case ww of wg { __DEFAULT -> Bar.$wg s True wg } + True -> let { t1 = MkT ww } in f s t1 t1 } + + We must make `f` inline inside `$wg`, because `f` too is ww'd, and we + don't want to rebox `t1` before passing it to `f`. BUT while `t1` + looks like a HNF, `exprIsHNF` will say False because `MkT` is strict + and `ww` isn't evaluated. So `f` doesn't inline and we get lots of + reboxing. + + The Right Thing to to is to add the eval for the data con argument: + $wg s ds ww = case ww of ww' { DEFAULT -> + case ds of { + False -> case ww of wg { __DEFAULT -> Bar.$wg s True wg } + True -> let { t1 = MkT ww' } in f s t1 t1 } } + + Now `t1` will be a HNF, and `f` will inline, and we get + $wg s ds ww = case ww of ww' { DEFAULT -> + case ds of { + False -> Bar.$wg s True ww' + True -> $wf s ww' + + (Ultimately `$wg` will be a CBV function, so that `case ww` will be a + no-op: see (EPT-codegen) in Note [EPT enforcement] in GHC.Stg.EnforceEpt.) -} --- | Do we expect there to be any benefit if we make this var strict --- in order for it to get treated as as cbv argument? --- See Note [Which Ids should be strictified] --- See Note [CBV Function Ids] for more background. -shouldStrictifyIdForCbv :: Var -> Bool -shouldStrictifyIdForCbv = wantCbvForId False - --- Like shouldStrictifyIdForCbv but also wants to use cbv for strict args. -shouldUseCbvForId :: Var -> Bool -shouldUseCbvForId = wantCbvForId True -- When we strictify we want to skip strict args otherwise the logic is the same --- as for shouldUseCbvForId so we common up the logic here. +-- as for wantCbvForId so we common up the logic here. -- Basically returns true if it would be beneficial for runtime to pass this argument -- as CBV independent of weither or not it's correct. E.g. it might return true for lazy args -- we are not allowed to force. -wantCbvForId :: Bool -> Var -> Bool -wantCbvForId cbv_for_strict v +wantCbvForId :: Var -> Bool +wantCbvForId v -- Must be a runtime var. -- See Note [Which Ids should be strictified] point 1) | isId v @@ -3037,9 +3055,6 @@ wantCbvForId cbv_for_strict v , not $ isFunTy ty -- If the var is strict already a seq is redundant. -- See Note [Which Ids should be strictified] point 4) - , not (isStrictDmd dmd) || cbv_for_strict - -- If the var is absent a seq is almost always useless. - -- See Note [Which Ids should be strictified] point 3) , not (isAbsDmd dmd) = True | otherwise ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -197,6 +197,8 @@ module GHC.Driver.Session ( -- * Compiler configuration suitable for display to the user compilerInfo, + targetHasRTSWays, + wordAlignment, setUnsafeGlobalDynFlags, @@ -3635,6 +3637,15 @@ compilerInfo dflags queryCmdMaybe p f = expandDirectories (query (maybe "" (prgPath . p) . f)) queryFlagsMaybe p f = query (maybe "" (unwords . map escapeArg . prgFlags . p) . f) +-- | Query if the target RTS has the given 'Ways'. It's computed from +-- the @"RTS ways"@ field in the settings file. +targetHasRTSWays :: DynFlags -> Ways -> Bool +targetHasRTSWays dflags ways + | Just ws <- lookup "RTS ways" $ compilerInfo dflags = + waysTag ways + `elem` words ws + | otherwise = panic "RTS ways not found in settings" + -- Note [Special unit-ids] -- ~~~~~~~~~~~~~~~~~~~~~~~ -- Certain units are special to the compiler: ===================================== compiler/GHC/Runtime/Interpreter/C.hs ===================================== @@ -8,7 +8,9 @@ where import GHC.Prelude import GHC.Platform +import GHC.Platform.Ways import GHC.Data.FastString +import GHC.Driver.Session import GHC.Utils.Logger import GHC.Utils.TmpFs import GHC.Unit.Types @@ -18,11 +20,10 @@ import GHC.Unit.State import GHC.Utils.Panic.Plain import GHC.Linker.Executable import GHC.Linker.Config -import GHC.Utils.CliOption -- | Generate iserv program for the target -generateIservC :: Logger -> TmpFs -> ExecutableLinkOpts -> UnitEnv -> IO FilePath -generateIservC logger tmpfs opts unit_env = do +generateIservC :: DynFlags -> Logger -> TmpFs -> ExecutableLinkOpts -> UnitEnv -> IO FilePath +generateIservC dflags logger tmpfs opts unit_env = do -- get the unit-id of the ghci package. We need this to load the -- interpreter code. let unit_state = ue_homeUnitState unit_env @@ -60,6 +61,12 @@ generateIservC logger tmpfs opts unit_env = do -- must retain CAFs for running interpreted code. , leKeepCafs = True + -- link with -threaded if target has threaded RTS + , leWays = + let ways = leWays opts + ways' = addWay WayThreaded ways + in if targetHasRTSWays dflags ways' then ways' else ways + -- enable all rts options , leRtsOptsEnabled = RtsOptsAll ===================================== compiler/GHC/Runtime/Interpreter/Init.hs ===================================== @@ -9,6 +9,7 @@ where import GHC.Prelude +import GHC.Driver.DynFlags import GHC.Platform import GHC.Platform.Ways import GHC.Settings @@ -57,14 +58,15 @@ data InterpOpts = InterpOpts -- | Initialize code interpreter initInterpreter - :: TmpFs + :: DynFlags + -> TmpFs -> Logger -> Platform -> FinderCache -> UnitEnv -> InterpOpts -> IO (Maybe Interp) -initInterpreter tmpfs logger platform finder_cache unit_env opts = do +initInterpreter dflags tmpfs logger platform finder_cache unit_env opts = do lookup_cache <- liftIO $ mkInterpSymbolCache @@ -125,7 +127,7 @@ initInterpreter tmpfs logger platform finder_cache unit_env opts = do dynamic = interpWays opts `hasWay` WayDyn prog <- case interpProg opts of -- build iserv program if none specified - "" -> generateIservC logger tmpfs (interpExecutableLinkOpts opts) unit_env + "" -> generateIservC dflags logger tmpfs (interpExecutableLinkOpts opts) unit_env _ -> pure (interpProg opts ++ flavour) where flavour ===================================== compiler/GHC/Stg/EnforceEpt.hs ===================================== @@ -140,9 +140,11 @@ Afterwards, the *EPT rewriter* inserts the actual evals realising Upcasts. Implementation -------------- -* EPT analysis is implemented in GHC.Stg.EnforceEpt.inferTags. +(EPT-anal) EPT analysis is implemented in `GHC.Stg.EnforceEpt.inferTags.` It attaches its result to /binders/, not occurrence sites. -* The EPT rewriter establishes the EPT invariant by inserting evals. That is, if + +(EPT-rewrite) The EPT rewriter, `GHC.Stg.EnforceEpt.Rewrite.rewriteTopBinds`, + establishes the EPT invariant by inserting evals. That is, if (a) a binder x is used to * construct a strict field (`SP x y`), or * passed as a CBV argument (`$wf x`), @@ -152,17 +154,27 @@ Implementation case x of x' { __ DEFAULT -> SP x' y }. case x of x' { __ DEFAULT -> $wf x' }. (Recall that the case binder x' is always EPT.) - This is implemented in GHC.Stg.EnforceEpt.Rewrite.rewriteTopBinds. + This pass also propagates the EPTness from binders to occurrences. + It is sound to insert evals on strict fields (Note [Strict fields in Core]), and on CBV arguments as well (Note [CBV Function Ids]). -* We also export the EPTness of top level bindings to allow this optimisation + +(EPT-codegen) Finally, code generation for (case x of alts) skips the thunk check + when `x` is EPT. This is done (a bit indirectly) thus: + * GHC.StgToCmm.Expr.cgCase: builds a `sequel`, and recurses into `cgExpr` on `x`. + * When `cgExpr` sees a `x` goes to `cgIdApp`, which uses `getCallMethod`. + * Then `getCallMethod` sees that `x` is EPT (via `idTagSigMaybe`), and + returns `InferredReturnIt`. + * Now `cgIdApp` can jump straight to the case-alternative switch in the `sequel` + constructed by `cgCase`. + +(EPT-export) We also export the EPTness of top level bindings to allow this optimisation to work across module boundaries. + NB: The EPT Invariant *must* be upheld, regardless of the optimisation level; hence EPTness is practically part of the internal ABI of a strict data constructor or CBV function. Note [CBV Function Ids] contains the details. -* Finally, code generation skips the thunk check when branching on binders that - are EPT. This is done by `cgExpr`/`cgCase` in the backend. Evaluation ---------- ===================================== compiler/GHC/StgToCmm/Closure.hs ===================================== @@ -617,12 +617,15 @@ getCallMethod cfg name id (LFThunk _ _ updatable std_form_info is_fun) getCallMethod cfg name id (LFUnknown might_be_a_function) n_args _cg_locs _self_loop_info | n_args == 0 , Just sig <- idTagSig_maybe id - , isTaggedSig sig -- Infered to be already evaluated by EPT analysis - -- When profiling we must enter all potential functions to make sure we update the SCC - -- even if the function itself is already evaluated. + , isTaggedSig sig -- This `id` is evaluated and properly tagged; no need to enter it + -- See (EPT-codegen) in Note [EPT enforcement] in GHC.Stg.EnforceEpt + + -- When profiling we must enter all potential functions to make sure we update + -- the SCC even if the function itself is already evaluated. -- See Note [Evaluating functions with profiling] in rts/Apply.cmm , not (profileIsProfiling (stgToCmmProfile cfg) && might_be_a_function) - = InferedReturnIt -- See Note [EPT enforcement] + + = InferedReturnIt -- See (EPT-codegen) in Note [EPT enforcement] | might_be_a_function = SlowCall ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -1053,6 +1053,7 @@ cgIdApp fun_id args = do | otherwise -> emitReturn [fun] -- A value infered to be in WHNF, so we can just return it. + -- See (EPT-codegen) in Note [EPT enforcement] in GHC.Stg.EnforceEpt InferedReturnIt | isZeroBitTy (idType fun_id) -> trace >> emitReturn [] | otherwise -> trace >> assertTag >> ===================================== 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 @@ -394,11 +395,11 @@ enableLateCCS = addArgs ? arg "-fprof-late" -- | Enable assertions for the stage2 compiler -enableAssertions :: Flavour -> Flavour -enableAssertions flav = flav { ghcDebugAssertions = f } +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/Packages.hs ===================================== @@ -217,7 +217,7 @@ timeoutPath = "testsuite/timeout/install-inplace/bin/timeout" <.> exe -- TODO: Can we extract this information from Cabal files? -- | Some program packages should not be linked with Haskell main function. nonHsMainPackage :: Package -> Bool -nonHsMainPackage = (`elem` [hp2ps, iserv, unlit, ghciWrapper]) +nonHsMainPackage = (`elem` [hp2ps, unlit, ghciWrapper]) {- ===================================== hadrian/src/Rules/Gmp.hs ===================================== @@ -126,6 +126,12 @@ gmpRules = do interpretInContext ctx $ mconcat [ getStagedCCFlags + -- gmp fails to configure with newer compilers + -- that default to c23: + -- https://gmplib.org/list-archives/gmp-devel/2025-January/006279.html. + -- for now just manually specify -std=gnu11 until + -- next upstream release. + , arg "-std=gnu11" -- gmp symbols are only used by bignum logic in -- ghc-internal and shouldn't be exported by the -- ghc-internal shared library. ===================================== hadrian/src/Settings/Packages.hs ===================================== @@ -41,6 +41,8 @@ packageArgs = do libzstdLibraryDir <- getSetting LibZstdLibDir stageVersion <- readVersion <$> (expr $ ghcVersionStage stage) + rtsWays <- getRtsWays + mconcat --------------------------------- base --------------------------------- [ package base ? mconcat @@ -185,11 +187,15 @@ packageArgs = do -- -- The Solaris linker does not support --export-dynamic option. It also -- does not need it since it exports all dynamic symbols by default - , package iserv - ? expr isElfTarget + , package iserv ? mconcat [ + expr isElfTarget ? notM (expr $ anyTargetOs [OSFreeBSD, OSSolaris2])? mconcat [ builder (Ghc LinkHs) ? arg "-optl-Wl,--export-dynamic" ] + -- Link iserv with -threaded if possible + , builder (Cabal Flags) ? any (wayUnit Threaded) rtsWays `cabalFlag` "threaded" + ] + -------------------------------- haddock ------------------------------- , package haddockApi ? builder (Cabal Flags) ? arg "in-ghc-tree" ===================================== libraries/ghc-internal/configure.ac ===================================== @@ -195,28 +195,10 @@ dnl-------------------------------------------------------------------- if test "$HaveFrameworkGMP" = "YES" || test "$HaveLibGmp" = "YES" then AC_MSG_RESULT([no]) - UseIntreeGmp=0 AC_CHECK_HEADER([gmp.h], , [AC_MSG_ERROR([Cannot find gmp.h])]) - - AC_MSG_CHECKING([GMP version]) - AC_COMPUTE_INT(GhcGmpVerMj, __GNU_MP_VERSION, [#include <gmp.h>], - AC_MSG_ERROR([Unable to get value of __GNU_MP_VERSION])) - AC_COMPUTE_INT(GhcGmpVerMi, __GNU_MP_VERSION_MINOR, [#include <gmp.h>], - AC_MSG_ERROR([Unable to get value of __GNU_MP_VERSION_MINOR])) - AC_COMPUTE_INT(GhcGmpVerPl, __GNU_MP_VERSION_PATCHLEVEL, [#include <gmp.h>], - AC_MSG_ERROR([Unable to get value of __GNU_MP_VERSION_PATCHLEVEL])) - AC_MSG_RESULT([$GhcGmpVerMj.$GhcGmpVerMi.$GhcGmpVerPl]) - else AC_MSG_RESULT([yes]) - UseIntreeGmp=1 HaveSecurePowm=1 - - AC_MSG_CHECKING([GMP version]) - GhcGmpVerMj=6 - GhcGmpVerMi=1 - GhcGmpVerPl=2 - AC_MSG_RESULT([$GhcGmpVerMj.$GhcGmpVerMi.$GhcGmpVerPl]) fi GMP_INSTALL_INCLUDES="HsIntegerGmp.h ghc-gmp.h" @@ -231,10 +213,6 @@ AC_SUBST(GMP_INSTALL_INCLUDES) AC_SUBST(HaveLibGmp) AC_SUBST(HaveFrameworkGMP) AC_SUBST(HaveSecurePowm) -AC_SUBST(UseIntreeGmp) -AC_SUBST(GhcGmpVerMj) -AC_SUBST(GhcGmpVerMi) -AC_SUBST(GhcGmpVerPl) # Compute offsets/sizes used by jsbits/base.js if test "$host" = "javascript-ghcjs" ===================================== libraries/ghc-internal/include/HsIntegerGmp.h.in ===================================== @@ -1,14 +1,4 @@ #pragma once -/* Whether GMP is embedded into ghc-internal */ -#define GHC_GMP_INTREE @UseIntreeGmp@ - -/* The following values denote the GMP version used during GHC build-time */ -#define GHC_GMP_VERSION_MJ @GhcGmpVerMj@ -#define GHC_GMP_VERSION_MI @GhcGmpVerMi@ -#define GHC_GMP_VERSION_PL @GhcGmpVerPl@ -#define GHC_GMP_VERSION \ - (@GhcGmpVerMj@ * 10000 + @GhcGmpVerMi@ * 100 + @GhcGmpVerPl@) - /* Whether GMP supports mpz_powm_sec */ #define HAVE_SECURE_POWM @HaveSecurePowm@ ===================================== testsuite/tests/simplCore/should_compile/T18013.stderr ===================================== @@ -143,14 +143,14 @@ T18013.$wmapMaybeRule [InlPrag=NOINLINE] Unf=OtherCon []] T18013.$wmapMaybeRule = \ (@a) (@b) (@s) (ww :: s) (ww1 :: s -> a -> IO (Result s b)) -> + case ww of ww2 { __DEFAULT -> case ww1 of wild { __DEFAULT -> - case ww of wild1 { __DEFAULT -> T18013a.Rule @IO @(Maybe a) @(Maybe b) @s - wild1 + ww2 ((\ (s2 :: s) (a1 :: Maybe a) (s1 :: GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld) -> @@ -158,7 +158,7 @@ T18013.$wmapMaybeRule Nothing -> (# s1, T18013a.Result - @s @(Maybe b) wild1 (GHC.Internal.Maybe.Nothing @b) #); + @s @(Maybe b) ww2 (GHC.Internal.Maybe.Nothing @b) #); Just x -> case ((wild s2 x) `cast` <Co:4> :: IO (Result s b) ===================================== testsuite/tests/simplCore/should_compile/T26722.hs ===================================== @@ -0,0 +1,9 @@ +module T26722 where + +data T = MkT ![Int] + +g s True t = f s t t +g s False t = g s True t + +f True (MkT xs) t = f False (MkT xs) t +f False (MkT xs) _ = xs ===================================== testsuite/tests/simplCore/should_compile/T26722.stderr ===================================== @@ -0,0 +1 @@ + \ No newline at end of file ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -563,3 +563,6 @@ 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']) + +# T26722: there should be no reboxing in $wg +test('T26722', [grep_errmsg(r'SPEC')], compile, ['-O -dno-typeable-binds']) ===================================== utils/iserv/cbits/iservmain.c deleted ===================================== @@ -1,18 +0,0 @@ -#include <ghcversion.h> -# include <rts/PosixSource.h> -#include <Rts.h> - -#include <HsFFI.h> - -int main (int argc, char *argv[]) -{ - RtsConfig conf = defaultRtsConfig; - - // We never know what symbols GHC will look up in the future, so - // we must retain CAFs for running interpreted code. - conf.keep_cafs = 1; - - conf.rts_opts_enabled = RtsOptsAll; - extern StgClosure ZCMain_main_closure; - hs_main(argc, argv, &ZCMain_main_closure, conf); -} ===================================== utils/iserv/iserv.cabal.in ===================================== @@ -23,11 +23,17 @@ Category: Development build-type: Simple cabal-version: >=1.10 +Flag threaded + Description: Link the iserv executable against the threaded RTS + Default: True + Manual: True + Executable iserv Default-Language: Haskell2010 - ghc-options: -no-hs-main + ghc-options: -fkeep-cafs -rtsopts + if flag(threaded) + ghc-options: -threaded Main-Is: Main.hs - C-Sources: cbits/iservmain.c Hs-Source-Dirs: src include-dirs: . Build-Depends: View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ee290e4bfc327e60346f927f618cce… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ee290e4bfc327e60346f927f618cce… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/T24867
by Simon Peyton Jones (＠simonpj) 07 Jan '26

07 Jan '26

Simon Peyton Jones pushed new branch wip/T24867 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T24867 You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/T26679-part1
by Simon Peyton Jones (＠simonpj) 07 Jan '26

07 Jan '26

Simon Peyton Jones pushed new branch wip/T26679-part1 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T26679-part1 You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-try-opt-coercion] 2 commits: Fix expression-equality for (Coercion co)
by Simon Peyton Jones (＠simonpj) 07 Jan '26

07 Jan '26

Simon Peyton Jones pushed to branch wip/spj-try-opt-coercion at Glasgow Haskell Compiler / GHC Commits: f4eea9ba by Simon Peyton Jones at 2026-01-07T11:40:17+00:00 Fix expression-equality for (Coercion co) We were just saying "True" which is utterly wrong. See Note [Equality for coercions] in GHC.Core.Map.Type - - - - - 68e18fc9 by Simon Peyton Jones at 2026-01-07T11:41:27+00:00 Wibbles on coercion bindings - - - - - 9 changed files: - compiler/GHC/Core/Map/Expr.hs - compiler/GHC/Core/Map/Type.hs - compiler/GHC/Core/Opt/CSE.hs - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Data/TrieMap.hs - compiler/GHC/Iface/Make.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Types/Id.hs Changes: ===================================== compiler/GHC/Core/Map/Expr.hs ===================================== @@ -26,6 +26,7 @@ import GHC.Prelude import GHC.Data.TrieMap import GHC.Core.Map.Type import GHC.Core +import GHC.Core.Coercion( coercionRKind ) import GHC.Core.Type import GHC.Types.Tickish import GHC.Types.Var @@ -150,13 +151,16 @@ instance Eq (DeBruijn CoreExpr) where eqDeBruijnExpr :: DeBruijn CoreExpr -> DeBruijn CoreExpr -> Bool eqDeBruijnExpr (D env1 e1) (D env2 e2) = go e1 e2 where - go (Var v1) (Var v2) = eqDeBruijnVar (D env1 v1) (D env2 v2) - go (Lit lit1) (Lit lit2) = lit1 == lit2 - go (Type t1) (Type t2) = eqDeBruijnType (D env1 t1) (D env2 t2) - -- See Note [Alpha-equality for Coercion arguments] - go (Coercion {}) (Coercion {}) = True - go (Cast e1 co1) (Cast e2 co2) = D env1 co1 == D env2 co2 && go e1 e2 - go (App f1 a1) (App f2 a2) = go f1 f2 && go a1 a2 + go (Var v1) (Var v2) = eqDeBruijnVar (D env1 v1) (D env2 v2) + go (Lit lit1) (Lit lit2) = lit1 == lit2 + go (Type t1) (Type t2) = eqDeBruijnType (D env1 t1) (D env2 t2) + go (Coercion co1) (Coercion co2) = eqDeBruijnCoercion (D env1 co1) (D env2 co2) + go (Cast e1 co1) (Cast e2 co2) = go e1 e2 && eqDeBruijnType (D env1 (coercionRKind co1)) + (D env2 (coercionRKind co2)) + go (App f1 a1) (App f2 a2) + | isCoArg a1, isCoArg a2 = go f1 f2 + | otherwise = go f1 f2 && go a1 a2 + -- isCoArg: see Note [Coercions in expressions] go (Tick n1 e1) (Tick n2 e2) = eqDeBruijnTickish (D env1 n1) (D env2 n2) && go e1 e2 @@ -204,12 +208,17 @@ eqDeBruijnTickish (D env1 t1) (D env2 t2) = go t1 t2 where eqCoreExpr :: CoreExpr -> CoreExpr -> Bool eqCoreExpr e1 e2 = eqDeBruijnExpr (deBruijnize e1) (deBruijnize e2) -{- Note [Alpha-equality for Coercion arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The 'Coercion' constructor only appears in argument positions, and so, if the -functions are equal, then the arguments must have equal types. Because the -comparison for coercions (correctly) checks only their types, checking for -alpha-equality of the coercions is redundant. +{- Note [Coercions in expressions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When a coercion appears in an expression, we mainly use `eqDeBruijnCoercion` +(see Note [Equality for coercions] in GHC.Core.Map.Type). But we can optimise + * Applications: f1 (CO: co1) = f2 (CO: co2) + If the two functions are equal their argument coercions must have equal + types, so no need to compare the coercions at all. + + * Casts: e1 |> co1 = e2 |> co2 + If e1 and e2 are equal, the coercionLKinds of the coercions are equal; + so we only need to compare the coercionRKinds -} {- Note [Alpha-equality for let-bindings] ===================================== compiler/GHC/Core/Map/Type.hs ===================================== @@ -20,6 +20,7 @@ module GHC.Core.Map.Type ( TypeMapG, CoercionMapG, DeBruijn(..), deBruijnize, eqDeBruijnType, eqDeBruijnVar, + eqDeBruijnCoercion, BndrMap, xtBndr, lkBndr, VarMap, xtVar, lkVar, lkDFreeVar, xtDFreeVar, @@ -78,9 +79,14 @@ import Control.Monad ( (>=>) ) ************************************************************************ -} --- We should really never care about the contents of a coercion. Instead, --- just look up the coercion's type. +{- Note [Equality for coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A coercion is a proof, and any one proof is as good as any other. +So to compare coercions we just compare their types. +-} + newtype CoercionMap a = CoercionMap (CoercionMapG a) + -- See [Equality for coercions] -- TODO(22292): derive instance Functor CoercionMap where @@ -98,6 +104,9 @@ instance TrieMap CoercionMap where type CoercionMapG = GenMap CoercionMapX newtype CoercionMapX a = CoercionMapX (TypeMapX a) +-- CoercionMapX key point: two coercions are considered equal if +-- their coercionTypes are the same; so we just defer to TypeMap + -- TODO(22292): derive instance Functor CoercionMapX where @@ -113,11 +122,6 @@ instance TrieMap CoercionMapX where filterTM f (CoercionMapX core_tm) = CoercionMapX (filterTM f core_tm) mapMaybeTM f (CoercionMapX core_tm) = CoercionMapX (mapMaybeTM f core_tm) -instance Eq (DeBruijn Coercion) where - D env1 co1 == D env2 co2 - = D env1 (coercionType co1) == - D env2 (coercionType co2) - lkC :: DeBruijn Coercion -> CoercionMapX a -> Maybe a lkC (D env co) (CoercionMapX core_tm) = lkT (D env $ coercionType co) core_tm @@ -126,6 +130,16 @@ xtC :: DeBruijn Coercion -> XT a -> CoercionMapX a -> CoercionMapX a xtC (D env co) f (CoercionMapX m) = CoercionMapX (xtT (D env $ coercionType co) f m) +-- This equality instance is needed for the equality test in leaf compression; +-- see GenMap and Note [Compressed TrieMap] in GHC.Data.TrieMap +instance Eq (DeBruijn Coercion) where + (==) = eqDeBruijnCoercion + +eqDeBruijnCoercion :: DeBruijn Coercion -> DeBruijn Coercion -> Bool +eqDeBruijnCoercion (D env1 co1) (D env2 co2) + = eqDeBruijnType (D env1 (coercionType co1)) (D env2 (coercionType co2)) + + {- ************************************************************************ * * @@ -139,9 +153,7 @@ xtC (D env co) f (CoercionMapX m) -- but it is strictly internal to this module. If you are including a 'TypeMap' -- inside another 'TrieMap', this is the type you want. Note that this -- lookup does not do a kind-check. Thus, all keys in this map must have --- the same kind. Also note that this map respects the distinction between --- @Type@ and @Constraint@, despite the fact that they are equivalent type --- synonyms in Core. +-- the same kind. type TypeMapG = GenMap TypeMapX -- | @TypeMapX a@ is the base map from @DeBruijn Type@ to @a@, but without the @@ -191,9 +203,6 @@ instance TrieMap TypeMapX where filterTM = filterT mapMaybeTM = mpT -instance Eq (DeBruijn Type) where - (==) = eqDeBruijnType - -- | An equality relation between two 'Type's (known below as @t1 :: k2@ -- and @t2 :: k2@) data TypeEquality = TNEQ -- ^ @t1 /= t2@ @@ -219,7 +228,7 @@ eqDeBruijnType env_t1@(D env1 t1) env_t2@(D env2 t2) = liftEquality :: Bool -> TypeEquality liftEquality False = TNEQ - liftEquality _ = TEQ + liftEquality True = TEQ hasCast :: TypeEquality -> TypeEquality hasCast TEQ = TEQX @@ -272,7 +281,7 @@ eqDeBruijnType env_t1@(D env1 t1) env_t2@(D env2 t2) = go (D (extendCME env tv) ty) (D (extendCME env' tv') ty') (CoercionTy {}, CoercionTy {}) -> TEQ - _ -> TNEQ + _ -> TNEQ -- These bangs make 'gos' strict in the CMEnv, which in turn -- keeps the CMEnv unboxed across the go/gos mutual recursion @@ -282,9 +291,6 @@ eqDeBruijnType env_t1@(D env1 t1) env_t2@(D env2 t2) = gos e1 e2 tys1 tys2 gos _ _ _ _ = TNEQ -instance Eq (DeBruijn Var) where - (==) = eqDeBruijnVar - eqDeBruijnVar :: DeBruijn Var -> DeBruijn Var -> Bool eqDeBruijnVar (D env1 v1) (D env2 v2) = case (lookupCME env1 v1, lookupCME env2 v2) of @@ -292,6 +298,14 @@ eqDeBruijnVar (D env1 v1) (D env2 v2) = (Nothing, Nothing) -> v1 == v2 _ -> False +-- This equality instance is needed for the equality test in leaf compression; +-- see GenMap and Note [Compressed TrieMap] in GHC.Data.TrieMap +instance Eq (DeBruijn Type) where + (==) = eqDeBruijnType + +instance Eq (DeBruijn Var) where + (==) = eqDeBruijnVar + instance {-# OVERLAPPING #-} Outputable a => Outputable (TypeMapG a) where ppr m = text "TypeMap elts" <+> ppr (foldTM (:) m []) @@ -488,6 +502,7 @@ instance TrieMap LooseTypeMap where filterTM f (LooseTypeMap m) = LooseTypeMap (filterTM f m) mapMaybeTM f (LooseTypeMap m) = LooseTypeMap (mapMaybeTM f m) + {- ************************************************************************ * * ===================================== compiler/GHC/Core/Opt/CSE.hs ===================================== @@ -450,7 +450,7 @@ cse_bind toplevel env_rhs env_body (in_id, in_rhs) out_id | otherwise = (env_body', (out_id'', out_rhs)) where - (env_body', out_id') = extendCSEnvWithBinding env_body in_id out_id out_rhs cse_done + (env_body', out_id') = extendCSEnvWithBinding env_body in_id out_id out_rhs cse_done (cse_done, out_rhs) = try_for_cse env_rhs in_rhs out_id'' | cse_done = zapStableUnfolding $ delayInlining toplevel out_id' ===================================== compiler/GHC/Core/Opt/Simplify/Env.hs ===================================== @@ -422,11 +422,12 @@ data SimplFloats } instance Outputable SimplFloats where - ppr (SimplFloats { sfLetFloats = lf, sfJoinFloats = jf, sfInScope = is }) + ppr (SimplFloats { sfLetFloats = lf, sfJoinFloats = jf, sfInScope = _is }) = text "SimplFloats" <+> braces (vcat [ text "lets: " <+> ppr lf , text "joins:" <+> ppr jf - , text "in_scope:" <+> ppr is ]) +-- , text "in_scope:" <+> ppr _is + ]) emptyFloats :: SimplEnv -> SimplFloats emptyFloats env ===================================== compiler/GHC/Core/TyCo/Rep.hs ===================================== @@ -2098,8 +2098,9 @@ coercionIsSmall :: Coercion -> Bool -- This function is called inside `exprIsTrivial` so it needs to be -- pretty efficient. It should return False quickly on a big coercion; -- it should /not/ traverse the big coercion! +-- The literal constant 40# is pretty arbitrary coercionIsSmall co - = not (isTrue# ((coercion_is_small co 100#) <# 0#)) + = not (isTrue# ((coercion_is_small co 40#) <# 0#)) coercion_is_small :: Coercion -> Int# -> Int# coercion_is_small co n = go co n ===================================== compiler/GHC/Data/TrieMap.hs ===================================== @@ -359,7 +359,6 @@ mpList f (LM { lm_nil = mnil, lm_cons = mcons }) Note [Compressed TrieMap] ~~~~~~~~~~~~~~~~~~~~~~~~~ - The GenMap constructor augments TrieMaps with leaf compression. This helps solve the performance problem detailed in #9960: suppose we have a handful H of entries in a TrieMap, each with a very large key, size K. If you fold over ===================================== compiler/GHC/Iface/Make.hs ===================================== @@ -199,7 +199,11 @@ updateDecl decls m_stg_infos m_cmm_infos m_cmm_infos tag_sigs = fromMaybe mempty m_stg_infos - update_decl (IfaceId nm ty details infos) + update_decl decl@(IfaceId nm ty details infos) + | IfCoVarId <- details + = decl -- Coercions can appear at top level in interface files + -- but we generate no code for them and they have no LFInfo + | let not_caffy = elemNameSet nm non_cafs , let mb_lf_info = lookupNameEnv lf_infos nm , let sig = lookupNameEnv tag_sigs nm ===================================== compiler/GHC/IfaceToCore.hs ===================================== @@ -1698,12 +1698,21 @@ tcIfaceExpr (IfaceCase scrut case_bndr alts) = do return (Case scrut' case_bndr' (coreAltsType alts') alts') tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info ji) rhs) body) + | IfaceCo co <- rhs + = -- For CoVars we ignore `info` and `ji` + do { name <- newIfaceName (mkVarOccFS (ifLclNameFS fs)) + ; ty' <- tcIfaceType ty + ; let covar = mkLocalCoVar name ty' + ; co' <- tcIfaceCo co + ; body' <- extendIfaceIdEnv [covar] (tcIfaceExpr body) + ; return (Let (NonRec covar (Coercion co')) body') } + | otherwise = do { name <- newIfaceName (mkVarOccFS (ifLclNameFS fs)) ; ty' <- tcIfaceType ty ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -} NotTopLevel name ty' info ; let id = mkLocalIdWithInfo name ManyTy ty' id_info - `asJoinId_maybe` ji + `asJoinId_maybe` ji ; rhs' <- tcIfaceExpr rhs ; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body) ; return (Let (NonRec id rhs') body') } ===================================== compiler/GHC/Types/Id.hs ===================================== @@ -329,8 +329,8 @@ mkLocalIdOrCoVar name w ty | isCoVarType ty = mkLocalCoVar name ty | otherwise = mkLocalId name w ty - -- proper ids only; no covars! mkLocalIdWithInfo :: HasDebugCallStack => Name -> Mult -> Type -> IdInfo -> Id +-- Used for proper ids only; no covars! mkLocalIdWithInfo name w ty info = Var.mkLocalVar VanillaId name w (assert (not (isCoVarType ty)) ty) info -- Note [Free type variables] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/528c804fa394c2b7eb421078f95373… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/528c804fa394c2b7eb421078f95373… You're receiving this email because of your account on gitlab.haskell.org.

1 0