January 2026 - ghc-commits

[Git][ghc/ghc] Pushed new branch wip/fix-cross-windows
by Cheng Shao (＠TerrorJack) 05 Jan '26

05 Jan '26

Cheng Shao pushed new branch wip/fix-cross-windows at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/fix-cross-windows You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/deepseq-primop] 11 commits: hadrian: fix bootstrapping with ghc-9.14
by Cheng Shao (＠TerrorJack) 05 Jan '26

05 Jan '26

Cheng Shao pushed to branch wip/deepseq-primop at Glasgow Haskell Compiler / GHC Commits: c72ddabf by Cheng Shao at 2025-12-23T16:13:23-05:00 hadrian: fix bootstrapping with ghc-9.14 This patch fixes bootstrapping GHC with ghc-9.14, tested locally with ghc-9.14.1 release as bootstrapping GHC. - - - - - 0fd6d8e4 by Cheng Shao at 2025-12-23T16:14:05-05:00 hadrian: pass -keep-tmp-files to test ghc when --keep-test-files is enabled This patch makes hadrian pass `-keep-tmp-files` to test ghc when `--keep-test-files` is enabled, so you can check the ghc intermediate files when debugging certain test failures. Closes #26688. - - - - - 81d10134 by Cheng Shao at 2025-12-24T06:11:52-05:00 configure: remove dead code in configure scripts This patch removes dead code in our configure scripts, including: - Variables and auto-detected programs that are not used - autoconf functions that are not used, or export a variable that's not used - `AC_CHECK_HEADERS` invocations that don't have actual corresponding `HAVE_XXX_H` usage - Other dead code (e.g. stray `AC_DEFUN()`) Co-authored-by: Codex <codex(a)openai.com> - - - - - fb1381c3 by Wolfgang Jeltsch at 2025-12-24T06:12:34-05:00 Remove unused known keys and names for list operations This removes the known-key and corresponding name variables for `concat`, `filter`, `zip`, and `(++)`, as they are apparently nowhere used in GHC’s source code. - - - - - 7b9c20f4 by Recursion Ninja at 2025-12-24T10:35:36-05:00 Decoupling Language.Haskell.Syntax.Binds from GHC.Types.Basic by transferring InlinePragma types between the modules. * Moved InlinePragma data-types to Language.Haskell.Syntax.Binds.InlinePragma * Partitioned of Arity type synonyms to GHC.Types.Arity * InlinePragma is now extensible via Trees That Grow * Activation is now extensible via Trees That Grow * Maybe Arity change to more descriptive InlineSaturation data-type * InlineSaturation information removed from InlinePragma during GHS parsing pass * Cleaned up the exposed module interfaces of the new modules - - - - - a3afae0c by Simon Peyton Jones at 2025-12-25T15:26:36-05:00 Check for rubbish literals in Lint Addresses #26607. See new Note [Checking for rubbish literals] in GHC.Core.Lint - - - - - 8a317b6f by Aaron Allen at 2026-01-01T03:05:15-05:00 [#26183] Associated Type Iface Fix When determining "extras" for class decl interface entries, axioms for the associated types need to included so that dependent modules will be recompiled if those axioms change. resolves #26183 - - - - - ae1aeaab by Cheng Shao at 2026-01-01T03:06:32-05:00 testsuite: run numeric tests with optasm when available This patch adds the `optasm` extra way to nueric tests when NCG is available. Some numeric bugs only surface with optimization, omitting this can hide these bugs and even make them slip into release! (e.g. #26711) - - - - - 6213bb57 by maralorn at 2026-01-02T16:30:32+01:00 GHC.Internal.Exception.Context: Fix comment on addExceptionAnnotation - - - - - b820ff50 by Janis Voigtlaender at 2026-01-05T02:43:18-05:00 GHC.Internal.Control.Monad.replicateM: Fix comment - - - - - 1b418e7b by Cheng Shao at 2026-01-05T13:22:15+01:00 WIP - - - - - 105 changed files: - .gitlab/ci.sh - compiler/GHC/Builtin/Names.hs - compiler/GHC/Builtin/PrimOps/Ids.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Core.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/CSE.hs - compiler/GHC/Core/Opt/CprAnal.hs - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Core/Opt/Pipeline/Types.hs - compiler/GHC/Core/Opt/Simplify.hs - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Opt/WorkWrap.hs - compiler/GHC/Core/Ppr.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/Unfold/Make.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToIface.hs - compiler/GHC/Driver/Config/Core/Lint.hs - compiler/GHC/Driver/Config/Core/Lint/Interactive.hs - compiler/GHC/Driver/Config/Core/Opt/Simplify.hs - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/HsToCore.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Errors/Types.hs - compiler/GHC/HsToCore/Foreign/C.hs - compiler/GHC/HsToCore/Foreign/JavaScript.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Make.hs - compiler/GHC/Iface/Recomp.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Tidy.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Lexer.x - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Tc/Deriv/Generics.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/Arrow.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/Tc/Instance/Typeable.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/Utils/Instantiate.hs - compiler/GHC/ThToHs.hs - + compiler/GHC/Types/Arity.hs - compiler/GHC/Types/Basic.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Id.hs - compiler/GHC/Types/Id/Info.hs - compiler/GHC/Types/Id/Make.hs - + compiler/GHC/Types/InlinePragma.hs - compiler/GHC/Utils/Binary.hs - compiler/GHC/Utils/Outputable.hs - compiler/Language/Haskell/Syntax/Binds.hs - + compiler/Language/Haskell/Syntax/Binds/InlinePragma.hs - compiler/Language/Haskell/Syntax/Decls.hs - compiler/Language/Haskell/Syntax/Extension.hs - compiler/ghc.cabal.in - configure.ac - hadrian/cabal.project - hadrian/src/Settings/Builders/RunTest.hs - libraries/base/src/GHC/Base.hs - libraries/base/src/GHC/Exts.hs - libraries/ghc-experimental/ghc-experimental.cabal.in - + libraries/ghc-experimental/src/GHC/DeepSeq.hs - libraries/ghc-internal/configure.ac - libraries/ghc-internal/src/GHC/Internal/Control/Monad.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Context.hs - − m4/find_ghc_bootstrap_prog.m4 - − m4/fp_copy_shellvar.m4 - − m4/fp_prog_ld_flag.m4 - − m4/fp_prog_sort.m4 - m4/prep_target_file.m4 - + rts/DeepSeq.cmm - rts/RtsSymbols.c - rts/configure.ac - rts/include/stg/MiscClosures.h - rts/rts.cabal - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout - + testsuite/tests/driver/recomp26183/M.hs - + testsuite/tests/driver/recomp26183/M2A.hs - + testsuite/tests/driver/recomp26183/M2B.hs - + testsuite/tests/driver/recomp26183/Makefile - + testsuite/tests/driver/recomp26183/all.T - + testsuite/tests/driver/recomp26183/recomp26183.stderr - testsuite/tests/interface-stability/ghc-experimental-exports.stdout - testsuite/tests/interface-stability/ghc-prim-exports.stdout - testsuite/tests/numeric/should_run/all.T - + testsuite/tests/primops/should_run/DeepSeqPrimOp.hs - + testsuite/tests/primops/should_run/DeepSeqPrimOp.stdout - testsuite/tests/primops/should_run/all.T - utils/check-exact/ExactPrint.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ea5fe7e8a34d93db03eb3af1d4d838… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ea5fe7e8a34d93db03eb3af1d4d838… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-try-opt-coercion] More on exported coercions
by Simon Peyton Jones (＠simonpj) 05 Jan '26

05 Jan '26

Simon Peyton Jones pushed to branch wip/spj-try-opt-coercion at Glasgow Haskell Compiler / GHC Commits: 25b2a74c by Simon Peyton Jones at 2026-01-05T11:31:43+00:00 More on exported coercions - - - - - 5 changed files: - compiler/GHC/CoreToIface.hs - compiler/GHC/Iface/Rename.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Type.hs - compiler/GHC/IfaceToCore.hs Changes: ===================================== compiler/GHC/CoreToIface.hs ===================================== @@ -223,9 +223,6 @@ toIfaceTypeX fr (TyConApp tc tys) toIfaceTyVar :: TyVar -> IfLclName toIfaceTyVar = mkIfLclName . occNameFS . getOccName -toIfaceCoVar :: CoVar -> IfLclName -toIfaceCoVar = mkIfLclName . occNameFS . getOccName - ---------------- toIfaceTyCon :: TyCon -> IfaceTyCon toIfaceTyCon tc @@ -287,7 +284,11 @@ toIfaceCoercionX fr co go (CoVarCo cv) -- See Note [Free TyVars and CoVars in IfaceType] in GHC.Iface.Type | cv `elemVarSet` fr = IfaceFreeCoVar cv - | otherwise = IfaceCoVarCo (toIfaceCoVar cv) + | isExternalName nm = IfaceExtCoVar nm + | otherwise = IfaceCoVarCo (mkIfLclName $ occNameFS $ nameOccName nm) + where + nm = idName cv + go (HoleCo h) = IfaceHoleCo (coHoleCoVar h) go (AppCo co1 co2) = IfaceAppCo (go co1) (go co2) @@ -454,6 +455,7 @@ toIfaceTopBndr id toIfaceIdDetails :: IdDetails -> IfaceIdDetails toIfaceIdDetails VanillaId = IfVanillaId toIfaceIdDetails (WorkerLikeId dmds) = IfWorkerLikeId dmds +toIfaceIdDetails CoVarId = IfCoVarId toIfaceIdDetails (DFunId {}) = IfDFunId toIfaceIdDetails (RecSelId { sel_naughty = n , sel_tycon = tc ===================================== compiler/GHC/Iface/Rename.hs ===================================== @@ -886,13 +886,14 @@ rnIfaceMCo IfaceMRefl = pure IfaceMRefl rnIfaceMCo (IfaceMCo co) = IfaceMCo <$> rnIfaceCo co rnIfaceCo :: Rename IfaceCoercion +rnIfaceCo co@(IfaceExtCoVar {}) = pure co +rnIfaceCo co@(IfaceFreeCoVar {}) = pure co +rnIfaceCo co@(IfaceCoVarCo {}) = pure co rnIfaceCo (IfaceReflCo ty) = IfaceReflCo <$> rnIfaceType ty rnIfaceCo (IfaceGReflCo role ty mco) = IfaceGReflCo role <$> rnIfaceType ty <*> rnIfaceMCo mco rnIfaceCo (IfaceFunCo role w co1 co2) = IfaceFunCo role <$> rnIfaceCo w <*> rnIfaceCo co1 <*> rnIfaceCo co2 rnIfaceCo (IfaceTyConAppCo role tc cos) = IfaceTyConAppCo role <$> rnIfaceTyCon tc <*> mapM rnIfaceCo cos rnIfaceCo (IfaceAppCo co1 co2) = IfaceAppCo <$> rnIfaceCo co1 <*> rnIfaceCo co2 -rnIfaceCo (IfaceFreeCoVar c) = pure (IfaceFreeCoVar c) -rnIfaceCo (IfaceCoVarCo lcl) = IfaceCoVarCo <$> pure lcl rnIfaceCo (IfaceHoleCo lcl) = IfaceHoleCo <$> pure lcl rnIfaceCo (IfaceSymCo c) = IfaceSymCo <$> rnIfaceCo c rnIfaceCo (IfaceTransCo c1 c2) = IfaceTransCo <$> rnIfaceCo c1 <*> rnIfaceCo c2 ===================================== compiler/GHC/Iface/Syntax.hs ===================================== @@ -490,6 +490,7 @@ data IfGuidance data IfaceIdDetails = IfVanillaId + | IfCoVarId | IfWorkerLikeId [CbvMark] | IfRecSelId { ifRecSelIdParent :: Either IfaceTyCon IfaceDecl @@ -1877,6 +1878,7 @@ instance Outputable IfaceIdDetails where then text "<naughty>" else Outputable.empty ppr IfDFunId = text "DFunId" + ppr IfCoVarId = text "CoVarId" instance Outputable IfaceInfoItem where ppr (HsUnfold lb unf) = text "Unfolding" @@ -1994,6 +1996,7 @@ freeNamesIfIdDetails (IfRecSelId tc first_con _ fl) = freeNamesIfIdDetails IfVanillaId = emptyNameSet freeNamesIfIdDetails (IfWorkerLikeId {}) = emptyNameSet freeNamesIfIdDetails IfDFunId = emptyNameSet +freeNamesIfIdDetails IfCoVarId = emptyNameSet -- All other changes are handled via the version info on the tycon freeNamesIfFamFlav :: IfaceFamTyConFlav -> NameSet @@ -2086,6 +2089,7 @@ freeNamesIfCoercion (IfaceAppCo c1 c2) freeNamesIfCoercion (IfaceForAllCo _tcv _visL _visR kind_co co) = freeNamesIfMCoercion kind_co &&& freeNamesIfCoercion co freeNamesIfCoercion (IfaceFreeCoVar _) = emptyNameSet +freeNamesIfCoercion (IfaceExtCoVar n) = unitNameSet n freeNamesIfCoercion (IfaceCoVarCo _) = emptyNameSet freeNamesIfCoercion (IfaceHoleCo _) = emptyNameSet freeNamesIfCoercion (IfaceUnivCo _ _ t1 t2 cos) @@ -2718,6 +2722,7 @@ instance Binary IfaceIdDetails where ; put_ bh d } put_ bh (IfWorkerLikeId dmds) = putByte bh 2 >> put_ bh dmds put_ bh IfDFunId = putByte bh 3 + put_ bh IfCoVarId = putByte bh 4 get bh = do h <- getByte bh case h of @@ -2729,7 +2734,8 @@ instance Binary IfaceIdDetails where ; return (IfRecSelId a b c d) } 2 -> do { dmds <- get bh ; return (IfWorkerLikeId dmds) } - _ -> return IfDFunId + 3 -> return IfDFunId + _ -> return IfCoVarId instance Binary IfaceInfoItem where put_ bh (HsArity aa) = putByte bh 0 >> put_ bh aa @@ -3167,7 +3173,8 @@ instance NFData IfaceIdDetails where IfWorkerLikeId dmds -> rnf dmds `seq` () IfRecSelId (Left tycon) b c d -> rnf tycon `seq` rnf b `seq` rnf c `seq` rnf d IfRecSelId (Right decl) b c d -> rnf decl `seq` rnf b `seq` rnf c `seq` rnf d - IfDFunId -> () + IfDFunId -> () + IfCoVarId -> () instance NFData IfaceInfoItem where rnf = \case ===================================== compiler/GHC/Iface/Type.hs ===================================== @@ -475,13 +475,15 @@ data IfaceMCoercion | IfaceMCo IfaceCoercion deriving (Eq, Ord) data IfaceCoercion - = IfaceReflCo IfaceType + = IfaceFreeCoVar CoVar -- ^ See Note [Free TyVars and CoVars in IfaceType] + | IfaceExtCoVar IfExtName -- Imported or top-level external coercion var + | IfaceCoVarCo IfLclName -- Regular, locally-bound coercion var + | IfaceReflCo IfaceType | IfaceGReflCo Role IfaceType (IfaceMCoercion) | IfaceFunCo Role IfaceCoercion IfaceCoercion IfaceCoercion | IfaceTyConAppCo Role IfaceTyCon [IfaceCoercion] | IfaceAppCo IfaceCoercion IfaceCoercion | IfaceForAllCo IfaceBndr !ForAllTyFlag !ForAllTyFlag IfaceMCoercion IfaceCoercion - | IfaceCoVarCo IfLclName | IfaceAxiomCo IfaceAxiomRule [IfaceCoercion] -- ^ There are only a fixed number of CoAxiomRules, so it suffices -- to use an IfaceLclName to distinguish them. @@ -494,7 +496,6 @@ data IfaceCoercion | IfaceInstCo IfaceCoercion IfaceCoercion | IfaceKindCo IfaceCoercion | IfaceSubCo IfaceCoercion - | IfaceFreeCoVar CoVar -- ^ See Note [Free TyVars and CoVars in IfaceType] | IfaceHoleCo CoVar -- ^ See Note [Holes in IfaceCoercion] deriving (Eq, Ord) -- Why Ord? See Note [Ord instance of IfaceType] @@ -779,9 +780,10 @@ substIfaceType env ty go_co (IfaceTyConAppCo r tc cos) = IfaceTyConAppCo r tc (go_cos cos) go_co (IfaceAppCo c1 c2) = IfaceAppCo (go_co c1) (go_co c2) go_co (IfaceForAllCo {}) = pprPanic "substIfaceCoercion" (ppr ty) - go_co (IfaceFreeCoVar cv) = IfaceFreeCoVar cv - go_co (IfaceCoVarCo cv) = IfaceCoVarCo cv - go_co (IfaceHoleCo cv) = IfaceHoleCo cv + go_co co@(IfaceFreeCoVar {}) = co + go_co co@(IfaceExtCoVar {}) = co + go_co co@(IfaceCoVarCo {}) = co + go_co co@(IfaceHoleCo {}) = co go_co (IfaceUnivCo p r t1 t2 ds) = IfaceUnivCo p r (go t1) (go t2) (go_cos ds) go_co (IfaceSymCo co) = IfaceSymCo (go_co co) go_co (IfaceTransCo co1 co2) = IfaceTransCo (go_co co1) (go_co co2) @@ -2076,8 +2078,9 @@ ppr_co ctxt_prec co@(IfaceForAllCo {}) = let (tvs, co'') = split_co co' in ((bndr,kind_co,visL,visR):tvs,co'') split_co co' = ([], co') --- Why these three? See Note [Free TyVars and CoVars in IfaceType] +-- Why these four? See Note [Free TyVars and CoVars in IfaceType] ppr_co _ (IfaceFreeCoVar covar) = ppr covar +ppr_co _ (IfaceExtCoVar covar) = ppr covar ppr_co _ (IfaceCoVarCo covar) = ppr covar ppr_co _ (IfaceHoleCo covar) = braces (ppr covar) @@ -2457,6 +2460,9 @@ instance Binary IfaceCoercion where put_ bh (IfaceCoVarCo a) = do putByte bh 7 put_ bh a + put_ bh (IfaceExtCoVar a) = do + putByte bh 8 + put_ bh a put_ bh (IfaceUnivCo a b c d deps) = do putByte bh 9 put_ bh a @@ -2530,6 +2536,8 @@ instance Binary IfaceCoercion where return $ IfaceForAllCo a visL visR b c 7 -> do a <- get bh return $ IfaceCoVarCo a + 8 -> do a <- get bh + return $ IfaceExtCoVar a 9 -> do a <- get bh b <- get bh c <- get bh @@ -2605,13 +2613,14 @@ instance NFData IfaceTyLit where instance NFData IfaceCoercion where rnf = \case + IfaceExtCoVar f1 -> rnf f1 + IfaceCoVarCo f1 -> rnf f1 IfaceReflCo f1 -> rnf f1 IfaceGReflCo f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3 IfaceFunCo f1 f2 f3 f4 -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 IfaceTyConAppCo f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3 IfaceAppCo f1 f2 -> rnf f1 `seq` rnf f2 IfaceForAllCo f1 f2 f3 f4 f5 -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 - IfaceCoVarCo f1 -> rnf f1 IfaceAxiomCo f1 f2 -> rnf f1 `seq` rnf f2 IfaceUnivCo f1 f2 f3 f4 deps -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf deps IfaceSymCo f1 -> rnf f1 ===================================== compiler/GHC/IfaceToCore.hs ===================================== @@ -1582,41 +1582,35 @@ tcIfaceCo = go go_mco IfaceMRefl = pure MRefl go_mco (IfaceMCo co) = MCo <$> (go co) + go (IfaceExtCoVar n) = CoVarCo <$> tcIfaceExtId n + go (IfaceCoVarCo n) = CoVarCo <$> tcIfaceLclId n go (IfaceReflCo t) = Refl <$> tcIfaceType t go (IfaceGReflCo r t mco) = GRefl r <$> tcIfaceType t <*> go_mco mco go (IfaceFunCo r w c1 c2) = mkFunCoNoFTF r <$> go w <*> go c1 <*> go c2 go (IfaceTyConAppCo r tc cs) = TyConAppCo r <$> tcIfaceTyCon tc <*> mapM go cs go (IfaceAppCo c1 c2) = AppCo <$> go c1 <*> go c2 + go (IfaceSymCo c) = SymCo <$> go c + go (IfaceTransCo c1 c2) = TransCo <$> go c1 <*> go c2 + go (IfaceInstCo c1 t2) = InstCo <$> go c1 <*> go t2 + go (IfaceSelCo d c) = mkSelCo d <$> go c + go (IfaceLRCo lr c) = LRCo lr <$> go c + go (IfaceKindCo c) = KindCo <$> go c + go (IfaceSubCo c) = SubCo <$> go c go (IfaceForAllCo tcv visL visR k co) = do { k' <- go_mco k ; bindIfaceBndr tcv $ \ tv' -> do { co' <- go co ; return (ForAllCo { fco_tcv = tv', fco_visL = visL, fco_visR = visR , fco_kind = k', fco_body = co' }) } } - go (IfaceCoVarCo n) = CoVarCo <$> go_var n go (IfaceUnivCo p r t1 t2 ds) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2 ; ds' <- mapM go ds ; return (UnivCo { uco_prov = p, uco_role = r , uco_lty = t1', uco_rty = t2' , uco_deps = ds' }) } - go (IfaceSymCo c) = SymCo <$> go c - go (IfaceTransCo c1 c2) = TransCo <$> go c1 - <*> go c2 - go (IfaceInstCo c1 t2) = InstCo <$> go c1 - <*> go t2 - go (IfaceSelCo d c) = do { c' <- go c - ; return $ mkSelCo d c' } - go (IfaceLRCo lr c) = LRCo lr <$> go c - go (IfaceKindCo c) = KindCo <$> go c - go (IfaceSubCo c) = SubCo <$> go c - go (IfaceAxiomCo ax cos) = AxiomCo <$> tcIfaceAxiomRule ax - <*> mapM go cos + go (IfaceAxiomCo ax cos) = AxiomCo <$> tcIfaceAxiomRule ax <*> mapM go cos go (IfaceFreeCoVar c) = pprPanic "tcIfaceCo:IfaceFreeCoVar" (ppr c) go (IfaceHoleCo c) = pprPanic "tcIfaceCo:IfaceHoleCo" (ppr c) - go_var :: IfLclName -> IfL CoVar - go_var = tcIfaceLclId - {- ************************************************************************ * * @@ -1801,6 +1795,7 @@ tcIfaceDataAlt mult con inst_tys arg_strs rhs tcIdDetails :: Name -> Type -> IfaceIdDetails -> IfL IdDetails tcIdDetails _ _ IfVanillaId = return VanillaId +tcIdDetails _ _ IfCoVarId = return CoVarId tcIdDetails _ _ (IfWorkerLikeId dmds) = return $ WorkerLikeId dmds tcIdDetails _ ty IfDFunId = return (DFunId (isUnaryClass cls)) where View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/25b2a74c138f0a02431bcd64f211e5e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/25b2a74c138f0a02431bcd64f211e5e… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fix-clang64-split-sections] 5 commits: GHC.Internal.Exception.Context: Fix comment
by Cheng Shao (＠TerrorJack) 05 Jan '26

05 Jan '26

Cheng Shao pushed to branch wip/fix-clang64-split-sections at Glasgow Haskell Compiler / GHC Commits: 6213bb57 by maralorn at 2026-01-02T16:30:32+01:00 GHC.Internal.Exception.Context: Fix comment on addExceptionAnnotation - - - - - b820ff50 by Janis Voigtlaender at 2026-01-05T02:43:18-05:00 GHC.Internal.Control.Monad.replicateM: Fix comment - - - - - f9bda57b by Cheng Shao at 2026-01-05T09:25:50+01:00 compiler: change sectionProtection to take SectionType argument This commit changes `sectionProtection` to only take `SectionType` argument instead of whole `Section`, since it doesn't need the Cmm section content anyway, and it can then be called in parts of NCG where we only have a `SectionType` in scope. - - - - - 9f426e30 by Cheng Shao at 2026-01-05T10:33:30+01:00 compiler: change isInitOrFiniSection to take SectionType argument This commit changes `isInitOrFiniSection` to only take `SectionType` argument instead of whole `Section`, since it doesn't need the Cmm section content anyway, and it can then be called in parts of NCG where we only have a `SectionType` in scope. Also marks it as exported. - - - - - 043299ef by Cheng Shao at 2026-01-05T10:42:34+01:00 compiler: fix split sections on windows This patch fixes split sections on windows by emitting the right COMDAT section header in NCG, see added comment for more explanation. Fix #26696 #26494. Co-authored-by: Codex <codex(a)openai.com> - - - - - 8 changed files: - compiler/GHC/Cmm.hs - compiler/GHC/Cmm/InitFini.hs - compiler/GHC/CmmToAsm/Ppr.hs - compiler/GHC/CmmToAsm/Wasm/FromCmm.hs - compiler/GHC/CmmToC.hs - compiler/GHC/CmmToLlvm/Data.hs - libraries/ghc-internal/src/GHC/Internal/Control/Monad.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Context.hs Changes: ===================================== compiler/GHC/Cmm.hs ===================================== @@ -278,8 +278,8 @@ data SectionProtection deriving (Eq) -- | Should a data in this section be considered constant at runtime -sectionProtection :: Section -> SectionProtection -sectionProtection (Section t _) = case t of +sectionProtection :: SectionType -> SectionProtection +sectionProtection t = case t of Text -> ReadOnlySection ReadOnlyData -> ReadOnlySection RelocatableReadOnlyData -> WriteProtectedSection ===================================== compiler/GHC/Cmm/InitFini.hs ===================================== @@ -2,6 +2,7 @@ module GHC.Cmm.InitFini ( InitOrFini(..) , isInitOrFiniArray + , isInitOrFiniSection ) where import GHC.Prelude @@ -63,8 +64,8 @@ finalizer CmmDecl will be emitted per module. data InitOrFini = IsInitArray | IsFiniArray isInitOrFiniArray :: RawCmmDecl -> Maybe (InitOrFini, [CLabel]) -isInitOrFiniArray (CmmData sect (CmmStaticsRaw _ lits)) - | Just initOrFini <- isInitOrFiniSection sect +isInitOrFiniArray (CmmData (Section t _) (CmmStaticsRaw _ lits)) + | Just initOrFini <- isInitOrFiniSection t = Just (initOrFini, map get_label lits) where get_label :: CmmStatic -> CLabel @@ -72,7 +73,7 @@ isInitOrFiniArray (CmmData sect (CmmStaticsRaw _ lits)) get_label static = pprPanic "isInitOrFiniArray: invalid entry" (ppr static) isInitOrFiniArray _ = Nothing -isInitOrFiniSection :: Section -> Maybe InitOrFini -isInitOrFiniSection (Section InitArray _) = Just IsInitArray -isInitOrFiniSection (Section FiniArray _) = Just IsFiniArray +isInitOrFiniSection :: SectionType -> Maybe InitOrFini +isInitOrFiniSection InitArray = Just IsInitArray +isInitOrFiniSection FiniArray = Just IsFiniArray isInitOrFiniSection _ = Nothing ===================================== compiler/GHC/CmmToAsm/Ppr.hs ===================================== @@ -1,4 +1,5 @@ {-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiWayIf #-} ----------------------------------------------------------------------------- -- @@ -23,6 +24,7 @@ import GHC.Prelude import GHC.Utils.Asm import GHC.Cmm.CLabel +import GHC.Cmm.InitFini import GHC.Cmm import GHC.CmmToAsm.Config import GHC.Utils.Outputable as SDoc @@ -240,21 +242,45 @@ pprGNUSectionHeader config t suffix = | OSMinGW32 <- platformOS platform -> text ".rdata" | otherwise -> text ".ipe" - flags = case t of - Text - | OSMinGW32 <- platformOS platform, splitSections - -> text ",\"xr\"" - | splitSections - -> text ",\"ax\"," <> sectionType platform "progbits" - CString - | OSMinGW32 <- platformOS platform - -> empty - | otherwise -> text ",\"aMS\"," <> sectionType platform "progbits" <> text ",1" - IPE - | OSMinGW32 <- platformOS platform - -> empty - | otherwise -> text ",\"a\"," <> sectionType platform "progbits" - _ -> empty + flags + -- See + -- https://github.com/llvm/llvm-project/blob/llvmorg-21.1.8/lld/COFF/Chunks.cp… + -- and https://llvm.org/docs/Extensions.html#section-directive. + -- LLD COFF backend gc-sections only work on COMDAT sections so + -- we need to mark it as a COMDAT section. You can use clang64 + -- toolchain to compile small examples with + -- `-ffunction-sections -fdata-sections -S` to see these section + -- headers in the wild. + | OSMinGW32 <- platformOS platform, + splitSections = + if + | Just _ <- isInitOrFiniSection t -> text ",\"dw\"" + | otherwise -> + let coff_section_flags + | Text <- t = "xr" + | UninitialisedData <- t = "bw" + | ReadWriteSection <- sectionProtection t = "dw" + | otherwise = "dr" + in hcat + [ text ",\"", + text coff_section_flags, + text "\",one_only,", + pprAsmLabel platform suffix + ] + | otherwise = + case t of + Text + | splitSections + -> text ",\"ax\"," <> sectionType platform "progbits" + CString + | OSMinGW32 <- platformOS platform + -> empty + | otherwise -> text ",\"aMS\"," <> sectionType platform "progbits" <> text ",1" + IPE + | OSMinGW32 <- platformOS platform + -> empty + | otherwise -> text ",\"a\"," <> sectionType platform "progbits" + _ -> empty {-# SPECIALIZE pprGNUSectionHeader :: NCGConfig -> SectionType -> CLabel -> SDoc #-} {-# SPECIALIZE pprGNUSectionHeader :: NCGConfig -> SectionType -> CLabel -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable ===================================== compiler/GHC/CmmToAsm/Wasm/FromCmm.hs ===================================== @@ -107,7 +107,7 @@ symKindFromCLabel lbl -- | Calculate a data section's kind, see haddock docs of -- 'DataSectionKind' for more explanation. dataSectionKindFromCmmSection :: Section -> DataSectionKind -dataSectionKindFromCmmSection s = case sectionProtection s of +dataSectionKindFromCmmSection (Section t _) = case sectionProtection t of ReadWriteSection -> SectionData _ -> SectionROData ===================================== compiler/GHC/CmmToC.hs ===================================== @@ -121,7 +121,7 @@ pprTop platform = \case pprDataExterns platform lits $$ pprWordArray platform (isSecConstant section) lbl lits where - isSecConstant section = case sectionProtection section of + isSecConstant (Section t _) = case sectionProtection t of ReadOnlySection -> True WriteProtectedSection -> True _ -> False ===================================== compiler/GHC/CmmToLlvm/Data.hs ===================================== @@ -75,7 +75,7 @@ genLlvmData (sect, statics) IsFiniArray -> fsLit "llvm.global_dtors" in genGlobalLabelArray var clbls -genLlvmData (sec, CmmStaticsRaw lbl xs) = do +genLlvmData (sec@(Section t _), CmmStaticsRaw lbl xs) = do label <- strCLabel_llvm lbl static <- mapM genData xs lmsec <- llvmSection sec @@ -92,7 +92,7 @@ genLlvmData (sec, CmmStaticsRaw lbl xs) = do then Just 2 else Just 1 Section Data _ -> Just $ platformWordSizeInBytes platform _ -> Nothing - const = if sectionProtection sec == ReadOnlySection + const = if sectionProtection t == ReadOnlySection then Constant else Global varDef = LMGlobalVar label tyAlias link lmsec align const globDef = LMGlobal varDef struct ===================================== libraries/ghc-internal/src/GHC/Internal/Control/Monad.hs ===================================== @@ -314,7 +314,7 @@ Core: https://gitlab.haskell.org/ghc/ghc/issues/11795#note_118976 -- | @'replicateM' n act@ performs the action @act@ @n@ times, -- and then returns the list of results. -- --- @replicateM n (pure x) == 'replicate' n x@ +-- @replicateM n (pure x) == pure ('replicate' n x)@ -- -- ==== __Examples__ -- ===================================== libraries/ghc-internal/src/GHC/Internal/Exception/Context.hs ===================================== @@ -64,7 +64,7 @@ instance Monoid ExceptionContext where emptyExceptionContext :: ExceptionContext emptyExceptionContext = ExceptionContext [] --- | Construct a singleton 'ExceptionContext' from an 'ExceptionAnnotation'. +-- | Add an 'ExceptionAnnotation' to a given 'ExceptionContext'. -- -- @since base-4.20.0.0 addExceptionAnnotation :: ExceptionAnnotation a => a -> ExceptionContext -> ExceptionContext View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dc022bcb1aba9a5d67adaca8f0af24… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dc022bcb1aba9a5d67adaca8f0af24… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-try-opt-coercion] Add a type signature
by Simon Peyton Jones (＠simonpj) 05 Jan '26

05 Jan '26

Simon Peyton Jones pushed to branch wip/spj-try-opt-coercion at Glasgow Haskell Compiler / GHC Commits: cd277d10 by Simon Peyton Jones at 2026-01-05T09:36:53+00:00 Add a type signature - - - - - 1 changed file: - compiler/GHC/Core/FVs.hs Changes: ===================================== compiler/GHC/Core/FVs.hs ===================================== @@ -647,6 +647,7 @@ idUnfoldingFVs id = stableUnfoldingFVs (realIdUnfolding id) `orElse` emptyFV stableUnfoldingVars :: Unfolding -> Maybe VarSet stableUnfoldingVars unf = fvVarSet `fmap` stableUnfoldingFVs unf +stableUnfoldingFVs :: Unfolding -> Maybe FV stableUnfoldingFVs unf | isStableUnfolding unf = Just (unfoldingFVs unf) | otherwise = Nothing View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cd277d10a8723332d38165a04d48669… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cd277d10a8723332d38165a04d48669… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] GHC.Internal.Control.Monad.replicateM: Fix comment
by Marge Bot (＠marge-bot) 05 Jan '26

05 Jan '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: b820ff50 by Janis Voigtlaender at 2026-01-05T02:43:18-05:00 GHC.Internal.Control.Monad.replicateM: Fix comment - - - - - 1 changed file: - libraries/ghc-internal/src/GHC/Internal/Control/Monad.hs Changes: ===================================== libraries/ghc-internal/src/GHC/Internal/Control/Monad.hs ===================================== @@ -314,7 +314,7 @@ Core: https://gitlab.haskell.org/ghc/ghc/issues/11795#note_118976 -- | @'replicateM' n act@ performs the action @act@ @n@ times, -- and then returns the list of results. -- --- @replicateM n (pure x) == 'replicate' n x@ +-- @replicateM n (pure x) == pure ('replicate' n x)@ -- -- ==== __Examples__ -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b820ff50459fc48bce6db3af652c2e5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b820ff50459fc48bce6db3af652c2e5… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] GHC.Internal.Exception.Context: Fix comment
by Marge Bot (＠marge-bot) 05 Jan '26

05 Jan '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 6213bb57 by maralorn at 2026-01-02T16:30:32+01:00 GHC.Internal.Exception.Context: Fix comment on addExceptionAnnotation - - - - - 1 changed file: - libraries/ghc-internal/src/GHC/Internal/Exception/Context.hs Changes: ===================================== libraries/ghc-internal/src/GHC/Internal/Exception/Context.hs ===================================== @@ -64,7 +64,7 @@ instance Monoid ExceptionContext where emptyExceptionContext :: ExceptionContext emptyExceptionContext = ExceptionContext [] --- | Construct a singleton 'ExceptionContext' from an 'ExceptionAnnotation'. +-- | Add an 'ExceptionAnnotation' to a given 'ExceptionContext'. -- -- @since base-4.20.0.0 addExceptionAnnotation :: ExceptionAnnotation a => a -> ExceptionContext -> ExceptionContext View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6213bb576d90f9725a7a3fddf47b299… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6213bb576d90f9725a7a3fddf47b299… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Deleted branch wip/windows-no-split-sections
by Cheng Shao (＠TerrorJack) 05 Jan '26

05 Jan '26

Cheng Shao deleted branch wip/windows-no-split-sections at Glasgow Haskell Compiler / GHC -- You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/fix-clang64-split-sections
by Cheng Shao (＠TerrorJack) 05 Jan '26

05 Jan '26

Cheng Shao pushed new branch wip/fix-clang64-split-sections at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/fix-clang64-split-sections 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: Wibbles
by Simon Peyton Jones (＠simonpj) 04 Jan '26

04 Jan '26

Simon Peyton Jones pushed to branch wip/spj-try-opt-coercion at Glasgow Haskell Compiler / GHC Commits: c72a1a15 by Simon Peyton Jones at 2026-01-02T17:37:33+00:00 Wibbles - - - - - bea0ee5a by Simon Peyton Jones at 2026-01-04T23:46:18+00:00 Progress on not-inlining coercions - - - - - 12 changed files: - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/FVs.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToStg.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Driver/Config/Core/Lint.hs - compiler/GHC/Iface/Tidy.hs Changes: ===================================== compiler/GHC/Core/Coercion.hs ===================================== @@ -172,7 +172,6 @@ import qualified Data.Monoid as Monoid import Data.List.NonEmpty ( NonEmpty (..) ) import Control.DeepSeq -import GHC.Exts {- %************************************************************************ @@ -2473,40 +2472,6 @@ seqCos :: [Coercion] -> () seqCos [] = () seqCos (co:cos) = seqCo co `seq` seqCos cos -coercionIsSmall :: Coercion -> Bool --- This function should return False quickly on a big coercion --- It should /not/ traverse the big coercion! -coercionIsSmall co - = not (isTrue# ((go co 100#) <# 0#)) - where - go :: Coercion -> Int# -> Int# - go _co n | isTrue# (n <# 0#) = n - go (Refl {}) n = dec n - go (GRefl _ _ mco) n = go_mco mco (dec n) - go (TyConAppCo _ _ cos) n = go_cos cos (dec n) - go (AxiomCo _ cos) n = go_cos cos (dec n) - go (UnivCo _ _ _ _ cos) n = go_cos cos (dec n) - go (AppCo co1 co2) n = go co1 (go co2 (dec n)) - go (CoVarCo {}) n = dec n - go (HoleCo {}) n = dec n - go (SymCo co) n = go co (dec n) - go (KindCo co) n = go co (dec n) - go (SubCo co) n = go co (dec n) - go (TransCo co1 co2) n = go co1 (go co2 (dec n)) - go (SelCo _ co) n = go co (dec n) - go (LRCo _ co) n = go co (dec n) - go (InstCo co1 co2) n = go co1 (go co2 (dec n)) - go (ForAllCo _ _ _ kco co) n = go co (go_mco kco (dec n)) - go (FunCo _ _ _ mco aco rco) n = go mco (go aco (go rco (dec n))) - - go_cos [] n = n - go_cos (co:cos) n = go_cos cos (go co n) - - go_mco MRefl n = dec n - go_mco (MCo co) n = go co n - - dec n = n -# 1# - {- %************************************************************************ %* * ===================================== compiler/GHC/Core/FVs.hs ===================================== @@ -29,12 +29,14 @@ module GHC.Core.FVs ( idUnfoldingVars, idFreeVars, dIdFreeVars, bndrRuleAndUnfoldingVarsDSet, bndrRuleAndUnfoldingIds, - idFVs, - idRuleVars, stableUnfoldingVars, + idFVs, idRuleVars, + stableUnfoldingVars, + unfoldingFVs, ruleFreeVars, rulesFreeVars, rulesFreeVarsDSet, mkRuleInfo, ruleLhsFreeIds, ruleLhsFreeIdsList, ruleRhsFreeVars, rulesRhsFreeIds, + rulesFVs, RuleFVsFrom(..), exprFVs, exprLocalFVs, addBndrFV, addBndrsFV, @@ -645,17 +647,18 @@ idUnfoldingFVs id = stableUnfoldingFVs (realIdUnfolding id) `orElse` emptyFV stableUnfoldingVars :: Unfolding -> Maybe VarSet stableUnfoldingVars unf = fvVarSet `fmap` stableUnfoldingFVs unf -stableUnfoldingFVs :: Unfolding -> Maybe FV stableUnfoldingFVs unf - = case unf of - CoreUnfolding { uf_tmpl = rhs, uf_src = src } - | isStableSource src - -> Just (exprLocalFVs rhs) - DFunUnfolding { df_bndrs = bndrs, df_args = args } - -> Just (filterFV isLocalVar $ FV.delFVs (mkVarSet bndrs) $ exprsFVs args) - -- DFuns are top level, so no fvs from types of bndrs - _other -> Nothing - + | isStableUnfolding unf = Just (unfoldingFVs unf) + | otherwise = Nothing + +unfoldingFVs :: Unfolding -> FV +unfoldingFVs (CoreUnfolding { uf_tmpl = rhs }) + = exprLocalFVs rhs +unfoldingFVs (DFunUnfolding { df_bndrs = bndrs, df_args = args }) + = FV.delFVs (mkVarSet bndrs) $ exprsLocalFVs args + -- DFuns are top level, so no fvs from types of bndrs +unfoldingFVs _ + = emptyFV {- ************************************************************************ ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -82,7 +82,6 @@ import GHC.Types.Basic import GHC.Types.Demand ( splitDmdSig, isDeadEndDiv ) import GHC.Builtin.Names -import GHC.Builtin.Types.Prim import GHC.Data.Bag import GHC.Data.List.SetOps @@ -589,19 +588,20 @@ lintLetBind top_lvl rec_flag binder rhs rhs_ty -- Check the let-can-float invariant -- See Note [Core let-can-float invariant] in GHC.Core - ; checkL ( isJoinId binder - || mightBeLiftedType binder_ty - || (isNonRec rec_flag && exprOkForSpeculation rhs) - || isDataConWorkId binder || isDataConWrapId binder -- until #17521 is fixed - || exprIsTickedString rhs) - (badBndrTyMsg binder (text "unlifted")) - - -- Check that if the binder is at the top level and has type Addr#, - -- that it is a string literal. + ; checkL ( isTopLevel top_lvl + || isJoinId binder + || mightBeLiftedType binder_ty + || (isNonRec rec_flag && exprOkForSpeculation rhs)) $ + badBndrTyMsg binder (text "unlifted") + + -- Check that if the binder is at the top level the binding + -- satisfies exprIsTopLevelBindable -- See Note [Core top-level string literals]. - ; checkL (not (isTopLevel top_lvl && binder_ty `eqType` addrPrimTy) - || exprIsTickedString rhs) - (mkTopNonLitStrMsg binder) + ; checkL ( not (isTopLevel top_lvl) + || exprIsTopLevelBindable rhs binder_ty + || isDataConWorkId binder || isDataConWrapId binder -- until #17521 is fixed + ) $ + mkTopNonLitStrMsg binder ; flags <- getLintFlags @@ -942,7 +942,7 @@ lintCoreExpr (Let (NonRec tv (Type ty)) body) | isTyVar tv = -- See Note [Linting type lets] do { ty' <- lintTypeAndSubst ty - ; lintTyCoBndr tv $ \ tv' -> + ; lintTyVarBndr tv $ \ tv' -> do { addLoc (RhsOf tv) $ lintTyKind tv' ty' -- Now extend the substitution so we -- take advantage of it in the body @@ -1796,24 +1796,24 @@ lintBinders site (var:vars) linterF = lintBinder site var $ \var' -> -- See Note [GHC Formalism] lintBinder :: HasDebugCallStack => BindingSite -> InVar -> (OutVar -> LintM a) -> LintM a lintBinder site var linterF - | isTyCoVar var = lintTyCoBndr var linterF - | otherwise = lintIdBndr NotTopLevel site var linterF + | isTyVar var = lintTyVarBndr var linterF + | otherwise = lintIdBndr NotTopLevel site var linterF -lintTyCoBndr :: HasDebugCallStack => TyCoVar -> (OutTyCoVar -> LintM a) -> LintM a -lintTyCoBndr tcv thing_inside +lintTyCoBndr :: HasDebugCallStack => InTyCoVar + -> (OutTyCoVar -> LintM a) -> LintM a +lintTyCoBndr var linterF + | isTyVar var = lintTyVarBndr var linterF + | otherwise = lintIdBndr NotTopLevel LambdaBind var linterF + +lintTyVarBndr :: HasDebugCallStack => InTyVar -> (OutTyVar -> LintM a) -> LintM a +lintTyVarBndr tcv thing_inside = do { tcv_type' <- lintTypeAndSubst (varType tcv) ; let tcv_kind' = typeKind tcv_type' - -- See (FORALL1) and (FORALL2) in GHC.Core.Type - ; if (isTyVar tcv) - then -- Check that in (forall (a:ki). blah) we have ki:Type - lintL (isLiftedTypeKind tcv_kind') $ + -- See (FORALL1) in GHC.Core.Type + ; lintL (isLiftedTypeKind tcv_kind') $ hang (text "TyVar whose kind does not have kind Type:") 2 (ppr tcv <+> dcolon <+> ppr tcv_type' <+> dcolon <+> ppr tcv_kind') - else -- Check that in (forall (cv::ty). blah), - -- then ty looks like (t1 ~# t2) - lintL (isCoVarType tcv_type') $ - text "CoVar with non-coercion type:" <+> pprTyVar tcv ; addInScopeTyCoVar tcv tcv_type' thing_inside } @@ -1858,19 +1858,21 @@ lintIdBndr top_lvl bind_site id thing_inside checkL (not is_top_lvl && is_let_bind) $ mkBadJoinBindMsg id - -- Check that the Id does not have type (t1 ~# t2) or (t1 ~R# t2); - -- if so, it should be a CoVar, and checked by lintCoVarBndr - ; lintL (not (isCoVarType id_ty)) - (text "Non-CoVar has coercion type" <+> ppr id <+> dcolon <+> ppr id_ty) + -- Check that the Id is a CoVar <=> has type (t1 ~# t2) or (t1 ~R# t2); + ; lintL (isCoVar id == isCoVarType id_ty) $ + hang (text "CoVar with non-coercion type or vice versa:") + 2 (ppr id <+> dcolon <+> ppr id_ty) -- Check that the lambda binder has no value or OtherCon unfolding. -- See #21496 ; lintL (not (bind_site == LambdaBind && isEvaldUnfolding (idUnfolding id))) - (text "Lambda binder with value or OtherCon unfolding.") + (text "Lambda binder with value or OtherCon unfolding.") ; out_ty <- addLoc (IdTy id) (lintValueType id_ty) - ; addInScopeId id out_ty thing_inside } + ; if isCoVar id + then addInScopeTyCoVar id out_ty thing_inside + else addInScopeId id out_ty thing_inside } where id_ty = idType id ===================================== compiler/GHC/Core/Opt/Simplify/Env.hs ===================================== @@ -934,6 +934,8 @@ addJoinFlts = appOL mkRecFloats :: SimplFloats -> SimplFloats -- Flattens the floats into a single Rec group, -- They must either all be lifted LetFloats or all JoinFloats +-- +-- ToDo: explain about CoVar floats mkRecFloats floats@(SimplFloats { sfLetFloats = LetFloats bs _ff , sfJoinFloats = jbs , sfInScope = in_scope }) @@ -944,9 +946,24 @@ mkRecFloats floats@(SimplFloats { sfLetFloats = LetFloats bs _ff where -- See Note [Bangs in the Simplifier] !floats' | isNilOL bs = emptyLetFloats - | otherwise = unitLetFloat (Rec (flattenBinds (fromOL bs))) + | otherwise = LetFloats (flatten_rec bs) FltLifted !jfloats' | isNilOL jbs = emptyJoinFloats - | otherwise = unitJoinFloat (Rec (flattenBinds (fromOL jbs))) + | otherwise = flatten_rec jbs + + flatten_rec :: OrdList OutBind -> OrdList OutBind + -- Put CoVar bindings first (guaranteed non-recursive) + -- then one recursive value binding + flatten_rec bs = let !(covar_bs, prs) = foldrOL do_one (nilOL, []) bs + in covar_bs `snocOL` Rec prs + + do_one :: OutBind -> (OrdList OutBind,[(OutId,OutExpr)]) + -> (OrdList OutBind,[(OutId,OutExpr)]) + do_one bind (cvbs, prs) + = case bind of + NonRec bndr rhs + | isCoVar bndr -> (bind `consOL` cvbs, prs) + | otherwise -> (cvbs, (bndr,rhs):prs) + Rec prs1 -> (cvbs, prs1 ++ prs) wrapFloats :: SimplFloats -> OutExpr -> OutExpr -- Wrap the floats around the expression ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -298,6 +298,7 @@ simplRecOrTopPair env bind_cxt old_bndr new_bndr rhs (old_bndr,env) (new_bndr,env) (rhs,env) simplTrace :: String -> SDoc -> SimplM a -> SimplM a +-- Spit out a trace with `-dverbose-core2core` simplTrace herald doc thing_inside = do logger <- getLogger if logHasDumpFlag logger Opt_D_verbose_core2core @@ -762,18 +763,15 @@ prepareRhs :: HasDebugCallStack -- See Note [prepareRhs] prepareRhs env top_lvl occ rhs0 | is_expandable = do { (flts,rhs) <- anfise rhs0 - ; pprTrace "prepareRhs" (ppr rhs0 $$ text "new" <+> ppr rhs) $ - return (flts, rhs) } + ; return (flts, rhs) } | otherwise = return (emptyLetFloats, rhs0) where - -- We can't use exprIsExpandable because the WHOLE POINT is that - -- we want to treat (K <big>) as expandable, because we are just - -- about "anfise" the <big> expression. exprIsExpandable would - -- just say no! + -- We can't use exprIsExpandable because the WHOLE POINT is that we want to + -- treat (K <big>) as expandable, because we are just about "anfise" the + -- <big> expression. exprIsExpandable would just say no! is_expandable = go rhs0 0 where - go (Var fun) n_val_args = pprTrace "is_exp" (ppr fun <+> ppr n_val_args $$ ppr (isExpandableApp fun n_val_args)) $ - isExpandableApp fun n_val_args + go (Var fun) n_val_args = isExpandableApp fun n_val_args go (App fun arg) n_val_args | isTypeArg arg = go fun n_val_args | otherwise = go fun (n_val_args + 1) ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -2251,9 +2251,12 @@ new binding is abstracted. Several points worth noting abstractFloats :: UnfoldingOpts -> TopLevelFlag -> [OutTyVar] -> SimplFloats -> OutExpr -> SimplM ([OutBind], OutExpr) abstractFloats uf_opts top_lvl main_tvs floats body - = assert (notNull body_floats) $ + | assert (notNull body_floats) $ assert (isNilOL (sfJoinFloats floats)) $ - do { let sccs = concatMap to_sccs body_floats + any isCoVar (bindersOfBinds body_floats) -- ToDo: Explain this case + = return ([], wrapFloats floats body) + | otherwise + = do { let sccs = concatMap to_sccs body_floats ; (subst, float_binds) <- mapAccumLM abstract empty_subst sccs ; return (float_binds, GHC.Core.Subst.substExpr subst body) } where ===================================== compiler/GHC/Core/TyCo/Rep.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE MagicHash #-} {-# OPTIONS_HADDOCK not-home #-} {- @@ -63,7 +64,7 @@ module GHC.Core.TyCo.Rep ( TyCoFolder(..), foldTyCo, noView, -- * Sizes - typeSize, typesSize, coercionSize, + typeSize, typesSize, coercionSize, coercionIsSmall, -- * Multiplicities Scaled(..), scaledMult, scaledThing, mapScaledType, Mult @@ -96,8 +97,8 @@ import GHC.Utils.Panic import GHC.Utils.Binary -- libraries +import GHC.Exts import qualified Data.Data as Data hiding ( TyCon ) -import Data.Coerce import Data.IORef ( IORef ) -- for CoercionHole import Control.DeepSeq @@ -2093,6 +2094,61 @@ mCoercionSize :: MCoercion -> Int mCoercionSize MRefl = 0 mCoercionSize (MCo co) = coercionSize co +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! +coercionIsSmall co + = not (isTrue# ((coercion_is_small co 100#) <# 0#)) + +coercion_is_small :: Coercion -> Int# -> Int# +coercion_is_small co n = go co n + where + go :: Coercion -> Int# -> Int# + go _co n | isTrue# (n <# 0#) = n + go (Refl ty) n = type_is_small ty n + go (GRefl _ ty mco) n = type_is_small ty $ go_mco mco n + go (TyConAppCo _ _ cos) n = go_cos cos $ dec n + go (AxiomCo _ cos) n = go_cos cos $ dec n + go (UnivCo _ _ _ _ cos) n = go_cos cos $ dec n + go (AppCo co1 co2) n = go co1 $ go co2 $ dec n + go (CoVarCo {}) n = dec n + go (HoleCo {}) n = dec n + go (SymCo co) n = go co $ dec n + go (KindCo co) n = go co $ dec n + go (SubCo co) n = go co $ dec n + go (TransCo co1 co2) n = go co1 $ go co2 $ dec n + go (SelCo _ co) n = go co $ dec n + go (LRCo _ co) n = go co $ dec n + go (InstCo co1 co2) n = go co1 $ go co2 $ dec n + go (ForAllCo _ _ _ kco co) n = go co $ go_mco kco $ dec n + go (FunCo _ _ _ mco aco rco) n = go mco $ go aco $ go rco $ dec n + + go_cos [] n = n + go_cos (co:cos) n = go_cos cos (go co n) + + go_mco MRefl n = dec n + go_mco (MCo co) n = go co n + +type_is_small :: Type -> Int# -> Int# +type_is_small ty n = go ty n + where + go _ty n | isTrue# (n <# 0#) = n + go (TyVarTy {}) n = dec n + go (LitTy {}) n = dec n + go (AppTy t1 t2) n = go t1 $ go t2 $ dec n + go (TyConApp _ tys) n = go_tys tys $ dec n + go (ForAllTy _ ty) n = go ty $ dec n + go (FunTy _ m a r) n = go m $ go a $ go r $ dec n + go (CastTy ty co) n = go ty $ coercion_is_small co $ dec n + go (CoercionTy co) n = coercion_is_small co n + + go_tys [] n = n + go_tys (ty:tys) n = go ty $ go_tys tys n + +dec :: Int# -> Int# +dec n = n -# 1# + {- ************************************************************************ * * ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -31,7 +31,7 @@ module GHC.Core.Utils ( exprIsWorkFree, exprIsConLike, isCheapApp, isExpandableApp, isSaturatedConApp, exprIsTickedString, exprIsTickedString_maybe, - exprIsTopLevelBindable, + exprIsCoercion, exprIsTopLevelBindable, exprIsUnaryClassFun, isUnaryClassId, altsAreExhaustive, etaExpansionTick, @@ -1331,8 +1331,7 @@ exprIsTrivial e = trivial_expr_fold (const True) -- Literals (const True) -- Types coercionIsSmall -- Coercions - (\ r co -> pprTrace "exprIsTrivial" (ppr (coercionIsSmall co) $$ ppr co) $ - r && coercionIsSmall co) -- Casts + (\ r co -> r && coercionIsSmall co) -- Casts False e {- ===================================== compiler/GHC/CoreToStg.hs ===================================== @@ -599,8 +599,10 @@ getStgArgFromTrivialArg :: HasDebugCallStack => CoreArg -> StgArg -- `case unsafeequalityProof of UnsafeRefl -> e` might intervene. -- Good thing we can just call `trivial_expr_fold` here. getStgArgFromTrivialArg e = trivial_expr_fold StgVarArg StgLitArg - panic panic panic panic e + panic panic get_cast panic e where + get_cast r _ = r + panic :: forall a. a panic = pprPanic "getStgArgFromTrivialArg" (ppr e) ===================================== compiler/GHC/CoreToStg/Prep.hs ===================================== @@ -2169,6 +2169,7 @@ data FloatInfoArgs , fia_is_hnf :: Bool , fia_is_triv :: Bool , fia_is_string :: Bool + , fia_is_coercion :: Bool , fia_is_dc_worker :: Bool , fia_ok_for_spec :: Bool } @@ -2181,14 +2182,17 @@ defFloatInfoArgs bndr rhs , fia_is_hnf = exprIsHNF rhs , fia_is_triv = exprIsTrivial rhs , fia_is_string = exprIsTickedString rhs + , fia_is_coercion = exprIsCoercion rhs , fia_is_dc_worker = isJust (isDataConId_maybe bndr) -- mkCaseFloat uses False , fia_ok_for_spec = False -- mkNonRecFloat uses exprOkForSpecEval } decideFloatInfo :: FloatInfoArgs -> (BindInfo, FloatInfo) decideFloatInfo FIA{fia_levity=lev, fia_demand=dmd, fia_is_hnf=is_hnf, - fia_is_triv=is_triv, fia_is_string=is_string, + fia_is_triv=is_triv, fia_is_string=is_string, fia_is_coercion = is_coercion, fia_is_dc_worker=is_dc_worker, fia_ok_for_spec=ok_for_spec} + -- NB: this function should line up with exprIsTopLevelBindable + -- ToDo: explain a bit more | Lifted <- lev, is_hnf, not is_triv = (LetBound, TopLvlFloatable) -- is_lifted: We currently don't allow unlifted values at the -- top-level or inside letrecs @@ -2199,8 +2203,9 @@ decideFloatInfo FIA{fia_levity=lev, fia_demand=dmd, fia_is_hnf=is_hnf, -- We need this special case for nullary unlifted DataCon -- workers/wrappers (top-level bindings) until #17521 is fixed | is_string = (CaseBound, TopLvlFloatable) + | is_coercion = (LetBound, TopLvlFloatable) -- String literals are unboxed (so must be case-bound) and float to - -- the top-level + -- the top-level. Coercion are ok at top level too. | ok_for_spec = (CaseBound, case lev of Unlifted -> LazyContextFloatable Lifted -> TopLvlFloatable) -- See Note [Speculative evaluation] ===================================== compiler/GHC/Driver/Config/Core/Lint.hs ===================================== @@ -149,10 +149,12 @@ perPassFlags dflags pass _ -> AllowAnywhere -- See Note [Linting linearity] - check_linearity = gopt Opt_DoLinearCoreLinting dflags || ( - case pass of + check_linearity = gopt Opt_DoLinearCoreLinting dflags + -- `-dlinear-core-lint`: check linearity in every pass + || -- Always check linearity just after desugaring + case pass of CoreDesugar -> True - _ -> False) + _ -> False -- See Note [Checking for rubbish literals] in GHC.Core.Lint check_rubbish = case pass of ===================================== compiler/GHC/Iface/Tidy.hs ===================================== @@ -58,6 +58,7 @@ import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) import GHC.Iface.Tidy.StaticPtrTable import GHC.Iface.Env +import GHC.Utils.FV import GHC.Utils.Outputable import GHC.Utils.Misc( filterOut ) import GHC.Utils.Panic @@ -89,7 +90,6 @@ import GHC.Unit.Module.Deps import GHC.Data.Maybe -import Control.Monad import Data.Function import Data.List ( sortBy, mapAccumL ) import qualified Data.Set as S @@ -826,71 +826,7 @@ See Note [Choosing external Ids] -} bndrFvsInOrder :: Bool -> Id -> [Id] -bndrFvsInOrder show_unfold id - = run (dffvLetBndr show_unfold id) - -run :: DFFV () -> [Id] -run (DFFV m) = case m emptyVarSet (emptyVarSet, []) of - ((_,ids),_) -> ids - -newtype DFFV a - = DFFV (VarSet -- Envt: non-top-level things that are in scope - -- we don't want to record these as free vars - -> (VarSet, [Var]) -- Input State: (set, list) of free vars so far - -> ((VarSet,[Var]),a)) -- Output state - deriving (Functor) - -instance Applicative DFFV where - pure a = DFFV $ \_ st -> (st, a) - (<*>) = ap - -instance Monad DFFV where - (DFFV m) >>= k = DFFV $ \env st -> - case m env st of - (st',a) -> case k a of - DFFV f -> f env st' - -extendScope :: Var -> DFFV a -> DFFV a -extendScope v (DFFV f) = DFFV (\env st -> f (extendVarSet env v) st) - -extendScopeList :: [Var] -> DFFV a -> DFFV a -extendScopeList vs (DFFV f) = DFFV (\env st -> f (extendVarSetList env vs) st) - -insert :: Var -> DFFV () -insert v = DFFV $ \ env (set, ids) -> - let keep_me = isLocalId v && - not (v `elemVarSet` env) && - not (v `elemVarSet` set) - in if keep_me - then ((extendVarSet set v, v:ids), ()) - else ((set, ids), ()) - - -dffvExpr :: CoreExpr -> DFFV () -dffvExpr (Var v) = insert v -dffvExpr (App e1 e2) = dffvExpr e1 >> dffvExpr e2 -dffvExpr (Lam v e) = extendScope v (dffvExpr e) -dffvExpr (Tick (Breakpoint _ _ ids) e) = mapM_ insert ids >> dffvExpr e -dffvExpr (Tick _other e) = dffvExpr e -dffvExpr (Cast e _) = dffvExpr e -dffvExpr (Let (NonRec x r) e) = dffvBind (x,r) >> extendScope x (dffvExpr e) -dffvExpr (Let (Rec prs) e) = extendScopeList (map fst prs) $ - (mapM_ dffvBind prs >> dffvExpr e) -dffvExpr (Case e b _ as) = dffvExpr e >> extendScope b (mapM_ dffvAlt as) -dffvExpr _other = return () - -dffvAlt :: CoreAlt -> DFFV () -dffvAlt (Alt _ xs r) = extendScopeList xs (dffvExpr r) - -dffvBind :: (Id, CoreExpr) -> DFFV () -dffvBind(x,r) - | not (isId x) = dffvExpr r - | otherwise = dffvLetBndr False x >> dffvExpr r - -- Pass False because we are doing the RHS right here - -- If you say True you'll get *exponential* behaviour! - -dffvLetBndr :: Bool -> Id -> DFFV () --- Gather the free vars of the RULES and unfolding of a binder +-- Gather the free vars of the type, RULES and unfolding of an Id bindeb -- We always get the free vars of a *stable* unfolding, but -- for a *vanilla* one (VanillaSrc), the flag controls what happens: -- True <=> get fvs of even a *vanilla* unfolding @@ -899,24 +835,21 @@ dffvLetBndr :: Bool -> Id -> DFFV () -- we are taking the fvs of the RHS anyway -- For top-level bindings (call from addExternal, via bndrFvsInOrder) -- we say "True" if we are exposing that unfolding -dffvLetBndr vanilla_unfold id - = do { go_unf (realUnfoldingInfo idinfo) - ; mapM_ go_rule (ruleInfoRules (ruleInfo idinfo)) } +bndrFvsInOrder show_unfold id + = fvVarList $ + filterFV isId $ -- Include CoVars, which can be top-level bound + tyCoFVsOfType (idType id) `unionFV` + unf_fvs `unionFV` + rules_fvs where idinfo = idInfo id - go_unf (CoreUnfolding { uf_tmpl = rhs, uf_src = src }) - | isStableSource src = dffvExpr rhs - | vanilla_unfold = dffvExpr rhs - | otherwise = return () - - go_unf (DFunUnfolding { df_bndrs = bndrs, df_args = args }) - = extendScopeList bndrs $ mapM_ dffvExpr args - go_unf _ = return () + unf_fvs :: FV + unf_fvs | show_unfold = unfoldingFVs (realUnfoldingInfo idinfo) + | otherwise = emptyFV - go_rule (BuiltinRule {}) = return () - go_rule (Rule { ru_bndrs = bndrs, ru_rhs = rhs }) - = extendScopeList bndrs (dffvExpr rhs) + rules_fvs :: FV + rules_fvs = rulesFVs RhsOnly (ruleInfoRules (ruleInfo idinfo)) {- ************************************************************************ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/760fe6e02a2b9be0ef0b23d73a9b9f… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/760fe6e02a2b9be0ef0b23d73a9b9f… You're receiving this email because of your account on gitlab.haskell.org.

1 0